diff options
736 files changed, 29206 insertions, 12255 deletions
@@ -44,10 +44,12 @@ parsing/ast_helper.cmo : parsing/parsetree.cmi parsing/longident.cmi \ parsing/ast_helper.cmx : parsing/parsetree.cmi parsing/longident.cmx \ parsing/location.cmx parsing/asttypes.cmi parsing/ast_helper.cmi parsing/ast_mapper.cmo : parsing/parsetree.cmi utils/misc.cmi \ - parsing/location.cmi utils/config.cmi parsing/ast_helper.cmi \ + parsing/longident.cmi parsing/location.cmi utils/config.cmi \ + utils/clflags.cmi parsing/asttypes.cmi parsing/ast_helper.cmi \ parsing/ast_mapper.cmi parsing/ast_mapper.cmx : parsing/parsetree.cmi utils/misc.cmx \ - parsing/location.cmx utils/config.cmx parsing/ast_helper.cmx \ + parsing/longident.cmx parsing/location.cmx utils/config.cmx \ + utils/clflags.cmx parsing/asttypes.cmi parsing/ast_helper.cmx \ parsing/ast_mapper.cmi parsing/lexer.cmo : utils/warnings.cmi parsing/parser.cmi utils/misc.cmi \ parsing/location.cmi parsing/lexer.cmi @@ -90,8 +92,7 @@ typing/cmt_format.cmi : typing/types.cmi typing/typedtree.cmi \ parsing/location.cmi typing/env.cmi typing/cmi_format.cmi typing/ctype.cmi : typing/types.cmi typing/path.cmi parsing/longident.cmi \ typing/ident.cmi typing/env.cmi parsing/asttypes.cmi -typing/datarepr.cmi : typing/types.cmi typing/path.cmi typing/ident.cmi \ - parsing/asttypes.cmi +typing/datarepr.cmi : typing/types.cmi typing/path.cmi typing/ident.cmi typing/env.cmi : utils/warnings.cmi typing/types.cmi typing/subst.cmi \ typing/path.cmi parsing/longident.cmi parsing/location.cmi \ typing/ident.cmi utils/consistbl.cmi parsing/asttypes.cmi @@ -134,23 +135,23 @@ typing/typedtree.cmi : typing/types.cmi typing/primitive.cmi typing/path.cmi \ typing/ident.cmi typing/env.cmi parsing/asttypes.cmi typing/typedtreeIter.cmi : typing/typedtree.cmi parsing/asttypes.cmi typing/typedtreeMap.cmi : typing/typedtree.cmi -typing/typemod.cmi : typing/types.cmi typing/typedtree.cmi \ +typing/typemod.cmi : typing/types.cmi typing/typedtree.cmi typing/path.cmi \ parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \ - typing/includemod.cmi typing/ident.cmi typing/env.cmi + typing/includemod.cmi typing/ident.cmi typing/env.cmi \ + parsing/asttypes.cmi typing/types.cmi : typing/primitive.cmi typing/path.cmi \ parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \ typing/ident.cmi parsing/asttypes.cmi -typing/typetexp.cmi : utils/warnings.cmi typing/types.cmi \ - typing/typedtree.cmi typing/path.cmi parsing/parsetree.cmi \ - parsing/longident.cmi parsing/location.cmi typing/env.cmi \ - parsing/asttypes.cmi +typing/typetexp.cmi : typing/types.cmi typing/typedtree.cmi typing/path.cmi \ + parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \ + typing/env.cmi parsing/asttypes.cmi parsing/ast_mapper.cmi typing/btype.cmo : typing/types.cmi typing/path.cmi utils/misc.cmi \ typing/ident.cmi typing/btype.cmi typing/btype.cmx : typing/types.cmx typing/path.cmx utils/misc.cmx \ typing/ident.cmx typing/btype.cmi -typing/cmi_format.cmo : typing/types.cmi utils/misc.cmi parsing/location.cmi \ +typing/cmi_format.cmo : typing/types.cmi parsing/location.cmi \ utils/config.cmi typing/cmi_format.cmi -typing/cmi_format.cmx : typing/types.cmx utils/misc.cmx parsing/location.cmx \ +typing/cmi_format.cmx : typing/types.cmx parsing/location.cmx \ utils/config.cmx typing/cmi_format.cmi typing/cmt_format.cmo : typing/types.cmi typing/typedtreeMap.cmi \ typing/typedtree.cmi utils/misc.cmi parsing/location.cmi \ @@ -168,12 +169,12 @@ typing/ctype.cmx : typing/types.cmx typing/subst.cmx typing/path.cmx \ utils/misc.cmx parsing/longident.cmx parsing/location.cmx \ typing/ident.cmx typing/env.cmx utils/clflags.cmx typing/btype.cmx \ parsing/asttypes.cmi typing/ctype.cmi -typing/datarepr.cmo : typing/types.cmi typing/predef.cmi typing/path.cmi \ - parsing/location.cmi typing/ident.cmi typing/btype.cmi \ - parsing/asttypes.cmi typing/datarepr.cmi -typing/datarepr.cmx : typing/types.cmx typing/predef.cmx typing/path.cmx \ - parsing/location.cmx typing/ident.cmx typing/btype.cmx \ - parsing/asttypes.cmi typing/datarepr.cmi +typing/datarepr.cmo : typing/types.cmi typing/path.cmi parsing/location.cmi \ + typing/ident.cmi typing/btype.cmi parsing/asttypes.cmi \ + typing/datarepr.cmi +typing/datarepr.cmx : typing/types.cmx typing/path.cmx parsing/location.cmx \ + typing/ident.cmx typing/btype.cmx parsing/asttypes.cmi \ + typing/datarepr.cmi typing/env.cmo : utils/warnings.cmi typing/types.cmi utils/tbl.cmi \ typing/subst.cmi typing/predef.cmi typing/path.cmi utils/misc.cmi \ parsing/longident.cmi parsing/location.cmi typing/ident.cmi \ @@ -187,11 +188,11 @@ typing/env.cmx : utils/warnings.cmx typing/types.cmx utils/tbl.cmx \ typing/cmi_format.cmx utils/clflags.cmx typing/btype.cmx \ parsing/asttypes.cmi typing/env.cmi typing/envaux.cmo : typing/types.cmi typing/subst.cmi typing/printtyp.cmi \ - typing/path.cmi typing/mtype.cmi utils/misc.cmi typing/ident.cmi \ - typing/env.cmi parsing/asttypes.cmi typing/envaux.cmi + typing/path.cmi utils/misc.cmi typing/ident.cmi typing/env.cmi \ + parsing/asttypes.cmi typing/envaux.cmi typing/envaux.cmx : typing/types.cmx typing/subst.cmx typing/printtyp.cmx \ - typing/path.cmx typing/mtype.cmx utils/misc.cmx typing/ident.cmx \ - typing/env.cmx parsing/asttypes.cmi typing/envaux.cmi + typing/path.cmx utils/misc.cmx typing/ident.cmx typing/env.cmx \ + parsing/asttypes.cmi typing/envaux.cmi typing/ident.cmo : typing/ident.cmi typing/ident.cmx : typing/ident.cmi typing/includeclass.cmo : typing/types.cmi typing/printtyp.cmi \ @@ -207,15 +208,17 @@ typing/includecore.cmx : typing/types.cmx typing/typedtree.cmx \ typing/env.cmx typing/ctype.cmx typing/btype.cmx parsing/asttypes.cmi \ typing/includecore.cmi typing/includemod.cmo : typing/types.cmi typing/typedtree.cmi utils/tbl.cmi \ - typing/subst.cmi typing/printtyp.cmi typing/path.cmi typing/mtype.cmi \ - utils/misc.cmi parsing/location.cmi typing/includecore.cmi \ - typing/includeclass.cmi typing/ident.cmi typing/env.cmi typing/ctype.cmi \ - typing/cmt_format.cmi utils/clflags.cmi typing/includemod.cmi + typing/subst.cmi typing/printtyp.cmi typing/primitive.cmi typing/path.cmi \ + typing/mtype.cmi utils/misc.cmi parsing/location.cmi \ + typing/includecore.cmi typing/includeclass.cmi typing/ident.cmi \ + typing/env.cmi typing/ctype.cmi typing/cmt_format.cmi utils/clflags.cmi \ + typing/includemod.cmi typing/includemod.cmx : typing/types.cmx typing/typedtree.cmx utils/tbl.cmx \ - typing/subst.cmx typing/printtyp.cmx typing/path.cmx typing/mtype.cmx \ - utils/misc.cmx parsing/location.cmx typing/includecore.cmx \ - typing/includeclass.cmx typing/ident.cmx typing/env.cmx typing/ctype.cmx \ - typing/cmt_format.cmx utils/clflags.cmx typing/includemod.cmi + typing/subst.cmx typing/printtyp.cmx typing/primitive.cmx typing/path.cmx \ + typing/mtype.cmx utils/misc.cmx parsing/location.cmx \ + typing/includecore.cmx typing/includeclass.cmx typing/ident.cmx \ + typing/env.cmx typing/ctype.cmx typing/cmt_format.cmx utils/clflags.cmx \ + typing/includemod.cmi typing/mtype.cmo : typing/types.cmi typing/subst.cmi typing/path.cmi \ utils/misc.cmi parsing/location.cmi typing/ident.cmi typing/env.cmi \ typing/ctype.cmi utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi \ @@ -231,15 +234,15 @@ typing/oprint.cmx : typing/outcometree.cmi parsing/asttypes.cmi \ typing/parmatch.cmo : utils/warnings.cmi typing/types.cmi \ typing/typedtree.cmi typing/subst.cmi typing/predef.cmi typing/path.cmi \ parsing/parsetree.cmi utils/misc.cmi parsing/longident.cmi \ - parsing/location.cmi typing/ident.cmi typing/env.cmi typing/datarepr.cmi \ - typing/ctype.cmi typing/btype.cmi parsing/asttypes.cmi \ - parsing/ast_helper.cmi typing/parmatch.cmi + parsing/location.cmi typing/ident.cmi typing/env.cmi typing/ctype.cmi \ + typing/btype.cmi parsing/asttypes.cmi parsing/ast_helper.cmi \ + typing/parmatch.cmi typing/parmatch.cmx : utils/warnings.cmx typing/types.cmx \ typing/typedtree.cmx typing/subst.cmx typing/predef.cmx typing/path.cmx \ parsing/parsetree.cmi utils/misc.cmx parsing/longident.cmx \ - parsing/location.cmx typing/ident.cmx typing/env.cmx typing/datarepr.cmx \ - typing/ctype.cmx typing/btype.cmx parsing/asttypes.cmi \ - parsing/ast_helper.cmx typing/parmatch.cmi + parsing/location.cmx typing/ident.cmx typing/env.cmx typing/ctype.cmx \ + typing/btype.cmx parsing/asttypes.cmi parsing/ast_helper.cmx \ + typing/parmatch.cmi typing/path.cmo : typing/ident.cmi typing/path.cmi typing/path.cmx : typing/ident.cmx typing/path.cmi typing/predef.cmo : typing/types.cmi typing/path.cmi parsing/location.cmi \ @@ -278,8 +281,8 @@ typing/subst.cmx : typing/types.cmx utils/tbl.cmx typing/path.cmx \ typing/btype.cmx parsing/ast_mapper.cmx typing/subst.cmi typing/typeclass.cmo : utils/warnings.cmi typing/typetexp.cmi \ typing/types.cmi typing/typedtree.cmi typing/typedecl.cmi \ - typing/typecore.cmi typing/subst.cmi typing/stypes.cmi \ - typing/printtyp.cmi typing/predef.cmi typing/path.cmi \ + typing/typecore.cmi parsing/syntaxerr.cmi typing/subst.cmi \ + typing/stypes.cmi typing/printtyp.cmi typing/predef.cmi typing/path.cmi \ parsing/parsetree.cmi typing/parmatch.cmi utils/misc.cmi \ parsing/longident.cmi parsing/location.cmi typing/includeclass.cmi \ typing/ident.cmi typing/env.cmi typing/ctype.cmi typing/cmt_format.cmi \ @@ -287,43 +290,43 @@ typing/typeclass.cmo : utils/warnings.cmi typing/typetexp.cmi \ parsing/ast_helper.cmi typing/typeclass.cmi typing/typeclass.cmx : utils/warnings.cmx typing/typetexp.cmx \ typing/types.cmx typing/typedtree.cmx typing/typedecl.cmx \ - typing/typecore.cmx typing/subst.cmx typing/stypes.cmx \ - typing/printtyp.cmx typing/predef.cmx typing/path.cmx \ + typing/typecore.cmx parsing/syntaxerr.cmx typing/subst.cmx \ + typing/stypes.cmx typing/printtyp.cmx typing/predef.cmx typing/path.cmx \ parsing/parsetree.cmi typing/parmatch.cmx utils/misc.cmx \ parsing/longident.cmx parsing/location.cmx typing/includeclass.cmx \ typing/ident.cmx typing/env.cmx typing/ctype.cmx typing/cmt_format.cmx \ utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \ parsing/ast_helper.cmx typing/typeclass.cmi typing/typecore.cmo : utils/warnings.cmi typing/typetexp.cmi \ - typing/types.cmi typing/typedtree.cmi typing/subst.cmi typing/stypes.cmi \ - typing/printtyp.cmi typing/primitive.cmi typing/predef.cmi \ - typing/path.cmi parsing/parsetree.cmi typing/parmatch.cmi \ - typing/oprint.cmi utils/misc.cmi parsing/longident.cmi \ - parsing/location.cmi typing/ident.cmi typing/env.cmi typing/ctype.cmi \ - typing/cmt_format.cmi utils/clflags.cmi typing/btype.cmi \ - parsing/asttypes.cmi parsing/ast_helper.cmi typing/annot.cmi \ - typing/typecore.cmi + typing/types.cmi typing/typedtree.cmi parsing/syntaxerr.cmi \ + typing/subst.cmi typing/stypes.cmi typing/printtyp.cmi \ + typing/primitive.cmi typing/predef.cmi typing/path.cmi \ + parsing/parsetree.cmi typing/parmatch.cmi typing/oprint.cmi \ + utils/misc.cmi parsing/longident.cmi parsing/location.cmi \ + typing/ident.cmi typing/env.cmi typing/ctype.cmi typing/cmt_format.cmi \ + utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi \ + parsing/ast_helper.cmi typing/annot.cmi typing/typecore.cmi typing/typecore.cmx : utils/warnings.cmx typing/typetexp.cmx \ - typing/types.cmx typing/typedtree.cmx typing/subst.cmx typing/stypes.cmx \ - typing/printtyp.cmx typing/primitive.cmx typing/predef.cmx \ - typing/path.cmx parsing/parsetree.cmi typing/parmatch.cmx \ - typing/oprint.cmx utils/misc.cmx parsing/longident.cmx \ - parsing/location.cmx typing/ident.cmx typing/env.cmx typing/ctype.cmx \ - typing/cmt_format.cmx utils/clflags.cmx typing/btype.cmx \ - parsing/asttypes.cmi parsing/ast_helper.cmx typing/annot.cmi \ - typing/typecore.cmi + typing/types.cmx typing/typedtree.cmx parsing/syntaxerr.cmx \ + typing/subst.cmx typing/stypes.cmx typing/printtyp.cmx \ + typing/primitive.cmx typing/predef.cmx typing/path.cmx \ + parsing/parsetree.cmi typing/parmatch.cmx typing/oprint.cmx \ + utils/misc.cmx parsing/longident.cmx parsing/location.cmx \ + typing/ident.cmx typing/env.cmx typing/ctype.cmx typing/cmt_format.cmx \ + utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \ + parsing/ast_helper.cmx typing/annot.cmi typing/typecore.cmi typing/typedecl.cmo : utils/warnings.cmi typing/typetexp.cmi \ - typing/types.cmi typing/typedtree.cmi typing/subst.cmi \ - typing/printtyp.cmi typing/primitive.cmi typing/predef.cmi \ - typing/path.cmi parsing/parsetree.cmi utils/misc.cmi \ + typing/types.cmi typing/typedtree.cmi parsing/syntaxerr.cmi \ + typing/subst.cmi typing/printtyp.cmi typing/primitive.cmi \ + typing/predef.cmi typing/path.cmi parsing/parsetree.cmi utils/misc.cmi \ parsing/longident.cmi parsing/location.cmi typing/includecore.cmi \ typing/ident.cmi typing/env.cmi typing/ctype.cmi utils/config.cmi \ utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi \ parsing/ast_helper.cmi typing/typedecl.cmi typing/typedecl.cmx : utils/warnings.cmx typing/typetexp.cmx \ - typing/types.cmx typing/typedtree.cmx typing/subst.cmx \ - typing/printtyp.cmx typing/primitive.cmx typing/predef.cmx \ - typing/path.cmx parsing/parsetree.cmi utils/misc.cmx \ + typing/types.cmx typing/typedtree.cmx parsing/syntaxerr.cmx \ + typing/subst.cmx typing/printtyp.cmx typing/primitive.cmx \ + typing/predef.cmx typing/path.cmx parsing/parsetree.cmi utils/misc.cmx \ parsing/longident.cmx parsing/location.cmx typing/includecore.cmx \ typing/ident.cmx typing/env.cmx typing/ctype.cmx utils/config.cmx \ utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \ @@ -351,8 +354,8 @@ typing/typemod.cmo : utils/warnings.cmi typing/typetexp.cmi typing/types.cmi \ typing/mtype.cmi utils/misc.cmi parsing/longident.cmi \ parsing/location.cmi typing/includemod.cmi typing/ident.cmi \ typing/env.cmi typing/ctype.cmi utils/config.cmi typing/cmt_format.cmi \ - utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi typing/annot.cmi \ - typing/typemod.cmi + utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi \ + parsing/ast_mapper.cmi typing/annot.cmi typing/typemod.cmi typing/typemod.cmx : utils/warnings.cmx typing/typetexp.cmx typing/types.cmx \ typing/typedtree.cmx typing/typedecl.cmx typing/typecore.cmx \ typing/typeclass.cmx typing/subst.cmx typing/stypes.cmx \ @@ -360,8 +363,8 @@ typing/typemod.cmx : utils/warnings.cmx typing/typetexp.cmx typing/types.cmx \ typing/mtype.cmx utils/misc.cmx parsing/longident.cmx \ parsing/location.cmx typing/includemod.cmx typing/ident.cmx \ typing/env.cmx typing/ctype.cmx utils/config.cmx typing/cmt_format.cmx \ - utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi typing/annot.cmi \ - typing/typemod.cmi + utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \ + parsing/ast_mapper.cmx typing/annot.cmi typing/typemod.cmi typing/types.cmo : typing/primitive.cmi typing/path.cmi \ parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \ typing/ident.cmi parsing/asttypes.cmi typing/types.cmi @@ -369,21 +372,21 @@ typing/types.cmx : typing/primitive.cmx typing/path.cmx \ parsing/parsetree.cmi parsing/longident.cmx parsing/location.cmx \ typing/ident.cmx parsing/asttypes.cmi typing/types.cmi typing/typetexp.cmo : utils/warnings.cmi typing/types.cmi \ - typing/typedtree.cmi utils/tbl.cmi typing/printtyp.cmi typing/path.cmi \ - parsing/parsetree.cmi utils/misc.cmi parsing/longident.cmi \ - parsing/location.cmi typing/env.cmi typing/ctype.cmi utils/clflags.cmi \ - typing/btype.cmi parsing/asttypes.cmi parsing/ast_helper.cmi \ - typing/typetexp.cmi + typing/typedtree.cmi utils/tbl.cmi parsing/syntaxerr.cmi \ + typing/printtyp.cmi typing/path.cmi parsing/parsetree.cmi utils/misc.cmi \ + parsing/longident.cmi parsing/location.cmi typing/env.cmi \ + typing/ctype.cmi utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi \ + parsing/ast_mapper.cmi parsing/ast_helper.cmi typing/typetexp.cmi typing/typetexp.cmx : utils/warnings.cmx typing/types.cmx \ - typing/typedtree.cmx utils/tbl.cmx typing/printtyp.cmx typing/path.cmx \ - parsing/parsetree.cmi utils/misc.cmx parsing/longident.cmx \ - parsing/location.cmx typing/env.cmx typing/ctype.cmx utils/clflags.cmx \ - typing/btype.cmx parsing/asttypes.cmi parsing/ast_helper.cmx \ - typing/typetexp.cmi + typing/typedtree.cmx utils/tbl.cmx parsing/syntaxerr.cmx \ + typing/printtyp.cmx typing/path.cmx parsing/parsetree.cmi utils/misc.cmx \ + parsing/longident.cmx parsing/location.cmx typing/env.cmx \ + typing/ctype.cmx utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \ + parsing/ast_mapper.cmx parsing/ast_helper.cmx typing/typetexp.cmi bytecomp/bytegen.cmi : bytecomp/lambda.cmi bytecomp/instruct.cmi bytecomp/bytelibrarian.cmi : bytecomp/bytelink.cmi : bytecomp/symtable.cmi bytecomp/cmo_format.cmi -bytecomp/bytepackager.cmi : typing/ident.cmi +bytecomp/bytepackager.cmi : typing/ident.cmi typing/env.cmi bytecomp/bytesections.cmi : bytecomp/cmo_format.cmi : bytecomp/lambda.cmi typing/ident.cmi bytecomp/dll.cmi : @@ -448,22 +451,20 @@ bytecomp/bytepackager.cmx : typing/typemod.cmx bytecomp/translmod.cmx \ typing/env.cmx bytecomp/emitcode.cmx utils/config.cmx \ bytecomp/cmo_format.cmi utils/clflags.cmx bytecomp/bytelink.cmx \ bytecomp/bytegen.cmx bytecomp/bytepackager.cmi -bytecomp/bytesections.cmo : utils/misc.cmi utils/config.cmi \ - bytecomp/bytesections.cmi -bytecomp/bytesections.cmx : utils/misc.cmx utils/config.cmx \ - bytecomp/bytesections.cmi +bytecomp/bytesections.cmo : utils/config.cmi bytecomp/bytesections.cmi +bytecomp/bytesections.cmx : utils/config.cmx bytecomp/bytesections.cmi bytecomp/dll.cmo : utils/misc.cmi utils/config.cmi bytecomp/dll.cmi bytecomp/dll.cmx : utils/misc.cmx utils/config.cmx bytecomp/dll.cmi bytecomp/emitcode.cmo : bytecomp/translmod.cmi typing/primitive.cmi \ - bytecomp/opcodes.cmo utils/misc.cmi bytecomp/meta.cmi bytecomp/lambda.cmi \ - bytecomp/instruct.cmi typing/env.cmi utils/config.cmi \ - bytecomp/cmo_format.cmi utils/clflags.cmi typing/btype.cmi \ - parsing/asttypes.cmi bytecomp/emitcode.cmi + bytecomp/opcodes.cmo utils/misc.cmi bytecomp/meta.cmi \ + parsing/location.cmi bytecomp/lambda.cmi bytecomp/instruct.cmi \ + typing/env.cmi utils/config.cmi bytecomp/cmo_format.cmi utils/clflags.cmi \ + typing/btype.cmi parsing/asttypes.cmi bytecomp/emitcode.cmi bytecomp/emitcode.cmx : bytecomp/translmod.cmx typing/primitive.cmx \ - bytecomp/opcodes.cmx utils/misc.cmx bytecomp/meta.cmx bytecomp/lambda.cmx \ - bytecomp/instruct.cmx typing/env.cmx utils/config.cmx \ - bytecomp/cmo_format.cmi utils/clflags.cmx typing/btype.cmx \ - parsing/asttypes.cmi bytecomp/emitcode.cmi + bytecomp/opcodes.cmx utils/misc.cmx bytecomp/meta.cmx \ + parsing/location.cmx bytecomp/lambda.cmx bytecomp/instruct.cmx \ + typing/env.cmx utils/config.cmx bytecomp/cmo_format.cmi utils/clflags.cmx \ + typing/btype.cmx parsing/asttypes.cmi bytecomp/emitcode.cmi bytecomp/instruct.cmo : typing/types.cmi typing/subst.cmi \ parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi \ bytecomp/instruct.cmi @@ -508,12 +509,12 @@ bytecomp/printlambda.cmx : typing/types.cmx typing/primitive.cmx \ parsing/asttypes.cmi bytecomp/printlambda.cmi bytecomp/runtimedef.cmo : bytecomp/runtimedef.cmi bytecomp/runtimedef.cmx : bytecomp/runtimedef.cmi -bytecomp/simplif.cmo : utils/tbl.cmi typing/stypes.cmi bytecomp/lambda.cmi \ - typing/ident.cmi utils/clflags.cmi parsing/asttypes.cmi typing/annot.cmi \ - bytecomp/simplif.cmi -bytecomp/simplif.cmx : utils/tbl.cmx typing/stypes.cmx bytecomp/lambda.cmx \ - typing/ident.cmx utils/clflags.cmx parsing/asttypes.cmi typing/annot.cmi \ - bytecomp/simplif.cmi +bytecomp/simplif.cmo : utils/tbl.cmi typing/stypes.cmi utils/misc.cmi \ + bytecomp/lambda.cmi typing/ident.cmi utils/clflags.cmi \ + parsing/asttypes.cmi typing/annot.cmi bytecomp/simplif.cmi +bytecomp/simplif.cmx : utils/tbl.cmx typing/stypes.cmx utils/misc.cmx \ + bytecomp/lambda.cmx typing/ident.cmx utils/clflags.cmx \ + parsing/asttypes.cmi typing/annot.cmi bytecomp/simplif.cmi bytecomp/switch.cmo : bytecomp/switch.cmi bytecomp/switch.cmx : bytecomp/switch.cmi bytecomp/symtable.cmo : utils/tbl.cmi bytecomp/runtimedef.cmi \ @@ -576,10 +577,11 @@ bytecomp/typeopt.cmo : typing/types.cmi typing/typedtree.cmi \ bytecomp/typeopt.cmx : typing/types.cmx typing/typedtree.cmx \ typing/predef.cmx typing/path.cmx bytecomp/lambda.cmx typing/ident.cmx \ typing/env.cmx typing/ctype.cmx bytecomp/typeopt.cmi +asmcomp/CSEgen.cmi : asmcomp/mach.cmi asmcomp/asmgen.cmi : bytecomp/lambda.cmi asmcomp/cmm.cmi asmcomp/asmlibrarian.cmi : asmcomp/asmlink.cmi : asmcomp/cmx_format.cmi -asmcomp/asmpackager.cmi : +asmcomp/asmpackager.cmi : typing/env.cmi asmcomp/clambda.cmi : bytecomp/lambda.cmi typing/ident.cmi \ asmcomp/debuginfo.cmi parsing/asttypes.cmi asmcomp/closure.cmi : bytecomp/lambda.cmi asmcomp/clambda.cmi @@ -592,6 +594,7 @@ asmcomp/coloring.cmi : asmcomp/comballoc.cmi : asmcomp/mach.cmi asmcomp/compilenv.cmi : typing/ident.cmi asmcomp/cmx_format.cmi \ asmcomp/clambda.cmi +asmcomp/deadcode.cmi : asmcomp/mach.cmi asmcomp/debuginfo.cmi : parsing/location.cmi bytecomp/lambda.cmi asmcomp/emit.cmi : asmcomp/linearize.cmi asmcomp/cmm.cmi asmcomp/emitaux.cmi : asmcomp/debuginfo.cmi @@ -617,6 +620,12 @@ asmcomp/selection.cmi : asmcomp/mach.cmi asmcomp/cmm.cmi asmcomp/spill.cmi : asmcomp/mach.cmi asmcomp/split.cmi : asmcomp/mach.cmi asmcomp/strmatch.cmi : asmcomp/cmm.cmi +asmcomp/CSE.cmo : asmcomp/mach.cmi asmcomp/CSEgen.cmi asmcomp/arch.cmo +asmcomp/CSE.cmx : asmcomp/mach.cmx asmcomp/CSEgen.cmx asmcomp/arch.cmx +asmcomp/CSEgen.cmo : asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/mach.cmi \ + asmcomp/CSEgen.cmi +asmcomp/CSEgen.cmx : asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/mach.cmx \ + asmcomp/CSEgen.cmi asmcomp/arch.cmo : asmcomp/arch.cmx : asmcomp/asmgen.cmo : bytecomp/translmod.cmi asmcomp/split.cmi \ @@ -625,20 +634,20 @@ asmcomp/asmgen.cmo : bytecomp/translmod.cmi asmcomp/split.cmi \ asmcomp/printlinear.cmi asmcomp/printcmm.cmi asmcomp/printclambda.cmi \ typing/primitive.cmi utils/misc.cmi asmcomp/mach.cmi parsing/location.cmi \ asmcomp/liveness.cmi asmcomp/linearize.cmi asmcomp/interf.cmi \ - asmcomp/emitaux.cmi asmcomp/emit.cmi utils/config.cmi \ - asmcomp/compilenv.cmi asmcomp/comballoc.cmi asmcomp/coloring.cmi \ - asmcomp/cmmgen.cmi asmcomp/cmm.cmi asmcomp/closure.cmi utils/clflags.cmi \ - asmcomp/asmgen.cmi + asmcomp/emitaux.cmi asmcomp/emit.cmi asmcomp/deadcode.cmi \ + utils/config.cmi asmcomp/compilenv.cmi asmcomp/comballoc.cmi \ + asmcomp/coloring.cmi asmcomp/cmmgen.cmi asmcomp/cmm.cmi \ + asmcomp/closure.cmi utils/clflags.cmi asmcomp/CSE.cmo asmcomp/asmgen.cmi asmcomp/asmgen.cmx : bytecomp/translmod.cmx asmcomp/split.cmx \ asmcomp/spill.cmx asmcomp/selection.cmx asmcomp/scheduling.cmx \ asmcomp/reload.cmx asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/printmach.cmx \ asmcomp/printlinear.cmx asmcomp/printcmm.cmx asmcomp/printclambda.cmx \ typing/primitive.cmx utils/misc.cmx asmcomp/mach.cmx parsing/location.cmx \ asmcomp/liveness.cmx asmcomp/linearize.cmx asmcomp/interf.cmx \ - asmcomp/emitaux.cmx asmcomp/emit.cmx utils/config.cmx \ - asmcomp/compilenv.cmx asmcomp/comballoc.cmx asmcomp/coloring.cmx \ - asmcomp/cmmgen.cmx asmcomp/cmm.cmx asmcomp/closure.cmx utils/clflags.cmx \ - asmcomp/asmgen.cmi + asmcomp/emitaux.cmx asmcomp/emit.cmx asmcomp/deadcode.cmx \ + utils/config.cmx asmcomp/compilenv.cmx asmcomp/comballoc.cmx \ + asmcomp/coloring.cmx asmcomp/cmmgen.cmx asmcomp/cmm.cmx \ + asmcomp/closure.cmx utils/clflags.cmx asmcomp/CSE.cmx asmcomp/asmgen.cmi asmcomp/asmlibrarian.cmo : utils/misc.cmi parsing/location.cmi \ utils/config.cmi asmcomp/compilenv.cmi asmcomp/cmx_format.cmi \ utils/clflags.cmi asmcomp/clambda.cmi utils/ccomp.cmi asmcomp/asmlink.cmi \ @@ -719,6 +728,10 @@ asmcomp/compilenv.cmo : utils/misc.cmi parsing/location.cmi typing/ident.cmi \ asmcomp/compilenv.cmx : utils/misc.cmx parsing/location.cmx typing/ident.cmx \ typing/env.cmx utils/config.cmx asmcomp/cmx_format.cmi \ asmcomp/clambda.cmx asmcomp/compilenv.cmi +asmcomp/deadcode.cmo : asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/mach.cmi \ + asmcomp/deadcode.cmi +asmcomp/deadcode.cmx : asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/mach.cmx \ + asmcomp/deadcode.cmi asmcomp/debuginfo.cmo : parsing/location.cmi bytecomp/lambda.cmi \ asmcomp/debuginfo.cmi asmcomp/debuginfo.cmx : parsing/location.cmx bytecomp/lambda.cmx \ @@ -861,10 +874,14 @@ driver/compile.cmx : utils/warnings.cmx typing/typemod.cmx \ utils/misc.cmx parsing/location.cmx typing/includemod.cmx typing/env.cmx \ bytecomp/emitcode.cmx driver/compmisc.cmx driver/compenv.cmx \ utils/clflags.cmx utils/ccomp.cmx bytecomp/bytegen.cmx driver/compile.cmi -driver/compmisc.cmo : utils/misc.cmi typing/ident.cmi typing/env.cmi \ - utils/config.cmi driver/compenv.cmi utils/clflags.cmi driver/compmisc.cmi -driver/compmisc.cmx : utils/misc.cmx typing/ident.cmx typing/env.cmx \ - utils/config.cmx driver/compenv.cmx utils/clflags.cmx driver/compmisc.cmi +driver/compmisc.cmo : typing/typemod.cmi utils/misc.cmi \ + parsing/longident.cmi parsing/location.cmi typing/ident.cmi \ + typing/env.cmi utils/config.cmi driver/compenv.cmi utils/clflags.cmi \ + parsing/asttypes.cmi driver/compmisc.cmi +driver/compmisc.cmx : typing/typemod.cmx utils/misc.cmx \ + parsing/longident.cmx parsing/location.cmx typing/ident.cmx \ + typing/env.cmx utils/config.cmx driver/compenv.cmx utils/clflags.cmx \ + parsing/asttypes.cmi driver/compmisc.cmi driver/errors.cmo : parsing/location.cmi driver/errors.cmi driver/errors.cmx : parsing/location.cmx driver/errors.cmi driver/main.cmo : utils/warnings.cmi utils/misc.cmi driver/main_args.cmi \ @@ -910,9 +927,11 @@ driver/optmain.cmx : utils/warnings.cmx asmcomp/printmach.cmx \ asmcomp/asmlink.cmx asmcomp/asmlibrarian.cmx asmcomp/arch.cmx \ driver/optmain.cmi driver/pparse.cmo : parsing/parse.cmi utils/misc.cmi parsing/location.cmi \ - utils/config.cmi utils/clflags.cmi utils/ccomp.cmi driver/pparse.cmi + utils/config.cmi utils/clflags.cmi utils/ccomp.cmi parsing/ast_mapper.cmi \ + driver/pparse.cmi driver/pparse.cmx : parsing/parse.cmx utils/misc.cmx parsing/location.cmx \ - utils/config.cmx utils/clflags.cmx utils/ccomp.cmx driver/pparse.cmi + utils/config.cmx utils/clflags.cmx utils/ccomp.cmx parsing/ast_mapper.cmx \ + driver/pparse.cmi toplevel/genprintval.cmi : typing/types.cmi typing/path.cmi \ typing/outcometree.cmi typing/env.cmi toplevel/opttopdirs.cmi : parsing/longident.cmi @@ -983,18 +1002,22 @@ toplevel/opttopmain.cmx : utils/warnings.cmx asmcomp/printmach.cmx \ driver/compenv.cmx utils/clflags.cmx toplevel/opttopmain.cmi toplevel/opttopstart.cmo : toplevel/opttopmain.cmi toplevel/opttopstart.cmx : toplevel/opttopmain.cmx -toplevel/topdirs.cmo : utils/warnings.cmi typing/types.cmi \ - toplevel/trace.cmi toplevel/toploop.cmi bytecomp/symtable.cmi \ - typing/printtyp.cmi typing/path.cmi bytecomp/opcodes.cmo utils/misc.cmi \ - bytecomp/meta.cmi parsing/longident.cmi typing/ident.cmi typing/env.cmi \ - bytecomp/dll.cmi typing/ctype.cmi utils/consistbl.cmi utils/config.cmi \ - bytecomp/cmo_format.cmi utils/clflags.cmi toplevel/topdirs.cmi -toplevel/topdirs.cmx : utils/warnings.cmx typing/types.cmx \ - toplevel/trace.cmx toplevel/toploop.cmx bytecomp/symtable.cmx \ - typing/printtyp.cmx typing/path.cmx bytecomp/opcodes.cmx utils/misc.cmx \ - bytecomp/meta.cmx parsing/longident.cmx typing/ident.cmx typing/env.cmx \ - bytecomp/dll.cmx typing/ctype.cmx utils/consistbl.cmx utils/config.cmx \ - bytecomp/cmo_format.cmi utils/clflags.cmx toplevel/topdirs.cmi +toplevel/topdirs.cmo : utils/warnings.cmi typing/typetexp.cmi \ + typing/types.cmi toplevel/trace.cmi toplevel/toploop.cmi \ + bytecomp/symtable.cmi typing/printtyp.cmi typing/predef.cmi \ + typing/path.cmi bytecomp/opcodes.cmo utils/misc.cmi bytecomp/meta.cmi \ + parsing/longident.cmi parsing/location.cmi typing/ident.cmi \ + typing/env.cmi bytecomp/dll.cmi typing/ctype.cmi utils/consistbl.cmi \ + utils/config.cmi bytecomp/cmo_format.cmi utils/clflags.cmi \ + parsing/asttypes.cmi toplevel/topdirs.cmi +toplevel/topdirs.cmx : utils/warnings.cmx typing/typetexp.cmx \ + typing/types.cmx toplevel/trace.cmx toplevel/toploop.cmx \ + bytecomp/symtable.cmx typing/printtyp.cmx typing/predef.cmx \ + typing/path.cmx bytecomp/opcodes.cmx utils/misc.cmx bytecomp/meta.cmx \ + parsing/longident.cmx parsing/location.cmx typing/ident.cmx \ + typing/env.cmx bytecomp/dll.cmx typing/ctype.cmx utils/consistbl.cmx \ + utils/config.cmx bytecomp/cmo_format.cmi utils/clflags.cmx \ + parsing/asttypes.cmi toplevel/topdirs.cmi toplevel/toploop.cmo : utils/warnings.cmi typing/types.cmi \ typing/typemod.cmi typing/typedtree.cmi typing/typecore.cmi \ bytecomp/translmod.cmi bytecomp/symtable.cmi bytecomp/simplif.cmi \ diff --git a/.gitignore b/.gitignore new file mode 100644 index 000000000..6c66ecc5a --- /dev/null +++ b/.gitignore @@ -0,0 +1,2759 @@ + +# / +/*.o +/*.a +/*.so +/*.obj +/*.lib +/*.dll +/*.cm[ioxat] +/*.cmx[as] +/*.cmti +/*.annot +/*.result +/*.byte +/*.native +/program +/*.exe +/*.exe.manifest +/.depend +/.depend.nt +/.DS_Store +/configure +/ocamlc +/ocamlc.opt +/expunge +/ocaml +/ocamlopt +/ocamlopt.opt +/ocamlcomp.sh +/ocamlcompopt.sh +/package-macosx +/ocamlnat + +# /asmcomp/ +/asmcomp/*.o +/asmcomp/*.a +/asmcomp/*.so +/asmcomp/*.obj +/asmcomp/*.lib +/asmcomp/*.dll +/asmcomp/*.cm[ioxat] +/asmcomp/*.cmx[as] +/asmcomp/*.cmti +/asmcomp/*.annot +/asmcomp/*.result +/asmcomp/*.byte +/asmcomp/*.native +/asmcomp/program +/asmcomp/*.exe +/asmcomp/*.exe.manifest +/asmcomp/.depend +/asmcomp/.depend.nt +/asmcomp/.DS_Store +/asmcomp/emit.ml +/asmcomp/arch.ml +/asmcomp/proc.ml +/asmcomp/selection.ml +/asmcomp/reload.ml +/asmcomp/scheduling.ml +/asmcomp/CSE.ml + +# /asmcomp/amd64/ +/asmcomp/amd64/*.o +/asmcomp/amd64/*.a +/asmcomp/amd64/*.so +/asmcomp/amd64/*.obj +/asmcomp/amd64/*.cm[ioxat] +/asmcomp/amd64/*.cmx[as] +/asmcomp/amd64/*.cmti +/asmcomp/amd64/*.annot +/asmcomp/amd64/*.result +/asmcomp/amd64/*.byte +/asmcomp/amd64/*.native +/asmcomp/amd64/program +/asmcomp/amd64/program.exe +/asmcomp/amd64/.depend +/asmcomp/amd64/.depend.nt +/asmcomp/amd64/.DS_Store + +# /asmrun/ +/asmrun/*.o +/asmrun/*.a +/asmrun/*.so +/asmrun/*.obj +/asmrun/*.lib +/asmrun/*.dll +/asmrun/*.cm[ioxat] +/asmrun/*.cmx[as] +/asmrun/*.cmti +/asmrun/*.annot +/asmrun/*.result +/asmrun/*.byte +/asmrun/*.native +/asmrun/program +/asmrun/*.exe +/asmrun/.depend +/asmrun/.depend.nt +/asmrun/.DS_Store +/asmrun/*.p.c +/asmrun/*.d.c +/asmrun/libasmrun.a +/asmrun/libasmrunp.a +/asmrun/main.c +/asmrun/misc.c +/asmrun/freelist.c +/asmrun/major_gc.c +/asmrun/minor_gc.c +/asmrun/memory.c +/asmrun/alloc.c +/asmrun/array.c +/asmrun/compare.c +/asmrun/ints.c +/asmrun/floats.c +/asmrun/str.c +/asmrun/io.c +/asmrun/extern.c +/asmrun/intern.c +/asmrun/hash.c +/asmrun/sys.c +/asmrun/parsing.c +/asmrun/gc_ctrl.c +/asmrun/terminfo.c +/asmrun/md5.c +/asmrun/obj.c +/asmrun/lexing.c +/asmrun/printexc.c +/asmrun/callback.c +/asmrun/weak.c +/asmrun/compact.c +/asmrun/finalise.c +/asmrun/custom.c +/asmrun/meta.c +/asmrun/globroots.c +/asmrun/unix.c +/asmrun/dynlink.c +/asmrun/signals.c +/asmrun/debugger.c +/asmrun/.depend.nt + +# /boot/ +/boot/*.o +/boot/*.a +/boot/*.so +/boot/*.obj +/boot/*.lib +/boot/*.dll +/boot/*.cm[ioxat] +/boot/*.cmx[as] +/boot/*.cmti +/boot/*.annot +/boot/*.result +/boot/*.byte +/boot/*.native +/boot/program +/boot/*.exe +/boot/*.exe.manifest +/boot/.depend +/boot/.depend.nt +/boot/.DS_Store +/boot/Saved +/boot/ocamlrun +/boot/ocamlrun.exe +/boot/ocamlyacc +/boot/ocamlyacc.exe +/boot/camlheader + +# /bytecomp/ +/bytecomp/*.o +/bytecomp/*.a +/bytecomp/*.so +/bytecomp/*.obj +/bytecomp/*.lib +/bytecomp/*.dll +/bytecomp/*.cm[ioxat] +/bytecomp/*.cmx[as] +/bytecomp/*.cmti +/bytecomp/*.annot +/bytecomp/*.result +/bytecomp/*.byte +/bytecomp/*.native +/bytecomp/program +/bytecomp/*.exe +/bytecomp/.depend +/bytecomp/.depend.nt +/bytecomp/.DS_Store +/bytecomp/runtimedef.ml +/bytecomp/opcodes.ml + +# /byterun/ +/byterun/*.o +/byterun/*.a +/byterun/*.so +/byterun/*.obj +/byterun/*.cm[ioxa] +/byterun/*.cmx[as] +/byterun/*.annot +/byterun/*.result +/byterun/*.byte +/byterun/*.native +/byterun/program +/byterun/program.exe +/byterun/.depend +/byterun/.depend.nt +/byterun/.DS_Store +/byterun/jumptbl.h +/byterun/primitives +/byterun/prims.c +/byterun/opnames.h +/byterun/version.h +/byterun/ocamlrun +/byterun/ocamlrun.exe +/byterun/ocamlrund +/byterun/ocamlrund.exe +/byterun/ld.conf +/byterun/interp.a.lst +/byterun/*.[sd]obj +/byterun/*.lib +/byterun/.gdb_history +/byterun/*.d.c +/byterun/*.pic.c + +# /compilerlibs/ +/compilerlibs/* + +# /config/ +/config/*.o +/config/*.a +/config/*.so +/config/*.obj +/config/*.lib +/config/*.dll +/config/*.cm[ioxat] +/config/*.cmx[as] +/config/*.cmti +/config/*.annot +/config/*.result +/config/*.byte +/config/*.native +/config/program +/config/*.exe +/config/*.exe.manifest +/config/.depend +/config/.depend.nt +/config/.DS_Store +/config/m.h +/config/s.h +/config/Makefile + +# /config/auto-aux/ +/config/auto-aux/*.o +/config/auto-aux/*.a +/config/auto-aux/*.so +/config/auto-aux/*.obj +/config/auto-aux/*.cm[ioxa] +/config/auto-aux/*.cmx[as] +/config/auto-aux/*.annot +/config/auto-aux/*.result +/config/auto-aux/*.byte +/config/auto-aux/*.native +/config/auto-aux/program +/config/auto-aux/.depend +/config/auto-aux/.depend.nt +/config/auto-aux/.DS_Store +/config/auto-aux/camlp4_config.ml + +# /config/gnu/ + +# /debugger/ +/debugger/*.o +/debugger/*.a +/debugger/*.so +/debugger/*.obj +/debugger/*.cm[ioxa] +/debugger/*.cmx[as] +/debugger/*.annot +/debugger/*.result +/debugger/*.byte +/debugger/*.native +/debugger/program +/debugger/program.exe +/debugger/.depend +/debugger/.depend.nt +/debugger/.DS_Store +/debugger/lexer.ml +/debugger/parser.ml +/debugger/parser.mli +/debugger/ocamldebug +/debugger/ocamldebug.exe +/debugger/dynlink.ml +/debugger/dynlink.mli + +# /driver/ +/driver/*.o +/driver/*.a +/driver/*.so +/driver/*.obj +/driver/*.lib +/driver/*.dll +/driver/*.cm[ioxat] +/driver/*.cmx[as] +/driver/*.cmti +/driver/*.annot +/driver/*.result +/driver/*.byte +/driver/*.native +/driver/program +/driver/*.exe +/driver/*.exe.manifest +/driver/.depend +/driver/.depend.nt +/driver/.DS_Store + +# /emacs/ +/emacs/*.o +/emacs/*.a +/emacs/*.so +/emacs/*.obj +/emacs/*.lib +/emacs/*.dll +/emacs/*.cm[ioxat] +/emacs/*.cmx[as] +/emacs/*.cmti +/emacs/*.annot +/emacs/*.result +/emacs/*.byte +/emacs/*.native +/emacs/program +/emacs/*.exe +/emacs/*.exe.manifest +/emacs/.depend +/emacs/.depend.nt +/emacs/.DS_Store +/emacs/ocamltags +/emacs/*.elc + +# /experimental/ + +# /experimental/garrigue/ +/experimental/garrigue/*.out +/experimental/garrigue/*.out2 + +# /lex/ +/lex/*.o +/lex/*.a +/lex/*.so +/lex/*.obj +/lex/*.lib +/lex/*.dll +/lex/*.cm[ioxat] +/lex/*.cmx[as] +/lex/*.cmti +/lex/*.annot +/lex/*.result +/lex/*.byte +/lex/*.native +/lex/program +/lex/*.exe +/lex/*.exe.manifest +/lex/.depend +/lex/.depend.nt +/lex/.DS_Store +/lex/parser.ml +/lex/parser.mli +/lex/lexer.ml +/lex/ocamllex +/lex/ocamllex.opt +/lex/parser.output + +# /ocamlbuild/ +/ocamlbuild/*.o +/ocamlbuild/*.a +/ocamlbuild/*.so +/ocamlbuild/*.obj +/ocamlbuild/*.lib +/ocamlbuild/*.dll +/ocamlbuild/*.cm[ioxat] +/ocamlbuild/*.cmx[as] +/ocamlbuild/*.cmti +/ocamlbuild/*.annot +/ocamlbuild/*.byte +/ocamlbuild/*.native +/ocamlbuild/ocamlbuild_config.ml +/ocamlbuild/lexers.ml +/ocamlbuild/glob_lexer.ml + +# /ocamldoc/ +/ocamldoc/*.o +/ocamldoc/*.a +/ocamldoc/*.so +/ocamldoc/*.obj +/ocamldoc/*.lib +/ocamldoc/*.dll +/ocamldoc/*.cm[ioxat] +/ocamldoc/*.cmx[as] +/ocamldoc/*.cmti +/ocamldoc/*.annot +/ocamldoc/*.result +/ocamldoc/*.byte +/ocamldoc/*.native +/ocamldoc/program +/ocamldoc/*.exe +/ocamldoc/.depend +/ocamldoc/.depend.nt +/ocamldoc/.DS_Store +/ocamldoc/ocamldoc +/ocamldoc/ocamldoc.opt +/ocamldoc/odoc_crc.ml +/ocamldoc/odoc_lexer.ml +/ocamldoc/odoc_ocamlhtml.ml +/ocamldoc/odoc_parser.ml +/ocamldoc/odoc_parser.mli +/ocamldoc/odoc_see_lexer.ml +/ocamldoc/odoc_text_lexer.ml +/ocamldoc/odoc_text_parser.ml +/ocamldoc/odoc_text_parser.mli +/ocamldoc/stdlib_man +/ocamldoc/stdlib_html +/ocamldoc/*.output +/ocamldoc/test_stdlib +/ocamldoc/test_latex +/ocamldoc/test + +# /ocamldoc/generators/ +/ocamldoc/generators/*.o +/ocamldoc/generators/*.a +/ocamldoc/generators/*.so +/ocamldoc/generators/*.obj +/ocamldoc/generators/*.lib +/ocamldoc/generators/*.dll +/ocamldoc/generators/*.cm[ioxat] +/ocamldoc/generators/*.cmx[as] +/ocamldoc/generators/*.cmti +/ocamldoc/generators/*.annot +/ocamldoc/generators/*.result +/ocamldoc/generators/*.byte +/ocamldoc/generators/*.native +/ocamldoc/generators/program +/ocamldoc/generators/*.exe +/ocamldoc/generators/*.exe.manifest +/ocamldoc/generators/.depend +/ocamldoc/generators/.depend.nt +/ocamldoc/generators/.DS_Store + +# /otherlibs/ +/otherlibs/.depend +/otherlibs/configure +/otherlibs/ocamlc +/otherlibs/ocamlc.opt +/otherlibs/expunge +/otherlibs/ocaml +/otherlibs/ocamlopt +/otherlibs/ocamlopt.opt +/otherlibs/ocamlcomp.sh +/otherlibs/ocamlcompopt.sh +/otherlibs/package-macosx +/otherlibs/.DS_Store +/otherlibs/*.annot +/otherlibs/_boot_log1 +/otherlibs/_boot_log2 +/otherlibs/_build +/otherlibs/_log +/otherlibs/myocamlbuild_config.ml +/otherlibs/ocamlnat +/otherlibs/*.cm* +/otherlibs/*.o + +# /otherlibs/bigarray/ +/otherlibs/bigarray/*.o +/otherlibs/bigarray/*.a +/otherlibs/bigarray/*.so +/otherlibs/bigarray/*.obj +/otherlibs/bigarray/*.lib +/otherlibs/bigarray/*.dll +/otherlibs/bigarray/*.cm[ioxat] +/otherlibs/bigarray/*.cmx[as] +/otherlibs/bigarray/*.cmti +/otherlibs/bigarray/*.annot +/otherlibs/bigarray/*.result +/otherlibs/bigarray/*.byte +/otherlibs/bigarray/*.native +/otherlibs/bigarray/program +/otherlibs/bigarray/*.exe +/otherlibs/bigarray/.depend +/otherlibs/bigarray/.depend.nt +/otherlibs/bigarray/.DS_Store + +# /otherlibs/dynlink/ +/otherlibs/dynlink/*.o +/otherlibs/dynlink/*.a +/otherlibs/dynlink/*.so +/otherlibs/dynlink/*.obj +/otherlibs/dynlink/*.lib +/otherlibs/dynlink/*.dll +/otherlibs/dynlink/*.cm[ioxat] +/otherlibs/dynlink/*.cmx[as] +/otherlibs/dynlink/*.cmti +/otherlibs/dynlink/*.annot +/otherlibs/dynlink/*.result +/otherlibs/dynlink/*.byte +/otherlibs/dynlink/*.native +/otherlibs/dynlink/program +/otherlibs/dynlink/*.exe +/otherlibs/dynlink/.depend +/otherlibs/dynlink/.depend.nt +/otherlibs/dynlink/.DS_Store +/otherlibs/dynlink/extract_crc + +# /otherlibs/graph/ +/otherlibs/graph/*.o +/otherlibs/graph/*.a +/otherlibs/graph/*.so +/otherlibs/graph/*.obj +/otherlibs/graph/*.lib +/otherlibs/graph/*.dll +/otherlibs/graph/*.cm[ioxat] +/otherlibs/graph/*.cmx[as] +/otherlibs/graph/*.cmti +/otherlibs/graph/*.annot +/otherlibs/graph/*.result +/otherlibs/graph/*.byte +/otherlibs/graph/*.native +/otherlibs/graph/program +/otherlibs/graph/*.exe +/otherlibs/graph/*.exe.manifest +/otherlibs/graph/.depend +/otherlibs/graph/.depend.nt +/otherlibs/graph/.DS_Store + +# /otherlibs/num/ +/otherlibs/num/*.o +/otherlibs/num/*.a +/otherlibs/num/*.so +/otherlibs/num/*.obj +/otherlibs/num/*.lib +/otherlibs/num/*.dll +/otherlibs/num/*.cm[ioxat] +/otherlibs/num/*.cmx[as] +/otherlibs/num/*.cmti +/otherlibs/num/*.annot +/otherlibs/num/*.result +/otherlibs/num/*.byte +/otherlibs/num/*.native +/otherlibs/num/program +/otherlibs/num/*.exe +/otherlibs/num/.depend +/otherlibs/num/.depend.nt +/otherlibs/num/.DS_Store + +# /otherlibs/str/ +/otherlibs/str/*.o +/otherlibs/str/*.a +/otherlibs/str/*.so +/otherlibs/str/*.obj +/otherlibs/str/*.lib +/otherlibs/str/*.dll +/otherlibs/str/*.cm[ioxat] +/otherlibs/str/*.cmx[as] +/otherlibs/str/*.cmti +/otherlibs/str/*.annot +/otherlibs/str/*.result +/otherlibs/str/*.byte +/otherlibs/str/*.native +/otherlibs/str/program +/otherlibs/str/*.exe +/otherlibs/str/.depend +/otherlibs/str/.depend.nt +/otherlibs/str/.DS_Store + +# /otherlibs/systhreads/ +/otherlibs/systhreads/*.o +/otherlibs/systhreads/*.a +/otherlibs/systhreads/*.so +/otherlibs/systhreads/*.obj +/otherlibs/systhreads/*.lib +/otherlibs/systhreads/*.dll +/otherlibs/systhreads/*.cm[ioxat] +/otherlibs/systhreads/*.cmx[as] +/otherlibs/systhreads/*.cmti +/otherlibs/systhreads/*.annot +/otherlibs/systhreads/*.result +/otherlibs/systhreads/*.byte +/otherlibs/systhreads/*.native +/otherlibs/systhreads/program +/otherlibs/systhreads/*.exe +/otherlibs/systhreads/.depend +/otherlibs/systhreads/.depend.nt +/otherlibs/systhreads/.DS_Store +/otherlibs/systhreads/thread.ml + +# /otherlibs/threads/ +/otherlibs/threads/*.o +/otherlibs/threads/*.a +/otherlibs/threads/*.so +/otherlibs/threads/*.obj +/otherlibs/threads/*.lib +/otherlibs/threads/*.dll +/otherlibs/threads/*.cm[ioxat] +/otherlibs/threads/*.cmx[as] +/otherlibs/threads/*.cmti +/otherlibs/threads/*.annot +/otherlibs/threads/*.result +/otherlibs/threads/*.byte +/otherlibs/threads/*.native +/otherlibs/threads/program +/otherlibs/threads/*.exe +/otherlibs/threads/*.exe.manifest +/otherlibs/threads/.depend +/otherlibs/threads/.depend.nt +/otherlibs/threads/.DS_Store +/otherlibs/threads/marshal.mli +/otherlibs/threads/pervasives.mli +/otherlibs/threads/unix.mli + +# /otherlibs/unix/ +/otherlibs/unix/*.o +/otherlibs/unix/*.a +/otherlibs/unix/*.so +/otherlibs/unix/*.obj +/otherlibs/unix/*.lib +/otherlibs/unix/*.dll +/otherlibs/unix/*.cm[ioxat] +/otherlibs/unix/*.cmx[as] +/otherlibs/unix/*.cmti +/otherlibs/unix/*.annot +/otherlibs/unix/*.result +/otherlibs/unix/*.byte +/otherlibs/unix/*.native +/otherlibs/unix/program +/otherlibs/unix/*.exe +/otherlibs/unix/*.exe.manifest +/otherlibs/unix/.depend +/otherlibs/unix/.depend.nt +/otherlibs/unix/.DS_Store + +# /otherlibs/win32graph/ +/otherlibs/win32graph/*.o +/otherlibs/win32graph/*.a +/otherlibs/win32graph/*.so +/otherlibs/win32graph/*.obj +/otherlibs/win32graph/*.lib +/otherlibs/win32graph/*.dll +/otherlibs/win32graph/*.cm[ioxat] +/otherlibs/win32graph/*.cmx[as] +/otherlibs/win32graph/*.cmti +/otherlibs/win32graph/*.annot +/otherlibs/win32graph/*.result +/otherlibs/win32graph/*.byte +/otherlibs/win32graph/*.native +/otherlibs/win32graph/program +/otherlibs/win32graph/*.exe +/otherlibs/win32graph/.depend +/otherlibs/win32graph/.depend.nt +/otherlibs/win32graph/.DS_Store +/otherlibs/win32graph/graphics.ml +/otherlibs/win32graph/graphics.mli + +# /otherlibs/win32unix/ +/otherlibs/win32unix/*.o +/otherlibs/win32unix/*.a +/otherlibs/win32unix/*.so +/otherlibs/win32unix/*.obj +/otherlibs/win32unix/*.lib +/otherlibs/win32unix/*.dll +/otherlibs/win32unix/*.cm[ioxat] +/otherlibs/win32unix/*.cmx[as] +/otherlibs/win32unix/*.cmti +/otherlibs/win32unix/*.annot +/otherlibs/win32unix/*.result +/otherlibs/win32unix/*.byte +/otherlibs/win32unix/*.native +/otherlibs/win32unix/program +/otherlibs/win32unix/*.exe +/otherlibs/win32unix/.depend +/otherlibs/win32unix/.depend.nt +/otherlibs/win32unix/.DS_Store +/otherlibs/win32unix/unixLabels.ml* +/otherlibs/win32unix/unix.mli +/otherlibs/win32unix/unix.lib +/otherlibs/win32unix/access.c +/otherlibs/win32unix/addrofstr.c +/otherlibs/win32unix/chdir.c +/otherlibs/win32unix/chmod.c +/otherlibs/win32unix/cst2constr.c +/otherlibs/win32unix/cstringv.c +/otherlibs/win32unix/envir.c +/otherlibs/win32unix/execv.c +/otherlibs/win32unix/execve.c +/otherlibs/win32unix/execvp.c +/otherlibs/win32unix/exit.c +/otherlibs/win32unix/getaddrinfo.c +/otherlibs/win32unix/getcwd.c +/otherlibs/win32unix/gethost.c +/otherlibs/win32unix/gethostname.c +/otherlibs/win32unix/getnameinfo.c +/otherlibs/win32unix/getproto.c +/otherlibs/win32unix/getserv.c +/otherlibs/win32unix/gmtime.c +/otherlibs/win32unix/putenv.c +/otherlibs/win32unix/rmdir.c +/otherlibs/win32unix/socketaddr.c +/otherlibs/win32unix/strofaddr.c +/otherlibs/win32unix/time.c +/otherlibs/win32unix/unlink.c +/otherlibs/win32unix/utimes.c + +# /parsing/ +/parsing/*.o +/parsing/*.a +/parsing/*.so +/parsing/*.obj +/parsing/*.lib +/parsing/*.dll +/parsing/*.cm[ioxat] +/parsing/*.cmx[as] +/parsing/*.cmti +/parsing/*.annot +/parsing/*.result +/parsing/*.byte +/parsing/*.native +/parsing/program +/parsing/*.exe +/parsing/*.exe.manifest +/parsing/.depend +/parsing/.depend.nt +/parsing/.DS_Store +/parsing/parser.ml +/parsing/parser.mli +/parsing/lexer.ml +/parsing/lexer_tmp.mll +/parsing/lexer_tmp.ml +/parsing/linenum.ml +/parsing/parser.output +/parsing/parser.automaton +/parsing/parser.conflicts + +# /stdlib/ +/stdlib/*.o +/stdlib/*.a +/stdlib/*.so +/stdlib/*.obj +/stdlib/*.lib +/stdlib/*.dll +/stdlib/*.cm[ioxat] +/stdlib/*.cmx[as] +/stdlib/*.cmti +/stdlib/*.annot +/stdlib/*.result +/stdlib/*.byte +/stdlib/*.native +/stdlib/program +/stdlib/*.exe +/stdlib/.depend +/stdlib/.depend.nt +/stdlib/.DS_Store +/stdlib/camlheader +/stdlib/camlheaderd +/stdlib/camlheader_ur +/stdlib/labelled-* +/stdlib/caml +/stdlib/sys.ml + +# /testsuite/ +/testsuite/*.o +/testsuite/*.a +/testsuite/*.so +/testsuite/*.obj +/testsuite/*.cm[ioxa] +/testsuite/*.cmx[as] +/testsuite/*.annot +/testsuite/*.result +/testsuite/*.byte +/testsuite/*.native +/testsuite/program +/testsuite/.depend +/testsuite/.depend.nt +/testsuite/.DS_Store +/testsuite/_log + +# /testsuite/external/ +/testsuite/external/*.o +/testsuite/external/*.a +/testsuite/external/*.so +/testsuite/external/*.obj +/testsuite/external/*.lib +/testsuite/external/*.dll +/testsuite/external/*.cm[ioxat] +/testsuite/external/*.cmx[as] +/testsuite/external/*.cmti +/testsuite/external/*.annot +/testsuite/external/*.result +/testsuite/external/*.byte +/testsuite/external/*.native +/testsuite/external/program +/testsuite/external/*.exe +/testsuite/external/*.exe.manifest +/testsuite/external/.depend +/testsuite/external/.depend.nt +/testsuite/external/.DS_Store +/testsuite/external/*.tar.gz +/testsuite/external/*.tar.bz2 +/testsuite/external/*.tgz +/testsuite/external/*.tbz +/testsuite/external/*.zip +/testsuite/external/log-* +/testsuite/external/log_* +/testsuite/external/advi +/testsuite/external/advi-1.10.2 +/testsuite/external/altergo +/testsuite/external/alt-ergo-0.95.2 +/testsuite/external/binprot +/testsuite/external/bin_prot-109.30.00 +/testsuite/external/bitstring +/testsuite/external/ocaml-bitstring-2.0.3 +/testsuite/external/boomerang +/testsuite/external/boomerang-0.2 +/testsuite/external/calendar +/testsuite/external/calendar-2.03.2 +/testsuite/external/camlimages +/testsuite/external/camlimages-4.0.1 +/testsuite/external/camlpdf +/testsuite/external/camlpdf-0.5 +/testsuite/external/camlp4 +/testsuite/external/camlp4-trunk +/testsuite/external/camlp5 +/testsuite/external/camlp5-git +/testsuite/external/camlzip +/testsuite/external/camlzip-1.04 +/testsuite/external/camomile +/testsuite/external/camomile-0.8.4 +/testsuite/external/comparelib +/testsuite/external/comparelib-109.15.00 +/testsuite/external/compcert +/testsuite/external/compcert-1.13 +/testsuite/external/configfile +/testsuite/external/config-file-1.1 +/testsuite/external/coq +/testsuite/external/coq-8.4pl2 +/testsuite/external/core +/testsuite/external/core-109.37.00 +/testsuite/external/coreextended +/testsuite/external/core_extended-109.36.00 +/testsuite/external/corekernel +/testsuite/external/core_kernel-109.37.00 +/testsuite/external/cryptokit +/testsuite/external/cryptokit-1.6 +/testsuite/external/csv +/testsuite/external/csv-1.3.1 +/testsuite/external/customprintf +/testsuite/external/custom_printf-109.27.00 +/testsuite/external/dbm +/testsuite/external/camldbm-1.0 +/testsuite/external/expect +/testsuite/external/ocaml-expect-0.0.3 +/testsuite/external/extlib +/testsuite/external/extlib-1.5.2 +/testsuite/external/fieldslib +/testsuite/external/fieldslib-109.15.00 +/testsuite/external/fileutils +/testsuite/external/ocaml-fileutils-0.4.4 +/testsuite/external/findlib +/testsuite/external/findlib-1.4.1 +/testsuite/external/framac +/testsuite/external/frama-c-Oxygen-20120901 +/testsuite/external/geneweb +/testsuite/external/gw-6.05-src +/testsuite/external/herelib +/testsuite/external/herelib-109.35.00 +/testsuite/external/hevea +/testsuite/external/hevea-2.09 +/testsuite/external/kaputt +/testsuite/external/kaputt-1.2 +/testsuite/external/lablgtk +/testsuite/external/lablgtk-2.18.0 +/testsuite/external/lablgtkextras +/testsuite/external/lablgtkextras-1.3 +/testsuite/external/lwt +/testsuite/external/lwt-2.4.0 +/testsuite/external/menhir +/testsuite/external/menhir-20120123 +/testsuite/external/mldonkey +/testsuite/external/mldonkey-3.1.2 +/testsuite/external/mysql +/testsuite/external/ocaml-mysql-1.0.4 +/testsuite/external/oasis +/testsuite/external/oasis-0.3.0 +/testsuite/external/obrowser +/testsuite/external/obrowser-1.1.1 +/testsuite/external/ocamlgraph +/testsuite/external/ocamlgraph-1.8.2 +/testsuite/external/ocamlify +/testsuite/external/ocamlify-0.0.1 +/testsuite/external/ocamlmod +/testsuite/external/ocamlmod-0.0.3 +/testsuite/external/ocamlnet +/testsuite/external/ocamlnet-3.5.1 +/testsuite/external/ocamlscript +/testsuite/external/ocamlscript-2.0.3 +/testsuite/external/ocamlssl +/testsuite/external/ocaml-ssl-0.4.6 +/testsuite/external/ocamltext +/testsuite/external/ocaml-text-0.5 +/testsuite/external/ocgi +/testsuite/external/ocgi-0.5 +/testsuite/external/ocsigen +/testsuite/external/ocsigen-bundle-2.2.2 +/testsuite/external/odn +/testsuite/external/ocaml-data-notation-0.0.10 +/testsuite/external/omake +/testsuite/external/omake-0.9.8.6 +/testsuite/external/ounit +/testsuite/external/ounit-1.1.2 +/testsuite/external/paounit +/testsuite/external/pa_ounit-109.36.00 +/testsuite/external/pcre +/testsuite/external/pcre-ocaml-6.2.5 +/testsuite/external/pipebang +/testsuite/external/pipebang-109.28.00 +/testsuite/external/react +/testsuite/external/react-0.9.3 +/testsuite/external/res +/testsuite/external/res-3.2.0 +/testsuite/external/rss +/testsuite/external/ocamlrss-2.2.2 +/testsuite/external/sexplib +/testsuite/external/sexplib-109.15.00 +/testsuite/external/sks +/testsuite/external/sks-1.1.3 +/testsuite/external/sqlite +/testsuite/external/sqlite3-ocaml-2.0.1 +/testsuite/external/textutils +/testsuite/external/textutils-109.36.00 +/testsuite/external/typeconv +/testsuite/external/type_conv-109.28.00 +/testsuite/external/unison +/testsuite/external/unison-2.45.4 +/testsuite/external/variantslib +/testsuite/external/variantslib-109.15.00 +/testsuite/external/vsyml +/testsuite/external/vsyml-2010-04-06 +/testsuite/external/xmllight +/testsuite/external/xml-light.2.3 +/testsuite/external/xmlm +/testsuite/external/xmlm-1.1.0 +/testsuite/external/zarith +/testsuite/external/zarith-1.2.1 +/testsuite/external/zen +/testsuite/external/zen_2.3.2 +/testsuite/external/._ZEN_2.3.2 + +# /testsuite/interactive/ +/testsuite/interactive/# svn propset -R svn:ignore -F .svnignore . +/testsuite/interactive/# find . -name .svnignore -print | while read f; do svn propset svn:ignore -F $f `dirname $f`; done +/testsuite/interactive/_log +/testsuite/interactive/*.so +/testsuite/interactive/*.a +/testsuite/interactive/*.result +/testsuite/interactive/*.byte +/testsuite/interactive/*.native +/testsuite/interactive/program +/testsuite/interactive/*.cm* +/testsuite/interactive/*.o + +# /testsuite/interactive/lib-gc/ +/testsuite/interactive/lib-gc/# svn propset -R svn:ignore -F .svnignore . +/testsuite/interactive/lib-gc/# find . -name .svnignore -print | while read f; do svn propset svn:ignore -F $f `dirname $f`; done +/testsuite/interactive/lib-gc/_log +/testsuite/interactive/lib-gc/*.so +/testsuite/interactive/lib-gc/*.a +/testsuite/interactive/lib-gc/*.result +/testsuite/interactive/lib-gc/*.byte +/testsuite/interactive/lib-gc/*.native +/testsuite/interactive/lib-gc/program +/testsuite/interactive/lib-gc/*.cm* +/testsuite/interactive/lib-gc/*.o + +# /testsuite/interactive/lib-graph/ +/testsuite/interactive/lib-graph/# svn propset -R svn:ignore -F .svnignore . +/testsuite/interactive/lib-graph/# find . -name .svnignore -print | while read f; do svn propset svn:ignore -F $f `dirname $f`; done +/testsuite/interactive/lib-graph/_log +/testsuite/interactive/lib-graph/*.so +/testsuite/interactive/lib-graph/*.a +/testsuite/interactive/lib-graph/*.result +/testsuite/interactive/lib-graph/*.byte +/testsuite/interactive/lib-graph/*.native +/testsuite/interactive/lib-graph/program +/testsuite/interactive/lib-graph/*.cm* +/testsuite/interactive/lib-graph/*.o + +# /testsuite/interactive/lib-graph-2/ +/testsuite/interactive/lib-graph-2/# svn propset -R svn:ignore -F .svnignore . +/testsuite/interactive/lib-graph-2/# find . -name .svnignore -print | while read f; do svn propset svn:ignore -F $f `dirname $f`; done +/testsuite/interactive/lib-graph-2/_log +/testsuite/interactive/lib-graph-2/*.so +/testsuite/interactive/lib-graph-2/*.a +/testsuite/interactive/lib-graph-2/*.result +/testsuite/interactive/lib-graph-2/*.byte +/testsuite/interactive/lib-graph-2/*.native +/testsuite/interactive/lib-graph-2/program +/testsuite/interactive/lib-graph-2/*.cm* +/testsuite/interactive/lib-graph-2/*.o + +# /testsuite/interactive/lib-graph-3/ +/testsuite/interactive/lib-graph-3/# svn propset -R svn:ignore -F .svnignore . +/testsuite/interactive/lib-graph-3/# find . -name .svnignore -print | while read f; do svn propset svn:ignore -F $f `dirname $f`; done +/testsuite/interactive/lib-graph-3/_log +/testsuite/interactive/lib-graph-3/*.so +/testsuite/interactive/lib-graph-3/*.a +/testsuite/interactive/lib-graph-3/*.result +/testsuite/interactive/lib-graph-3/*.byte +/testsuite/interactive/lib-graph-3/*.native +/testsuite/interactive/lib-graph-3/program +/testsuite/interactive/lib-graph-3/*.cm* +/testsuite/interactive/lib-graph-3/*.o + +# /testsuite/interactive/lib-signals/ +/testsuite/interactive/lib-signals/# svn propset -R svn:ignore -F .svnignore . +/testsuite/interactive/lib-signals/# find . -name .svnignore -print | while read f; do svn propset svn:ignore -F $f `dirname $f`; done +/testsuite/interactive/lib-signals/_log +/testsuite/interactive/lib-signals/*.so +/testsuite/interactive/lib-signals/*.a +/testsuite/interactive/lib-signals/*.result +/testsuite/interactive/lib-signals/*.byte +/testsuite/interactive/lib-signals/*.native +/testsuite/interactive/lib-signals/program +/testsuite/interactive/lib-signals/*.cm* +/testsuite/interactive/lib-signals/*.o + +# /testsuite/lib/ +/testsuite/lib/*.o +/testsuite/lib/*.a +/testsuite/lib/*.so +/testsuite/lib/*.obj +/testsuite/lib/*.dll +/testsuite/lib/*.cm[ioxat] +/testsuite/lib/*.cmx[as] +/testsuite/lib/*.cmti +/testsuite/lib/*.annot +/testsuite/lib/*.result +/testsuite/lib/*.byte +/testsuite/lib/*.native +/testsuite/lib/program +/testsuite/lib/*.exe +/testsuite/lib/.depend +/testsuite/lib/.depend.nt +/testsuite/lib/.DS_Store + +# /testsuite/makefiles/ +/testsuite/makefiles/# svn propset -R svn:ignore -F .svnignore . +/testsuite/makefiles/# find . -name .svnignore -print | while read f; do svn propset svn:ignore -F $f `dirname $f`; done +/testsuite/makefiles/_log +/testsuite/makefiles/*.so +/testsuite/makefiles/*.a +/testsuite/makefiles/*.result +/testsuite/makefiles/*.byte +/testsuite/makefiles/*.native +/testsuite/makefiles/program +/testsuite/makefiles/*.cm* +/testsuite/makefiles/*.o + +# /testsuite/tests/ +/testsuite/tests/# svn propset -R svn:ignore -F .svnignore . +/testsuite/tests/# find . -name .svnignore -print | while read f; do svn propset svn:ignore -F $f `dirname $f`; done +/testsuite/tests/_log +/testsuite/tests/*.so +/testsuite/tests/*.a +/testsuite/tests/*.result +/testsuite/tests/*.byte +/testsuite/tests/*.native +/testsuite/tests/program +/testsuite/tests/*.cm* +/testsuite/tests/*.o + +# /testsuite/tests/asmcomp/ +/testsuite/tests/asmcomp/*.o +/testsuite/tests/asmcomp/*.a +/testsuite/tests/asmcomp/*.so +/testsuite/tests/asmcomp/*.obj +/testsuite/tests/asmcomp/*.lib +/testsuite/tests/asmcomp/*.dll +/testsuite/tests/asmcomp/*.cm[ioxat] +/testsuite/tests/asmcomp/*.cmx[as] +/testsuite/tests/asmcomp/*.cmti +/testsuite/tests/asmcomp/*.annot +/testsuite/tests/asmcomp/*.result +/testsuite/tests/asmcomp/*.byte +/testsuite/tests/asmcomp/*.native +/testsuite/tests/asmcomp/program +/testsuite/tests/asmcomp/*.exe +/testsuite/tests/asmcomp/*.exe.manifest +/testsuite/tests/asmcomp/.depend +/testsuite/tests/asmcomp/.depend.nt +/testsuite/tests/asmcomp/.DS_Store +/testsuite/tests/asmcomp/codegen +/testsuite/tests/asmcomp/parsecmm.ml +/testsuite/tests/asmcomp/parsecmm.mli +/testsuite/tests/asmcomp/lexcmm.ml +/testsuite/tests/asmcomp/*.s +/testsuite/tests/asmcomp/*.out +/testsuite/tests/asmcomp/*.out.dSYM + +# /testsuite/tests/backtrace/ +/testsuite/tests/backtrace/*.o +/testsuite/tests/backtrace/*.a +/testsuite/tests/backtrace/*.so +/testsuite/tests/backtrace/*.obj +/testsuite/tests/backtrace/*.lib +/testsuite/tests/backtrace/*.dll +/testsuite/tests/backtrace/*.cm[ioxat] +/testsuite/tests/backtrace/*.cmx[as] +/testsuite/tests/backtrace/*.cmti +/testsuite/tests/backtrace/*.annot +/testsuite/tests/backtrace/*.result +/testsuite/tests/backtrace/*.byte +/testsuite/tests/backtrace/*.native +/testsuite/tests/backtrace/program +/testsuite/tests/backtrace/*.exe +/testsuite/tests/backtrace/*.exe.manifest +/testsuite/tests/backtrace/.depend +/testsuite/tests/backtrace/.depend.nt +/testsuite/tests/backtrace/.DS_Store + +# /testsuite/tests/basic/ +/testsuite/tests/basic/*.o +/testsuite/tests/basic/*.a +/testsuite/tests/basic/*.so +/testsuite/tests/basic/*.obj +/testsuite/tests/basic/*.cm[ioxa] +/testsuite/tests/basic/*.cmx[as] +/testsuite/tests/basic/*.annot +/testsuite/tests/basic/*.result +/testsuite/tests/basic/*.byte +/testsuite/tests/basic/*.native +/testsuite/tests/basic/program +/testsuite/tests/basic/program.exe +/testsuite/tests/basic/.depend +/testsuite/tests/basic/.depend.nt +/testsuite/tests/basic/.DS_Store + +# /testsuite/tests/basic-float/ +/testsuite/tests/basic-float/*.o +/testsuite/tests/basic-float/*.a +/testsuite/tests/basic-float/*.so +/testsuite/tests/basic-float/*.obj +/testsuite/tests/basic-float/*.lib +/testsuite/tests/basic-float/*.dll +/testsuite/tests/basic-float/*.cm[ioxat] +/testsuite/tests/basic-float/*.cmx[as] +/testsuite/tests/basic-float/*.cmti +/testsuite/tests/basic-float/*.annot +/testsuite/tests/basic-float/*.result +/testsuite/tests/basic-float/*.byte +/testsuite/tests/basic-float/*.native +/testsuite/tests/basic-float/program +/testsuite/tests/basic-float/*.exe +/testsuite/tests/basic-float/*.exe.manifest +/testsuite/tests/basic-float/.depend +/testsuite/tests/basic-float/.depend.nt +/testsuite/tests/basic-float/.DS_Store + +# /testsuite/tests/basic-io/ +/testsuite/tests/basic-io/*.o +/testsuite/tests/basic-io/*.a +/testsuite/tests/basic-io/*.so +/testsuite/tests/basic-io/*.obj +/testsuite/tests/basic-io/*.lib +/testsuite/tests/basic-io/*.dll +/testsuite/tests/basic-io/*.cm[ioxat] +/testsuite/tests/basic-io/*.cmx[as] +/testsuite/tests/basic-io/*.cmti +/testsuite/tests/basic-io/*.annot +/testsuite/tests/basic-io/*.result +/testsuite/tests/basic-io/*.byte +/testsuite/tests/basic-io/*.native +/testsuite/tests/basic-io/program +/testsuite/tests/basic-io/*.exe +/testsuite/tests/basic-io/*.exe.manifest +/testsuite/tests/basic-io/.depend +/testsuite/tests/basic-io/.depend.nt +/testsuite/tests/basic-io/.DS_Store + +# /testsuite/tests/basic-io-2/ +/testsuite/tests/basic-io-2/*.o +/testsuite/tests/basic-io-2/*.a +/testsuite/tests/basic-io-2/*.so +/testsuite/tests/basic-io-2/*.obj +/testsuite/tests/basic-io-2/*.lib +/testsuite/tests/basic-io-2/*.dll +/testsuite/tests/basic-io-2/*.cm[ioxat] +/testsuite/tests/basic-io-2/*.cmx[as] +/testsuite/tests/basic-io-2/*.cmti +/testsuite/tests/basic-io-2/*.annot +/testsuite/tests/basic-io-2/*.result +/testsuite/tests/basic-io-2/*.byte +/testsuite/tests/basic-io-2/*.native +/testsuite/tests/basic-io-2/program +/testsuite/tests/basic-io-2/*.exe +/testsuite/tests/basic-io-2/*.exe.manifest +/testsuite/tests/basic-io-2/.depend +/testsuite/tests/basic-io-2/.depend.nt +/testsuite/tests/basic-io-2/.DS_Store + +# /testsuite/tests/basic-manyargs/ +/testsuite/tests/basic-manyargs/*.o +/testsuite/tests/basic-manyargs/*.a +/testsuite/tests/basic-manyargs/*.so +/testsuite/tests/basic-manyargs/*.obj +/testsuite/tests/basic-manyargs/*.lib +/testsuite/tests/basic-manyargs/*.dll +/testsuite/tests/basic-manyargs/*.cm[ioxat] +/testsuite/tests/basic-manyargs/*.cmx[as] +/testsuite/tests/basic-manyargs/*.cmti +/testsuite/tests/basic-manyargs/*.annot +/testsuite/tests/basic-manyargs/*.result +/testsuite/tests/basic-manyargs/*.byte +/testsuite/tests/basic-manyargs/*.native +/testsuite/tests/basic-manyargs/program +/testsuite/tests/basic-manyargs/*.exe +/testsuite/tests/basic-manyargs/*.exe.manifest +/testsuite/tests/basic-manyargs/.depend +/testsuite/tests/basic-manyargs/.depend.nt +/testsuite/tests/basic-manyargs/.DS_Store + +# /testsuite/tests/basic-modules/ +/testsuite/tests/basic-modules/*.o +/testsuite/tests/basic-modules/*.a +/testsuite/tests/basic-modules/*.so +/testsuite/tests/basic-modules/*.obj +/testsuite/tests/basic-modules/*.lib +/testsuite/tests/basic-modules/*.dll +/testsuite/tests/basic-modules/*.cm[ioxat] +/testsuite/tests/basic-modules/*.cmx[as] +/testsuite/tests/basic-modules/*.cmti +/testsuite/tests/basic-modules/*.annot +/testsuite/tests/basic-modules/*.result +/testsuite/tests/basic-modules/*.byte +/testsuite/tests/basic-modules/*.native +/testsuite/tests/basic-modules/program +/testsuite/tests/basic-modules/*.exe +/testsuite/tests/basic-modules/*.exe.manifest +/testsuite/tests/basic-modules/.depend +/testsuite/tests/basic-modules/.depend.nt +/testsuite/tests/basic-modules/.DS_Store + +# /testsuite/tests/basic-more/ +/testsuite/tests/basic-more/*.o +/testsuite/tests/basic-more/*.a +/testsuite/tests/basic-more/*.so +/testsuite/tests/basic-more/*.obj +/testsuite/tests/basic-more/*.cm[ioxa] +/testsuite/tests/basic-more/*.cmx[as] +/testsuite/tests/basic-more/*.annot +/testsuite/tests/basic-more/*.result +/testsuite/tests/basic-more/*.byte +/testsuite/tests/basic-more/*.native +/testsuite/tests/basic-more/program +/testsuite/tests/basic-more/program.exe +/testsuite/tests/basic-more/.depend +/testsuite/tests/basic-more/.depend.nt +/testsuite/tests/basic-more/.DS_Store + +# /testsuite/tests/basic-multdef/ +/testsuite/tests/basic-multdef/*.o +/testsuite/tests/basic-multdef/*.a +/testsuite/tests/basic-multdef/*.so +/testsuite/tests/basic-multdef/*.obj +/testsuite/tests/basic-multdef/*.lib +/testsuite/tests/basic-multdef/*.dll +/testsuite/tests/basic-multdef/*.cm[ioxat] +/testsuite/tests/basic-multdef/*.cmx[as] +/testsuite/tests/basic-multdef/*.cmti +/testsuite/tests/basic-multdef/*.annot +/testsuite/tests/basic-multdef/*.result +/testsuite/tests/basic-multdef/*.byte +/testsuite/tests/basic-multdef/*.native +/testsuite/tests/basic-multdef/program +/testsuite/tests/basic-multdef/*.exe +/testsuite/tests/basic-multdef/*.exe.manifest +/testsuite/tests/basic-multdef/.depend +/testsuite/tests/basic-multdef/.depend.nt +/testsuite/tests/basic-multdef/.DS_Store + +# /testsuite/tests/basic-private/ +/testsuite/tests/basic-private/*.o +/testsuite/tests/basic-private/*.a +/testsuite/tests/basic-private/*.so +/testsuite/tests/basic-private/*.obj +/testsuite/tests/basic-private/*.lib +/testsuite/tests/basic-private/*.dll +/testsuite/tests/basic-private/*.cm[ioxat] +/testsuite/tests/basic-private/*.cmx[as] +/testsuite/tests/basic-private/*.cmti +/testsuite/tests/basic-private/*.annot +/testsuite/tests/basic-private/*.result +/testsuite/tests/basic-private/*.byte +/testsuite/tests/basic-private/*.native +/testsuite/tests/basic-private/program +/testsuite/tests/basic-private/*.exe +/testsuite/tests/basic-private/*.exe.manifest +/testsuite/tests/basic-private/.depend +/testsuite/tests/basic-private/.depend.nt +/testsuite/tests/basic-private/.DS_Store + +# /testsuite/tests/callback/ +/testsuite/tests/callback/*.o +/testsuite/tests/callback/*.a +/testsuite/tests/callback/*.so +/testsuite/tests/callback/*.obj +/testsuite/tests/callback/*.cm[ioxa] +/testsuite/tests/callback/*.cmx[as] +/testsuite/tests/callback/*.annot +/testsuite/tests/callback/*.result +/testsuite/tests/callback/*.byte +/testsuite/tests/callback/*.native +/testsuite/tests/callback/program +/testsuite/tests/callback/program.exe +/testsuite/tests/callback/.depend +/testsuite/tests/callback/.depend.nt +/testsuite/tests/callback/.DS_Store + +# /testsuite/tests/embedded/ +/testsuite/tests/embedded/*.o +/testsuite/tests/embedded/*.a +/testsuite/tests/embedded/*.so +/testsuite/tests/embedded/*.obj +/testsuite/tests/embedded/*.lib +/testsuite/tests/embedded/*.dll +/testsuite/tests/embedded/*.cm[ioxat] +/testsuite/tests/embedded/*.cmx[as] +/testsuite/tests/embedded/*.cmti +/testsuite/tests/embedded/*.annot +/testsuite/tests/embedded/*.result +/testsuite/tests/embedded/*.byte +/testsuite/tests/embedded/*.native +/testsuite/tests/embedded/program +/testsuite/tests/embedded/*.exe +/testsuite/tests/embedded/*.exe.manifest +/testsuite/tests/embedded/.depend +/testsuite/tests/embedded/.depend.nt +/testsuite/tests/embedded/.DS_Store +/testsuite/tests/embedded/caml + +# /testsuite/tests/exotic-syntax/ +/testsuite/tests/exotic-syntax/*.o +/testsuite/tests/exotic-syntax/*.a +/testsuite/tests/exotic-syntax/*.so +/testsuite/tests/exotic-syntax/*.obj +/testsuite/tests/exotic-syntax/*.lib +/testsuite/tests/exotic-syntax/*.dll +/testsuite/tests/exotic-syntax/*.cm[ioxat] +/testsuite/tests/exotic-syntax/*.cmx[as] +/testsuite/tests/exotic-syntax/*.cmti +/testsuite/tests/exotic-syntax/*.annot +/testsuite/tests/exotic-syntax/*.result +/testsuite/tests/exotic-syntax/*.byte +/testsuite/tests/exotic-syntax/*.native +/testsuite/tests/exotic-syntax/program +/testsuite/tests/exotic-syntax/*.exe +/testsuite/tests/exotic-syntax/*.exe.manifest +/testsuite/tests/exotic-syntax/.depend +/testsuite/tests/exotic-syntax/.depend.nt +/testsuite/tests/exotic-syntax/.DS_Store + +# /testsuite/tests/formats-transition/ +/testsuite/tests/formats-transition/*.o +/testsuite/tests/formats-transition/*.a +/testsuite/tests/formats-transition/*.so +/testsuite/tests/formats-transition/*.obj +/testsuite/tests/formats-transition/*.lib +/testsuite/tests/formats-transition/*.dll +/testsuite/tests/formats-transition/*.cm[ioxat] +/testsuite/tests/formats-transition/*.cmx[as] +/testsuite/tests/formats-transition/*.cmti +/testsuite/tests/formats-transition/*.annot +/testsuite/tests/formats-transition/*.result +/testsuite/tests/formats-transition/*.byte +/testsuite/tests/formats-transition/*.native +/testsuite/tests/formats-transition/program +/testsuite/tests/formats-transition/*.exe +/testsuite/tests/formats-transition/*.exe.manifest +/testsuite/tests/formats-transition/.depend +/testsuite/tests/formats-transition/.depend.nt +/testsuite/tests/formats-transition/.DS_Store + +# /testsuite/tests/gc-roots/ +/testsuite/tests/gc-roots/*.o +/testsuite/tests/gc-roots/*.a +/testsuite/tests/gc-roots/*.so +/testsuite/tests/gc-roots/*.obj +/testsuite/tests/gc-roots/*.lib +/testsuite/tests/gc-roots/*.dll +/testsuite/tests/gc-roots/*.cm[ioxat] +/testsuite/tests/gc-roots/*.cmx[as] +/testsuite/tests/gc-roots/*.cmti +/testsuite/tests/gc-roots/*.annot +/testsuite/tests/gc-roots/*.result +/testsuite/tests/gc-roots/*.byte +/testsuite/tests/gc-roots/*.native +/testsuite/tests/gc-roots/program +/testsuite/tests/gc-roots/*.exe +/testsuite/tests/gc-roots/*.exe.manifest +/testsuite/tests/gc-roots/.depend +/testsuite/tests/gc-roots/.depend.nt +/testsuite/tests/gc-roots/.DS_Store + +# /testsuite/tests/letrec/ +/testsuite/tests/letrec/*.o +/testsuite/tests/letrec/*.a +/testsuite/tests/letrec/*.so +/testsuite/tests/letrec/*.obj +/testsuite/tests/letrec/*.cm[ioxa] +/testsuite/tests/letrec/*.cmx[as] +/testsuite/tests/letrec/*.annot +/testsuite/tests/letrec/*.result +/testsuite/tests/letrec/*.byte +/testsuite/tests/letrec/*.native +/testsuite/tests/letrec/program +/testsuite/tests/letrec/program.exe +/testsuite/tests/letrec/.depend +/testsuite/tests/letrec/.depend.nt +/testsuite/tests/letrec/.DS_Store + +# /testsuite/tests/lib-bigarray/ +/testsuite/tests/lib-bigarray/*.o +/testsuite/tests/lib-bigarray/*.a +/testsuite/tests/lib-bigarray/*.so +/testsuite/tests/lib-bigarray/*.obj +/testsuite/tests/lib-bigarray/*.lib +/testsuite/tests/lib-bigarray/*.dll +/testsuite/tests/lib-bigarray/*.cm[ioxat] +/testsuite/tests/lib-bigarray/*.cmx[as] +/testsuite/tests/lib-bigarray/*.cmti +/testsuite/tests/lib-bigarray/*.annot +/testsuite/tests/lib-bigarray/*.result +/testsuite/tests/lib-bigarray/*.byte +/testsuite/tests/lib-bigarray/*.native +/testsuite/tests/lib-bigarray/program +/testsuite/tests/lib-bigarray/*.exe +/testsuite/tests/lib-bigarray/*.exe.manifest +/testsuite/tests/lib-bigarray/.depend +/testsuite/tests/lib-bigarray/.depend.nt +/testsuite/tests/lib-bigarray/.DS_Store + +# /testsuite/tests/lib-bigarray-2/ +/testsuite/tests/lib-bigarray-2/# svn propset -R svn:ignore -F .svnignore . +/testsuite/tests/lib-bigarray-2/# find . -name .svnignore -print | while read f; do svn propset svn:ignore -F $f `dirname $f`; done +/testsuite/tests/lib-bigarray-2/_log +/testsuite/tests/lib-bigarray-2/*.so +/testsuite/tests/lib-bigarray-2/*.a +/testsuite/tests/lib-bigarray-2/*.result +/testsuite/tests/lib-bigarray-2/*.byte +/testsuite/tests/lib-bigarray-2/*.native +/testsuite/tests/lib-bigarray-2/program +/testsuite/tests/lib-bigarray-2/*.cm* +/testsuite/tests/lib-bigarray-2/*.o + +# /testsuite/tests/lib-digest/ +/testsuite/tests/lib-digest/*.o +/testsuite/tests/lib-digest/*.a +/testsuite/tests/lib-digest/*.so +/testsuite/tests/lib-digest/*.obj +/testsuite/tests/lib-digest/*.lib +/testsuite/tests/lib-digest/*.dll +/testsuite/tests/lib-digest/*.cm[ioxat] +/testsuite/tests/lib-digest/*.cmx[as] +/testsuite/tests/lib-digest/*.cmti +/testsuite/tests/lib-digest/*.annot +/testsuite/tests/lib-digest/*.result +/testsuite/tests/lib-digest/*.byte +/testsuite/tests/lib-digest/*.native +/testsuite/tests/lib-digest/program +/testsuite/tests/lib-digest/*.exe +/testsuite/tests/lib-digest/*.exe.manifest +/testsuite/tests/lib-digest/.depend +/testsuite/tests/lib-digest/.depend.nt +/testsuite/tests/lib-digest/.DS_Store + +# /testsuite/tests/lib-dynlink-bytecode/ +/testsuite/tests/lib-dynlink-bytecode/*.o +/testsuite/tests/lib-dynlink-bytecode/*.a +/testsuite/tests/lib-dynlink-bytecode/*.so +/testsuite/tests/lib-dynlink-bytecode/*.obj +/testsuite/tests/lib-dynlink-bytecode/*.lib +/testsuite/tests/lib-dynlink-bytecode/*.dll +/testsuite/tests/lib-dynlink-bytecode/*.cm[ioxat] +/testsuite/tests/lib-dynlink-bytecode/*.cmx[as] +/testsuite/tests/lib-dynlink-bytecode/*.cmti +/testsuite/tests/lib-dynlink-bytecode/*.annot +/testsuite/tests/lib-dynlink-bytecode/*.result +/testsuite/tests/lib-dynlink-bytecode/*.byte +/testsuite/tests/lib-dynlink-bytecode/*.native +/testsuite/tests/lib-dynlink-bytecode/program +/testsuite/tests/lib-dynlink-bytecode/*.exe +/testsuite/tests/lib-dynlink-bytecode/*.exe.manifest +/testsuite/tests/lib-dynlink-bytecode/.depend +/testsuite/tests/lib-dynlink-bytecode/.depend.nt +/testsuite/tests/lib-dynlink-bytecode/.DS_Store +/testsuite/tests/lib-dynlink-bytecode/main +/testsuite/tests/lib-dynlink-bytecode/static +/testsuite/tests/lib-dynlink-bytecode/custom +/testsuite/tests/lib-dynlink-bytecode/custom.exe +/testsuite/tests/lib-dynlink-bytecode/marshal.data +/testsuite/tests/lib-dynlink-bytecode/caml + +# /testsuite/tests/lib-dynlink-csharp/ +/testsuite/tests/lib-dynlink-csharp/*.o +/testsuite/tests/lib-dynlink-csharp/*.a +/testsuite/tests/lib-dynlink-csharp/*.so +/testsuite/tests/lib-dynlink-csharp/*.obj +/testsuite/tests/lib-dynlink-csharp/*.lib +/testsuite/tests/lib-dynlink-csharp/*.dll +/testsuite/tests/lib-dynlink-csharp/*.cm[ioxat] +/testsuite/tests/lib-dynlink-csharp/*.cmx[as] +/testsuite/tests/lib-dynlink-csharp/*.cmti +/testsuite/tests/lib-dynlink-csharp/*.annot +/testsuite/tests/lib-dynlink-csharp/*.result +/testsuite/tests/lib-dynlink-csharp/*.byte +/testsuite/tests/lib-dynlink-csharp/*.native +/testsuite/tests/lib-dynlink-csharp/program +/testsuite/tests/lib-dynlink-csharp/*.exe +/testsuite/tests/lib-dynlink-csharp/*.exe.manifest +/testsuite/tests/lib-dynlink-csharp/.depend +/testsuite/tests/lib-dynlink-csharp/.depend.nt +/testsuite/tests/lib-dynlink-csharp/.DS_Store + +# /testsuite/tests/lib-dynlink-native/ +/testsuite/tests/lib-dynlink-native/*.o +/testsuite/tests/lib-dynlink-native/*.a +/testsuite/tests/lib-dynlink-native/*.so +/testsuite/tests/lib-dynlink-native/*.obj +/testsuite/tests/lib-dynlink-native/*.lib +/testsuite/tests/lib-dynlink-native/*.dll +/testsuite/tests/lib-dynlink-native/*.cm[ioxat] +/testsuite/tests/lib-dynlink-native/*.cmx[as] +/testsuite/tests/lib-dynlink-native/*.cmti +/testsuite/tests/lib-dynlink-native/*.annot +/testsuite/tests/lib-dynlink-native/*.result +/testsuite/tests/lib-dynlink-native/*.byte +/testsuite/tests/lib-dynlink-native/*.native +/testsuite/tests/lib-dynlink-native/program +/testsuite/tests/lib-dynlink-native/*.exe +/testsuite/tests/lib-dynlink-native/*.exe.manifest +/testsuite/tests/lib-dynlink-native/.depend +/testsuite/tests/lib-dynlink-native/.depend.nt +/testsuite/tests/lib-dynlink-native/.DS_Store +/testsuite/tests/lib-dynlink-native/mypack.pack.s +/testsuite/tests/lib-dynlink-native/mypack.pack.asm +/testsuite/tests/lib-dynlink-native/result +/testsuite/tests/lib-dynlink-native/main +/testsuite/tests/lib-dynlink-native/main.exe +/testsuite/tests/lib-dynlink-native/marshal.data +/testsuite/tests/lib-dynlink-native/caml + +# /testsuite/tests/lib-dynlink-native/sub/ +/testsuite/tests/lib-dynlink-native/sub/*.o +/testsuite/tests/lib-dynlink-native/sub/*.a +/testsuite/tests/lib-dynlink-native/sub/*.so +/testsuite/tests/lib-dynlink-native/sub/*.obj +/testsuite/tests/lib-dynlink-native/sub/*.lib +/testsuite/tests/lib-dynlink-native/sub/*.dll +/testsuite/tests/lib-dynlink-native/sub/*.cm[ioxat] +/testsuite/tests/lib-dynlink-native/sub/*.cmx[as] +/testsuite/tests/lib-dynlink-native/sub/*.cmti +/testsuite/tests/lib-dynlink-native/sub/*.annot +/testsuite/tests/lib-dynlink-native/sub/*.result +/testsuite/tests/lib-dynlink-native/sub/*.byte +/testsuite/tests/lib-dynlink-native/sub/*.native +/testsuite/tests/lib-dynlink-native/sub/program +/testsuite/tests/lib-dynlink-native/sub/*.exe +/testsuite/tests/lib-dynlink-native/sub/*.exe.manifest +/testsuite/tests/lib-dynlink-native/sub/.depend +/testsuite/tests/lib-dynlink-native/sub/.depend.nt +/testsuite/tests/lib-dynlink-native/sub/.DS_Store + +# /testsuite/tests/lib-format/ +/testsuite/tests/lib-format/*.o +/testsuite/tests/lib-format/*.a +/testsuite/tests/lib-format/*.so +/testsuite/tests/lib-format/*.obj +/testsuite/tests/lib-format/*.lib +/testsuite/tests/lib-format/*.dll +/testsuite/tests/lib-format/*.cm[ioxat] +/testsuite/tests/lib-format/*.cmx[as] +/testsuite/tests/lib-format/*.cmti +/testsuite/tests/lib-format/*.annot +/testsuite/tests/lib-format/*.result +/testsuite/tests/lib-format/*.byte +/testsuite/tests/lib-format/*.native +/testsuite/tests/lib-format/program +/testsuite/tests/lib-format/*.exe +/testsuite/tests/lib-format/*.exe.manifest +/testsuite/tests/lib-format/.depend +/testsuite/tests/lib-format/.depend.nt +/testsuite/tests/lib-format/.DS_Store + +# /testsuite/tests/lib-hashtbl/ +/testsuite/tests/lib-hashtbl/*.o +/testsuite/tests/lib-hashtbl/*.a +/testsuite/tests/lib-hashtbl/*.so +/testsuite/tests/lib-hashtbl/*.obj +/testsuite/tests/lib-hashtbl/*.cm[ioxa] +/testsuite/tests/lib-hashtbl/*.cmx[as] +/testsuite/tests/lib-hashtbl/*.annot +/testsuite/tests/lib-hashtbl/*.result +/testsuite/tests/lib-hashtbl/*.byte +/testsuite/tests/lib-hashtbl/*.native +/testsuite/tests/lib-hashtbl/program +/testsuite/tests/lib-hashtbl/program.exe +/testsuite/tests/lib-hashtbl/.depend +/testsuite/tests/lib-hashtbl/.depend.nt +/testsuite/tests/lib-hashtbl/.DS_Store + +# /testsuite/tests/lib-marshal/ +/testsuite/tests/lib-marshal/*.o +/testsuite/tests/lib-marshal/*.a +/testsuite/tests/lib-marshal/*.so +/testsuite/tests/lib-marshal/*.obj +/testsuite/tests/lib-marshal/*.lib +/testsuite/tests/lib-marshal/*.dll +/testsuite/tests/lib-marshal/*.cm[ioxat] +/testsuite/tests/lib-marshal/*.cmx[as] +/testsuite/tests/lib-marshal/*.cmti +/testsuite/tests/lib-marshal/*.annot +/testsuite/tests/lib-marshal/*.result +/testsuite/tests/lib-marshal/*.byte +/testsuite/tests/lib-marshal/*.native +/testsuite/tests/lib-marshal/program +/testsuite/tests/lib-marshal/*.exe +/testsuite/tests/lib-marshal/*.exe.manifest +/testsuite/tests/lib-marshal/.depend +/testsuite/tests/lib-marshal/.depend.nt +/testsuite/tests/lib-marshal/.DS_Store + +# /testsuite/tests/lib-num/ +/testsuite/tests/lib-num/*.o +/testsuite/tests/lib-num/*.a +/testsuite/tests/lib-num/*.so +/testsuite/tests/lib-num/*.obj +/testsuite/tests/lib-num/*.lib +/testsuite/tests/lib-num/*.dll +/testsuite/tests/lib-num/*.cm[ioxat] +/testsuite/tests/lib-num/*.cmx[as] +/testsuite/tests/lib-num/*.cmti +/testsuite/tests/lib-num/*.annot +/testsuite/tests/lib-num/*.result +/testsuite/tests/lib-num/*.byte +/testsuite/tests/lib-num/*.native +/testsuite/tests/lib-num/program +/testsuite/tests/lib-num/*.exe +/testsuite/tests/lib-num/*.exe.manifest +/testsuite/tests/lib-num/.depend +/testsuite/tests/lib-num/.depend.nt +/testsuite/tests/lib-num/.DS_Store + +# /testsuite/tests/lib-num-2/ +/testsuite/tests/lib-num-2/*.o +/testsuite/tests/lib-num-2/*.a +/testsuite/tests/lib-num-2/*.so +/testsuite/tests/lib-num-2/*.obj +/testsuite/tests/lib-num-2/*.cm[ioxa] +/testsuite/tests/lib-num-2/*.cmx[as] +/testsuite/tests/lib-num-2/*.annot +/testsuite/tests/lib-num-2/*.result +/testsuite/tests/lib-num-2/*.byte +/testsuite/tests/lib-num-2/*.native +/testsuite/tests/lib-num-2/program +/testsuite/tests/lib-num-2/program.exe +/testsuite/tests/lib-num-2/.depend +/testsuite/tests/lib-num-2/.depend.nt +/testsuite/tests/lib-num-2/.DS_Store + +# /testsuite/tests/lib-printf/ +/testsuite/tests/lib-printf/*.o +/testsuite/tests/lib-printf/*.a +/testsuite/tests/lib-printf/*.so +/testsuite/tests/lib-printf/*.obj +/testsuite/tests/lib-printf/*.lib +/testsuite/tests/lib-printf/*.dll +/testsuite/tests/lib-printf/*.cm[ioxat] +/testsuite/tests/lib-printf/*.cmx[as] +/testsuite/tests/lib-printf/*.cmti +/testsuite/tests/lib-printf/*.annot +/testsuite/tests/lib-printf/*.result +/testsuite/tests/lib-printf/*.byte +/testsuite/tests/lib-printf/*.native +/testsuite/tests/lib-printf/program +/testsuite/tests/lib-printf/*.exe +/testsuite/tests/lib-printf/*.exe.manifest +/testsuite/tests/lib-printf/.depend +/testsuite/tests/lib-printf/.depend.nt +/testsuite/tests/lib-printf/.DS_Store + +# /testsuite/tests/lib-random/ +/testsuite/tests/lib-random/*.o +/testsuite/tests/lib-random/*.a +/testsuite/tests/lib-random/*.so +/testsuite/tests/lib-random/*.obj +/testsuite/tests/lib-random/*.lib +/testsuite/tests/lib-random/*.dll +/testsuite/tests/lib-random/*.cm[ioxat] +/testsuite/tests/lib-random/*.cmx[as] +/testsuite/tests/lib-random/*.cmti +/testsuite/tests/lib-random/*.annot +/testsuite/tests/lib-random/*.result +/testsuite/tests/lib-random/*.byte +/testsuite/tests/lib-random/*.native +/testsuite/tests/lib-random/program +/testsuite/tests/lib-random/*.exe +/testsuite/tests/lib-random/*.exe.manifest +/testsuite/tests/lib-random/.depend +/testsuite/tests/lib-random/.depend.nt +/testsuite/tests/lib-random/.DS_Store + +# /testsuite/tests/lib-scanf/ +/testsuite/tests/lib-scanf/*.o +/testsuite/tests/lib-scanf/*.a +/testsuite/tests/lib-scanf/*.so +/testsuite/tests/lib-scanf/*.obj +/testsuite/tests/lib-scanf/*.lib +/testsuite/tests/lib-scanf/*.dll +/testsuite/tests/lib-scanf/*.cm[ioxat] +/testsuite/tests/lib-scanf/*.cmx[as] +/testsuite/tests/lib-scanf/*.cmti +/testsuite/tests/lib-scanf/*.annot +/testsuite/tests/lib-scanf/*.result +/testsuite/tests/lib-scanf/*.byte +/testsuite/tests/lib-scanf/*.native +/testsuite/tests/lib-scanf/program +/testsuite/tests/lib-scanf/*.exe +/testsuite/tests/lib-scanf/*.exe.manifest +/testsuite/tests/lib-scanf/.depend +/testsuite/tests/lib-scanf/.depend.nt +/testsuite/tests/lib-scanf/.DS_Store +/testsuite/tests/lib-scanf/tscanf_data + +# /testsuite/tests/lib-scanf-2/ +/testsuite/tests/lib-scanf-2/*.o +/testsuite/tests/lib-scanf-2/*.a +/testsuite/tests/lib-scanf-2/*.so +/testsuite/tests/lib-scanf-2/*.obj +/testsuite/tests/lib-scanf-2/*.lib +/testsuite/tests/lib-scanf-2/*.dll +/testsuite/tests/lib-scanf-2/*.cm[ioxat] +/testsuite/tests/lib-scanf-2/*.cmx[as] +/testsuite/tests/lib-scanf-2/*.cmti +/testsuite/tests/lib-scanf-2/*.annot +/testsuite/tests/lib-scanf-2/*.result +/testsuite/tests/lib-scanf-2/*.byte +/testsuite/tests/lib-scanf-2/*.native +/testsuite/tests/lib-scanf-2/program +/testsuite/tests/lib-scanf-2/*.exe +/testsuite/tests/lib-scanf-2/*.exe.manifest +/testsuite/tests/lib-scanf-2/.depend +/testsuite/tests/lib-scanf-2/.depend.nt +/testsuite/tests/lib-scanf-2/.DS_Store + +# /testsuite/tests/lib-set/ +/testsuite/tests/lib-set/*.o +/testsuite/tests/lib-set/*.a +/testsuite/tests/lib-set/*.so +/testsuite/tests/lib-set/*.obj +/testsuite/tests/lib-set/*.cm[ioxa] +/testsuite/tests/lib-set/*.cmx[as] +/testsuite/tests/lib-set/*.annot +/testsuite/tests/lib-set/*.result +/testsuite/tests/lib-set/*.byte +/testsuite/tests/lib-set/*.native +/testsuite/tests/lib-set/program +/testsuite/tests/lib-set/program.exe +/testsuite/tests/lib-set/.depend +/testsuite/tests/lib-set/.depend.nt +/testsuite/tests/lib-set/.DS_Store + +# /testsuite/tests/lib-str/ +/testsuite/tests/lib-str/*.o +/testsuite/tests/lib-str/*.a +/testsuite/tests/lib-str/*.so +/testsuite/tests/lib-str/*.obj +/testsuite/tests/lib-str/*.cm[ioxa] +/testsuite/tests/lib-str/*.cmx[as] +/testsuite/tests/lib-str/*.annot +/testsuite/tests/lib-str/*.result +/testsuite/tests/lib-str/*.byte +/testsuite/tests/lib-str/*.native +/testsuite/tests/lib-str/program +/testsuite/tests/lib-str/program.exe +/testsuite/tests/lib-str/.depend +/testsuite/tests/lib-str/.depend.nt +/testsuite/tests/lib-str/.DS_Store + +# /testsuite/tests/lib-stream/ +/testsuite/tests/lib-stream/*.o +/testsuite/tests/lib-stream/*.a +/testsuite/tests/lib-stream/*.so +/testsuite/tests/lib-stream/*.obj +/testsuite/tests/lib-stream/*.cm[ioxa] +/testsuite/tests/lib-stream/*.cmx[as] +/testsuite/tests/lib-stream/*.annot +/testsuite/tests/lib-stream/*.result +/testsuite/tests/lib-stream/*.byte +/testsuite/tests/lib-stream/*.native +/testsuite/tests/lib-stream/program +/testsuite/tests/lib-stream/program.exe +/testsuite/tests/lib-stream/.depend +/testsuite/tests/lib-stream/.depend.nt +/testsuite/tests/lib-stream/.DS_Store + +# /testsuite/tests/lib-systhreads/ +/testsuite/tests/lib-systhreads/*.o +/testsuite/tests/lib-systhreads/*.a +/testsuite/tests/lib-systhreads/*.so +/testsuite/tests/lib-systhreads/*.obj +/testsuite/tests/lib-systhreads/*.cm[ioxa] +/testsuite/tests/lib-systhreads/*.cmx[as] +/testsuite/tests/lib-systhreads/*.annot +/testsuite/tests/lib-systhreads/*.result +/testsuite/tests/lib-systhreads/*.byte +/testsuite/tests/lib-systhreads/*.native +/testsuite/tests/lib-systhreads/program +/testsuite/tests/lib-systhreads/program.exe +/testsuite/tests/lib-systhreads/.depend +/testsuite/tests/lib-systhreads/.depend.nt +/testsuite/tests/lib-systhreads/.DS_Store + +# /testsuite/tests/lib-threads/ +/testsuite/tests/lib-threads/*.o +/testsuite/tests/lib-threads/*.a +/testsuite/tests/lib-threads/*.so +/testsuite/tests/lib-threads/*.obj +/testsuite/tests/lib-threads/*.cm[ioxa] +/testsuite/tests/lib-threads/*.cmx[as] +/testsuite/tests/lib-threads/*.annot +/testsuite/tests/lib-threads/*.result +/testsuite/tests/lib-threads/*.byte +/testsuite/tests/lib-threads/*.native +/testsuite/tests/lib-threads/program +/testsuite/tests/lib-threads/program.exe +/testsuite/tests/lib-threads/.depend +/testsuite/tests/lib-threads/.depend.nt +/testsuite/tests/lib-threads/.DS_Store +/testsuite/tests/lib-threads/*.byt + +# /testsuite/tests/match-exception/ +/testsuite/tests/match-exception/*.o +/testsuite/tests/match-exception/*.a +/testsuite/tests/match-exception/*.so +/testsuite/tests/match-exception/*.obj +/testsuite/tests/match-exception/*.lib +/testsuite/tests/match-exception/*.dll +/testsuite/tests/match-exception/*.cm[ioxat] +/testsuite/tests/match-exception/*.cmx[as] +/testsuite/tests/match-exception/*.cmti +/testsuite/tests/match-exception/*.annot +/testsuite/tests/match-exception/*.result +/testsuite/tests/match-exception/*.byte +/testsuite/tests/match-exception/*.native +/testsuite/tests/match-exception/program +/testsuite/tests/match-exception/*.exe +/testsuite/tests/match-exception/*.exe.manifest +/testsuite/tests/match-exception/.depend +/testsuite/tests/match-exception/.depend.nt +/testsuite/tests/match-exception/.DS_Store + +# /testsuite/tests/match-exception-warnings/ +/testsuite/tests/match-exception-warnings/*.o +/testsuite/tests/match-exception-warnings/*.a +/testsuite/tests/match-exception-warnings/*.so +/testsuite/tests/match-exception-warnings/*.obj +/testsuite/tests/match-exception-warnings/*.lib +/testsuite/tests/match-exception-warnings/*.dll +/testsuite/tests/match-exception-warnings/*.cm[ioxat] +/testsuite/tests/match-exception-warnings/*.cmx[as] +/testsuite/tests/match-exception-warnings/*.cmti +/testsuite/tests/match-exception-warnings/*.annot +/testsuite/tests/match-exception-warnings/*.result +/testsuite/tests/match-exception-warnings/*.byte +/testsuite/tests/match-exception-warnings/*.native +/testsuite/tests/match-exception-warnings/program +/testsuite/tests/match-exception-warnings/*.exe +/testsuite/tests/match-exception-warnings/*.exe.manifest +/testsuite/tests/match-exception-warnings/.depend +/testsuite/tests/match-exception-warnings/.depend.nt +/testsuite/tests/match-exception-warnings/.DS_Store + +# /testsuite/tests/misc/ +/testsuite/tests/misc/*.o +/testsuite/tests/misc/*.a +/testsuite/tests/misc/*.so +/testsuite/tests/misc/*.obj +/testsuite/tests/misc/*.cm[ioxa] +/testsuite/tests/misc/*.cmx[as] +/testsuite/tests/misc/*.annot +/testsuite/tests/misc/*.result +/testsuite/tests/misc/*.byte +/testsuite/tests/misc/*.native +/testsuite/tests/misc/program +/testsuite/tests/misc/program.exe +/testsuite/tests/misc/.depend +/testsuite/tests/misc/.depend.nt +/testsuite/tests/misc/.DS_Store + +# /testsuite/tests/misc-kb/ +/testsuite/tests/misc-kb/*.o +/testsuite/tests/misc-kb/*.a +/testsuite/tests/misc-kb/*.so +/testsuite/tests/misc-kb/*.obj +/testsuite/tests/misc-kb/*.lib +/testsuite/tests/misc-kb/*.dll +/testsuite/tests/misc-kb/*.cm[ioxat] +/testsuite/tests/misc-kb/*.cmx[as] +/testsuite/tests/misc-kb/*.cmti +/testsuite/tests/misc-kb/*.annot +/testsuite/tests/misc-kb/*.result +/testsuite/tests/misc-kb/*.byte +/testsuite/tests/misc-kb/*.native +/testsuite/tests/misc-kb/program +/testsuite/tests/misc-kb/*.exe +/testsuite/tests/misc-kb/*.exe.manifest +/testsuite/tests/misc-kb/.depend +/testsuite/tests/misc-kb/.depend.nt +/testsuite/tests/misc-kb/.DS_Store + +# /testsuite/tests/misc-unsafe/ +/testsuite/tests/misc-unsafe/*.o +/testsuite/tests/misc-unsafe/*.a +/testsuite/tests/misc-unsafe/*.so +/testsuite/tests/misc-unsafe/*.obj +/testsuite/tests/misc-unsafe/*.cm[ioxa] +/testsuite/tests/misc-unsafe/*.cmx[as] +/testsuite/tests/misc-unsafe/*.annot +/testsuite/tests/misc-unsafe/*.result +/testsuite/tests/misc-unsafe/*.byte +/testsuite/tests/misc-unsafe/*.native +/testsuite/tests/misc-unsafe/program +/testsuite/tests/misc-unsafe/program.exe +/testsuite/tests/misc-unsafe/.depend +/testsuite/tests/misc-unsafe/.depend.nt +/testsuite/tests/misc-unsafe/.DS_Store + +# /testsuite/tests/prim-bigstring/ +/testsuite/tests/prim-bigstring/*.o +/testsuite/tests/prim-bigstring/*.a +/testsuite/tests/prim-bigstring/*.so +/testsuite/tests/prim-bigstring/*.obj +/testsuite/tests/prim-bigstring/*.lib +/testsuite/tests/prim-bigstring/*.dll +/testsuite/tests/prim-bigstring/*.cm[ioxat] +/testsuite/tests/prim-bigstring/*.cmx[as] +/testsuite/tests/prim-bigstring/*.cmti +/testsuite/tests/prim-bigstring/*.annot +/testsuite/tests/prim-bigstring/*.result +/testsuite/tests/prim-bigstring/*.byte +/testsuite/tests/prim-bigstring/*.native +/testsuite/tests/prim-bigstring/program +/testsuite/tests/prim-bigstring/*.exe +/testsuite/tests/prim-bigstring/*.exe.manifest +/testsuite/tests/prim-bigstring/.depend +/testsuite/tests/prim-bigstring/.depend.nt +/testsuite/tests/prim-bigstring/.DS_Store + +# /testsuite/tests/prim-bswap/ +/testsuite/tests/prim-bswap/*.o +/testsuite/tests/prim-bswap/*.a +/testsuite/tests/prim-bswap/*.so +/testsuite/tests/prim-bswap/*.obj +/testsuite/tests/prim-bswap/*.cm[ioxat] +/testsuite/tests/prim-bswap/*.cmx[as] +/testsuite/tests/prim-bswap/*.cmti +/testsuite/tests/prim-bswap/*.annot +/testsuite/tests/prim-bswap/*.result +/testsuite/tests/prim-bswap/*.byte +/testsuite/tests/prim-bswap/*.native +/testsuite/tests/prim-bswap/program +/testsuite/tests/prim-bswap/program.exe +/testsuite/tests/prim-bswap/.depend +/testsuite/tests/prim-bswap/.depend.nt +/testsuite/tests/prim-bswap/.DS_Store + +# /testsuite/tests/prim-revapply/ +/testsuite/tests/prim-revapply/*.o +/testsuite/tests/prim-revapply/*.a +/testsuite/tests/prim-revapply/*.so +/testsuite/tests/prim-revapply/*.obj +/testsuite/tests/prim-revapply/*.cm[ioxa] +/testsuite/tests/prim-revapply/*.cmx[as] +/testsuite/tests/prim-revapply/*.annot +/testsuite/tests/prim-revapply/*.result +/testsuite/tests/prim-revapply/*.byte +/testsuite/tests/prim-revapply/*.native +/testsuite/tests/prim-revapply/program +/testsuite/tests/prim-revapply/program.exe +/testsuite/tests/prim-revapply/.depend +/testsuite/tests/prim-revapply/.depend.nt +/testsuite/tests/prim-revapply/.DS_Store + +# /testsuite/tests/regression/pr5080-notes/ +/testsuite/tests/regression/pr5080-notes/*.o +/testsuite/tests/regression/pr5080-notes/*.a +/testsuite/tests/regression/pr5080-notes/*.so +/testsuite/tests/regression/pr5080-notes/*.obj +/testsuite/tests/regression/pr5080-notes/*.cm[ioxa] +/testsuite/tests/regression/pr5080-notes/*.cmx[as] +/testsuite/tests/regression/pr5080-notes/*.annot +/testsuite/tests/regression/pr5080-notes/*.result +/testsuite/tests/regression/pr5080-notes/*.byte +/testsuite/tests/regression/pr5080-notes/*.native +/testsuite/tests/regression/pr5080-notes/program +/testsuite/tests/regression/pr5080-notes/program.exe +/testsuite/tests/regression/pr5080-notes/.depend +/testsuite/tests/regression/pr5080-notes/.depend.nt +/testsuite/tests/regression/pr5080-notes/.DS_Store + +# /testsuite/tests/regression/pr5233/ +/testsuite/tests/regression/pr5233/*.o +/testsuite/tests/regression/pr5233/*.a +/testsuite/tests/regression/pr5233/*.so +/testsuite/tests/regression/pr5233/*.obj +/testsuite/tests/regression/pr5233/*.lib +/testsuite/tests/regression/pr5233/*.dll +/testsuite/tests/regression/pr5233/*.cm[ioxat] +/testsuite/tests/regression/pr5233/*.cmx[as] +/testsuite/tests/regression/pr5233/*.cmti +/testsuite/tests/regression/pr5233/*.annot +/testsuite/tests/regression/pr5233/*.result +/testsuite/tests/regression/pr5233/*.byte +/testsuite/tests/regression/pr5233/*.native +/testsuite/tests/regression/pr5233/program +/testsuite/tests/regression/pr5233/*.exe +/testsuite/tests/regression/pr5233/*.exe.manifest +/testsuite/tests/regression/pr5233/.depend +/testsuite/tests/regression/pr5233/.depend.nt +/testsuite/tests/regression/pr5233/.DS_Store + +# /testsuite/tests/regression/pr5757/ +/testsuite/tests/regression/pr5757/*.o +/testsuite/tests/regression/pr5757/*.a +/testsuite/tests/regression/pr5757/*.so +/testsuite/tests/regression/pr5757/*.obj +/testsuite/tests/regression/pr5757/*.lib +/testsuite/tests/regression/pr5757/*.dll +/testsuite/tests/regression/pr5757/*.cm[ioxat] +/testsuite/tests/regression/pr5757/*.cmx[as] +/testsuite/tests/regression/pr5757/*.cmti +/testsuite/tests/regression/pr5757/*.annot +/testsuite/tests/regression/pr5757/*.result +/testsuite/tests/regression/pr5757/*.byte +/testsuite/tests/regression/pr5757/*.native +/testsuite/tests/regression/pr5757/program +/testsuite/tests/regression/pr5757/*.exe +/testsuite/tests/regression/pr5757/*.exe.manifest +/testsuite/tests/regression/pr5757/.depend +/testsuite/tests/regression/pr5757/.depend.nt +/testsuite/tests/regression/pr5757/.DS_Store + +# /testsuite/tests/regression/pr6024/ +/testsuite/tests/regression/pr6024/*.o +/testsuite/tests/regression/pr6024/*.a +/testsuite/tests/regression/pr6024/*.so +/testsuite/tests/regression/pr6024/*.obj +/testsuite/tests/regression/pr6024/*.lib +/testsuite/tests/regression/pr6024/*.dll +/testsuite/tests/regression/pr6024/*.cm[ioxat] +/testsuite/tests/regression/pr6024/*.cmx[as] +/testsuite/tests/regression/pr6024/*.cmti +/testsuite/tests/regression/pr6024/*.annot +/testsuite/tests/regression/pr6024/*.result +/testsuite/tests/regression/pr6024/*.byte +/testsuite/tests/regression/pr6024/*.native +/testsuite/tests/regression/pr6024/program +/testsuite/tests/regression/pr6024/*.exe +/testsuite/tests/regression/pr6024/*.exe.manifest +/testsuite/tests/regression/pr6024/.depend +/testsuite/tests/regression/pr6024/.depend.nt +/testsuite/tests/regression/pr6024/.DS_Store + +# /testsuite/tests/runtime-errors/ +/testsuite/tests/runtime-errors/*.o +/testsuite/tests/runtime-errors/*.a +/testsuite/tests/runtime-errors/*.so +/testsuite/tests/runtime-errors/*.obj +/testsuite/tests/runtime-errors/*.lib +/testsuite/tests/runtime-errors/*.dll +/testsuite/tests/runtime-errors/*.cm[ioxat] +/testsuite/tests/runtime-errors/*.cmx[as] +/testsuite/tests/runtime-errors/*.cmti +/testsuite/tests/runtime-errors/*.annot +/testsuite/tests/runtime-errors/*.result +/testsuite/tests/runtime-errors/*.byte +/testsuite/tests/runtime-errors/*.native +/testsuite/tests/runtime-errors/program +/testsuite/tests/runtime-errors/*.exe +/testsuite/tests/runtime-errors/*.exe.manifest +/testsuite/tests/runtime-errors/.depend +/testsuite/tests/runtime-errors/.depend.nt +/testsuite/tests/runtime-errors/.DS_Store +/testsuite/tests/runtime-errors/*.bytecode + +# /testsuite/tests/tool-debugger/ +/testsuite/tests/tool-debugger/*.o +/testsuite/tests/tool-debugger/*.a +/testsuite/tests/tool-debugger/*.so +/testsuite/tests/tool-debugger/*.obj +/testsuite/tests/tool-debugger/*.lib +/testsuite/tests/tool-debugger/*.dll +/testsuite/tests/tool-debugger/*.cm[ioxat] +/testsuite/tests/tool-debugger/*.cmx[as] +/testsuite/tests/tool-debugger/*.cmti +/testsuite/tests/tool-debugger/*.annot +/testsuite/tests/tool-debugger/*.result +/testsuite/tests/tool-debugger/*.byte +/testsuite/tests/tool-debugger/*.native +/testsuite/tests/tool-debugger/program +/testsuite/tests/tool-debugger/*.exe +/testsuite/tests/tool-debugger/*.exe.manifest +/testsuite/tests/tool-debugger/.depend +/testsuite/tests/tool-debugger/.depend.nt +/testsuite/tests/tool-debugger/.DS_Store +/testsuite/tests/tool-debugger/compiler-libs + +# /testsuite/tests/tool-debugger/basic/ +/testsuite/tests/tool-debugger/basic/*.o +/testsuite/tests/tool-debugger/basic/*.a +/testsuite/tests/tool-debugger/basic/*.so +/testsuite/tests/tool-debugger/basic/*.obj +/testsuite/tests/tool-debugger/basic/*.lib +/testsuite/tests/tool-debugger/basic/*.dll +/testsuite/tests/tool-debugger/basic/*.cm[ioxat] +/testsuite/tests/tool-debugger/basic/*.cmx[as] +/testsuite/tests/tool-debugger/basic/*.cmti +/testsuite/tests/tool-debugger/basic/*.annot +/testsuite/tests/tool-debugger/basic/*.result +/testsuite/tests/tool-debugger/basic/*.byte +/testsuite/tests/tool-debugger/basic/*.native +/testsuite/tests/tool-debugger/basic/program +/testsuite/tests/tool-debugger/basic/*.exe +/testsuite/tests/tool-debugger/basic/*.exe.manifest +/testsuite/tests/tool-debugger/basic/.depend +/testsuite/tests/tool-debugger/basic/.depend.nt +/testsuite/tests/tool-debugger/basic/.DS_Store +/testsuite/tests/tool-debugger/basic/compiler-libs + +# /testsuite/tests/tool-debugger/find-artifacts/ +/testsuite/tests/tool-debugger/find-artifacts/*.o +/testsuite/tests/tool-debugger/find-artifacts/*.a +/testsuite/tests/tool-debugger/find-artifacts/*.so +/testsuite/tests/tool-debugger/find-artifacts/*.obj +/testsuite/tests/tool-debugger/find-artifacts/*.lib +/testsuite/tests/tool-debugger/find-artifacts/*.dll +/testsuite/tests/tool-debugger/find-artifacts/*.cm[ioxat] +/testsuite/tests/tool-debugger/find-artifacts/*.cmx[as] +/testsuite/tests/tool-debugger/find-artifacts/*.cmti +/testsuite/tests/tool-debugger/find-artifacts/*.annot +/testsuite/tests/tool-debugger/find-artifacts/*.result +/testsuite/tests/tool-debugger/find-artifacts/*.byte +/testsuite/tests/tool-debugger/find-artifacts/*.native +/testsuite/tests/tool-debugger/find-artifacts/program +/testsuite/tests/tool-debugger/find-artifacts/*.exe +/testsuite/tests/tool-debugger/find-artifacts/*.exe.manifest +/testsuite/tests/tool-debugger/find-artifacts/.depend +/testsuite/tests/tool-debugger/find-artifacts/.depend.nt +/testsuite/tests/tool-debugger/find-artifacts/.DS_Store +/testsuite/tests/tool-debugger/find-artifacts/compiler-libs +/testsuite/tests/tool-debugger/find-artifacts/out + +# /testsuite/tests/tool-lexyacc/ +/testsuite/tests/tool-lexyacc/*.o +/testsuite/tests/tool-lexyacc/*.a +/testsuite/tests/tool-lexyacc/*.so +/testsuite/tests/tool-lexyacc/*.obj +/testsuite/tests/tool-lexyacc/*.lib +/testsuite/tests/tool-lexyacc/*.dll +/testsuite/tests/tool-lexyacc/*.cm[ioxat] +/testsuite/tests/tool-lexyacc/*.cmx[as] +/testsuite/tests/tool-lexyacc/*.cmti +/testsuite/tests/tool-lexyacc/*.annot +/testsuite/tests/tool-lexyacc/*.result +/testsuite/tests/tool-lexyacc/*.byte +/testsuite/tests/tool-lexyacc/*.native +/testsuite/tests/tool-lexyacc/program +/testsuite/tests/tool-lexyacc/*.exe +/testsuite/tests/tool-lexyacc/*.exe.manifest +/testsuite/tests/tool-lexyacc/.depend +/testsuite/tests/tool-lexyacc/.depend.nt +/testsuite/tests/tool-lexyacc/.DS_Store +/testsuite/tests/tool-lexyacc/scanner.ml +/testsuite/tests/tool-lexyacc/grammar.mli +/testsuite/tests/tool-lexyacc/grammar.ml + +# /testsuite/tests/tool-ocaml/ +/testsuite/tests/tool-ocaml/# svn propset -R svn:ignore -F .svnignore . +/testsuite/tests/tool-ocaml/# find . -name .svnignore -print | while read f; do svn propset svn:ignore -F $f `dirname $f`; done +/testsuite/tests/tool-ocaml/_log +/testsuite/tests/tool-ocaml/*.so +/testsuite/tests/tool-ocaml/*.a +/testsuite/tests/tool-ocaml/*.result +/testsuite/tests/tool-ocaml/*.byte +/testsuite/tests/tool-ocaml/*.native +/testsuite/tests/tool-ocaml/program +/testsuite/tests/tool-ocaml/*.cm* +/testsuite/tests/tool-ocaml/*.o + +# /testsuite/tests/tool-ocamldoc/ +/testsuite/tests/tool-ocamldoc/*.o +/testsuite/tests/tool-ocamldoc/*.a +/testsuite/tests/tool-ocamldoc/*.so +/testsuite/tests/tool-ocamldoc/*.obj +/testsuite/tests/tool-ocamldoc/*.cm[ioxa] +/testsuite/tests/tool-ocamldoc/*.cmx[as] +/testsuite/tests/tool-ocamldoc/*.annot +/testsuite/tests/tool-ocamldoc/*.result +/testsuite/tests/tool-ocamldoc/*.byte +/testsuite/tests/tool-ocamldoc/*.native +/testsuite/tests/tool-ocamldoc/program +/testsuite/tests/tool-ocamldoc/.depend +/testsuite/tests/tool-ocamldoc/.depend.nt +/testsuite/tests/tool-ocamldoc/.DS_Store +/testsuite/tests/tool-ocamldoc/*.html +/testsuite/tests/tool-ocamldoc/*.sty +/testsuite/tests/tool-ocamldoc/*.css +/testsuite/tests/tool-ocamldoc/ocamldoc.out + +# /testsuite/tests/tool-toplevel/ +/testsuite/tests/tool-toplevel/*.o +/testsuite/tests/tool-toplevel/*.a +/testsuite/tests/tool-toplevel/*.so +/testsuite/tests/tool-toplevel/*.obj +/testsuite/tests/tool-toplevel/*.lib +/testsuite/tests/tool-toplevel/*.dll +/testsuite/tests/tool-toplevel/*.cm[ioxat] +/testsuite/tests/tool-toplevel/*.cmx[as] +/testsuite/tests/tool-toplevel/*.cmti +/testsuite/tests/tool-toplevel/*.annot +/testsuite/tests/tool-toplevel/*.result +/testsuite/tests/tool-toplevel/*.byte +/testsuite/tests/tool-toplevel/*.native +/testsuite/tests/tool-toplevel/program +/testsuite/tests/tool-toplevel/*.exe +/testsuite/tests/tool-toplevel/*.exe.manifest +/testsuite/tests/tool-toplevel/.depend +/testsuite/tests/tool-toplevel/.depend.nt +/testsuite/tests/tool-toplevel/.DS_Store + +# /testsuite/tests/typing-extensions/ +/testsuite/tests/typing-extensions/*.o +/testsuite/tests/typing-extensions/*.a +/testsuite/tests/typing-extensions/*.so +/testsuite/tests/typing-extensions/*.obj +/testsuite/tests/typing-extensions/*.lib +/testsuite/tests/typing-extensions/*.dll +/testsuite/tests/typing-extensions/*.cm[ioxat] +/testsuite/tests/typing-extensions/*.cmx[as] +/testsuite/tests/typing-extensions/*.cmti +/testsuite/tests/typing-extensions/*.annot +/testsuite/tests/typing-extensions/*.result +/testsuite/tests/typing-extensions/*.byte +/testsuite/tests/typing-extensions/*.native +/testsuite/tests/typing-extensions/program +/testsuite/tests/typing-extensions/*.exe +/testsuite/tests/typing-extensions/*.exe.manifest +/testsuite/tests/typing-extensions/.depend +/testsuite/tests/typing-extensions/.depend.nt +/testsuite/tests/typing-extensions/.DS_Store + +# /testsuite/tests/typing-fstclassmod/ +/testsuite/tests/typing-fstclassmod/*.o +/testsuite/tests/typing-fstclassmod/*.a +/testsuite/tests/typing-fstclassmod/*.so +/testsuite/tests/typing-fstclassmod/*.obj +/testsuite/tests/typing-fstclassmod/*.lib +/testsuite/tests/typing-fstclassmod/*.dll +/testsuite/tests/typing-fstclassmod/*.cm[ioxat] +/testsuite/tests/typing-fstclassmod/*.cmx[as] +/testsuite/tests/typing-fstclassmod/*.cmti +/testsuite/tests/typing-fstclassmod/*.annot +/testsuite/tests/typing-fstclassmod/*.result +/testsuite/tests/typing-fstclassmod/*.byte +/testsuite/tests/typing-fstclassmod/*.native +/testsuite/tests/typing-fstclassmod/program +/testsuite/tests/typing-fstclassmod/*.exe +/testsuite/tests/typing-fstclassmod/*.exe.manifest +/testsuite/tests/typing-fstclassmod/.depend +/testsuite/tests/typing-fstclassmod/.depend.nt +/testsuite/tests/typing-fstclassmod/.DS_Store + +# /testsuite/tests/typing-gadts/ +/testsuite/tests/typing-gadts/*.o +/testsuite/tests/typing-gadts/*.a +/testsuite/tests/typing-gadts/*.so +/testsuite/tests/typing-gadts/*.obj +/testsuite/tests/typing-gadts/*.cm[ioxa] +/testsuite/tests/typing-gadts/*.cmx[as] +/testsuite/tests/typing-gadts/*.annot +/testsuite/tests/typing-gadts/*.result +/testsuite/tests/typing-gadts/*.byte +/testsuite/tests/typing-gadts/*.native +/testsuite/tests/typing-gadts/program +/testsuite/tests/typing-gadts/.depend +/testsuite/tests/typing-gadts/.depend.nt +/testsuite/tests/typing-gadts/.DS_Store + +# /testsuite/tests/typing-implicit_unpack/ +/testsuite/tests/typing-implicit_unpack/*.o +/testsuite/tests/typing-implicit_unpack/*.a +/testsuite/tests/typing-implicit_unpack/*.so +/testsuite/tests/typing-implicit_unpack/*.obj +/testsuite/tests/typing-implicit_unpack/*.cm[ioxa] +/testsuite/tests/typing-implicit_unpack/*.cmx[as] +/testsuite/tests/typing-implicit_unpack/*.annot +/testsuite/tests/typing-implicit_unpack/*.result +/testsuite/tests/typing-implicit_unpack/*.byte +/testsuite/tests/typing-implicit_unpack/*.native +/testsuite/tests/typing-implicit_unpack/program +/testsuite/tests/typing-implicit_unpack/.depend +/testsuite/tests/typing-implicit_unpack/.depend.nt +/testsuite/tests/typing-implicit_unpack/.DS_Store + +# /testsuite/tests/typing-labels/ +/testsuite/tests/typing-labels/*.o +/testsuite/tests/typing-labels/*.a +/testsuite/tests/typing-labels/*.so +/testsuite/tests/typing-labels/*.obj +/testsuite/tests/typing-labels/*.cm[ioxa] +/testsuite/tests/typing-labels/*.cmx[as] +/testsuite/tests/typing-labels/*.annot +/testsuite/tests/typing-labels/*.result +/testsuite/tests/typing-labels/*.byte +/testsuite/tests/typing-labels/*.native +/testsuite/tests/typing-labels/program +/testsuite/tests/typing-labels/program.exe +/testsuite/tests/typing-labels/.depend +/testsuite/tests/typing-labels/.depend.nt +/testsuite/tests/typing-labels/.DS_Store + +# /testsuite/tests/typing-misc/ +/testsuite/tests/typing-misc/*.o +/testsuite/tests/typing-misc/*.a +/testsuite/tests/typing-misc/*.so +/testsuite/tests/typing-misc/*.obj +/testsuite/tests/typing-misc/*.cm[ioxa] +/testsuite/tests/typing-misc/*.cmx[as] +/testsuite/tests/typing-misc/*.annot +/testsuite/tests/typing-misc/*.result +/testsuite/tests/typing-misc/*.byte +/testsuite/tests/typing-misc/*.native +/testsuite/tests/typing-misc/program +/testsuite/tests/typing-misc/.depend +/testsuite/tests/typing-misc/.depend.nt +/testsuite/tests/typing-misc/.DS_Store + +# /testsuite/tests/typing-modules/ +/testsuite/tests/typing-modules/# svn propset -R svn:ignore -F .svnignore . +/testsuite/tests/typing-modules/# find . -name .svnignore -print | while read f; do svn propset svn:ignore -F $f `dirname $f`; done +/testsuite/tests/typing-modules/_log +/testsuite/tests/typing-modules/*.so +/testsuite/tests/typing-modules/*.a +/testsuite/tests/typing-modules/*.result +/testsuite/tests/typing-modules/*.byte +/testsuite/tests/typing-modules/*.native +/testsuite/tests/typing-modules/program + +# /testsuite/tests/typing-modules-bugs/ +/testsuite/tests/typing-modules-bugs/*.o +/testsuite/tests/typing-modules-bugs/*.a +/testsuite/tests/typing-modules-bugs/*.so +/testsuite/tests/typing-modules-bugs/*.obj +/testsuite/tests/typing-modules-bugs/*.cm[ioxa] +/testsuite/tests/typing-modules-bugs/*.cmx[as] +/testsuite/tests/typing-modules-bugs/*.annot +/testsuite/tests/typing-modules-bugs/*.result +/testsuite/tests/typing-modules-bugs/*.byte +/testsuite/tests/typing-modules-bugs/*.native +/testsuite/tests/typing-modules-bugs/program +/testsuite/tests/typing-modules-bugs/program.exe +/testsuite/tests/typing-modules-bugs/.depend +/testsuite/tests/typing-modules-bugs/.depend.nt +/testsuite/tests/typing-modules-bugs/.DS_Store + +# /testsuite/tests/typing-objects/ +/testsuite/tests/typing-objects/*.o +/testsuite/tests/typing-objects/*.a +/testsuite/tests/typing-objects/*.so +/testsuite/tests/typing-objects/*.obj +/testsuite/tests/typing-objects/*.cm[ioxa] +/testsuite/tests/typing-objects/*.cmx[as] +/testsuite/tests/typing-objects/*.annot +/testsuite/tests/typing-objects/*.result +/testsuite/tests/typing-objects/*.byte +/testsuite/tests/typing-objects/*.native +/testsuite/tests/typing-objects/program +/testsuite/tests/typing-objects/.depend +/testsuite/tests/typing-objects/.depend.nt +/testsuite/tests/typing-objects/.DS_Store + +# /testsuite/tests/typing-objects-bugs/ +/testsuite/tests/typing-objects-bugs/# svn propset -R svn:ignore -F .svnignore . +/testsuite/tests/typing-objects-bugs/# find . -name .svnignore -print | while read f; do svn propset svn:ignore -F $f `dirname $f`; done +/testsuite/tests/typing-objects-bugs/_log +/testsuite/tests/typing-objects-bugs/*.so +/testsuite/tests/typing-objects-bugs/*.a +/testsuite/tests/typing-objects-bugs/*.result +/testsuite/tests/typing-objects-bugs/*.byte +/testsuite/tests/typing-objects-bugs/*.native +/testsuite/tests/typing-objects-bugs/program +/testsuite/tests/typing-objects-bugs/*.cm* +/testsuite/tests/typing-objects-bugs/*.o + +# /testsuite/tests/typing-poly/ +/testsuite/tests/typing-poly/*.o +/testsuite/tests/typing-poly/*.a +/testsuite/tests/typing-poly/*.so +/testsuite/tests/typing-poly/*.obj +/testsuite/tests/typing-poly/*.cm[ioxa] +/testsuite/tests/typing-poly/*.cmx[as] +/testsuite/tests/typing-poly/*.annot +/testsuite/tests/typing-poly/*.result +/testsuite/tests/typing-poly/*.byte +/testsuite/tests/typing-poly/*.native +/testsuite/tests/typing-poly/program +/testsuite/tests/typing-poly/.depend +/testsuite/tests/typing-poly/.depend.nt +/testsuite/tests/typing-poly/.DS_Store + +# /testsuite/tests/typing-poly-bugs/ +/testsuite/tests/typing-poly-bugs/*.o +/testsuite/tests/typing-poly-bugs/*.a +/testsuite/tests/typing-poly-bugs/*.so +/testsuite/tests/typing-poly-bugs/*.obj +/testsuite/tests/typing-poly-bugs/*.cm[ioxa] +/testsuite/tests/typing-poly-bugs/*.cmx[as] +/testsuite/tests/typing-poly-bugs/*.annot +/testsuite/tests/typing-poly-bugs/*.result +/testsuite/tests/typing-poly-bugs/*.byte +/testsuite/tests/typing-poly-bugs/*.native +/testsuite/tests/typing-poly-bugs/program +/testsuite/tests/typing-poly-bugs/program.exe +/testsuite/tests/typing-poly-bugs/.depend +/testsuite/tests/typing-poly-bugs/.depend.nt +/testsuite/tests/typing-poly-bugs/.DS_Store + +# /testsuite/tests/typing-polyvariants-bugs/ +/testsuite/tests/typing-polyvariants-bugs/# svn propset -R svn:ignore -F .svnignore . +/testsuite/tests/typing-polyvariants-bugs/# find . -name .svnignore -print | while read f; do svn propset svn:ignore -F $f `dirname $f`; done +/testsuite/tests/typing-polyvariants-bugs/_log +/testsuite/tests/typing-polyvariants-bugs/*.so +/testsuite/tests/typing-polyvariants-bugs/*.a +/testsuite/tests/typing-polyvariants-bugs/*.result +/testsuite/tests/typing-polyvariants-bugs/*.byte +/testsuite/tests/typing-polyvariants-bugs/*.native +/testsuite/tests/typing-polyvariants-bugs/program +/testsuite/tests/typing-polyvariants-bugs/*.cm* +/testsuite/tests/typing-polyvariants-bugs/*.o + +# /testsuite/tests/typing-polyvariants-bugs-2/ +/testsuite/tests/typing-polyvariants-bugs-2/# svn propset -R svn:ignore -F .svnignore . +/testsuite/tests/typing-polyvariants-bugs-2/# find . -name .svnignore -print | while read f; do svn propset svn:ignore -F $f `dirname $f`; done +/testsuite/tests/typing-polyvariants-bugs-2/_log +/testsuite/tests/typing-polyvariants-bugs-2/*.so +/testsuite/tests/typing-polyvariants-bugs-2/*.a +/testsuite/tests/typing-polyvariants-bugs-2/*.result +/testsuite/tests/typing-polyvariants-bugs-2/*.byte +/testsuite/tests/typing-polyvariants-bugs-2/*.native +/testsuite/tests/typing-polyvariants-bugs-2/program +/testsuite/tests/typing-polyvariants-bugs-2/*.cm* +/testsuite/tests/typing-polyvariants-bugs-2/*.o + +# /testsuite/tests/typing-private/ +/testsuite/tests/typing-private/*.o +/testsuite/tests/typing-private/*.a +/testsuite/tests/typing-private/*.so +/testsuite/tests/typing-private/*.obj +/testsuite/tests/typing-private/*.cm[ioxa] +/testsuite/tests/typing-private/*.cmx[as] +/testsuite/tests/typing-private/*.annot +/testsuite/tests/typing-private/*.result +/testsuite/tests/typing-private/*.byte +/testsuite/tests/typing-private/*.native +/testsuite/tests/typing-private/program +/testsuite/tests/typing-private/.depend +/testsuite/tests/typing-private/.depend.nt +/testsuite/tests/typing-private/.DS_Store + +# /testsuite/tests/typing-private-bugs/ +/testsuite/tests/typing-private-bugs/# svn propset -R svn:ignore -F .svnignore . +/testsuite/tests/typing-private-bugs/# find . -name .svnignore -print | while read f; do svn propset svn:ignore -F $f `dirname $f`; done +/testsuite/tests/typing-private-bugs/_log +/testsuite/tests/typing-private-bugs/*.so +/testsuite/tests/typing-private-bugs/*.a +/testsuite/tests/typing-private-bugs/*.result +/testsuite/tests/typing-private-bugs/*.byte +/testsuite/tests/typing-private-bugs/*.native +/testsuite/tests/typing-private-bugs/program +/testsuite/tests/typing-private-bugs/*.cm* +/testsuite/tests/typing-private-bugs/*.o + +# /testsuite/tests/typing-recmod/ +/testsuite/tests/typing-recmod/# svn propset -R svn:ignore -F .svnignore . +/testsuite/tests/typing-recmod/# find . -name .svnignore -print | while read f; do svn propset svn:ignore -F $f `dirname $f`; done +/testsuite/tests/typing-recmod/_log +/testsuite/tests/typing-recmod/*.so +/testsuite/tests/typing-recmod/*.a +/testsuite/tests/typing-recmod/*.result +/testsuite/tests/typing-recmod/*.byte +/testsuite/tests/typing-recmod/*.native +/testsuite/tests/typing-recmod/program +/testsuite/tests/typing-recmod/*.cm* +/testsuite/tests/typing-recmod/*.o + +# /testsuite/tests/typing-short-paths/ +/testsuite/tests/typing-short-paths/*.o +/testsuite/tests/typing-short-paths/*.a +/testsuite/tests/typing-short-paths/*.so +/testsuite/tests/typing-short-paths/*.obj +/testsuite/tests/typing-short-paths/*.cm[ioxat] +/testsuite/tests/typing-short-paths/*.cmx[as] +/testsuite/tests/typing-short-paths/*.cmti +/testsuite/tests/typing-short-paths/*.annot +/testsuite/tests/typing-short-paths/*.result +/testsuite/tests/typing-short-paths/*.byte +/testsuite/tests/typing-short-paths/*.native +/testsuite/tests/typing-short-paths/program +/testsuite/tests/typing-short-paths/program.exe +/testsuite/tests/typing-short-paths/.depend +/testsuite/tests/typing-short-paths/.depend.nt +/testsuite/tests/typing-short-paths/.DS_Store + +# /testsuite/tests/typing-signatures/ +/testsuite/tests/typing-signatures/*.o +/testsuite/tests/typing-signatures/*.a +/testsuite/tests/typing-signatures/*.so +/testsuite/tests/typing-signatures/*.obj +/testsuite/tests/typing-signatures/*.cm[ioxa] +/testsuite/tests/typing-signatures/*.cmx[as] +/testsuite/tests/typing-signatures/*.annot +/testsuite/tests/typing-signatures/*.result +/testsuite/tests/typing-signatures/*.byte +/testsuite/tests/typing-signatures/*.native +/testsuite/tests/typing-signatures/program +/testsuite/tests/typing-signatures/.depend +/testsuite/tests/typing-signatures/.depend.nt +/testsuite/tests/typing-signatures/.DS_Store + +# /testsuite/tests/typing-sigsubst/ +/testsuite/tests/typing-sigsubst/*.o +/testsuite/tests/typing-sigsubst/*.a +/testsuite/tests/typing-sigsubst/*.so +/testsuite/tests/typing-sigsubst/*.obj +/testsuite/tests/typing-sigsubst/*.cm[ioxa] +/testsuite/tests/typing-sigsubst/*.cmx[as] +/testsuite/tests/typing-sigsubst/*.annot +/testsuite/tests/typing-sigsubst/*.result +/testsuite/tests/typing-sigsubst/*.byte +/testsuite/tests/typing-sigsubst/*.native +/testsuite/tests/typing-sigsubst/program +/testsuite/tests/typing-sigsubst/.depend +/testsuite/tests/typing-sigsubst/.depend.nt +/testsuite/tests/typing-sigsubst/.DS_Store + +# /testsuite/tests/typing-typeparam/ +/testsuite/tests/typing-typeparam/*.o +/testsuite/tests/typing-typeparam/*.a +/testsuite/tests/typing-typeparam/*.so +/testsuite/tests/typing-typeparam/*.obj +/testsuite/tests/typing-typeparam/*.cm[ioxa] +/testsuite/tests/typing-typeparam/*.cmx[as] +/testsuite/tests/typing-typeparam/*.annot +/testsuite/tests/typing-typeparam/*.result +/testsuite/tests/typing-typeparam/*.byte +/testsuite/tests/typing-typeparam/*.native +/testsuite/tests/typing-typeparam/program +/testsuite/tests/typing-typeparam/.depend +/testsuite/tests/typing-typeparam/.depend.nt +/testsuite/tests/typing-typeparam/.DS_Store + +# /testsuite/tests/typing-warnings/ +/testsuite/tests/typing-warnings/*.o +/testsuite/tests/typing-warnings/*.a +/testsuite/tests/typing-warnings/*.so +/testsuite/tests/typing-warnings/*.obj +/testsuite/tests/typing-warnings/*.cm[ioxat] +/testsuite/tests/typing-warnings/*.cmx[as] +/testsuite/tests/typing-warnings/*.cmti +/testsuite/tests/typing-warnings/*.annot +/testsuite/tests/typing-warnings/*.result +/testsuite/tests/typing-warnings/*.byte +/testsuite/tests/typing-warnings/*.native +/testsuite/tests/typing-warnings/program +/testsuite/tests/typing-warnings/program.exe +/testsuite/tests/typing-warnings/.depend +/testsuite/tests/typing-warnings/.depend.nt +/testsuite/tests/typing-warnings/.DS_Store + +# /testsuite/tests/utils/ +/testsuite/tests/utils/*.o +/testsuite/tests/utils/*.a +/testsuite/tests/utils/*.so +/testsuite/tests/utils/*.obj +/testsuite/tests/utils/*.cm[ioxat] +/testsuite/tests/utils/*.cmx[as] +/testsuite/tests/utils/*.cmti +/testsuite/tests/utils/*.annot +/testsuite/tests/utils/*.result +/testsuite/tests/utils/*.byte +/testsuite/tests/utils/*.native +/testsuite/tests/utils/program +/testsuite/tests/utils/program.exe +/testsuite/tests/utils/.depend +/testsuite/tests/utils/.depend.nt +/testsuite/tests/utils/.DS_Store + +# /testsuite/tests/warnings/ +/testsuite/tests/warnings/*.o +/testsuite/tests/warnings/*.a +/testsuite/tests/warnings/*.so +/testsuite/tests/warnings/*.obj +/testsuite/tests/warnings/*.lib +/testsuite/tests/warnings/*.dll +/testsuite/tests/warnings/*.cm[ioxat] +/testsuite/tests/warnings/*.cmx[as] +/testsuite/tests/warnings/*.cmti +/testsuite/tests/warnings/*.annot +/testsuite/tests/warnings/*.result +/testsuite/tests/warnings/*.byte +/testsuite/tests/warnings/*.native +/testsuite/tests/warnings/program +/testsuite/tests/warnings/*.exe +/testsuite/tests/warnings/*.exe.manifest +/testsuite/tests/warnings/.depend +/testsuite/tests/warnings/.depend.nt +/testsuite/tests/warnings/.DS_Store + +# /tools/ +/tools/*.o +/tools/*.a +/tools/*.so +/tools/*.obj +/tools/*.lib +/tools/*.dll +/tools/*.cm[ioxat] +/tools/*.cmx[as] +/tools/*.cmti +/tools/*.annot +/tools/*.result +/tools/*.byte +/tools/*.native +/tools/program +/tools/*.exe +/tools/*.exe.manifest +/tools/.depend +/tools/.depend.nt +/tools/.DS_Store +/tools/ocamldep +/tools/ocamldep.opt +/tools/ocamldep.bak +/tools/ocamlprof +/tools/opnames.ml +/tools/dumpobj +/tools/dumpapprox +/tools/objinfo +/tools/cvt_emit +/tools/cvt_emit.bak +/tools/cvt_emit.ml +/tools/ocamlcp +/tools/ocamloptp +/tools/ocamlmktop +/tools/primreq +/tools/ocamldumpobj +/tools/keywords +/tools/lexer299.ml +/tools/ocaml299to3 +/tools/ocamlmklib +/tools/ocamlmklibconfig.ml +/tools/lexer301.ml +/tools/scrapelabels +/tools/addlabels +/tools/objinfo_helper +/tools/read_cmt +/tools/read_cmt.opt + +# /toplevel/ +/toplevel/.depend +/toplevel/configure +/toplevel/ocamlc +/toplevel/ocamlc.opt +/toplevel/expunge +/toplevel/ocaml +/toplevel/ocamlopt +/toplevel/ocamlopt.opt +/toplevel/ocamlcomp.sh +/toplevel/ocamlcompopt.sh +/toplevel/package-macosx +/toplevel/.DS_Store +/toplevel/*.annot +/toplevel/_boot_log1 +/toplevel/_boot_log2 +/toplevel/_build +/toplevel/_log +/toplevel/myocamlbuild_config.ml +/toplevel/ocamlnat +/toplevel/*.cm* +/toplevel/*.o + +# /typing/ +/typing/*.o +/typing/*.a +/typing/*.so +/typing/*.obj +/typing/*.dll +/typing/*.cm[ioxat] +/typing/*.cmx[as] +/typing/*.cmti +/typing/*.annot +/typing/*.result +/typing/*.byte +/typing/*.native +/typing/program +/typing/*.exe +/typing/.depend +/typing/.depend.nt +/typing/.DS_Store + +# /utils/ +/utils/*.o +/utils/*.a +/utils/*.so +/utils/*.obj +/utils/*.dll +/utils/*.cm[ioxat] +/utils/*.cmx[as] +/utils/*.cmti +/utils/*.annot +/utils/*.result +/utils/*.byte +/utils/*.native +/utils/program +/utils/*.exe +/utils/.depend +/utils/.depend.nt +/utils/.DS_Store +/utils/config.ml + +# /yacc/ +/yacc/*.o +/yacc/*.a +/yacc/*.so +/yacc/*.obj +/yacc/*.cm[ioxa] +/yacc/*.cmx[as] +/yacc/*.annot +/yacc/*.result +/yacc/*.byte +/yacc/*.native +/yacc/program +/yacc/program.exe +/yacc/.depend +/yacc/.depend.nt +/yacc/.DS_Store +/yacc/ocamlyacc +/yacc/ocamlyacc.exe +/yacc/version.h +/yacc/.gdb_history diff --git a/.travis-ci.sh b/.travis-ci.sh new file mode 100644 index 000000000..d65fcbc63 --- /dev/null +++ b/.travis-ci.sh @@ -0,0 +1,21 @@ +case $XARCH in +i386) + ./configure + make world.opt + sudo make install + cd testsuite && make all + git clone git://github.com/ocaml/camlp4 + cd camlp4 && ./configure && make && sudo make install + git clone git://github.com/ocaml/opam + cd opam && ./configure && make lib-ext && make && sudo make install + git config --global user.email "some@name.com" + git config --global user.name "Some Name" + opam init -y -a git://github.com/ocaml/opam-repository + opam install -y oasis + opam pin add -y utop https://github.com/diml/utop + ;; +*) + echo unknown arch + exit 1 + ;; +esac diff --git a/.travis.yml b/.travis.yml new file mode 100644 index 000000000..3015c16d3 --- /dev/null +++ b/.travis.yml @@ -0,0 +1,4 @@ +language: c +script: bash -ex .travis-ci.sh +env: + - XARCH=i386 @@ -1,135 +1,396 @@ -Next version: +OCaml 4.03.0: +------------- + +Compilers: +- PR#6501: harden the native-code generator against certain uses of "%identity" + (Xavier Leroy, report by Antoine Miné). + +Runtime system: +- PR#6517: use ISO C99 types {,u}int{32,64}_t in preference to our homegrown + types {,u}int{32,64}. + (Xavier Leroy) + +Standard library: +- PR#6577: improve performance of %L, %l, %n, %S, %C format specifiers + (Alain Frisch) +- PR#6585: fix memory leak in win32unix/createprocess.c + +Type system: +- PR#6374: allow "_ t" as a short-hand for "(_, _, ..) t" for n-ary type + constructors (Alain Frisch) +* PR#6465: allow incremental weakening of module aliases (Jacques Garrigue). + This is done by adding equations to submodules when expanding aliases. + In theory this may be incompatible is some corner cases defining a module + type through inference, but no breakage known on published code. +- PR#6593: Functor application in tests/basic-modules fails after commit 15405 + +OCaml 4.02.1: +------------- + +- PR#4099: Bug in Makefile.nt: won't stop on error (George Necula) +- PR#6181: Improve MSVC build (Chen Gang) +- PR#6466: Non-exhaustive matching warning message for open types is confusing +- PR#6529: fix quadratic-time algorithm in Consistbl.extract. + (Xavier Leroy) +- PR#6554: fix race condition when retrieving backtraces (Jérémie Dimino, + Mark Shinwell). +- PR#6588: Code generation errors for ARM + (Mark Shinwell, Xavier Leroy) +- PR#6590: Improve Windows (MSVC and mingw) build + (Chen Gang) + +Ocaml 4.02.0: ------------- (Changes that can break existing programs are marked with a "*") Language features: - Attributes and extension nodes -- Generative functors + (Alain Frisch) +- Generative functors (PR#5905) + (Jacques Garrigue) - Module aliases + (Jacques Garrigue) +* Alternative syntax for string literals {id|...|id} (can break comments) + (Alain Frisch) +- Separation between read-only strings (type string) and read-write byte + sequences (type bytes). Activated by command-line option -safe-string. + (Damien Doligez) +- PR#6318: Exception cases in pattern matching + (Jeremy Yallop, backend by Alain Frisch) +- PR#5584: Extensible open datatypes + (Leo White) Build system for the OCaml distribution: - Use -bin-annot when building. +- Use GNU make instead of portable makefiles. +- Updated build instructions for 32-bit Mac OS X on Intel hardware. -Camlp4: -- Removed from the official distribution - -Other libraries: -* Labltk: removed from the distribution, now available as a third-party library +Shedding weight: +* Removed Camlp4 from the distribution, now available as third-party software. +* Removed Labltk from the distribution, now available as a third-party library. Type system: -* Keep typing of pattern cases independent in principal mode +* PR#6235: Keep typing of pattern cases independent in principal mode (i.e. information from previous cases is no longer used when typing - patterns; cf. PR6235' in typing-warnings/records.ml) + patterns; cf. 'PR#6235' in testsuite/test/typing-warnings/records.ml) + (Jacques Garrigue) - Allow opening a first-class module or applying a generative functor in the body of a generative functor. Allow it also in the body of an applicative functor if no types are created + (Jacques Garrigue, suggestion by Leo White) * Module aliases are now typed in a specific way, which remembers their identity. In particular this changes the signature inferred by "module type of" + (Jacques Garrigue, feedback from Leo White, Mark Shinwell and Nick Chapman) - PR#6331: Slight change in the criterion to distinguish private abbreviations and private row types: create a private abbreviation for closed objects and fixed polymorphic variants. -- PR#6333: Compare first class module types structurally rather than + (Jacques Garrigue) +* PR#6333: Compare first class module types structurally rather than nominally. Value subtyping allows module subtyping as long as the internal representation is unchanged. + (Jacques Garrigue) Compilers: -- PR#6269 Optimization of string matching (patch by Benoit Vaugon - and Luc Maranget) +- More aggressive constant propagation, including float and + int32/int64/nativeint arithmetic. Constant propagation for floats + can be turned off with option -no-float-const-prop, for codes that + change FP rounding modes at run-time. + (Xavier Leroy) +- New back-end optimization pass: common subexpression elimination (CSE). + (Reuses results of previous computations instead of recomputing them.) + (Xavier Leroy) +- New back-end optimization pass: dead code elimination. + (Removes arithmetic and load instructions whose results are unused.) + (Xavier Leroy) +- PR#6269: Optimization of sequences of string patterns + (Benoît Vaugon and Luc Maranget) - Experimental native code generator for AArch64 (ARM 64 bits) -- Optimization of integer division and modulus by constant divisors - (feature wish PR#6042) -- PR#6182: better message for virtual objects and class types - (Leo P. White, Stephen Dolan) + (Xavier Leroy) +- PR#6042: Optimization of integer division and modulus by constant divisors + (Xavier Leroy and Phil Denys) +- Add "-open" command line flag for opening a single module before typing + (Leo White, Mark Shinwell and Nick Chapman) +* "-o" now sets module name to the output file name up to the first "." + (it also applies when "-o" is not given, i.e. the module name is then + the input file name up to the first ".") + (Leo White, Mark Shinwell and Nick Chapman) +* PR#5779: better sharing of structured constants + (Alain Frisch) - PR#5817: new flag to keep locations in cmi files + (Alain Frisch) - PR#5854: issue warning 3 when referring to a value marked with - the [@@deprecated] attribute -- PR#6203: Constant exception constructor no longer allocate -- PR#6311: Improve signature mismatch error messages + the [@@ocaml.deprecated] attribute + (Alain Frisch, suggestion by Pierre-Marie Pédrot) +- PR#6017: a new format implementation based on GADTs + (Benoît Vaugon and Gabriel Scherer) +* PR#6203: Constant exception constructors no longer allocate + (Alain Frisch) +- PR#6260: avoid unnecessary boxing in let + (Vladimir Brankov) - PR#6345: Better compilation of optional arguments with default values -- PR#6260: Unnecessary boxing in let (patch by vbrankov) + (Alain Frisch, review by Jacques Garrigue) +- PR#6389: ocamlopt -opaque option for incremental native compilation + (Pierre Chambart, Gabriel Scherer) + +Toplevel interactive system: +- PR#5377: New "#show_*" directives + (ygrek, Jacques Garrigue and Alain Frisch) Runtime system: +- New configure option "-no-naked-pointers" to improve performance by + avoiding page table tests during block darkening and the marking phase + of the major GC. In this mode, all out-of-heap pointers must point at + things that look like OCaml values: in particular they must have a valid + header. The colour of said headers should be black. + (Mark Shinwell, reviews by Damien Doligez and Xavier Leroy) +- Fixed bug in native code version of [caml_raise_with_string] that could + potentially lead to heap corruption. + (Mark Shinwell) +- Blocks initialized by [CAMLlocal*] and [caml_alloc] are now filled with + [Val_unit] rather than zero. + (Mark Shinwell) - Fixed a major performance problem on large heaps (~1GB) by making heap - increments proportional to heap size -- PR#4765: Structural equality should treat exception specifically -- PR#5009: Extending exception tag blocks + increments proportional to heap size by default + (Damien Doligez) +- PR#4765: Structural equality treats exception specifically + (Alain Frisch) +- PR#5009: efficient comparison/indexing of exceptions + (Alain Frisch, request by Markus Mottl) +- PR#6075: avoid using unsafe C library functions (strcpy, strcat, sprintf) + (Xavier Leroy, reports from user 'jfc' and Anil Madhavapeddy) +- An ISO C99-compliant C compiler and standard library is now assumed. + (Plus special exceptions for MSVC.) In particular, emulation code for + 64-bit integer arithmetic was removed, the C compiler must support a + 64-bit integer type. + (Xavier Leroy) Standard library: +* Add new modules Bytes and BytesLabels for mutable byte sequences. + (Damien Doligez) - PR#4986: add List.sort_uniq and Set.of_list + (Alain Frisch) - PR#5935: a faster version of "raise" which does not maintain the backtrace + (Alain Frisch) - PR#6146: support "Unix.kill pid Sys.sigkill" under Windows -- PR#6148: speed improvement for Buffer (patch by John Whitington) + (Romain Bardou and Alain Frisch) +- PR#6148: speed improvement for Buffer + (John Whitington) - PR#6180: efficient creation of uninitialized float arrays + (Alain Frisch, request by Markus Mottl) +- PR#6355: Improve documentation regarding finalisers and multithreading + (Daniel Bünzli, Mark Shinwell) +- Trigger warning 3 for all values marked as deprecated in the documentation. + (Damien Doligez) OCamldoc: - PR#6257: handle full doc comments for variant constructors and - record fields + record fields + (Maxence Guesdon, request by ygrek) +- PR#6274: allow doc comments on object types + (Thomas Refis) - PR#6310: fix ocamldoc's subscript/superscript CSS font size - (patch by Anil Madhavapeddy) + (Anil Madhavapeddy) +- PR#6425: fix generation of man pages + (Maxence Guesdon, report by Anil Madhavapeddy) Bug fixes: +- PR#2719: wrong scheduling of bound checks within a + try...with Invalid_argument -> _ ... (Xavier Leroy) - PR#4719: Sys.executable_name wrong if executable name contains dots (Windows) -- PR#4855: 'camlp4 -I +dir' accepted, dir is relative to 'camlp4 -where' -- PR#5201: ocamlbuild: add --norc to the bash invocation to help performances -- PR#5598: follow-up fix related to PR#6165 + (Alain Frisch, report by Bart Jacobs) +- PR#5406 ocamlbuild: "tag 'package' does not expect a parameter" + (Gabriel Scherer) +- PR#5598, PR#6165: Alterations to handling of \013 in source files + breaking other tools + (David Allsopp and Damien Doligez) - PR#5820: Fix camlp4 lexer roll back problem -- PR#6062: Fix a regression bug caused by commit 13047 -- PR#6109: Typos in ocamlbuild error messages -- PR#6116: more efficient implementation of Digest.to_hex (patch by ygrek) + (Hongbo Zhang) +- PR#5946: CAMLprim taking (void) as argument + (Benoît Vaugon) +- PR#6038: on x86-32, enforce 16-byte stack alignment for compatibility + with recent GCC and Clang. Win32/MSVC keeps 4-byte stack alignment. + (Xavier Leroy) +- PR#6062: Fix a 4.01 camlp4 DELETE_RULE regression caused by commit 13047 + (Hongbo Zhang, report by Christophe Troestler) +- PR#6173: Typing error message is worse than before + (Jacques Garrigue and John Whitington) - PR#6174: OCaml compiler loops on an example using GADTs (-rectypes case) + (Jacques Garrigue and Grégoire Henry, report by Chantal Keller) +- PR#6175: open! was not suppored by camlp4 + (Hongbo Zhang) - PR#6184: ocamlbuild: `ocamlfind ocamldep` does not support -predicate - (report and patch by Jacques-Pascal Deplaix) + (Jacques-Pascal Deplaix) +- PR#6194: Incorrect unused warning with first-class modules in patterns + (Jacques Garrigue, report by Markus Mottl and Leo White) +- PR#6211: in toplevel interactive use, bad interaction between uncaught + exceptions and multiple bindings of the form "let x = a let y = b;;". + (Xavier Leroy) +- PR#6216: inlining of GADT matches generates invalid assembly + (Xavier Leroy and Alain Frisch, report by Mark Shinwell) +- PR#6232: Don't use [mktemp] on platforms where [mkstemp] is available + (Stéphane Glondu, Mark Shinwell) +- PR#6233: out-of-bounds exceptions lose their locations on ARM, PowerPC + (Jacques-Henri Jourdan and Xavier Leroy, + report and testing by Stéphane Glondu) +- PR#6235: Issue with type information flowing through a variant pattern + (Jacques Garrigue, report by Hongbo Zhang) +- PR#6239: sometimes wrong stack alignment when raising exceptions + in -g mode with backtraces active + (Xavier Leroy, report by Yaron Minsky) +- PR#6240: Fail to expand module type abbreviation during substyping + (Jacques Garrigue, report by Leo White) +- PR#6241: Assumed inequality between paths involving functor arguments + (Jacques Garrigue, report by Jeremy Yallop) +- PR#6243: Make "ocamlopt -g" more resistant to ill-formed locations + (Xavier Leroy, report by Pierre-Marie Pédrot) - PR#6262: equality of first-class modules take module aliases into account + (Alain Frisch and Leo White) +- PR#6268: -DMODEL_$(MODEL) not passed when building asmrun/arm.p.o + (Peter Michael Green) +- PR#6273: fix Sys.file_exists on large files (Win32) + (Christoph Bauer) +- PR#6275: Soundness bug related to type constraints + (Jacques Garrigue, report by Leo White) - PR#6293: Assert_failure with invalid package type + (Jacques Garrigue, report by Elnatan Reisner) +- PR#6300: ocamlbuild -use-ocamlfind conflicts with -ocamlc + (Gabriel Scherer) +- PR#6302: bytecode debug information re-read from filesystem every time + (Jacques-Henri Jourdan) - PR#6307: Behavior of 'module type of' w.r.t. module aliases -- fix -dsource printing of "external _pipe = ..." + (Jacques Garrigue, report by Alain Frisch) +- PR#6332: Unix.open_process fails to pass empty arguments under Windows + (Damien Doligez, report Virgile Prevosto) +- PR#6346: Build failure with latest version of xcode on OSX + (Jérémie Dimino) +- PR#6348: Unification failure for GADT when original definition is hidden + (Leo White and Jacques Garrigue, report by Jeremy Yallop) +- PR#6352: Automatic removal of optional arguments and sequencing + (Jacques Garrigue and Alain Frisch) +- PR#6361: Hashtbl.hash not terminating on some lazy values w/ recursive types + (Xavier Leroy, report by Leo White) +- PR#6383: Exception Not_found when using object type in absent module + (Jacques Garrigue, report by Sébastien Briais) +- PR#6384: Uncaught Not_found exception with a hidden .cmi file + (Leo White) +- PR#6385: wrong allocation of large closures by the bytecode interpreter + (Xavier Leroy, report by Stephen Dolan) +- PR#6394: Assertion failed in Typecore.expand_path + (Alain Frisch and Jacques Garrigue) +- PR#6405: unsound interaction of -rectypes and GADTs + (Jacques Garrigue, report by Gabriel Scherer and Benoît Vaugon) +- PR#6408: Optional arguments given as ~?arg instead of ?arg in message + (Michael O'Connor) +- PR#6411: missing libgcc_s_sjlj-1.dll in mingw (add -static-libgcc) + (Jun Furuse and Alain Frisch, Jonathan Protzenko and Adrien Nader) +- PR#6436: Typos in @deprecated text in stdlib/arrayLabels.mli + (John Whitington) +- PR#6439: Don't use the deprecated [getpagesize] function + (John Whitington, Mark Shinwell) +- PR#6441: undetected tail-call in some mutually-recursive functions + (many arguments, and mutual block mixes functions and non-functions) + (Stefan Holdermans, review by Xavier Leroy) +- PR#6443: ocaml segfault when List.fold_left is traced then executed + (Jacques Garrigue, report by user 'Reventlov') +- PR#6451: some bugs in untypeast.ml + (Jun Furuse, review by Alain Frisch) +- PR#6460: runtime assertion failure with large [| e1;...eN |] + float array expressions + (Leo White) +- PR#6463: -dtypedtree fails on class fields + (Leo White) +- PR#6469: invalid -dsource printing of "external _pipe = ...", "Pervasives.(!)" + (Gabriel Scherer and Damien Doligez, user 'ngunn') +- PR#6482: ocamlbuild fails when _tags file in unhygienic directory (Gabriel Scherer) +- PR#6502: ocamlbuild spurious warning on "use_menhir" tag + (Xavier Leroy) +- PR#6505: Missed Type-error leads to a segfault upon record access + (Jacques Garrigue, Jeremy Yallop, report by Christoph Höger) +- PR#6507: crash on AArch64 resulting from incorrect setting of + [caml_bottom_of_stack]. (Richard Jones, Mark Shinwell) +- PR#6509: add -linkall flag to ocamlcommon.cma + (Frédéric Bour) +- PR#6513: Fatal error Ctype.Unify(_) in functor type +- PR#6523: failure upon character bigarray access, and unnecessary change + in comparison ordering (Jeremy Yallop, Mark Shinwell) +- bound-checking bug in caml_string_{get,set}{16,32,64} + (Pierre Chambart and Gabriel Scherer, report by Nicolas Trangez) +- sometimes wrong stack alignment at out-of-bounds array access + (Gabriel Scherer and Xavier Leroy, report by Pierre Chambart) Features wishes: - PR#4243: make the Makefiles parallelizable + (Grégoire Henry and Damien Doligez) - PR#4323: have "of_string" in Num and Big_int work with binary and - hexa representations (patch by Zoe Paraskevopoulou) -- PR#5547: Enable the "-use-ocamlfind" option by default + hex representations + (Zoe Paraskevopoulou, review by Gabriel Scherer) +- PR#4771: Clarify documentation of Dynlink.allow_only + (Damien Doligez, report by David Allsopp) +- PR#4855: 'camlp4 -I +dir' accepted, dir is relative to 'camlp4 -where' + (Jun Furuse and Hongbo Zhang, report by Dmitry Grebeniuk) +- PR#5201: ocamlbuild: add --norc to the bash invocation to help performances + (user 'daweil') - PR#5650: Camlp4FoldGenerator doesn't handle well "abstract" types -- PR#5808: allow simple patterns, not only identifiers, in "let p : t = ..." + (Hongbo Zhang) +- PR#5808: allow simple patterns, not just identifiers, in "let p : t = ..." + (Alain Frisch) +- PR#5851: warn when -r is disabled because no _tags file is present + (Gabriel Scherer) +- PR#5899: a programmer-friendly access to backtrace information + (Jacques-Henri Jourdan and Gabriel Scherer) +- PR#6000 comment 9644: add a warning for non-principal coercions to format + (Jacques Garrigue, report by Damien Doligez) - PR#6054: add support for M.[ foo ], M.[| foo |] etc. - (patch by Kaustuv Chaudhuri) + (Kaustuv Chaudhuri) - PR#6064: GADT representation for Bigarray.kind + CAML_BA_CHAR runtime kind -- PR#6071: Add a -noinit option to the toplevel (patch by David Sheets) + (Jeremy Yallop, review by Gabriel Scherer) +- PR#6071: Add a -noinit option to the toplevel + (David Sheets) +- PR#6087: ocamlbuild, improve _tags parsing of escaped newlines + (Gabriel Scherer, request by Daniel Bünzli) +- PR#6109: Typos in ocamlbuild error messages + (Gabriel Kerneis) +- PR#6116: more efficient implementation of Digest.to_hex + (ygrek) +- PR#6142: add cmt file support to ocamlobjinfo + (Anil Madhavapeddy) - PR#6166: document -ocamldoc option of ocamlbuild + (Xavier Clerc) +- PR#6182: better message for virtual objects and class types + (Leo White, Stephen Dolan) +- PR#6183: enhanced documentation for 'Unix.shutdown_connection' + (Anil Madhavapeddy, report by Jun Furuse) - PR#6187: ocamlbuild: warn when using -plugin-tag(s) without myocamlbuild.ml - (patch by Jacques-Pascal Deplaix) -- PR#6246: allow wilcard _ as for-loop index + (Jacques-Pascal Deplaix) +- PR#6246: allow wildcard _ as for-loop index + (Alain Frisch, request by ygrek) +- PR#6267: more information printed by "bt" command of ocamldebug + (Josh Watzman) +- PR#6270: remove need for -I directives to ocamldebug in common case + (Josh Watzman, review by Xavier Clerc and Alain Frisch) +- PR#6311: Improve signature mismatch error messages + (Alain Frisch, suggestion by Daniel Bünzli) +- PR#6358: obey DESTDIR in install targets + (Gabriel Scherer, request by François Berenger) +- PR#6388, PR#6424: more parsetree correctness checks for -ppx users + (Alain Frisch, request by Peter Zotov and Jun Furuse) +- PR#6406: Expose OCaml version in C headers + (Peter Zotov and Romain Calascibetta) +- PR#6446: improve "unused declaration" warnings wrt. name shadowing + (Alain Frisch) +- PR#6495: ocamlbuild tags 'safe_string', 'unsafe_string' + (Anil Madhavapeddy) +- PR#6497: pass context information to -ppx preprocessors + (Peter Zotov, Alain Frisch) - ocamllex: user-definable refill action - (patch by Frédéric Bour, review by Gabriel Scherer and Luc Maranget) + (Frédéric Bour, review by Gabriel Scherer and Luc Maranget) - shorten syntax for functor signatures: "functor (M1:S1) (M2:S2) .. -> .." - (patches by Thomas Gazagnaire and Jeremy Yallop, review by Gabriel Scherer) - -OCaml 4.01.1: -------------- - -Bug fixes: -- PR#4855: 'camlp4 -I +dir' accepted, dir is related to 'camlp4 -where' -- PR#5820: Fix camlp4 lexer roll back problem -- PR#6062: Fix a regression bug caused by commit 13047 -- PR#6165: Alterations to handling of \013 in source files breaking other tools -- PR#6173: Typing error message is worse that before -- PR#6174: OCaml compiler loops on an example using GADTs (non -rectypes) -- PR#6175: Fix open! -- PR#6183: enhanced documentation for 'Unix.shutdown_connection' -- PR#6216: inlining of GADT matches generates invalid assembly -- PR#6233: out-of-bounds exceptions lose their locations on ARM, PowerPC -- PR#6235: Issue with type information flowing through a variant pattern -- PR#6239: sometimes wrong stack alignment when raising exceptions - in -g mode with backtraces active -- PR#6240: Fail to expand module type abbreviation during substyping -- PR#6241: Assumed inequality between paths involving functor arguments -- PR#6243: Make "ocamlopt -g" more resistant to ill-formed locations -- PR#6267: more information printed by "bt" command of ocamldebug -- PR#6275: Soundness bug related to type constraints - + (Thomas Gazagnaire and Jeremy Yallop, review by Gabriel Scherer) +- make ocamldebug -I auto-detection work with ocamlbuild + (Josh Watzman) OCaml 4.01.0: ------------- @@ -286,7 +547,7 @@ Bug fixes: (Alain Frisch) - PR#5552: unrecognized gcc option -no-cpp-precomp (Damien Doligez, report by Markus Mottl) -- PR#5580: missed opportunities for constant propagation +* PR#5580: missed opportunities for constant propagation (Xavier Leroy and John Carr) - PR#5611: avoid clashes betwen .cmo files and output files during linking (Wojciech Meyer) @@ -483,8 +744,6 @@ Bug fixes: (Jacques Garrigue, report by Elnatan Reisner) - PR#6058: 'ocamlbuild -use-ocamlfind -tag thread -package threads t.cma' fails (Gabriel Scherer, report by Hezekiah M. Carty) -- PR#6060: ocamlbuild rules for -principal, -strict-sequence and -short-paths - (Anil Madhavapeddy) - PR#6069: ocamldoc: lexing: empty token (Maxence Guesdon, Grégoire Henry, report by ygrek) - PR#6072: configure does not handle FreeBSD current (i.e. 10) correctly @@ -506,6 +765,8 @@ Bug fixes: (Jacques Garrigue, report by Leo P. White) - PR#6164: segmentation fault on Num.power_num of 0/1 (Fabrice Le Fessant, report by Johannes Kanig) +- PR#6210: Camlp4 location error + (Hongbo Zhang, report by Jun Furuse) Feature wishes: - PR#5181: Merge common floating point constants in ocamlopt @@ -548,6 +809,10 @@ Feature wishes: (Anil Madhavapeddy, review by Benedikt Meurer) - PR#6059: add -output-obj rules for ocamlbuild (Anil Madhavapeddy) +- PR#6060: ocamlbuild tags 'principal', 'strict_sequence' and 'short_paths' + (Anil Madhavapeddy) +- ocamlbuild tag 'no_alias_deps' + (Daniel Bünzli) Tools: - OCamlbuild now features a bin_annot tag to generate .cmt files. @@ -699,6 +964,7 @@ Installation procedure: (-runtime-variant) to select the debug runtime. Bug Fixes: + - PR#1643: functions of the Lazy module whose named started with 'lazy_' have been deprecated, and new ones without the prefix added - PR#3571: in Bigarrays, call msync() before unmapping to commit changes @@ -153,8 +153,9 @@ Examples: to build a 64-bit version of OCaml: ./configure -cc "gcc -m64" - On a MacOSX 10.6/Intel Core 2, to build a 32-bit version of OCaml: - ./configure -cc "gcc -m32" -as "as -arch i386" -aspp "gcc -m32 -c" + On Intel Mac OS X, to build a 32-bit version of OCaml: + ./configure -host "i386-apple-darwin13.2.0" -cc "gcc -arch i386 -m32" \ + -as "as -arch i386" -aspp "gcc -arch i386 -m32 -c" For Sun Solaris with the "acc" compiler: ./configure -cc "acc -fast" -libs "-lucb" @@ -17,7 +17,8 @@ include stdlib/StdlibModules CAMLC=boot/ocamlrun boot/ocamlc -nostdlib -I boot CAMLOPT=boot/ocamlrun ./ocamlopt -nostdlib -I stdlib -I otherlibs/dynlink -COMPFLAGS=-strict-sequence -w +33..39+48 -warn-error A -bin-annot $(INCLUDES) +COMPFLAGS=-strict-sequence -w +33..39+48 -warn-error A -bin-annot \ + -safe-string $(INCLUDES) LINKFLAGS= CAMLYACC=boot/ocamlyacc @@ -84,10 +85,13 @@ ASMCOMP=asmcomp/arch.cmo asmcomp/debuginfo.cmo \ asmcomp/clambda.cmo asmcomp/printclambda.cmo asmcomp/compilenv.cmo \ asmcomp/closure.cmo asmcomp/strmatch.cmo asmcomp/cmmgen.cmo \ asmcomp/printmach.cmo asmcomp/selectgen.cmo asmcomp/selection.cmo \ - asmcomp/comballoc.cmo asmcomp/liveness.cmo \ + asmcomp/comballoc.cmo \ + asmcomp/CSEgen.cmo asmcomp/CSE.cmo \ + asmcomp/liveness.cmo \ asmcomp/spill.cmo asmcomp/split.cmo \ asmcomp/interf.cmo asmcomp/coloring.cmo \ asmcomp/reloadgen.cmo asmcomp/reload.cmo \ + asmcomp/deadcode.cmo \ asmcomp/printlinear.cmo asmcomp/linearize.cmo \ asmcomp/schedgen.cmo asmcomp/scheduling.cmo \ asmcomp/emitaux.cmo asmcomp/emit.cmo asmcomp/asmgen.cmo \ @@ -121,11 +125,7 @@ defaultentry: # Recompile the system using the bootstrap compiler all: $(MAKE) runtime - $(MAKE) ocamlc - $(MAKE) ocamllex - $(MAKE) ocamlyacc - $(MAKE) ocamltools - $(MAKE) library + $(MAKE) coreall $(MAKE) ocaml $(MAKE) otherlibraries $(OCAMLBUILDBYTE) $(WITH_DEBUGGER) \ $(WITH_OCAMLDOC) @@ -145,11 +145,10 @@ world.opt: # # make coreboot [old system -- you were in a stable state] # <change the source> -# make core [cross-compiler] -# make partialclean [if you get "inconsistent assumptions"] +# make clean runtime coreall # <debug your changes> -# make core [cross-compiler] -# make coreboot [new system -- now you are in a stable state] +# make clean runtime coreall +# make coreboot [new system -- now in a stable state] # Core bootstrapping cycle coreboot: @@ -198,8 +197,7 @@ coldstart: # Build the core system: the minimum needed to make depend and bootstrap core: $(MAKE) coldstart - $(MAKE) ocamlc - $(MAKE) ocamllex ocamlyacc ocamltools library + $(MAKE) coreall # Recompile the core system using the bootstrap compiler coreall: @@ -294,29 +292,39 @@ base.opt: COMPLIBDIR=$(LIBDIR)/compiler-libs +INSTALL_BINDIR=$(DESTDIR)$(BINDIR) +INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR) +INSTALL_COMPLIBDIR=$(DESTDIR)$(COMPLIBDIR) +INSTALL_STUBLIBDIR=$(DESTDIR)$(STUBLIBDIR) +INSTALL_MANDIR=$(DESTDIR)$(MANDIR) + install: - if test -d $(BINDIR); then : ; else $(MKDIR) $(BINDIR); fi - if test -d $(LIBDIR); then : ; else $(MKDIR) $(LIBDIR); fi - if test -d $(STUBLIBDIR); then : ; else $(MKDIR) $(STUBLIBDIR); fi - if test -d $(COMPLIBDIR); then : ; else $(MKDIR) $(COMPLIBDIR); fi - if test -d $(MANDIR)/man$(MANEXT); then : ; \ - else $(MKDIR) $(MANDIR)/man$(MANEXT); fi - cp VERSION $(LIBDIR)/ - cd $(LIBDIR); rm -f dllbigarray.so dllnums.so dllthreads.so \ + if test -d $(INSTALL_BINDIR); then : ; \ + else $(MKDIR) $(INSTALL_BINDIR); fi + if test -d $(INSTALL_LIBDIR); then : ; \ + else $(MKDIR) $(INSTALL_LIBDIR); fi + if test -d $(INSTALL_STUBLIBDIR); then : ; \ + else $(MKDIR) $(INSTALL_STUBLIBDIR); fi + if test -d $(INSTALL_COMPLIBDIR); then : ; \ + else $(MKDIR) $(INSTALL_COMPLIBDIR); fi + if test -d $(INSTALL_MANDIR)/man$(MANEXT); then : ; \ + else $(MKDIR) $(INSTALL_MANDIR)/man$(MANEXT); fi + cp VERSION $(INSTALL_LIBDIR)/ + cd $(INSTALL_LIBDIR); rm -f dllbigarray.so dllnums.so dllthreads.so \ dllunix.so dllgraphics.so dllstr.so cd byterun; $(MAKE) install - cp ocamlc $(BINDIR)/ocamlc$(EXE) - cp ocaml $(BINDIR)/ocaml$(EXE) + cp ocamlc $(INSTALL_BINDIR)/ocamlc$(EXE) + cp ocaml $(INSTALL_BINDIR)/ocaml$(EXE) cd stdlib; $(MAKE) install - cp lex/ocamllex $(BINDIR)/ocamllex$(EXE) - cp yacc/ocamlyacc$(EXE) $(BINDIR)/ocamlyacc$(EXE) + cp lex/ocamllex $(INSTALL_BINDIR)/ocamllex$(EXE) + cp yacc/ocamlyacc$(EXE) $(INSTALL_BINDIR)/ocamlyacc$(EXE) cp utils/*.cmi parsing/*.cmi typing/*.cmi bytecomp/*.cmi driver/*.cmi \ - toplevel/*.cmi $(COMPLIBDIR) + toplevel/*.cmi $(INSTALL_COMPLIBDIR) cp compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma \ compilerlibs/ocamltoplevel.cma $(BYTESTART) $(TOPLEVELSTART) \ - $(COMPLIBDIR) - cp expunge $(LIBDIR)/expunge$(EXE) - cp toplevel/topdirs.cmi $(LIBDIR) + $(INSTALL_COMPLIBDIR) + cp expunge $(INSTALL_LIBDIR)/expunge$(EXE) + cp toplevel/topdirs.cmi $(INSTALL_LIBDIR) cd tools; $(MAKE) install -cd man; $(MAKE) install for i in $(OTHERLIBRARIES); do \ @@ -327,16 +335,16 @@ install: else :; fi if test -n "$(WITH_OCAMLBUILD)"; then (cd ocamlbuild; $(MAKE) install); \ else :; fi - cp config/Makefile $(LIBDIR)/Makefile.config + cp config/Makefile $(INSTALL_LIBDIR)/Makefile.config if test -f ocamlopt; then $(MAKE) installopt; else :; fi # Installation of the native-code compiler installopt: cd asmrun; $(MAKE) install - cp ocamlopt $(BINDIR)/ocamlopt$(EXE) + cp ocamlopt $(INSTALL_BINDIR)/ocamlopt$(EXE) cd stdlib; $(MAKE) installopt - cp asmcomp/*.cmi $(COMPLIBDIR) - cp compilerlibs/ocamloptcomp.cma $(OPTSTART) $(COMPLIBDIR) + cp asmcomp/*.cmi $(INSTALL_COMPLIBDIR) + cp compilerlibs/ocamloptcomp.cma $(OPTSTART) $(INSTALL_COMPLIBDIR) if test -n "$(WITH_OCAMLDOC)"; then (cd ocamldoc; $(MAKE) installopt); \ else :; fi if test -n "$(WITH_OCAMLBUILD)"; then (cd ocamlbuild; $(MAKE) installopt); \ @@ -347,16 +355,16 @@ installopt: cd tools; $(MAKE) installopt installoptopt: - cp ocamlc.opt $(BINDIR)/ocamlc.opt$(EXE) - cp ocamlopt.opt $(BINDIR)/ocamlopt.opt$(EXE) - cp lex/ocamllex.opt $(BINDIR)/ocamllex.opt$(EXE) + cp ocamlc.opt $(INSTALL_BINDIR)/ocamlc.opt$(EXE) + cp ocamlopt.opt $(INSTALL_BINDIR)/ocamlopt.opt$(EXE) + cp lex/ocamllex.opt $(INSTALL_BINDIR)/ocamllex.opt$(EXE) cp compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlcommon.a \ compilerlibs/ocamlbytecomp.cmxa compilerlibs/ocamlbytecomp.a \ compilerlibs/ocamloptcomp.cmxa compilerlibs/ocamloptcomp.a \ $(BYTESTART:.cmo=.cmx) $(BYTESTART:.cmo=.o) \ $(OPTSTART:.cmo=.cmx) $(OPTSTART:.cmo=.o) \ - $(COMPLIBDIR) - cd $(COMPLIBDIR) && $(RANLIB) ocamlcommon.a ocamlbytecomp.a \ + $(INSTALL_COMPLIBDIR) + cd $(INSTALL_COMPLIBDIR) && $(RANLIB) ocamlcommon.a ocamlbytecomp.a \ ocamloptcomp.a clean:: partialclean @@ -364,7 +372,7 @@ clean:: partialclean # Shared parts of the system compilerlibs/ocamlcommon.cma: $(COMMON) - $(CAMLC) -a -o $@ $(COMMON) + $(CAMLC) -a -linkall -o $@ $(COMMON) partialclean:: rm -f compilerlibs/ocamlcommon.cma @@ -378,9 +386,6 @@ partialclean:: ocamlc: compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma $(BYTESTART) $(CAMLC) $(LINKFLAGS) -compat-32 -o ocamlc \ compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma $(BYTESTART) - @sed -e 's|@compiler@|$$topdir/boot/ocamlrun $$topdir/ocamlc|' \ - driver/ocamlcomp.sh.in > ocamlcomp.sh - @chmod +x ocamlcomp.sh # The native-code compiler @@ -392,12 +397,9 @@ partialclean:: ocamlopt: compilerlibs/ocamlcommon.cma compilerlibs/ocamloptcomp.cma $(OPTSTART) $(CAMLC) $(LINKFLAGS) -o ocamlopt \ compilerlibs/ocamlcommon.cma compilerlibs/ocamloptcomp.cma $(OPTSTART) - @sed -e 's|@compiler@|$$topdir/boot/ocamlrun $$topdir/ocamlopt|' \ - driver/ocamlcomp.sh.in > ocamlcompopt.sh - @chmod +x ocamlcompopt.sh partialclean:: - rm -f ocamlopt ocamlcompopt.sh + rm -f ocamlopt # The toplevel @@ -460,7 +462,6 @@ utils/config.ml: utils/config.mlp config/Makefile -e 's|%%HOST%%|$(HOST)|' \ -e 's|%%TARGET%%|$(TARGET)|' \ utils/config.mlp > utils/config.ml - @chmod -w utils/config.ml partialclean:: rm -f utils/config.ml @@ -490,7 +491,7 @@ beforedepend:: parsing/lexer.ml # Shared parts of the system compiled with the native-code compiler compilerlibs/ocamlcommon.cmxa: $(COMMON:.cmo=.cmx) - $(CAMLOPT) -a -o $@ $(COMMON:.cmo=.cmx) + $(CAMLOPT) -a -linkall -o $@ $(COMMON:.cmo=.cmx) partialclean:: rm -f compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlcommon.a @@ -506,9 +507,6 @@ ocamlc.opt: compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlbytecomp.cmxa \ $(CAMLOPT) $(LINKFLAGS) -ccopt "$(BYTECCLINKOPTS)" -o ocamlc.opt \ compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlbytecomp.cmxa \ $(BYTESTART:.cmo=.cmx) -cclib "$(BYTECCLIBS)" - @sed -e 's|@compiler@|$$topdir/ocamlc.opt|' \ - driver/ocamlcomp.sh.in > ocamlcomp.sh - @chmod +x ocamlcomp.sh partialclean:: rm -f ocamlc.opt @@ -525,9 +523,6 @@ ocamlopt.opt: compilerlibs/ocamlcommon.cmxa compilerlibs/ocamloptcomp.cmxa \ $(CAMLOPT) $(LINKFLAGS) -o ocamlopt.opt \ compilerlibs/ocamlcommon.cmxa compilerlibs/ocamloptcomp.cmxa \ $(OPTSTART:.cmo=.cmx) - @sed -e 's|@compiler@|$$topdir/ocamlopt.opt|' \ - driver/ocamlcomp.sh.in > ocamlcompopt.sh - @chmod +x ocamlcompopt.sh partialclean:: rm -f ocamlopt.opt @@ -590,6 +585,14 @@ partialclean:: beforedepend:: asmcomp/selection.ml +asmcomp/CSE.ml: asmcomp/$(ARCH)/CSE.ml + ln -s $(ARCH)/CSE.ml asmcomp/CSE.ml + +partialclean:: + rm -f asmcomp/CSE.ml + +beforedepend:: asmcomp/CSE.ml + asmcomp/reload.ml: asmcomp/$(ARCH)/reload.ml ln -s $(ARCH)/reload.ml asmcomp/reload.ml @@ -609,7 +612,8 @@ beforedepend:: asmcomp/scheduling.ml # Preprocess the code emitters asmcomp/emit.ml: asmcomp/$(ARCH)/emit.mlp tools/cvt_emit - $(CAMLRUN) tools/cvt_emit < asmcomp/$(ARCH)/emit.mlp > asmcomp/emit.ml \ + echo \# 1 \"$(ARCH)/emit.mlp\" > asmcomp/emit.ml + $(CAMLRUN) tools/cvt_emit < asmcomp/$(ARCH)/emit.mlp >> asmcomp/emit.ml \ || { rm -f asmcomp/emit.ml; exit 2; } partialclean:: @@ -700,13 +704,15 @@ clean:: # Tools -ocamltools: ocamlc ocamlyacc ocamllex asmcomp/cmx_format.cmi asmcomp/printclambda.cmo +ocamltools: ocamlc ocamlyacc ocamllex asmcomp/cmx_format.cmi \ + asmcomp/printclambda.cmo cd tools; $(MAKE) all ocamltoolsopt: ocamlopt cd tools; $(MAKE) opt -ocamltoolsopt.opt: ocamlc.opt ocamlyacc ocamllex asmcomp/cmx_format.cmi asmcomp/printclambda.cmx +ocamltoolsopt.opt: ocamlc.opt ocamlyacc ocamllex asmcomp/cmx_format.cmi \ + asmcomp/printclambda.cmx cd tools; $(MAKE) opt.opt partialclean:: @@ -723,6 +729,12 @@ ocamldoc: ocamlc ocamlyacc ocamllex otherlibraries ocamldoc.opt: ocamlc.opt ocamlyacc ocamllex cd ocamldoc && $(MAKE) opt.opt +# Documentation + +html_doc: ocamldoc + make -C ocamldoc html_doc + @echo "documentation is in ./ocamldoc/stdlib_html/" + partialclean:: cd ocamldoc && $(MAKE) clean @@ -818,7 +830,7 @@ clean:: partialclean:: for d in utils parsing typing bytecomp asmcomp driver toplevel tools; \ - do rm -f $$d/*.cm[iox] $$d/*.annot $$d/*.[so] $$d/*~; done + do rm -f $$d/*.cm[ioxt] $$d/*.cmti $$d/*.annot $$d/*.[so] $$d/*~; done rm -f *~ depend: beforedepend @@ -833,8 +845,8 @@ distclean: rm -f boot/ocamlrun boot/ocamlrun.exe boot/camlheader boot/ocamlyacc \ boot/*.cm* boot/libcamlrun.a rm -f config/Makefile config/m.h config/s.h - rm -f tools/*.bak tools/ocamlmklibconfig.ml - rm -f ocaml ocamlc ocamlcomp.sh + rm -f tools/*.bak + rm -f ocaml ocamlc rm -f testsuite/_log .PHONY: all backup bootstrap checkstack clean diff --git a/Makefile.nt b/Makefile.nt index 68a7e1d4d..16b53fe26 100644 --- a/Makefile.nt +++ b/Makefile.nt @@ -81,10 +81,13 @@ ASMCOMP=asmcomp/arch.cmo asmcomp/debuginfo.cmo \ asmcomp/clambda.cmo asmcomp/printclambda.cmo asmcomp/compilenv.cmo \ asmcomp/closure.cmo asmcomp/strmatch.cmo asmcomp/cmmgen.cmo \ asmcomp/printmach.cmo asmcomp/selectgen.cmo asmcomp/selection.cmo \ - asmcomp/comballoc.cmo asmcomp/liveness.cmo \ + asmcomp/comballoc.cmo \ + asmcomp/CSEgen.cmo asmcomp/CSE.cmo \ + asmcomp/liveness.cmo \ asmcomp/spill.cmo asmcomp/split.cmo \ asmcomp/interf.cmo asmcomp/coloring.cmo \ asmcomp/reloadgen.cmo asmcomp/reload.cmo \ + asmcomp/deadcode.cmo \ asmcomp/printlinear.cmo asmcomp/linearize.cmo \ asmcomp/schedgen.cmo asmcomp/scheduling.cmo \ asmcomp/emitaux.cmo asmcomp/emit.cmo asmcomp/asmgen.cmo \ @@ -117,12 +120,13 @@ all: runtime ocamlc ocamllex ocamlyacc ocamltools library ocaml \ # Compile everything the first time world: coldstart all -# Complete bootstrapping cycle -bootstrap: +# Core bootstrapping cycle +coreboot: # Save the original bootstrap compiler $(MAKEREC) backup # Promote the new compiler but keep the old runtime -# This compiler runs on boot/ocamlrun and produces bytecode for byterun/ocamlrun +# This compiler runs on boot/ocamlrun and produces bytecode for +# byterun/ocamlrun $(MAKEREC) promote-cross # Rebuild ocamlc and ocamllex (run on byterun/ocamlrun) $(MAKEREC) partialclean @@ -131,12 +135,18 @@ bootstrap: $(MAKEREC) library-cross # Promote the new compiler and the new runtime $(MAKEREC) promote -# Rebuild everything, including ocaml and the tools +# Rebuild the core system $(MAKEREC) partialclean - $(MAKEREC) all + $(MAKEREC) core # Check if fixpoint reached $(MAKEREC) compare +# Do a complete bootstrapping cycle +bootstrap: + $(MAKEREC) coreboot + $(MAKEREC) all + $(MAKEREC) compare + LIBFILES=stdlib.cma std_exit.cmo *.cmi camlheader # Start up the system from the distribution compiler @@ -149,7 +159,7 @@ coldstart: cd stdlib ; cp $(LIBFILES) ../boot # Build the core system: the minimum needed to make depend and bootstrap -core : runtime ocamlc ocamllex ocamlyacc ocamltools library +core: runtime ocamlc ocamllex ocamlyacc ocamltools library # Save the current bootstrap compiler MAXSAVED=boot/Saved/Saved.prev/Saved.prev/Saved.prev/Saved.prev/Saved.prev @@ -201,11 +211,11 @@ opt-core: opt: $(MAKE) -f Makefile.nt opt-core - $(MAKE) -f Makefile.nt otherlibrariesopt + $(MAKE) -f Makefile.nt otherlibrariesopt ocamltoolsopt # Native-code versions of the tools opt.opt: core opt-core ocamlc.opt all ocamlopt.opt ocamllex.opt \ - ocamltoolsopt.opt $(OCAMLBUILDNATIVE) $(OCAMLDOC_OPT) + ocamltoolsopt ocamltoolsopt.opt $(OCAMLBUILDNATIVE) $(OCAMLDOC_OPT) # Complete build using fast compilers world.opt: coldstart opt.opt @@ -214,63 +224,73 @@ world.opt: coldstart opt.opt COMPLIBDIR=$(LIBDIR)/compiler-libs +INSTALL_BINDIR=$(DESTDIR)$(BINDIR) +INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR) +INSTALL_COMPLIBDIR=$(DESTDIR)$(COMPLIBDIR) +INSTALL_STUBLIBDIR=$(DESTDIR)$(STUBLIBDIR) +INSTALL_MANDIR=$(DESTDIR)$(MANDIR) + install: installbyt installopt installbyt: - mkdir -p $(BINDIR) - mkdir -p $(LIBDIR) - mkdir -p $(COMPLIBDIR) + mkdir -p $(INSTALL_BINDIR) + mkdir -p $(INSTALL_LIBDIR) + mkdir -p $(INSTALL_STUBLIBDIR) + mkdir -p $(INSTALL_COMPLIBDIR) + cp VERSION $(INSTALL_LIBDIR)/ cd byterun ; $(MAKEREC) install - cp ocamlc $(BINDIR)/ocamlc.exe - cp ocaml $(BINDIR)/ocaml.exe + cp ocamlc $(INSTALL_BINDIR)/ocamlc.exe + cp ocaml $(INSTALL_BINDIR)/ocaml.exe cd stdlib ; $(MAKEREC) install - cp lex/ocamllex $(BINDIR)/ocamllex.exe - cp yacc/ocamlyacc.exe $(BINDIR)/ocamlyacc.exe + cp lex/ocamllex $(INSTALL_BINDIR)/ocamllex.exe + cp yacc/ocamlyacc.exe $(INSTALL_BINDIR)/ocamlyacc.exe cp utils/*.cmi parsing/*.cmi typing/*.cmi bytecomp/*.cmi driver/*.cmi \ - toplevel/*.cmi $(COMPLIBDIR) + toplevel/*.cmi $(INSTALL_COMPLIBDIR) cp compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma \ compilerlibs/ocamltoplevel.cma $(BYTESTART) $(TOPLEVELSTART) \ - $(COMPLIBDIR) - cp expunge $(LIBDIR)/expunge.exe - cp toplevel/topdirs.cmi $(LIBDIR) + $(INSTALL_COMPLIBDIR) + cp expunge $(INSTALL_LIBDIR)/expunge.exe + cp toplevel/topdirs.cmi $(INSTALL_LIBDIR) cd tools ; $(MAKEREC) install + for i in $(OTHERLIBRARIES); do \ + $(MAKEREC) -C otherlibs/$$i install || exit $$?; \ + done if test -n "$(WITH_OCAMLDOC)"; then (cd ocamldoc; $(MAKEREC) install); \ else :; fi - mkdir -p $(STUBLIBDIR) - for i in $(OTHERLIBRARIES); do $(MAKEREC) -C otherlibs/$$i install; done if test -n "$(WITH_DEBUGGER)"; then (cd debugger; $(MAKEREC) install); \ else :; fi if test -n "$(WITH_OCAMLBUILD)"; then (cd ocamlbuild; $(MAKE) install); \ else :; fi - cp config/Makefile $(LIBDIR)/Makefile.config - cp README $(DISTRIB)/Readme.general.txt - cp README.win32 $(DISTRIB)/Readme.windows.txt - cp LICENSE $(DISTRIB)/License.txt - cp Changes $(DISTRIB)/Changes.txt + cp config/Makefile $(INSTALL_LIBDIR)/Makefile.config + cp README $(INSTALL_DISTRIB)/Readme.general.txt + cp README.win32 $(INSTALL_DISTRIB)/Readme.windows.txt + cp LICENSE $(INSTALL_DISTRIB)/License.txt + cp Changes $(INSTALL_DISTRIB)/Changes.txt # Installation of the native-code compiler installopt: cd asmrun ; $(MAKEREC) install - cp ocamlopt $(BINDIR)/ocamlopt.exe + cp ocamlopt $(INSTALL_BINDIR)/ocamlopt.exe cd stdlib ; $(MAKEREC) installopt - cp asmcomp/*.cmi driver/*.cmi $(COMPLIBDIR) - cp compilerlibs/ocamloptcomp.cma $(OPTSTART) $(COMPLIBDIR) + cp asmcomp/*.cmi $(INSTALL_COMPLIBDIR) + cp compilerlibs/ocamloptcomp.cma $(OPTSTART) $(INSTALL_COMPLIBDIR) if test -n "$(WITH_OCAMLDOC)"; then (cd ocamldoc; $(MAKEREC) installopt); fi if test -n "$(WITH_OCAMLBUILD)"; then (cd ocamlbuild; $(MAKE) installopt); \ else :; fi for i in $(OTHERLIBRARIES); do $(MAKEREC) -C otherlibs/$$i installopt; done if test -f ocamlopt.opt ; then $(MAKEREC) installoptopt; fi + cd tools; $(MAKE) installopt installoptopt: - cp ocamlc.opt $(BINDIR)/ocamlc.opt$(EXE) - cp ocamlopt.opt $(BINDIR)/ocamlopt.opt$(EXE) - cp lex/ocamllex.opt $(BINDIR)/ocamllex.opt$(EXE) + cp ocamlc.opt $(INSTALL_BINDIR)/ocamlc.opt$(EXE) + cp ocamlopt.opt $(INSTALL_BINDIR)/ocamlopt.opt$(EXE) + cp lex/ocamllex.opt $(INSTALL_BINDIR)/ocamllex.opt$(EXE) cp compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlcommon.$(A) \ compilerlibs/ocamlbytecomp.cmxa compilerlibs/ocamlbytecomp.$(A) \ compilerlibs/ocamloptcomp.cmxa compilerlibs/ocamloptcomp.$(A) \ $(BYTESTART:.cmo=.cmx) $(BYTESTART:.cmo=.$(O)) \ $(OPTSTART:.cmo=.cmx) $(OPTSTART:.cmo=.$(O)) \ - $(COMPLIBDIR) + $(INSTALL_COMPLIBDIR) clean:: partialclean @@ -291,12 +311,9 @@ partialclean:: ocamlc: compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma $(BYTESTART) $(CAMLC) $(LINKFLAGS) -compat-32 -o ocamlc compilerlibs/ocamlcommon.cma \ compilerlibs/ocamlbytecomp.cma $(BYTESTART) - @sed -e 's|@compiler@|$$topdir/boot/ocamlrun $$topdir/ocamlc|' \ - driver/ocamlcomp.sh.in > ocamlcomp.sh - @chmod +x ocamlcomp.sh partialclean:: - rm -f ocamlc ocamlcomp.sh + rm -f ocamlc # The native-code compiler @@ -308,12 +325,9 @@ partialclean:: ocamlopt: compilerlibs/ocamlcommon.cma compilerlibs/ocamloptcomp.cma $(OPTSTART) $(CAMLC) $(LINKFLAGS) -o ocamlopt \ compilerlibs/ocamlcommon.cma compilerlibs/ocamloptcomp.cma $(OPTSTART) - @sed -e 's|@compiler@|$$topdir/boot/ocamlrun $$topdir/ocamlopt|' \ - driver/ocamlcomp.sh.in > ocamlcompopt.sh - @chmod +x ocamlcompopt.sh partialclean:: - rm -f ocamlopt ocamlcompopt.sh + rm -f ocamlopt # The toplevel @@ -380,7 +394,6 @@ utils/config.ml: utils/config.mlp config/Makefile -e 's|%%HOST%%|$(HOST)|' \ -e 's|%%TARGET%%|$(TARGET)|' \ utils/config.mlp > utils/config.ml - @chmod -w utils/config.ml partialclean:: rm -f utils/config.ml @@ -426,9 +439,6 @@ ocamlc.opt: compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlbytecomp.cmxa \ $(CAMLOPT) $(LINKFLAGS) -ccopt "$(BYTECCLINKOPTS)" -o ocamlc.opt \ compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlbytecomp.cmxa \ $(BYTESTART:.cmo=.cmx) -cclib "$(BYTECCLIBS)" - @sed -e 's|@compiler@|$$topdir/ocamlc.opt|' \ - driver/ocamlcomp.sh.in > ocamlcomp.sh - @chmod +x ocamlcomp.sh partialclean:: rm -f ocamlc.opt @@ -445,9 +455,6 @@ ocamlopt.opt: compilerlibs/ocamlcommon.cmxa compilerlibs/ocamloptcomp.cmxa \ $(CAMLOPT) $(LINKFLAGS) -o ocamlopt.opt \ compilerlibs/ocamlcommon.cmxa compilerlibs/ocamloptcomp.cmxa \ $(OPTSTART:.cmo=.cmx) - @sed -e 's|@compiler@|$$topdir/ocamlopt.opt|' \ - driver/ocamlcomp.sh.in > ocamlcompopt.sh - @chmod +x ocamlcompopt.sh partialclean:: rm -f ocamlopt.opt @@ -516,6 +523,14 @@ partialclean:: beforedepend:: asmcomp/selection.ml +asmcomp/CSE.ml: asmcomp/$(ARCH)/CSE.ml + cp asmcomp/$(ARCH)/CSE.ml asmcomp/CSE.ml + +partialclean:: + rm -f asmcomp/CSE.ml + +beforedepend:: asmcomp/CSE.ml + asmcomp/reload.ml: asmcomp/$(ARCH)/reload.ml cp asmcomp/$(ARCH)/reload.ml asmcomp/reload.ml @@ -614,10 +629,17 @@ clean:: # Tools -ocamltools: ocamlc ocamlyacc ocamllex asmcomp/cmx_format.cmi asmcomp/printclambda.cmo +ocamltools: ocamlc ocamlyacc ocamllex asmcomp/cmx_format.cmi \ + asmcomp/printclambda.cmo cd tools ; $(MAKEREC) all -ocamltoolsopt.opt: ocamlc.opt ocamlyacc ocamllex asmcomp/cmx_format.cmi asmcomp/printclambda.cmx + +ocamltoolsopt: + cd tools ; $(MAKEREC) opt + +ocamltoolsopt.opt: ocamlc.opt ocamlyacc ocamllex asmcomp/cmx_format.cmi \ + asmcomp/printclambda.cmx cd tools ; $(MAKEREC) opt.opt + partialclean:: cd tools ; $(MAKEREC) clean alldepend:: @@ -706,7 +728,13 @@ depend: beforedepend alldepend:: depend distclean: - ./build/distclean.sh + $(MAKE) clean + rm -f boot/ocamlrun boot/ocamlrun.exe boot/camlheader boot/ocamlyacc \ + boot/*.cm* boot/libcamlrun.a + rm -f config/Makefile config/m.h config/s.h + rm -f tools/*.bak + rm -f ocaml ocamlc + rm -f testsuite/_log .PHONY: all backup bootstrap checkstack clean .PHONY: partialclean beforedepend alldepend cleanboot coldstart @@ -714,8 +742,8 @@ distclean: .PHONY: coreboot defaultentry depend distclean install installopt .PHONY: library library-cross libraryopt ocamlbuild-mixed-boot .PHONY: ocamlbuild.byte ocamlbuild.native ocamldebugger ocamldoc -.PHONY: ocamldoc.opt ocamllex ocamllex.opt ocamltools ocamltools.opt -.PHONY: ocamlyacc opt-core opt opt.opt otherlibraries +.PHONY: ocamldoc.opt ocamllex ocamllex.opt ocamltools ocamltoolsopt +.PHONY: ocamltoolsopt.opt ocamlyacc opt-core opt opt.opt otherlibraries .PHONY: otherlibrariesopt promote promote-cross .PHONY: restore runtime runtimeopt makeruntimeopt world world.opt diff --git a/README.win32 b/README.win32 index 7575888f1..111c9a107 100644 --- a/README.win32 +++ b/README.win32 @@ -260,6 +260,12 @@ NOTES: * The replay debugger is partially supported (no reverse execution). +* The default Makefile.mingw passes -static-libgcc to the linker. + For more information on this topic: + + http://gcc.gnu.org/onlinedocs/gcc-4.9.1/gcc/Link-Options.html#Link-Options + http://caml.inria.fr/mantis/view.php?id=6411 + ------------------------------------------------------------------------------ The Cygwin port of OCaml @@ -1,4 +1,4 @@ -4.02.0+dev3-2013-12-19 +4.03.0+dev4-2014-09-26 # The version string is the first line of this file. # It must be in the format described in stdlib/sys.mli diff --git a/asmcomp/.ignore b/asmcomp/.ignore index 31d00178a..8c24e74ad 100644 --- a/asmcomp/.ignore +++ b/asmcomp/.ignore @@ -4,3 +4,4 @@ proc.ml selection.ml reload.ml scheduling.ml +CSE.ml diff --git a/asmcomp/CSEgen.ml b/asmcomp/CSEgen.ml new file mode 100644 index 000000000..6571ad53f --- /dev/null +++ b/asmcomp/CSEgen.ml @@ -0,0 +1,322 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2014 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* Common subexpression elimination by value numbering over extended + basic blocks. *) + +open Mach + +type valnum = int + +(* We maintain sets of equations of the form + valnums = operation(valnums) + plus a mapping from registers to valnums (value numbers). *) + +type rhs = operation * valnum array + +module Equations = + Map.Make(struct type t = rhs let compare = Pervasives.compare end) + +type numbering = + { num_next: int; (* next fresh value number *) + num_eqs: valnum array Equations.t; (* mapping rhs -> valnums *) + num_reg: valnum Reg.Map.t } (* mapping register -> valnum *) + +let empty_numbering = + { num_next = 0; num_eqs = Equations.empty; num_reg = Reg.Map.empty } + +(** Generate a fresh value number [v] and associate it to register [r]. + Returns a pair [(n',v)] with the updated value numbering [n']. *) + +let fresh_valnum_reg n r = + let v = n.num_next in + ({n with num_next = v + 1; num_reg = Reg.Map.add r v n.num_reg}, v) + +(* Same, for a set of registers [rs]. *) + +let array_fold_transf (f: numbering -> 'a -> numbering * 'b) n (a: 'a array) + : numbering * 'b array = + match Array.length a with + | 0 -> (n, [||]) + | 1 -> let (n', b) = f n a.(0) in (n', [|b|]) + | l -> let b = Array.make l 0 and n = ref n in + for i = 0 to l - 1 do + let (n', x) = f !n a.(i) in + b.(i) <- x; n := n' + done; + (!n, b) + +let fresh_valnum_regs n rs = + array_fold_transf fresh_valnum_reg n rs + +(** [valnum_reg n r] returns the value number for the contents of + register [r]. If none exists, a fresh value number is returned + and associated with register [r]. The possibly updated numbering + is also returned. [valnum_regs] is similar, but for an array of + registers. *) + +let valnum_reg n r = + try + (n, Reg.Map.find r n.num_reg) + with Not_found -> + fresh_valnum_reg n r + +let valnum_regs n rs = + array_fold_transf valnum_reg n rs + +(* Look up the set of equations for an equation with the given rhs. + Return [Some res] if there is one, where [res] is the lhs. *) + +let find_equation n rhs = + try + Some(Equations.find rhs n.num_eqs) + with Not_found -> + None + +(* Find a register containing the given value number. *) + +let find_reg_containing n v = + Reg.Map.fold (fun r v' res -> if v' = v then Some r else res) + n.num_reg None + +(* Find a set of registers containing the given value numbers. *) + +let find_regs_containing n vs = + match Array.length vs with + | 0 -> Some [||] + | 1 -> begin match find_reg_containing n vs.(0) with + | None -> None + | Some r -> Some [|r|] + end + | l -> let rs = Array.make l Reg.dummy in + begin try + for i = 0 to l - 1 do + match find_reg_containing n vs.(i) with + | None -> raise Exit + | Some r -> rs.(i) <- r + done; + Some rs + with Exit -> + None + end + +(* Associate the given value number to the given result register, + without adding new equations. *) + +let set_known_reg n r v = + { n with num_reg = Reg.Map.add r v n.num_reg } + +(* Associate the given value numbers to the given result registers, + without adding new equations. *) + +let array_fold2 f n a1 a2 = + let l = Array.length a1 in + assert (l = Array.length a2); + let n = ref n in + for i = 0 to l - 1 do n := f !n a1.(i) a2.(i) done; + !n + +let set_known_regs n rs vs = + array_fold2 set_known_reg n rs vs + +(* Record the effect of a move: no new equations, but the result reg + maps to the same value number as the argument reg. *) + +let set_move n src dst = + let (n1, v) = valnum_reg n src in + { n1 with num_reg = Reg.Map.add dst v n1.num_reg } + +(* Record the equation [fresh valnums = rhs] and associate the given + result registers [rs] to [fresh valnums]. *) + +let set_fresh_regs n rs rhs = + let (n1, vs) = fresh_valnum_regs n rs in + { n1 with num_eqs = Equations.add rhs vs n.num_eqs } + +(* Forget everything we know about the given result registers, + which are receiving unpredictable values at run-time. *) + +let set_unknown_regs n rs = + { n with num_reg = Array.fold_right Reg.Map.remove rs n.num_reg } + +(* Keep only the equations satisfying the given predicate. *) + +let filter_equations pred n = + { n with num_eqs = Equations.filter (fun (op,_) res -> pred op) n.num_eqs } + +(* Prepend a set of moves before [i] to assign [srcs] to [dsts]. *) + +let insert_single_move i src dst = instr_cons (Iop Imove) [|src|] [|dst|] i + +let insert_move srcs dsts i = + match Array.length srcs with + | 0 -> i + | 1 -> instr_cons (Iop Imove) srcs dsts i + | l -> (* Parallel move: first copy srcs into tmps one by one, + then copy tmps into dsts one by one *) + let tmps = Reg.createv_like srcs in + let i1 = array_fold2 insert_single_move i tmps dsts in + array_fold2 insert_single_move i1 srcs tmps + +(* Classification of operations *) + +type op_class = + | Op_pure (* pure arithmetic, produce one or several result *) + | Op_checkbound (* checkbound-style: no result, can raise an exn *) + | Op_load (* memory load *) + | Op_store of bool (* memory store, false = init, true = assign *) + | Op_other (* anything else that does not allocate nor store in memory *) + +class cse_generic = object (self) + +(* Default classification of operations. Can be overriden in + processor-specific files to classify specific operations better. *) + +method class_of_operation op = + match op with + | Imove | Ispill | Ireload -> assert false (* treated specially *) + | Iconst_int _ | Iconst_float _ | Iconst_symbol _ + | Iconst_blockheader _ -> Op_pure + | Icall_ind | Icall_imm _ | Itailcall_ind | Itailcall_imm _ + | Iextcall _ -> assert false (* treated specially *) + | Istackoffset _ -> Op_other + | Iload(_,_) -> Op_load + | Istore(_,_,asg) -> Op_store asg + | Ialloc _ -> assert false (* treated specially *) + | Iintop(Icheckbound) -> Op_checkbound + | Iintop _ -> Op_pure + | Iintop_imm(Icheckbound, _) -> Op_checkbound + | Iintop_imm(_, _) -> Op_pure + | Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf + | Ifloatofint | Iintoffloat -> Op_pure + | Ispecific _ -> Op_other + +(* Operations that are so cheap that it isn't worth factoring them. *) + +method is_cheap_operation op = + match op with + | Iconst_int _ | Iconst_blockheader _ -> true + | _ -> false + +(* Forget all equations involving memory loads. Performed after a + non-initializing store *) + +method private kill_loads n = + filter_equations (fun o -> self#class_of_operation o <> Op_load) n + +(* Perform CSE on the given instruction [i] and its successors. + [n] is the value numbering current at the beginning of [i]. *) + +method private cse n i = + match i.desc with + | Iend | Ireturn | Iop(Itailcall_ind) | Iop(Itailcall_imm _) + | Iexit _ | Iraise _ -> + i + | Iop (Imove | Ispill | Ireload) -> + (* For moves, we associate the same value number to the result reg + as to the argument reg. *) + let n1 = set_move n i.arg.(0) i.res.(0) in + {i with next = self#cse n1 i.next} + | Iop (Icall_ind | Icall_imm _ | Iextcall _) -> + (* For function calls, we should at least forget: + - equations involving memory loads, since the callee can + perform arbitrary memory stores; + - equations involving arithmetic operations that can + produce bad pointers into the heap (see below for Ialloc); + - mappings from hardware registers to value numbers, + since the callee does not preserve these registers. + That doesn't leave much usable information: checkbounds + could be kept, but won't be usable for CSE as one of their + arguments is always a memory load. For simplicity, we + just forget everything. *) + {i with next = self#cse empty_numbering i.next} + | Iop (Ialloc _) -> + (* For allocations, we must avoid extending the live range of a + pseudoregister across the allocation if this pseudoreg can + contain a value that looks like a pointer into the heap but + is not a pointer to the beginning of a Caml object. PR#6484 + is an example of such a value (a derived pointer into a + block). In the absence of more precise typing information, + we just forget everything. *) + {i with next = self#cse empty_numbering i.next} + | Iop op -> + begin match self#class_of_operation op with + | Op_pure | Op_checkbound | Op_load -> + let (n1, varg) = valnum_regs n i.arg in + let n2 = set_unknown_regs n1 (Proc.destroyed_at_oper i.desc) in + begin match find_equation n1 (op, varg) with + | Some vres -> + (* This operation was computed earlier. *) + (* Are there registers that hold the results computed earlier? *) + begin match find_regs_containing n1 vres with + | Some res when (not (self#is_cheap_operation op)) + && (not (Proc.regs_are_volatile res)) -> + (* We can replace res <- op args with r <- move res, + provided res are stable (non-volatile) registers. + If the operation is very cheap to compute, e.g. + an integer constant, don't bother. *) + let n3 = set_known_regs n1 i.res vres in + (* This is n1 above and not n2 because the move + does not destroy any regs *) + insert_move res i.res (self#cse n3 i.next) + | _ -> + (* We already computed the operation but lost its + results. Associate the result registers to + the result valnums of the previous operation. *) + let n3 = set_known_regs n2 i.res vres in + {i with next = self#cse n3 i.next} + end + | None -> + (* This operation produces a result we haven't seen earlier. *) + let n3 = set_fresh_regs n2 i.res (op, varg) in + {i with next = self#cse n3 i.next} + end + | Op_store false | Op_other -> + (* An initializing store or an "other" operation do not invalidate + any equations, but we do not know anything about the results. *) + let n1 = set_unknown_regs n (Proc.destroyed_at_oper i.desc) in + let n2 = set_unknown_regs n1 i.res in + {i with next = self#cse n2 i.next} + | Op_store true -> + (* A non-initializing store can invalidate + anything we know about prior loads. *) + let n1 = set_unknown_regs n (Proc.destroyed_at_oper i.desc) in + let n2 = set_unknown_regs n1 i.res in + let n3 = self#kill_loads n2 in + {i with next = self#cse n3 i.next} + end + (* For control structures, we set the numbering to empty at every + join point, but propagate the current numbering across fork points. *) + | Iifthenelse(test, ifso, ifnot) -> + let n1 = set_unknown_regs n (Proc.destroyed_at_oper i.desc) in + {i with desc = Iifthenelse(test, self#cse n1 ifso, self#cse n1 ifnot); + next = self#cse empty_numbering i.next} + | Iswitch(index, cases) -> + let n1 = set_unknown_regs n (Proc.destroyed_at_oper i.desc) in + {i with desc = Iswitch(index, Array.map (self#cse n1) cases); + next = self#cse empty_numbering i.next} + | Iloop(body) -> + {i with desc = Iloop(self#cse empty_numbering body); + next = self#cse empty_numbering i.next} + | Icatch(nfail, body, handler) -> + {i with desc = Icatch(nfail, self#cse n body, + self#cse empty_numbering handler); + next = self#cse empty_numbering i.next} + | Itrywith(body, handler) -> + {i with desc = Itrywith(self#cse n body, + self#cse empty_numbering handler); + next = self#cse empty_numbering i.next} + +method fundecl f = + {f with fun_body = self#cse empty_numbering f.fun_body} + +end diff --git a/asmcomp/CSEgen.mli b/asmcomp/CSEgen.mli new file mode 100644 index 000000000..0b375ff57 --- /dev/null +++ b/asmcomp/CSEgen.mli @@ -0,0 +1,35 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2014 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* Common subexpression elimination by value numbering over extended + basic blocks. *) + +type op_class = + | Op_pure (* pure, produce one result *) + | Op_checkbound (* checkbound-style: no result, can raise an exn *) + | Op_load (* memory load *) + | Op_store of bool (* memory store, false = init, true = assign *) + | Op_other (* anything else that does not allocate nor store in memory *) + +class cse_generic : object + (* The following methods can be overriden to handle processor-specific + operations. *) + + method class_of_operation: Mach.operation -> op_class + + method is_cheap_operation: Mach.operation -> bool + (* Operations that are so cheap that it isn't worth factoring them. *) + + (* The following method is the entry point and should not be overridden *) + method fundecl: Mach.fundecl -> Mach.fundecl + +end diff --git a/asmcomp/amd64/CSE.ml b/asmcomp/amd64/CSE.ml new file mode 100644 index 000000000..aee43d2bc --- /dev/null +++ b/asmcomp/amd64/CSE.ml @@ -0,0 +1,38 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2014 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* CSE for the AMD64 *) + +open Arch +open Mach +open CSEgen + +class cse = object (self) + +inherit cse_generic as super + +method! class_of_operation op = + match op with + | Ispecific spec -> + begin match spec with + | Ilea _ -> Op_pure + | Istore_int(_, _, is_asg) | Istore_symbol(_, _, is_asg) -> Op_store is_asg + | Ioffset_loc(_, _) -> Op_store true + | Ifloatarithmem _ | Ifloatsqrtf _ -> Op_load + | Ibswap _ | Isqrtf -> super#class_of_operation op + end + | _ -> super#class_of_operation op + +end + +let fundecl f = + (new cse)#fundecl f diff --git a/asmcomp/amd64/arch.ml b/asmcomp/amd64/arch.ml index b0a5ffb8b..a4f1abd97 100644 --- a/asmcomp/amd64/arch.ml +++ b/asmcomp/amd64/arch.ml @@ -33,8 +33,9 @@ type addressing_mode = type specific_operation = Ilea of addressing_mode (* "lea" gives scaled adds *) - | Istore_int of nativeint * addressing_mode (* Store an integer constant *) - | Istore_symbol of string * addressing_mode (* Store a symbol *) + | Istore_int of nativeint * addressing_mode * bool + (* Store an integer constant *) + | Istore_symbol of string * addressing_mode * bool (* Store a symbol *) | Ioffset_loc of int * addressing_mode (* Add a constant to a location *) | Ifloatarithmem of float_operation * addressing_mode (* Float arith operation with memory *) @@ -101,10 +102,14 @@ let print_addressing printreg addr ppf arg = let print_specific_operation printreg op ppf arg = match op with | Ilea addr -> print_addressing printreg addr ppf arg - | Istore_int(n, addr) -> - fprintf ppf "[%a] := %nd" (print_addressing printreg addr) arg n - | Istore_symbol(lbl, addr) -> - fprintf ppf "[%a] := \"%s\"" (print_addressing printreg addr) arg lbl + | Istore_int(n, addr, is_assign) -> + fprintf ppf "[%a] := %nd %s" + (print_addressing printreg addr) arg n + (if is_assign then "(assign)" else "(init)") + | Istore_symbol(lbl, addr, is_assign) -> + fprintf ppf "[%a] := \"%s\" %s" + (print_addressing printreg addr) arg lbl + (if is_assign then "(assign)" else "(init)") | Ioffset_loc(n, addr) -> fprintf ppf "[%a] +:= %i" (print_addressing printreg addr) arg n | Isqrtf -> diff --git a/asmcomp/amd64/emit.mlp b/asmcomp/amd64/emit.mlp index bdcc3a18d..b576ece98 100644 --- a/asmcomp/amd64/emit.mlp +++ b/asmcomp/amd64/emit.mlp @@ -335,15 +335,16 @@ let output_epilogue f = (* Floating-point constants *) -let float_constants = ref ([] : (string * int) list) +let float_constants = ref ([] : (int64 * int) list) let add_float_constant cst = + let repr = Int64.bits_of_float cst in try - List.assoc cst !float_constants + List.assoc repr !float_constants with Not_found -> let lbl = new_label() in - float_constants := (cst, lbl) :: !float_constants; + float_constants := (repr, lbl) :: !float_constants; lbl let emit_float_constant (cst, lbl) = @@ -382,12 +383,12 @@ let emit_instr fallthrough i = ` movq ${emit_nativeint n}, {emit_reg i.res.(0)}\n` else ` movabsq ${emit_nativeint n}, {emit_reg i.res.(0)}\n` - | Lop(Iconst_float s) -> - begin match Int64.bits_of_float (float_of_string s) with + | Lop(Iconst_float f) -> + begin match Int64.bits_of_float f with | 0x0000_0000_0000_0000L -> (* +0.0 *) ` xorpd {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` | _ -> - let lbl = add_float_constant s in + let lbl = add_float_constant f in ` movsd {emit_label lbl}(%rip), {emit_reg i.res.(0)}\n` end | Lop(Iconst_symbol s) -> @@ -448,7 +449,7 @@ let emit_instr fallthrough i = | Double | Double_u -> ` movsd {emit_addressing addr i.arg 0}, {emit_reg dest}\n` end - | Lop(Istore(chunk, addr)) -> + | Lop(Istore(chunk, addr, _)) -> begin match chunk with | Word -> ` movq {emit_reg i.arg.(0)}, {emit_addressing addr i.arg 1}\n` @@ -541,9 +542,9 @@ let emit_instr fallthrough i = ` cvttsd2siq {emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n` | Lop(Ispecific(Ilea addr)) -> ` leaq {emit_addressing addr i.arg 0}, {emit_reg i.res.(0)}\n` - | Lop(Ispecific(Istore_int(n, addr))) -> + | Lop(Ispecific(Istore_int(n, addr, _))) -> ` movq ${emit_nativeint n}, {emit_addressing addr i.arg 0}\n` - | Lop(Ispecific(Istore_symbol(s, addr))) -> + | Lop(Ispecific(Istore_symbol(s, addr, _))) -> assert (not !pic_code && not !Clflags.dlcode); ` movq ${emit_symbol s}, {emit_addressing addr i.arg 0}\n` | Lop(Ispecific(Ioffset_loc(n, addr))) -> @@ -764,9 +765,9 @@ let emit_item = function | Cint n -> ` .quad {emit_nativeint n}\n` | Csingle f -> - emit_float32_directive ".long" f + emit_float32_directive ".long" (Int32.bits_of_float f) | Cdouble f -> - emit_float64_directive ".quad" f + emit_float64_directive ".quad" (Int64.bits_of_float f) | Csymbol_address s -> ` .quad {emit_symbol s}\n` | Clabel_address lbl -> diff --git a/asmcomp/amd64/emit_nt.mlp b/asmcomp/amd64/emit_nt.mlp index 77156b8f0..f14e69cd3 100644 --- a/asmcomp/amd64/emit_nt.mlp +++ b/asmcomp/amd64/emit_nt.mlp @@ -53,9 +53,10 @@ let slot_offset loc cl = else !stack_offset + (num_stack_slots.(0) + n) * 8 | Outgoing n -> n -(* Output a 32 bit integer in hex *) +(* Output a 32 or 64 bit integer in hex *) let emit_int32 n = emit_printf "0%lxh" n +let emit_int64 n = emit_printf "0%Lxh" n (* Symbols *) @@ -321,36 +322,20 @@ let output_epilogue () = (* Floating-point constants *) -let float_constants = ref ([] : (string * int) list) +let float_constants = ref ([] : (int64 * int) list) let add_float_constant cst = + let repr = Int64.bits_of_float cst in try - List.assoc cst !float_constants + List.assoc repr !float_constants with Not_found -> let lbl = new_label() in - float_constants := (cst, lbl) :: !float_constants; + float_constants := (repr, lbl) :: !float_constants; lbl -let emit_float s = - (* MASM doesn't like floating-point constants such as 2e9. - Turn them into 2.0e9. *) - let pos_e = ref (-1) and pos_dot = ref (-1) in - for i = 0 to String.length s - 1 do - match s.[i] with - 'e'|'E' -> pos_e := i - | '.' -> pos_dot := i - | _ -> () - done; - if !pos_dot < 0 && !pos_e >= 0 then begin - emit_string (String.sub s 0 !pos_e); - emit_string ".0"; - emit_string (String.sub s !pos_e (String.length s - !pos_e)) - end else - emit_string s - let emit_float_constant (cst, lbl) = - `{emit_label lbl} REAL8 {emit_float cst}\n` + `{emit_label lbl} QWORD {emit_int64 cst}\n` let emit_movabs reg n = (* force ml64 to use mov reg, imm64 instruction *) @@ -389,12 +374,12 @@ let emit_instr fallthrough i = ` mov {emit_reg32 i.res.(0)}, {emit_nativeint n}\n` else emit_movabs i.res.(0) n - | Lop(Iconst_float s) -> - begin match Int64.bits_of_float (float_of_string s) with + | Lop(Iconst_float f) -> + begin match Int64.bits_of_float f with | 0x0000_0000_0000_0000L -> (* +0.0 *) ` xorpd {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` | _ -> - let lbl = add_float_constant s in + let lbl = add_float_constant f in ` movsd {emit_reg i.res.(0)}, {emit_label lbl}\n` end | Lop(Iconst_symbol s) -> @@ -458,7 +443,7 @@ let emit_instr fallthrough i = | Double | Double_u -> ` movsd {emit_reg dest}, REAL8 PTR {emit_addressing addr i.arg 0}\n` end - | Lop(Istore(chunk, addr)) -> + | Lop(Istore(chunk, addr, _)) -> begin match chunk with | Word -> ` mov QWORD PTR {emit_addressing addr i.arg 1}, {emit_reg i.arg.(0)}\n` @@ -547,9 +532,9 @@ let emit_instr fallthrough i = ` cvttsd2si {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}\n` | Lop(Ispecific(Ilea addr)) -> ` lea {emit_reg i.res.(0)}, {emit_addressing addr i.arg 0}\n` - | Lop(Ispecific(Istore_int(n, addr))) -> + | Lop(Ispecific(Istore_int(n, addr, _))) -> ` mov QWORD PTR {emit_addressing addr i.arg 0}, {emit_nativeint n}\n` - | Lop(Ispecific(Istore_symbol(s, addr))) -> + | Lop(Ispecific(Istore_symbol(s, addr, _))) -> assert (not !pic_code); add_used_symbol s; ` mov QWORD PTR {emit_addressing addr i.arg 0}, OFFSET {emit_symbol s}\n` @@ -721,9 +706,9 @@ let emit_item = function | Cint n -> ` QWORD {emit_nativeint n}\n` | Csingle f -> - ` REAL4 {emit_float f}\n` + ` DWORD {emit_int32 (Int32.bits_of_float f)}\n` | Cdouble f -> - ` REAL8 {emit_float f}\n` + ` QWORD {emit_int64 (Int64.bits_of_float f)}\n` | Csymbol_address s -> add_used_symbol s; ` QWORD {emit_symbol s}\n` diff --git a/asmcomp/amd64/proc.ml b/asmcomp/amd64/proc.ml index b6e0fa94a..298e92900 100644 --- a/asmcomp/amd64/proc.ml +++ b/asmcomp/amd64/proc.ml @@ -117,12 +117,12 @@ let rotate_registers = false (* Representation of hard registers by pseudo-registers *) let hard_int_reg = - let v = Array.create 13 Reg.dummy in + let v = Array.make 13 Reg.dummy in for i = 0 to 12 do v.(i) <- Reg.at_location Int (Reg i) done; v let hard_float_reg = - let v = Array.create 16 Reg.dummy in + let v = Array.make 16 Reg.dummy in for i = 0 to 15 do v.(i) <- Reg.at_location Float (Reg (100 + i)) done; v @@ -149,7 +149,7 @@ let word_addressed = false let calling_conventions first_int last_int first_float last_float make_stack arg = - let loc = Array.create (Array.length arg) Reg.dummy in + let loc = Array.make (Array.length arg) Reg.dummy in let int = ref first_int in let float = ref first_float in let ofs = ref 0 in @@ -210,7 +210,7 @@ let win64_float_external_arguments = [| 100 (*xmm0*); 101 (*xmm1*); 102 (*xmm2*); 103 (*xmm3*) |] let win64_loc_external_arguments arg = - let loc = Array.create (Array.length arg) Reg.dummy in + let loc = Array.make (Array.length arg) Reg.dummy in let reg = ref 0 and ofs = ref 32 in for i = 0 to Array.length arg - 1 do @@ -239,6 +239,10 @@ let loc_external_arguments = let loc_exn_bucket = rax +(* Volatile registers: none *) + +let regs_are_volatile rs = false + (* Registers destroyed by operations *) let destroyed_at_c_call = @@ -259,7 +263,7 @@ let destroyed_at_oper = function | Iop(Iextcall(_, false)) -> destroyed_at_c_call | Iop(Iintop(Idiv | Imod)) | Iop(Iintop_imm((Idiv | Imod), _)) -> [| rax; rdx |] - | Iop(Istore(Single, _)) -> [| rxmm15 |] + | Iop(Istore(Single, _, _)) -> [| rxmm15 |] | Iop(Ialloc _ | Iintop(Imulh | Icomp _) | Iintop_imm((Icomp _), _)) -> [| rax |] | Iswitch(_, _) -> [| rax; rdx |] @@ -290,10 +294,21 @@ let max_register_pressure = function if fp then [| 10; 16 |] else [| 11; 16 |] | Ialloc _ | Iintop(Icomp _) | Iintop_imm((Icomp _), _) -> if fp then [| 11; 16 |] else [| 12; 16 |] - | Istore(Single, _) -> + | Istore(Single, _, _) -> if fp then [| 12; 15 |] else [| 13; 15 |] | _ -> if fp then [| 12; 16 |] else [| 13; 16 |] +(* Pure operations (without any side effect besides updating their result + registers). *) + +let op_is_pure = function + | Icall_ind | Icall_imm _ | Itailcall_ind | Itailcall_imm _ + | Iextcall _ | Istackoffset _ | Istore _ | Ialloc _ + | Iintop(Icheckbound) | Iintop_imm(Icheckbound, _) -> false + | Ispecific(Ilea _) -> true + | Ispecific _ -> false + | _ -> true + (* Layout of the stack frame *) let num_stack_slots = [| 0; 0 |] diff --git a/asmcomp/amd64/selection.ml b/asmcomp/amd64/selection.ml index cce7e575d..fa7fe66c0 100644 --- a/asmcomp/amd64/selection.ml +++ b/asmcomp/amd64/selection.ml @@ -152,20 +152,20 @@ method select_addressing chunk exp = | Ascaledadd(e1, e2, scale) -> (Iindexed2scaled(scale, d), Ctuple[e1; e2]) -method! select_store addr exp = +method! select_store is_assign addr exp = match exp with Cconst_int n when self#is_immediate n -> - (Ispecific(Istore_int(Nativeint.of_int n, addr)), Ctuple []) - | Cconst_natint n when self#is_immediate_natint n -> - (Ispecific(Istore_int(n, addr)), Ctuple []) + (Ispecific(Istore_int(Nativeint.of_int n, addr, is_assign)), Ctuple []) + | (Cconst_natint n | Cconst_blockheader n) when self#is_immediate_natint n -> + (Ispecific(Istore_int(n, addr, is_assign)), Ctuple []) | Cconst_pointer n when self#is_immediate n -> - (Ispecific(Istore_int(Nativeint.of_int n, addr)), Ctuple []) + (Ispecific(Istore_int(Nativeint.of_int n, addr, is_assign)), Ctuple []) | Cconst_natpointer n when self#is_immediate_natint n -> - (Ispecific(Istore_int(n, addr)), Ctuple []) + (Ispecific(Istore_int(n, addr, is_assign)), Ctuple []) | Cconst_symbol s when not (!pic_code || !Clflags.dlcode) -> - (Ispecific(Istore_symbol(s, addr)), Ctuple []) + (Ispecific(Istore_symbol(s, addr, is_assign)), Ctuple []) | _ -> - super#select_store addr exp + super#select_store is_assign addr exp method! select_operation op args = match op with @@ -234,6 +234,9 @@ method select_floatarith commutative regular_op mem_op args = | _ -> assert false +method! mark_c_tailcall = + Proc.contains_calls := true + (* Deal with register constraints *) method! insert_op_debug op dbg rs rd = diff --git a/asmcomp/arm/CSE.ml b/asmcomp/arm/CSE.ml new file mode 100644 index 000000000..bea333dc4 --- /dev/null +++ b/asmcomp/arm/CSE.ml @@ -0,0 +1,37 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2014 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* CSE for ARM *) + +open Arch +open Mach +open CSEgen + +class cse = object (self) + +inherit cse_generic as super + +method! class_of_operation op = + match op with + | Ispecific(Ishiftcheckbound _) -> Op_checkbound + | Ispecific _ -> Op_pure + | _ -> super#class_of_operation op + +method! is_cheap_operation op = + match op with + | Iconst_int n | Iconst_blockheader n -> n <= 255n && n >= 0n + | _ -> false + +end + +let fundecl f = + (new cse)#fundecl f diff --git a/asmcomp/arm/arch.ml b/asmcomp/arm/arch.ml index fbd9f6db0..d93c1e0e4 100644 --- a/asmcomp/arm/arch.ml +++ b/asmcomp/arm/arch.ml @@ -21,7 +21,7 @@ type fpu = Soft | VFPv2 | VFPv3_D16 | VFPv3 let abi = match Config.system with - "linux_eabi" -> EABI + "linux_eabi" | "freebsd" -> EABI | "linux_eabihf" -> EABI_HF | _ -> assert false diff --git a/asmcomp/arm/emit.mlp b/asmcomp/arm/emit.mlp index 2f20ecf61..61035b85f 100644 --- a/asmcomp/arm/emit.mlp +++ b/asmcomp/arm/emit.mlp @@ -273,7 +273,7 @@ let function_name = ref "" (* Entry point for tail recursive calls *) let tailrec_entry_point = ref 0 (* Pending floating-point literals *) -let float_literals = ref ([] : (string * label) list) +let float_literals = ref ([] : (int64 * label) list) (* Pending relative references to the global offset table *) let gotrel_literals = ref ([] : (label * label) list) (* Pending symbol literals *) @@ -283,12 +283,13 @@ let num_literals = ref 0 (* Label a floating-point literal *) let float_literal f = + let repr = Int64.bits_of_float f in try - List.assoc f !float_literals + List.assoc repr !float_literals with Not_found -> let lbl = new_label() in num_literals := !num_literals + 2; - float_literals := (f, lbl) :: !float_literals; + float_literals := (repr, lbl) :: !float_literals; lbl (* Label a GOTREL literal *) @@ -314,7 +315,7 @@ let emit_literals() = ` .align 3\n`; List.iter (fun (f, lbl) -> - `{emit_label lbl}: .double {emit_string f}\n`) + `{emit_label lbl}:`; emit_float64_split_directive ".long" f) !float_literals; float_literals := [] end; @@ -390,8 +391,7 @@ let emit_instr i = | Lop(Iconst_int n | Iconst_blockheader n) -> emit_intconst i.res.(0) (Nativeint.to_int32 n) | Lop(Iconst_float f) when !fpu = Soft -> - ` @ {emit_string f}\n`; - let bits = Int64.bits_of_float (float_of_string f) in + let bits = Int64.bits_of_float f in let high_bits = Int64.to_int32 (Int64.shift_right_logical bits 32) and low_bits = Int64.to_int32 bits in if is_immediate low_bits || is_immediate high_bits then begin @@ -406,7 +406,7 @@ let emit_instr i = end | Lop(Iconst_float f) when !fpu = VFPv2 -> let lbl = float_literal f in - ` fldd {emit_reg i.res.(0)}, {emit_label lbl} @ {emit_string f}\n`; + ` fldd {emit_reg i.res.(0)}, {emit_label lbl}\n`; 1 | Lop(Iconst_float f) -> let encode imm = @@ -425,12 +425,12 @@ let emit_instr i = let ex = ((ex + 3) land 0x07) lxor 0x04 in Some((sg lsl 7) lor (ex lsl 4) lor mn) end in - begin match encode (Int64.bits_of_float (float_of_string f)) with + begin match encode (Int64.bits_of_float f) with None -> let lbl = float_literal f in - ` fldd {emit_reg i.res.(0)}, {emit_label lbl} @ {emit_string f}\n` + ` fldd {emit_reg i.res.(0)}, {emit_label lbl}\n` | Some imm8 -> - ` fconstd {emit_reg i.res.(0)}, #{emit_int imm8} @ {emit_string f}\n` + ` fconstd {emit_reg i.res.(0)}, #{emit_int imm8}\n` end; 1 | Lop(Iconst_symbol s) -> emit_load_symbol_addr i.res.(0) s @@ -508,10 +508,10 @@ let emit_instr i = | Double_u -> "fldd" | _ (* 32-bit quantities *) -> "ldr" in ` {emit_string instr} {emit_reg r}, {emit_addressing addr i.arg 0}\n`; 1 - | Lop(Istore(Single, addr)) when !fpu >= VFPv2 -> + | Lop(Istore(Single, addr, _)) when !fpu >= VFPv2 -> ` fcvtsd s14, {emit_reg i.arg.(0)}\n`; ` fsts s14, {emit_addressing addr i.arg 1}\n`; 2 - | Lop(Istore((Double | Double_u), addr)) when !fpu = Soft -> + | Lop(Istore((Double | Double_u), addr, _)) when !fpu = Soft -> (* Use STM or STRD if possible *) begin match i.arg.(0), i.arg.(1), addr with {loc = Reg rt}, {loc = Reg rt2}, Iindexed 0 @@ -525,7 +525,7 @@ let emit_instr i = ` str {emit_reg i.arg.(0)}, {emit_addressing addr i.arg 2}\n`; ` str {emit_reg i.arg.(1)}, {emit_addressing addr' i.arg 2}\n`; 2 end - | Lop(Istore(size, addr)) -> + | Lop(Istore(size, addr, _)) -> let r = i.arg.(0) in let instr = match size with @@ -874,8 +874,8 @@ let emit_item = function | Cint16 n -> ` .short {emit_int n}\n` | Cint32 n -> ` .long {emit_int32 (Nativeint.to_int32 n)}\n` | Cint n -> ` .long {emit_int32 (Nativeint.to_int32 n)}\n` - | Csingle f -> ` .single {emit_string f}\n` - | Cdouble f -> ` .double {emit_string f}\n` + | Csingle f -> emit_float32_directive ".long" (Int32.bits_of_float f) + | Cdouble f -> emit_float64_split_directive ".long" (Int64.bits_of_float f) | Csymbol_address s -> ` .word {emit_symbol s}\n` | Clabel_address lbl -> ` .word {emit_data_label lbl}\n` | Cstring s -> emit_string_directive " .ascii " s diff --git a/asmcomp/arm/proc.ml b/asmcomp/arm/proc.ml index a16c35a22..58bfa427b 100644 --- a/asmcomp/arm/proc.ml +++ b/asmcomp/arm/proc.ml @@ -82,14 +82,14 @@ let rotate_registers = true (* Representation of hard registers by pseudo-registers *) let hard_int_reg = - let v = Array.create 9 Reg.dummy in + let v = Array.make 9 Reg.dummy in for i = 0 to 8 do v.(i) <- Reg.at_location Int (Reg i) done; v let hard_float_reg = - let v = Array.create 32 Reg.dummy in + let v = Array.make 32 Reg.dummy in for i = 0 to 31 do v.(i) <- Reg.at_location Float (Reg(100 + i)) done; @@ -108,7 +108,7 @@ let stack_slot slot ty = let calling_conventions first_int last_int first_float last_float make_stack arg = - let loc = Array.create (Array.length arg) Reg.dummy in + let loc = Array.make (Array.length arg) Reg.dummy in let int = ref first_int in let float = ref first_float in let ofs = ref 0 in @@ -166,13 +166,17 @@ let loc_external_results res = let loc_exn_bucket = phys_reg 0 +(* Volatile registers: none *) + +let regs_are_volatile rs = false + (* Registers destroyed by operations *) let destroyed_at_alloc = (* r0-r6, d0-d15 preserved *) Array.of_list (List.map phys_reg [7;8; - 116;116;118;119;120;121;122;123; + 116;117;118;119;120;121;122;123; 124;125;126;127;128;129;130;131]) let destroyed_at_c_call = @@ -183,12 +187,12 @@ let destroyed_at_c_call = [0;1;2;3;8; 100;101;102;103;104;105;106;107; 108;109;110;111;112;113;114;115; - 116;116;118;119;120;121;122;123; + 116;117;118;119;120;121;122;123; 124;125;126;127;128;129;130;131] | EABI_HF -> (* r4-r7, d8-d15 preserved *) [0;1;2;3;8; 100;101;102;103;104;105;106;107; - 116;116;118;119;120;121;122;123; + 116;117;118;119;120;121;122;123; 124;125;126;127;128;129;130;131])) let destroyed_at_oper = function @@ -203,7 +207,7 @@ let destroyed_at_oper = function [| phys_reg 3; phys_reg 8 |] (* r3 and r12 destroyed *) | Iop(Iintop Imulh) when !arch < ARMv6 -> [| phys_reg 8 |] (* r12 destroyed *) - | Iop(Iintoffloat | Ifloatofint | Iload(Single, _) | Istore(Single, _)) -> + | Iop(Iintoffloat | Ifloatofint | Iload(Single, _) | Istore(Single, _, _)) -> [| phys_reg 107 |] (* d7 (s14-s15) destroyed *) | _ -> [||] @@ -215,6 +219,7 @@ let safe_register_pressure = function Iextcall(_, _) -> if abi = EABI then 0 else 4 | Ialloc _ -> if abi = EABI then 0 else 7 | Iconst_symbol _ when !pic_code -> 7 + | Iintop Imulh when !arch < ARMv6 -> 8 | _ -> 9 let max_register_pressure = function @@ -222,9 +227,20 @@ let max_register_pressure = function | Ialloc _ -> if abi = EABI then [| 7; 0; 0 |] else [| 7; 8; 8 |] | Iconst_symbol _ when !pic_code -> [| 7; 16; 32 |] | Iintoffloat | Ifloatofint - | Iload(Single, _) | Istore(Single, _) -> [| 9; 15; 31 |] + | Iload(Single, _) | Istore(Single, _, _) -> [| 9; 15; 31 |] + | Iintop Imulh when !arch < ARMv6 -> [| 8; 16; 32 |] | _ -> [| 9; 16; 32 |] +(* Pure operations (without any side effect besides updating their result + registers). *) + +let op_is_pure = function + | Icall_ind | Icall_imm _ | Itailcall_ind | Itailcall_imm _ + | Iextcall _ | Istackoffset _ | Istore _ | Ialloc _ + | Iintop(Icheckbound) | Iintop_imm(Icheckbound, _) + | Ispecific(Ishiftcheckbound _) -> false + | _ -> true + (* Layout of the stack *) let num_stack_slots = [| 0; 0; 0 |] diff --git a/asmcomp/arm/selection.ml b/asmcomp/arm/selection.ml index 9cd6090cd..4725942b7 100644 --- a/asmcomp/arm/selection.ml +++ b/asmcomp/arm/selection.ml @@ -48,6 +48,8 @@ let select_shiftop = function exception Use_default let r1 = phys_reg 1 +let r6 = phys_reg 6 +let r7 = phys_reg 7 let r12 = phys_reg 8 let pseudoregs_for_operation op arg res = @@ -58,10 +60,12 @@ let pseudoregs_for_operation op arg res = Iintop Imul | Ispecific Imuladd when !arch < ARMv6 -> (arg, [| res.(0); arg.(0) |]) (* For smull rdlo,rdhi,rn,rm (pre-ARMv6) the registers rdlo, rdhi and rn - must be different. We deal with this by pretending that rn is also a - result of the smull operation. *) + must be different. Also, rdlo (whose contents we discard) is always + forced to be r12 in proc.ml, which means that neither rdhi and rn can + be r12. To keep things simple, we force both of those two to specific + hard regs: rdhi in r6 and rn in r7. *) | Iintop Imulh when !arch < ARMv6 -> - (arg, [| res.(0); arg.(0) |]) + ([| r7; arg.(1) |], [| r6 |]) (* Soft-float Iabsf and Inegf: arg.(0) and res.(0) must be the same *) | Iabsf | Inegf when !fpu = Soft -> ([|res.(0); arg.(1)|], res) diff --git a/asmcomp/arm64/CSE.ml b/asmcomp/arm64/CSE.ml new file mode 100644 index 000000000..f9e03e487 --- /dev/null +++ b/asmcomp/arm64/CSE.ml @@ -0,0 +1,37 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2014 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* CSE for ARM64 *) + +open Arch +open Mach +open CSEgen + +class cse = object (self) + +inherit cse_generic as super + +method! class_of_operation op = + match op with + | Ispecific(Ishiftcheckbound _) -> Op_checkbound + | Ispecific _ -> Op_pure + | _ -> super#class_of_operation op + +method! is_cheap_operation op = + match op with + | Iconst_int n | Iconst_blockheader n -> n <= 65535n && n >= 0n + | _ -> false + +end + +let fundecl f = + (new cse)#fundecl f diff --git a/asmcomp/arm64/emit.mlp b/asmcomp/arm64/emit.mlp index 274e6ffca..734bd23e1 100644 --- a/asmcomp/arm64/emit.mlp +++ b/asmcomp/arm64/emit.mlp @@ -104,7 +104,7 @@ let emit_stack r = (* Output an addressing mode *) let emit_symbol_offset s ofs = - emit_symbol s; + emit_symbol s; if ofs > 0 then `+{emit_int ofs}` else if ofs < 0 then `-{emit_int (-ofs)}` else () @@ -286,7 +286,7 @@ let emit_literals() = ` .align 3\n`; List.iter (fun (f, lbl) -> - `{emit_label lbl}: .quad `; emit_printf "0x%Lx\n" f) + `{emit_label lbl}:`; emit_float64_directive ".quad" f) !float_literals; float_literals := [] end @@ -326,15 +326,15 @@ let emit_instr i = | Lop(Iconst_int n | Iconst_blockheader n) -> emit_intconst i.res.(0) n | Lop(Iconst_float f) -> - let b = Int64.bits_of_float(float_of_string f) in + let b = Int64.bits_of_float f in if b = 0L then - ` fmov {emit_reg i.res.(0)}, xzr /* {emit_string f} */\n` + ` fmov {emit_reg i.res.(0)}, xzr\n` else if is_immediate_float b then - ` fmov {emit_reg i.res.(0)}, #{emit_printf "0x%Lx" b} /* {emit_string f} */\n` + ` fmov {emit_reg i.res.(0)}, #{emit_printf "0x%Lx" b}\n` else begin let lbl = float_literal b in ` adrp {emit_reg reg_tmp1}, {emit_label lbl}\n`; - ` ldr {emit_reg i.res.(0)}, [{emit_reg reg_tmp1}, #:lo12:{emit_label lbl}] /* {emit_string f} */\n` + ` ldr {emit_reg i.res.(0)}, [{emit_reg reg_tmp1}, #:lo12:{emit_label lbl}]\n` end | Lop(Iconst_symbol s) -> emit_load_symbol_addr i.res.(0) s @@ -388,7 +388,7 @@ let emit_instr i = | Word | Double | Double_u -> ` ldr {emit_reg dst}, {emit_addressing addr base}\n` end - | Lop(Istore(size, addr)) -> + | Lop(Istore(size, addr, _)) -> let src = i.arg.(0) in let base = match addr with @@ -578,7 +578,7 @@ let emit_instr i = for j = 0 to Array.length jumptbl - 1 do ` b {emit_label jumptbl.(j)}\n` done -(* Alternative: +(* Alternative: let lbltbl = new_label() in ` adr {emit_reg reg_tmp1}, {emit_label lbltbl}\n`; ` ldr {emit_wreg reg_tmp2}, [{emit_reg reg_tmp1}, {emit_reg i.arg.(0)}, lsl #2]\n`; @@ -644,7 +644,7 @@ let fundecl fundecl = call_gc_sites := []; bound_error_sites := []; ` .text\n`; - ` .align 2\n`; + ` .align 3\n`; ` .globl {emit_symbol fundecl.fun_name}\n`; ` .type {emit_symbol fundecl.fun_name}, %function\n`; `{emit_symbol fundecl.fun_name}:\n`; @@ -652,7 +652,7 @@ let fundecl fundecl = cfi_startproc(); if !Clflags.gprofile then emit_profile(); let n = frame_size() in - if n > 0 then + if n > 0 then emit_stack_adjustment (-n); if !contains_calls then ` str x30, [sp, #{emit_int (n-8)}]\n`; @@ -675,8 +675,8 @@ let emit_item = function | Cint16 n -> ` .short {emit_int n}\n` | Cint32 n -> ` .long {emit_nativeint n}\n` | Cint n -> ` .quad {emit_nativeint n}\n` - | Csingle f -> emit_float32_directive ".long" f - | Cdouble f -> emit_float64_directive ".quad" f + | Csingle f -> emit_float32_directive ".long" (Int32.bits_of_float f) + | Cdouble f -> emit_float64_directive ".quad" (Int64.bits_of_float f) | Csymbol_address s -> ` .quad {emit_symbol s}\n` | Clabel_address lbl -> ` .quad {emit_data_label lbl}\n` | Cstring s -> emit_string_directive " .ascii " s @@ -685,6 +685,7 @@ let emit_item = function let data l = ` .data\n`; + ` .align 3\n`; List.iter emit_item l (* Beginning / end of an assembly file *) diff --git a/asmcomp/arm64/proc.ml b/asmcomp/arm64/proc.ml index b52c2fd8a..0222b72a7 100644 --- a/asmcomp/arm64/proc.ml +++ b/asmcomp/arm64/proc.ml @@ -76,14 +76,14 @@ let rotate_registers = true (* Representation of hard registers by pseudo-registers *) let hard_int_reg = - let v = Array.create 28 Reg.dummy in + let v = Array.make 28 Reg.dummy in for i = 0 to 27 do v.(i) <- Reg.at_location Int (Reg i) done; v let hard_float_reg = - let v = Array.create 32 Reg.dummy in + let v = Array.make 32 Reg.dummy in for i = 0 to 31 do v.(i) <- Reg.at_location Float (Reg(100 + i)) done; @@ -105,7 +105,7 @@ let stack_slot slot ty = let calling_conventions first_int last_int first_float last_float make_stack arg = - let loc = Array.create (Array.length arg) Reg.dummy in + let loc = Array.make (Array.length arg) Reg.dummy in let int = ref first_int in let float = ref first_float in let ofs = ref 0 in @@ -160,6 +160,10 @@ let loc_external_results res = let loc_exn_bucket = phys_reg 0 +(* Volatile registers: none *) + +let regs_are_volatile rs = false + (* Registers destroyed by operations *) let destroyed_at_c_call = @@ -177,7 +181,7 @@ let destroyed_at_oper = function destroyed_at_c_call | Iop(Ialloc _) -> [| reg_x15 |] - | Iop(Iintoffloat | Ifloatofint | Iload(Single, _) | Istore(Single, _)) -> + | Iop(Iintoffloat | Ifloatofint | Iload(Single, _) | Istore(Single, _, _)) -> [| reg_d7 |] (* d7 / s7 destroyed *) | _ -> [||] @@ -194,9 +198,19 @@ let max_register_pressure = function | Iextcall(_, _) -> [| 10; 8 |] | Ialloc _ -> [| 25; 32 |] | Iintoffloat | Ifloatofint - | Iload(Single, _) | Istore(Single, _) -> [| 26; 31 |] + | Iload(Single, _) | Istore(Single, _, _) -> [| 26; 31 |] | _ -> [| 26; 32 |] +(* Pure operations (without any side effect besides updating their result + registers). *) + +let op_is_pure = function + | Icall_ind | Icall_imm _ | Itailcall_ind | Itailcall_imm _ + | Iextcall _ | Istackoffset _ | Istore _ | Ialloc _ + | Iintop(Icheckbound) | Iintop_imm(Icheckbound, _) + | Ispecific(Ishiftcheckbound _) -> false + | _ -> true + (* Layout of the stack *) let num_stack_slots = [| 0; 0 |] diff --git a/asmcomp/arm64/selection.ml b/asmcomp/arm64/selection.ml index 36b401894..e7ded8fb4 100644 --- a/asmcomp/arm64/selection.ml +++ b/asmcomp/arm64/selection.ml @@ -37,7 +37,7 @@ let is_offset chunk n = / \ / \ / \ \ / \ / \ / -0--> [1] --1--> [2] --0--> [3] - / + / [0] \ -1--> [4] --0--> [5] --1--> [6] @@ -61,7 +61,7 @@ let auto_table = [| (* accepting?, next on 0, next on 1 *) let rec run_automata nbits state input = let (acc, next0, next1) = auto_table.(state) in if nbits <= 0 - then acc + then acc else run_automata (nbits - 1) (if input land 1 = 0 then next0 else next1) (input asr 1) @@ -71,7 +71,7 @@ let rec run_automata nbits state input = pattern of this kind. *) let is_logical_immediate n = - n <> 0 && n <> -1 && run_automata 64 0 n + n <> 0 && n <> -1 && run_automata 64 0 n let is_intconst = function Cconst_int _ -> true diff --git a/asmcomp/asmgen.ml b/asmcomp/asmgen.ml index 34283875c..311bb029b 100644 --- a/asmcomp/asmgen.ml +++ b/asmcomp/asmgen.ml @@ -64,7 +64,10 @@ let compile_fundecl (ppf : formatter) fd_cmm = ++ pass_dump_if ppf dump_selection "After instruction selection" ++ Comballoc.fundecl ++ pass_dump_if ppf dump_combine "After allocation combining" + ++ CSE.fundecl + ++ pass_dump_if ppf dump_cse "After CSE" ++ liveness ppf + ++ Deadcode.fundecl ++ pass_dump_if ppf dump_live "Liveness analysis" ++ Spill.fundecl ++ liveness ppf diff --git a/asmcomp/asmlink.ml b/asmcomp/asmlink.ml index 5842f44eb..153da7cac 100644 --- a/asmcomp/asmlink.ml +++ b/asmcomp/asmlink.ml @@ -33,31 +33,37 @@ exception Error of error (* Consistency check between interfaces and implementations *) let crc_interfaces = Consistbl.create () +let interfaces = ref ([] : string list) let crc_implementations = Consistbl.create () -let extra_implementations = ref ([] : string list) +let implementations = ref ([] : string list) let implementations_defined = ref ([] : (string * string) list) let cmx_required = ref ([] : string list) let check_consistency file_name unit crc = begin try List.iter - (fun (name, crc) -> - if name = unit.ui_name - then Consistbl.set crc_interfaces name crc file_name - else Consistbl.check crc_interfaces name crc file_name) + (fun (name, crco) -> + interfaces := name :: !interfaces; + match crco with + None -> () + | Some crc -> + if name = unit.ui_name + then Consistbl.set crc_interfaces name crc file_name + else Consistbl.check crc_interfaces name crc file_name) unit.ui_imports_cmi with Consistbl.Inconsistency(name, user, auth) -> raise(Error(Inconsistent_interface(name, user, auth))) end; begin try List.iter - (fun (name, crc) -> - if crc <> cmx_not_found_crc then - Consistbl.check crc_implementations name crc file_name - else if List.mem name !cmx_required then - raise(Error(Missing_cmx(file_name, name))) - else - extra_implementations := name :: !extra_implementations) + (fun (name, crco) -> + implementations := name :: !implementations; + match crco with + None -> + if List.mem name !cmx_required then + raise(Error(Missing_cmx(file_name, name))) + | Some crc -> + Consistbl.check crc_implementations name crc file_name) unit.ui_imports_cmx with Consistbl.Inconsistency(name, user, auth) -> raise(Error(Inconsistent_implementation(name, user, auth))) @@ -67,6 +73,7 @@ let check_consistency file_name unit crc = raise (Error(Multiple_definition(unit.ui_name, file_name, source))) with Not_found -> () end; + implementations := unit.ui_name :: !implementations; Consistbl.set crc_implementations unit.ui_name crc file_name; implementations_defined := (unit.ui_name, file_name) :: !implementations_defined; @@ -74,13 +81,9 @@ let check_consistency file_name unit crc = cmx_required := unit.ui_name :: !cmx_required let extract_crc_interfaces () = - Consistbl.extract crc_interfaces + Consistbl.extract !interfaces crc_interfaces let extract_crc_implementations () = - List.fold_left - (fun ncl n -> - if List.mem_assoc n ncl then ncl else (n, cmx_not_found_crc) :: ncl) - (Consistbl.extract crc_implementations) - !extra_implementations + Consistbl.extract !implementations crc_implementations (* Add C objects and options and "custom" info from a library descriptor. See bytecomp/bytelink.ml for comments on the order of C objects. *) @@ -214,10 +217,14 @@ let make_startup_file ppf filename units_list = (Cmmgen.globals_map (List.map (fun (unit,_,crc) -> - try (unit.ui_name, List.assoc unit.ui_name unit.ui_imports_cmi, - crc, - unit.ui_defines) - with Not_found -> assert false) + let intf_crc = + try + match List.assoc unit.ui_name unit.ui_imports_cmi with + None -> assert false + | Some crc -> crc + with Not_found -> assert false + in + (unit.ui_name, intf_crc, crc, unit.ui_defines)) units_list)); compile_phrase(Cmmgen.data_segment_table ("_startup" :: name_list)); compile_phrase(Cmmgen.code_segment_table ("_startup" :: name_list)); @@ -397,3 +404,11 @@ let () = | Error err -> Some (Location.error_of_printer_file report_error err) | _ -> None ) + +let reset () = + Consistbl.clear crc_interfaces; + Consistbl.clear crc_implementations; + implementations_defined := []; + cmx_required := []; + interfaces := []; + implementations := [] diff --git a/asmcomp/asmlink.mli b/asmcomp/asmlink.mli index 1cf9e302c..60a2111e1 100644 --- a/asmcomp/asmlink.mli +++ b/asmcomp/asmlink.mli @@ -20,9 +20,10 @@ val link_shared: formatter -> string list -> string -> unit val call_linker_shared: string list -> string -> unit +val reset : unit -> unit val check_consistency: string -> Cmx_format.unit_infos -> Digest.t -> unit -val extract_crc_interfaces: unit -> (string * Digest.t) list -val extract_crc_implementations: unit -> (string * Digest.t) list +val extract_crc_interfaces: unit -> (string * Digest.t option) list +val extract_crc_implementations: unit -> (string * Digest.t option) list type error = File_not_found of string diff --git a/asmcomp/asmpackager.ml b/asmcomp/asmpackager.ml index a8fcfe789..d900df1e1 100644 --- a/asmcomp/asmpackager.ml +++ b/asmcomp/asmpackager.ml @@ -130,7 +130,7 @@ let build_package_cmx members cmxfile = List.flatten (List.map (fun info -> info.ui_defines) units) @ [ui.ui_symbol]; ui_imports_cmi = - (ui.ui_name, Env.crc_of_unit ui.ui_name) :: + (ui.ui_name, Some (Env.crc_of_unit ui.ui_name)) :: filter(Asmlink.extract_crc_interfaces()); ui_imports_cmx = filter(Asmlink.extract_crc_implementations()); @@ -161,7 +161,7 @@ let package_object_files ppf files targetcmx (* The entry point *) -let package_files ppf files targetcmx = +let package_files ppf initial_env files targetcmx = let files = List.map (fun f -> @@ -177,7 +177,8 @@ let package_files ppf files targetcmx = (* Set the name of the current compunit *) Compilenv.reset ?packname:!Clflags.for_package targetname; try - let coercion = Typemod.package_units files targetcmi targetname in + let coercion = + Typemod.package_units initial_env files targetcmi targetname in package_object_files ppf files targetcmx targetobj targetname coercion with x -> remove_file targetcmx; remove_file targetobj; diff --git a/asmcomp/asmpackager.mli b/asmcomp/asmpackager.mli index 65272b7ed..4d47f5c28 100644 --- a/asmcomp/asmpackager.mli +++ b/asmcomp/asmpackager.mli @@ -13,7 +13,7 @@ (* "Package" a set of .cmx/.o files into one .cmx/.o file having the original compilation units as sub-modules. *) -val package_files: Format.formatter -> string list -> string -> unit +val package_files: Format.formatter -> Env.t -> string list -> string -> unit type error = Illegal_renaming of string * string * string diff --git a/asmcomp/clambda.ml b/asmcomp/clambda.ml index c4baf6cf9..ed96f218b 100644 --- a/asmcomp/clambda.ml +++ b/asmcomp/clambda.ml @@ -19,12 +19,12 @@ open Lambda type function_label = string type ustructured_constant = - | Uconst_float of string + | Uconst_float of float | Uconst_int32 of int32 | Uconst_int64 of int64 | Uconst_nativeint of nativeint | Uconst_block of int * uconstant list - | Uconst_float_array of string list + | Uconst_float_array of float list | Uconst_string of string and uconstant = @@ -43,7 +43,7 @@ type ulambda = | Uletrec of (Ident.t * ulambda) list * ulambda | Uprim of primitive * ulambda list * Debuginfo.t | Uswitch of ulambda * ulambda_switch - | Ustringswitch of ulambda * (string * ulambda) list * ulambda + | Ustringswitch of ulambda * (string * ulambda) list * ulambda option | Ustaticfail of int * ulambda list | Ucatch of int * Ident.t list * ulambda * ulambda | Utrywith of ulambda * Ident.t * ulambda @@ -74,7 +74,9 @@ type function_description = { fun_label: function_label; (* Label of direct entry point *) fun_arity: int; (* Number of arguments *) mutable fun_closed: bool; (* True if environment not used *) - mutable fun_inline: (Ident.t list * ulambda) option } + mutable fun_inline: (Ident.t list * ulambda) option; + mutable fun_float_const_prop: bool (* Can propagate FP consts *) + } (* Approximation of values *) @@ -84,3 +86,65 @@ type value_approximation = | Value_unknown | Value_const of uconstant | Value_global_field of string * int + +(* Comparison functions for constants. We must not use Pervasives.compare + because it compares "0.0" and "-0.0" equal. (PR#6442) *) + +let compare_floats x1 x2 = + Int64.compare (Int64.bits_of_float x1) (Int64.bits_of_float x2) + +let rec compare_float_lists l1 l2 = + match l1, l2 with + | [], [] -> 0 + | [], _::_ -> -1 + | _::_, [] -> 1 + | h1::t1, h2::t2 -> + let c = compare_floats h1 h2 in + if c <> 0 then c else compare_float_lists t1 t2 + +let compare_constants c1 c2 = + match c1, c2 with + | Uconst_ref(lbl1, c1), Uconst_ref(lbl2, c2) -> String.compare lbl1 lbl2 + (* Same labels -> same constants. + Different labels -> different constants, even if the contents + match, because of string constants that must not be + reshared. *) + | Uconst_int n1, Uconst_int n2 -> Pervasives.compare n1 n2 + | Uconst_ptr n1, Uconst_ptr n2 -> Pervasives.compare n1 n2 + | Uconst_ref _, _ -> -1 + | Uconst_int _, Uconst_ref _ -> 1 + | Uconst_int _, Uconst_ptr _ -> -1 + | Uconst_ptr _, _ -> 1 + +let rec compare_constant_lists l1 l2 = + match l1, l2 with + | [], [] -> 0 + | [], _::_ -> -1 + | _::_, [] -> 1 + | h1::t1, h2::t2 -> + let c = compare_constants h1 h2 in + if c <> 0 then c else compare_constant_lists t1 t2 + +let rank_structured_constant = function + | Uconst_float _ -> 0 + | Uconst_int32 _ -> 1 + | Uconst_int64 _ -> 2 + | Uconst_nativeint _ -> 3 + | Uconst_block _ -> 4 + | Uconst_float_array _ -> 5 + | Uconst_string _ -> 6 + +let compare_structured_constants c1 c2 = + match c1, c2 with + | Uconst_float x1, Uconst_float x2 -> compare_floats x1 x2 + | Uconst_int32 x1, Uconst_int32 x2 -> Int32.compare x1 x2 + | Uconst_int64 x1, Uconst_int64 x2 -> Int64.compare x1 x2 + | Uconst_nativeint x1, Uconst_nativeint x2 -> Nativeint.compare x1 x2 + | Uconst_block(t1, l1), Uconst_block(t2, l2) -> + let c = t1 - t2 (* no overflow possible here *) in + if c <> 0 then c else compare_constant_lists l1 l2 + | Uconst_float_array l1, Uconst_float_array l2 -> + compare_float_lists l1 l2 + | Uconst_string s1, Uconst_string s2 -> String.compare s1 s2 + | _, _ -> rank_structured_constant c1 - rank_structured_constant c2 + (* no overflow possible here *) diff --git a/asmcomp/clambda.mli b/asmcomp/clambda.mli index 1853933c9..fc7a14d1e 100644 --- a/asmcomp/clambda.mli +++ b/asmcomp/clambda.mli @@ -19,12 +19,12 @@ open Lambda type function_label = string type ustructured_constant = - | Uconst_float of string + | Uconst_float of float | Uconst_int32 of int32 | Uconst_int64 of int64 | Uconst_nativeint of nativeint | Uconst_block of int * uconstant list - | Uconst_float_array of string list + | Uconst_float_array of float list | Uconst_string of string and uconstant = @@ -43,7 +43,7 @@ type ulambda = | Uletrec of (Ident.t * ulambda) list * ulambda | Uprim of primitive * ulambda list * Debuginfo.t | Uswitch of ulambda * ulambda_switch - | Ustringswitch of ulambda * (string * ulambda) list * ulambda + | Ustringswitch of ulambda * (string * ulambda) list * ulambda option | Ustaticfail of int * ulambda list | Ucatch of int * Ident.t list * ulambda * ulambda | Utrywith of ulambda * Ident.t * ulambda @@ -74,7 +74,9 @@ type function_description = { fun_label: function_label; (* Label of direct entry point *) fun_arity: int; (* Number of arguments *) mutable fun_closed: bool; (* True if environment not used *) - mutable fun_inline: (Ident.t list * ulambda) option } + mutable fun_inline: (Ident.t list * ulambda) option; + mutable fun_float_const_prop: bool (* Can propagate FP consts *) + } (* Approximation of values *) @@ -84,3 +86,10 @@ type value_approximation = | Value_unknown | Value_const of uconstant | Value_global_field of string * int + +(* Comparison functions for constants *) + +val compare_structured_constants: + ustructured_constant -> ustructured_constant -> int +val compare_constants: + uconstant -> uconstant -> int diff --git a/asmcomp/closure.ml b/asmcomp/closure.ml index 78357d3b1..249e67c4e 100644 --- a/asmcomp/closure.ml +++ b/asmcomp/closure.ml @@ -19,6 +19,14 @@ open Lambda open Switch open Clambda +module Storer = + Switch.Store + (struct + type t = lambda + type key = lambda + let make_key = Lambda.make_key + end) + (* Auxiliaries for compiling functions *) let rec split_list n l = @@ -63,7 +71,7 @@ let occurs_var var u = | Ustringswitch(arg,sw,d) -> occurs arg || List.exists (fun (_,e) -> occurs e) sw || - occurs d + (match d with None -> false | Some d -> occurs d) | Ustaticfail (_, args) -> List.exists occurs args | Ucatch(_, _, body, hdlr) -> occurs body || occurs hdlr | Utrywith(body, exn, hdlr) -> occurs body || occurs hdlr @@ -198,7 +206,7 @@ let lambda_smaller lam threshold = size := !size+2 ; lambda_size lam) sw ; - lambda_size d + Misc.may lambda_size d | Ustaticfail (_,args) -> lambda_list_size args | Ucatch(_, _, body, handler) -> incr size; lambda_size body; lambda_size handler @@ -237,14 +245,15 @@ let rec is_pure_clambda = function | Uprim(p, args, _) -> List.for_all is_pure_clambda args | _ -> false -(* Simplify primitive operations on integers *) +(* Simplify primitive operations on known arguments *) let make_const c = (Uconst c, Value_const c) - +let make_const_ref c = + make_const(Uconst_ref(Compilenv.new_structured_constant ~shared:true c, c)) let make_const_int n = make_const (Uconst_int n) let make_const_ptr n = make_const (Uconst_ptr n) let make_const_bool b = make_const_ptr(if b then 1 else 0) -let make_comparison cmp (x: int) (y: int) = +let make_comparison cmp x y = make_const_bool (match cmp with Ceq -> x = y @@ -253,71 +262,187 @@ let make_comparison cmp (x: int) (y: int) = | Cgt -> x > y | Cle -> x <= y | Cge -> x >= y) +let make_const_float n = make_const_ref (Uconst_float n) +let make_const_natint n = make_const_ref (Uconst_nativeint n) +let make_const_int32 n = make_const_ref (Uconst_int32 n) +let make_const_int64 n = make_const_ref (Uconst_int64 n) + +(* The [fpc] parameter is true if constant propagation of + floating-point computations is allowed *) -let simplif_int_prim_pure p (args, approxs) dbg = +let simplif_arith_prim_pure fpc p (args, approxs) dbg = + let default = (Uprim(p, args, dbg), Value_unknown) in match approxs with - [Value_const (Uconst_int x)] -> + (* int (or enumerated type) *) + | [ Value_const(Uconst_int n1 | Uconst_ptr n1) ] -> begin match p with - Pidentity -> make_const_int x - | Pnegint -> make_const_int (-x) - | Pbswap16 -> - make_const_int (((x land 0xff) lsl 8) lor - ((x land 0xff00) lsr 8)) - | Poffsetint y -> make_const_int (x + y) - | _ -> (Uprim(p, args, dbg), Value_unknown) + | Pnot -> make_const_bool (n1 = 0) + | Pnegint -> make_const_int (- n1) + | Poffsetint n -> make_const_int (n + n1) + | Pfloatofint when fpc -> make_const_float (float_of_int n1) + | Pbintofint Pnativeint -> make_const_natint (Nativeint.of_int n1) + | Pbintofint Pint32 -> make_const_int32 (Int32.of_int n1) + | Pbintofint Pint64 -> make_const_int64 (Int64.of_int n1) + | Pbswap16 -> make_const_int (((n1 land 0xff) lsl 8) + lor ((n1 land 0xff00) lsr 8)) + | _ -> default end - | [Value_const (Uconst_int x); Value_const (Uconst_int y)] -> + (* int (or enumerated type), int (or enumerated type) *) + | [ Value_const(Uconst_int n1 | Uconst_ptr n1); + Value_const(Uconst_int n2 | Uconst_ptr n2) ] -> begin match p with - Paddint -> make_const_int(x + y) - | Psubint -> make_const_int(x - y) - | Pmulint -> make_const_int(x * y) - | Pdivint when y <> 0 -> make_const_int(x / y) - | Pmodint when y <> 0 -> make_const_int(x mod y) - | Pandint -> make_const_int(x land y) - | Porint -> make_const_int(x lor y) - | Pxorint -> make_const_int(x lxor y) - | Plslint -> make_const_int(x lsl y) - | Plsrint -> make_const_int(x lsr y) - | Pasrint -> make_const_int(x asr y) - | Pintcomp cmp -> make_comparison cmp x y - | _ -> (Uprim(p, args, dbg), Value_unknown) + | Psequand -> make_const_bool (n1 <> 0 && n2 <> 0) + | Psequor -> make_const_bool (n1 <> 0 || n2 <> 0) + | Paddint -> make_const_int (n1 + n2) + | Psubint -> make_const_int (n1 - n2) + | Pmulint -> make_const_int (n1 * n2) + | Pdivint when n2 <> 0 -> make_const_int (n1 / n2) + | Pmodint when n2 <> 0 -> make_const_int (n1 mod n2) + | Pandint -> make_const_int (n1 land n2) + | Porint -> make_const_int (n1 lor n2) + | Pxorint -> make_const_int (n1 lxor n2) + | Plslint when 0 <= n2 && n2 < 8 * Arch.size_int -> + make_const_int (n1 lsl n2) + | Plsrint when 0 <= n2 && n2 < 8 * Arch.size_int -> + make_const_int (n1 lsr n2) + | Pasrint when 0 <= n2 && n2 < 8 * Arch.size_int -> + make_const_int (n1 asr n2) + | Pintcomp c -> make_comparison c n1 n2 + | _ -> default end - | [Value_const (Uconst_ptr x)] -> + (* float *) + | [Value_const(Uconst_ref(_, Uconst_float n1))] when fpc -> begin match p with - Pidentity -> make_const_ptr x - | Pnot -> make_const_bool(x = 0) - | Pisint -> make_const_bool true - | Pctconst c -> - begin - match c with - | Big_endian -> make_const_bool Arch.big_endian - | Word_size -> make_const_int (8*Arch.size_int) - | Ostype_unix -> make_const_bool (Sys.os_type = "Unix") - | Ostype_win32 -> make_const_bool (Sys.os_type = "Win32") - | Ostype_cygwin -> make_const_bool (Sys.os_type = "Cygwin") - end - | _ -> (Uprim(p, args, dbg), Value_unknown) + | Pintoffloat -> make_const_int (int_of_float n1) + | Pnegfloat -> make_const_float (-. n1) + | Pabsfloat -> make_const_float (abs_float n1) + | _ -> default end - | [Value_const (Uconst_ptr x); Value_const (Uconst_ptr y)] -> + (* float, float *) + | [Value_const(Uconst_ref(_, Uconst_float n1)); + Value_const(Uconst_ref(_, Uconst_float n2))] when fpc -> begin match p with - Psequand -> make_const_bool(x <> 0 && y <> 0) - | Psequor -> make_const_bool(x <> 0 || y <> 0) - | Pintcomp cmp -> make_comparison cmp x y - | _ -> (Uprim(p, args, dbg), Value_unknown) + | Paddfloat -> make_const_float (n1 +. n2) + | Psubfloat -> make_const_float (n1 -. n2) + | Pmulfloat -> make_const_float (n1 *. n2) + | Pdivfloat -> make_const_float (n1 /. n2) + | Pfloatcomp c -> make_comparison c n1 n2 + | _ -> default end - | [Value_const (Uconst_ptr x); Value_const (Uconst_int y)] -> + (* nativeint *) + | [Value_const(Uconst_ref(_, Uconst_nativeint n))] -> begin match p with - | Pintcomp cmp -> make_comparison cmp x y - | _ -> (Uprim(p, args, dbg), Value_unknown) + | Pintofbint Pnativeint -> make_const_int (Nativeint.to_int n) + | Pcvtbint(Pnativeint, Pint32) -> make_const_int32 (Nativeint.to_int32 n) + | Pcvtbint(Pnativeint, Pint64) -> make_const_int64 (Int64.of_nativeint n) + | Pnegbint Pnativeint -> make_const_natint (Nativeint.neg n) + | _ -> default end - | [Value_const (Uconst_int x); Value_const (Uconst_ptr y)] -> + (* nativeint, nativeint *) + | [Value_const(Uconst_ref(_, Uconst_nativeint n1)); + Value_const(Uconst_ref(_, Uconst_nativeint n2))] -> begin match p with - | Pintcomp cmp -> make_comparison cmp x y - | _ -> (Uprim(p, args, dbg), Value_unknown) + | Paddbint Pnativeint -> make_const_natint (Nativeint.add n1 n2) + | Psubbint Pnativeint -> make_const_natint (Nativeint.sub n1 n2) + | Pmulbint Pnativeint -> make_const_natint (Nativeint.mul n1 n2) + | Pdivbint Pnativeint when n2 <> 0n -> + make_const_natint (Nativeint.div n1 n2) + | Pmodbint Pnativeint when n2 <> 0n -> + make_const_natint (Nativeint.rem n1 n2) + | Pandbint Pnativeint -> make_const_natint (Nativeint.logand n1 n2) + | Porbint Pnativeint -> make_const_natint (Nativeint.logor n1 n2) + | Pxorbint Pnativeint -> make_const_natint (Nativeint.logxor n1 n2) + | Pbintcomp(Pnativeint, c) -> make_comparison c n1 n2 + | _ -> default + end + (* nativeint, int *) + | [Value_const(Uconst_ref(_, Uconst_nativeint n1)); + Value_const(Uconst_int n2)] -> + begin match p with + | Plslbint Pnativeint when 0 <= n2 && n2 < 8 * Arch.size_int -> + make_const_natint (Nativeint.shift_left n1 n2) + | Plsrbint Pnativeint when 0 <= n2 && n2 < 8 * Arch.size_int -> + make_const_natint (Nativeint.shift_right_logical n1 n2) + | Pasrbint Pnativeint when 0 <= n2 && n2 < 8 * Arch.size_int -> + make_const_natint (Nativeint.shift_right n1 n2) + | _ -> default + end + (* int32 *) + | [Value_const(Uconst_ref(_, Uconst_int32 n))] -> + begin match p with + | Pintofbint Pint32 -> make_const_int (Int32.to_int n) + | Pcvtbint(Pint32, Pnativeint) -> make_const_natint (Nativeint.of_int32 n) + | Pcvtbint(Pint32, Pint64) -> make_const_int64 (Int64.of_int32 n) + | Pnegbint Pint32 -> make_const_int32 (Int32.neg n) + | _ -> default + end + (* int32, int32 *) + | [Value_const(Uconst_ref(_, Uconst_int32 n1)); + Value_const(Uconst_ref(_, Uconst_int32 n2))] -> + begin match p with + | Paddbint Pint32 -> make_const_int32 (Int32.add n1 n2) + | Psubbint Pint32 -> make_const_int32 (Int32.sub n1 n2) + | Pmulbint Pint32 -> make_const_int32 (Int32.mul n1 n2) + | Pdivbint Pint32 when n2 <> 0l -> make_const_int32 (Int32.div n1 n2) + | Pmodbint Pint32 when n2 <> 0l -> make_const_int32 (Int32.rem n1 n2) + | Pandbint Pint32 -> make_const_int32 (Int32.logand n1 n2) + | Porbint Pint32 -> make_const_int32 (Int32.logor n1 n2) + | Pxorbint Pint32 -> make_const_int32 (Int32.logxor n1 n2) + | Pbintcomp(Pint32, c) -> make_comparison c n1 n2 + | _ -> default + end + (* int32, int *) + | [Value_const(Uconst_ref(_, Uconst_int32 n1)); + Value_const(Uconst_int n2)] -> + begin match p with + | Plslbint Pint32 when 0 <= n2 && n2 < 32 -> + make_const_int32 (Int32.shift_left n1 n2) + | Plsrbint Pint32 when 0 <= n2 && n2 < 32 -> + make_const_int32 (Int32.shift_right_logical n1 n2) + | Pasrbint Pint32 when 0 <= n2 && n2 < 32 -> + make_const_int32 (Int32.shift_right n1 n2) + | _ -> default + end + (* int64 *) + | [Value_const(Uconst_ref(_, Uconst_int64 n))] -> + begin match p with + | Pintofbint Pint64 -> make_const_int (Int64.to_int n) + | Pcvtbint(Pint64, Pint32) -> make_const_int32 (Int64.to_int32 n) + | Pcvtbint(Pint64, Pnativeint) -> make_const_natint (Int64.to_nativeint n) + | Pnegbint Pint64 -> make_const_int64 (Int64.neg n) + | _ -> default end + (* int64, int64 *) + | [Value_const(Uconst_ref(_, Uconst_int64 n1)); + Value_const(Uconst_ref(_, Uconst_int64 n2))] -> + begin match p with + | Paddbint Pint64 -> make_const_int64 (Int64.add n1 n2) + | Psubbint Pint64 -> make_const_int64 (Int64.sub n1 n2) + | Pmulbint Pint64 -> make_const_int64 (Int64.mul n1 n2) + | Pdivbint Pint64 when n2 <> 0L -> make_const_int64 (Int64.div n1 n2) + | Pmodbint Pint64 when n2 <> 0L -> make_const_int64 (Int64.rem n1 n2) + | Pandbint Pint64 -> make_const_int64 (Int64.logand n1 n2) + | Porbint Pint64 -> make_const_int64 (Int64.logor n1 n2) + | Pxorbint Pint64 -> make_const_int64 (Int64.logxor n1 n2) + | Pbintcomp(Pint64, c) -> make_comparison c n1 n2 + | _ -> default + end + (* int64, int *) + | [Value_const(Uconst_ref(_, Uconst_int64 n1)); + Value_const(Uconst_int n2)] -> + begin match p with + | Plslbint Pint64 when 0 <= n2 && n2 < 64 -> + make_const_int64 (Int64.shift_left n1 n2) + | Plsrbint Pint64 when 0 <= n2 && n2 < 64 -> + make_const_int64 (Int64.shift_right_logical n1 n2) + | Pasrbint Pint64 when 0 <= n2 && n2 < 64 -> + make_const_int64 (Int64.shift_right n1 n2) + | _ -> default + end + (* TODO: Pbbswap *) + (* Catch-all *) | _ -> - (Uprim(p, args, dbg), Value_unknown) - + default let field_approx n = function | Value_tuple a when n < Array.length a -> a.(n) @@ -325,8 +450,9 @@ let field_approx n = function Value_const (List.nth l n) | _ -> Value_unknown -let simplif_prim_pure p (args, approxs) dbg = +let simplif_prim_pure fpc p (args, approxs) dbg = match p, args, approxs with + (* Block construction *) | Pmakeblock(tag, Immutable), _, _ -> let field = function | Value_const c -> c @@ -341,24 +467,43 @@ let simplif_prim_pure p (args, approxs) dbg = with Exit -> (Uprim(p, args, dbg), Value_tuple (Array.of_list approxs)) end + (* Field access *) | Pfield n, _, [ Value_const(Uconst_ref(_, Uconst_block(_, l))) ] when n < List.length l -> make_const (List.nth l n) - - | Pfield n, [ Uprim(Pmakeblock _, ul, _) ], [approx] -> - assert(n < List.length ul); - List.nth ul n, field_approx n approx - - | Pstringlength, _, [ Value_const(Uconst_ref(_, Uconst_string s)) ] - -> + | Pfield n, [ Uprim(Pmakeblock _, ul, _) ], [approx] + when n < List.length ul -> + (List.nth ul n, field_approx n approx) + (* Strings *) + | Pstringlength, _, [ Value_const(Uconst_ref(_, Uconst_string s)) ] -> make_const_int (String.length s) - + (* Identity *) + | Pidentity, [arg1], [app1] -> + (arg1, app1) + (* Kind test *) + | Pisint, _, [a1] -> + begin match a1 with + | Value_const(Uconst_int _ | Uconst_ptr _) -> make_const_bool true + | Value_const(Uconst_ref _) -> make_const_bool false + | Value_closure _ | Value_tuple _ -> make_const_bool false + | _ -> (Uprim(p, args, dbg), Value_unknown) + end + (* Compile-time constants *) + | Pctconst c, _, _ -> + begin match c with + | Big_endian -> make_const_bool Arch.big_endian + | Word_size -> make_const_int (8*Arch.size_int) + | Ostype_unix -> make_const_bool (Sys.os_type = "Unix") + | Ostype_win32 -> make_const_bool (Sys.os_type = "Win32") + | Ostype_cygwin -> make_const_bool (Sys.os_type = "Cygwin") + end + (* Catch-all *) | _ -> - simplif_int_prim_pure p (args, approxs) dbg + simplif_arith_prim_pure fpc p (args, approxs) dbg -let simplif_prim p (args, approxs as args_approxs) dbg = +let simplif_prim fpc p (args, approxs as args_approxs) dbg = if List.for_all is_pure_clambda args - then simplif_prim_pure p args_approxs dbg + then simplif_prim_pure fpc p args_approxs dbg else (* XXX : always return the same approxs as simplif_prim_pure? *) let approx = @@ -383,15 +528,16 @@ let approx_ulam = function Uconst c -> Value_const c | _ -> Value_unknown -let rec substitute sb ulam = +let rec substitute fpc sb ulam = match ulam with Uvar v -> begin try Tbl.find v sb with Not_found -> ulam end | Uconst _ -> ulam | Udirect_apply(lbl, args, dbg) -> - Udirect_apply(lbl, List.map (substitute sb) args, dbg) + Udirect_apply(lbl, List.map (substitute fpc sb) args, dbg) | Ugeneric_apply(fn, args, dbg) -> - Ugeneric_apply(substitute sb fn, List.map (substitute sb) args, dbg) + Ugeneric_apply(substitute fpc sb fn, + List.map (substitute fpc sb) args, dbg) | Uclosure(defs, env) -> (* Question: should we rename function labels as well? Otherwise, there is a risk that function labels are not globally unique. @@ -401,11 +547,12 @@ let rec substitute sb ulam = - When we substitute offsets for idents bound by let rec in [close], case [Lletrec], we discard the original let rec body and use only the substituted term. *) - Uclosure(defs, List.map (substitute sb) env) - | Uoffset(u, ofs) -> Uoffset(substitute sb u, ofs) + Uclosure(defs, List.map (substitute fpc sb) env) + | Uoffset(u, ofs) -> Uoffset(substitute fpc sb u, ofs) | Ulet(id, u1, u2) -> let id' = Ident.rename id in - Ulet(id', substitute sb u1, substitute (Tbl.add id (Uvar id') sb) u2) + Ulet(id', substitute fpc sb u1, + substitute fpc (Tbl.add id (Uvar id') sb) u2) | Uletrec(bindings, body) -> let bindings1 = List.map (fun (id, rhs) -> (id, Ident.rename id, rhs)) bindings in @@ -414,57 +561,64 @@ let rec substitute sb ulam = (fun (id, id', _) s -> Tbl.add id (Uvar id') s) bindings1 sb in Uletrec( - List.map (fun (id, id', rhs) -> (id', substitute sb' rhs)) bindings1, - substitute sb' body) + List.map + (fun (id, id', rhs) -> (id', substitute fpc sb' rhs)) + bindings1, + substitute fpc sb' body) | Uprim(p, args, dbg) -> - let sargs = List.map (substitute sb) args in - let (res, _) = simplif_prim p (sargs, List.map approx_ulam sargs) dbg in + let sargs = + List.map (substitute fpc sb) args in + let (res, _) = + simplif_prim fpc p (sargs, List.map approx_ulam sargs) dbg in res | Uswitch(arg, sw) -> - Uswitch(substitute sb arg, + Uswitch(substitute fpc sb arg, { sw with us_actions_consts = - Array.map (substitute sb) sw.us_actions_consts; + Array.map (substitute fpc sb) sw.us_actions_consts; us_actions_blocks = - Array.map (substitute sb) sw.us_actions_blocks; + Array.map (substitute fpc sb) sw.us_actions_blocks; }) | Ustringswitch(arg,sw,d) -> Ustringswitch - (substitute sb arg, - List.map (fun (s,act) -> s,substitute sb act) sw, - substitute sb d) + (substitute fpc sb arg, + List.map (fun (s,act) -> s,substitute fpc sb act) sw, + Misc.may_map (substitute fpc sb) d) | Ustaticfail (nfail, args) -> - Ustaticfail (nfail, List.map (substitute sb) args) + Ustaticfail (nfail, List.map (substitute fpc sb) args) | Ucatch(nfail, ids, u1, u2) -> - Ucatch(nfail, ids, substitute sb u1, substitute sb u2) + Ucatch(nfail, ids, substitute fpc sb u1, substitute fpc sb u2) | Utrywith(u1, id, u2) -> let id' = Ident.rename id in - Utrywith(substitute sb u1, id', substitute (Tbl.add id (Uvar id') sb) u2) + Utrywith(substitute fpc sb u1, id', + substitute fpc (Tbl.add id (Uvar id') sb) u2) | Uifthenelse(u1, u2, u3) -> - begin match substitute sb u1 with + begin match substitute fpc sb u1 with Uconst (Uconst_ptr n) -> - if n <> 0 then substitute sb u2 else substitute sb u3 + if n <> 0 then substitute fpc sb u2 else substitute fpc sb u3 | Uprim(Pmakeblock _, _, _) -> - substitute sb u2 + substitute fpc sb u2 | su1 -> - Uifthenelse(su1, substitute sb u2, substitute sb u3) + Uifthenelse(su1, substitute fpc sb u2, substitute fpc sb u3) end - | Usequence(u1, u2) -> Usequence(substitute sb u1, substitute sb u2) - | Uwhile(u1, u2) -> Uwhile(substitute sb u1, substitute sb u2) + | Usequence(u1, u2) -> + Usequence(substitute fpc sb u1, substitute fpc sb u2) + | Uwhile(u1, u2) -> + Uwhile(substitute fpc sb u1, substitute fpc sb u2) | Ufor(id, u1, u2, dir, u3) -> let id' = Ident.rename id in - Ufor(id', substitute sb u1, substitute sb u2, dir, - substitute (Tbl.add id (Uvar id') sb) u3) + Ufor(id', substitute fpc sb u1, substitute fpc sb u2, dir, + substitute fpc (Tbl.add id (Uvar id') sb) u3) | Uassign(id, u) -> let id' = try match Tbl.find id sb with Uvar i -> i | _ -> assert false with Not_found -> id in - Uassign(id', substitute sb u) + Uassign(id', substitute fpc sb u) | Usend(k, u1, u2, ul, dbg) -> - Usend(k, substitute sb u1, substitute sb u2, List.map (substitute sb) ul, - dbg) + Usend(k, substitute fpc sb u1, substitute fpc sb u2, + List.map (substitute fpc sb) ul, dbg) (* Perform an inline expansion *) @@ -476,12 +630,12 @@ let no_effects = function | Uclosure _ -> true | u -> is_simple_argument u -let rec bind_params_rec subst params args body = +let rec bind_params_rec fpc subst params args body = match (params, args) with - ([], []) -> substitute subst body + ([], []) -> substitute fpc subst body | (p1 :: pl, a1 :: al) -> if is_simple_argument a1 then - bind_params_rec (Tbl.add p1 a1 subst) pl al body + bind_params_rec fpc (Tbl.add p1 a1 subst) pl al body else begin let p1' = Ident.rename p1 in let u1, u2 = @@ -492,17 +646,17 @@ let rec bind_params_rec subst params args body = a1, Uvar p1' in let body' = - bind_params_rec (Tbl.add p1 u2 subst) pl al body in + bind_params_rec fpc (Tbl.add p1 u2 subst) pl al body in if occurs_var p1 body then Ulet(p1', u1, body') else if no_effects a1 then body' else Usequence(a1, body') end | (_, _) -> assert false -let bind_params params args body = +let bind_params fpc params args body = (* Reverse parameters and arguments to preserve right-to-left evaluation order (PR#2910). *) - bind_params_rec Tbl.empty (List.rev params) (List.rev args) body + bind_params_rec fpc Tbl.empty (List.rev params) (List.rev args) body (* Check if a lambda term is ``pure'', that is without side-effects *and* not containing function definitions *) @@ -524,8 +678,10 @@ let direct_apply fundesc funct ufunct uargs = if fundesc.fun_closed then uargs else uargs @ [ufunct] in let app = match fundesc.fun_inline with - None -> Udirect_apply(fundesc.fun_label, app_args, Debuginfo.none) - | Some(params, body) -> bind_params params app_args body in + | None -> + Udirect_apply(fundesc.fun_label, app_args, Debuginfo.none) + | Some(params, body) -> + bind_params fundesc.fun_float_const_prop params app_args body in (* If ufunct can contain side-effects or function definitions, we must make sure that it is evaluated exactly once. If the function is not closed, we evaluate ufunct as part of the @@ -640,14 +796,14 @@ let rec close fenv cenv = function str (Uconst_block (tag, List.map transl fields)) | Const_float_array sl -> (* constant float arrays are really immutable *) - str (Uconst_float_array sl) + str (Uconst_float_array (List.map float_of_string sl)) | Const_immstring s -> str (Uconst_string s) | Const_base (Const_string (s, _)) -> (* strings (even literal ones) are mutable! *) (* of course, the empty string is really immutable *) str ~shared:false(*(String.length s = 0)*) (Uconst_string s) - | Const_base(Const_float x) -> str (Uconst_float x) + | Const_base(Const_float x) -> str (Uconst_float (float_of_string x)) | Const_base(Const_int32 x) -> str (Uconst_int32 x) | Const_base(Const_int64 x) -> str (Uconst_int64 x) | Const_base(Const_nativeint x) -> str (Uconst_nativeint x) @@ -741,7 +897,7 @@ let rec close fenv cenv = function (fun (id, pos, approx) sb -> Tbl.add id (Uoffset(Uvar clos_ident, pos)) sb) infos Tbl.empty in - (Ulet(clos_ident, clos, substitute sb ubody), + (Ulet(clos_ident, clos, substitute !Clflags.float_const_prop sb ubody), approx) end else begin (* General case: recursive definition of values *) @@ -749,7 +905,7 @@ let rec close fenv cenv = function [] -> ([], fenv) | (id, lam) :: rem -> let (udefs, fenv_body) = clos_defs rem in - let (ulam, approx) = close fenv cenv lam in + let (ulam, approx) = close_named fenv cenv id lam in ((id, ulam) :: udefs, Tbl.add id approx fenv_body) in let (udefs, fenv_body) = clos_defs defs in let (ubody, approx) = close fenv_body cenv body in @@ -777,29 +933,51 @@ let rec close fenv cenv = function (Uprim(Praise k, [ulam], Debuginfo.from_raise ev), Value_unknown) | Lprim(p, args) -> - simplif_prim p (close_list_approx fenv cenv args) Debuginfo.none + simplif_prim !Clflags.float_const_prop + p (close_list_approx fenv cenv args) Debuginfo.none | Lswitch(arg, sw) -> + let fn fail = + let (uarg, _) = close fenv cenv arg in + let const_index, const_actions, fconst = + close_switch arg fenv cenv sw.sw_consts sw.sw_numconsts fail + and block_index, block_actions, fblock = + close_switch arg fenv cenv sw.sw_blocks sw.sw_numblocks fail in + let ulam = + Uswitch + (uarg, + {us_index_consts = const_index; + us_actions_consts = const_actions; + us_index_blocks = block_index; + us_actions_blocks = block_actions}) in + (fconst (fblock ulam),Value_unknown) in (* NB: failaction might get copied, thus it should be some Lstaticraise *) - let (uarg, _) = close fenv cenv arg in - let const_index, const_actions = - close_switch fenv cenv sw.sw_consts sw.sw_numconsts sw.sw_failaction - and block_index, block_actions = - close_switch fenv cenv sw.sw_blocks sw.sw_numblocks sw.sw_failaction in - (Uswitch(uarg, - {us_index_consts = const_index; - us_actions_consts = const_actions; - us_index_blocks = block_index; - us_actions_blocks = block_actions}), - Value_unknown) + let fail = sw.sw_failaction in + begin match fail with + | None|Some (Lstaticraise (_,_)) -> fn fail + | Some lamfail -> + if + (sw.sw_numconsts - List.length sw.sw_consts) + + (sw.sw_numblocks - List.length sw.sw_blocks) > 1 + then + let i = next_raise_count () in + let ubody,_ = fn (Some (Lstaticraise (i,[]))) + and uhandler,_ = close fenv cenv lamfail in + Ucatch (i,[],ubody,uhandler),Value_unknown + else fn fail + end | Lstringswitch(arg,sw,d) -> let uarg,_ = close fenv cenv arg in - let usw = + let usw = List.map (fun (s,act) -> let uact,_ = close fenv cenv act in s,uact) sw in - let ud,_ = close fenv cenv d in + let ud = + Misc.may_map + (fun d -> + let ud,_ = close fenv cenv d in + ud) d in Ustringswitch (uarg,usw,ud),Value_unknown | Lstaticraise (i, args) -> (Ustaticfail (i, close_list fenv cenv args), Value_unknown) @@ -896,7 +1074,8 @@ and close_functions fenv cenv fun_defs = {fun_label = label; fun_arity = (if kind = Tupled then -arity else arity); fun_closed = initially_closed; - fun_inline = None } in + fun_inline = None; + fun_float_const_prop = !Clflags.float_const_prop } in (id, params, body, fundesc) | (_, _) -> fatal_error "Closure.close_functions") fun_defs in @@ -996,14 +1175,15 @@ and close_one_function fenv cenv id funct = (* Close a switch *) -and close_switch fenv cenv cases num_keys default = - let index = Array.create num_keys 0 - and store = mk_store Lambda.same in +and close_switch arg fenv cenv cases num_keys default = + let ncases = List.length cases in + let index = Array.make num_keys 0 + and store = Storer.mk_store () in (* First default case *) begin match default with - | Some def when List.length cases < num_keys -> - ignore (store.act_store def) + | Some def when ncases < num_keys -> + assert (store.act_store def = 0) | _ -> () end ; (* Then all other cases *) @@ -1011,16 +1191,37 @@ and close_switch fenv cenv cases num_keys default = (fun (key,lam) -> index.(key) <- store.act_store lam) cases ; - (* Compile action *) + + (* Explicit sharing with catch/exit, as switcher compilation may + later unshare *) + let acts = store.act_get_shared () in + let hs = ref (fun e -> e) in + + (* Compile actions *) let actions = Array.map - (fun lam -> - let ulam,_ = close fenv cenv lam in - ulam) - (store.act_get ()) in + (function + | Single lam|Shared (Lstaticraise (_,[]) as lam) -> + let ulam,_ = close fenv cenv lam in + ulam + | Shared lam -> + let ulam,_ = close fenv cenv lam in + let i = next_raise_count () in +(* + let string_of_lambda e = + Printlambda.lambda Format.str_formatter e ; + Format.flush_str_formatter () in + Printf.eprintf "SHARE CLOSURE %i [%s]\n%s\n" i + (string_of_lambda arg) + (string_of_lambda lam) ; +*) + let ohs = !hs in + hs := (fun e -> Ucatch (i,[],ohs e,ulam)) ; + Ustaticfail (i,[])) + acts in match actions with - | [| |] -> [| |], [| |] (* May happen when default is None *) - | _ -> index, actions + | [| |] -> [| |], [| |], !hs (* May happen when default is None *) + | _ -> index, actions, !hs (* Collect exported symbols for structured constants *) @@ -1065,7 +1266,7 @@ let collect_exported_structured_constants a = | Ustringswitch (u,sw,d) -> ulam u ; List.iter (fun (_,act) -> ulam act) sw ; - ulam d + Misc.may ulam d | Ustaticfail (_, ul) -> List.iter ulam ul | Ucatch (_, _, u1, u2) | Utrywith (u1, _, u2) @@ -1078,14 +1279,20 @@ let collect_exported_structured_constants a = in approx a +let reset () = + global_approx := [||]; + function_nesting_depth := 0 + (* The entry point *) let intro size lam = - function_nesting_depth := 0; + reset (); let id = Compilenv.make_symbol None in global_approx := Array.init size (fun i -> Value_global_field (id, i)); Compilenv.set_global_approx(Value_tuple !global_approx); let (ulam, approx) = close Tbl.empty Tbl.empty lam in - collect_exported_structured_constants (Value_tuple !global_approx); + if !Clflags.opaque + then Compilenv.set_global_approx(Value_unknown) + else collect_exported_structured_constants (Value_tuple !global_approx); global_approx := [||]; ulam diff --git a/asmcomp/closure.mli b/asmcomp/closure.mli index e7bccbca6..2db6e1633 100644 --- a/asmcomp/closure.mli +++ b/asmcomp/closure.mli @@ -13,3 +13,4 @@ (* Introduction of closures, uncurrying, recognition of direct calls *) val intro: int -> Lambda.lambda -> Clambda.ulambda +val reset : unit -> unit diff --git a/asmcomp/cmm.ml b/asmcomp/cmm.ml index 9a5f3ec6b..67ee3445f 100644 --- a/asmcomp/cmm.ml +++ b/asmcomp/cmm.ml @@ -85,7 +85,7 @@ type operation = type expression = Cconst_int of int | Cconst_natint of nativeint - | Cconst_float of string + | Cconst_float of float | Cconst_symbol of string | Cconst_pointer of int | Cconst_natpointer of nativeint @@ -118,8 +118,8 @@ type data_item = | Cint16 of int | Cint32 of nativeint | Cint of nativeint - | Csingle of string - | Cdouble of string + | Csingle of float + | Cdouble of float | Csymbol_address of string | Clabel_address of int | Cstring of string diff --git a/asmcomp/cmm.mli b/asmcomp/cmm.mli index be2bd4145..97b8d4097 100644 --- a/asmcomp/cmm.mli +++ b/asmcomp/cmm.mli @@ -71,7 +71,7 @@ type operation = type expression = Cconst_int of int | Cconst_natint of nativeint - | Cconst_float of string + | Cconst_float of float | Cconst_symbol of string | Cconst_pointer of int | Cconst_natpointer of nativeint @@ -104,8 +104,8 @@ type data_item = | Cint16 of int | Cint32 of nativeint | Cint of nativeint - | Csingle of string - | Cdouble of string + | Csingle of float + | Cdouble of float | Csymbol_address of string | Clabel_address of int | Cstring of string diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml index 0e92fc499..17dcb8220 100644 --- a/asmcomp/cmmgen.ml +++ b/asmcomp/cmmgen.ml @@ -38,6 +38,9 @@ let bind_nonvar name arg fn = | Cconst_blockheader _ -> fn arg | _ -> let id = Ident.create name in Clet(id, arg, fn (Cvar id)) +let caml_black = Nativeint.shift_left (Nativeint.of_int 3) 8 + (* cf. byterun/gc.h *) + (* Block headers. Meaning of the tag field: see stdlib/obj.ml *) let floatarray_tag = Cconst_int Obj.double_array_tag @@ -45,7 +48,12 @@ let floatarray_tag = Cconst_int Obj.double_array_tag let block_header tag sz = Nativeint.add (Nativeint.shift_left (Nativeint.of_int sz) 10) (Nativeint.of_int tag) -let closure_header sz = block_header Obj.closure_tag sz +(* Static data corresponding to "value"s must be marked black in case we are + in no-naked-pointers mode. See [caml_darken] and the code below that emits + structured constants and static module definitions. *) +let black_block_header tag sz = Nativeint.logor (block_header tag sz) caml_black +let white_closure_header sz = block_header Obj.closure_tag sz +let black_closure_header sz = black_block_header Obj.closure_tag sz let infix_header ofs = block_header Obj.infix_tag ofs let float_header = block_header Obj.double_tag (size_float / size_addr) let floatarray_header len = @@ -59,7 +67,7 @@ let boxedintnat_header = block_header Obj.custom_tag 2 let alloc_block_header tag sz = Cconst_blockheader(block_header tag sz) let alloc_float_header = Cconst_blockheader(float_header) let alloc_floatarray_header len = Cconst_blockheader(floatarray_header len) -let alloc_closure_header sz = Cconst_blockheader(closure_header sz) +let alloc_closure_header sz = Cconst_blockheader(white_closure_header sz) let alloc_infix_header ofs = Cconst_blockheader(infix_header ofs) let alloc_boxedint32_header = Cconst_blockheader(boxedint32_header) let alloc_boxedint64_header = Cconst_blockheader(boxedint64_header) @@ -633,9 +641,9 @@ let rec expr_size env = function RHS_block (List.length args) | Uprim(Pmakearray(Pfloatarray), args, _) -> RHS_floatblock (List.length args) - | Uprim (Pduprecord (Record_regular | Record_inlined _, sz), _, _) -> + | Uprim (Pduprecord ((Record_regular | Record_inlined _), sz), _, _) -> RHS_block sz - | Uprim (Pduprecord (Record_exception _, sz), _, _) -> + | Uprim (Pduprecord (Record_extension, sz), _, _) -> RHS_block (sz + 1) | Uprim (Pduprecord (Record_float, sz), _, _) -> RHS_floatblock sz @@ -993,8 +1001,22 @@ let unaligned_set_64 ptr idx newval = Cop(Cstore Byte_unsigned, [add_int (add_int ptr idx) (Cconst_int 7); b8])))) +let max_or_zero a = + bind "size" a (fun a -> + (* equivalent to + Cifthenelse(Cop(Ccmpi Cle, [a; Cconst_int 0]), Cconst_int 0, a) + + if a is positive, sign is 0 hence sign_negation is full of 1 + so sign_negation&a = a + if a is negative, sign is full of 1 hence sign_negation is 0 + so sign_negation&a = 0 *) + let sign = Cop(Casr, [a; Cconst_int (size_int * 8 - 1)]) in + let sign_negation = Cop(Cxor, [sign; Cconst_int (-1)]) in + Cop(Cand, [sign_negation; a])) + let check_bound unsafe dbg a1 a2 k = - if unsafe then k else Csequence(make_checkbound dbg [a1;a2], k) + if unsafe then k + else Csequence(make_checkbound dbg [max_or_zero a1;a2], k) (* Simplification of some primitives into C calls *) @@ -1057,28 +1079,9 @@ let simplif_primitive p = (* Build switchers both for constants and blocks *) -(* constants first *) - let transl_isout h arg = tag_int (Cop(Ccmpa Clt, [h ; arg])) -let make_switch_gen arg cases acts = - let lcases = Array.length cases in - let new_cases = Array.create lcases 0 in - let store = Switch.mk_store (=) in - - for i = 0 to Array.length cases-1 do - let act = cases.(i) in - let new_act = store.Switch.act_store act in - new_cases.(i) <- new_act - done ; - Cswitch - (arg, new_cases, - Array.map - (fun n -> acts.(n)) - (store.Switch.act_get ())) - - -(* Then for blocks *) +(* Build an actual switch (ie jump table) *) module SArgBlocks = struct @@ -1094,17 +1097,47 @@ struct type act = expression let default = Cexit (0,[]) + let make_const i = Cconst_int i let make_prim p args = Cop (p,args) let make_offset arg n = add_const arg n let make_isout h arg = Cop (Ccmpa Clt, [h ; arg]) let make_isin h arg = Cop (Ccmpa Cge, [h ; arg]) let make_if cond ifso ifnot = Cifthenelse (cond, ifso, ifnot) - let make_switch arg cases actions = - make_switch_gen arg cases actions + let make_switch arg cases actions = Cswitch (arg,cases,actions) let bind arg body = bind "switcher" arg body + let make_catch handler = match handler with + | Cexit (i,[]) -> i,fun e -> e + | _ -> + let i = next_raise_count () in +(* + Printf.eprintf "SHARE CMM: %i\n" i ; + Printcmm.expression Format.str_formatter handler ; + Printf.eprintf "%s\n" (Format.flush_str_formatter ()) ; +*) + i, + (fun body -> match body with + | Cexit (j,_) -> + if i=j then handler + else body + | _ -> Ccatch (i,[],body,handler)) + + let make_exit i = Cexit (i,[]) + end +(* cmm store, as sharing as normally been detected in previous + phases, we only share exits *) +module StoreExp = + Switch.Store + (struct + type t = expression + type key = int + let make_key = function + | Cexit (i,[]) -> Some i + | _ -> None + end) + module SwitcherBlocks = Switch.Make(SArgBlocks) (* Int switcher, arg in [low..high], @@ -1112,35 +1145,48 @@ module SwitcherBlocks = Switch.Make(SArgBlocks) let transl_int_switch arg low high cases default = match cases with | [] -> assert false -| (k0,_)::_ -> - let nacts = List.length cases + 1 in - let actions = Array.create nacts default in - let rec set_acts idx = function - | [] -> assert false - | [i,act] -> - actions.(idx) <- act ; - if i = high then [(i,i,idx)] - else [(i,i,idx); (i+1,max_int,0)] - | (i,act)::((j,_)::_ as rem) -> - actions.(idx) <- act ; - let inters = set_acts (idx+1) rem in - (i,i,idx):: - begin - if j = i+1 then inters - else (i+1,j-1,0)::inters - end in - let inters = set_acts 1 cases in - let inters = - if k0 = low then inters else (low,k0-1,0)::inters in - bind "switcher" arg - (fun a -> - SwitcherBlocks.zyva - (low,high) - (fun i -> Cconst_int i) - a - (Array.of_list inters) actions) - - +| _::_ -> + let store = StoreExp.mk_store () in + assert (store.Switch.act_store default = 0) ; + let cases = + List.map + (fun (i,act) -> i,store.Switch.act_store act) + cases in + let rec inters plow phigh pact = function + | [] -> + if phigh = high then [plow,phigh,pact] + else [(plow,phigh,pact); (phigh+1,high,0) ] + | (i,act)::rem -> + if i = phigh+1 then + if pact = act then + inters plow i pact rem + else + (plow,phigh,pact)::inters i i act rem + else (* insert default *) + if pact = 0 then + if act = 0 then + inters plow i 0 rem + else + (plow,i-1,pact):: + inters i i act rem + else (* pact <> 0 *) + (plow,phigh,pact):: + begin + if act = 0 then inters (phigh+1) i 0 rem + else (phigh+1,i-1,0)::inters i i act rem + end in + let inters = match cases with + | [] -> assert false + | (k0,act0)::rem -> + if k0 = low then inters k0 k0 act0 rem + else inters low (k0-1) 0 cases in + bind "switcher" arg + (fun a -> + SwitcherBlocks.zyva + (low,high) + a + (Array.of_list inters) store) + (* Auxiliary functions for optimizing "let" of boxed numbers (floats and boxed integers *) @@ -1242,7 +1288,7 @@ let strmatch_compile = let transl_switch = transl_int_switch end) in S.compile - + let rec transl = function Uvar id -> Cvar id @@ -1419,7 +1465,7 @@ let rec transl = function | Ustringswitch(arg,sw,d) -> bind "switch" (transl arg) (fun arg -> - strmatch_compile arg (transl d) + strmatch_compile arg (Misc.may_map transl d) (List.map (fun (s,act) -> s,transl act) sw)) | Ustaticfail (nfail, args) -> Cexit (nfail, List.map transl args) @@ -1513,6 +1559,8 @@ and transl_prim_1 p arg dbg = Cop(Cload Double_u, [if n = 0 then ptr else Cop(Cadda, [ptr; Cconst_int(n * size_float)])])) + | Pint_as_pointer -> + Cop(Cadda, [transl arg; Cconst_int (-1)]) (* Exceptions *) | Praise k -> Cop(Craise (k, dbg), [transl arg]) @@ -1977,7 +2025,7 @@ and transl_unbox_int bi = function Cconst_int i | exp -> unbox_int bi (transl exp) -and transl_unbox_let box_fn unbox_fn transl_unbox_fn box_chunk box_offset +and transl_unbox_let box_fn unbox_fn transl_unbox_fn box_chunk box_offset id exp body = let unboxed_id = Ident.create (Ident.name id) in let trbody1 = transl body in @@ -2069,9 +2117,13 @@ and transl_switch arg index cases = match Array.length cases with | 0 -> fatal_error "Cmmgen.transl_switch" | 1 -> transl cases.(0) | _ -> + let cases = Array.map transl cases in + let store = StoreExp.mk_store () in + let index = + Array.map + (fun j -> store.Switch.act_store cases.(j)) + index in let n_index = Array.length index in - let actions = Array.map transl cases in - let inters = ref [] and this_high = ref (n_index-1) and this_low = ref (n_index-1) @@ -2088,13 +2140,15 @@ and transl_switch arg index cases = match Array.length cases with end done ; inters := (0, !this_high, !this_act) :: !inters ; - bind "switcher" arg - (fun a -> - SwitcherBlocks.zyva - (0,n_index-1) - (fun i -> Cconst_int i) - a - (Array.of_list !inters) actions) + match !inters with + | [_] -> cases.(0) + | inters -> + bind "switcher" arg + (fun a -> + SwitcherBlocks.zyva + (0,n_index-1) + a + (Array.of_list inters) store) and transl_letrec bindings cont = let bsz = @@ -2158,10 +2212,13 @@ let rec transl_all_functions already_translated cont = (* Emit structured constants *) -let emit_block header symb cont = - Cint header :: Cdefine_symbol symb :: cont - let rec emit_structured_constant symb cst cont = + let emit_block white_header symb cont = + (* Headers for structured constants must be marked black in case we + are in no-naked-pointers mode. See [caml_darken]. *) + let black_header = Nativeint.logor white_header caml_black in + Cint black_header :: Cdefine_symbol symb :: cont + in match cst with | Uconst_float s-> emit_block float_header symb (Cdouble s :: cont) @@ -2187,7 +2244,8 @@ let rec emit_structured_constant symb cst cont = and emit_constant cst cont = match cst with | Uconst_int n | Uconst_ptr n -> - Cint(Nativeint.add (Nativeint.shift_left (Nativeint.of_int n) 1) 1n) :: cont + Cint(Nativeint.add (Nativeint.shift_left (Nativeint.of_int n) 1) 1n) + :: cont | Uconst_ref (label, _) -> Csymbol_address label :: cont @@ -2237,7 +2295,7 @@ let emit_constant_closure symb fundecls cont = Cint(Nativeint.of_int (f2.arity lsl 1 + 1)) :: Csymbol_address f2.label :: emit_others (pos + 4) rem in - Cint(closure_header (fundecls_size fundecls)) :: + Cint(black_closure_header (fundecls_size fundecls)) :: Cdefine_symbol symb :: if f1.arity = 1 then Csymbol_address f1.label :: @@ -2279,10 +2337,18 @@ let compunit size ulam = fun_dbg = Debuginfo.none }] in let c2 = transl_all_functions StringSet.empty c1 in let c3 = emit_all_constants c2 in - Cdata [Cint(block_header 0 size); + let space = + (* These words will be registered as roots and as such must contain + valid values, in case we are in no-naked-pointers mode. Likewise + the block header must be black, below (see [caml_darken]), since + the overall record may be referenced. *) + Array.to_list + (Array.init size (fun _index -> + Cint (Nativeint.of_int 1 (* Val_unit *)))) + in + Cdata ([Cint(black_block_header 0 size); Cglobal_symbol glob; - Cdefine_symbol glob; - Cskip(size * size_addr)] :: c3 + Cdefine_symbol glob] @ space) :: c3 (* CAMLprim value caml_cache_public_method (value meths, value tag, value *cache) @@ -2346,7 +2412,7 @@ let cache_public_method meths tag cache = *) let apply_function_body arity = - let arg = Array.create arity (Ident.create "arg") in + let arg = Array.make arity (Ident.create "arg") in for i = 1 to arity - 1 do arg.(i) <- Ident.create "arg" done; let clos = Ident.create "clos" in let rec app_fun clos n = diff --git a/asmcomp/cmx_format.mli b/asmcomp/cmx_format.mli index c4e557969..51aa04408 100644 --- a/asmcomp/cmx_format.mli +++ b/asmcomp/cmx_format.mli @@ -26,8 +26,9 @@ type unit_infos = { mutable ui_name: string; (* Name of unit implemented *) mutable ui_symbol: string; (* Prefix for symbols *) mutable ui_defines: string list; (* Unit and sub-units implemented *) - mutable ui_imports_cmi: (string * Digest.t) list; (* Interfaces imported *) - mutable ui_imports_cmx: (string * Digest.t) list; (* Infos imported *) + mutable ui_imports_cmi: + (string * Digest.t option) list; (* Interfaces imported *) + mutable ui_imports_cmx:(string * Digest.t option) list; (* Infos imported *) mutable ui_approx: Clambda.value_approximation; (* Approx of the structure*) mutable ui_curry_fun: int list; (* Currying functions needed *) mutable ui_apply_fun: int list; (* Apply functions needed *) @@ -49,8 +50,8 @@ type library_infos = type dynunit = { dynu_name: string; dynu_crc: Digest.t; - dynu_imports_cmi: (string * Digest.t) list; - dynu_imports_cmx: (string * Digest.t) list; + dynu_imports_cmi: (string * Digest.t option) list; + dynu_imports_cmx: (string * Digest.t option) list; dynu_defines: string list; } diff --git a/asmcomp/coloring.ml b/asmcomp/coloring.ml index 67ed8729e..aff4ad626 100644 --- a/asmcomp/coloring.ml +++ b/asmcomp/coloring.ml @@ -47,7 +47,7 @@ let allocate_registers() = if reg.spill then begin (* Preallocate the registers in the stack *) let nslots = Proc.num_stack_slots.(cl) in - let conflict = Array.create nslots false in + let conflict = Array.make nslots false in List.iter (fun r -> match r.loc with @@ -84,14 +84,14 @@ let allocate_registers() = (* Where to start the search for a suitable register. Used to introduce some "randomness" in the choice between registers with equal scores. This offers more opportunities for scheduling. *) - let start_register = Array.create Proc.num_register_classes 0 in + let start_register = Array.make Proc.num_register_classes 0 in (* Assign a location to a register, the best we can. *) let assign_location reg = let cl = Proc.register_class reg in let first_reg = Proc.first_available_register.(cl) in let num_regs = Proc.num_available_registers.(cl) in - let score = Array.create num_regs 0 in + let score = Array.make num_regs 0 in let best_score = ref (-1000000) and best_reg = ref (-1) in let start = start_register.(cl) in if num_regs <> 0 then begin @@ -161,7 +161,7 @@ let allocate_registers() = end else begin (* Sorry, we must put the pseudoreg in a stack location *) let nslots = Proc.num_stack_slots.(cl) in - let score = Array.create nslots 0 in + let score = Array.make nslots 0 in (* Compute the scores as for registers *) List.iter (fun (r, w) -> diff --git a/asmcomp/compilenv.ml b/asmcomp/compilenv.ml index 80be94e9f..a313b9720 100644 --- a/asmcomp/compilenv.ml +++ b/asmcomp/compilenv.ml @@ -30,9 +30,9 @@ let global_infos_table = module CstMap = Map.Make(struct type t = Clambda.ustructured_constant - let compare = Pervasives.compare - (* could use a better version, comparing on the - first arg of Uconst_ref *) + let compare = Clambda.compare_structured_constants + (* PR#6442: it is incorrect to use Pervasives.compare on values of type t + because it compares "0.0" and "-0.0" equal. *) end) type structured_constants = @@ -108,7 +108,7 @@ let make_symbol ?(unitname = current_unit.ui_symbol) idopt = let symbol_in_current_unit name = let prefix = "caml" ^ current_unit.ui_symbol in - name = prefix || + name = prefix || (let lp = String.length prefix in String.length name >= 2 + lp && String.sub name 0 lp = prefix @@ -118,7 +118,7 @@ let symbol_in_current_unit name = let read_unit_info filename = let ic = open_in_bin filename in try - let buffer = input_bytes ic (String.length cmx_magic_number) in + let buffer = really_input_string ic (String.length cmx_magic_number) in if buffer <> cmx_magic_number then begin close_in ic; raise(Error(Not_a_unit_info filename)) @@ -133,7 +133,7 @@ let read_unit_info filename = let read_library_info filename = let ic = open_in_bin filename in - let buffer = input_bytes ic (String.length cmxa_magic_number) in + let buffer = really_input_string ic (String.length cmxa_magic_number) in if buffer <> cmxa_magic_number then raise(Error(Not_a_unit_info filename)); let infos = (input_value ic : library_infos) in @@ -143,9 +143,6 @@ let read_library_info filename = (* Read and cache info on global identifiers *) -let cmx_not_found_crc = - "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" - let get_global_info global_ident = ( let modname = Ident.name global_ident in if modname = current_unit.ui_name then @@ -161,9 +158,9 @@ let get_global_info global_ident = ( let (ui, crc) = read_unit_info filename in if ui.ui_name <> modname then raise(Error(Illegal_renaming(modname, ui.ui_name, filename))); - (Some ui, crc) + (Some ui, Some crc) with Not_found -> - (None, cmx_not_found_crc) in + (None, None) in current_unit.ui_imports_cmx <- (modname, crc) :: current_unit.ui_imports_cmx; Hashtbl.add global_infos_table modname infos; @@ -231,7 +228,7 @@ let write_unit_info info filename = close_out oc let save_unit_info filename = - current_unit.ui_imports_cmi <- Env.imported_units(); + current_unit.ui_imports_cmi <- Env.imports(); write_unit_info current_unit filename diff --git a/asmcomp/compilenv.mli b/asmcomp/compilenv.mli index 9c2eb6297..7fae3bade 100644 --- a/asmcomp/compilenv.mli +++ b/asmcomp/compilenv.mli @@ -59,7 +59,8 @@ val new_structured_constant: Clambda.ustructured_constant -> shared:bool -> (* can be shared with another structually equal constant *) string -val structured_constants: unit -> (string * bool * Clambda.ustructured_constant) list +val structured_constants: + unit -> (string * bool * Clambda.ustructured_constant) list val add_exported_constant: string -> unit type structured_constants @@ -78,10 +79,6 @@ val cache_unit_info: unit_infos -> unit honored by [symbol_for_global] and [global_approx] without looking at the corresponding .cmx file. *) -val cmx_not_found_crc: Digest.t - (* Special digest used in the [ui_imports_cmx] list to signal - that no [.cmx] file was found and used for the imported unit *) - val read_library_info: string -> library_infos type error = diff --git a/asmcomp/deadcode.ml b/asmcomp/deadcode.ml new file mode 100644 index 000000000..cb93c2869 --- /dev/null +++ b/asmcomp/deadcode.ml @@ -0,0 +1,67 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2014 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* Dead code elimination: remove pure instructions whose results are + not used. *) + +open Mach + +(* [deadcode i] returns a pair of an optimized instruction [i'] + and a set of registers live "before" instruction [i]. *) + +let rec deadcode i = + match i.desc with + | Iend | Ireturn | Iop(Itailcall_ind) | Iop(Itailcall_imm _) | Iraise _ -> + (i, Reg.add_set_array i.live i.arg) + | Iop op -> + let (s, before) = deadcode i.next in + if Proc.op_is_pure op (* no side effects *) + && Reg.disjoint_set_array before i.res (* results are not used after *) + && not (Proc.regs_are_volatile i.arg) (* no stack-like hard reg *) + && not (Proc.regs_are_volatile i.res) (* is involved *) + then begin + assert (Array.length i.res > 0); (* sanity check *) + (s, before) + end else begin + ({i with next = s}, Reg.add_set_array i.live i.arg) + end + | Iifthenelse(test, ifso, ifnot) -> + let (ifso', _) = deadcode ifso in + let (ifnot', _) = deadcode ifnot in + let (s, _) = deadcode i.next in + ({i with desc = Iifthenelse(test, ifso', ifnot'); next = s}, + Reg.add_set_array i.live i.arg) + | Iswitch(index, cases) -> + let cases' = Array.map (fun c -> fst (deadcode c)) cases in + let (s, _) = deadcode i.next in + ({i with desc = Iswitch(index, cases'); next = s}, + Reg.add_set_array i.live i.arg) + | Iloop(body) -> + let (body', _) = deadcode body in + let (s, _) = deadcode i.next in + ({i with desc = Iloop body'; next = s}, i.live) + | Icatch(nfail, body, handler) -> + let (body', _) = deadcode body in + let (handler', _) = deadcode handler in + let (s, _) = deadcode i.next in + ({i with desc = Icatch(nfail, body', handler'); next = s}, i.live) + | Iexit nfail -> + (i, i.live) + | Itrywith(body, handler) -> + let (body', _) = deadcode body in + let (handler', _) = deadcode handler in + let (s, _) = deadcode i.next in + ({i with desc = Itrywith(body', handler'); next = s}, i.live) + +let fundecl f = + let (new_body, _) = deadcode f.fun_body in + {f with fun_body = new_body} diff --git a/asmcomp/deadcode.mli b/asmcomp/deadcode.mli new file mode 100644 index 000000000..6aafae054 --- /dev/null +++ b/asmcomp/deadcode.mli @@ -0,0 +1,16 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2014 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* Dead code elimination: remove pure instructions whose results are + not used. *) + +val fundecl: Mach.fundecl -> Mach.fundecl diff --git a/asmcomp/emitaux.ml b/asmcomp/emitaux.ml index ccfa977ff..24a621b33 100644 --- a/asmcomp/emitaux.ml +++ b/asmcomp/emitaux.ml @@ -88,16 +88,10 @@ let emit_bytes_directive directive s = done; if !pos > 0 then emit_char '\n' -(* PR#4813: assemblers do strange things with float literals indeed, - so we convert to IEEE representation ourselves and emit float - literals as 32- or 64-bit integers. *) - -let emit_float64_directive directive f = - let x = Int64.bits_of_float (float_of_string f) in +let emit_float64_directive directive x = emit_printf "\t%s\t0x%Lx\n" directive x -let emit_float64_split_directive directive f = - let x = Int64.bits_of_float (float_of_string f) in +let emit_float64_split_directive directive x = let lo = Int64.logand x 0xFFFF_FFFFL and hi = Int64.shift_right_logical x 32 in emit_printf "\t%s\t0x%Lx, 0x%Lx\n" @@ -105,8 +99,7 @@ let emit_float64_split_directive directive f = (if Arch.big_endian then hi else lo) (if Arch.big_endian then lo else hi) -let emit_float32_directive directive f = - let x = Int32.bits_of_float (float_of_string f) in +let emit_float32_directive directive x = emit_printf "\t%s\t0x%lx\n" directive x (* Record live pointers at call points *) @@ -239,3 +232,7 @@ let emit_debug_info dbg = emit_int file_num; emit_char '\t'; emit_int line; emit_char '\n' end + +let reset () = + reset_debug_info (); + frame_descriptors := [] diff --git a/asmcomp/emitaux.mli b/asmcomp/emitaux.mli index cc479d8cc..486a5839c 100644 --- a/asmcomp/emitaux.mli +++ b/asmcomp/emitaux.mli @@ -23,10 +23,11 @@ val emit_char: char -> unit val emit_string_literal: string -> unit val emit_string_directive: string -> string -> unit val emit_bytes_directive: string -> string -> unit -val emit_float64_directive: string -> string -> unit -val emit_float64_split_directive: string -> string -> unit -val emit_float32_directive: string -> string -> unit +val emit_float64_directive: string -> int64 -> unit +val emit_float64_split_directive: string -> int64 -> unit +val emit_float32_directive: string -> int32 -> unit +val reset : unit -> unit val reset_debug_info: unit -> unit val emit_debug_info: Debuginfo.t -> unit diff --git a/asmcomp/i386/CSE.ml b/asmcomp/i386/CSE.ml new file mode 100644 index 000000000..6bea76f1a --- /dev/null +++ b/asmcomp/i386/CSE.ml @@ -0,0 +1,47 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2014 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* CSE for the i386 *) + +open Cmm +open Arch +open Mach +open CSEgen + +class cse = object (self) + +inherit cse_generic as super + +method! class_of_operation op = + match op with + (* Operations that affect the floating-point stack cannot be factored *) + | Iconst_float _ | Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf + | Iintoffloat | Ifloatofint + | Iload((Single | Double | Double_u), _) -> Op_other + (* Specific ops *) + | Ispecific(Ilea _) -> Op_pure + | Ispecific(Istore_int(_, _, is_asg)) -> Op_store is_asg + | Ispecific(Istore_symbol(_, _, is_asg)) -> Op_store is_asg + | Ispecific(Ioffset_loc(_, _)) -> Op_store true + | Ispecific _ -> Op_other + | _ -> super#class_of_operation op + +method! is_cheap_operation op = + match op with + | Iconst_int _ | Iconst_blockheader _ -> true + | Iconst_symbol _ -> true + | _ -> false + +end + +let fundecl f = + (new cse)#fundecl f diff --git a/asmcomp/i386/arch.ml b/asmcomp/i386/arch.ml index d2f9fd61a..1d486db3e 100644 --- a/asmcomp/i386/arch.ml +++ b/asmcomp/i386/arch.ml @@ -31,11 +31,12 @@ type addressing_mode = type specific_operation = Ilea of addressing_mode (* Lea gives scaled adds *) - | Istore_int of nativeint * addressing_mode (* Store an integer constant *) - | Istore_symbol of string * addressing_mode (* Store a symbol *) + | Istore_int of nativeint * addressing_mode * bool + (* Store an integer constant *) + | Istore_symbol of string * addressing_mode * bool (* Store a symbol *) | Ioffset_loc of int * addressing_mode (* Add a constant to a location *) | Ipush (* Push regs on stack *) - | Ipush_int of nativeint (* Push an integer constant *) + | Ipush_int of nativeint (* Push an integer constant *) | Ipush_symbol of string (* Push a symbol *) | Ipush_load of addressing_mode (* Load a scalar and push *) | Ipush_load_float of addressing_mode (* Load a float and push *) @@ -105,11 +106,14 @@ let print_addressing printreg addr ppf arg = let print_specific_operation printreg op ppf arg = match op with | Ilea addr -> print_addressing printreg addr ppf arg - | Istore_int(n, addr) -> - fprintf ppf "[%a] := %s" (print_addressing printreg addr) arg - (Nativeint.to_string n) - | Istore_symbol(lbl, addr) -> - fprintf ppf "[%a] := \"%s\"" (print_addressing printreg addr) arg lbl + | Istore_int(n, addr, is_assign) -> + fprintf ppf "[%a] := %nd %s" + (print_addressing printreg addr) arg n + (if is_assign then "(assign)" else "(init)") + | Istore_symbol(lbl, addr, is_assign) -> + fprintf ppf "[%a] := \"%s\" %s" + (print_addressing printreg addr) arg lbl + (if is_assign then "(assign)" else "(init)") | Ioffset_loc(n, addr) -> fprintf ppf "[%a] +:= %i" (print_addressing printreg addr) arg n | Ipush -> @@ -152,5 +156,7 @@ let print_specific_operation printreg op ppf arg = let stack_alignment = match Config.system with - | "macosx" -> 16 - | _ -> 4 + | "win32" -> 4 (* MSVC *) + | _ -> 16 +(* PR#6038: GCC and Clang seem to require 16-byte alignment nowadays, + even if only MacOS X's ABI formally requires it *) diff --git a/asmcomp/i386/emit.mlp b/asmcomp/i386/emit.mlp index 2b90d37f6..98df5f958 100644 --- a/asmcomp/i386/emit.mlp +++ b/asmcomp/i386/emit.mlp @@ -412,15 +412,16 @@ let emit_floatspecial = function (* Floating-point constants *) -let float_constants = ref ([] : (string * int) list) +let float_constants = ref ([] : (int64 * int) list) let add_float_constant cst = + let repr = Int64.bits_of_float cst in try - List.assoc cst !float_constants + List.assoc repr !float_constants with Not_found -> let lbl = new_label() in - float_constants := (cst, lbl) :: !float_constants; + float_constants := (repr, lbl) :: !float_constants; lbl let emit_float_constant (cst, lbl) = @@ -465,8 +466,8 @@ let emit_instr fallthrough i = | _ -> ` movl $0, {emit_reg i.res.(0)}\n` end else ` movl ${emit_nativeint n}, {emit_reg i.res.(0)}\n` - | Lop(Iconst_float s) -> - begin match Int64.bits_of_float (float_of_string s) with + | Lop(Iconst_float f) -> + begin match Int64.bits_of_float f with | 0x0000_0000_0000_0000L -> (* +0.0 *) ` fldz\n` | 0x8000_0000_0000_0000L -> (* -0.0 *) @@ -476,7 +477,7 @@ let emit_instr fallthrough i = | 0xBFF0_0000_0000_0000L -> (* -1.0 *) ` fld1\n fchs\n` | _ -> - let lbl = add_float_constant s in + let lbl = add_float_constant f in ` fldl {emit_label lbl}\n` end | Lop(Iconst_symbol s) -> @@ -543,7 +544,7 @@ let emit_instr fallthrough i = | Double | Double_u -> ` fldl {emit_addressing addr i.arg 0}\n` end - | Lop(Istore(chunk, addr)) -> + | Lop(Istore(chunk, addr, _)) -> begin match chunk with | Word | Thirtytwo_signed | Thirtytwo_unsigned -> ` movl {emit_reg i.arg.(0)}, {emit_addressing addr i.arg 1}\n` @@ -683,9 +684,9 @@ let emit_instr fallthrough i = stack_offset := !stack_offset + 8 | Lop(Ispecific(Ilea addr)) -> ` lea {emit_addressing addr i.arg 0}, {emit_reg i.res.(0)}\n` - | Lop(Ispecific(Istore_int(n, addr))) -> + | Lop(Ispecific(Istore_int(n, addr, _))) -> ` movl ${emit_nativeint n}, {emit_addressing addr i.arg 0}\n` - | Lop(Ispecific(Istore_symbol(s, addr))) -> + | Lop(Ispecific(Istore_symbol(s, addr, _))) -> ` movl ${emit_symbol s}, {emit_addressing addr i.arg 0}\n` | Lop(Ispecific(Ioffset_loc(n, addr))) -> ` addl ${emit_int n}, {emit_addressing addr i.arg 0}\n` @@ -960,9 +961,9 @@ let emit_item = function | Cint n -> ` .long {emit_nativeint n}\n` | Csingle f -> - emit_float32_directive ".long" f + emit_float32_directive ".long" (Int32.bits_of_float f) | Cdouble f -> - emit_float64_split_directive ".long" f + emit_float64_split_directive ".long" (Int64.bits_of_float f) | Csymbol_address s -> ` .long {emit_symbol s}\n` | Clabel_address lbl -> diff --git a/asmcomp/i386/emit_nt.mlp b/asmcomp/i386/emit_nt.mlp index 495a29aec..ef5205ef8 100644 --- a/asmcomp/i386/emit_nt.mlp +++ b/asmcomp/i386/emit_nt.mlp @@ -62,7 +62,10 @@ let add_used_symbol s = let emit_symbol s = emit_string "_"; Emitaux.emit_symbol '$' s +(* Output a 32 or 64 bit integer in hex *) + let emit_int32 n = emit_printf "0%lxh" n +let emit_int64 n = emit_printf "0%Lxh" n (* Output a label *) @@ -361,36 +364,20 @@ let emit_floatspecial = function (* Floating-point constants *) -let float_constants = ref ([] : (string * int) list) +let float_constants = ref ([] : (int64 * int) list) let add_float_constant cst = + let repr = Int64.bits_of_float cst in try - List.assoc cst !float_constants + List.assoc repr !float_constants with Not_found -> let lbl = new_label() in - float_constants := (cst, lbl) :: !float_constants; + float_constants := (repr, lbl) :: !float_constants; lbl -let emit_float s = - (* MASM doesn't like floating-point constants such as 2e9. - Turn them into 2.0e9. *) - let pos_e = ref (-1) and pos_dot = ref (-1) in - for i = 0 to String.length s - 1 do - match s.[i] with - 'e'|'E' -> pos_e := i - | '.' -> pos_dot := i - | _ -> () - done; - if !pos_dot < 0 && !pos_e >= 0 then begin - emit_string (String.sub s 0 !pos_e); - emit_string ".0"; - emit_string (String.sub s !pos_e (String.length s - !pos_e)) - end else - emit_string s - let emit_float_constant (cst, lbl) = - `{emit_label lbl} REAL8 {emit_float cst}\n` + `{emit_label lbl} QWORD {emit_int64 cst}\n` (* Output the assembly code for an instruction *) @@ -426,8 +413,8 @@ let emit_instr i = | _ -> ` mov {emit_reg i.res.(0)}, 0\n` end else ` mov {emit_reg i.res.(0)}, {emit_nativeint n}\n` - | Lop(Iconst_float s) -> - begin match Int64.bits_of_float (float_of_string s) with + | Lop(Iconst_float f) -> + begin match Int64.bits_of_float f with | 0x0000_0000_0000_0000L -> (* +0.0 *) ` fldz\n` | 0x8000_0000_0000_0000L -> (* -0.0 *) @@ -437,7 +424,7 @@ let emit_instr i = | 0xBFF0_0000_0000_0000L -> (* -1.0 *) ` fld1\n fchs\n` | _ -> - let lbl = add_float_constant s in + let lbl = add_float_constant f in ` fld {emit_label lbl}\n` end | Lop(Iconst_symbol s) -> @@ -493,7 +480,7 @@ let emit_instr i = | Double | Double_u -> ` fld REAL8 PTR {emit_addressing addr i.arg 0}\n` end - | Lop(Istore(chunk, addr)) -> + | Lop(Istore(chunk, addr, _)) -> begin match chunk with | Word | Thirtytwo_signed | Thirtytwo_unsigned -> ` mov DWORD PTR {emit_addressing addr i.arg 1}, {emit_reg i.arg.(0)}\n` @@ -631,9 +618,9 @@ let emit_instr i = stack_offset := !stack_offset + 8 | Lop(Ispecific(Ilea addr)) -> ` lea {emit_reg i.res.(0)}, DWORD PTR {emit_addressing addr i.arg 0}\n` - | Lop(Ispecific(Istore_int(n, addr))) -> + | Lop(Ispecific(Istore_int(n, addr, _))) -> ` mov DWORD PTR {emit_addressing addr i.arg 0},{emit_nativeint n}\n` - | Lop(Ispecific(Istore_symbol(s, addr))) -> + | Lop(Ispecific(Istore_symbol(s, addr, _))) -> add_used_symbol s ; ` mov DWORD PTR {emit_addressing addr i.arg 0},OFFSET {emit_symbol s}\n` | Lop(Ispecific(Ioffset_loc(n, addr))) -> @@ -816,9 +803,9 @@ let emit_item = function | Cint32 n -> ` DWORD {emit_nativeint n}\n` | Csingle f -> - ` REAL4 {emit_float f}\n` + ` DWORD {emit_int32 (Int32.bits_of_float f)}\n` | Cdouble f -> - ` REAL8 {emit_float f}\n` + ` QWORD {emit_int64 (Int64.bits_of_float f)}\n` | Csymbol_address s -> add_used_symbol s ; ` DWORD {emit_symbol s}\n` diff --git a/asmcomp/i386/proc.ml b/asmcomp/i386/proc.ml index d80d18208..0b010d248 100644 --- a/asmcomp/i386/proc.ml +++ b/asmcomp/i386/proc.ml @@ -72,7 +72,7 @@ let rotate_registers = false (* Representation of hard registers by pseudo-registers *) let hard_int_reg = - let v = Array.create 7 Reg.dummy in + let v = Array.make 7 Reg.dummy in for i = 0 to 6 do v.(i) <- Reg.at_location Int (Reg i) done; v @@ -111,7 +111,7 @@ let word_addressed = false let calling_conventions first_int last_int first_float last_float make_stack arg = - let loc = Array.create (Array.length arg) Reg.dummy in + let loc = Array.make (Array.length arg) Reg.dummy in let int = ref first_int in let float = ref first_float in let ofs = ref (-64) in @@ -154,6 +154,21 @@ let loc_external_results res = let loc_exn_bucket = eax +(* Volatile registers: the x87 top of FP stack is *) + +let reg_is_volatile = function + | { typ = Float; loc = Reg _ } -> true + | _ -> false + +let regs_are_volatile rs = + try + for i = 0 to Array.length rs - 1 do + if reg_is_volatile rs.(i) then raise Exit + done; + false + with Exit -> + true + (* Registers destroyed by operations *) let destroyed_at_c_call = (* ebx, esi, edi, ebp preserved *) @@ -182,6 +197,17 @@ let max_register_pressure = function Iintoffloat -> [| 6; max_int |] | _ -> [|7; max_int |] +(* Pure operations (without any side effect besides updating their result + registers). *) + +let op_is_pure = function + | Icall_ind | Icall_imm _ | Itailcall_ind | Itailcall_imm _ + | Iextcall _ | Istackoffset _ | Istore _ | Ialloc _ + | Iintop(Icheckbound) | Iintop_imm(Icheckbound, _) -> false + | Ispecific(Ilea _) -> true + | Ispecific _ -> false + | _ -> true + (* Layout of the stack frame *) let num_stack_slots = [| 0; 0 |] diff --git a/asmcomp/i386/selection.ml b/asmcomp/i386/selection.ml index 473499f36..10d2d40e3 100644 --- a/asmcomp/i386/selection.ml +++ b/asmcomp/i386/selection.ml @@ -135,7 +135,7 @@ let pseudoregs_for_operation op arg res = (* For storing a byte, the argument must be in eax...edx. (But for a short, any reg will do!) Keep it simple, just force the argument to be in edx. *) - | Istore((Byte_unsigned | Byte_signed), addr) -> + | Istore((Byte_unsigned | Byte_signed), addr, _) -> let newarg = Array.copy arg in newarg.(0) <- edx; (newarg, res, false) @@ -178,20 +178,20 @@ method select_addressing chunk exp = | (Ascaledadd(e1, e2, scale), d) -> (Iindexed2scaled(scale, d), Ctuple[e1; e2]) -method! select_store addr exp = +method! select_store is_assign addr exp = match exp with Cconst_int n -> - (Ispecific(Istore_int(Nativeint.of_int n, addr)), Ctuple []) - | Cconst_natint n -> - (Ispecific(Istore_int(n, addr)), Ctuple []) + (Ispecific(Istore_int(Nativeint.of_int n, addr, is_assign)), Ctuple []) + | (Cconst_natint n | Cconst_blockheader n) -> + (Ispecific(Istore_int(n, addr, is_assign)), Ctuple []) | Cconst_pointer n -> - (Ispecific(Istore_int(Nativeint.of_int n, addr)), Ctuple []) + (Ispecific(Istore_int(Nativeint.of_int n, addr, is_assign)), Ctuple []) | Cconst_natpointer n -> - (Ispecific(Istore_int(n, addr)), Ctuple []) + (Ispecific(Istore_int(n, addr, is_assign)), Ctuple []) | Cconst_symbol s -> - (Ispecific(Istore_symbol(s, addr)), Ctuple []) + (Ispecific(Istore_symbol(s, addr, is_assign)), Ctuple []) | _ -> - super#select_store addr exp + super#select_store is_assign addr exp method! select_operation op args = match op with @@ -288,6 +288,9 @@ method select_push exp = (Ispecific(Ipush_load_float addr), arg) | _ -> (Ispecific(Ipush), exp) +method! mark_c_tailcall = + Proc.contains_calls := true + method! emit_extcall_args env args = let rec size_pushes = function | [] -> 0 diff --git a/asmcomp/linearize.ml b/asmcomp/linearize.ml index ebe590c56..64678c1d4 100644 --- a/asmcomp/linearize.ml +++ b/asmcomp/linearize.ml @@ -126,9 +126,9 @@ let rec discard_dead_code n = match n.desc with Lend -> n | Llabel _ -> n -(* Do not discard Lpoptrap or Istackoffset instructions, +(* Do not discard Lpoptrap/Lpushtrap or Istackoffset instructions, as this may cause a stack imbalance later during assembler generation. *) - | Lpoptrap -> n + | Lpoptrap | Lpushtrap -> n | Lop(Istackoffset _) -> n | _ -> discard_dead_code n.next @@ -148,20 +148,30 @@ let add_branch lbl n = else discard_dead_code n -(* Current labels for exit handler *) +let try_depth = ref 0 + +(* Association list: exit handler -> (handler label, try-nesting factor) *) let exit_label = ref [] -let find_exit_label k = +let find_exit_label_try_depth k = try List.assoc k !exit_label with | Not_found -> Misc.fatal_error "Linearize.find_exit_label" +let find_exit_label k = + let (label, t) = find_exit_label_try_depth k in + assert(t = !try_depth); + label + let is_next_catch n = match !exit_label with -| (n0,_)::_ when n0=n -> true +| (n0,(_,t))::_ when n0=n && t = !try_depth -> true | _ -> false +let local_exit k = + snd (find_exit_label_try_depth k) = !try_depth + (* Linearize an instruction [i]: add it in front of the continuation [n] *) let rec linear i n = @@ -187,15 +197,15 @@ let rec linear i n = | _, Iend, Lbranch lbl -> copy_instr (Lcondbranch(invert_test test, lbl)) i (linear ifso n1) | Iexit nfail1, Iexit nfail2, _ - when is_next_catch nfail1 -> + when is_next_catch nfail1 && local_exit nfail2 -> let lbl2 = find_exit_label nfail2 in copy_instr (Lcondbranch (invert_test test, lbl2)) i (linear ifso n1) - | Iexit nfail, _, _ -> + | Iexit nfail, _, _ when local_exit nfail -> let n2 = linear ifnot n1 and lbl = find_exit_label nfail in copy_instr (Lcondbranch(test, lbl)) i n2 - | _, Iexit nfail, _ -> + | _, Iexit nfail, _ when local_exit nfail -> let n2 = linear ifso n1 in let lbl = find_exit_label nfail in copy_instr (Lcondbranch(invert_test test, lbl)) i n2 @@ -214,7 +224,7 @@ let rec linear i n = (linear ifso (add_branch lbl_end nelse)) end | Iswitch(index, cases) -> - let lbl_cases = Array.create (Array.length cases) 0 in + let lbl_cases = Array.make (Array.length cases) 0 in let (lbl_end, n1) = get_label(linear i.Mach.next n) in let n2 = ref (discard_dead_code n1) in for i = Array.length cases - 1 downto 0 do @@ -242,24 +252,44 @@ let rec linear i n = | Icatch(io, body, handler) -> let (lbl_end, n1) = get_label(linear i.Mach.next n) in let (lbl_handler, n2) = get_label(linear handler n1) in - exit_label := (io, lbl_handler) :: !exit_label ; + exit_label := (io, (lbl_handler, !try_depth)) :: !exit_label ; let n3 = linear body (add_branch lbl_end n2) in exit_label := List.tl !exit_label; n3 | Iexit nfail -> - let n1 = linear i.Mach.next n in - let lbl = find_exit_label nfail in - add_branch lbl n1 + let lbl, t = find_exit_label_try_depth nfail in + (* We need to re-insert dummy pushtrap (which won't be executed), + so as to preserve stack offset during assembler generation. + It would make sense to have a special pseudo-instruction + only to inform the later pass about this stack offset + (corresponding to N traps). + *) + let rec loop i tt = + if t = tt then i + else loop (cons_instr Lpushtrap i) (tt - 1) + in + let n1 = loop (linear i.Mach.next n) !try_depth in + let rec loop i tt = + if t = tt then i + else loop (cons_instr Lpoptrap i) (tt - 1) + in + loop (add_branch lbl n1) !try_depth | Itrywith(body, handler) -> let (lbl_join, n1) = get_label (linear i.Mach.next n) in + incr try_depth; let (lbl_body, n2) = get_label (cons_instr Lpushtrap (linear body (cons_instr Lpoptrap n1))) in + decr try_depth; cons_instr (Lsetuptrap lbl_body) (linear handler (add_branch lbl_join n2)) | Iraise k -> copy_instr (Lraise k) i (discard_dead_code n) +let reset () = + label_counter := 99; + exit_label := [] + let fundecl f = { fun_name = f.Mach.fun_name; fun_body = linear f.Mach.fun_body end_instr; diff --git a/asmcomp/linearize.mli b/asmcomp/linearize.mli index 22987e5ba..2996a29bf 100644 --- a/asmcomp/linearize.mli +++ b/asmcomp/linearize.mli @@ -50,4 +50,5 @@ type fundecl = fun_fast: bool; fun_dbg : Debuginfo.t } +val reset : unit -> unit val fundecl: Mach.fundecl -> fundecl diff --git a/asmcomp/liveness.ml b/asmcomp/liveness.ml index 434d50655..2ef322ef3 100644 --- a/asmcomp/liveness.ml +++ b/asmcomp/liveness.ml @@ -16,13 +16,13 @@ open Mach let live_at_exit = ref [] + let find_live_at_exit k = try List.assoc k !live_at_exit with - | Not_found -> Misc.fatal_error "Spill.find_live_at_exit" + | Not_found -> Misc.fatal_error "Liveness.find_live_at_exit" -let live_at_break = ref Reg.Set.empty let live_at_raise = ref Reg.Set.empty let rec live i finally = @@ -37,8 +37,34 @@ let rec live i finally = i.live <- finally; finally | Ireturn | Iop(Itailcall_ind) | Iop(Itailcall_imm _) -> - (* i.live remains empty since no regs are live across *) + i.live <- Reg.Set.empty; (* no regs are live across *) Reg.set_of_array i.arg + | Iop op -> + let after = live i.next finally in + if Proc.op_is_pure op (* no side effects *) + && Reg.disjoint_set_array after i.res (* results are not used after *) + && not (Proc.regs_are_volatile i.arg) (* no stack-like hard reg *) + && not (Proc.regs_are_volatile i.res) (* is involved *) + then begin + (* This operation is dead code. Ignore its arguments. *) + i.live <- after; + after + end else begin + let across_after = Reg.diff_set_array after i.res in + let across = + match op with + | Icall_ind | Icall_imm _ | Iextcall _ + | Iintop Icheckbound | Iintop_imm(Icheckbound, _) -> + (* The function call may raise an exception, branching to the + nearest enclosing try ... with. Similarly for bounds checks. + Hence, everything that must be live at the beginning of + the exception handler must also be live across this instr. *) + Reg.Set.union across_after !live_at_raise + | _ -> + across_after in + i.live <- across; + Reg.add_set_array across i.arg + end | Iifthenelse(test, ifso, ifnot) -> let at_join = live i.next finally in let at_fork = Reg.Set.union (live ifso at_join) (live ifnot at_join) in @@ -90,23 +116,12 @@ let rec live i finally = i.live <- before_body; before_body | Iraise _ -> - (* i.live remains empty since no regs are live across *) + i.live <- !live_at_raise; Reg.add_set_array !live_at_raise i.arg - | _ -> - let across_after = Reg.diff_set_array (live i.next finally) i.res in - let across = - match i.desc with - Iop Icall_ind | Iop(Icall_imm _) | Iop(Iextcall _) - | Iop(Iintop Icheckbound) | Iop(Iintop_imm(Icheckbound, _)) -> - (* The function call may raise an exception, branching to the - nearest enclosing try ... with. Similarly for bounds checks. - Hence, everything that must be live at the beginning of - the exception handler must also be live across this instr. *) - Reg.Set.union across_after !live_at_raise - | _ -> - across_after in - i.live <- across; - Reg.add_set_array across i.arg + +let reset () = + live_at_raise := Reg.Set.empty; + live_at_exit := [] let fundecl ppf f = let initially_live = live f.fun_body Reg.Set.empty in diff --git a/asmcomp/liveness.mli b/asmcomp/liveness.mli index b52ec5a2b..ed2f1a8ae 100644 --- a/asmcomp/liveness.mli +++ b/asmcomp/liveness.mli @@ -15,4 +15,5 @@ open Format +val reset : unit -> unit val fundecl: formatter -> Mach.fundecl -> unit diff --git a/asmcomp/mach.ml b/asmcomp/mach.ml index a11910ec7..3a7174763 100644 --- a/asmcomp/mach.ml +++ b/asmcomp/mach.ml @@ -36,7 +36,7 @@ type operation = | Ispill | Ireload | Iconst_int of nativeint - | Iconst_float of string + | Iconst_float of float | Iconst_symbol of string | Iconst_blockheader of nativeint | Icall_ind @@ -46,7 +46,7 @@ type operation = | Iextcall of string * bool | Istackoffset of int | Iload of Cmm.memory_chunk * Arch.addressing_mode - | Istore of Cmm.memory_chunk * Arch.addressing_mode + | Istore of Cmm.memory_chunk * Arch.addressing_mode * bool | Ialloc of int | Iintop of integer_operation | Iintop_imm of integer_operation * int diff --git a/asmcomp/mach.mli b/asmcomp/mach.mli index 000c3cf9f..618e5e4ce 100644 --- a/asmcomp/mach.mli +++ b/asmcomp/mach.mli @@ -36,17 +36,18 @@ type operation = | Ispill | Ireload | Iconst_int of nativeint - | Iconst_float of string + | Iconst_float of float | Iconst_symbol of string | Iconst_blockheader of nativeint | Icall_ind | Icall_imm of string | Itailcall_ind | Itailcall_imm of string - | Iextcall of string * bool + | Iextcall of string * bool (* false = noalloc, true = alloc *) | Istackoffset of int | Iload of Cmm.memory_chunk * Arch.addressing_mode - | Istore of Cmm.memory_chunk * Arch.addressing_mode + | Istore of Cmm.memory_chunk * Arch.addressing_mode * bool + (* false = initialization, true = assignment *) | Ialloc of int | Iintop of integer_operation | Iintop_imm of integer_operation * int diff --git a/asmcomp/power/CSE.ml b/asmcomp/power/CSE.ml new file mode 100644 index 000000000..ec10d2df4 --- /dev/null +++ b/asmcomp/power/CSE.ml @@ -0,0 +1,37 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2014 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* CSE for the PowerPC *) + +open Arch +open Mach +open CSEgen + +class cse = object (self) + +inherit cse_generic as super + +method! class_of_operation op = + match op with + | Ispecific(Imultaddf | Imultsubf) -> Op_pure + | Ispecific(Ialloc_far _) -> Op_other + | _ -> super#class_of_operation op + +method! is_cheap_operation op = + match op with + | Iconst_int n | Iconst_blockheader n -> n <= 32767n && n >= -32768n + | _ -> false + +end + +let fundecl f = + (new cse)#fundecl f diff --git a/asmcomp/power/emit.mlp b/asmcomp/power/emit.mlp index f6ee1a232..0a26ed147 100644 --- a/asmcomp/power/emit.mlp +++ b/asmcomp/power/emit.mlp @@ -229,7 +229,7 @@ let record_frame live dbg = (* Record floating-point and large integer literals *) -let float_literals = ref ([] : (string * int) list) +let float_literals = ref ([] : (int64 * int) list) let int_literals = ref ([] : (nativeint * int) list) (* Record external C functions to be called in a position-independent way @@ -333,7 +333,7 @@ let instr_size = function if chunk = Byte_signed then load_store_size addr + 1 else load_store_size addr - | Lop(Istore(chunk, addr)) -> load_store_size addr + | Lop(Istore(chunk, addr, _)) -> load_store_size addr | Lop(Ialloc n) -> 4 | Lop(Ispecific(Ialloc_far n)) -> 5 | Lop(Iintop Imod) -> 3 @@ -466,9 +466,9 @@ let rec emit_instr i dslot = ` addis {emit_gpr 11}, 0, {emit_upper emit_label lbl}\n`; ` {emit_string lg} {emit_reg i.res.(0)}, {emit_lower emit_label lbl}({emit_gpr 11})\n` end - | Lop(Iconst_float s) -> + | Lop(Iconst_float f) -> let lbl = new_label() in - float_literals := (s, lbl) :: !float_literals; + float_literals := (Int64.bits_of_float f, lbl) :: !float_literals; ` addis {emit_gpr 11}, 0, {emit_upper emit_label lbl}\n`; ` lfd {emit_reg i.res.(0)}, {emit_lower emit_label lbl}({emit_gpr 11})\n` | Lop(Iconst_symbol s) -> @@ -548,7 +548,7 @@ let rec emit_instr i dslot = emit_load_store loadinstr addr i.arg 0 i.res.(0); if chunk = Byte_signed then ` extsb {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` - | Lop(Istore(chunk, addr)) -> + | Lop(Istore(chunk, addr, _)) -> let storeinstr = match chunk with Byte_unsigned | Byte_signed -> "stb" @@ -628,8 +628,7 @@ let rec emit_instr i dslot = ` fcfid {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` end else begin let lbl = new_label() in - float_literals := ("4.503601774854144e15", lbl) :: !float_literals; - (* That float above represents 0x4330000080000000 *) + float_literals := (0x4330000080000000L, lbl) :: !float_literals; ` addis {emit_gpr 11}, 0, {emit_upper emit_label lbl}\n`; ` lfd {emit_fpr 0}, {emit_lower emit_label lbl}({emit_gpr 11})\n`; ` lis {emit_gpr 0}, 0x4330\n`; @@ -899,11 +898,11 @@ let emit_item = function | Cint n -> ` {emit_string datag} {emit_nativeint n}\n` | Csingle f -> - emit_float32_directive ".long" f + emit_float32_directive ".long" (Int32.bits_of_float f) | Cdouble f -> if ppc64 - then emit_float64_directive ".quad" f - else emit_float64_split_directive ".long" f + then emit_float64_directive ".quad" (Int64.bits_of_float f) + else emit_float64_split_directive ".long" (Int64.bits_of_float f) | Csymbol_address s -> ` {emit_string datag} {emit_symbol s}\n` | Clabel_address lbl -> diff --git a/asmcomp/power/proc.ml b/asmcomp/power/proc.ml index 203e8a9ef..934d2cbfe 100644 --- a/asmcomp/power/proc.ml +++ b/asmcomp/power/proc.ml @@ -83,11 +83,11 @@ let rotate_registers = true (* Representation of hard registers by pseudo-registers *) let hard_int_reg = - let v = Array.create 23 Reg.dummy in + let v = Array.make 23 Reg.dummy in for i = 0 to 22 do v.(i) <- Reg.at_location Int (Reg i) done; v let hard_float_reg = - let v = Array.create 31 Reg.dummy in + let v = Array.make 31 Reg.dummy in for i = 0 to 30 do v.(i) <- Reg.at_location Float (Reg(100 + i)) done; v let all_phys_regs = @@ -103,7 +103,7 @@ let stack_slot slot ty = let calling_conventions first_int last_int first_float last_float make_stack stack_ofs arg = - let loc = Array.create (Array.length arg) Reg.dummy in + let loc = Array.make (Array.length arg) Reg.dummy in let int = ref first_int in let float = ref first_float in let ofs = ref stack_ofs in @@ -157,7 +157,7 @@ let loc_results res = let poweropen_external_conventions first_int last_int first_float last_float arg = - let loc = Array.create (Array.length arg) Reg.dummy in + let loc = Array.make (Array.length arg) Reg.dummy in let int = ref first_int in let float = ref first_float in let ofs = ref (14 * size_addr) in @@ -200,6 +200,10 @@ let loc_external_results res = let loc_exn_bucket = phys_reg 0 +(* Volatile registers: none *) + +let regs_are_volatile rs = false + (* Registers destroyed by operations *) let destroyed_at_c_call = @@ -224,6 +228,17 @@ let max_register_pressure = function Iextcall(_, _) -> [| 15; 18 |] | _ -> [| 23; 30 |] +(* Pure operations (without any side effect besides updating their result + registers). *) + +let op_is_pure = function + | Icall_ind | Icall_imm _ | Itailcall_ind | Itailcall_imm _ + | Iextcall _ | Istackoffset _ | Istore _ | Ialloc _ + | Iintop(Icheckbound) | Iintop_imm(Icheckbound, _) -> false + | Ispecific(Imultaddf | Imultsubf) -> true + | Ispecific _ -> false + | _ -> true + (* Layout of the stack *) let num_stack_slots = [| 0; 0 |] diff --git a/asmcomp/power/scheduling.ml b/asmcomp/power/scheduling.ml index 6e594f028..7adaa2eed 100644 --- a/asmcomp/power/scheduling.ml +++ b/asmcomp/power/scheduling.ml @@ -44,7 +44,7 @@ method reload_retaddr_latency = 12 method oper_issue_cycles = function Iconst_float _ | Iconst_symbol _ -> 2 | Iload(_, Ibased(_, _)) -> 2 - | Istore(_, Ibased(_, _)) -> 2 + | Istore(_, Ibased(_, _), _) -> 2 | Ialloc _ -> 4 | Iintop(Imod) -> 40 (* assuming full stall *) | Iintop(Icomp _) -> 4 diff --git a/asmcomp/printclambda.ml b/asmcomp/printclambda.ml index 3d4c32c0a..b28d749e2 100644 --- a/asmcomp/printclambda.ml +++ b/asmcomp/printclambda.ml @@ -16,17 +16,20 @@ open Asttypes open Clambda let rec structured_constant ppf = function - | Uconst_float x -> fprintf ppf "%s" x - | Uconst_int32 x -> fprintf ppf "%ld" x - | Uconst_int64 x -> fprintf ppf "%Ld" x - | Uconst_nativeint x -> fprintf ppf "%nd" x + | Uconst_float x -> fprintf ppf "%F" x + | Uconst_int32 x -> fprintf ppf "%ldl" x + | Uconst_int64 x -> fprintf ppf "%LdL" x + | Uconst_nativeint x -> fprintf ppf "%ndn" x | Uconst_block (tag, l) -> fprintf ppf "block(%i" tag; List.iter (fun u -> fprintf ppf ",%a" uconstant u) l; fprintf ppf ")" - | Uconst_float_array sl -> - fprintf ppf "floatarray(%s)" - (String.concat "," sl) + | Uconst_float_array [] -> + fprintf ppf "floatarray()" + | Uconst_float_array (f1 :: fl) -> + fprintf ppf "floatarray(%F" f1; + List.iter (fun f -> fprintf ppf ",%F" f) fl; + fprintf ppf ")" | Uconst_string s -> fprintf ppf "%S" s and uconstant ppf = function @@ -51,7 +54,7 @@ let rec lam ppf = function let idents ppf = List.iter (fprintf ppf "@ %a" Ident.print)in let one_fun ppf f = - fprintf ppf "(fun@ %s@ %d @[<2>%a@] @[<2>%a@])" + fprintf ppf "@[<2>(fun@ %s@ %d @[<2>%a@]@ @[<2>%a@]@])" f.label f.arity idents f.params lam f.body in let funs ppf = List.iter (fprintf ppf "@ %a" one_fun) in @@ -83,22 +86,20 @@ let rec lam ppf = function List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in fprintf ppf "@[<2>(%a%a)@]" Printlambda.primitive prim lams largs | Uswitch(larg, sw) -> - let switch ppf sw = - let spc = ref false in - for i = 0 to Array.length sw.us_index_consts - 1 do - let n = sw.us_index_consts.(i) in - let l = sw.us_actions_consts.(n) in - if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[<hv 1>case int %i:@ %a@]" i lam l; - done; - for i = 0 to Array.length sw.us_index_blocks - 1 do - let n = sw.us_index_blocks.(i) in - let l = sw.us_actions_blocks.(n) in - if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[<hv 1>case tag %i:@ %a@]" i lam l; + let print_case tag index i ppf = + for j = 0 to Array.length index - 1 do + if index.(j) = i then fprintf ppf "case %s %i:" tag j + done in + let print_cases tag index cases ppf = + for i = 0 to Array.length cases - 1 do + fprintf ppf "@ @[<2>%t@ %a@]" + (print_case tag index i) sequence cases.(i) done in + let switch ppf sw = + print_cases "int" sw.us_index_consts sw.us_actions_consts ppf ; + print_cases "tag" sw.us_index_blocks sw.us_actions_blocks ppf in fprintf ppf - "@[<1>(switch %a@ @[<v 0>%a@])@]" + "@[<v 0>@[<2>(switch@ %a@ @]%a)@]" lam larg switch sw | Ustringswitch(larg,sw,d) -> let switch ppf sw = @@ -109,8 +110,12 @@ let rec lam ppf = function fprintf ppf "@[<hv 1>case \"%s\":@ %a@]" (String.escaped s) lam l) sw ; - if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[<hv 1>default:@ %a@]" lam d in + begin match d with + | Some d -> + if !spc then fprintf ppf "@ " else spc := true; + fprintf ppf "@[<hv 1>default:@ %a@]" lam d + | None -> () + end in fprintf ppf "@[<1>(switch %a@ @[<v 0>%a@])@]" lam larg switch sw | Ustaticfail (i, ls) -> @@ -186,4 +191,3 @@ let rec approx ppf = function fprintf ppf "@[const(%a)@]" uconstant c | Value_global_field (s, i) -> fprintf ppf "@[global(%s,%i)@]" s i - diff --git a/asmcomp/printcmm.ml b/asmcomp/printcmm.ml index 008081fb4..89c8582ae 100644 --- a/asmcomp/printcmm.ml +++ b/asmcomp/printcmm.ml @@ -89,7 +89,7 @@ let rec expr ppf = function | Cconst_int n -> fprintf ppf "%i" n | Cconst_natint n | Cconst_blockheader n -> fprintf ppf "%s" (Nativeint.to_string n) - | Cconst_float s -> fprintf ppf "%s" s + | Cconst_float n -> fprintf ppf "%F" n | Cconst_symbol s -> fprintf ppf "\"%s\"" s | Cconst_pointer n -> fprintf ppf "%ia" n | Cconst_natpointer n -> fprintf ppf "%sa" (Nativeint.to_string n) @@ -188,8 +188,8 @@ let data_item ppf = function | Cint16 n -> fprintf ppf "int16 %i" n | Cint32 n -> fprintf ppf "int32 %s" (Nativeint.to_string n) | Cint n -> fprintf ppf "int %s" (Nativeint.to_string n) - | Csingle f -> fprintf ppf "single %s" f - | Cdouble f -> fprintf ppf "double %s" f + | Csingle f -> fprintf ppf "single %F" f + | Cdouble f -> fprintf ppf "double %F" f | Csymbol_address s -> fprintf ppf "addr \"%s\"" s | Clabel_address l -> fprintf ppf "addr L%i" l | Cstring s -> fprintf ppf "string \"%s\"" s diff --git a/asmcomp/printmach.ml b/asmcomp/printmach.ml index 824665cd9..a39160d28 100644 --- a/asmcomp/printmach.ml +++ b/asmcomp/printmach.ml @@ -105,7 +105,7 @@ let operation op arg ppf res = | Ireload -> fprintf ppf "%a (reload)" regs arg | Iconst_int n | Iconst_blockheader n -> fprintf ppf "%s" (Nativeint.to_string n) - | Iconst_float s -> fprintf ppf "%s" s + | Iconst_float f -> fprintf ppf "%F" f | Iconst_symbol s -> fprintf ppf "\"%s\"" s | Icall_ind -> fprintf ppf "call %a" regs arg | Icall_imm lbl -> fprintf ppf "call \"%s\" %a" lbl regs arg @@ -119,12 +119,13 @@ let operation op arg ppf res = | Iload(chunk, addr) -> fprintf ppf "%s[%a]" (Printcmm.chunk chunk) (Arch.print_addressing reg addr) arg - | Istore(chunk, addr) -> - fprintf ppf "%s[%a] := %a" + | Istore(chunk, addr, is_assign) -> + fprintf ppf "%s[%a] := %a %s" (Printcmm.chunk chunk) (Arch.print_addressing reg addr) (Array.sub arg 1 (Array.length arg - 1)) reg arg.(0) + (if is_assign then "(assign)" else "(init)") | Ialloc n -> fprintf ppf "alloc %i" n | Iintop(op) -> fprintf ppf "%a%s%a" reg arg.(0) (intop op) reg arg.(1) | Iintop_imm(op, n) -> fprintf ppf "%a%s%i" reg arg.(0) (intop op) n diff --git a/asmcomp/proc.mli b/asmcomp/proc.mli index 6cc6aedc9..cabac4db7 100644 --- a/asmcomp/proc.mli +++ b/asmcomp/proc.mli @@ -40,6 +40,12 @@ val max_register_pressure: Mach.operation -> int array val destroyed_at_oper: Mach.instruction_desc -> Reg.t array val destroyed_at_raise: Reg.t array +(* Volatile registers: those that change value when read *) +val regs_are_volatile: Reg.t array -> bool + +(* Pure operations *) +val op_is_pure: Mach.operation -> bool + (* Info for laying out the stack frame *) val num_stack_slots: int array val contains_calls: bool ref diff --git a/asmcomp/reg.ml b/asmcomp/reg.ml index a0fc7dfff..064be4dbb 100644 --- a/asmcomp/reg.ml +++ b/asmcomp/reg.ml @@ -32,7 +32,7 @@ end type t = { mutable raw_name: Raw_name.t; stamp: int; - typ: Cmm.machtype_component; + mutable typ: Cmm.machtype_component; mutable loc: location; mutable spill: bool; mutable part: int option; @@ -73,13 +73,13 @@ let create ty = let createv tyv = let n = Array.length tyv in - let rv = Array.create n dummy in + let rv = Array.make n dummy in for i = 0 to n-1 do rv.(i) <- create tyv.(i) done; rv let createv_like rv = let n = Array.length rv in - let rv' = Array.create n dummy in + let rv' = Array.make n dummy in for i = 0 to n-1 do rv'.(i) <- create rv.(i).typ done; rv' @@ -178,6 +178,16 @@ let inter_set_array s v = else inter_all(i+1) in inter_all 0 +let disjoint_set_array s v = + match Array.length v with + 0 -> true + | 1 -> not (Set.mem v.(0) s) + | n -> let rec disjoint_all i = + if i >= n then true + else if Set.mem v.(i) s then false + else disjoint_all (i+1) + in disjoint_all 0 + let set_of_array v = match Array.length v with 0 -> Set.empty diff --git a/asmcomp/reg.mli b/asmcomp/reg.mli index 34e749801..f705c209e 100644 --- a/asmcomp/reg.mli +++ b/asmcomp/reg.mli @@ -20,7 +20,7 @@ end type t = { mutable raw_name: Raw_name.t; (* Name *) stamp: int; (* Unique stamp *) - typ: Cmm.machtype_component; (* Type of contents *) + mutable typ: Cmm.machtype_component;(* Type of contents *) mutable loc: location; (* Actual location *) mutable spill: bool; (* "true" to force stack allocation *) mutable part: int option; (* Zero-based index of part of value *) @@ -58,6 +58,7 @@ module Map: Map.S with type key = t val add_set_array: Set.t -> t array -> Set.t val diff_set_array: Set.t -> t array -> Set.t val inter_set_array: Set.t -> t array -> Set.t +val disjoint_set_array: Set.t -> t array -> bool val set_of_array: t array -> Set.t val reset: unit -> unit diff --git a/asmcomp/reloadgen.ml b/asmcomp/reloadgen.ml index a9c74bb1d..30f23a825 100644 --- a/asmcomp/reloadgen.ml +++ b/asmcomp/reloadgen.ml @@ -54,7 +54,7 @@ method makereg r = method private makeregs rv = let n = Array.length rv in - let newv = Array.create n Reg.dummy in + let newv = Array.make n Reg.dummy in for i = 0 to n-1 do newv.(i) <- self#makereg rv.(i) done; newv diff --git a/asmcomp/schedgen.ml b/asmcomp/schedgen.ml index e04eacd37..f7af44367 100644 --- a/asmcomp/schedgen.ml +++ b/asmcomp/schedgen.ml @@ -138,6 +138,8 @@ let some_load = (Iload(Cmm.Word, Arch.identity_addressing)) class virtual scheduler_generic = object (self) +val mutable trywith_nesting = 0 + (* Determine whether an operation ends a basic block or not. Can be overridden for some processors to signal specific instructions that terminate a basic block. *) @@ -154,9 +156,16 @@ method oper_in_basic_block = function (* Determine whether an instruction ends a basic block or not *) -method private instr_in_basic_block instr = +(* PR#2719: it is generally incorrect to schedule checkbound instructions + within a try ... with Invalid_argument _ -> ... + Hence, a checkbound instruction within a try...with block ends the + current basic block. *) + +method private instr_in_basic_block instr try_nesting = match instr.desc with - Lop op -> self#oper_in_basic_block op + Lop op -> + self#oper_in_basic_block op && + not (try_nesting > 0 && self#is_checkbound op) | Lreloadretaddr -> true | _ -> false @@ -165,7 +174,7 @@ method private instr_in_basic_block instr = load or store instructions (e.g. on the I386). *) method is_store = function - Istore(_, _) -> true + Istore(_, _, _) -> true | _ -> false method is_load = function @@ -345,19 +354,21 @@ method private reschedule ready_queue date cont = method schedule_fundecl f = - let rec schedule i = + let rec schedule i try_nesting = match i.desc with - Lend -> i + | Lend -> i + | Lpushtrap -> { i with next = schedule i.next (try_nesting + 1) } + | Lpoptrap -> { i with next = schedule i.next (try_nesting - 1) } | _ -> - if self#instr_in_basic_block i then begin + if self#instr_in_basic_block i try_nesting then begin clear_code_dag(); - schedule_block [] i + schedule_block [] i try_nesting end else - { i with next = schedule i.next } + { i with next = schedule i.next try_nesting } - and schedule_block ready_queue i = - if self#instr_in_basic_block i then - schedule_block (self#add_instruction ready_queue i) i.next + and schedule_block ready_queue i try_nesting = + if self#instr_in_basic_block i try_nesting then + schedule_block (self#add_instruction ready_queue i) i.next try_nesting else begin let critical_outputs = match i.desc with @@ -366,11 +377,11 @@ method schedule_fundecl f = | Lreturn -> [||] | _ -> i.arg in List.iter (fun x -> ignore (longest_path critical_outputs x)) ready_queue; - self#reschedule ready_queue 0 (schedule i) + self#reschedule ready_queue 0 (schedule i try_nesting) end in if f.fun_fast then begin - let new_body = schedule f.fun_body in + let new_body = schedule f.fun_body 0 in clear_code_dag(); { fun_name = f.fun_name; fun_body = new_body; @@ -380,3 +391,5 @@ method schedule_fundecl f = f end + +let reset () = clear_code_dag () diff --git a/asmcomp/schedgen.mli b/asmcomp/schedgen.mli index 6019d96f4..911330f8a 100644 --- a/asmcomp/schedgen.mli +++ b/asmcomp/schedgen.mli @@ -42,3 +42,5 @@ class virtual scheduler_generic : object (* Entry point *) method schedule_fundecl : Linearize.fundecl -> Linearize.fundecl end + +val reset : unit -> unit diff --git a/asmcomp/selectgen.ml b/asmcomp/selectgen.ml index 0f1277f75..86e16d38f 100644 --- a/asmcomp/selectgen.ml +++ b/asmcomp/selectgen.ml @@ -47,7 +47,8 @@ let oper_result_type = function let size_expr env exp = let rec size localenv = function - Cconst_int _ | Cconst_natint _ -> Arch.size_int + Cconst_int _ | Cconst_natint _ + | Cconst_blockheader _ -> Arch.size_int | Cconst_symbol _ | Cconst_pointer _ | Cconst_natpointer _ -> Arch.size_addr | Cconst_float _ -> Arch.size_float @@ -110,7 +111,7 @@ let join opt_r1 seq1 opt_r2 seq2 = | (Some r1, Some r2) -> let l1 = Array.length r1 in assert (l1 = Array.length r2); - let r = Array.create l1 Reg.dummy in + let r = Array.make l1 Reg.dummy in for i = 0 to l1-1 do if Reg.anonymous r1.(i) then begin r.(i) <- r1.(i); @@ -138,7 +139,7 @@ let join_array rs = None -> None | Some template -> let size_res = Array.length template in - let res = Array.create size_res Reg.dummy in + let res = Array.make size_res Reg.dummy in for i = 0 to size_res - 1 do res.(i) <- Reg.create template.(i).typ done; @@ -178,6 +179,7 @@ class virtual selector_generic = object (self) method is_simple_expr = function Cconst_int _ -> true | Cconst_natint _ -> true + | Cconst_blockheader _ -> true | Cconst_float _ -> true | Cconst_symbol _ -> true | Cconst_pointer _ -> true @@ -207,8 +209,39 @@ method virtual select_addressing : (* Default instruction selection for stores (of words) *) -method select_store addr arg = - (Istore(Word, addr), arg) +method select_store is_assign addr arg = + (Istore(Word, addr, is_assign), arg) + +(* call marking methods, documented in selectgen.mli *) + +method mark_call = + Proc.contains_calls := true + +method mark_tailcall = () + +method mark_c_tailcall = () + +method mark_instr = function + | Iop (Icall_ind | Icall_imm _ | Iextcall _) -> + self#mark_call + | Iop (Itailcall_ind | Itailcall_imm _) -> + self#mark_tailcall + | Iop (Ialloc _) -> + self#mark_call (* caml_alloc*, caml_garbage_collection *) + | Iop (Iintop Icheckbound | Iintop_imm(Icheckbound, _)) -> + self#mark_c_tailcall (* caml_ml_array_bound_error *) + | Iraise raise_kind -> + begin match raise_kind with + | Lambda.Raise_notrace -> () + | Lambda.Raise_regular | Lambda.Raise_reraise -> + if !Clflags.debug then (* PR#6239 *) + (* caml_stash_backtrace; we #mark_call rather than + #mark_c_tailcall to get a good stack backtrace *) + self#mark_call + end + | Itrywith _ -> + self#mark_call + | _ -> () (* Default instruction selection for operators *) @@ -223,10 +256,10 @@ method select_operation op args = | (Cstore chunk, [arg1; arg2]) -> let (addr, eloc) = self#select_addressing chunk arg1 in if chunk = Word then begin - let (op, newarg2) = self#select_store addr arg2 in + let (op, newarg2) = self#select_store true addr arg2 in (op, [newarg2; eloc]) end else begin - (Istore(chunk, addr), [arg2; eloc]) + (Istore(chunk, addr, true), [arg2; eloc]) (* Inversion addr/datum in Istore *) end | (Calloc, _) -> (Ialloc 0, args) @@ -360,6 +393,24 @@ method insert_moves src dst = self#insert_move src.(i) dst.(i) done +(* Adjust the types of destination pseudoregs for a [Cassign] assignment. + The type inferred at [let] binding might be [Int] while we assign + something of type [Addr] (PR#6501). *) + +method adjust_type src dst = + let ts = src.typ and td = dst.typ in + if ts <> td then + match ts, td with + | Addr, Int -> dst.typ <- Addr + | Int, Addr -> () + | _, _ -> fatal_error("Selection.adjust_type: bad assignment to " + ^ Reg.name dst) + +method adjust_types src dst = + for i = 0 to min (Array.length src) (Array.length dst) - 1 do + self#adjust_type src.(i) dst.(i) + done + (* Insert moves and stack offsets for function arguments and results *) method insert_move_args arg loc stacksize = @@ -426,7 +477,7 @@ method emit_expr env exp = fatal_error ("Selection.emit_expr: unbound var " ^ Ident.name v) in begin match self#emit_expr env e1 with None -> None - | Some r1 -> self#insert_moves r1 rv; Some [||] + | Some r1 -> self#adjust_types r1 rv; self#insert_moves r1 rv; Some [||] end | Ctuple [] -> Some [||] @@ -437,8 +488,6 @@ method emit_expr env exp = Some(self#emit_tuple ext_env simple_list) end | Cop(Craise (k, dbg), [arg]) -> - if !Clflags.debug && k <> Lambda.Raise_notrace then - Proc.contains_calls := true; (* PR#6239 *) begin match self#emit_expr env arg with None -> None | Some r1 -> @@ -458,7 +507,6 @@ method emit_expr env exp = let dbg = debuginfo_op op in match new_op with Icall_ind -> - Proc.contains_calls := true; let r1 = self#emit_tuple env new_args in let rarg = Array.sub r1 1 (Array.length r1 - 1) in let rd = self#regs_for ty in @@ -470,7 +518,6 @@ method emit_expr env exp = self#insert_move_results loc_res rd stack_ofs; Some rd | Icall_imm lbl -> - Proc.contains_calls := true; let r1 = self#emit_tuple env new_args in let rd = self#regs_for ty in let (loc_arg, stack_ofs) = Proc.loc_arguments r1 in @@ -480,7 +527,6 @@ method emit_expr env exp = self#insert_move_results loc_res rd stack_ofs; Some rd | Iextcall(lbl, alloc) -> - Proc.contains_calls := true; let (loc_arg, stack_ofs) = self#emit_extcall_args env new_args in let rd = self#regs_for ty in @@ -489,7 +535,6 @@ method emit_expr env exp = self#insert_move_results loc_res rd stack_ofs; Some rd | Ialloc _ -> - Proc.contains_calls := true; let rd = self#regs_for typ_addr in let size = size_expr env (Ctuple new_args) in self#insert (Iop(Ialloc size)) [||] rd; @@ -564,7 +609,6 @@ method emit_expr env exp = None end | Ctrywith(e1, v, e2) -> - Proc.contains_calls := true; let (r1, s1) = self#emit_sequence env e1 in let rv = self#regs_for typ_addr in let (r2, s2) = self#emit_sequence (Tbl.add v rv env) e2 in @@ -651,16 +695,16 @@ method emit_stores env data regs_addr = ref (Arch.offset_addressing Arch.identity_addressing (-Arch.size_int)) in List.iter (fun e -> - let (op, arg) = self#select_store !a e in + let (op, arg) = self#select_store false !a e in match self#emit_expr env arg with None -> assert false | Some regs -> match op with - Istore(_, _) -> + Istore(_, _, _) -> for i = 0 to Array.length regs - 1 do let r = regs.(i) in let kind = if r.typ = Float then Double_u else Word in - self#insert (Iop(Istore(kind, !a))) + self#insert (Iop(Istore(kind, !a, false))) (Array.append [|r|] regs_addr) [||]; a := Arch.offset_addressing !a (size_component r.typ) done @@ -701,7 +745,6 @@ method emit_tail env exp = self#insert (Iop Itailcall_ind) (Array.append [|r1.(0)|] loc_arg) [||] end else begin - Proc.contains_calls := true; let rd = self#regs_for ty in let loc_res = Proc.loc_results rd in self#insert_move_args rarg loc_arg stack_ofs; @@ -721,7 +764,6 @@ method emit_tail env exp = self#insert_moves r1 loc_arg'; self#insert (Iop(Itailcall_imm lbl)) loc_arg' [||] end else begin - Proc.contains_calls := true; let rd = self#regs_for ty in let loc_res = Proc.loc_results rd in self#insert_move_args r1 loc_arg stack_ofs; @@ -771,7 +813,6 @@ method emit_tail env exp = let s2 = self#emit_tail_sequence new_env e2 in self#insert (Icatch(nfail, s1, s2)) [||] [||] | Ctrywith(e1, v, e2) -> - Proc.contains_calls := true; let (opt_r1, s1) = self#emit_sequence env e1 in let rv = self#regs_for typ_addr in let s2 = self#emit_tail_sequence (Tbl.add v rv env) e2 in @@ -811,9 +852,11 @@ method emit_fundecl f = f.Cmm.fun_args rargs Tbl.empty in self#insert_moves loc_arg rarg; self#emit_tail env f.Cmm.fun_body; + let body = self#extract in + instr_iter (fun instr -> self#mark_instr instr.Mach.desc) body; { fun_name = f.Cmm.fun_name; fun_args = loc_arg; - fun_body = self#extract; + fun_body = body; fun_fast = f.Cmm.fun_fast; fun_dbg = f.Cmm.fun_dbg } @@ -832,3 +875,7 @@ let is_tail_call nargs = let _ = Simplif.is_tail_native_heuristic := is_tail_call + +let reset () = + catch_regs := []; + current_function_name := "" diff --git a/asmcomp/selectgen.mli b/asmcomp/selectgen.mli index 11af7c1ff..499b9ea0f 100644 --- a/asmcomp/selectgen.mli +++ b/asmcomp/selectgen.mli @@ -35,7 +35,8 @@ class virtual selector_generic : object method select_condition : Cmm.expression -> Mach.test * Cmm.expression (* Can be overridden to deal with special test instructions *) method select_store : - Arch.addressing_mode -> Cmm.expression -> Mach.operation * Cmm.expression + bool -> Arch.addressing_mode -> Cmm.expression -> + Mach.operation * Cmm.expression (* Can be overridden to deal with special store constant instructions *) method regs_for : Cmm.machtype -> Reg.t array (* Return an array of fresh registers of the given type. @@ -58,6 +59,30 @@ class virtual selector_generic : object (* Fill a freshly allocated block. Can be overridden for architectures that do not provide Arch.offset_addressing. *) + method mark_call : unit + (* informs the code emitter that the current function is non-leaf: + it may perform a (non-tail) call; by default, sets + [Proc.contains_calls := true] *) + + method mark_tailcall : unit + (* informs the code emitter that the current function may end with + a tail-call; by default, does nothing *) + + method mark_c_tailcall : unit + (* informs the code emitter that the current function may call + a C function that never returns; by default, does nothing. + + It is unecessary to save the stack pointer in this situation + (which is the main purpose of tracking leaf functions) but some + architectures still need to ensure that the stack is properly + aligned when the C function is called. This is achieved by + overloading this method to set [Proc.contains_calls := true] *) + + method mark_instr : Mach.instruction_desc -> unit + (* dispatches on instructions to call one of the marking function + above; overloading this is useful if Ispecific instructions need + marking *) + (* The following method is the entry point and should not be overridden *) method emit_fundecl : Cmm.fundecl -> Mach.fundecl @@ -72,7 +97,11 @@ class virtual selector_generic : object method insert_move_args : Reg.t array -> Reg.t array -> int -> unit method insert_move_results : Reg.t array -> Reg.t array -> int -> unit method insert_moves : Reg.t array -> Reg.t array -> unit + method adjust_type : Reg.t -> Reg.t -> unit + method adjust_types : Reg.t array -> Reg.t array -> unit method emit_expr : (Ident.t, Reg.t array) Tbl.t -> Cmm.expression -> Reg.t array option method emit_tail : (Ident.t, Reg.t array) Tbl.t -> Cmm.expression -> unit end + +val reset : unit -> unit diff --git a/asmcomp/sparc/CSE.ml b/asmcomp/sparc/CSE.ml new file mode 100644 index 000000000..e48d60436 --- /dev/null +++ b/asmcomp/sparc/CSE.ml @@ -0,0 +1,30 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2014 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* CSE for Sparc *) + +open Mach +open CSEgen + +class cse = object (self) + +inherit cse_generic (* as super *) + +method! is_cheap_operation op = + match op with + | Iconst_int n | Iconst_blockheader n -> n <= 4095n && n >= -4096n + | _ -> false + +end + +let fundecl f = + (new cse)#fundecl f diff --git a/asmcomp/sparc/emit.mlp b/asmcomp/sparc/emit.mlp index 12d60ed32..877a3d52a 100644 --- a/asmcomp/sparc/emit.mlp +++ b/asmcomp/sparc/emit.mlp @@ -190,7 +190,7 @@ let emit_frame fd = (* Record floating-point constants *) -let float_constants = ref ([] : (int * string) list) +let float_constants = ref ([] : (int * int64) list) let emit_float_constant (lbl, cst) = rodata (); @@ -309,11 +309,11 @@ let rec emit_instr i dslot = ` sethi %hi({emit_nativeint n}), %g1\n`; ` or %g1, %lo({emit_nativeint n}), {emit_reg i.res.(0)}\n` end - | Lop(Iconst_float s) -> + | Lop(Iconst_float f) -> (* On UltraSPARC, the fzero instruction could be used to set a floating point register pair to zero. *) let lbl = new_label() in - float_constants := (lbl, s) :: !float_constants; + float_constants := (lbl, Int64.bits_of_float f) :: !float_constants; ` sethi %hi({emit_label lbl}), %g1\n`; ` ldd [%g1 + %lo({emit_label lbl})], {emit_reg i.res.(0)}\n` | Lop(Iconst_symbol s) -> @@ -375,7 +375,7 @@ let rec emit_instr i dslot = | _ -> "ld" in emit_load loadinstr addr i.arg dest end - | Lop(Istore(chunk, addr)) -> + | Lop(Istore(chunk, addr, _)) -> let src = i.arg.(0) in begin match chunk with Double_u -> @@ -612,7 +612,7 @@ let is_one_instr i = | Iconst_int n | Iconst_blockheader n -> is_native_immediate n | Istackoffset _ -> true | Iload(_, Iindexed n) -> i.res.(0).typ <> Float && is_immediate n - | Istore(_, Iindexed n) -> i.arg.(0).typ <> Float && is_immediate n + | Istore(_, Iindexed n, _) -> i.arg.(0).typ <> Float && is_immediate n | Iintop(op) -> is_one_instr_op op | Iintop_imm(op, _) -> is_one_instr_op op | Iaddf | Isubf | Imulf | Idivf -> true @@ -706,9 +706,9 @@ let emit_item = function | Cint n -> ` .word {emit_nativeint n}\n` | Csingle f -> - emit_float32_directive ".word" f + emit_float32_directive ".word" (Int32.bits_of_float f) | Cdouble f -> - emit_float64_split_directive ".word" f + emit_float64_split_directive ".word" (Int64.bits_of_float f) | Csymbol_address s -> ` .word {emit_symbol s}\n` | Clabel_address lbl -> diff --git a/asmcomp/sparc/proc.ml b/asmcomp/sparc/proc.ml index ed107a82a..625f517f6 100644 --- a/asmcomp/sparc/proc.ml +++ b/asmcomp/sparc/proc.ml @@ -81,12 +81,12 @@ let rotate_registers = true (* Representation of hard registers by pseudo-registers *) let hard_int_reg = - let v = Array.create 19 Reg.dummy in + let v = Array.make 19 Reg.dummy in for i = 0 to 18 do v.(i) <- Reg.at_location Int (Reg i) done; v let hard_float_reg = - let v = Array.create 32 Reg.dummy in + let v = Array.make 32 Reg.dummy in for i = 0 to 31 do v.(i) <- Reg.at_location Float (Reg(100 + i)) done; v @@ -105,7 +105,7 @@ let stack_slot slot ty = let calling_conventions first_int last_int first_float last_float make_stack arg = - let loc = Array.create (Array.length arg) Reg.dummy in + let loc = Array.make (Array.length arg) Reg.dummy in let int = ref first_int in let float = ref first_float in let ofs = ref 0 in @@ -171,6 +171,10 @@ let loc_external_results res = let loc_exn_bucket = phys_reg 0 (* $o0 *) +(* Volatile registers: none *) + +let regs_are_volatile rs = false + (* Registers destroyed by operations *) let destroyed_at_c_call = (* %l0-%l4, %i0-%i5 preserved *) @@ -196,6 +200,15 @@ let max_register_pressure = function Iextcall(_, _) -> [| 11; 0 |] | _ -> [| 19; 15 |] +(* Pure operations (without any side effect besides updating their result + registers). *) + +let op_is_pure = function + | Icall_ind | Icall_imm _ | Itailcall_ind | Itailcall_imm _ + | Iextcall _ | Istackoffset _ | Istore _ | Ialloc _ + | Iintop(Icheckbound) | Iintop_imm(Icheckbound, _) -> false + | _ -> true + (* Layout of the stack *) let num_stack_slots = [| 0; 0 |] diff --git a/asmcomp/spill.ml b/asmcomp/spill.ml index ca17fe5bf..105550d05 100644 --- a/asmcomp/spill.ml +++ b/asmcomp/spill.ml @@ -64,7 +64,7 @@ let add_superpressure_regs op live_regs res_regs spilled = let max_pressure = Proc.max_register_pressure op in let regs = Reg.add_set_array live_regs res_regs in (* Compute the pressure in each register class *) - let pressure = Array.create Proc.num_register_classes 0 in + let pressure = Array.make Proc.num_register_classes 0 in Reg.Set.iter (fun r -> if Reg.Set.mem r spilled then () else begin @@ -233,7 +233,12 @@ let rec reload i before = (i, Reg.Set.empty) | Itrywith(body, handler) -> let (new_body, after_body) = reload body before in - let (new_handler, after_handler) = reload handler handler.live in + (* All registers live at the beginning of the handler are destroyed, + except the exception bucket *) + let before_handler = + Reg.Set.remove Proc.loc_exn_bucket + (Reg.add_set_array handler.live handler.arg) in + let (new_handler, after_handler) = reload handler before_handler in let (new_next, finally) = reload i.next (Reg.Set.union after_body after_handler) in (instr_cons (Itrywith(new_body, new_handler)) i.arg i.res new_next, @@ -384,10 +389,14 @@ let rec spill i finally = (* Entry point *) -let fundecl f = +let reset () = spill_env := Reg.Map.empty; use_date := Reg.Map.empty; - current_date := 0; + current_date := 0 + +let fundecl f = + reset (); + let (body1, _) = reload f.fun_body Reg.Set.empty in let (body2, tospill_at_entry) = spill body1 Reg.Set.empty in let new_body = diff --git a/asmcomp/spill.mli b/asmcomp/spill.mli index 66954aef5..598a17552 100644 --- a/asmcomp/spill.mli +++ b/asmcomp/spill.mli @@ -14,3 +14,4 @@ before register allocation. *) val fundecl: Mach.fundecl -> Mach.fundecl +val reset : unit -> unit diff --git a/asmcomp/split.ml b/asmcomp/split.ml index 9e076e648..8c553ab9e 100644 --- a/asmcomp/split.ml +++ b/asmcomp/split.ml @@ -30,7 +30,7 @@ let subst_regs rv sub = None -> rv | Some s -> let n = Array.length rv in - let nv = Array.create n Reg.dummy in + let nv = Array.make n Reg.dummy in for i = 0 to n-1 do nv.(i) <- subst_reg rv.(i) s done; nv @@ -195,8 +195,13 @@ let set_repres i = (* Entry point *) -let fundecl f = +let reset () = equiv_classes := Reg.Map.empty; + exit_subst := [] + +let fundecl f = + reset (); + let new_args = Array.copy f.fun_args in let (new_body, sub_body) = rename f.fun_body (Some Reg.Map.empty) in repres_regs new_args; diff --git a/asmcomp/split.mli b/asmcomp/split.mli index f794fec16..1924a5ad6 100644 --- a/asmcomp/split.mli +++ b/asmcomp/split.mli @@ -13,3 +13,5 @@ (* Renaming of registers at reload points to split live ranges. *) val fundecl: Mach.fundecl -> Mach.fundecl + +val reset : unit -> unit diff --git a/asmcomp/strmatch.ml b/asmcomp/strmatch.ml index 760540d8a..d63e92bf0 100644 --- a/asmcomp/strmatch.ml +++ b/asmcomp/strmatch.ml @@ -45,7 +45,7 @@ module Make(I:I) = struct if Arch.big_endian then ds else List.rev ds in String.concat "" ds - let do_pp_cases chan cases = + let do_pp_cases chan cases = List.iter (fun (ps,_) -> Printf.fprintf chan " [%s]\n" @@ -168,7 +168,7 @@ module Make(I:I) = struct (fun set (ps,_) -> IntSet.add (List.length ps) set) IntSet.empty cases in IntSet.cardinal set - + let best_col = let rec do_rec kbest best k = function | [] -> kbest @@ -225,7 +225,6 @@ module Make(I:I) = struct try OMap.find key env with Not_found -> assert false - let divide cases = let env = List.fold_left @@ -290,7 +289,6 @@ module Make(I:I) = struct let lt,midkey,ge = split_env len env in mk_lt id midkey (comp_rec lt) (comp_rec ge) in mk_let_cell id str idx (comp_rec env) - (* Recursive 'list of cells' compile function: @@ -319,7 +317,7 @@ module Make(I:I) = struct (* Group by size *) - + module DivideInt = Divide(IntArg) @@ -353,8 +351,8 @@ module Make(I:I) = struct (* Compilation entry point: we choose to switch either on size or on first cell, using the - 'least discriminant' heuristics. - *) + 'least discriminant' heuristics. + *) let top_compile str default cases = let a_len = count_arities_length cases and a_fst = count_arities_first cases in @@ -377,6 +375,11 @@ module Make(I:I) = struct Ccatch (e,[],k (Cexit (e,[])),arg) let compile str default cases = +(* We do not attempt to really optimise default=None *) + let cases,default = match cases,default with + | (_,e)::cases,None + | cases,Some e -> cases,e + | [],None -> assert false in let cases = List.rev_map (fun (s,act) -> pat_of_string s,act) diff --git a/asmcomp/strmatch.mli b/asmcomp/strmatch.mli index 9be2b6945..143dae5cb 100644 --- a/asmcomp/strmatch.mli +++ b/asmcomp/strmatch.mli @@ -23,6 +23,6 @@ end module Make(I:I) : sig (* Compile stringswitch (arg,cases,d) Note: cases should not contain string duplicates *) - val compile : Cmm.expression (* arg *) -> Cmm.expression (* d *) -> + val compile : Cmm.expression (* arg *) -> Cmm.expression option (* d *) -> (string * Cmm.expression) list (* cases *)-> Cmm.expression end diff --git a/asmrun/.depend b/asmrun/.depend index bec9f0c07..1088ad8ed 100644 --- a/asmrun/.depend +++ b/asmrun/.depend @@ -1,756 +1,753 @@ alloc.o: alloc.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/custom.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/stacks.h \ - ../byterun/memory.h + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ + ../byterun/custom.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ + ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/stacks.h \ + ../byterun/memory.h array.o: array.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ + ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ + ../byterun/misc.h ../byterun/mlvalues.h backtrace.o: backtrace.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/backtrace.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/misc.h ../byterun/mlvalues.h stack.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/mlvalues.h ../byterun/backtrace.h ../byterun/memory.h \ + ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/minor_gc.h ../byterun/misc.h ../byterun/mlvalues.h stack.h callback.o: callback.c ../byterun/callback.h ../byterun/mlvalues.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/misc.h ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/mlvalues.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/misc.h ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ + ../byterun/mlvalues.h compact.o: compact.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/finalise.h ../byterun/roots.h \ - ../byterun/misc.h ../byterun/config.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/mlvalues.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/freelist.h \ - ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/major_gc.h \ - ../byterun/memory.h ../byterun/mlvalues.h ../byterun/roots.h \ - ../byterun/weak.h + ../byterun/../config/s.h ../byterun/finalise.h ../byterun/roots.h \ + ../byterun/misc.h ../byterun/config.h ../byterun/memory.h \ + ../byterun/gc.h ../byterun/mlvalues.h ../byterun/major_gc.h \ + ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/freelist.h \ + ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/major_gc.h \ + ../byterun/memory.h ../byterun/mlvalues.h ../byterun/roots.h \ + ../byterun/weak.h compare.o: compare.c ../byterun/custom.h ../byterun/mlvalues.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/misc.h ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/misc.h ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ + ../byterun/misc.h ../byterun/mlvalues.h custom.o: custom.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/custom.h ../byterun/fail.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/mlvalues.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/mlvalues.h ../byterun/custom.h ../byterun/fail.h \ + ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ + ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/mlvalues.h debugger.o: debugger.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/config.h ../byterun/debugger.h \ - ../byterun/misc.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/mlvalues.h ../byterun/config.h ../byterun/debugger.h \ + ../byterun/misc.h dynlink.o: dynlink.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/mlvalues.h ../byterun/dynlink.h \ - ../byterun/fail.h ../byterun/mlvalues.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/misc.h ../byterun/osdeps.h \ - ../byterun/prims.h + ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ + ../byterun/config.h ../byterun/mlvalues.h ../byterun/dynlink.h \ + ../byterun/fail.h ../byterun/mlvalues.h ../byterun/memory.h \ + ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/minor_gc.h ../byterun/misc.h ../byterun/osdeps.h \ + ../byterun/prims.h extern.o: extern.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/custom.h ../byterun/fail.h \ - ../byterun/gc.h ../byterun/intext.h ../byterun/io.h ../byterun/io.h \ - ../byterun/md5.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h ../byterun/reverse.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/mlvalues.h ../byterun/custom.h ../byterun/fail.h \ + ../byterun/gc.h ../byterun/intext.h ../byterun/io.h ../byterun/io.h \ + ../byterun/md5.h ../byterun/memory.h ../byterun/gc.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/reverse.h fail.o: fail.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/io.h ../byterun/gc.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/printexc.h \ - ../byterun/signals.h stack.h ../byterun/roots.h ../byterun/memory.h \ - ../byterun/callback.h + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ + ../byterun/fail.h ../byterun/io.h ../byterun/gc.h ../byterun/memory.h \ + ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/printexc.h \ + ../byterun/signals.h stack.h ../byterun/roots.h ../byterun/memory.h \ + ../byterun/callback.h finalise.o: finalise.c ../byterun/callback.h ../byterun/mlvalues.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/misc.h ../byterun/fail.h ../byterun/mlvalues.h \ - ../byterun/roots.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/signals.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/misc.h ../byterun/fail.h ../byterun/mlvalues.h \ + ../byterun/roots.h ../byterun/memory.h ../byterun/gc.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ + ../byterun/signals.h floats.o: floats.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/fail.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/misc.h \ - ../byterun/reverse.h ../byterun/stacks.h ../byterun/memory.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/mlvalues.h ../byterun/fail.h ../byterun/memory.h \ + ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/misc.h \ + ../byterun/reverse.h ../byterun/stacks.h ../byterun/memory.h freelist.o: freelist.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/freelist.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/mlvalues.h ../byterun/gc.h \ - ../byterun/gc_ctrl.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/major_gc.h ../byterun/misc.h ../byterun/mlvalues.h + ../byterun/../config/s.h ../byterun/freelist.h ../byterun/misc.h \ + ../byterun/config.h ../byterun/mlvalues.h ../byterun/gc.h \ + ../byterun/gc_ctrl.h ../byterun/memory.h ../byterun/gc.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ + ../byterun/major_gc.h ../byterun/misc.h ../byterun/mlvalues.h gc_ctrl.o: gc_ctrl.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/compact.h ../byterun/custom.h \ - ../byterun/finalise.h ../byterun/roots.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/freelist.h ../byterun/gc.h \ - ../byterun/gc_ctrl.h ../byterun/major_gc.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h stack.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/mlvalues.h ../byterun/compact.h ../byterun/custom.h \ + ../byterun/finalise.h ../byterun/roots.h ../byterun/memory.h \ + ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/minor_gc.h ../byterun/freelist.h ../byterun/gc.h \ + ../byterun/gc_ctrl.h ../byterun/major_gc.h ../byterun/minor_gc.h \ + ../byterun/misc.h ../byterun/mlvalues.h stack.h globroots.o: globroots.c ../byterun/memory.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/gc.h \ - ../byterun/mlvalues.h ../byterun/misc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/misc.h \ - ../byterun/mlvalues.h ../byterun/roots.h ../byterun/memory.h \ - ../byterun/globroots.h ../byterun/roots.h + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/gc.h \ + ../byterun/mlvalues.h ../byterun/misc.h ../byterun/major_gc.h \ + ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/roots.h ../byterun/memory.h \ + ../byterun/globroots.h ../byterun/roots.h hash.o: hash.c ../byterun/mlvalues.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/misc.h \ - ../byterun/custom.h ../byterun/mlvalues.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/hash.h ../byterun/int64_native.h + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/misc.h \ + ../byterun/custom.h ../byterun/mlvalues.h ../byterun/memory.h \ + ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/minor_gc.h ../byterun/hash.h intern.o: intern.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/callback.h ../byterun/custom.h \ - ../byterun/fail.h ../byterun/gc.h ../byterun/intext.h ../byterun/io.h \ - ../byterun/io.h ../byterun/md5.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/mlvalues.h ../byterun/misc.h ../byterun/reverse.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/mlvalues.h ../byterun/callback.h ../byterun/custom.h \ + ../byterun/fail.h ../byterun/gc.h ../byterun/intext.h ../byterun/io.h \ + ../byterun/io.h ../byterun/md5.h ../byterun/memory.h ../byterun/gc.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ + ../byterun/mlvalues.h ../byterun/misc.h ../byterun/reverse.h ints.o: ints.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/custom.h ../byterun/fail.h ../byterun/intext.h \ - ../byterun/io.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h ../byterun/int64_native.h + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ + ../byterun/custom.h ../byterun/fail.h ../byterun/intext.h \ + ../byterun/io.h ../byterun/memory.h ../byterun/gc.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ + ../byterun/misc.h ../byterun/mlvalues.h io.o: io.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/mlvalues.h ../byterun/custom.h \ - ../byterun/fail.h ../byterun/io.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h ../byterun/signals.h \ - ../byterun/sys.h + ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ + ../byterun/config.h ../byterun/mlvalues.h ../byterun/custom.h \ + ../byterun/fail.h ../byterun/io.h ../byterun/memory.h ../byterun/gc.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/signals.h \ + ../byterun/sys.h lexing.o: lexing.c ../byterun/fail.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/mlvalues.h ../byterun/stacks.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/mlvalues.h ../byterun/mlvalues.h ../byterun/stacks.h \ + ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ + ../byterun/freelist.h ../byterun/minor_gc.h main.o: main.c ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/misc.h ../byterun/sys.h + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ + ../byterun/misc.h ../byterun/sys.h major_gc.o: major_gc.c ../byterun/compact.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/misc.h \ - ../byterun/custom.h ../byterun/mlvalues.h ../byterun/config.h \ - ../byterun/fail.h ../byterun/finalise.h ../byterun/roots.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/freelist.h \ - ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/major_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h ../byterun/roots.h \ - ../byterun/weak.h + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/misc.h \ + ../byterun/custom.h ../byterun/mlvalues.h ../byterun/config.h \ + ../byterun/fail.h ../byterun/finalise.h ../byterun/roots.h \ + ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ + ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/freelist.h \ + ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/major_gc.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/roots.h \ + ../byterun/weak.h md5.o: md5.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/md5.h ../byterun/io.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/io.h \ - ../byterun/reverse.h + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ + ../byterun/fail.h ../byterun/md5.h ../byterun/io.h ../byterun/memory.h \ + ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/io.h \ + ../byterun/reverse.h memory.o: memory.c ../byterun/fail.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/freelist.h ../byterun/gc.h \ - ../byterun/gc_ctrl.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/minor_gc.h ../byterun/minor_gc.h ../byterun/misc.h \ - ../byterun/mlvalues.h ../byterun/signals.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/mlvalues.h ../byterun/freelist.h ../byterun/gc.h \ + ../byterun/gc_ctrl.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ + ../byterun/minor_gc.h ../byterun/minor_gc.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/signals.h meta.o: meta.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/config.h ../byterun/fail.h ../byterun/fix_code.h \ - ../byterun/interp.h ../byterun/intext.h ../byterun/io.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/minor_gc.h \ - ../byterun/minor_gc.h ../byterun/misc.h ../byterun/mlvalues.h \ - ../byterun/prims.h ../byterun/stacks.h ../byterun/memory.h + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ + ../byterun/config.h ../byterun/fail.h ../byterun/fix_code.h \ + ../byterun/interp.h ../byterun/intext.h ../byterun/io.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/memory.h \ + ../byterun/gc.h ../byterun/major_gc.h ../byterun/minor_gc.h \ + ../byterun/minor_gc.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/prims.h ../byterun/stacks.h ../byterun/memory.h minor_gc.o: minor_gc.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/fail.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/mlvalues.h ../byterun/finalise.h \ - ../byterun/roots.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/major_gc.h \ - ../byterun/memory.h ../byterun/minor_gc.h ../byterun/misc.h \ - ../byterun/mlvalues.h ../byterun/roots.h ../byterun/signals.h \ - ../byterun/weak.h + ../byterun/../config/s.h ../byterun/fail.h ../byterun/misc.h \ + ../byterun/config.h ../byterun/mlvalues.h ../byterun/finalise.h \ + ../byterun/roots.h ../byterun/memory.h ../byterun/gc.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ + ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/major_gc.h \ + ../byterun/memory.h ../byterun/minor_gc.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/roots.h ../byterun/signals.h \ + ../byterun/weak.h misc.o: misc.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/mlvalues.h \ - ../byterun/misc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h + ../byterun/../config/s.h ../byterun/misc.h ../byterun/config.h \ + ../byterun/memory.h ../byterun/gc.h ../byterun/mlvalues.h \ + ../byterun/misc.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/minor_gc.h natdynlink.o: natdynlink.c ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/misc.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h stack.h ../byterun/callback.h ../byterun/alloc.h \ - ../byterun/intext.h ../byterun/io.h ../byterun/osdeps.h \ - ../byterun/fail.h + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ + ../byterun/misc.h ../byterun/memory.h ../byterun/gc.h \ + ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/minor_gc.h stack.h ../byterun/callback.h ../byterun/alloc.h \ + ../byterun/intext.h ../byterun/io.h ../byterun/osdeps.h \ + ../byterun/fail.h obj.o: obj.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/gc.h ../byterun/interp.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/minor_gc.h \ - ../byterun/minor_gc.h ../byterun/misc.h ../byterun/mlvalues.h \ - ../byterun/prims.h + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ + ../byterun/fail.h ../byterun/gc.h ../byterun/interp.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/memory.h \ + ../byterun/gc.h ../byterun/major_gc.h ../byterun/minor_gc.h \ + ../byterun/minor_gc.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/prims.h parsing.o: parsing.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/mlvalues.h ../byterun/config.h \ - ../byterun/misc.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/alloc.h + ../byterun/../config/s.h ../byterun/mlvalues.h ../byterun/config.h \ + ../byterun/misc.h ../byterun/memory.h ../byterun/gc.h \ + ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/minor_gc.h ../byterun/alloc.h printexc.o: printexc.c ../byterun/backtrace.h ../byterun/mlvalues.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/misc.h ../byterun/callback.h ../byterun/debugger.h \ - ../byterun/fail.h ../byterun/misc.h ../byterun/mlvalues.h \ - ../byterun/printexc.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/misc.h ../byterun/callback.h ../byterun/debugger.h \ + ../byterun/fail.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/printexc.h roots.o: roots.c ../byterun/finalise.h ../byterun/roots.h \ - ../byterun/misc.h ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/globroots.h ../byterun/memory.h \ - ../byterun/major_gc.h ../byterun/minor_gc.h ../byterun/misc.h \ - ../byterun/mlvalues.h stack.h ../byterun/roots.h + ../byterun/misc.h ../byterun/config.h ../byterun/../config/m.h \ + ../byterun/../config/s.h ../byterun/memory.h ../byterun/gc.h \ + ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/minor_gc.h ../byterun/globroots.h ../byterun/memory.h \ + ../byterun/major_gc.h ../byterun/minor_gc.h ../byterun/misc.h \ + ../byterun/mlvalues.h stack.h ../byterun/roots.h signals.o: signals.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/callback.h ../byterun/config.h \ - ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h ../byterun/roots.h \ - ../byterun/memory.h ../byterun/signals.h ../byterun/signals_machdep.h \ - ../byterun/sys.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/mlvalues.h ../byterun/callback.h ../byterun/config.h \ + ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/roots.h \ + ../byterun/memory.h ../byterun/signals.h ../byterun/signals_machdep.h \ + ../byterun/sys.h signals_asm.o: signals_asm.c ../byterun/fail.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/osdeps.h ../byterun/signals.h ../byterun/signals_machdep.h \ - signals_osdep.h stack.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/mlvalues.h ../byterun/memory.h ../byterun/gc.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ + ../byterun/osdeps.h ../byterun/signals.h ../byterun/signals_machdep.h \ + signals_osdep.h stack.h startup.o: startup.c ../byterun/callback.h ../byterun/mlvalues.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/misc.h ../byterun/backtrace.h ../byterun/custom.h \ - ../byterun/debugger.h ../byterun/fail.h ../byterun/freelist.h \ - ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/intext.h ../byterun/io.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/misc.h \ - ../byterun/mlvalues.h ../byterun/osdeps.h ../byterun/printexc.h stack.h \ - ../byterun/sys.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/misc.h ../byterun/backtrace.h ../byterun/custom.h \ + ../byterun/debugger.h ../byterun/fail.h ../byterun/freelist.h \ + ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/intext.h \ + ../byterun/io.h ../byterun/memory.h ../byterun/gc.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/osdeps.h \ + ../byterun/printexc.h stack.h ../byterun/sys.h str.o: str.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/mlvalues.h ../byterun/misc.h \ - ../byterun/int64_native.h + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ + ../byterun/fail.h ../byterun/mlvalues.h ../byterun/misc.h sys.o: sys.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/mlvalues.h ../byterun/debugger.h \ - ../byterun/fail.h ../byterun/instruct.h ../byterun/mlvalues.h \ - ../byterun/osdeps.h ../byterun/signals.h ../byterun/stacks.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/sys.h + ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ + ../byterun/config.h ../byterun/mlvalues.h ../byterun/debugger.h \ + ../byterun/fail.h ../byterun/instruct.h ../byterun/mlvalues.h \ + ../byterun/osdeps.h ../byterun/signals.h ../byterun/stacks.h \ + ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ + ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/sys.h terminfo.o: terminfo.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/mlvalues.h ../byterun/fail.h \ - ../byterun/io.h ../byterun/mlvalues.h + ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ + ../byterun/config.h ../byterun/mlvalues.h ../byterun/fail.h \ + ../byterun/io.h ../byterun/mlvalues.h unix.o: unix.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/memory.h ../byterun/config.h \ - ../byterun/gc.h ../byterun/mlvalues.h ../byterun/misc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/osdeps.h + ../byterun/../config/s.h ../byterun/memory.h ../byterun/config.h \ + ../byterun/gc.h ../byterun/mlvalues.h ../byterun/misc.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ + ../byterun/misc.h ../byterun/osdeps.h weak.o: weak.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/minor_gc.h ../byterun/mlvalues.h + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ + ../byterun/fail.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ + ../byterun/minor_gc.h ../byterun/mlvalues.h alloc.d.o: alloc.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/custom.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/stacks.h \ - ../byterun/memory.h + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ + ../byterun/custom.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ + ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/stacks.h \ + ../byterun/memory.h array.d.o: array.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ + ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ + ../byterun/misc.h ../byterun/mlvalues.h backtrace.d.o: backtrace.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/backtrace.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/misc.h ../byterun/mlvalues.h stack.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/mlvalues.h ../byterun/backtrace.h ../byterun/memory.h \ + ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/minor_gc.h ../byterun/misc.h ../byterun/mlvalues.h stack.h callback.d.o: callback.c ../byterun/callback.h ../byterun/mlvalues.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/misc.h ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/mlvalues.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/misc.h ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ + ../byterun/mlvalues.h compact.d.o: compact.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/finalise.h ../byterun/roots.h \ - ../byterun/misc.h ../byterun/config.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/mlvalues.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/freelist.h \ - ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/major_gc.h \ - ../byterun/memory.h ../byterun/mlvalues.h ../byterun/roots.h \ - ../byterun/weak.h + ../byterun/../config/s.h ../byterun/finalise.h ../byterun/roots.h \ + ../byterun/misc.h ../byterun/config.h ../byterun/memory.h \ + ../byterun/gc.h ../byterun/mlvalues.h ../byterun/major_gc.h \ + ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/freelist.h \ + ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/major_gc.h \ + ../byterun/memory.h ../byterun/mlvalues.h ../byterun/roots.h \ + ../byterun/weak.h compare.d.o: compare.c ../byterun/custom.h ../byterun/mlvalues.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/misc.h ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/misc.h ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ + ../byterun/misc.h ../byterun/mlvalues.h custom.d.o: custom.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/custom.h ../byterun/fail.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/mlvalues.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/mlvalues.h ../byterun/custom.h ../byterun/fail.h \ + ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ + ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/mlvalues.h debugger.d.o: debugger.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/config.h ../byterun/debugger.h \ - ../byterun/misc.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/mlvalues.h ../byterun/config.h ../byterun/debugger.h \ + ../byterun/misc.h dynlink.d.o: dynlink.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/mlvalues.h ../byterun/dynlink.h \ - ../byterun/fail.h ../byterun/mlvalues.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/misc.h ../byterun/osdeps.h \ - ../byterun/prims.h + ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ + ../byterun/config.h ../byterun/mlvalues.h ../byterun/dynlink.h \ + ../byterun/fail.h ../byterun/mlvalues.h ../byterun/memory.h \ + ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/minor_gc.h ../byterun/misc.h ../byterun/osdeps.h \ + ../byterun/prims.h extern.d.o: extern.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/custom.h ../byterun/fail.h \ - ../byterun/gc.h ../byterun/intext.h ../byterun/io.h ../byterun/io.h \ - ../byterun/md5.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h ../byterun/reverse.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/mlvalues.h ../byterun/custom.h ../byterun/fail.h \ + ../byterun/gc.h ../byterun/intext.h ../byterun/io.h ../byterun/io.h \ + ../byterun/md5.h ../byterun/memory.h ../byterun/gc.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/reverse.h fail.d.o: fail.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/io.h ../byterun/gc.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/printexc.h \ - ../byterun/signals.h stack.h ../byterun/roots.h ../byterun/memory.h \ - ../byterun/callback.h + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ + ../byterun/fail.h ../byterun/io.h ../byterun/gc.h ../byterun/memory.h \ + ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/printexc.h \ + ../byterun/signals.h stack.h ../byterun/roots.h ../byterun/memory.h \ + ../byterun/callback.h finalise.d.o: finalise.c ../byterun/callback.h ../byterun/mlvalues.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/misc.h ../byterun/fail.h ../byterun/mlvalues.h \ - ../byterun/roots.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/signals.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/misc.h ../byterun/fail.h ../byterun/mlvalues.h \ + ../byterun/roots.h ../byterun/memory.h ../byterun/gc.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ + ../byterun/signals.h floats.d.o: floats.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/fail.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/misc.h \ - ../byterun/reverse.h ../byterun/stacks.h ../byterun/memory.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/mlvalues.h ../byterun/fail.h ../byterun/memory.h \ + ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/misc.h \ + ../byterun/reverse.h ../byterun/stacks.h ../byterun/memory.h freelist.d.o: freelist.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/freelist.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/mlvalues.h ../byterun/gc.h \ - ../byterun/gc_ctrl.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/major_gc.h ../byterun/misc.h ../byterun/mlvalues.h + ../byterun/../config/s.h ../byterun/freelist.h ../byterun/misc.h \ + ../byterun/config.h ../byterun/mlvalues.h ../byterun/gc.h \ + ../byterun/gc_ctrl.h ../byterun/memory.h ../byterun/gc.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ + ../byterun/major_gc.h ../byterun/misc.h ../byterun/mlvalues.h gc_ctrl.d.o: gc_ctrl.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/compact.h ../byterun/custom.h \ - ../byterun/finalise.h ../byterun/roots.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/freelist.h ../byterun/gc.h \ - ../byterun/gc_ctrl.h ../byterun/major_gc.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h stack.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/mlvalues.h ../byterun/compact.h ../byterun/custom.h \ + ../byterun/finalise.h ../byterun/roots.h ../byterun/memory.h \ + ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/minor_gc.h ../byterun/freelist.h ../byterun/gc.h \ + ../byterun/gc_ctrl.h ../byterun/major_gc.h ../byterun/minor_gc.h \ + ../byterun/misc.h ../byterun/mlvalues.h stack.h globroots.d.o: globroots.c ../byterun/memory.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/gc.h \ - ../byterun/mlvalues.h ../byterun/misc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/misc.h \ - ../byterun/mlvalues.h ../byterun/roots.h ../byterun/memory.h \ - ../byterun/globroots.h ../byterun/roots.h + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/gc.h \ + ../byterun/mlvalues.h ../byterun/misc.h ../byterun/major_gc.h \ + ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/roots.h ../byterun/memory.h \ + ../byterun/globroots.h ../byterun/roots.h hash.d.o: hash.c ../byterun/mlvalues.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/misc.h \ - ../byterun/custom.h ../byterun/mlvalues.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/hash.h ../byterun/int64_native.h + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/misc.h \ + ../byterun/custom.h ../byterun/mlvalues.h ../byterun/memory.h \ + ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/minor_gc.h ../byterun/hash.h intern.d.o: intern.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/callback.h ../byterun/custom.h \ - ../byterun/fail.h ../byterun/gc.h ../byterun/intext.h ../byterun/io.h \ - ../byterun/io.h ../byterun/md5.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/mlvalues.h ../byterun/misc.h ../byterun/reverse.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/mlvalues.h ../byterun/callback.h ../byterun/custom.h \ + ../byterun/fail.h ../byterun/gc.h ../byterun/intext.h ../byterun/io.h \ + ../byterun/io.h ../byterun/md5.h ../byterun/memory.h ../byterun/gc.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ + ../byterun/mlvalues.h ../byterun/misc.h ../byterun/reverse.h ints.d.o: ints.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/custom.h ../byterun/fail.h ../byterun/intext.h \ - ../byterun/io.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h ../byterun/int64_native.h + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ + ../byterun/custom.h ../byterun/fail.h ../byterun/intext.h \ + ../byterun/io.h ../byterun/memory.h ../byterun/gc.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ + ../byterun/misc.h ../byterun/mlvalues.h io.d.o: io.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/mlvalues.h ../byterun/custom.h \ - ../byterun/fail.h ../byterun/io.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h ../byterun/signals.h \ - ../byterun/sys.h + ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ + ../byterun/config.h ../byterun/mlvalues.h ../byterun/custom.h \ + ../byterun/fail.h ../byterun/io.h ../byterun/memory.h ../byterun/gc.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/signals.h \ + ../byterun/sys.h lexing.d.o: lexing.c ../byterun/fail.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/mlvalues.h ../byterun/stacks.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/mlvalues.h ../byterun/mlvalues.h ../byterun/stacks.h \ + ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ + ../byterun/freelist.h ../byterun/minor_gc.h main.d.o: main.c ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/misc.h ../byterun/sys.h + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ + ../byterun/misc.h ../byterun/sys.h major_gc.d.o: major_gc.c ../byterun/compact.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/misc.h \ - ../byterun/custom.h ../byterun/mlvalues.h ../byterun/config.h \ - ../byterun/fail.h ../byterun/finalise.h ../byterun/roots.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/freelist.h \ - ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/major_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h ../byterun/roots.h \ - ../byterun/weak.h + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/misc.h \ + ../byterun/custom.h ../byterun/mlvalues.h ../byterun/config.h \ + ../byterun/fail.h ../byterun/finalise.h ../byterun/roots.h \ + ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ + ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/freelist.h \ + ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/major_gc.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/roots.h \ + ../byterun/weak.h md5.d.o: md5.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/md5.h ../byterun/io.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/io.h \ - ../byterun/reverse.h + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ + ../byterun/fail.h ../byterun/md5.h ../byterun/io.h ../byterun/memory.h \ + ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/io.h \ + ../byterun/reverse.h memory.d.o: memory.c ../byterun/fail.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/freelist.h ../byterun/gc.h \ - ../byterun/gc_ctrl.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/minor_gc.h ../byterun/minor_gc.h ../byterun/misc.h \ - ../byterun/mlvalues.h ../byterun/signals.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/mlvalues.h ../byterun/freelist.h ../byterun/gc.h \ + ../byterun/gc_ctrl.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ + ../byterun/minor_gc.h ../byterun/minor_gc.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/signals.h meta.d.o: meta.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/config.h ../byterun/fail.h ../byterun/fix_code.h \ - ../byterun/interp.h ../byterun/intext.h ../byterun/io.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/minor_gc.h \ - ../byterun/minor_gc.h ../byterun/misc.h ../byterun/mlvalues.h \ - ../byterun/prims.h ../byterun/stacks.h ../byterun/memory.h + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ + ../byterun/config.h ../byterun/fail.h ../byterun/fix_code.h \ + ../byterun/interp.h ../byterun/intext.h ../byterun/io.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/memory.h \ + ../byterun/gc.h ../byterun/major_gc.h ../byterun/minor_gc.h \ + ../byterun/minor_gc.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/prims.h ../byterun/stacks.h ../byterun/memory.h minor_gc.d.o: minor_gc.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/fail.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/mlvalues.h ../byterun/finalise.h \ - ../byterun/roots.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/major_gc.h \ - ../byterun/memory.h ../byterun/minor_gc.h ../byterun/misc.h \ - ../byterun/mlvalues.h ../byterun/roots.h ../byterun/signals.h \ - ../byterun/weak.h + ../byterun/../config/s.h ../byterun/fail.h ../byterun/misc.h \ + ../byterun/config.h ../byterun/mlvalues.h ../byterun/finalise.h \ + ../byterun/roots.h ../byterun/memory.h ../byterun/gc.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ + ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/major_gc.h \ + ../byterun/memory.h ../byterun/minor_gc.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/roots.h ../byterun/signals.h \ + ../byterun/weak.h misc.d.o: misc.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/mlvalues.h \ - ../byterun/misc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h + ../byterun/../config/s.h ../byterun/misc.h ../byterun/config.h \ + ../byterun/memory.h ../byterun/gc.h ../byterun/mlvalues.h \ + ../byterun/misc.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/minor_gc.h natdynlink.d.o: natdynlink.c ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/misc.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h stack.h ../byterun/callback.h ../byterun/alloc.h \ - ../byterun/intext.h ../byterun/io.h ../byterun/osdeps.h \ - ../byterun/fail.h + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ + ../byterun/misc.h ../byterun/memory.h ../byterun/gc.h \ + ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/minor_gc.h stack.h ../byterun/callback.h ../byterun/alloc.h \ + ../byterun/intext.h ../byterun/io.h ../byterun/osdeps.h \ + ../byterun/fail.h obj.d.o: obj.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/gc.h ../byterun/interp.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/minor_gc.h \ - ../byterun/minor_gc.h ../byterun/misc.h ../byterun/mlvalues.h \ - ../byterun/prims.h + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ + ../byterun/fail.h ../byterun/gc.h ../byterun/interp.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/memory.h \ + ../byterun/gc.h ../byterun/major_gc.h ../byterun/minor_gc.h \ + ../byterun/minor_gc.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/prims.h parsing.d.o: parsing.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/mlvalues.h ../byterun/config.h \ - ../byterun/misc.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/alloc.h + ../byterun/../config/s.h ../byterun/mlvalues.h ../byterun/config.h \ + ../byterun/misc.h ../byterun/memory.h ../byterun/gc.h \ + ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/minor_gc.h ../byterun/alloc.h printexc.d.o: printexc.c ../byterun/backtrace.h ../byterun/mlvalues.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/misc.h ../byterun/callback.h ../byterun/debugger.h \ - ../byterun/fail.h ../byterun/misc.h ../byterun/mlvalues.h \ - ../byterun/printexc.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/misc.h ../byterun/callback.h ../byterun/debugger.h \ + ../byterun/fail.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/printexc.h roots.d.o: roots.c ../byterun/finalise.h ../byterun/roots.h \ - ../byterun/misc.h ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/globroots.h ../byterun/memory.h \ - ../byterun/major_gc.h ../byterun/minor_gc.h ../byterun/misc.h \ - ../byterun/mlvalues.h stack.h ../byterun/roots.h + ../byterun/misc.h ../byterun/config.h ../byterun/../config/m.h \ + ../byterun/../config/s.h ../byterun/memory.h ../byterun/gc.h \ + ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/minor_gc.h ../byterun/globroots.h ../byterun/memory.h \ + ../byterun/major_gc.h ../byterun/minor_gc.h ../byterun/misc.h \ + ../byterun/mlvalues.h stack.h ../byterun/roots.h signals.d.o: signals.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/callback.h ../byterun/config.h \ - ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h ../byterun/roots.h \ - ../byterun/memory.h ../byterun/signals.h ../byterun/signals_machdep.h \ - ../byterun/sys.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/mlvalues.h ../byterun/callback.h ../byterun/config.h \ + ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/roots.h \ + ../byterun/memory.h ../byterun/signals.h ../byterun/signals_machdep.h \ + ../byterun/sys.h signals_asm.d.o: signals_asm.c ../byterun/fail.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/osdeps.h ../byterun/signals.h ../byterun/signals_machdep.h \ - signals_osdep.h stack.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/mlvalues.h ../byterun/memory.h ../byterun/gc.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ + ../byterun/osdeps.h ../byterun/signals.h ../byterun/signals_machdep.h \ + signals_osdep.h stack.h startup.d.o: startup.c ../byterun/callback.h ../byterun/mlvalues.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/misc.h ../byterun/backtrace.h ../byterun/custom.h \ - ../byterun/debugger.h ../byterun/fail.h ../byterun/freelist.h \ - ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/intext.h ../byterun/io.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/misc.h \ - ../byterun/mlvalues.h ../byterun/osdeps.h ../byterun/printexc.h stack.h \ - ../byterun/sys.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/misc.h ../byterun/backtrace.h ../byterun/custom.h \ + ../byterun/debugger.h ../byterun/fail.h ../byterun/freelist.h \ + ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/intext.h \ + ../byterun/io.h ../byterun/memory.h ../byterun/gc.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/osdeps.h \ + ../byterun/printexc.h stack.h ../byterun/sys.h str.d.o: str.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/mlvalues.h ../byterun/misc.h \ - ../byterun/int64_native.h + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ + ../byterun/fail.h ../byterun/mlvalues.h ../byterun/misc.h sys.d.o: sys.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/mlvalues.h ../byterun/debugger.h \ - ../byterun/fail.h ../byterun/instruct.h ../byterun/mlvalues.h \ - ../byterun/osdeps.h ../byterun/signals.h ../byterun/stacks.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/sys.h + ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ + ../byterun/config.h ../byterun/mlvalues.h ../byterun/debugger.h \ + ../byterun/fail.h ../byterun/instruct.h ../byterun/mlvalues.h \ + ../byterun/osdeps.h ../byterun/signals.h ../byterun/stacks.h \ + ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ + ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/sys.h terminfo.d.o: terminfo.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/mlvalues.h ../byterun/fail.h \ - ../byterun/io.h ../byterun/mlvalues.h + ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ + ../byterun/config.h ../byterun/mlvalues.h ../byterun/fail.h \ + ../byterun/io.h ../byterun/mlvalues.h unix.d.o: unix.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/memory.h ../byterun/config.h \ - ../byterun/gc.h ../byterun/mlvalues.h ../byterun/misc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/osdeps.h + ../byterun/../config/s.h ../byterun/memory.h ../byterun/config.h \ + ../byterun/gc.h ../byterun/mlvalues.h ../byterun/misc.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ + ../byterun/misc.h ../byterun/osdeps.h weak.d.o: weak.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/minor_gc.h ../byterun/mlvalues.h + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ + ../byterun/fail.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ + ../byterun/minor_gc.h ../byterun/mlvalues.h alloc.p.o: alloc.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/custom.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/stacks.h \ - ../byterun/memory.h + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ + ../byterun/custom.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ + ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/stacks.h \ + ../byterun/memory.h array.p.o: array.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ + ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ + ../byterun/misc.h ../byterun/mlvalues.h backtrace.p.o: backtrace.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/backtrace.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/misc.h ../byterun/mlvalues.h stack.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/mlvalues.h ../byterun/backtrace.h ../byterun/memory.h \ + ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/minor_gc.h ../byterun/misc.h ../byterun/mlvalues.h stack.h callback.p.o: callback.c ../byterun/callback.h ../byterun/mlvalues.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/misc.h ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/mlvalues.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/misc.h ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ + ../byterun/mlvalues.h compact.p.o: compact.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/finalise.h ../byterun/roots.h \ - ../byterun/misc.h ../byterun/config.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/mlvalues.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/freelist.h \ - ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/major_gc.h \ - ../byterun/memory.h ../byterun/mlvalues.h ../byterun/roots.h \ - ../byterun/weak.h + ../byterun/../config/s.h ../byterun/finalise.h ../byterun/roots.h \ + ../byterun/misc.h ../byterun/config.h ../byterun/memory.h \ + ../byterun/gc.h ../byterun/mlvalues.h ../byterun/major_gc.h \ + ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/freelist.h \ + ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/major_gc.h \ + ../byterun/memory.h ../byterun/mlvalues.h ../byterun/roots.h \ + ../byterun/weak.h compare.p.o: compare.c ../byterun/custom.h ../byterun/mlvalues.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/misc.h ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/misc.h ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ + ../byterun/misc.h ../byterun/mlvalues.h custom.p.o: custom.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/custom.h ../byterun/fail.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/mlvalues.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/mlvalues.h ../byterun/custom.h ../byterun/fail.h \ + ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ + ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/mlvalues.h debugger.p.o: debugger.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/config.h ../byterun/debugger.h \ - ../byterun/misc.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/mlvalues.h ../byterun/config.h ../byterun/debugger.h \ + ../byterun/misc.h dynlink.p.o: dynlink.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/mlvalues.h ../byterun/dynlink.h \ - ../byterun/fail.h ../byterun/mlvalues.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/misc.h ../byterun/osdeps.h \ - ../byterun/prims.h + ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ + ../byterun/config.h ../byterun/mlvalues.h ../byterun/dynlink.h \ + ../byterun/fail.h ../byterun/mlvalues.h ../byterun/memory.h \ + ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/minor_gc.h ../byterun/misc.h ../byterun/osdeps.h \ + ../byterun/prims.h extern.p.o: extern.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/custom.h ../byterun/fail.h \ - ../byterun/gc.h ../byterun/intext.h ../byterun/io.h ../byterun/io.h \ - ../byterun/md5.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h ../byterun/reverse.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/mlvalues.h ../byterun/custom.h ../byterun/fail.h \ + ../byterun/gc.h ../byterun/intext.h ../byterun/io.h ../byterun/io.h \ + ../byterun/md5.h ../byterun/memory.h ../byterun/gc.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/reverse.h fail.p.o: fail.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/io.h ../byterun/gc.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/printexc.h \ - ../byterun/signals.h stack.h ../byterun/roots.h ../byterun/memory.h \ - ../byterun/callback.h + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ + ../byterun/fail.h ../byterun/io.h ../byterun/gc.h ../byterun/memory.h \ + ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/printexc.h \ + ../byterun/signals.h stack.h ../byterun/roots.h ../byterun/memory.h \ + ../byterun/callback.h finalise.p.o: finalise.c ../byterun/callback.h ../byterun/mlvalues.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/misc.h ../byterun/fail.h ../byterun/mlvalues.h \ - ../byterun/roots.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/signals.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/misc.h ../byterun/fail.h ../byterun/mlvalues.h \ + ../byterun/roots.h ../byterun/memory.h ../byterun/gc.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ + ../byterun/signals.h floats.p.o: floats.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/fail.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/misc.h \ - ../byterun/reverse.h ../byterun/stacks.h ../byterun/memory.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/mlvalues.h ../byterun/fail.h ../byterun/memory.h \ + ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/misc.h \ + ../byterun/reverse.h ../byterun/stacks.h ../byterun/memory.h freelist.p.o: freelist.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/freelist.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/mlvalues.h ../byterun/gc.h \ - ../byterun/gc_ctrl.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/major_gc.h ../byterun/misc.h ../byterun/mlvalues.h + ../byterun/../config/s.h ../byterun/freelist.h ../byterun/misc.h \ + ../byterun/config.h ../byterun/mlvalues.h ../byterun/gc.h \ + ../byterun/gc_ctrl.h ../byterun/memory.h ../byterun/gc.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ + ../byterun/major_gc.h ../byterun/misc.h ../byterun/mlvalues.h gc_ctrl.p.o: gc_ctrl.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/compact.h ../byterun/custom.h \ - ../byterun/finalise.h ../byterun/roots.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/freelist.h ../byterun/gc.h \ - ../byterun/gc_ctrl.h ../byterun/major_gc.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h stack.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/mlvalues.h ../byterun/compact.h ../byterun/custom.h \ + ../byterun/finalise.h ../byterun/roots.h ../byterun/memory.h \ + ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/minor_gc.h ../byterun/freelist.h ../byterun/gc.h \ + ../byterun/gc_ctrl.h ../byterun/major_gc.h ../byterun/minor_gc.h \ + ../byterun/misc.h ../byterun/mlvalues.h stack.h globroots.p.o: globroots.c ../byterun/memory.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/gc.h \ - ../byterun/mlvalues.h ../byterun/misc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/misc.h \ - ../byterun/mlvalues.h ../byterun/roots.h ../byterun/memory.h \ - ../byterun/globroots.h ../byterun/roots.h + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/gc.h \ + ../byterun/mlvalues.h ../byterun/misc.h ../byterun/major_gc.h \ + ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/roots.h ../byterun/memory.h \ + ../byterun/globroots.h ../byterun/roots.h hash.p.o: hash.c ../byterun/mlvalues.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/misc.h \ - ../byterun/custom.h ../byterun/mlvalues.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/hash.h ../byterun/int64_native.h + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/misc.h \ + ../byterun/custom.h ../byterun/mlvalues.h ../byterun/memory.h \ + ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/minor_gc.h ../byterun/hash.h intern.p.o: intern.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/callback.h ../byterun/custom.h \ - ../byterun/fail.h ../byterun/gc.h ../byterun/intext.h ../byterun/io.h \ - ../byterun/io.h ../byterun/md5.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/mlvalues.h ../byterun/misc.h ../byterun/reverse.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/mlvalues.h ../byterun/callback.h ../byterun/custom.h \ + ../byterun/fail.h ../byterun/gc.h ../byterun/intext.h ../byterun/io.h \ + ../byterun/io.h ../byterun/md5.h ../byterun/memory.h ../byterun/gc.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ + ../byterun/mlvalues.h ../byterun/misc.h ../byterun/reverse.h ints.p.o: ints.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/custom.h ../byterun/fail.h ../byterun/intext.h \ - ../byterun/io.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h ../byterun/int64_native.h + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ + ../byterun/custom.h ../byterun/fail.h ../byterun/intext.h \ + ../byterun/io.h ../byterun/memory.h ../byterun/gc.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ + ../byterun/misc.h ../byterun/mlvalues.h io.p.o: io.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/mlvalues.h ../byterun/custom.h \ - ../byterun/fail.h ../byterun/io.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h ../byterun/signals.h \ - ../byterun/sys.h + ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ + ../byterun/config.h ../byterun/mlvalues.h ../byterun/custom.h \ + ../byterun/fail.h ../byterun/io.h ../byterun/memory.h ../byterun/gc.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/signals.h \ + ../byterun/sys.h lexing.p.o: lexing.c ../byterun/fail.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/mlvalues.h ../byterun/stacks.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/mlvalues.h ../byterun/mlvalues.h ../byterun/stacks.h \ + ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ + ../byterun/freelist.h ../byterun/minor_gc.h main.p.o: main.c ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/misc.h ../byterun/sys.h + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ + ../byterun/misc.h ../byterun/sys.h major_gc.p.o: major_gc.c ../byterun/compact.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/misc.h \ - ../byterun/custom.h ../byterun/mlvalues.h ../byterun/config.h \ - ../byterun/fail.h ../byterun/finalise.h ../byterun/roots.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/freelist.h \ - ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/major_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h ../byterun/roots.h \ - ../byterun/weak.h + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/misc.h \ + ../byterun/custom.h ../byterun/mlvalues.h ../byterun/config.h \ + ../byterun/fail.h ../byterun/finalise.h ../byterun/roots.h \ + ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ + ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/freelist.h \ + ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/major_gc.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/roots.h \ + ../byterun/weak.h md5.p.o: md5.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/md5.h ../byterun/io.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/io.h \ - ../byterun/reverse.h + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ + ../byterun/fail.h ../byterun/md5.h ../byterun/io.h ../byterun/memory.h \ + ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/io.h \ + ../byterun/reverse.h memory.p.o: memory.c ../byterun/fail.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/freelist.h ../byterun/gc.h \ - ../byterun/gc_ctrl.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/minor_gc.h ../byterun/minor_gc.h ../byterun/misc.h \ - ../byterun/mlvalues.h ../byterun/signals.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/mlvalues.h ../byterun/freelist.h ../byterun/gc.h \ + ../byterun/gc_ctrl.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ + ../byterun/minor_gc.h ../byterun/minor_gc.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/signals.h meta.p.o: meta.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/config.h ../byterun/fail.h ../byterun/fix_code.h \ - ../byterun/interp.h ../byterun/intext.h ../byterun/io.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/minor_gc.h \ - ../byterun/minor_gc.h ../byterun/misc.h ../byterun/mlvalues.h \ - ../byterun/prims.h ../byterun/stacks.h ../byterun/memory.h + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ + ../byterun/config.h ../byterun/fail.h ../byterun/fix_code.h \ + ../byterun/interp.h ../byterun/intext.h ../byterun/io.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/memory.h \ + ../byterun/gc.h ../byterun/major_gc.h ../byterun/minor_gc.h \ + ../byterun/minor_gc.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/prims.h ../byterun/stacks.h ../byterun/memory.h minor_gc.p.o: minor_gc.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/fail.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/mlvalues.h ../byterun/finalise.h \ - ../byterun/roots.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/major_gc.h \ - ../byterun/memory.h ../byterun/minor_gc.h ../byterun/misc.h \ - ../byterun/mlvalues.h ../byterun/roots.h ../byterun/signals.h \ - ../byterun/weak.h + ../byterun/../config/s.h ../byterun/fail.h ../byterun/misc.h \ + ../byterun/config.h ../byterun/mlvalues.h ../byterun/finalise.h \ + ../byterun/roots.h ../byterun/memory.h ../byterun/gc.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ + ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/major_gc.h \ + ../byterun/memory.h ../byterun/minor_gc.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/roots.h ../byterun/signals.h \ + ../byterun/weak.h misc.p.o: misc.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/mlvalues.h \ - ../byterun/misc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h + ../byterun/../config/s.h ../byterun/misc.h ../byterun/config.h \ + ../byterun/memory.h ../byterun/gc.h ../byterun/mlvalues.h \ + ../byterun/misc.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/minor_gc.h natdynlink.p.o: natdynlink.c ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/misc.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h stack.h ../byterun/callback.h ../byterun/alloc.h \ - ../byterun/intext.h ../byterun/io.h ../byterun/osdeps.h \ - ../byterun/fail.h + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ + ../byterun/misc.h ../byterun/memory.h ../byterun/gc.h \ + ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/minor_gc.h stack.h ../byterun/callback.h ../byterun/alloc.h \ + ../byterun/intext.h ../byterun/io.h ../byterun/osdeps.h \ + ../byterun/fail.h obj.p.o: obj.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/gc.h ../byterun/interp.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/minor_gc.h \ - ../byterun/minor_gc.h ../byterun/misc.h ../byterun/mlvalues.h \ - ../byterun/prims.h + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ + ../byterun/fail.h ../byterun/gc.h ../byterun/interp.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/memory.h \ + ../byterun/gc.h ../byterun/major_gc.h ../byterun/minor_gc.h \ + ../byterun/minor_gc.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/prims.h parsing.p.o: parsing.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/mlvalues.h ../byterun/config.h \ - ../byterun/misc.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/alloc.h + ../byterun/../config/s.h ../byterun/mlvalues.h ../byterun/config.h \ + ../byterun/misc.h ../byterun/memory.h ../byterun/gc.h \ + ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/minor_gc.h ../byterun/alloc.h printexc.p.o: printexc.c ../byterun/backtrace.h ../byterun/mlvalues.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/misc.h ../byterun/callback.h ../byterun/debugger.h \ - ../byterun/fail.h ../byterun/misc.h ../byterun/mlvalues.h \ - ../byterun/printexc.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/misc.h ../byterun/callback.h ../byterun/debugger.h \ + ../byterun/fail.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/printexc.h roots.p.o: roots.c ../byterun/finalise.h ../byterun/roots.h \ - ../byterun/misc.h ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/globroots.h ../byterun/memory.h \ - ../byterun/major_gc.h ../byterun/minor_gc.h ../byterun/misc.h \ - ../byterun/mlvalues.h stack.h ../byterun/roots.h + ../byterun/misc.h ../byterun/config.h ../byterun/../config/m.h \ + ../byterun/../config/s.h ../byterun/memory.h ../byterun/gc.h \ + ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/minor_gc.h ../byterun/globroots.h ../byterun/memory.h \ + ../byterun/major_gc.h ../byterun/minor_gc.h ../byterun/misc.h \ + ../byterun/mlvalues.h stack.h ../byterun/roots.h signals.p.o: signals.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/callback.h ../byterun/config.h \ - ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h ../byterun/roots.h \ - ../byterun/memory.h ../byterun/signals.h ../byterun/signals_machdep.h \ - ../byterun/sys.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/mlvalues.h ../byterun/callback.h ../byterun/config.h \ + ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/roots.h \ + ../byterun/memory.h ../byterun/signals.h ../byterun/signals_machdep.h \ + ../byterun/sys.h signals_asm.p.o: signals_asm.c ../byterun/fail.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/osdeps.h ../byterun/signals.h ../byterun/signals_machdep.h \ - signals_osdep.h stack.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/mlvalues.h ../byterun/memory.h ../byterun/gc.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ + ../byterun/osdeps.h ../byterun/signals.h ../byterun/signals_machdep.h \ + signals_osdep.h stack.h startup.p.o: startup.c ../byterun/callback.h ../byterun/mlvalues.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/misc.h ../byterun/backtrace.h ../byterun/custom.h \ - ../byterun/debugger.h ../byterun/fail.h ../byterun/freelist.h \ - ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/intext.h ../byterun/io.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/misc.h \ - ../byterun/mlvalues.h ../byterun/osdeps.h ../byterun/printexc.h stack.h \ - ../byterun/sys.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/misc.h ../byterun/backtrace.h ../byterun/custom.h \ + ../byterun/debugger.h ../byterun/fail.h ../byterun/freelist.h \ + ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/intext.h \ + ../byterun/io.h ../byterun/memory.h ../byterun/gc.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/osdeps.h \ + ../byterun/printexc.h stack.h ../byterun/sys.h str.p.o: str.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/mlvalues.h ../byterun/misc.h \ - ../byterun/int64_native.h + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ + ../byterun/fail.h ../byterun/mlvalues.h ../byterun/misc.h sys.p.o: sys.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/mlvalues.h ../byterun/debugger.h \ - ../byterun/fail.h ../byterun/instruct.h ../byterun/mlvalues.h \ - ../byterun/osdeps.h ../byterun/signals.h ../byterun/stacks.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/sys.h + ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ + ../byterun/config.h ../byterun/mlvalues.h ../byterun/debugger.h \ + ../byterun/fail.h ../byterun/instruct.h ../byterun/mlvalues.h \ + ../byterun/osdeps.h ../byterun/signals.h ../byterun/stacks.h \ + ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ + ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/sys.h terminfo.p.o: terminfo.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/mlvalues.h ../byterun/fail.h \ - ../byterun/io.h ../byterun/mlvalues.h + ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ + ../byterun/config.h ../byterun/mlvalues.h ../byterun/fail.h \ + ../byterun/io.h ../byterun/mlvalues.h unix.p.o: unix.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/memory.h ../byterun/config.h \ - ../byterun/gc.h ../byterun/mlvalues.h ../byterun/misc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/osdeps.h + ../byterun/../config/s.h ../byterun/memory.h ../byterun/config.h \ + ../byterun/gc.h ../byterun/mlvalues.h ../byterun/misc.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ + ../byterun/misc.h ../byterun/osdeps.h weak.p.o: weak.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/minor_gc.h ../byterun/mlvalues.h + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ + ../byterun/fail.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ + ../byterun/minor_gc.h ../byterun/mlvalues.h diff --git a/asmrun/Makefile b/asmrun/Makefile index fa8aa6a72..63ff80c68 100644 --- a/asmrun/Makefile +++ b/asmrun/Makefile @@ -60,26 +60,29 @@ libasmrunp.a: $(POBJS) ar rc libasmrunp.a $(POBJS) $(RANLIB) libasmrunp.a +INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR) + install: install-default install-$(RUNTIMED) install-$(PROFILING) install-default: - cp libasmrun.a $(LIBDIR)/libasmrun.a - cd $(LIBDIR); $(RANLIB) libasmrun.a + cp libasmrun.a $(INSTALL_LIBDIR)/libasmrun.a + cd $(INSTALL_LIBDIR); $(RANLIB) libasmrun.a install-noruntimed: .PHONY: install-noruntimed install-runtimed: - cp libasmrund.a $(LIBDIR)/libasmrund.a - cd $(LIBDIR); $(RANLIB) libasmrund.a + cp libasmrund.a $(INSTALL_LIBDIR)/libasmrund.a + cd $(INSTALL_LIBDIR); $(RANLIB) libasmrund.a .PHONY: install-runtimed install-noprof: - rm -f $(LIBDIR)/libasmrunp.a; ln -s libasmrun.a $(LIBDIR)/libasmrunp.a + rm -f $(INSTALL_LIBDIR)/libasmrunp.a + ln -s libasmrun.a $(INSTALL_LIBDIR)/libasmrunp.a install-prof: - cp libasmrunp.a $(LIBDIR)/libasmrunp.a - cd $(LIBDIR); $(RANLIB) libasmrunp.a + cp libasmrunp.a $(INSTALL_LIBDIR)/libasmrunp.a + cd $(INSTALL_LIBDIR); $(RANLIB) libasmrunp.a power-bsd_elf.S: power-elf.S cp power-elf.S power-bsd_elf.S @@ -180,7 +183,7 @@ clean:: exit 2; } .S.p.o: - $(ASPP) -DSYS_$(SYSTEM) $(ASPPPROFFLAGS) -o $*.p.o $*.S + $(ASPP) -DSYS_$(SYSTEM) -DMODEL_$(MODEL) $(ASPPPROFFLAGS) -o $*.p.o $*.S .c.d.o: ln -s -f $*.c $*.d.c diff --git a/asmrun/Makefile.nt b/asmrun/Makefile.nt index 876fe6024..77c2002d4 100644 --- a/asmrun/Makefile.nt +++ b/asmrun/Makefile.nt @@ -56,8 +56,10 @@ i386.o: i386.S amd64.o: amd64.S $(ASPP) -DSYS_$(SYSTEM) amd64.S +INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR) + install: - cp libasmrun.$(A) $(LIBDIR) + cp libasmrun.$(A) $(INSTALL_LIBDIR) $(LINKEDFILES): %.c: ../byterun/%.c cp ../byterun/$*.c $*.c diff --git a/asmrun/arm.S b/asmrun/arm.S index 2ce244a1a..9720665aa 100644 --- a/asmrun/arm.S +++ b/asmrun/arm.S @@ -44,6 +44,15 @@ cmp \reg, #0 beq \lbl .endm +#elif defined(SYS_freebsd) + .arch armv6 + .arm + + /* Compatibility macros */ + .macro cbz reg, lbl + cmp \reg, #0 + beq \lbl + .endm #endif trap_ptr .req r8 diff --git a/asmrun/arm64.S b/asmrun/arm64.S index de670e660..9b4b9ab7c 100644 --- a/asmrun/arm64.S +++ b/asmrun/arm64.S @@ -44,30 +44,30 @@ #if defined(__PIC__) #define ADDRGLOBAL(reg,symb) \ - adrp TMP2, :got:symb; \ - ldr reg, [TMP2, #:got_lo12:symb] + adrp TMP2, :got:symb; \ + ldr reg, [TMP2, #:got_lo12:symb] #define LOADGLOBAL(reg,symb) \ - ADDRGLOBAL(TMP2,symb); \ - ldr reg, [TMP2] + ADDRGLOBAL(TMP2,symb); \ + ldr reg, [TMP2] #define STOREGLOBAL(reg,symb) \ - ADDRGLOBAL(TMP2,symb); \ - str reg, [TMP2] + ADDRGLOBAL(TMP2,symb); \ + str reg, [TMP2] #else #define ADDRGLOBAL(reg,symb) \ - adrp reg, symb; \ - add reg, reg, #:lo12:symb + adrp reg, symb; \ + add reg, reg, #:lo12:symb #define LOADGLOBAL(reg,symb) \ - adrp TMP2, symb; \ - ldr reg, [TMP2, #:lo12:symb] + adrp TMP2, symb; \ + ldr reg, [TMP2, #:lo12:symb] #define STOREGLOBAL(reg,symb) \ - adrp TMP2, symb; \ - str reg, [TMP2, #:lo12:symb] + adrp TMP2, symb; \ + str reg, [TMP2, #:lo12:symb] #endif @@ -82,11 +82,11 @@ caml_call_gc: CFI_STARTPROC PROFILE /* Record return address */ - STOREGLOBAL(x30, caml_last_return_address) -.Lcaml_call_gc: + STOREGLOBAL(x30, caml_last_return_address) /* Record lowest stack address */ - mov TMP, sp - STOREGLOBAL(TMP, caml_bottom_of_stack) + mov TMP, sp + STOREGLOBAL(TMP, caml_bottom_of_stack) +.Lcaml_call_gc: /* Set up stack space, saving return address and frame pointer */ /* (2 regs RA/GP, 24 allocatable int regs, 24 caller-save float regs) * 8 */ stp x29, x30, [sp, -400]! @@ -94,7 +94,7 @@ caml_call_gc: add x29, sp, #0 /* Save allocatable integer registers on the stack, in the order given in proc.ml */ - stp x0, x1, [sp, 16] + stp x0, x1, [sp, 16] stp x2, x3, [sp, 32] stp x4, x5, [sp, 48] stp x6, x7, [sp, 64] @@ -121,16 +121,16 @@ caml_call_gc: stp d28, d29, [sp, 368] stp d30, d31, [sp, 384] /* Store pointer to saved integer registers in caml_gc_regs */ - add TMP, sp, #16 - STOREGLOBAL(TMP, caml_gc_regs) + add TMP, sp, #16 + STOREGLOBAL(TMP, caml_gc_regs) /* Save current allocation pointer for debugging purposes */ - STOREGLOBAL(ALLOC_PTR, caml_young_ptr) + STOREGLOBAL(ALLOC_PTR, caml_young_ptr) /* Save trap pointer in case an exception is raised during GC */ - STOREGLOBAL(TRAP_PTR, caml_exception_pointer) + STOREGLOBAL(TRAP_PTR, caml_exception_pointer) /* Call the garbage collector */ bl caml_garbage_collection /* Restore registers */ - ldp x0, x1, [sp, 16] + ldp x0, x1, [sp, 16] ldp x2, x3, [sp, 32] ldp x4, x5, [sp, 48] ldp x6, x7, [sp, 64] @@ -155,10 +155,10 @@ caml_call_gc: ldp d28, d29, [sp, 368] ldp d30, d31, [sp, 384] /* Reload new allocation pointer and allocation limit */ - LOADGLOBAL(ALLOC_PTR, caml_young_ptr) - LOADGLOBAL(ALLOC_LIMIT, caml_young_limit) + LOADGLOBAL(ALLOC_PTR, caml_young_ptr) + LOADGLOBAL(ALLOC_LIMIT, caml_young_limit) /* Free stack space and return to caller */ - ldp x29, x30, [sp], 400 + ldp x29, x30, [sp], 400 ret CFI_ENDPROC .type caml_call_gc, %function @@ -175,13 +175,20 @@ caml_alloc1: ret 2: stp x29, x30, [sp, -16]! CFI_ADJUST(16) + /* Record the lowest address of the caller's stack frame. This is the address + immediately above the pair of words (x29 and x30) we just pushed. Those must + not be included since otherwise the distance from [caml_bottom_of_stack] to the + highest address in the caller's stack frame won't match the frame size contained + in the relevant frame descriptor. */ + add x29, sp, #16 + STOREGLOBAL(x29, caml_bottom_of_stack) add x29, sp, #0 /* Record return address */ - STOREGLOBAL(x30, caml_last_return_address) + STOREGLOBAL(x30, caml_last_return_address) /* Call GC */ bl .Lcaml_call_gc /* Restore return address */ - ldp x29, x30, [sp], 16 + ldp x29, x30, [sp], 16 CFI_ADJUST(-16) /* Try again */ b 1b @@ -200,20 +207,23 @@ caml_alloc2: ret 2: stp x29, x30, [sp, -16]! CFI_ADJUST(16) + /* Record the lowest address of the caller's stack frame. See comment above. */ + add x29, sp, #16 + STOREGLOBAL(x29, caml_bottom_of_stack) add x29, sp, #0 /* Record return address */ - STOREGLOBAL(x30, caml_last_return_address) + STOREGLOBAL(x30, caml_last_return_address) /* Call GC */ bl .Lcaml_call_gc /* Restore return address */ - ldp x29, x30, [sp], 16 + ldp x29, x30, [sp], 16 CFI_ADJUST(-16) /* Try again */ b 1b CFI_ENDPROC .type caml_alloc2, %function .size caml_alloc2, .-caml_alloc2 - + .align 2 .globl caml_alloc3 caml_alloc3: @@ -225,20 +235,23 @@ caml_alloc3: ret 2: stp x29, x30, [sp, -16]! CFI_ADJUST(16) + /* Record the lowest address of the caller's stack frame. See comment above. */ + add x29, sp, #16 + STOREGLOBAL(x29, caml_bottom_of_stack) add x29, sp, #0 /* Record return address */ - STOREGLOBAL(x30, caml_last_return_address) + STOREGLOBAL(x30, caml_last_return_address) /* Call GC */ bl .Lcaml_call_gc /* Restore return address */ - ldp x29, x30, [sp], 16 + ldp x29, x30, [sp], 16 CFI_ADJUST(-16) /* Try again */ b 1b CFI_ENDPROC .type caml_alloc2, %function .size caml_alloc2, .-caml_alloc2 - + .align 2 .globl caml_allocN caml_allocN: @@ -250,13 +263,16 @@ caml_allocN: ret 2: stp x29, x30, [sp, -16]! CFI_ADJUST(16) + /* Record the lowest address of the caller's stack frame. See comment above. */ + add x29, sp, #16 + STOREGLOBAL(x29, caml_bottom_of_stack) add x29, sp, #0 /* Record return address */ - STOREGLOBAL(x30, caml_last_return_address) + STOREGLOBAL(x30, caml_last_return_address) /* Call GC. This preserves ARG */ bl .Lcaml_call_gc /* Restore return address */ - ldp x29, x30, [sp], 16 + ldp x29, x30, [sp], 16 CFI_ADJUST(-16) /* Try again */ b 1b @@ -279,12 +295,12 @@ caml_c_call: add TMP, sp, #0 STOREGLOBAL(TMP, caml_bottom_of_stack) /* Make the exception handler alloc ptr available to the C code */ - STOREGLOBAL(ALLOC_PTR, caml_young_ptr) + STOREGLOBAL(ALLOC_PTR, caml_young_ptr) STOREGLOBAL(TRAP_PTR, caml_exception_pointer) /* Call the function */ blr ARG /* Reload alloc ptr and alloc limit */ - LOADGLOBAL(ALLOC_PTR, caml_young_ptr) + LOADGLOBAL(ALLOC_PTR, caml_young_ptr) LOADGLOBAL(ALLOC_LIMIT, caml_young_limit) /* Return */ ret x19 @@ -299,7 +315,7 @@ caml_c_call: caml_start_program: CFI_STARTPROC PROFILE - ADDRGLOBAL(ARG, caml_program) + ADDRGLOBAL(ARG, caml_program) /* Code shared with caml_callback* */ /* Address of OCaml code to call is in ARG */ @@ -307,62 +323,62 @@ caml_start_program: .Ljump_to_caml: /* Set up stack frame and save callee-save registers */ - stp x29, x30, [sp, -160]! + stp x29, x30, [sp, -160]! CFI_ADJUST(160) - add x29, sp, #0 + add x29, sp, #0 stp x19, x20, [sp, 16] stp x21, x22, [sp, 32] stp x23, x24, [sp, 48] stp x25, x26, [sp, 64] stp x27, x28, [sp, 80] - stp d8, d9, [sp, 96] + stp d8, d9, [sp, 96] stp d10, d11, [sp, 112] stp d12, d13, [sp, 128] stp d14, d15, [sp, 144] /* Setup a callback link on the stack */ - LOADGLOBAL(x8, caml_bottom_of_stack) + LOADGLOBAL(x8, caml_bottom_of_stack) LOADGLOBAL(x9, caml_last_return_address) LOADGLOBAL(x10, caml_gc_regs) stp x8, x9, [sp, -32]! /* 16-byte alignment */ CFI_ADJUST(32) str x10, [sp, 16] /* Setup a trap frame to catch exceptions escaping the OCaml code */ - LOADGLOBAL(x8, caml_exception_pointer) + LOADGLOBAL(x8, caml_exception_pointer) adr x9, .Ltrap_handler stp x8, x9, [sp, -16]! CFI_ADJUST(16) add TRAP_PTR, sp, #0 /* Reload allocation pointers */ - LOADGLOBAL(ALLOC_PTR, caml_young_ptr) + LOADGLOBAL(ALLOC_PTR, caml_young_ptr) LOADGLOBAL(ALLOC_LIMIT, caml_young_limit) /* Call the OCaml code */ blr ARG .Lcaml_retaddr: /* Pop the trap frame, restoring caml_exception_pointer */ - ldr x8, [sp], 16 + ldr x8, [sp], 16 CFI_ADJUST(-16) STOREGLOBAL(x8, caml_exception_pointer) /* Pop the callback link, restoring the global variables */ .Lreturn_result: - ldr x10, [sp, 16] + ldr x10, [sp, 16] ldp x8, x9, [sp], 32 CFI_ADJUST(-32) - STOREGLOBAL(x8, caml_bottom_of_stack) + STOREGLOBAL(x8, caml_bottom_of_stack) STOREGLOBAL(x9, caml_last_return_address) STOREGLOBAL(x10, caml_gc_regs) /* Update allocation pointer */ - STOREGLOBAL(ALLOC_PTR, caml_young_ptr) + STOREGLOBAL(ALLOC_PTR, caml_young_ptr) /* Reload callee-save registers and return address */ ldp x19, x20, [sp, 16] ldp x21, x22, [sp, 32] ldp x23, x24, [sp, 48] ldp x25, x26, [sp, 64] ldp x27, x28, [sp, 80] - ldp d8, d9, [sp, 96] + ldp d8, d9, [sp, 96] ldp d10, d11, [sp, 112] ldp d12, d13, [sp, 128] ldp d14, d15, [sp, 144] - ldp x29, x30, [sp], 160 + ldp x29, x30, [sp], 160 CFI_ADJUST(-160) /* Return to C caller */ ret @@ -400,7 +416,7 @@ caml_raise_exn: 1: /* Cut stack at current trap handler */ mov sp, TRAP_PTR /* Pop previous handler and jump to it */ - ldr TMP, [sp, 8] + ldr TMP, [sp, 8] ldr TRAP_PTR, [sp], 16 br TMP 2: /* Preserve exception bucket in callee-save register x19 */ @@ -413,7 +429,7 @@ caml_raise_exn: bl caml_stash_backtrace /* Restore exception bucket and raise */ mov x0, x19 - b 1b + b 1b CFI_ENDPROC .type caml_raise_exn, %function .size caml_raise_exn, .-caml_raise_exn @@ -430,12 +446,12 @@ caml_raise_exception: LOADGLOBAL(ALLOC_PTR, caml_young_ptr) LOADGLOBAL(ALLOC_LIMIT, caml_young_limit) /* Test if backtrace is active */ - LOADGLOBAL(TMP, caml_backtrace_active) + LOADGLOBAL(TMP, caml_backtrace_active) cbnz TMP, 2f 1: /* Cut stack at current trap handler */ mov sp, TRAP_PTR /* Pop previous handler and jump to it */ - ldr TMP, [sp, 8] + ldr TMP, [sp, 8] ldr TRAP_PTR, [sp], 16 br TMP 2: /* Preserve exception bucket in callee-save register x19 */ @@ -443,12 +459,12 @@ caml_raise_exception: /* Stash the backtrace */ /* arg1: exn bucket, already in x0 */ LOADGLOBAL(x1, caml_last_return_address) /* arg2: pc of raise */ - LOADGLOBAL(x2, caml_bottom_of_stack) /* arg3: sp of raise */ + LOADGLOBAL(x2, caml_bottom_of_stack) /* arg3: sp of raise */ mov x3, TRAP_PTR /* arg4: sp of handler */ bl caml_stash_backtrace /* Restore exception bucket and raise */ mov x0, x19 - b 1b + b 1b CFI_ENDPROC .type caml_raise_exception, %function .size caml_raise_exception, .-caml_raise_exception @@ -461,7 +477,7 @@ caml_callback_exn: CFI_STARTPROC PROFILE /* Initial shuffling of arguments (x0 = closure, x1 = first arg) */ - mov TMP, x0 + mov TMP, x0 mov x0, x1 /* x0 = first arg */ mov x1, TMP /* x1 = closure environment */ ldr ARG, [TMP] /* code pointer */ @@ -476,11 +492,11 @@ caml_callback2_exn: CFI_STARTPROC PROFILE /* Initial shuffling of arguments (x0 = closure, x1 = arg1, x2 = arg2) */ - mov TMP, x0 + mov TMP, x0 mov x0, x1 /* x0 = first arg */ - mov x1, x2 /* x1 = second arg + mov x1, x2 /* x1 = second arg */ mov x2, TMP /* x2 = closure environment */ - ADDRGLOBAL(ARG, caml_apply2) + ADDRGLOBAL(ARG, caml_apply2) b .Ljump_to_caml CFI_ENDPROC .type caml_callback2_exn, %function @@ -498,7 +514,7 @@ caml_callback3_exn: mov x1, x2 /* x1 = second arg */ mov x2, x3 /* x2 = third arg */ mov x3, TMP /* x3 = closure environment */ - ADDRGLOBAL(ARG, caml_apply3) + ADDRGLOBAL(ARG, caml_apply3) b .Ljump_to_caml CFI_ENDPROC .type caml_callback3_exn, %function diff --git a/asmrun/backtrace.c b/asmrun/backtrace.c index 3854967cf..5eb8600cd 100644 --- a/asmrun/backtrace.c +++ b/asmrun/backtrace.c @@ -30,6 +30,17 @@ code_t * caml_backtrace_buffer = NULL; value caml_backtrace_last_exn = Val_unit; #define BACKTRACE_BUFFER_SIZE 1024 +/* In order to prevent the GC from walking through the debug information + (which have no headers), we transform frame_descr pointers into + 31/63 bits ocaml integers by shifting them by 1 to the right. We do + not lose information as descr pointers are aligned. + + In particular, we do not need to use [caml_initialize] when setting + an array element with such a value. +*/ +#define Val_Descrptr(descr) Val_long((uintnat)descr>>1) +#define Descrptr_Val(v) ((frame_descr *) (Long_val(v)<<1)) + /* Start or stop the backtrace machinery */ CAMLprim value caml_record_backtrace(value vflag) @@ -112,6 +123,7 @@ void caml_stash_backtrace(value exn, uintnat pc, char * sp, char * trapsp) caml_backtrace_last_exn = exn; } if (caml_backtrace_buffer == NULL) { + Assert(caml_backtrace_pos == 0); caml_backtrace_buffer = malloc(BACKTRACE_BUFFER_SIZE * sizeof(code_t)); if (caml_backtrace_buffer == NULL) return; } @@ -172,7 +184,7 @@ CAMLprim value caml_get_current_callstack(value max_frames_value) { } } - trace = caml_alloc((mlsize_t) trace_size, Abstract_tag); + trace = caml_alloc((mlsize_t) trace_size, 0); /* then collect the trace */ { @@ -183,11 +195,7 @@ CAMLprim value caml_get_current_callstack(value max_frames_value) { for (trace_pos = 0; trace_pos < trace_size; trace_pos++) { frame_descr * descr = caml_next_frame_descriptor(&pc, &sp); Assert(descr != NULL); - /* The assignment below is safe without [caml_initialize], even - if the trace is large and allocated on the old heap, because - we assign values that are outside the OCaml heap. */ - Assert(!(Is_block((value) descr) && Is_in_heap((value) descr))); - Field(trace, trace_pos) = (value) descr; + Field(trace, trace_pos) = Val_Descrptr(descr); } } @@ -209,7 +217,7 @@ static void extract_location_info(frame_descr * d, /*out*/ struct loc_info * li) { uintnat infoptr; - uint32 info1, info2; + uint32_t info1, info2; /* If no debugging information available, print nothing. When everything is compiled with -g, this corresponds to @@ -224,8 +232,8 @@ static void extract_location_info(frame_descr * d, sizeof(char *) + sizeof(short) + sizeof(short) + sizeof(short) * d->num_live + sizeof(frame_descr *) - 1) & -sizeof(frame_descr *); - info1 = ((uint32 *)infoptr)[0]; - info2 = ((uint32 *)infoptr)[1]; + info1 = ((uint32_t *)infoptr)[0]; + info2 = ((uint32_t *)infoptr)[1]; /* Format of the two info words: llllllllllllllllllll aaaaaaaa bbbbbbbbbb nnnnnnnnnnnnnnnnnnnnnnnn kk 44 36 26 2 0 @@ -295,31 +303,27 @@ void caml_print_exception_backtrace(void) /* Convert the raw backtrace to a data structure usable from OCaml */ -CAMLprim value caml_convert_raw_backtrace(value backtrace) { - CAMLparam1(backtrace); - CAMLlocal4(res, arr, p, fname); - int i; +CAMLprim value caml_convert_raw_backtrace_slot(value backtrace_slot) { + CAMLparam1(backtrace_slot); + CAMLlocal2(p, fname); struct loc_info li; - arr = caml_alloc(Wosize_val(backtrace), 0); - for (i = 0; i < Wosize_val(backtrace); i++) { - extract_location_info((frame_descr *) Field(backtrace, i), &li); - if (li.loc_valid) { - fname = caml_copy_string(li.loc_filename); - p = caml_alloc_small(5, 0); - Field(p, 0) = Val_bool(li.loc_is_raise); - Field(p, 1) = fname; - Field(p, 2) = Val_int(li.loc_lnum); - Field(p, 3) = Val_int(li.loc_startchr); - Field(p, 4) = Val_int(li.loc_endchr); - } else { - p = caml_alloc_small(1, 1); - Field(p, 0) = Val_bool(li.loc_is_raise); - } - caml_modify(&Field(arr, i), p); + extract_location_info(Descrptr_Val(backtrace_slot), &li); + + if (li.loc_valid) { + fname = caml_copy_string(li.loc_filename); + p = caml_alloc_small(5, 0); + Field(p, 0) = Val_bool(li.loc_is_raise); + Field(p, 1) = fname; + Field(p, 2) = Val_int(li.loc_lnum); + Field(p, 3) = Val_int(li.loc_startchr); + Field(p, 4) = Val_int(li.loc_endchr); + } else { + p = caml_alloc_small(1, 1); + Field(p, 0) = Val_bool(li.loc_is_raise); } - res = caml_alloc_small(1, 0); Field(res, 0) = arr; /* Some */ - CAMLreturn(res); + + CAMLreturn(p); } /* Get a copy of the latest backtrace */ @@ -328,10 +332,37 @@ CAMLprim value caml_get_exception_raw_backtrace(value unit) { CAMLparam0(); CAMLlocal1(res); - res = caml_alloc(caml_backtrace_pos, Abstract_tag); - if(caml_backtrace_buffer != NULL) - memcpy(&Field(res, 0), caml_backtrace_buffer, - caml_backtrace_pos * sizeof(code_t)); + const int tag = 0; + + /* Beware: the allocations below may cause finalizers to be run, and another + backtrace---possibly of a different length---to be stashed (for example + if the finalizer raises then catches an exception). We choose to ignore + any such finalizer backtraces and return the original one. */ + + if (caml_backtrace_buffer == NULL || caml_backtrace_pos == 0) { + res = caml_alloc(0, tag); + } + else { + code_t saved_caml_backtrace_buffer[BACKTRACE_BUFFER_SIZE]; + int saved_caml_backtrace_pos; + intnat i; + + saved_caml_backtrace_pos = caml_backtrace_pos; + + if (saved_caml_backtrace_pos > BACKTRACE_BUFFER_SIZE) { + saved_caml_backtrace_pos = BACKTRACE_BUFFER_SIZE; + } + + memcpy(saved_caml_backtrace_buffer, caml_backtrace_buffer, + saved_caml_backtrace_pos * sizeof(code_t)); + + res = caml_alloc(saved_caml_backtrace_pos, tag); + for (i = 0; i < saved_caml_backtrace_pos; i++) { + /* [Val_Descrptr] always returns an immediate. */ + Field(res, i) = Val_Descrptr(saved_caml_backtrace_buffer[i]); + } + } + CAMLreturn(res); } @@ -348,8 +379,16 @@ CAMLprim value caml_get_exception_raw_backtrace(value unit) CAMLprim value caml_get_exception_backtrace(value unit) { CAMLparam0(); - CAMLlocal2(raw,res); - raw = caml_get_exception_raw_backtrace(unit); - res = caml_convert_raw_backtrace(raw); + CAMLlocal3(arr, res, backtrace); + intnat i; + + backtrace = caml_get_exception_raw_backtrace(Val_unit); + + arr = caml_alloc(Wosize_val(backtrace), 0); + for (i = 0; i < Wosize_val(backtrace); i++) { + Store_field(arr, i, caml_convert_raw_backtrace_slot(Field(backtrace, i))); + } + + res = caml_alloc_small(1, 0); Field(res, 0) = arr; /* Some */ CAMLreturn(res); } diff --git a/asmrun/fail.c b/asmrun/fail.c index a63a09ca0..cb2c1cbd7 100644 --- a/asmrun/fail.c +++ b/asmrun/fail.c @@ -104,7 +104,10 @@ void caml_raise_with_args(value tag, int nargs, value args[]) void caml_raise_with_string(value tag, char const *msg) { - caml_raise_with_arg(tag, caml_copy_string(msg)); + CAMLparam1(tag); + value v_msg = caml_copy_string(msg); + caml_raise_with_arg(tag, v_msg); + CAMLnoreturn; } void caml_failwith (char const *msg) @@ -161,9 +164,11 @@ static value * caml_array_bound_error_exn = NULL; void caml_array_bound_error(void) { if (caml_array_bound_error_exn == NULL) { - caml_array_bound_error_exn = caml_named_value("Pervasives.array_bound_error"); + caml_array_bound_error_exn = + caml_named_value("Pervasives.array_bound_error"); if (caml_array_bound_error_exn == NULL) { - fprintf(stderr, "Fatal error: exception Invalid_argument(\"index out of bounds\")\n"); + fprintf(stderr, "Fatal error: exception " + "Invalid_argument(\"index out of bounds\")\n"); exit(2); } } diff --git a/asmrun/i386.S b/asmrun/i386.S index f880db257..347e967c1 100644 --- a/asmrun/i386.S +++ b/asmrun/i386.S @@ -115,13 +115,10 @@ #define PROFILE_C #endif -#ifdef SYS_macosx +/* PR#6038: GCC and Clang seem to require 16-byte alignment nowadays, + even if only MacOS X's ABI formally requires it. */ #define ALIGN_STACK(amount) subl $ amount, %esp ; CFI_ADJUST(amount) #define UNDO_ALIGN_STACK(amount) addl $ amount, %esp ; CFI_ADJUST(-amount) -#else -#define ALIGN_STACK(amount) -#define UNDO_ALIGN_STACK(amount) -#endif /* Allocation */ @@ -304,11 +301,7 @@ LBL(106): LBL(107): /* Pop the exception handler */ popl G(caml_exception_pointer); CFI_ADJUST(-4) -#ifdef SYS_macosx addl $12, %esp ; CFI_ADJUST(-12) -#else - addl $4, %esp ; CFI_ADJUST(-4) -#endif LBL(109): /* Pop the callback link, restoring the global variables */ popl G(caml_bottom_of_stack); CFI_ADJUST(-4) @@ -461,10 +454,8 @@ FUNCTION(caml_ml_array_bound_error) movl %edx, G(caml_last_return_address) leal 4(%esp), %edx movl %edx, G(caml_bottom_of_stack) - /* For MacOS X: re-align the stack */ -#ifdef SYS_macosx + /* Re-align the stack */ andl $-16, %esp -#endif /* Branch to [caml_array_bound_error] (never returns) */ call G(caml_array_bound_error) CFI_ENDPROC diff --git a/asmrun/natdynlink.c b/asmrun/natdynlink.c index edb389dbb..86c4f3e6f 100644 --- a/asmrun/natdynlink.c +++ b/asmrun/natdynlink.c @@ -25,12 +25,11 @@ #include <string.h> static void *getsym(void *handle, char *module, char *name){ - char *fullname = malloc(strlen(module) + strlen(name) + 5); + char *fullname = caml_strconcat(3, "caml", module, name); void *sym; - sprintf(fullname, "caml%s%s", module, name); sym = caml_dlsym (handle, fullname); /* printf("%s => %lx\n", fullname, (uintnat) sym); */ - free(fullname); + caml_stat_free(fullname); return sym; } diff --git a/asmrun/power-elf.S b/asmrun/power-elf.S index dfbf5b97a..facbfbf0e 100644 --- a/asmrun/power-elf.S +++ b/asmrun/power-elf.S @@ -253,9 +253,9 @@ caml_reraise_exn: .globl caml_raise_exception .type caml_raise_exception, @function caml_raise_exception: - Loadglobal(0, caml_backtrace_active, 11) - cmpwi 0, 0 - bne .L121 + Loadglobal(0, caml_backtrace_active, 11) + cmpwi 0, 0 + bne .L121 .L120: /* Reload OCaml global registers */ Loadglobal(1, caml_exception_pointer, 11) @@ -274,8 +274,8 @@ caml_raise_exception: mr 28, 3 /* preserve exn bucket in callee-save reg */ /* arg1: exception bucket, already in r3 */ Loadglobal(4, caml_last_return_address, 11) /* arg2: PC of raise */ - Loadglobal(5, caml_bottom_of_stack, 11) /* arg3: SP of raise */ - Loadglobal(6, caml_exception_pointer, 11) /* arg4: SP of handler */ + Loadglobal(5, caml_bottom_of_stack, 11) /* arg3: SP of raise */ + Loadglobal(6, caml_exception_pointer, 11) /* arg4: SP of handler */ addi 1, 1, -16 /* reserve stack space for C call */ bl caml_stash_backtrace mr 3, 28 /* restore exn bucket */ diff --git a/asmrun/power-rhapsody.S b/asmrun/power-rhapsody.S index a228cc1d5..6fcb43cc2 100644 --- a/asmrun/power-rhapsody.S +++ b/asmrun/power-rhapsody.S @@ -255,9 +255,9 @@ L111: /* Branch to handler */ bctr L110: - li r0, 0 - Storeglobal32 r0, _caml_backtrace_pos, r11 -L114: + li r0, 0 + Storeglobal32 r0, _caml_backtrace_pos, r11 +L114: mr r28, r3 /* preserve exn bucket in callee-save */ /* arg 1: exception bucket (already in r3) */ mflr r4 /* arg 2: PC of raise */ @@ -282,7 +282,7 @@ _caml_reraise_exn: /* Branch to handler */ bctr - /* Raise an exception from C */ + /* Raise an exception from C */ .globl _caml_raise_exception _caml_raise_exception: diff --git a/asmrun/signals_osdep.h b/asmrun/signals_osdep.h index 573e3a571..23165ad68 100644 --- a/asmrun/signals_osdep.h +++ b/asmrun/signals_osdep.h @@ -267,9 +267,11 @@ sigact.sa_flags = 0 typedef unsigned long context_reg; + #define CONTEXT_PC (context->sc_frame.srr0) #define CONTEXT_EXCEPTION_POINTER (context->sc_frame.fixreg[29]) #define CONTEXT_YOUNG_LIMIT (context->sc_frame.fixreg[30]) #define CONTEXT_YOUNG_PTR (context->sc_frame.fixreg[31]) + #define CONTEXT_SP (context->sc_frame.fixreg[1]) /****************** SPARC, Solaris */ @@ -288,6 +290,7 @@ #define CONTEXT_PC (context->uc_mcontext.gregs[REG_PC]) /* Local register number N is saved on the stack N words after the stack pointer */ + #define CONTEXT_SP (context->uc_mcontext.gregs[REG_SP]) #define SPARC_L_REG(n) ((long *)(context->uc_mcontext.gregs[REG_SP]))[n] #define CONTEXT_EXCEPTION_POINTER (SPARC_L_REG(5)) #define CONTEXT_YOUNG_LIMIT (SPARC_L_REG(7)) diff --git a/asmrun/stack.h b/asmrun/stack.h index 9abd6e9ce..92b3c28a3 100644 --- a/asmrun/stack.h +++ b/asmrun/stack.h @@ -25,7 +25,7 @@ #ifdef TARGET_i386 #define Saved_return_address(sp) *((intnat *)((sp) - 4)) -#ifdef SYS_macosx +#ifndef SYS_win32 #define Callback_link(sp) ((struct caml_context *)((sp) + 16)) #else #define Callback_link(sp) ((struct caml_context *)((sp) + 8)) diff --git a/boot/ocamlc b/boot/ocamlc Binary files differindex c3936a291..51c6883b2 100755 --- a/boot/ocamlc +++ b/boot/ocamlc diff --git a/boot/ocamldep b/boot/ocamldep Binary files differindex 037bec05c..90534fe30 100755 --- a/boot/ocamldep +++ b/boot/ocamldep diff --git a/boot/ocamllex b/boot/ocamllex Binary files differindex 41526528c..4a839a9fc 100755 --- a/boot/ocamllex +++ b/boot/ocamllex diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml index 90764de6b..be884ded5 100644 --- a/bytecomp/bytegen.ml +++ b/bytecomp/bytegen.ml @@ -146,7 +146,7 @@ let rec size_of_lambda = function begin match kind with | Record_regular | Record_inlined _ -> RHS_block size | Record_float -> RHS_floatblock size - | Record_exception _ -> RHS_block (size + 1) + | Record_extension -> RHS_block (size + 1) end | Llet(str, id, arg, body) -> size_of_lambda body | Lletrec(bindings, body) -> size_of_lambda body @@ -157,7 +157,7 @@ let rec size_of_lambda = function | Lprim (Pmakearray Pgenarray, args) -> assert false | Lprim (Pduprecord ((Record_regular | Record_inlined _), size), args) -> RHS_block size - | Lprim (Pduprecord (Record_exception _, size), args) -> + | Lprim (Pduprecord (Record_extension, size), args) -> RHS_block (size + 1) | Lprim (Pduprecord (Record_float, size), args) -> RHS_floatblock size | Levent (lam, _) -> size_of_lambda lam @@ -237,9 +237,15 @@ let add_event ev = (**** Compilation of a lambda expression ****) -(* association staticraise numbers -> (lbl,size of stack *) +let try_blocks = ref [] (* list of stack size for each nested try block *) + +(* association staticraise numbers -> (lbl,size of stack, try_blocks *) let sz_static_raises = ref [] + +let push_static_raise i lbl_handler sz = + sz_static_raises := (i, (lbl_handler, sz, !try_blocks)) :: !sz_static_raises + let find_raise_label i = try List.assoc i !sz_static_raises @@ -251,8 +257,8 @@ let find_raise_label i = (* Will the translation of l lead to a jump to label ? *) let code_as_jump l sz = match l with | Lstaticraise (i,[]) -> - let label,size = find_raise_label i in - if sz = size then + let label,size,tb = find_raise_label i in + if sz = size && tb == !try_blocks then Some label else None @@ -405,10 +411,15 @@ let comp_primitive p args = | Pbigstring_set_64(_) -> Kccall("caml_ba_uint8_set64", 3) | Pbswap16 -> Kccall("caml_bswap16", 1) | Pbbswap(bi) -> comp_bint_primitive bi "bswap" args + | Pint_as_pointer -> Kccall("caml_int_as_pointer", 1) | _ -> fatal_error "Bytegen.comp_primitive" let is_immed n = immed_min <= n && n <= immed_max +module Storer = + Switch.Store + (struct type t = lambda type key = lambda + let make_key = Lambda.make_key end) (* Compile an expression. The value of the expression is left in the accumulator. @@ -636,8 +647,7 @@ let rec comp_expr env exp sz cont = (comp_expr (add_vars vars (sz+1) env) handler (sz+nvars) (add_pop nvars cont1)) in - sz_static_raises := - (i, (lbl_handler, sz+nvars)) :: !sz_static_raises ; + push_static_raise i lbl_handler (sz+nvars); push_dummies nvars (comp_expr env body (sz+nvars) (add_pop nvars (branch1 :: cont2))) @@ -648,30 +658,39 @@ let rec comp_expr env exp sz cont = (Kpush::comp_expr (add_var var (sz+1) env) handler (sz+1) (add_pop 1 cont1)) in - sz_static_raises := - (i, (lbl_handler, sz)) :: !sz_static_raises ; + push_static_raise i lbl_handler sz; comp_expr env body sz (branch1 :: cont2) end in sz_static_raises := List.tl !sz_static_raises ; r | Lstaticraise (i, args) -> let cont = discard_dead_code cont in - let label,size = find_raise_label i in + let label,size,tb = find_raise_label i in + let cont = branch_to label cont in + let rec loop sz tbb = + if tb == tbb then add_pop (sz-size) cont + else match tbb with + | [] -> assert false + | try_sz :: tbb -> add_pop (sz-try_sz-4) (Kpoptrap :: loop try_sz tbb) + in + let cont = loop sz !try_blocks in begin match args with | [arg] -> (* optim, argument passed in accumulator *) - comp_expr env arg sz - (add_pop (sz-size) (branch_to label cont)) - | _ -> - comp_exit_args env args sz size - (add_pop (sz-size) (branch_to label cont)) + comp_expr env arg sz cont + | _ -> comp_exit_args env args sz size cont end | Ltrywith(body, id, handler) -> let (branch1, cont1) = make_branch cont in let lbl_handler = new_label() in - Kpushtrap lbl_handler :: - comp_expr env body (sz+4) (Kpoptrap :: branch1 :: - Klabel lbl_handler :: Kpush :: - comp_expr (add_var id (sz+1) env) handler (sz+1) (add_pop 1 cont1)) + let body_cont = + Kpoptrap :: branch1 :: + Klabel lbl_handler :: Kpush :: + comp_expr (add_var id (sz+1) env) handler (sz+1) (add_pop 1 cont1) + in + try_blocks := sz :: !try_blocks; + let l = comp_expr env body (sz+4) body_cont in + try_blocks := List.tl !try_blocks; + Kpushtrap lbl_handler :: l | Lifthenelse(cond, ifso, ifnot) -> comp_binary_test env cond ifso ifnot sz cont | Lsequence(exp1, exp2) -> @@ -699,10 +718,11 @@ let rec comp_expr env exp sz cont = | Lswitch(arg, sw) -> let (branch, cont1) = make_branch cont in let c = ref (discard_dead_code cont1) in + (* Build indirection vectors *) - let store = mk_store Lambda.same in - let act_consts = Array.create sw.sw_numconsts 0 - and act_blocks = Array.create sw.sw_numblocks 0 in + let store = Storer.mk_store () in + let act_consts = Array.make sw.sw_numconsts 0 + and act_blocks = Array.make sw.sw_numblocks 0 in begin match sw.sw_failaction with (* default is index 0 *) | Some fail -> ignore (store.act_store fail) | None -> () @@ -713,7 +733,18 @@ let rec comp_expr env exp sz cont = (fun (n, act) -> act_blocks.(n) <- store.act_store act) sw.sw_blocks; (* Compile and label actions *) let acts = store.act_get () in - let lbls = Array.create (Array.length acts) 0 in +(* + let a = store.act_get_shared () in + Array.iter + (function + | Switch.Shared (Lstaticraise _) -> () + | Switch.Shared act -> + Printlambda.lambda Format.str_formatter act ; + Printf.eprintf "SHARE BYTE:\n%s\n" (Format.flush_str_formatter ()) + | _ -> ()) + a ; +*) + let lbls = Array.make (Array.length acts) 0 in for i = Array.length acts-1 downto 0 do let lbl,c1 = label_code (comp_expr env acts.(i) sz (branch :: !c)) in lbls.(i) <- lbl ; @@ -721,11 +752,11 @@ let rec comp_expr env exp sz cont = done ; (* Build label vectors *) - let lbl_blocks = Array.create sw.sw_numblocks 0 in + let lbl_blocks = Array.make sw.sw_numblocks 0 in for i = sw.sw_numblocks - 1 downto 0 do lbl_blocks.(i) <- lbls.(act_blocks.(i)) done; - let lbl_consts = Array.create sw.sw_numconsts 0 in + let lbl_consts = Array.make sw.sw_numconsts 0 in for i = sw.sw_numconsts - 1 downto 0 do lbl_consts.(i) <- lbls.(act_consts.(i)) done; @@ -903,3 +934,10 @@ let compile_phrase expr = let init_code = comp_block empty_env expr 1 [Kreturn 1] in let fun_code = comp_remainder [] in (init_code, fun_code) + +let reset () = + label_counter := 0; + sz_static_raises := []; + compunit_name := ""; + Stack.clear functions_to_compile; + max_stack_used := 0 diff --git a/bytecomp/bytegen.mli b/bytecomp/bytegen.mli index 3c24cc8e8..24f1d64f3 100644 --- a/bytecomp/bytegen.mli +++ b/bytecomp/bytegen.mli @@ -17,3 +17,4 @@ open Instruct val compile_implementation: string -> lambda -> instruction list val compile_phrase: lambda -> instruction list * instruction list +val reset: unit -> unit diff --git a/bytecomp/bytelibrarian.ml b/bytecomp/bytelibrarian.ml index c63cf80ec..7c96dfd0e 100644 --- a/bytecomp/bytelibrarian.ml +++ b/bytecomp/bytelibrarian.ml @@ -60,7 +60,7 @@ let copy_object_file ppf oc name = raise(Error(File_not_found name)) in let ic = open_in_bin file_name in try - let buffer = input_bytes ic (String.length cmo_magic_number) in + let buffer = really_input_string ic (String.length cmo_magic_number) in if buffer = cmo_magic_number then begin let compunit_pos = input_binary_int ic in seek_in ic compunit_pos; @@ -124,3 +124,8 @@ let () = | Error err -> Some (Location.error_of_printer_file report_error err) | _ -> None ) + +let reset () = + lib_ccobjs := []; + lib_ccopts := []; + lib_dllibs := [] diff --git a/bytecomp/bytelibrarian.mli b/bytecomp/bytelibrarian.mli index 757874cb4..b9a4ced84 100644 --- a/bytecomp/bytelibrarian.mli +++ b/bytecomp/bytelibrarian.mli @@ -30,3 +30,5 @@ exception Error of error open Format val report_error: formatter -> error -> unit + +val reset: unit -> unit diff --git a/bytecomp/bytelink.ml b/bytecomp/bytelink.ml index 75db3533c..c0f8f6a93 100644 --- a/bytecomp/bytelink.ml +++ b/bytecomp/bytelink.ml @@ -113,7 +113,7 @@ let scan_file obj_name tolink = raise(Error(File_not_found obj_name)) in let ic = open_in_bin file_name in try - let buffer = input_bytes ic (String.length cmo_magic_number) in + let buffer = really_input_string ic (String.length cmo_magic_number) in if buffer = cmo_magic_number then begin (* This is a .cmo file. It must be linked in any case. Read the relocation information to see which modules it @@ -158,15 +158,20 @@ let scan_file obj_name tolink = (* Consistency check between interfaces *) let crc_interfaces = Consistbl.create () +let interfaces = ref ([] : string list) let implementations_defined = ref ([] : (string * string) list) let check_consistency ppf file_name cu = begin try List.iter - (fun (name, crc) -> - if name = cu.cu_name - then Consistbl.set crc_interfaces name crc file_name - else Consistbl.check crc_interfaces name crc file_name) + (fun (name, crco) -> + interfaces := name :: !interfaces; + match crco with + None -> () + | Some crc -> + if name = cu.cu_name + then Consistbl.set crc_interfaces name crc file_name + else Consistbl.check crc_interfaces name crc file_name) cu.cu_imports with Consistbl.Inconsistency(name, user, auth) -> raise(Error(Inconsistent_import(name, user, auth))) @@ -183,7 +188,11 @@ let check_consistency ppf file_name cu = (cu.cu_name, file_name) :: !implementations_defined let extract_crc_interfaces () = - Consistbl.extract crc_interfaces + Consistbl.extract !interfaces crc_interfaces + +let clear_crc_interfaces () = + Consistbl.clear crc_interfaces; + interfaces := [] (* Record compilation events *) @@ -256,7 +265,7 @@ let output_debug_info oc = List.iter (fun (ofs, evl) -> output_binary_int oc ofs; - Array.iter (output_string oc) evl) + Array.iter (output_bytes oc) evl) !debug_info; debug_info := [] @@ -307,7 +316,7 @@ let link_bytecode ppf tolink exec_name standalone = (* The bytecode *) let start_code = pos_out outchan in Symtable.init(); - Consistbl.clear crc_interfaces; + clear_crc_interfaces (); let sharedobjs = List.map Dll.extract_dll_name !Clflags.dllibs in let check_dlls = standalone && Config.target = Config.host in if check_dlls then begin @@ -317,7 +326,7 @@ let link_bytecode ppf tolink exec_name standalone = try Dll.open_dlls Dll.For_checking sharedobjs with Failure reason -> raise(Error(Cannot_open_dll reason)) end; - let output_fun = output_string outchan + let output_fun = output_bytes outchan and currpos_fun () = pos_out outchan - start_code in List.iter (link_file ppf output_fun currpos_fun) tolink; if check_dlls then Dll.close_all_dlls(); @@ -371,12 +380,12 @@ let output_code_string_counter = ref 0 let output_code_string outchan code = let pos = ref 0 in - let len = String.length code in + let len = Bytes.length code in while !pos < len do - let c1 = Char.code(code.[!pos]) in - let c2 = Char.code(code.[!pos + 1]) in - let c3 = Char.code(code.[!pos + 2]) in - let c4 = Char.code(code.[!pos + 3]) in + let c1 = Char.code(Bytes.get code !pos) in + let c2 = Char.code(Bytes.get code (!pos + 1)) in + let c3 = Char.code(Bytes.get code (!pos + 2)) in + let c4 = Char.code(Bytes.get code (!pos + 3)) in pos := !pos + 4; Printf.fprintf outchan "0x%02x%02x%02x%02x, " c4 c3 c2 c1; incr output_code_string_counter; @@ -440,11 +449,11 @@ let link_bytecode_as_c ppf tolink outfile = \n char **argv);\n"; output_string outchan "static int caml_code[] = {\n"; Symtable.init(); - Consistbl.clear crc_interfaces; + clear_crc_interfaces (); let currpos = ref 0 in let output_fun code = output_code_string outchan code; - currpos := !currpos + String.length code + currpos := !currpos + Bytes.length code and currpos_fun () = !currpos in List.iter (link_file ppf output_fun currpos_fun) tolink; (* The final STOP instruction *) @@ -629,3 +638,13 @@ let () = | Error err -> Some (Location.error_of_printer_file report_error err) | _ -> None ) + +let reset () = + lib_ccobjs := []; + lib_ccopts := []; + lib_dllibs := []; + missing_globals := IdentSet.empty; + Consistbl.clear crc_interfaces; + implementations_defined := []; + debug_info := []; + output_code_string_counter := 0 diff --git a/bytecomp/bytelink.mli b/bytecomp/bytelink.mli index 6e123c3f5..37dad2b52 100644 --- a/bytecomp/bytelink.mli +++ b/bytecomp/bytelink.mli @@ -13,11 +13,12 @@ (* Link .cmo files and produce a bytecode executable. *) val link : Format.formatter -> string list -> string -> unit +val reset : unit -> unit val check_consistency: Format.formatter -> string -> Cmo_format.compilation_unit -> unit -val extract_crc_interfaces: unit -> (string * Digest.t) list +val extract_crc_interfaces: unit -> (string * Digest.t option) list type error = File_not_found of string diff --git a/bytecomp/bytepackager.ml b/bytecomp/bytepackager.ml index 9c9c1b842..3348f46dc 100644 --- a/bytecomp/bytepackager.ml +++ b/bytecomp/bytepackager.ml @@ -17,6 +17,8 @@ open Misc open Instruct open Cmo_format +module StringSet = Set.Make(String) + type error = Forward_reference of string * Ident.t | Multiple_definition of string * Ident.t @@ -30,6 +32,7 @@ exception Error of error let relocs = ref ([] : (reloc_info * int) list) let events = ref ([] : debug_event list) +let debug_dirs = ref StringSet.empty let primitives = ref ([] : string list) let force_link = ref false @@ -98,7 +101,9 @@ let read_member_info file = ( if Filename.check_suffix file ".cmo" then begin let ic = open_in_bin file in try - let buffer = input_bytes ic (String.length Config.cmo_magic_number) in + let buffer = + really_input_string ic (String.length Config.cmo_magic_number) + in if buffer <> Config.cmo_magic_number then raise(Error(Not_an_object_file file)); let compunit_pos = input_binary_int ic in @@ -137,6 +142,10 @@ let rename_append_bytecode ppf packagename oc mapping defined ofs prefix subst if !Clflags.debug && compunit.cu_debug > 0 then begin seek_in ic compunit.cu_debug; List.iter (relocate_debug ofs prefix subst) (input_value ic); + debug_dirs := List.fold_left + (fun s e -> StringSet.add e s) + !debug_dirs + (input_value ic); end; close_in ic; compunit.cu_codesize @@ -215,6 +224,7 @@ let package_object_files ppf files targetfile targetname coercion = let pos_debug = pos_out oc in if !Clflags.debug && !events <> [] then output_value oc (List.rev !events); + output_value oc (StringSet.elements !debug_dirs); let pos_final = pos_out oc in let imports = List.filter @@ -225,7 +235,8 @@ let package_object_files ppf files targetfile targetname coercion = cu_pos = pos_code; cu_codesize = pos_debug - pos_code; cu_reloc = List.rev !relocs; - cu_imports = (targetname, Env.crc_of_unit targetname) :: imports; + cu_imports = + (targetname, Some (Env.crc_of_unit targetname)) :: imports; cu_primitives = !primitives; cu_force_link = !force_link; cu_debug = if pos_final > pos_debug then pos_debug else 0; @@ -240,7 +251,7 @@ let package_object_files ppf files targetfile targetname coercion = (* The entry point *) -let package_files ppf files targetfile = +let package_files ppf initial_env files targetfile = let files = List.map (fun f -> @@ -251,11 +262,12 @@ let package_files ppf files targetfile = let targetcmi = prefix ^ ".cmi" in let targetname = String.capitalize(Filename.basename prefix) in try - let coercion = Typemod.package_units files targetcmi targetname in - let ret = package_object_files ppf files targetfile targetname coercion in - ret - with x -> - remove_file targetfile; raise x + let coercion = + Typemod.package_units initial_env files targetcmi targetname in + let ret = package_object_files ppf files targetfile targetname coercion in + ret + with x -> + remove_file targetfile; raise x (* Error report *) @@ -285,3 +297,9 @@ let () = | Error err -> Some (Location.error_of_printer_file report_error err) | _ -> None ) + +let reset () = + relocs := []; + events := []; + primitives := []; + force_link := false diff --git a/bytecomp/bytepackager.mli b/bytecomp/bytepackager.mli index 04de0726a..69e3c77ac 100644 --- a/bytecomp/bytepackager.mli +++ b/bytecomp/bytepackager.mli @@ -13,7 +13,7 @@ (* "Package" a set of .cmo files into one .cmo file having the original compilation units as sub-modules. *) -val package_files: Format.formatter -> string list -> string -> unit +val package_files: Format.formatter -> Env.t -> string list -> string -> unit type error = Forward_reference of string * Ident.t @@ -25,3 +25,4 @@ type error = exception Error of error val report_error: Format.formatter -> error -> unit +val reset: unit -> unit diff --git a/bytecomp/bytesections.ml b/bytecomp/bytesections.ml index 5af3bc523..759bde3b2 100644 --- a/bytecomp/bytesections.ml +++ b/bytecomp/bytesections.ml @@ -46,12 +46,14 @@ let read_toc ic = let pos_trailer = in_channel_length ic - 16 in seek_in ic pos_trailer; let num_sections = input_binary_int ic in - let header = Misc.input_bytes ic (String.length Config.exec_magic_number) in + let header = + really_input_string ic (String.length Config.exec_magic_number) + in if header <> Config.exec_magic_number then raise Bad_magic_number; seek_in ic (pos_trailer - 8 * num_sections); section_table := []; for _i = 1 to num_sections do - let name = Misc.input_bytes ic 4 in + let name = really_input_string ic 4 in let len = input_binary_int ic in section_table := (name, len) :: !section_table done @@ -77,7 +79,7 @@ let seek_section ic name = (* Return the contents of a section, as a string *) let read_section_string ic name = - Misc.input_bytes ic (seek_section ic name) + really_input_string ic (seek_section ic name) (* Return the contents of a section, as marshalled data *) @@ -90,3 +92,7 @@ let read_section_struct ic name = let pos_first_section ic = in_channel_length ic - 16 - 8 * List.length !section_table - List.fold_left (fun total (name, len) -> total + len) 0 !section_table + +let reset () = + section_table := []; + section_beginning := 0 diff --git a/bytecomp/bytesections.mli b/bytecomp/bytesections.mli index b9639c1fa..12e679d73 100644 --- a/bytecomp/bytesections.mli +++ b/bytecomp/bytesections.mli @@ -50,3 +50,5 @@ val read_section_struct: in_channel -> string -> 'a val pos_first_section: in_channel -> int (* Return the position of the beginning of the first section *) + +val reset: unit -> unit diff --git a/bytecomp/cmo_format.mli b/bytecomp/cmo_format.mli index abf4f1af3..0c0f08f08 100644 --- a/bytecomp/cmo_format.mli +++ b/bytecomp/cmo_format.mli @@ -27,7 +27,8 @@ type compilation_unit = mutable cu_pos: int; (* Absolute position in file *) cu_codesize: int; (* Size of code block *) cu_reloc: (reloc_info * int) list; (* Relocation information *) - cu_imports: (string * Digest.t) list; (* Names and CRC of intfs imported *) + cu_imports: + (string * Digest.t option) list; (* Names and CRC of intfs imported *) cu_primitives: string list; (* Primitives declared inside *) mutable cu_force_link: bool; (* Must be linked even if unref'ed *) mutable cu_debug: int; (* Position of debugging info, or 0 *) diff --git a/bytecomp/dll.ml b/bytecomp/dll.ml index 5c62b9edc..21688e08e 100644 --- a/bytecomp/dll.ml +++ b/bytecomp/dll.ml @@ -173,3 +173,9 @@ let init_toplevel dllpath = opened_dlls := Array.to_list (get_current_dlls()); names_of_opened_dlls := []; linking_in_core := true + +let reset () = + search_path := []; + opened_dlls :=[]; + names_of_opened_dlls := []; + linking_in_core := false diff --git a/bytecomp/dll.mli b/bytecomp/dll.mli index 975315e26..878ffb919 100644 --- a/bytecomp/dll.mli +++ b/bytecomp/dll.mli @@ -59,3 +59,5 @@ val init_compile: bool -> unit contents of ld.conf file). Take note of the DLLs that were opened when starting the running program. *) val init_toplevel: string -> unit + +val reset: unit -> unit diff --git a/bytecomp/emitcode.ml b/bytecomp/emitcode.ml index 9911de882..77df46110 100644 --- a/bytecomp/emitcode.ml +++ b/bytecomp/emitcode.ml @@ -20,6 +20,8 @@ open Instruct open Opcodes open Cmo_format +module StringSet = Set.Make(String) + (* Buffering of bytecode *) let out_buffer = ref(LongString.create 1024) @@ -80,7 +82,7 @@ let label_table = ref ([| |] : label_definition array) let extend_label_table needed = let new_size = ref(Array.length !label_table) in while needed >= !new_size do new_size := 2 * !new_size done; - let new_table = Array.create !new_size (Label_undefined []) in + let new_table = Array.make !new_size (Label_undefined []) in Array.blit !label_table 0 new_table 0 (Array.length !label_table); label_table := new_table @@ -135,8 +137,12 @@ and slot_for_c_prim name = (* Debugging events *) let events = ref ([] : debug_event list) +let debug_dirs = ref StringSet.empty let record_event ev = + let path = ev.ev_loc.Location.loc_start.Lexing.pos_fname in + let abspath = Location.absolute_path path in + debug_dirs := StringSet.add (Filename.dirname abspath) !debug_dirs; ev.ev_pos <- !out_position; events := ev :: !events @@ -144,8 +150,9 @@ let record_event ev = let init () = out_position := 0; - label_table := Array.create 16 (Label_undefined []); + label_table := Array.make 16 (Label_undefined []); reloc_info := []; + debug_dirs := StringSet.empty; events := [] (* Emission of one instruction *) @@ -353,7 +360,7 @@ let rec emit = function (* Emission to a file *) -let to_file outchan unit_name code = +let to_file outchan unit_name objfile code = init(); output_string outchan cmo_magic_number; let pos_depl = pos_out outchan in @@ -363,8 +370,12 @@ let to_file outchan unit_name code = LongString.output outchan !out_buffer 0 !out_position; let (pos_debug, size_debug) = if !Clflags.debug then begin + debug_dirs := StringSet.add + (Filename.dirname (Location.absolute_path objfile)) + !debug_dirs; let p = pos_out outchan in output_value outchan !events; + output_value outchan (StringSet.elements !debug_dirs); (p, pos_out outchan - p) end else (0, 0) in @@ -373,7 +384,7 @@ let to_file outchan unit_name code = cu_pos = pos_code; cu_codesize = !out_position; cu_reloc = List.rev !reloc_info; - cu_imports = Env.imported_units(); + cu_imports = Env.imports(); cu_primitives = List.map Primitive.byte_name !Translmod.primitive_declarations; cu_force_link = false; @@ -394,7 +405,7 @@ let to_memory init_code fun_code = emit init_code; emit fun_code; let code = Meta.static_alloc !out_position in - LongString.unsafe_blit_to_string !out_buffer 0 code 0 !out_position; + LongString.unsafe_blit_to_bytes !out_buffer 0 code 0 !out_position; let reloc = List.rev !reloc_info and code_size = !out_position in init(); @@ -409,3 +420,9 @@ let to_packed_file outchan code = let reloc = !reloc_info in init(); reloc + +let reset () = + out_buffer := LongString.create 1024; + out_position := 0; + label_table := [| |]; + reloc_info := [] diff --git a/bytecomp/emitcode.mli b/bytecomp/emitcode.mli index 60d791434..e2fdb8155 100644 --- a/bytecomp/emitcode.mli +++ b/bytecomp/emitcode.mli @@ -15,13 +15,14 @@ open Cmo_format open Instruct -val to_file: out_channel -> string -> instruction list -> unit +val to_file: out_channel -> string -> string -> instruction list -> unit (* Arguments: channel on output file name of compilation unit implemented + path of cmo file being written list of instructions to emit *) val to_memory: instruction list -> instruction list -> - string * int * (reloc_info * int) list + bytes * int * (reloc_info * int) list (* Arguments: initialization code (terminated by STOP) function code @@ -36,3 +37,5 @@ val to_packed_file: list of instructions to emit Result: relocation information (reversed) *) + +val reset: unit -> unit diff --git a/bytecomp/lambda.ml b/bytecomp/lambda.ml index 83c00a32d..4ad8e9b4e 100644 --- a/bytecomp/lambda.ml +++ b/bytecomp/lambda.ml @@ -21,11 +21,19 @@ type compile_time_constant = | Ostype_win32 | Ostype_cygwin +type loc_kind = + | Loc_FILE + | Loc_LINE + | Loc_MODULE + | Loc_LOC + | Loc_POS + type primitive = Pidentity | Pignore | Prevapply of Location.t | Pdirapply of Location.t + | Ploc of loc_kind (* Globals *) | Pgetglobal of Ident.t | Psetglobal of Ident.t @@ -113,6 +121,8 @@ type primitive = (* byte swap *) | Pbswap16 | Pbbswap of boxed_integer + (* Integer to external pointer *) + | Pint_as_pointer and comparison = Ceq | Cneq | Clt | Cgt | Cle | Cge @@ -166,7 +176,7 @@ type lambda = | Lletrec of (Ident.t * lambda) list * lambda | Lprim of primitive * lambda list | Lswitch of lambda * lambda_switch - | Lstringswitch of lambda * (string * lambda) list * lambda + | Lstringswitch of lambda * (string * lambda) list * lambda option | Lstaticraise of int * lambda list | Lstaticcatch of lambda * (int * Ident.t list) * lambda | Ltrywith of lambda * Ident.t * lambda @@ -201,65 +211,91 @@ let const_unit = Const_pointer 0 let lambda_unit = Lconst const_unit -let rec same l1 l2 = - match (l1, l2) with - | Lvar v1, Lvar v2 -> - Ident.same v1 v2 - | Lconst (Const_base (Const_string _)), _ -> - false (* do not share strings *) - | Lconst c1, Lconst c2 -> - c1 = c2 - | Lapply(a1, bl1, _), Lapply(a2, bl2, _) -> - same a1 a2 && samelist same bl1 bl2 - | Lfunction(k1, idl1, a1), Lfunction(k2, idl2, a2) -> - k1 = k2 && samelist Ident.same idl1 idl2 && same a1 a2 - | Llet(k1, id1, a1, b1), Llet(k2, id2, a2, b2) -> - k1 = k2 && Ident.same id1 id2 && same a1 a2 && same b1 b2 - | Lletrec (bl1, a1), Lletrec (bl2, a2) -> - samelist samebinding bl1 bl2 && same a1 a2 - | Lprim(p1, al1), Lprim(p2, al2) -> - p1 = p2 && samelist same al1 al2 - | Lswitch(a1, s1), Lswitch(a2, s2) -> - same a1 a2 && sameswitch s1 s2 - | Lstaticraise(n1, al1), Lstaticraise(n2, al2) -> - n1 = n2 && samelist same al1 al2 - | Lstaticcatch(a1, (n1, idl1), b1), Lstaticcatch(a2, (n2, idl2), b2) -> - same a1 a2 && n1 = n2 && samelist Ident.same idl1 idl2 && same b1 b2 - | Ltrywith(a1, id1, b1), Ltrywith(a2, id2, b2) -> - same a1 a2 && Ident.same id1 id2 && same b1 b2 - | Lifthenelse(a1, b1, c1), Lifthenelse(a2, b2, c2) -> - same a1 a2 && same b1 b2 && same c1 c2 - | Lsequence(a1, b1), Lsequence(a2, b2) -> - same a1 a2 && same b1 b2 - | Lwhile(a1, b1), Lwhile(a2, b2) -> - same a1 a2 && same b1 b2 - | Lfor(id1, a1, b1, df1, c1), Lfor(id2, a2, b2, df2, c2) -> - Ident.same id1 id2 && same a1 a2 && - same b1 b2 && df1 = df2 && same c1 c2 - | Lassign(id1, a1), Lassign(id2, a2) -> - Ident.same id1 id2 && same a1 a2 - | Lsend(k1, a1, b1, cl1, _), Lsend(k2, a2, b2, cl2, _) -> - k1 = k2 && same a1 a2 && same b1 b2 && samelist same cl1 cl2 - | Levent(a1, ev1), Levent(a2, ev2) -> - same a1 a2 && ev1.lev_loc = ev2.lev_loc - | Lifused(id1, a1), Lifused(id2, a2) -> - Ident.same id1 id2 && same a1 a2 - | _, _ -> - false - -and samebinding (id1, c1) (id2, c2) = - Ident.same id1 id2 && same c1 c2 - -and sameswitch sw1 sw2 = - let samecase (n1, a1) (n2, a2) = n1 = n2 && same a1 a2 in - sw1.sw_numconsts = sw2.sw_numconsts && - sw1.sw_numblocks = sw2.sw_numblocks && - samelist samecase sw1.sw_consts sw2.sw_consts && - samelist samecase sw1.sw_blocks sw2.sw_blocks && - (match (sw1.sw_failaction, sw2.sw_failaction) with - | (None, None) -> true - | (Some a1, Some a2) -> same a1 a2 - | _ -> false) +(* Build sharing keys *) +(* + Those keys are later compared with Pervasives.compare. + For that reason, they should not include cycles. +*) + +exception Not_simple + +let max_raw = 32 + +let make_key e = + let count = ref 0 (* Used for controling size *) + and make_key = Ident.make_key_generator () in + (* make_key is used for normalizing let-bound variables *) + let rec tr_rec env e = + incr count ; + if !count > max_raw then raise Not_simple ; (* Too big ! *) + match e with + | Lvar id -> + begin + try Ident.find_same id env + with Not_found -> e + end + | Lconst (Const_base (Const_string _)|Const_float_array _) -> + (* Mutable constants are not shared *) + raise Not_simple + | Lconst _ -> e + | Lapply (e,es,loc) -> + Lapply (tr_rec env e,tr_recs env es,Location.none) + | Llet (Alias,x,ex,e) -> (* Ignore aliases -> substitute *) + let ex = tr_rec env ex in + tr_rec (Ident.add x ex env) e + | Llet (str,x,ex,e) -> + (* Because of side effects, keep other lets with normalized names *) + let ex = tr_rec env ex in + let y = make_key x in + Llet (str,y,ex,tr_rec (Ident.add x (Lvar y) env) e) + | Lprim (p,es) -> + Lprim (p,tr_recs env es) + | Lswitch (e,sw) -> + Lswitch (tr_rec env e,tr_sw env sw) + | Lstringswitch (e,sw,d) -> + Lstringswitch + (tr_rec env e, + List.map (fun (s,e) -> s,tr_rec env e) sw, + tr_opt env d) + | Lstaticraise (i,es) -> + Lstaticraise (i,tr_recs env es) + | Lstaticcatch (e1,xs,e2) -> + Lstaticcatch (tr_rec env e1,xs,tr_rec env e2) + | Ltrywith (e1,x,e2) -> + Ltrywith (tr_rec env e1,x,tr_rec env e2) + | Lifthenelse (cond,ifso,ifnot) -> + Lifthenelse (tr_rec env cond,tr_rec env ifso,tr_rec env ifnot) + | Lsequence (e1,e2) -> + Lsequence (tr_rec env e1,tr_rec env e2) + | Lassign (x,e) -> + Lassign (x,tr_rec env e) + | Lsend (m,e1,e2,es,loc) -> + Lsend (m,tr_rec env e1,tr_rec env e2,tr_recs env es,Location.none) + | Lifused (id,e) -> Lifused (id,tr_rec env e) + | Lletrec _|Lfunction _ + | Lfor _ | Lwhile _ +(* Beware: (PR#6412) the event argument to Levent + may include cyclic structure of type Type.typexpr *) + | Levent _ -> + raise Not_simple + + and tr_recs env es = List.map (tr_rec env) es + + and tr_sw env sw = + { sw with + sw_consts = List.map (fun (i,e) -> i,tr_rec env e) sw.sw_consts ; + sw_blocks = List.map (fun (i,e) -> i,tr_rec env e) sw.sw_blocks ; + sw_failaction = tr_opt env sw.sw_failaction ; } + + and tr_opt env = function + | None -> None + | Some e -> Some (tr_rec env e) in + + try + Some (tr_rec Ident.empty e) + with Not_simple -> None + +(***************) let name_lambda strict arg fn = match arg with @@ -276,6 +312,11 @@ let name_lambda_list args fn = Llet(Strict, id, arg, name_list (Lvar id :: names) rem) in name_list [] args + +let iter_opt f = function + | None -> () + | Some e -> f e + let iter f = function Lvar _ | Lconst _ -> () @@ -294,14 +335,11 @@ let iter f = function f arg; List.iter (fun (key, case) -> f case) sw.sw_consts; List.iter (fun (key, case) -> f case) sw.sw_blocks; - begin match sw.sw_failaction with - | None -> () - | Some l -> f l - end + iter_opt f sw.sw_failaction | Lstringswitch (arg,cases,default) -> f arg ; List.iter (fun (_,act) -> f act) cases ; - f default + iter_opt f default | Lstaticraise (_,args) -> List.iter f args | Lstaticcatch(e1, (_,vars), e2) -> @@ -325,6 +363,7 @@ let iter f = function | Lifused (v, e) -> f e + module IdentSet = Set.Make(struct type t = Ident.t @@ -370,6 +409,12 @@ let next_raise_count () = incr raise_count ; !raise_count +let negative_raise_count = ref 0 + +let next_negative_raise_count () = + decr negative_raise_count ; + !negative_raise_count + (* Anticipated staticraise, for guards *) let staticfail = Lstaticraise (0,[]) @@ -401,7 +446,7 @@ let rec transl_normal_path = function (* Translation of value identifiers *) let transl_path ?(loc=Location.none) env path = - transl_normal_path (Env.normalize_path (Some loc) env path) + transl_normal_path (Env.normalize_path (Some loc) env path) (* Compile a sequence of expressions *) @@ -431,13 +476,10 @@ let subst_lambda s lam = Lswitch(subst arg, {sw with sw_consts = List.map subst_case sw.sw_consts; sw_blocks = List.map subst_case sw.sw_blocks; - sw_failaction = - match sw.sw_failaction with - | None -> None - | Some l -> Some (subst l)}) + sw_failaction = subst_opt sw.sw_failaction; }) | Lstringswitch (arg,cases,default) -> Lstringswitch - (subst arg,List.map subst_strcase cases,subst default) + (subst arg,List.map subst_strcase cases,subst_opt default) | Lstaticraise (i,args) -> Lstaticraise (i, List.map subst args) | Lstaticcatch(e1, io, e2) -> Lstaticcatch(subst e1, io, subst e2) | Ltrywith(e1, exn, e2) -> Ltrywith(subst e1, exn, subst e2) @@ -453,6 +495,9 @@ let subst_lambda s lam = and subst_decl (id, exp) = (id, subst exp) and subst_case (key, case) = (key, subst case) and subst_strcase (key, case) = (key, subst case) + and subst_opt = function + | None -> None + | Some e -> Some (subst e) in subst lam @@ -477,3 +522,29 @@ let raise_kind = function | Raise_regular -> "raise" | Raise_reraise -> "reraise" | Raise_notrace -> "raise_notrace" + +let lam_of_loc kind loc = + let loc_start = loc.Location.loc_start in + let (file, lnum, cnum) = Location.get_pos_info loc_start in + let enum = loc.Location.loc_end.Lexing.pos_cnum - + loc_start.Lexing.pos_cnum + cnum in + match kind with + | Loc_POS -> + Lconst (Const_block (0, [ + Const_immstring file; + Const_base (Const_int lnum); + Const_base (Const_int cnum); + Const_base (Const_int enum); + ])) + | Loc_FILE -> Lconst (Const_immstring file) + | Loc_MODULE -> Lconst (Const_immstring + (String.capitalize + (Filename.chop_extension (Filename.basename file)))) + | Loc_LOC -> + let loc = Printf.sprintf "File %S, line %d, characters %d-%d" + file lnum cnum enum in + Lconst (Const_immstring loc) + | Loc_LINE -> Lconst (Const_base (Const_int lnum)) + +let reset () = + raise_count := 0 diff --git a/bytecomp/lambda.mli b/bytecomp/lambda.mli index 6748fefe1..0e038d93d 100644 --- a/bytecomp/lambda.mli +++ b/bytecomp/lambda.mli @@ -21,11 +21,19 @@ type compile_time_constant = | Ostype_win32 | Ostype_cygwin +type loc_kind = + | Loc_FILE + | Loc_LINE + | Loc_MODULE + | Loc_LOC + | Loc_POS + type primitive = Pidentity | Pignore | Prevapply of Location.t | Pdirapply of Location.t + | Ploc of loc_kind (* Globals *) | Pgetglobal of Ident.t | Psetglobal of Ident.t @@ -113,6 +121,8 @@ type primitive = (* byte swap *) | Pbswap16 | Pbbswap of boxed_integer + (* Integer to external pointer *) + | Pint_as_pointer and comparison = Ceq | Cneq | Clt | Cgt | Cle | Cge @@ -177,7 +187,7 @@ type lambda = | Lswitch of lambda * lambda_switch (* switch on strings, clauses are sorted by string order, strings are pairwise distinct *) - | Lstringswitch of lambda * (string * lambda) list * lambda + | Lstringswitch of lambda * (string * lambda) list * lambda option | Lstaticraise of int * lambda list | Lstaticcatch of lambda * (int * Ident.t list) * lambda | Ltrywith of lambda * Ident.t * lambda @@ -207,7 +217,9 @@ and lambda_event_kind = | Lev_after of Types.type_expr | Lev_function -val same: lambda -> lambda -> bool +(* Sharing key *) +val make_key: lambda -> lambda option + val const_unit: structured_constant val lambda_unit: lambda val name_lambda: let_kind -> lambda -> (Ident.t -> lambda) -> lambda @@ -234,7 +246,11 @@ val negate_comparison : comparison -> comparison (* Get a new static failure ident *) val next_raise_count : unit -> int - +val next_negative_raise_count : unit -> int + (* Negative raise counts are used to compile 'match ... with + exception x -> ...'. This disabled some simplifications + performed by the Simplif module that assume that static raises + are in tail position in their handler. *) val staticfail : lambda (* Anticipated static failure *) @@ -243,3 +259,6 @@ val is_guarded: lambda -> bool val patch_guarded : lambda -> lambda -> lambda val raise_kind: raise_kind -> string +val lam_of_loc : loc_kind -> Location.t -> lambda + +val reset: unit -> unit diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml index 3ec3611ba..cba32391e 100644 --- a/bytecomp/matching.ml +++ b/bytecomp/matching.ml @@ -21,6 +21,7 @@ open Lambda open Parmatch open Printf + let dbg = false (* See Peyton-Jones, ``The Implementation of functional programming @@ -40,6 +41,10 @@ let dbg = false - Jump summaries: mapping from exit numbers to contexts *) +let string_of_lam lam = + Printlambda.lambda Format.str_formatter lam ; + Format.flush_str_formatter () + type matrix = pattern list list let add_omega_column pss = List.map (fun ps -> omega::ps) pss @@ -164,7 +169,7 @@ let ctx_matcher p = match p.pat_desc with | Tpat_construct (_, cstr,omegas) -> begin match cstr.cstr_tag with - | Cstr_exception _ -> (* exception matching *) + | Cstr_extension _ -> let nargs = List.length omegas in (fun q rem -> match q.pat_desc with | Tpat_construct (_, cstr',args) @@ -443,68 +448,97 @@ let pretty_precompiled_res first nexts = -(* A slight attempt to identify semantically equivalent lambda-expressions, - We could have used Lambda.same, but our goal here is also to +(* Identifing some semantically equivalent lambda-expressions, + Our goal here is also to find alpha-equivalent (simple) terms *) -exception Not_simple -let rec raw_rec env : lambda -> lambda = function - | Llet(Alias,x,ex, body) -> raw_rec ((x,raw_rec env ex)::env) body - | Lvar id as l -> - begin try List.assoc id env with - | Not_found -> l - end - | Lprim (Pfield i,args) -> - Lprim (Pfield i, List.map (raw_rec env) args) - | Lconst (Const_base (Const_string _)) -> - raise Not_simple (* do not share strings *) - | Lconst _ as l -> l - | Lstaticraise (i,args) -> - Lstaticraise (i, List.map (raw_rec env) args) - | _ -> raise Not_simple +(* However, as shown by PR#6359 such sharing may hinders the + lambda-code invariant that all bound idents are unique, + when switchs are compiled to test sequences. + The definitive fix is the systematic introduction of exit/catch + in case action sharing is present. +*) + + +module StoreExp = + Switch.Store + (struct + type t = lambda + type key = lambda + let make_key = Lambda.make_key + end) + + +let make_exit i = Lstaticraise (i,[]) + +(* Introduce a catch, if worth it *) +let make_catch d k = match d with +| Lstaticraise (_,[]) -> k d +| _ -> + let e = next_raise_count () in + Lstaticcatch (k (make_exit e),(e,[]),d) + +(* Introduce a catch, if worth it, delayed version *) +let rec as_simple_exit = function + | Lstaticraise (i,[]) -> Some i + | Llet (Alias,_,_,e) -> as_simple_exit e + | _ -> None + -let raw_action l = try raw_rec [] l with Not_simple -> l +let make_catch_delayed handler = match as_simple_exit handler with +| Some i -> i,(fun act -> act) +| None -> + let i = next_raise_count () in +(* + Printf.eprintf "SHARE LAMBDA: %i\n%s\n" i (string_of_lam handler); +*) + i, + (fun body -> match body with + | Lstaticraise (j,_) -> + if i=j then handler else body + | _ -> Lstaticcatch (body,(i,[]),handler)) + + +let raw_action l = + match make_key l with | Some l -> l | None -> l + + +let tr_raw act = match make_key act with +| Some act -> act +| None -> raise Exit let same_actions = function | [] -> None | [_,act] -> Some act | (_,act0) :: rem -> try - let raw_act0 = raw_rec [] act0 in + let raw_act0 = tr_raw act0 in let rec s_rec = function | [] -> Some act0 | (_,act)::rem -> - if raw_act0 = raw_rec [] act then + if raw_act0 = tr_raw act then s_rec rem else None in s_rec rem with - | Not_simple -> None + | Exit -> None -let equal_action act1 act2 = - try - let raw1 = raw_rec [] act1 - and raw2 = raw_rec [] act2 in - raw1 = raw2 - with - | Not_simple -> false (* Test for swapping two clauses *) let up_ok_action act1 act2 = try - let raw1 = raw_rec [] act1 - and raw2 = raw_rec [] act2 in - match raw1, raw2 with - | Lstaticraise (i1,[]), Lstaticraise (i2,[]) -> i1=i2 - | _,_ -> raw1 = raw2 + let raw1 = tr_raw act1 + and raw2 = tr_raw act2 in + raw1 = raw2 with - | Not_simple -> false + | Exit -> false -(* Nothing is kown about exeception patterns, because of potential rebind *) +(* Nothing is kown about exception/extension patterns, + because of potential rebind *) let rec exc_inside p = match p.pat_desc with - | Tpat_construct (_,{cstr_tag=Cstr_exception _},_) -> true + | Tpat_construct (_,{cstr_tag=Cstr_extension _},_) -> true | Tpat_any|Tpat_constant _|Tpat_var _ | Tpat_construct (_,_,[]) | Tpat_variant (_,None,_) @@ -626,7 +660,7 @@ let rec what_is_cases cases = match cases with (* A few operation on default environments *) let as_matrix cases = get_mins le_pats (List.map (fun (ps,_) -> ps) cases) -(* For exception matching, record no imformation in matrix *) +(* For extension matching, record no imformation in matrix *) let as_matrix_omega cases = get_mins le_pats (List.map @@ -902,9 +936,8 @@ let rec split_or argo cls args def = do_split [] [] [] cls -(* Ultra-naive spliting, close to semantics, - used for exception, as potential rebind prevents any kind of - optimisation *) +(* Ultra-naive spliting, close to semantics, used for extension, + as potential rebind prevents any kind of optimisation *) and split_naive cls args def k = @@ -961,7 +994,7 @@ and split_naive cls args def k = | (p::_,_ as cl)::rem -> if group_constructor p then split_exc (pat_as_constr p) [cl] rem - else + else split_noexc [cl] rem | _ -> assert false @@ -969,7 +1002,7 @@ and split_constr cls args def k = let ex_pat = what_is_cases cls in match ex_pat.pat_desc with | Tpat_any -> precompile_var args cls def k - | Tpat_construct (_,{cstr_tag=Cstr_exception _},_) -> + | Tpat_construct (_,{cstr_tag=Cstr_extension _},_) -> split_naive cls args def k | _ -> @@ -1079,7 +1112,7 @@ and dont_precompile_var args cls def k = and is_exc p = match p.pat_desc with | Tpat_or (p1,p2,_) -> is_exc p1 || is_exc p2 | Tpat_alias (p,v,_) -> is_exc p -| Tpat_construct (_,{cstr_tag = Cstr_exception _},_) -> true +| Tpat_construct (_,{cstr_tag=Cstr_extension _},_) -> true | _ -> false and precompile_or argo cls ors args def k = match ors with @@ -1315,12 +1348,12 @@ let make_constr_matching p def ctx = function | ((arg, mut) :: argl) -> let cstr = pat_as_constr p in let newargs = - if cstr.cstr_inlined then + if cstr.cstr_inlined <> None then (arg, Alias) :: argl else match cstr.cstr_tag with Cstr_constant _ | Cstr_block _ -> make_field_args Alias arg 0 (cstr.cstr_arity - 1) argl - | Cstr_exception _ -> + | Cstr_extension _ -> make_field_args Alias arg 1 cstr.cstr_arity argl in {pm= {cases = []; args = newargs; @@ -1451,7 +1484,7 @@ let get_mod_field modname field = lazy ( try let mod_ident = Ident.create_persistent modname in - let env = Env.open_pers_signature modname Env.initial in + let env = Env.open_pers_signature modname Env.initial_safe_string in let p = try match Env.lookup_value (Longident.Lident field) env with | (Path.Pdot(_,_,i), _) -> i @@ -1573,7 +1606,7 @@ let divide_tuple arity p ctx pm = let record_matching_line num_fields lbl_pat_list = - let patv = Array.create num_fields omega in + let patv = Array.make num_fields omega in List.iter (fun (_, lbl, pat) -> patv.(lbl.lbl_pos) <- pat) lbl_pat_list; Array.to_list patv @@ -1599,7 +1632,7 @@ let make_record_matching all_labels def = function match lbl.lbl_repres with Record_regular | Record_inlined _ -> Pfield lbl.lbl_pos | Record_float -> Pfloatfield lbl.lbl_pos - | Record_exception _ -> Pfield (lbl.lbl_pos + 1) + | Record_extension -> Pfield (lbl.lbl_pos + 1) in let str = match lbl.lbl_mut with @@ -1656,9 +1689,10 @@ let divide_array kind ctx pm = (make_array_matching kind) (=) get_key_array get_args_array ctx pm + (* Specific string test sequence - Will be called by the bytecode compiler, from bytegen.ml. + Will be called by the bytecode compiler, from bytegen.ml. The strategy is first dichotomic search (we perform 3-way tests with compare_string), then sequence of equality tests when there are less then T=strings_test_threshold static strings to match. @@ -1668,7 +1702,7 @@ let divide_array kind ctx pm = T=8 looks a decent tradeoff. *) -(* Utlities *) +(* Utilities *) let strings_test_threshold = 8 @@ -1687,11 +1721,18 @@ let bind_sw arg k = match arg with | _ -> let id = Ident.create "switch" in Llet (Strict,id,arg,k (Lvar id)) - - + + (* Sequential equality tests *) -let make_test_sequence arg sw d = +let make_string_test_sequence arg sw d = + let d,sw = match d with + | None -> + begin match sw with + | (_,d)::sw -> d,sw + | [] -> assert false + end + | Some d -> d,sw in bind_sw arg (fun arg -> List.fold_right @@ -1703,12 +1744,6 @@ let make_test_sequence arg sw d = k,lam)) sw d) -let catch_sw d k = match d with -| Lstaticraise (_,[]) -> k d -| _ -> - let e = next_raise_count () in - Lstaticcatch (k (Lstaticraise (e,[])),(e,[]),d) - let rec split k xs = match xs with | [] -> assert false | x0::xs -> @@ -1726,9 +1761,11 @@ let tree_way_test arg lt eq gt = (* Dichotomic tree *) -let rec do_make_tree arg sw d = + +let rec do_make_string_test_tree arg sw delta d = let len = List.length sw in - if len <= strings_test_threshold then make_test_sequence arg sw d + if len <= strings_test_threshold+delta then + make_string_test_sequence arg sw d else let lt,(s,act),gt = split len sw in bind_sw @@ -1737,17 +1774,64 @@ let rec do_make_tree arg sw d = [arg; Lconst (Const_immstring s)];)) (fun r -> tree_way_test r - (do_make_tree arg lt d) + (do_make_string_test_tree arg lt delta d) act - (do_make_tree arg gt d)) - -(* Entry point *) -let expand_stringswitch arg sw d = - bind_sw arg (fun arg -> catch_sw d (fun d -> do_make_tree arg sw d)) + (do_make_string_test_tree arg gt delta d)) -(*************************************) -(* To combine sub-matchings together *) -(*************************************) +(* Entry point *) +let expand_stringswitch arg sw d = match d with +| None -> + bind_sw arg + (fun arg -> do_make_string_test_tree arg sw 0 None) +| Some e -> + bind_sw arg + (fun arg -> + make_catch e + (fun d -> do_make_string_test_tree arg sw 1 (Some d))) + +(**********************) +(* Generic test trees *) +(**********************) + +(* Sharing *) + +(* Add handler, if shared *) +let handle_shared () = + let hs = ref (fun x -> x) in + let handle_shared act = match act with + | Switch.Single act -> act + | Switch.Shared act -> + let i,h = make_catch_delayed act in + let ohs = !hs in + hs := (fun act -> h (ohs act)) ; + make_exit i in + hs,handle_shared + + +let share_actions_tree sw d = + let store = StoreExp.mk_store () in +(* Default action is always shared *) + let d = + match d with + | None -> None + | Some d -> Some (store.Switch.act_store_shared d) in +(* Store all other actions *) + let sw = + List.map (fun (cst,act) -> cst,store.Switch.act_store act) sw in + +(* Retrieve all actions, includint potentiel default *) + let acts = store.Switch.act_get_shared () in + +(* Array of actual actions *) + let hs,handle_shared = handle_shared () in + let acts = Array.map handle_shared acts in + +(* Recontruct default and switch list *) + let d = match d with + | None -> None + | Some d -> Some (acts.(d)) in + let sw = List.map (fun (cst,j) -> cst,acts.(j)) sw in + !hs,sw,d (* Note: dichotomic search requires sorted input with no duplicates *) let rec uniq_lambda_list sw = match sw with @@ -1785,6 +1869,10 @@ let rec do_tests_nofail tst arg = function act) let make_test_sequence fail tst lt_tst arg const_lambda_list = + let const_lambda_list = sort_lambda_list const_lambda_list in + let hs,const_lambda_list,fail = + share_actions_tree const_lambda_list fail in + let rec make_test_sequence const_lambda_list = if List.length const_lambda_list >= 4 && lt_tst <> Pignore then split_sequence const_lambda_list @@ -1797,10 +1885,9 @@ let make_test_sequence fail tst lt_tst arg const_lambda_list = cut (List.length const_lambda_list / 2) const_lambda_list in Lifthenelse(Lprim(lt_tst,[arg; Lconst(Const_base (fst(List.hd list2)))]), make_test_sequence list1, make_test_sequence list2) - in make_test_sequence (sort_lambda_list const_lambda_list) - + in + hs (make_test_sequence const_lambda_list) -let make_offset x arg = if x=0 then arg else Lprim(Poffsetint(x), [arg]) let rec explode_inter offset i j act k = if i <= j then @@ -1809,7 +1896,7 @@ let rec explode_inter offset i j act k = k let max_vals cases acts = - let vals = Array.create (Array.length acts) 0 in + let vals = Array.make (Array.length acts) 0 in for i=Array.length cases-1 downto 0 do let l,h,act = cases.(i) in vals.(act) <- h - l + 1 + vals.(act) @@ -1842,65 +1929,6 @@ let as_int_list cases acts = (if default >= 0 then Some acts.(default) else None) -let make_switch_offset arg min_key max_key int_lambda_list default = - let numcases = max_key - min_key + 1 in - let cases = - List.map (fun (key, l) -> (key - min_key, l)) int_lambda_list in - let offsetarg = make_offset (-min_key) arg in - Lswitch(offsetarg, - {sw_numconsts = numcases; sw_consts = cases; - sw_numblocks = 0; sw_blocks = []; - sw_failaction = default}) - -let make_switch_switcher arg cases acts = - let l = ref [] in - for i = Array.length cases-1 downto 0 do - l := (i,acts.(cases.(i))) :: !l - done ; - Lswitch(arg, - {sw_numconsts = Array.length cases ; sw_consts = !l ; - sw_numblocks = 0 ; sw_blocks = [] ; - sw_failaction = None}) - -let full sw = - List.length sw.sw_consts = sw.sw_numconsts && - List.length sw.sw_blocks = sw.sw_numblocks - -let make_switch (arg,sw) = match sw.sw_failaction with -| None -> - let t = Hashtbl.create 17 in - let seen l = match l with - | Lstaticraise (i,[]) -> - let old = try Hashtbl.find t i with Not_found -> 0 in - Hashtbl.replace t i (old+1) - | _ -> () in - List.iter (fun (_,lam) -> seen lam) sw.sw_consts ; - List.iter (fun (_,lam) -> seen lam) sw.sw_blocks ; - let i_max = ref (-1) - and max = ref (-1) in - Hashtbl.iter - (fun i c -> - if c > !max then begin - i_max := i ; - max := c - end) t ; - if !i_max >= 0 then - let default = !i_max in - let rec remove = function - | [] -> [] - | (_,Lstaticraise (j,[]))::rem when j=default -> - remove rem - | x::rem -> x::remove rem in - Lswitch - (arg, - {sw with -sw_consts = remove sw.sw_consts ; -sw_blocks = remove sw.sw_blocks ; -sw_failaction = Some (Lstaticraise (default,[]))}) - else - Lswitch (arg,sw) -| _ -> Lswitch (arg,sw) - module SArg = struct type primitive = Lambda.primitive @@ -1917,6 +1945,7 @@ module SArg = struct let make_offset arg n = match n with | 0 -> arg | _ -> Lprim (Poffsetint n,[arg]) + let bind arg body = let newvar,newarg = match arg with | Lvar v -> v,arg @@ -1924,13 +1953,89 @@ module SArg = struct let newvar = Ident.create "switcher" in newvar,Lvar newvar in bind Alias newvar arg (body newarg) - + let make_const i = Lconst (Const_base (Const_int i)) let make_isout h arg = Lprim (Pisout, [h ; arg]) let make_isin h arg = Lprim (Pnot,[make_isout h arg]) let make_if cond ifso ifnot = Lifthenelse (cond, ifso, ifnot) - let make_switch = make_switch_switcher + let make_switch arg cases acts = + let l = ref [] in + for i = Array.length cases-1 downto 0 do + l := (i,acts.(cases.(i))) :: !l + done ; + Lswitch(arg, + {sw_numconsts = Array.length cases ; sw_consts = !l ; + sw_numblocks = 0 ; sw_blocks = [] ; + sw_failaction = None}) + let make_catch = make_catch_delayed + let make_exit = make_exit + end +(* Action sharing for Lswitch argument *) +let share_actions_sw sw = +(* Attempt sharing on all actions *) + let store = StoreExp.mk_store () in + let fail = match sw.sw_failaction with + | None -> None + | Some fail -> + (* Fail is translated to exit, whatever happens *) + Some (store.Switch.act_store_shared fail) in + let consts = + List.map + (fun (i,e) -> i,store.Switch.act_store e) + sw.sw_consts + and blocks = + List.map + (fun (i,e) -> i,store.Switch.act_store e) + sw.sw_blocks in + let acts = store.Switch.act_get_shared () in + let hs,handle_shared = handle_shared () in + let acts = Array.map handle_shared acts in + let fail = match fail with + | None -> None + | Some fail -> Some (acts.(fail)) in + !hs, + { sw with + sw_consts = List.map (fun (i,j) -> i,acts.(j)) consts ; + sw_blocks = List.map (fun (i,j) -> i,acts.(j)) blocks ; + sw_failaction = fail; } + +(* Reintroduce fail action in switch argument, + for the sake of avoiding carrying over huge switches *) + +let reintroduce_fail sw = match sw.sw_failaction with +| None -> + let t = Hashtbl.create 17 in + let seen (_,l) = match as_simple_exit l with + | Some i -> + let old = try Hashtbl.find t i with Not_found -> 0 in + Hashtbl.replace t i (old+1) + | None -> () in + List.iter seen sw.sw_consts ; + List.iter seen sw.sw_blocks ; + let i_max = ref (-1) + and max = ref (-1) in + Hashtbl.iter + (fun i c -> + if c > !max then begin + i_max := i ; + max := c + end) t ; + if !max >= 3 then + let default = !i_max in + let remove = + List.filter + (fun (_,lam) -> match as_simple_exit lam with + | Some j -> j <> default + | None -> true) in + {sw with + sw_consts = remove sw.sw_consts ; + sw_blocks = remove sw.sw_blocks ; + sw_failaction = Some (make_exit default)} + else sw +| Some _ -> sw + + module Switcher = Switch.Make(SArg) open Switch @@ -1947,7 +2052,16 @@ let get_edges low high l = match l with let as_interval_canfail fail low high l = - let store = mk_store equal_action in + let store = StoreExp.mk_store () in + + let do_store tag act = + let i = store.act_store act in +(* + Printlambda.lambda Format.str_formatter act ; + eprintf "STORE [%s] %i %s\n" tag i (Format.flush_str_formatter ()) ; +*) + i in + let rec nofail_rec cur_low cur_high cur_act = function | [] -> if cur_high = high then @@ -1955,7 +2069,7 @@ let as_interval_canfail fail low high l = else [(cur_low,cur_high,cur_act) ; (cur_high+1,high, 0)] | ((i,act_i)::rem) as all -> - let act_index = store.act_store act_i in + let act_index = do_store "NO" act_i in if cur_high+1= i then if act_index=cur_act then nofail_rec cur_low i cur_act rem @@ -1963,14 +2077,18 @@ let as_interval_canfail fail low high l = (cur_low,i-1, cur_act)::fail_rec i i rem else (cur_low, i-1, cur_act)::nofail_rec i i act_index rem + else if act_index = 0 then + (cur_low, cur_high, cur_act):: + fail_rec (cur_high+1) (cur_high+1) all else (cur_low, cur_high, cur_act):: - fail_rec ((cur_high+1)) (cur_high+1) all + (cur_high+1,i-1,0):: + nofail_rec i i act_index rem and fail_rec cur_low cur_high = function | [] -> [(cur_low, cur_high, 0)] | (i,act_i)::rem -> - let index = store.act_store act_i in + let index = do_store "YES" act_i in if index=0 then fail_rec cur_low i rem else (cur_low,i-1,0):: @@ -1979,7 +2097,7 @@ let as_interval_canfail fail low high l = let init_rec = function | [] -> [] | (i,act_i)::rem -> - let index = store.act_store act_i in + let index = do_store "INIT" act_i in if index=0 then fail_rec low i rem else @@ -1988,12 +2106,12 @@ let as_interval_canfail fail low high l = else nofail_rec i i index rem in - ignore (store.act_store fail) ; (* fail has action index 0 *) + assert (do_store "FAIL" fail = 0) ; (* fail has action index 0 *) let r = init_rec l in - Array.of_list r, store.act_get () + Array.of_list r, store let as_interval_nofail l = - let store = mk_store equal_action in + let store = StoreExp.mk_store () in let rec i_rec cur_low cur_high cur_act = function | [] -> @@ -2011,7 +2129,7 @@ let as_interval_nofail l = i_rec i i act_index rem | _ -> assert false in - Array.of_list inters, store.act_get () + Array.of_list inters, store let sort_int_lambda_list l = @@ -2029,10 +2147,10 @@ let as_interval fail low high l = | None -> as_interval_nofail l | Some act -> as_interval_canfail act low high l) -let call_switcher konst fail arg low high int_lambda_list = +let call_switcher fail arg low high int_lambda_list = let edges, (cases, actions) = as_interval fail low high int_lambda_list in - Switcher.zyva edges konst arg cases actions + Switcher.zyva edges arg cases actions let exists_ctx ok ctx = @@ -2187,33 +2305,27 @@ let combine_constant arg cst partial ctx def let int_lambda_list = List.map (function Const_int n, l -> n,l | _ -> assert false) const_lambda_list in - call_switcher - lambda_of_int fail arg min_int max_int int_lambda_list + call_switcher fail arg min_int max_int int_lambda_list | Const_char _ -> let int_lambda_list = List.map (function Const_char c, l -> (Char.code c, l) | _ -> assert false) const_lambda_list in - call_switcher - (fun i -> Lconst (Const_base (Const_int i))) - fail arg 0 255 int_lambda_list + call_switcher fail arg 0 255 int_lambda_list | Const_string _ -> (* Note as the bytecode compiler may resort to dichotmic search, the clauses of strinswitch are sorted with duplicate removed. This partly applies to the native code compiler, which requires - no duplicates *) - let fail,const_lambda_list = match fail with - | Some fail -> fail,sort_lambda_list const_lambda_list - | None -> - let cls,(_,lst) = Misc.split_last const_lambda_list in - lst,sort_lambda_list cls in + no duplicates *) + let const_lambda_list = sort_lambda_list const_lambda_list in let sw = List.map (fun (c,act) -> match c with | Const_string (s,_) -> s,act | _ -> assert false) const_lambda_list in - Lstringswitch (arg,sw,fail) + let hs,sw,fail = share_actions_tree sw fail in + hs (Lstringswitch (arg,sw,fail)) | Const_float _ -> make_test_sequence fail @@ -2251,39 +2363,61 @@ let split_cases tag_lambda_list = sort_int_lambda_list const, sort_int_lambda_list nonconst +let split_extension_cases tag_lambda_list = + let rec split_rec = function + [] -> ([], []) + | (cstr, act) :: rem -> + let (consts, nonconsts) = split_rec rem in + match cstr with + Cstr_extension(path, true) -> ((path, act) :: consts, nonconsts) + | Cstr_extension(path, false) -> (consts, (path, act) :: nonconsts) + | _ -> assert false in + split_rec tag_lambda_list + let combine_constructor arg ex_pat cstr partial ctx def (tag_lambda_list, total1, pats) = if cstr.cstr_consts < 0 then begin - (* Special cases for exceptions *) + (* Special cases for extensions *) let fail, to_add, local_jumps = mk_failaction_neg partial ctx def in let tag_lambda_list = to_add@tag_lambda_list in let lambda1 = - let default, tests = + let consts, nonconsts = split_extension_cases tag_lambda_list in + let default, consts, nonconsts = match fail with | None -> - begin match tag_lambda_list with - | (_, act)::rem -> act,rem + begin match consts, nonconsts with + | _, (_, act)::rem -> act, consts, rem + | (_, act)::rem, _ -> act, rem, nonconsts | _ -> assert false end - | Some fail -> fail, tag_lambda_list in - List.fold_right - (fun (ex, act) rem -> - assert(ex = cstr.cstr_tag); - match ex with - | Cstr_exception (path, _) -> - let slot = - if cstr.cstr_arity = 0 then arg - else Lprim(Pfield 0, [arg]) - in - Lifthenelse(Lprim(Pintcomp Ceq, - [slot; - transl_path ~loc:ex_pat.pat_loc - ex_pat.pat_env path]), - act, rem) - | _ -> assert false) - tests default in + | Some fail -> fail, consts, nonconsts in + let nonconst_lambda = + match nonconsts with + [] -> default + | _ -> + let tag = Ident.create "tag" in + let tests = + List.fold_right + (fun (path, act) rem -> + Lifthenelse(Lprim(Pintcomp Ceq, + [Lvar tag; + transl_path ex_pat.pat_env path]), + act, rem)) + nonconsts + default + in + Llet(Alias, tag, Lprim(Pfield 0, [arg]), tests) + in + List.fold_right + (fun (path, act) rem -> + Lifthenelse(Lprim(Pintcomp Ceq, + [arg; transl_path ex_pat.pat_env path]), + act, rem)) + consts + nonconst_lambda + in lambda1, jumps_union local_jumps total1 end else begin (* Regular concrete type *) @@ -2307,22 +2441,22 @@ let combine_constructor arg ex_pat cstr partial ctx def | (1, 1, [0, act1], [0, act2]) -> Lifthenelse(arg, act2, act1) | (n,_,_,[]) -> - call_switcher - (fun i -> Lconst (Const_base (Const_int i))) - None arg 0 (n-1) consts + call_switcher None arg 0 (n-1) consts | (n, _, _, _) -> match same_actions nonconsts with | None -> - make_switch(arg, {sw_numconsts = cstr.cstr_consts; - sw_consts = consts; - sw_numblocks = cstr.cstr_nonconsts; - sw_blocks = nonconsts; - sw_failaction = None}) +(* Emit a switch, as bytecode implements this sophisticated instruction *) + let sw = + {sw_numconsts = cstr.cstr_consts; sw_consts = consts; + sw_numblocks = cstr.cstr_nonconsts; sw_blocks = nonconsts; + sw_failaction = None} in + let hs,sw = share_actions_sw sw in + let sw = reintroduce_fail sw in + hs (Lswitch (arg,sw)) | Some act -> Lifthenelse (Lprim (Pisint, [arg]), call_switcher - (fun i -> Lconst (Const_base (Const_int i))) None arg 0 (n-1) consts, act) in @@ -2332,20 +2466,16 @@ let combine_constructor arg ex_pat cstr partial ctx def let make_test_sequence_variant_constant fail arg int_lambda_list = let _, (cases, actions) = as_interval fail min_int max_int int_lambda_list in - Switcher.test_sequence - (fun i -> Lconst (Const_base (Const_int i))) arg cases actions + Switcher.test_sequence arg cases actions let call_switcher_variant_constant fail arg int_lambda_list = - call_switcher - (fun i -> Lconst (Const_base (Const_int i))) - fail arg min_int max_int int_lambda_list + call_switcher fail arg min_int max_int int_lambda_list let call_switcher_variant_constr fail arg int_lambda_list = let v = Ident.create "variant" in Llet(Alias, v, Lprim(Pfield 0, [arg]), call_switcher - (fun i -> Lconst (Const_base (Const_int i))) fail (Lvar v) min_int max_int int_lambda_list) let combine_variant row arg partial ctx def (tag_lambda_list, total1, pats) = @@ -2409,7 +2539,6 @@ let combine_array arg kind partial ctx def let newvar = Ident.create "len" in let switch = call_switcher - lambda_of_int fail (Lvar newvar) 0 max_int len_lambda_list in bind @@ -2528,10 +2657,6 @@ let rec approx_present v = function | Lvar vv -> Ident.same v vv | _ -> true -let string_of_lam lam = - Printlambda.lambda Format.str_formatter lam ; - Format.flush_str_formatter () - let rec lower_bind v arg lam = match lam with | Lifthenelse (cond, ifso, ifnot) -> let pcond = approx_present v cond diff --git a/bytecomp/matching.mli b/bytecomp/matching.mli index 398143778..88002e056 100644 --- a/bytecomp/matching.mli +++ b/bytecomp/matching.mli @@ -37,13 +37,7 @@ exception Cannot_flatten val flatten_pattern: int -> pattern -> pattern list (* Expand stringswitch to string test tree *) - -val expand_stringswitch: lambda -> (string * lambda) list -> lambda -> lambda - -(* -val make_test_sequence: - lambda option -> primitive -> primitive -> lambda -> - (Asttypes.constant * lambda) list -> lambda -*) +val expand_stringswitch: + lambda -> (string * lambda) list -> lambda option -> lambda val inline_lazy_force : lambda -> Location.t -> lambda diff --git a/bytecomp/meta.ml b/bytecomp/meta.ml index 35d877666..f7711ff15 100644 --- a/bytecomp/meta.ml +++ b/bytecomp/meta.ml @@ -12,13 +12,13 @@ external global_data : unit -> Obj.t array = "caml_get_global_data" external realloc_global_data : int -> unit = "caml_realloc_global" -external static_alloc : int -> string = "caml_static_alloc" -external static_free : string -> unit = "caml_static_free" -external static_resize : string -> int -> string = "caml_static_resize" -external static_release_bytecode : string -> int -> unit +external static_alloc : int -> bytes = "caml_static_alloc" +external static_free : bytes -> unit = "caml_static_free" +external static_resize : bytes -> int -> bytes = "caml_static_resize" +external static_release_bytecode : bytes -> int -> unit = "caml_static_release_bytecode" type closure = unit -> Obj.t -external reify_bytecode : string -> int -> closure = "caml_reify_bytecode" +external reify_bytecode : bytes -> int -> closure = "caml_reify_bytecode" external invoke_traced_function : Obj.t -> Obj.t -> Obj.t -> Obj.t = "caml_invoke_traced_function" external get_section_table : unit -> (string * Obj.t) list diff --git a/bytecomp/meta.mli b/bytecomp/meta.mli index a8ef5272a..cb3565dcc 100644 --- a/bytecomp/meta.mli +++ b/bytecomp/meta.mli @@ -14,13 +14,13 @@ external global_data : unit -> Obj.t array = "caml_get_global_data" external realloc_global_data : int -> unit = "caml_realloc_global" -external static_alloc : int -> string = "caml_static_alloc" -external static_free : string -> unit = "caml_static_free" -external static_release_bytecode : string -> int -> unit +external static_alloc : int -> bytes = "caml_static_alloc" +external static_free : bytes -> unit = "caml_static_free" +external static_release_bytecode : bytes -> int -> unit = "caml_static_release_bytecode" -external static_resize : string -> int -> string = "caml_static_resize" +external static_resize : bytes -> int -> bytes = "caml_static_resize" type closure = unit -> Obj.t -external reify_bytecode : string -> int -> closure = "caml_reify_bytecode" +external reify_bytecode : bytes -> int -> closure = "caml_reify_bytecode" external invoke_traced_function : Obj.t -> Obj.t -> Obj.t -> Obj.t = "caml_invoke_traced_function" external get_section_table : unit -> (string * Obj.t) list diff --git a/bytecomp/printlambda.ml b/bytecomp/printlambda.ml index 7e9c197e3..1b9085edd 100644 --- a/bytecomp/printlambda.ml +++ b/bytecomp/printlambda.ml @@ -86,14 +86,22 @@ let record_rep ppf r = | Record_regular -> fprintf ppf "regular" | Record_inlined i -> fprintf ppf "inlined(%i)" i | Record_float -> fprintf ppf "float" - | Record_exception p -> fprintf ppf "exn (%s)" (Path.name p) + | Record_extension -> fprintf ppf "ext" ;; +let string_of_loc_kind = function + | Loc_FILE -> "loc_FILE" + | Loc_LINE -> "loc_LINE" + | Loc_MODULE -> "loc_MODULE" + | Loc_POS -> "loc_POS" + | Loc_LOC -> "loc_LOC" + let primitive ppf = function | Pidentity -> fprintf ppf "id" | Pignore -> fprintf ppf "ignore" | Prevapply _ -> fprintf ppf "revapply" | Pdirapply _ -> fprintf ppf "dirapply" + | Ploc kind -> fprintf ppf "%s" (string_of_loc_kind kind) | Pgetglobal id -> fprintf ppf "global %a" Ident.print id | Psetglobal id -> fprintf ppf "setglobal %a" Ident.print id | Pmakeblock(tag, Immutable) -> fprintf ppf "makeblock %i" tag @@ -231,6 +239,7 @@ let primitive ppf = function else fprintf ppf "bigarray.array1.set64" | Pbswap16 -> fprintf ppf "bswap16" | Pbbswap(bi) -> print_boxed_integer "bswap" ppf bi + | Pint_as_pointer -> fprintf ppf "int_as_pointer" let rec lam ppf = function | Lvar id -> @@ -313,8 +322,12 @@ let rec lam ppf = function if !spc then fprintf ppf "@ " else spc := true; fprintf ppf "@[<hv 1>case \"%s\":@ %a@]" (String.escaped s) lam l) cases; - if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[<hv 1>default:@ %a@]" lam default in + begin match default with + | Some default -> + if !spc then fprintf ppf "@ " else spc := true; + fprintf ppf "@[<hv 1>default:@ %a@]" lam default + | None -> () + end in fprintf ppf "@[<1>(stringswitch %a@ @[<v 0>%a@])@]" lam arg switch cases | Lstaticraise (i, ls) -> diff --git a/bytecomp/simplif.ml b/bytecomp/simplif.ml index c03cd857e..fd3d21c17 100644 --- a/bytecomp/simplif.ml +++ b/bytecomp/simplif.ml @@ -51,14 +51,13 @@ let rec eliminate_ref id = function sw_numblocks = sw.sw_numblocks; sw_blocks = List.map (fun (n, e) -> (n, eliminate_ref id e)) sw.sw_blocks; - sw_failaction = match sw.sw_failaction with - | None -> None - | Some l -> Some (eliminate_ref id l)}) + sw_failaction = + Misc.may_map (eliminate_ref id) sw.sw_failaction; }) | Lstringswitch(e, sw, default) -> Lstringswitch (eliminate_ref id e, List.map (fun (s, e) -> (s, eliminate_ref id e)) sw, - eliminate_ref id default) + Misc.may_map (eliminate_ref id) default) | Lstaticraise (i,args) -> Lstaticraise (i,List.map (eliminate_ref id) args) | Lstaticcatch(e1, i, e2) -> @@ -123,7 +122,12 @@ let simplify_exits lam = | Lstringswitch(l, sw, d) -> count l; List.iter (fun (_, l) -> count l) sw; - count d + begin match d with + | None -> () + | Some d -> match sw with + | []|[_] -> count d + | _ -> count d; count d (* default will get replicated *) + end | Lstaticraise (i,ls) -> incr_exit i ; List.iter count ls | Lstaticcatch (l1,(i,[]),Lstaticraise (j,[])) -> (* i will be replaced by j in l1, so each occurence of i in l1 @@ -147,10 +151,7 @@ let simplify_exits lam = | Lsequence(l1, l2) -> count l1; count l2 | Lwhile(l1, l2) -> count l1; count l2 | Lfor(_, l1, l2, dir, l3) -> count l1; count l2; count l3 - | Lassign(v, l) -> - (* Lalias-bound variables are never assigned, so don't increase - v's refcount *) - count l + | Lassign(v, l) -> count l | Lsend(k, m, o, ll, _) -> List.iter count (m::o::ll) | Levent(l, _) -> count l | Lifused(v, l) -> count l @@ -218,16 +219,15 @@ let simplify_exits lam = let new_l = simplif l and new_consts = List.map (fun (n, e) -> (n, simplif e)) sw.sw_consts and new_blocks = List.map (fun (n, e) -> (n, simplif e)) sw.sw_blocks - and new_fail = match sw.sw_failaction with - | None -> None - | Some l -> Some (simplif l) in + and new_fail = Misc.may_map simplif sw.sw_failaction in Lswitch (new_l, {sw with sw_consts = new_consts ; sw_blocks = new_blocks; sw_failaction = new_fail}) | Lstringswitch(l,sw,d) -> Lstringswitch - (simplif l,List.map (fun (s,l) -> s,simplif l) sw,simplif d) + (simplif l,List.map (fun (s,l) -> s,simplif l) sw, + Misc.may_map simplif d) | Lstaticraise (i,[]) as l -> begin try let _,handler = Hashtbl.find subst i in @@ -253,17 +253,10 @@ let simplify_exits lam = | Lstaticcatch (l1,(i,[]),(Lstaticraise (j,[]) as l2)) -> Hashtbl.add subst i ([],simplif l2) ; simplif l1 - | Lstaticcatch (l1,(i,xs), (Lvar _ as l2)) -> - begin match count_exit i with - | 0 -> simplif l1 - | _ -> - Hashtbl.add subst i (xs,l2) ; - simplif l1 - end | Lstaticcatch (l1,(i,xs),l2) -> begin match count_exit i with | 0 -> simplif l1 - | 1 -> + | 1 when i >= 0 -> Hashtbl.add subst i (xs,simplif l2) ; simplif l1 | _ -> @@ -376,7 +369,14 @@ let simplify_lets lam = | Lstringswitch(l, sw, d) -> count bv l ; List.iter (fun (_, l) -> count bv l) sw ; - count bv d + begin match d with + | Some d -> + begin match sw with + | []|[_] -> count bv d + | _ -> count bv d ; count bv d + end + | None -> () + end | Lstaticraise (i,ls) -> List.iter (count bv) ls | Lstaticcatch(l1, (i,_), l2) -> count bv l1; count bv l2 | Ltrywith(l1, v, l2) -> count bv l1; count bv l2 @@ -469,16 +469,15 @@ let simplify_lets lam = let new_l = simplif l and new_consts = List.map (fun (n, e) -> (n, simplif e)) sw.sw_consts and new_blocks = List.map (fun (n, e) -> (n, simplif e)) sw.sw_blocks - and new_fail = match sw.sw_failaction with - | None -> None - | Some l -> Some (simplif l) in + and new_fail = Misc.may_map simplif sw.sw_failaction in Lswitch (new_l, {sw with sw_consts = new_consts ; sw_blocks = new_blocks; sw_failaction = new_fail}) | Lstringswitch (l,sw,d) -> Lstringswitch - (simplif l,List.map (fun (s,l) -> s,simplif l) sw,simplif d) + (simplif l,List.map (fun (s,l) -> s,simplif l) sw, + Misc.may_map simplif d) | Lstaticraise (i,ls) -> Lstaticraise (i, List.map simplif ls) | Lstaticcatch(l1, (i,args), l2) -> @@ -539,13 +538,14 @@ let rec emit_tail_infos is_tail lambda = | Lswitch (lam, sw) -> emit_tail_infos false lam; list_emit_tail_infos_fun snd is_tail sw.sw_consts; - list_emit_tail_infos_fun snd is_tail sw.sw_blocks + list_emit_tail_infos_fun snd is_tail sw.sw_blocks; + Misc.may (emit_tail_infos is_tail) sw.sw_failaction | Lstringswitch (lam, sw, d) -> emit_tail_infos false lam; List.iter (fun (_,lam) -> emit_tail_infos is_tail lam) sw ; - emit_tail_infos is_tail d + Misc.may (emit_tail_infos is_tail) d | Lstaticraise (_, l) -> list_emit_tail_infos false l | Lstaticcatch (body, _, handler) -> diff --git a/bytecomp/switch.ml b/bytecomp/switch.ml index ff193ee13..da9a48f1a 100644 --- a/bytecomp/switch.ml +++ b/bytecomp/switch.ml @@ -10,31 +10,81 @@ (* *) (***********************************************************************) -(* Store for actions in object style *) -exception Found of int + +type 'a shared = Shared of 'a | Single of 'a + +let share_out = function + | Shared act|Single act -> act + type 'a t_store = - {act_get : unit -> 'a array ; act_store : 'a -> int} - -let mk_store same = - let r_acts = ref [] in - let store act = - let rec store_rec i = function - | [] -> i,[act] - | act0::rem -> - if same act0 act then raise (Found i) - else - let i,rem = store_rec (i+1) rem in - i,act0::rem in - try - let i,acts = store_rec 0 !r_acts in - r_acts := acts ; - i - with - | Found i -> i + {act_get : unit -> 'a array ; + act_get_shared : unit -> 'a shared array ; + act_store : 'a -> int ; + act_store_shared : 'a -> int ; } - and get () = Array.of_list !r_acts in - {act_store=store ; act_get=get} +exception Not_simple + +module type Stored = sig + type t + type key + val make_key : t -> key option +end + +module Store(A:Stored) = struct + module AMap = + Map.Make(struct type t = A.key let compare = Pervasives.compare end) + + type intern = + { mutable map : (bool * int) AMap.t ; + mutable next : int ; + mutable acts : (bool * A.t) list; } + + let mk_store () = + let st = + { map = AMap.empty ; + next = 0 ; + acts = [] ; } in + + let add mustshare act = + let i = st.next in + st.acts <- (mustshare,act) :: st.acts ; + st.next <- i+1 ; + i in + + let store mustshare act = match A.make_key act with + | Some key -> + begin try + let (shared,i) = AMap.find key st.map in + if not shared then st.map <- AMap.add key (true,i) st.map ; + i + with Not_found -> + let i = add mustshare act in + st.map <- AMap.add key (mustshare,i) st.map ; + i + end + | None -> + add mustshare act + + and get () = Array.of_list (List.rev_map (fun (_,act) -> act) st.acts) + + and get_shared () = + let acts = + Array.of_list + (List.rev_map + (fun (shared,act) -> + if shared then Shared act else Single act) + st.acts) in + AMap.iter + (fun _ (shared,i) -> + if shared then match acts.(i) with + | Single act -> acts.(i) <- Shared act + | Shared _ -> ()) + st.map ; + acts in + {act_store = store false ; act_store_shared = store true ; + act_get = get; act_get_shared = get_shared; } +end @@ -50,13 +100,15 @@ module type S = type act val bind : act -> (act -> act) -> act + val make_const : int -> act val make_offset : act -> int -> act val make_prim : primitive -> act list -> act val make_isout : act -> act -> act val make_isin : act -> act -> act val make_if : act -> act -> act -> act - val make_switch : - act -> int array -> act array -> act + val make_switch : act -> int array -> act array -> act + val make_catch : act -> int * (act -> act) + val make_exit : int -> act end (* The module will ``produce good code for the case statement'' *) @@ -196,7 +248,7 @@ let case_append c1 c2 = let l1,h1,act1 = c1.(Array.length c1-1) and l2,h2,act2 = c2.(0) in if act1 = act2 then - let r = Array.create (len1+len2-1) c1.(0) in + let r = Array.make (len1+len2-1) c1.(0) in for i = 0 to len1-2 do r.(i) <- c1.(i) done ; @@ -225,7 +277,7 @@ let case_append c1 c2 = done ; r else if h1 > l1 then - let r = Array.create (len1+len2) c1.(0) in + let r = Array.make (len1+len2) c1.(0) in for i = 0 to len1-2 do r.(i) <- c1.(i) done ; @@ -235,7 +287,7 @@ let case_append c1 c2 = done ; r else if h2 > l2 then - let r = Array.create (len1+len2) c1.(0) in + let r = Array.make (len1+len2) c1.(0) in for i = 0 to len1-1 do r.(i) <- c1.(i) done ; @@ -489,77 +541,77 @@ and enum top cases = end ; !r, !rc - let make_if_test konst test arg i ifso ifnot = + let make_if_test test arg i ifso ifnot = Arg.make_if - (Arg.make_prim test [arg ; konst i]) + (Arg.make_prim test [arg ; Arg.make_const i]) ifso ifnot - let make_if_lt konst arg i ifso ifnot = match i with + let make_if_lt arg i ifso ifnot = match i with | 1 -> - make_if_test konst Arg.leint arg 0 ifso ifnot + make_if_test Arg.leint arg 0 ifso ifnot | _ -> - make_if_test konst Arg.ltint arg i ifso ifnot + make_if_test Arg.ltint arg i ifso ifnot - and make_if_le konst arg i ifso ifnot = match i with + and make_if_le arg i ifso ifnot = match i with | -1 -> - make_if_test konst Arg.ltint arg 0 ifso ifnot + make_if_test Arg.ltint arg 0 ifso ifnot | _ -> - make_if_test konst Arg.leint arg i ifso ifnot + make_if_test Arg.leint arg i ifso ifnot - and make_if_gt konst arg i ifso ifnot = match i with + and make_if_gt arg i ifso ifnot = match i with | -1 -> - make_if_test konst Arg.geint arg 0 ifso ifnot + make_if_test Arg.geint arg 0 ifso ifnot | _ -> - make_if_test konst Arg.gtint arg i ifso ifnot + make_if_test Arg.gtint arg i ifso ifnot - and make_if_ge konst arg i ifso ifnot = match i with + and make_if_ge arg i ifso ifnot = match i with | 1 -> - make_if_test konst Arg.gtint arg 0 ifso ifnot + make_if_test Arg.gtint arg 0 ifso ifnot | _ -> - make_if_test konst Arg.geint arg i ifso ifnot + make_if_test Arg.geint arg i ifso ifnot - and make_if_eq konst arg i ifso ifnot = - make_if_test konst Arg.eqint arg i ifso ifnot + and make_if_eq arg i ifso ifnot = + make_if_test Arg.eqint arg i ifso ifnot - and make_if_ne konst arg i ifso ifnot = - make_if_test konst Arg.neint arg i ifso ifnot + and make_if_ne arg i ifso ifnot = + make_if_test Arg.neint arg i ifso ifnot let do_make_if_out h arg ifso ifno = Arg.make_if (Arg.make_isout h arg) ifso ifno - let make_if_out konst ctx l d mk_ifso mk_ifno = match l with + let make_if_out ctx l d mk_ifso mk_ifno = match l with | 0 -> do_make_if_out - (konst d) ctx.arg (mk_ifso ctx) (mk_ifno ctx) + (Arg.make_const d) ctx.arg (mk_ifso ctx) (mk_ifno ctx) | _ -> Arg.bind (Arg.make_offset ctx.arg (-l)) (fun arg -> let ctx = {off= (-l+ctx.off) ; arg=arg} in do_make_if_out - (konst d) arg (mk_ifso ctx) (mk_ifno ctx)) + (Arg.make_const d) arg (mk_ifso ctx) (mk_ifno ctx)) let do_make_if_in h arg ifso ifno = Arg.make_if (Arg.make_isin h arg) ifso ifno - let make_if_in konst ctx l d mk_ifso mk_ifno = match l with + let make_if_in ctx l d mk_ifso mk_ifno = match l with | 0 -> do_make_if_in - (konst d) ctx.arg (mk_ifso ctx) (mk_ifno ctx) + (Arg.make_const d) ctx.arg (mk_ifso ctx) (mk_ifno ctx) | _ -> Arg.bind (Arg.make_offset ctx.arg (-l)) (fun arg -> let ctx = {off= (-l+ctx.off) ; arg=arg} in do_make_if_in - (konst d) arg (mk_ifso ctx) (mk_ifno ctx)) - + (Arg.make_const d) arg (mk_ifso ctx) (mk_ifno ctx)) - let rec c_test konst ctx ({cases=cases ; actions=actions} as s) = + let rec c_test ctx ({cases=cases ; actions=actions} as s) = let lcases = Array.length cases in assert(lcases > 0) ; if lcases = 1 then actions.(get_act cases 0) ctx + else begin let w,c = opt_count false cases in @@ -579,31 +631,31 @@ and enum top cases = if low=high then begin if less_tests coutside cinside then make_if_eq - konst ctx.arg + ctx.arg (low+ctx.off) - (c_test konst ctx {s with cases=inside}) - (c_test konst ctx {s with cases=outside}) + (c_test ctx {s with cases=inside}) + (c_test ctx {s with cases=outside}) else make_if_ne - konst ctx.arg + ctx.arg (low+ctx.off) - (c_test konst ctx {s with cases=outside}) - (c_test konst ctx {s with cases=inside}) + (c_test ctx {s with cases=outside}) + (c_test ctx {s with cases=inside}) end else begin if less_tests coutside cinside then make_if_in - konst ctx + ctx (low+ctx.off) (high-low) - (fun ctx -> c_test konst ctx {s with cases=inside}) - (fun ctx -> c_test konst ctx {s with cases=outside}) + (fun ctx -> c_test ctx {s with cases=inside}) + (fun ctx -> c_test ctx {s with cases=outside}) else make_if_out - konst ctx + ctx (low+ctx.off) (high-low) - (fun ctx -> c_test konst ctx {s with cases=outside}) - (fun ctx -> c_test konst ctx {s with cases=inside}) + (fun ctx -> c_test ctx {s with cases=outside}) + (fun ctx -> c_test ctx {s with cases=inside}) end | Sep i -> let lim,left,right = coupe cases i in @@ -613,17 +665,17 @@ and enum top cases = and right = {s with cases=right} in if i=1 && (lim+ctx.off)=1 && get_low cases 0+ctx.off=0 then - make_if_ne konst + make_if_ne ctx.arg 0 - (c_test konst ctx right) (c_test konst ctx left) + (c_test ctx right) (c_test ctx left) else if less_tests cright cleft then - make_if_lt konst + make_if_lt ctx.arg (lim+ctx.off) - (c_test konst ctx left) (c_test konst ctx right) + (c_test ctx left) (c_test ctx right) else - make_if_ge konst + make_if_ge ctx.arg (lim+ctx.off) - (c_test konst ctx right) (c_test konst ctx left) + (c_test ctx right) (c_test ctx left) end @@ -676,8 +728,8 @@ let dense {cases=cases ; actions=actions} i j = let comp_clusters ({cases=cases ; actions=actions} as s) = let len = Array.length cases in - let min_clusters = Array.create len max_int - and k = Array.create len 0 in + let min_clusters = Array.make len max_int + and k = Array.make len 0 in let get_min i = if i < 0 then 0 else min_clusters.(i) in for i = 0 to len-1 do @@ -697,7 +749,7 @@ let comp_clusters ({cases=cases ; actions=actions} as s) = let make_switch {cases=cases ; actions=actions} i j = let ll,_,_ = cases.(i) and _,hh,_ = cases.(j) in - let tbl = Array.create (hh-ll+1) 0 + let tbl = Array.make (hh-ll+1) 0 and t = Hashtbl.create 17 and index = ref 0 in let get_index act = @@ -717,7 +769,7 @@ let make_switch {cases=cases ; actions=actions} i j = tbl.(kk) <- index done done ; - let acts = Array.create !index actions.(0) in + let acts = Array.make !index actions.(0) in Hashtbl.iter (fun act i -> acts.(i) <- actions.(act)) t ; @@ -732,7 +784,7 @@ let make_switch {cases=cases ; actions=actions} i j = let make_clusters ({cases=cases ; actions=actions} as s) n_clusters k = let len = Array.length cases in - let r = Array.create n_clusters (0,0,0) + let r = Array.make n_clusters (0,0,0) and t = Hashtbl.create 17 and index = ref 0 and bidon = ref (Array.length actions) in @@ -768,13 +820,13 @@ let make_clusters ({cases=cases ; actions=actions} as s) n_clusters k = if i > 0 then zyva (i-1) (ir-1) in zyva (len-1) (n_clusters-1) ; - let acts = Array.create !index (fun _ -> assert false) in + let acts = Array.make !index (fun _ -> assert false) in Hashtbl.iter (fun _ (i,act) -> acts.(i) <- act) t ; {cases = r ; actions = acts} ;; -let zyva (low,high) konst arg cases actions = +let do_zyva (low,high) arg cases actions = let old_ok = !ok_inter in ok_inter := (abs low <= inter_limit && abs high <= inter_limit) ; if !ok_inter <> old_ok then Hashtbl.clear t ; @@ -787,12 +839,31 @@ let zyva (low,high) konst arg cases actions = *) let n_clusters,k = comp_clusters s in let clusters = make_clusters s n_clusters k in - let r = c_test konst {arg=arg ; off=0} clusters in + let r = c_test {arg=arg ; off=0} clusters in r - - -and test_sequence konst arg cases actions = +let abstract_shared actions = + let handlers = ref (fun x -> x) in + let actions = + Array.map + (fun act -> match act with + | Single act -> act + | Shared act -> + let i,h = Arg.make_catch act in + let oh = !handlers in + handlers := (fun act -> h (oh act)) ; + Arg.make_exit i) + actions in + !handlers,actions + +let zyva lh arg cases actions = + let actions = actions.act_get_shared () in + let hs,actions = abstract_shared actions in + hs (do_zyva lh arg cases actions) + +and test_sequence arg cases actions = + let actions = actions.act_get_shared () in + let hs,actions = abstract_shared actions in let old_ok = !ok_inter in ok_inter := false ; if !ok_inter <> old_ok then Hashtbl.clear t ; @@ -804,8 +875,7 @@ and test_sequence konst arg cases actions = pcases stderr cases ; prerr_endline "" ; *) - let r = c_test konst {arg=arg ; off=0} s in - r + hs (c_test {arg=arg ; off=0} s) ;; end diff --git a/bytecomp/switch.mli b/bytecomp/switch.mli index 69fc800d3..53fd99748 100644 --- a/bytecomp/switch.mli +++ b/bytecomp/switch.mli @@ -17,9 +17,35 @@ (* For detecting action sharing, object style *) +(* Store for actions in object style: + act_store : store an action, returns index in table + In case an action with equal key exists, returns index + of the stored action. Otherwise add entry in table. + act_store_shared : This stored action will always be shared. + act_get : retrieve table + act_get_shared : retrieve table, with sharing explicit +*) + +type 'a shared = Shared of 'a | Single of 'a + type 'a t_store = - {act_get : unit -> 'a array ; act_store : 'a -> int} -val mk_store : ('a -> 'a -> bool) -> 'a t_store + {act_get : unit -> 'a array ; + act_get_shared : unit -> 'a shared array ; + act_store : 'a -> int ; + act_store_shared : 'a -> int ; } + +exception Not_simple + +module type Stored = sig + type t + type key + val make_key : t -> key option +end + +module Store(A:Stored) : + sig + val mk_store : unit -> A.t t_store + end (* Arguments to the Make functor *) module type S = @@ -39,6 +65,7 @@ module type S = (* Various constructors, for making a binder, adding one integer, etc. *) val bind : act -> (act -> act) -> act + val make_const : int -> act val make_offset : act -> int -> act val make_prim : primitive -> act list -> act val make_isout : act -> act -> act @@ -49,12 +76,15 @@ module type S = NB: cases is in the value form *) val make_switch : act -> int array -> act array -> act + (* Build last minute sharing of action stuff *) + val make_catch : act -> int * (act -> act) + val make_exit : int -> act + end (* - Make.zyva mk_const arg low high cases actions where - - mk_const takes an integer sends a constant action. + Make.zyva arg low high cases actions where - arg is the argument of the switch. - low, high are the interval limits. - cases is a list of sub-interval and action indices @@ -66,17 +96,18 @@ module type S = module Make : functor (Arg : S) -> sig +(* Standard entry point, sharing is tracked *) val zyva : (int * int) -> - (int -> Arg.act) -> Arg.act -> (int * int * int) array -> - Arg.act array -> + Arg.act t_store -> Arg.act + +(* Output test sequence, sharing tracked *) val test_sequence : - (int -> Arg.act) -> Arg.act -> (int * int * int) array -> - Arg.act array -> + Arg.act t_store -> Arg.act end diff --git a/bytecomp/symtable.ml b/bytecomp/symtable.ml index baff51c48..1cc3a5314 100644 --- a/bytecomp/symtable.ml +++ b/bytecomp/symtable.ml @@ -96,7 +96,7 @@ let require_primitive name = if name.[0] <> '%' then ignore(num_of_prim name) let all_primitives () = - let prim = Array.create !c_prim_table.num_cnt "" in + let prim = Array.make !c_prim_table.num_cnt "" in Tbl.iter (fun name number -> prim.(number) <- name) !c_prim_table.num_tbl; prim @@ -198,7 +198,7 @@ let gen_patch_object str_set buff patchlist = gen_patch_int str_set buff pos (num_of_prim name)) patchlist -let patch_object = gen_patch_object String.unsafe_set +let patch_object = gen_patch_object Bytes.unsafe_set let ls_patch_object = gen_patch_object LongString.set (* Translate structured constants *) @@ -226,7 +226,7 @@ let rec transl_const = function (* Build the initial table of globals *) let initial_global_table () = - let glob = Array.create !global_table.num_cnt (Obj.repr 0) in + let glob = Array.make !global_table.num_cnt (Obj.repr 0) in List.iter (fun (slot, cst) -> glob.(slot) <- transl_const cst) !literal_table; @@ -300,7 +300,8 @@ let init_toplevel () = Dll.init_toplevel dllpath; (* Recover CRC infos for interfaces *) let crcintfs = - try (Obj.magic (sect.read_struct "CRCS") : (string * Digest.t) list) + try + (Obj.magic (sect.read_struct "CRCS") : (string * Digest.t option) list) with Not_found -> [] in (* Done *) sect.close_reader(); @@ -383,3 +384,8 @@ let () = | Error err -> Some (Location.error_of_printer_file report_error err) | _ -> None ) + +let reset () = + global_table := empty_numtable; + literal_table := []; + c_prim_table := empty_numtable diff --git a/bytecomp/symtable.mli b/bytecomp/symtable.mli index e3c33d239..ffc878bf1 100644 --- a/bytecomp/symtable.mli +++ b/bytecomp/symtable.mli @@ -17,7 +17,7 @@ open Cmo_format (* Functions for batch linking *) val init: unit -> unit -val patch_object: string -> (reloc_info * int) list -> unit +val patch_object: bytes -> (reloc_info * int) list -> unit val ls_patch_object: Misc.LongString.t -> (reloc_info * int) list -> unit val require_primitive: string -> unit val initial_global_table: unit -> Obj.t array @@ -29,7 +29,7 @@ val data_primitive_names: unit -> string (* Functions for the toplevel *) -val init_toplevel: unit -> (string * Digest.t) list +val init_toplevel: unit -> (string * Digest.t option) list val update_global_table: unit -> unit val get_global_value: Ident.t -> Obj.t val is_global_defined: Ident.t -> bool @@ -57,3 +57,5 @@ exception Error of error open Format val report_error: formatter -> error -> unit + +val reset: unit -> unit diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml index 55ddab3bc..0fb68457b 100644 --- a/bytecomp/translclass.ml +++ b/bytecomp/translclass.ml @@ -116,7 +116,7 @@ let name_pattern default p = | _ -> Ident.create default let normalize_cl_path cl path = - Env.normalize_path (Some cl.cl_loc) cl.cl_env path + Env.normalize_path (Some cl.cl_loc) cl.cl_env path let rec build_object_init cl_table obj params inh_init obj_init cl = match cl.cl_desc with @@ -145,7 +145,7 @@ let rec build_object_init cl_table obj params inh_init obj_init cl = | Tcf_val (_, _, id, Tcfk_concrete (_, exp), _) -> (inh_init, lsequence (set_inst_var obj id exp) obj_init, has_init) - | Tcf_method _ | Tcf_val _ | Tcf_constraint _ -> + | Tcf_method _ | Tcf_val _ | Tcf_constraint _ | Tcf_attribute _-> (inh_init, obj_init, has_init) | Tcf_initializer _ -> (inh_init, obj_init, true) @@ -280,7 +280,9 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl = inh_init cl_init msubst top cl in (inh_init, cl_init, [], values) | Tcf_val (name, _, id, _, over) -> - let values = if over then values else (name.txt, id) :: values in + let values = + if over then values else (name.txt, id) :: values + in (inh_init, cl_init, methods, values) | Tcf_method (_, _, Tcfk_virtual _) | Tcf_constraint _ @@ -296,14 +298,16 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl = else met_code in (inh_init, cl_init, - Lvar (Meths.find name.txt str.cstr_meths) :: met_code @ methods, + Lvar(Meths.find name.txt str.cstr_meths) :: met_code @ methods, values) | Tcf_initializer exp -> (inh_init, Lsequence(mkappl (oo_prim "add_initializer", Lvar cla :: msubst false (transl_exp exp)), cl_init), - methods, values)) + methods, values) + | Tcf_attribute _ -> + (inh_init, cl_init, methods, values)) str.cstr_fields (inh_init, cl_init, [], []) in @@ -808,7 +812,7 @@ let transl_class ids cl_id pub_meths cl vflag = (* let cl_id = ci.ci_id_class in (* TODO: cl_id is used somewhere else as typesharp ? *) - let _arity = List.length (fst ci.ci_params) in + let _arity = List.length ci.ci_params in let pub_meths = m in let cl = ci.ci_expr in let vflag = vf in diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml index a2d15bf77..14f8b0659 100644 --- a/bytecomp/translcore.ml +++ b/bytecomp/translcore.ml @@ -311,6 +311,7 @@ let primitives_table = create_hashtable 57 [ "%bswap_int32", Pbbswap(Pint32); "%bswap_int64", Pbbswap(Pint64); "%bswap_native", Pbbswap(Pnativeint); + "%int_as_pointer", Pint_as_pointer; ] let prim_makearray = @@ -325,6 +326,11 @@ let find_primitive loc prim_name = match prim_name with "%revapply" -> Prevapply loc | "%apply" -> Pdirapply loc + | "%loc_LOC" -> Ploc Loc_LOC + | "%loc_FILE" -> Ploc Loc_FILE + | "%loc_LINE" -> Ploc Loc_LINE + | "%loc_POS" -> Ploc Loc_POS + | "%loc_MODULE" -> Ploc Loc_MODULE | name -> Hashtbl.find primitives_table name let transl_prim loc prim args = @@ -404,10 +410,20 @@ let transl_primitive loc p = with Not_found -> Pccall p in match prim with - Plazyforce -> + | Plazyforce -> let parm = Ident.create "prim" in Lfunction(Curried, [parm], Matching.inline_lazy_force (Lvar parm) Location.none) + | Ploc kind -> + let lam = lam_of_loc kind loc in + begin match p.prim_arity with + | 0 -> lam + | 1 -> (* TODO: we should issue a warning ? *) + let param = Ident.create "prim" in + Lfunction(Curried, [param], + Lprim(Pmakeblock(0, Immutable), [lam; Lvar param])) + | _ -> assert false + end | _ -> let rec make_params n = if n <= 0 then [] else Ident.create "prim" :: make_params (n-1) in @@ -510,12 +526,14 @@ let rec push_defaults loc bindings cases partial = [{c_lhs=pat; c_guard=None; c_rhs={exp_desc = Texp_function(l, pl,partial)} as exp}] -> let pl = push_defaults exp.exp_loc bindings pl partial in - [{c_lhs=pat; c_guard=None; c_rhs={exp with exp_desc = Texp_function(l, pl, partial)}}] + [{c_lhs=pat; c_guard=None; + c_rhs={exp with exp_desc = Texp_function(l, pl, partial)}}] | [{c_lhs=pat; c_guard=None; c_rhs={exp_attributes=[{txt="#default"},_]; exp_desc = Texp_let (Nonrecursive, binds, ({exp_desc = Texp_function _} as e2))}}] -> - push_defaults loc (binds :: bindings) [{c_lhs=pat;c_guard=None;c_rhs=e2}] partial + push_defaults loc (binds :: bindings) [{c_lhs=pat;c_guard=None;c_rhs=e2}] + partial | [case] -> let exp = List.fold_left @@ -536,10 +554,12 @@ let rec push_defaults loc bindings cases partial = val_attributes = []; Types.val_loc = Location.none; })}, - cases, partial) } + cases, [], partial) } in push_defaults loc bindings - [{c_lhs={pat with pat_desc = Tpat_var (param, mknoloc name)}; c_guard=None; c_rhs=exp}] Total + [{c_lhs={pat with pat_desc = Tpat_var (param, mknoloc name)}; + c_guard=None; c_rhs=exp}] + Total | _ -> cases @@ -694,6 +714,12 @@ and transl_exp0 e = k in wrap0 (Lprim(Praise k, [event_after arg1 targ])) + | (Ploc kind, []) -> + lam_of_loc kind e.exp_loc + | (Ploc kind, [arg1]) -> + let lam = lam_of_loc kind arg1.exp_loc in + Lprim(Pmakeblock(0, Immutable), lam :: argl) + | (Ploc _, _) -> assert false | (_, _) -> begin match (prim, argl) with | (Plazyforce, [a]) -> @@ -705,12 +731,8 @@ and transl_exp0 e = end | Texp_apply(funct, oargs) -> event_after e (transl_apply (transl_exp funct) oargs e.exp_loc) - | Texp_match({exp_desc = Texp_tuple argl}, pat_expr_list, partial) -> - Matching.for_multiple_match e.exp_loc - (transl_list argl) (transl_cases pat_expr_list) partial - | Texp_match(arg, pat_expr_list, partial) -> - Matching.for_function e.exp_loc None - (transl_exp arg) (transl_cases pat_expr_list) partial + | Texp_match(arg, pat_expr_list, exn_pat_expr_list, partial) -> + transl_match e arg pat_expr_list exn_pat_expr_list partial | Texp_try(body, pat_expr_list) -> let id = name_pattern "exn" pat_expr_list in Ltrywith(transl_exp body, id, @@ -724,7 +746,7 @@ and transl_exp0 e = end | Texp_construct(_, cstr, args) -> let ll = transl_list args in - if cstr.cstr_inlined then begin match ll with + if cstr.cstr_inlined <> None then begin match ll with | [x] -> x | _ -> assert false end else begin match cstr.cstr_tag with @@ -736,10 +758,12 @@ and transl_exp0 e = with Not_constant -> Lprim(Pmakeblock(n, Immutable), ll) end - | Cstr_exception (path, _) -> - let slot = transl_path ~loc:e.exp_loc e.exp_env path in - if cstr.cstr_arity = 0 then slot - else Lprim(Pmakeblock(0, Immutable), slot :: ll) + | Cstr_extension(path, is_const) -> + if is_const then + transl_path e.exp_env path + else + Lprim(Pmakeblock(0, Immutable), + transl_path e.exp_env path :: ll) end | Texp_variant(l, arg) -> let tag = Btype.hash_variant l in @@ -764,7 +788,7 @@ and transl_exp0 e = match lbl.lbl_repres with Record_regular | Record_inlined _ -> Pfield lbl.lbl_pos | Record_float -> Pfloatfield lbl.lbl_pos - | Record_exception _ -> Pfield (lbl.lbl_pos + 1) + | Record_extension -> Pfield (lbl.lbl_pos + 1) in Lprim(access, [transl_exp arg]) | Texp_setfield(arg, _, lbl, newval) -> @@ -773,8 +797,7 @@ and transl_exp0 e = Record_regular | Record_inlined _ -> Psetfield(lbl.lbl_pos, maybe_pointer newval) | Record_float -> Psetfloatfield lbl.lbl_pos - | Record_exception _ -> - Psetfield (lbl.lbl_pos + 1, maybe_pointer newval) + | Record_extension -> Psetfield (lbl.lbl_pos + 1, maybe_pointer newval) in Lprim(access, [transl_exp arg; transl_exp newval]) | Texp_array expr_list -> @@ -887,7 +910,6 @@ and transl_exp0 e = || has_base_type e Predef.path_exn || has_base_type e Predef.path_array || has_base_type e Predef.path_list - || has_base_type e Predef.path_format6 || has_base_type e Predef.path_option || has_base_type e Predef.path_nativeint || has_base_type e Predef.path_int32 @@ -1065,7 +1087,7 @@ and transl_record env all_labels repres lbl_expr_list opt_init_expr = then begin (* Allocate new record with given fields (and remaining fields taken from init_expr if any *) - let lv = Array.create (Array.length all_labels) staticfail in + let lv = Array.make (Array.length all_labels) staticfail in let init_id = Ident.create "init" in begin match opt_init_expr with None -> () @@ -1074,7 +1096,7 @@ and transl_record env all_labels repres lbl_expr_list opt_init_expr = let access = match all_labels.(i).lbl_repres with Record_regular | Record_inlined _ -> Pfield i - | Record_exception _ -> Pfield (i + 1) + | Record_extension -> Pfield (i + 1) | Record_float -> Pfloatfield i in lv.(i) <- Lprim(access, [Lvar init_id]) done @@ -1096,16 +1118,21 @@ and transl_record env all_labels repres lbl_expr_list opt_init_expr = | Record_inlined tag -> Lconst(Const_block(tag, cl)) | Record_float -> Lconst(Const_float_array(List.map extract_float cl)) - | Record_exception _ -> + | Record_extension -> raise Not_constant with Not_constant -> match repres with Record_regular -> Lprim(Pmakeblock(0, mut), ll) | Record_inlined tag -> Lprim(Pmakeblock(tag, mut), ll) | Record_float -> Lprim(Pmakearray Pfloatarray, ll) - | Record_exception path -> + | Record_extension -> + let path = + match all_labels.(0).lbl_res.desc with + | Tconstr(p, _, _) -> p + | _ -> assert false + in let slot = transl_path env path in - Lprim(Pmakeblock(0, Immutable), slot :: ll) + Lprim(Pmakeblock(0, mut), slot :: ll) in begin match opt_init_expr with None -> lam @@ -1123,7 +1150,7 @@ and transl_record env all_labels repres lbl_expr_list opt_init_expr = Record_regular | Record_inlined _ -> Psetfield(lbl.lbl_pos, maybe_pointer expr) | Record_float -> Psetfloatfield lbl.lbl_pos - | Record_exception _ -> Psetfield(lbl.lbl_pos + 1, maybe_pointer expr) + | Record_extension -> Psetfield(lbl.lbl_pos + 1, maybe_pointer expr) in Lsequence(Lprim(upd, [Lvar copy_id; transl_exp expr]), cont) in begin match opt_init_expr with @@ -1135,6 +1162,34 @@ and transl_record env all_labels repres lbl_expr_list opt_init_expr = end end +and transl_match e arg pat_expr_list exn_pat_expr_list partial = + let id = name_pattern "exn" exn_pat_expr_list + and cases = transl_cases pat_expr_list + and exn_cases = transl_cases exn_pat_expr_list in + let static_catch body val_ids handler = + let static_exception_id = next_negative_raise_count () in + Lstaticcatch + (Ltrywith (Lstaticraise (static_exception_id, body), id, + Matching.for_trywith (Lvar id) exn_cases), + (static_exception_id, val_ids), + handler) + in + match arg, exn_cases with + | {exp_desc = Texp_tuple argl}, [] -> + Matching.for_multiple_match e.exp_loc (transl_list argl) cases partial + | {exp_desc = Texp_tuple argl}, _ :: _ -> + let val_ids = List.map (fun _ -> name_pattern "val" []) argl in + let lvars = List.map (fun id -> Lvar id) val_ids in + static_catch (transl_list argl) val_ids + (Matching.for_multiple_match e.exp_loc lvars cases partial) + | arg, [] -> + Matching.for_function e.exp_loc None (transl_exp arg) cases partial + | arg, _ :: _ -> + let val_id = name_pattern "val" pat_expr_list in + static_catch [transl_exp arg] [val_id] + (Matching.for_function e.exp_loc None (Lvar val_id) cases partial) + + (* Wrapper for class compilation *) (* diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml index 4b3141ad9..1f475565f 100644 --- a/bytecomp/translmod.ml +++ b/bytecomp/translmod.ml @@ -30,23 +30,50 @@ type error = exception Error of Location.t * error -(* Compile an exception definition *) +(* Keep track of the root path (from the root of the namespace to the + currently compiled module expression). Useful for naming extensions. *) + +let global_path glob = Some(Pident glob) +let functor_path path param = + match path with + None -> None + | Some p -> Some(Papply(p, Pident param)) +let field_path path field = + match path with + None -> None + | Some p -> Some(Pdot(p, Ident.name field, Path.nopos)) + +(* Compile type extensions *) let prim_set_oo_id = Pccall {Primitive.prim_name = "caml_set_oo_id"; prim_arity = 1; prim_alloc = false; prim_native_name = ""; prim_native_float = false} -let transl_exception path decl = +let transl_extension_constructor env path ext = let name = match path with - None -> Ident.name decl.cd_id + None -> Ident.name ext.ext_id | Some p -> Path.name p in - Lprim(prim_set_oo_id, - [Lprim(Pmakeblock(Obj.object_tag, Mutable), - [Lconst(Const_base(Const_string (name,None))); - Lconst(Const_base(Const_int 0))])]) + match ext.ext_kind with + Text_decl(args, ret) -> + Lprim(prim_set_oo_id, + [Lprim(Pmakeblock(Obj.object_tag, Mutable), + [Lconst(Const_base(Const_string (name,None))); + Lconst(Const_base(Const_int 0))])]) + | Text_rebind(path, lid) -> + transl_path ~loc:ext.ext_loc env path + +let transl_type_extension env rootpath tyext body = + List.fold_right + (fun ext body -> + let lam = + transl_extension_constructor env (field_path rootpath ext.ext_id) ext + in + Llet(Strict, ext.ext_id, lam, body)) + tyext.tyext_constructors + body (* Compile a coercion *) @@ -118,6 +145,19 @@ let rec compose_coercions c1 c2 = | (_, _) -> fatal_error "Translmod.compose_coercions" +(* +let apply_coercion a b c = + Format.eprintf "@[<2>apply_coercion@ %a@]@." Includemod.print_coercion b; + apply_coercion a b c + +let compose_coercions c1 c2 = + let c3 = compose_coercions c1 c2 in + let open Includemod in + Format.eprintf "@[<2>compose_coercions@ (%a)@ (%a) =@ %a@]@." + print_coercion c1 print_coercion c2 print_coercion c2; + c3 +*) + (* Record the primitive declarations occuring in the module compiled *) let primitive_declarations = ref ([] : Primitive.description list) @@ -126,19 +166,6 @@ let record_primitive = function primitive_declarations := p :: !primitive_declarations | _ -> () -(* Keep track of the root path (from the root of the namespace to the - currently compiled module expression). Useful for naming exceptions. *) - -let global_path glob = Some(Pident glob) -let functor_path path param = - match path with - None -> None - | Some p -> Some(Papply(p, Pident param)) -let field_path path field = - match path with - None -> None - | Some p -> Some(Pdot(p, Ident.name field, Path.nopos)) - (* Utilities for compiling "module rec" definitions *) let mod_prim name = @@ -181,7 +208,7 @@ let init_shape modl = init_v :: init_shape_struct env rem | Sig_type(id, tdecl, _) :: rem -> init_shape_struct (Env.add_type ~check:false id tdecl env) rem - | Sig_exception(id, edecl) :: rem -> + | Sig_typext(id, ext, _) :: rem -> raise Not_found | Sig_module(id, md, _) :: rem -> init_shape_mod env md.md_type :: @@ -211,7 +238,7 @@ let reorder_rec_bindings bindings = and rhs = Array.of_list (List.map (fun (_,_,_,rhs) -> rhs) bindings) in let fv = Array.map Lambda.free_variables rhs in let num_bindings = Array.length id in - let status = Array.create num_bindings Undefined in + let status = Array.make num_bindings Undefined in let res = ref [] in let rec emit_binding i = match status.(i) with @@ -275,14 +302,14 @@ let compile_recmodule compile_rhs bindings cont = (* Extract the list of "value" identifiers bound by a signature. "Value" identifiers are identifiers for signature components that - correspond to a run-time value: values, exceptions, modules, classes. + correspond to a run-time value: values, extensions, modules, classes. Note: manifest primitives do not correspond to a run-time value! *) let rec bound_value_identifiers = function [] -> [] | Sig_value(id, {val_kind = Val_reg}) :: rem -> id :: bound_value_identifiers rem - | Sig_exception(id, decl) :: rem -> id :: bound_value_identifiers rem + | Sig_typext(id, ext, _) :: rem -> id :: bound_value_identifiers rem | Sig_module(id, mty, _) :: rem -> id :: bound_value_identifiers rem | Sig_class(id, decl, _) :: rem -> id :: bound_value_identifiers rem | _ :: rem -> bound_value_identifiers rem @@ -363,12 +390,14 @@ and transl_structure fields cc rootpath = function transl_structure fields cc rootpath rem | Tstr_type(decls) -> transl_structure fields cc rootpath rem - | Tstr_exception decl -> - let id = decl.cd_id in - Llet(Strict, id, transl_exception (field_path rootpath id) decl, - transl_structure (id :: fields) cc rootpath rem) - | Tstr_exn_rebind( id, _, path, {Location.loc=loc}, _) -> - Llet(Strict, id, transl_path ~loc item.str_env path, + | Tstr_typext(tyext) -> + let ids = List.map (fun ext -> ext.ext_id) tyext.tyext_constructors in + transl_type_extension item.str_env rootpath tyext + (transl_structure (List.rev_append ids fields) cc rootpath rem) + | Tstr_exception ext -> + let id = ext.ext_id in + let path = field_path rootpath id in + Llet(Strict, id, transl_extension_constructor item.str_env path ext, transl_structure (id :: fields) cc rootpath rem) | Tstr_module mb -> let id = mb.mb_id in @@ -392,9 +421,10 @@ and transl_structure fields cc rootpath = function let cl = ci.ci_expr in (id, transl_class ids id meths cl vf )) cl_list, - transl_structure (List.rev ids @ fields) cc rootpath rem) - | Tstr_include(modl, sg, _) -> - let ids = bound_value_identifiers sg in + transl_structure (List.rev_append ids fields) cc rootpath rem) + | Tstr_include incl -> + let ids = bound_value_identifiers incl.incl_type in + let modl = incl.incl_mod in let mid = Ident.create "include" in let rec rebind_idents pos newfields = function [] -> @@ -444,8 +474,10 @@ let rec defined_idents = function let_bound_idents pat_expr_list @ defined_idents rem | Tstr_primitive desc -> defined_idents rem | Tstr_type decls -> defined_idents rem - | Tstr_exception decl -> decl.cd_id :: defined_idents rem - | Tstr_exn_rebind(id, _, path, _, _) -> id :: defined_idents rem + | Tstr_typext tyext -> + List.map (fun ext -> ext.ext_id) tyext.tyext_constructors + @ defined_idents rem + | Tstr_exception ext -> ext.ext_id :: defined_idents rem | Tstr_module mb -> mb.mb_id :: defined_idents rem | Tstr_recmodule decls -> List.map (fun mb -> mb.mb_id) decls @ defined_idents rem @@ -454,7 +486,8 @@ let rec defined_idents = function | Tstr_class cl_list -> List.map (fun (ci, _, _) -> ci.ci_id_class) cl_list @ defined_idents rem | Tstr_class_type cl_list -> defined_idents rem - | Tstr_include(modl, sg, _) -> bound_value_identifiers sg @ defined_idents rem + | Tstr_include incl -> + bound_value_identifiers incl.incl_type @ defined_idents rem | Tstr_attribute _ -> defined_idents rem (* second level idents (module M = struct ... let id = ... end), @@ -467,14 +500,14 @@ let rec more_idents = function | Tstr_value(rec_flag, pat_expr_list) -> more_idents rem | Tstr_primitive _ -> more_idents rem | Tstr_type decls -> more_idents rem + | Tstr_typext tyext -> more_idents rem | Tstr_exception _ -> more_idents rem - | Tstr_exn_rebind(id, _, path, _, _) -> more_idents rem | Tstr_recmodule decls -> more_idents rem | Tstr_modtype _ -> more_idents rem | Tstr_open _ -> more_idents rem | Tstr_class cl_list -> more_idents rem | Tstr_class_type cl_list -> more_idents rem - | Tstr_include(modl, _, _) -> more_idents rem + | Tstr_include _ -> more_idents rem | Tstr_module {mb_expr={mod_desc = Tmod_structure str}} -> all_idents str.str_items @ more_idents rem | Tstr_module _ -> more_idents rem @@ -489,8 +522,10 @@ and all_idents = function let_bound_idents pat_expr_list @ all_idents rem | Tstr_primitive _ -> all_idents rem | Tstr_type decls -> all_idents rem - | Tstr_exception decl -> decl.cd_id :: all_idents rem - | Tstr_exn_rebind(id, _, path, _, _) -> id :: all_idents rem + | Tstr_typext tyext -> + List.map (fun ext -> ext.ext_id) tyext.tyext_constructors + @ all_idents rem + | Tstr_exception ext -> ext.ext_id :: all_idents rem | Tstr_recmodule decls -> List.map (fun mb -> mb.mb_id) decls @ all_idents rem | Tstr_modtype _ -> all_idents rem @@ -498,7 +533,8 @@ and all_idents = function | Tstr_class cl_list -> List.map (fun (ci, _, _) -> ci.ci_id_class) cl_list @ all_idents rem | Tstr_class_type cl_list -> all_idents rem - | Tstr_include(modl, sg, _) -> bound_value_identifiers sg @ all_idents rem + | Tstr_include incl -> + bound_value_identifiers incl.incl_type @ all_idents rem | Tstr_module {mb_id;mb_expr={mod_desc = Tmod_structure str}} -> mb_id :: all_idents str.str_items @ all_idents rem | Tstr_module mb -> mb.mb_id :: all_idents rem @@ -545,14 +581,18 @@ let transl_store_structure glob map prims str = transl_store rootpath subst rem | Tstr_type(decls) -> transl_store rootpath subst rem - | Tstr_exception decl -> - let id = decl.cd_id in - let lam = transl_exception (field_path rootpath id) decl in - Lsequence(Llet(Strict, id, lam, store_ident id), - transl_store rootpath (add_ident false id subst) rem) - | Tstr_exn_rebind( id, _, path, {Location.loc=loc}, _) -> - let lam = subst_lambda subst (transl_path ~loc item.str_env path) in - Lsequence(Llet(Strict, id, lam, store_ident id), + | Tstr_typext(tyext) -> + let ids = List.map (fun ext -> ext.ext_id) tyext.tyext_constructors in + let lam = + transl_type_extension item.str_env rootpath tyext (store_idents ids) + in + Lsequence(subst_lambda subst lam, + transl_store rootpath (add_idents false ids subst) rem) + | Tstr_exception ext -> + let id = ext.ext_id in + let path = field_path rootpath id in + let lam = transl_extension_constructor item.str_env path ext in + Lsequence(Llet(Strict, id, subst_lambda subst lam, store_ident id), transl_store rootpath (add_ident false id subst) rem) | Tstr_module{mb_id=id; mb_expr={mod_desc = Tmod_structure str}} -> let lam = transl_store (field_path rootpath id) subst str.str_items in @@ -600,8 +640,9 @@ let transl_store_structure glob map prims str = store_idents ids) in Lsequence(subst_lambda subst lam, transl_store rootpath (add_idents false ids subst) rem) - | Tstr_include(modl, sg, _attrs) -> - let ids = bound_value_identifiers sg in + | Tstr_include incl -> + let ids = bound_value_identifiers incl.incl_type in + let modl = incl.incl_mod in let mid = Ident.create "include" in let rec store_idents pos = function [] -> transl_store rootpath (add_idents true ids subst) rem @@ -760,10 +801,19 @@ let transl_toplevel_item item = let idents = let_bound_idents pat_expr_list in transl_let rec_flag pat_expr_list (make_sequence toploop_setvalue_id idents) - | Tstr_exception decl -> - toploop_setvalue decl.cd_id (transl_exception None decl) - | Tstr_exn_rebind(id, _, path, {Location.loc=loc}, _) -> - toploop_setvalue id (transl_path ~loc item.str_env path) + | Tstr_typext(tyext) -> + let idents = + List.map (fun ext -> ext.ext_id) tyext.tyext_constructors + in + (* we need to use unique name in case of multiple + definitions of the same extension constructor in the toplevel *) + List.iter set_toplevel_unique_name idents; + transl_type_extension item.str_env None tyext + (make_sequence toploop_setvalue_id idents) + | Tstr_exception ext -> + set_toplevel_unique_name ext.ext_id; + toploop_setvalue ext.ext_id + (transl_extension_constructor item.str_env None ext) | Tstr_module {mb_id=id; mb_expr=modl} -> (* we need to use the unique name for the module because of issues with "open" (PR#1672) *) @@ -790,8 +840,9 @@ let transl_toplevel_item item = make_sequence (fun (ci, _, _) -> toploop_setvalue_id ci.ci_id_class) cl_list) - | Tstr_include(modl, sg, _attrs) -> - let ids = bound_value_identifiers sg in + | Tstr_include incl -> + let ids = bound_value_identifiers incl.incl_type in + let modl = incl.incl_mod in let mid = Ident.create "include" in let rec set_idents pos = function [] -> @@ -868,7 +919,7 @@ let transl_store_package component_names target_name coercion = [Lprim(Pgetglobal target_name, []); Lprim(Pfield pos, [Lvar blk])])) 0 pos_cc_list)) - (* + (* (* ignore id_pos_list as the ids are already bound *) let id = Array.of_list component_names in (List.length pos_cc_list, @@ -900,3 +951,9 @@ let () = | _ -> None ) + +let reset () = + primitive_declarations := []; + transl_store_subst := Ident.empty; + toploop_ident.Ident.flags <- 0; + aliased_idents := Ident.empty diff --git a/bytecomp/translmod.mli b/bytecomp/translmod.mli index 8e5005546..1d84aaabd 100644 --- a/bytecomp/translmod.mli +++ b/bytecomp/translmod.mli @@ -37,3 +37,5 @@ type error = exception Error of Location.t * error val report_error: Format.formatter -> error -> unit + +val reset: unit -> unit diff --git a/bytecomp/translobj.ml b/bytecomp/translobj.ml index 7f0d8577e..02731ec68 100644 --- a/bytecomp/translobj.ml +++ b/bytecomp/translobj.ml @@ -162,3 +162,14 @@ let oo_wrap env req f x = wrapping := false; top_env := Env.empty; raise exn + +let reset () = + Hashtbl.clear consts; + cache_required := false; + method_cache := lambda_unit; + method_count := 0; + method_table := []; + wrapping := false; + top_env := Env.empty; + classes := []; + method_ids := IdentSet.empty diff --git a/bytecomp/translobj.mli b/bytecomp/translobj.mli index 55c163433..a44ac683f 100644 --- a/bytecomp/translobj.mli +++ b/bytecomp/translobj.mli @@ -26,3 +26,5 @@ val method_ids: IdentSet.t ref (* reset when starting a new wrapper *) val oo_wrap: Env.t -> bool -> ('a -> lambda) -> 'a -> lambda val oo_add_class: Ident.t -> Env.t * bool + +val reset: unit -> unit diff --git a/bytecomp/typeopt.ml b/bytecomp/typeopt.ml index c96e32b66..eb8c9435e 100644 --- a/bytecomp/typeopt.ml +++ b/bytecomp/typeopt.ml @@ -34,7 +34,7 @@ let maybe_pointer exp = match Env.find_type p exp.exp_env with | {type_kind = Type_variant []} -> true (* type exn *) | {type_kind = Type_variant cstrs} -> - List.exists (fun c -> c.Types.cd_args <> []) cstrs + List.exists (fun c -> c.Types.cd_args <> Cstr_tuple []) cstrs | _ -> true with Not_found -> true (* This can happen due to e.g. missing -I options, @@ -64,7 +64,8 @@ let array_element_kind env ty = {type_kind = Type_abstract} -> Pgenarray | {type_kind = Type_variant cstrs} - when List.for_all (fun c -> c.Types.cd_args = []) cstrs -> + when List.for_all (fun c -> c.Types.cd_args = Cstr_tuple []) + cstrs -> Pintarray | {type_kind = _} -> Paddrarray diff --git a/byterun/.depend b/byterun/.depend index a68ab0904..743737d05 100644 --- a/byterun/.depend +++ b/byterun/.depend @@ -1,419 +1,422 @@ alloc.o: alloc.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h custom.h major_gc.h freelist.h memory.h gc.h \ - minor_gc.h stacks.h + ../config/s.h mlvalues.h custom.h major_gc.h freelist.h memory.h gc.h \ + minor_gc.h stacks.h array.o: array.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h memory.h gc.h major_gc.h freelist.h \ - minor_gc.h + ../config/s.h mlvalues.h fail.h memory.h gc.h major_gc.h freelist.h \ + minor_gc.h backtrace.o: backtrace.c config.h ../config/m.h ../config/s.h \ - compatibility.h mlvalues.h misc.h alloc.h io.h instruct.h intext.h \ - exec.h fix_code.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ - startup.h stacks.h sys.h backtrace.h + compatibility.h mlvalues.h misc.h alloc.h io.h instruct.h intext.h \ + exec.h fix_code.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ + startup.h stacks.h sys.h backtrace.h fail.h callback.o: callback.c callback.h compatibility.h mlvalues.h config.h \ - ../config/m.h ../config/s.h misc.h fail.h memory.h gc.h major_gc.h \ - freelist.h minor_gc.h interp.h instruct.h fix_code.h stacks.h + ../config/m.h ../config/s.h misc.h fail.h memory.h gc.h major_gc.h \ + freelist.h minor_gc.h interp.h instruct.h fix_code.h stacks.h compact.o: compact.c config.h ../config/m.h ../config/s.h compatibility.h \ - finalise.h roots.h misc.h memory.h gc.h mlvalues.h major_gc.h freelist.h \ - minor_gc.h gc_ctrl.h weak.h + finalise.h roots.h misc.h memory.h gc.h mlvalues.h major_gc.h \ + freelist.h minor_gc.h gc_ctrl.h weak.h compare.o: compare.c custom.h compatibility.h mlvalues.h config.h \ - ../config/m.h ../config/s.h misc.h fail.h memory.h gc.h major_gc.h \ - freelist.h minor_gc.h + ../config/m.h ../config/s.h misc.h fail.h memory.h gc.h major_gc.h \ + freelist.h minor_gc.h custom.o: custom.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h custom.h fail.h memory.h gc.h major_gc.h \ - freelist.h minor_gc.h + ../config/s.h mlvalues.h custom.h fail.h memory.h gc.h major_gc.h \ + freelist.h minor_gc.h debugger.o: debugger.c alloc.h compatibility.h misc.h config.h \ - ../config/m.h ../config/s.h mlvalues.h debugger.h fail.h fix_code.h \ - instruct.h intext.h io.h stacks.h memory.h gc.h major_gc.h freelist.h \ - minor_gc.h sys.h + ../config/m.h ../config/s.h mlvalues.h debugger.h fail.h fix_code.h \ + instruct.h intext.h io.h stacks.h memory.h gc.h major_gc.h freelist.h \ + minor_gc.h sys.h dynlink.o: dynlink.c config.h ../config/m.h ../config/s.h compatibility.h \ - alloc.h misc.h mlvalues.h dynlink.h fail.h memory.h gc.h major_gc.h \ - freelist.h minor_gc.h osdeps.h prims.h + alloc.h misc.h mlvalues.h dynlink.h fail.h memory.h gc.h major_gc.h \ + freelist.h minor_gc.h osdeps.h prims.h extern.o: extern.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h custom.h fail.h gc.h intext.h io.h md5.h \ - memory.h major_gc.h freelist.h minor_gc.h reverse.h + ../config/s.h mlvalues.h custom.h fail.h gc.h intext.h io.h md5.h \ + memory.h major_gc.h freelist.h minor_gc.h reverse.h fail.o: fail.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h io.h gc.h memory.h major_gc.h freelist.h \ - minor_gc.h printexc.h signals.h stacks.h + ../config/s.h mlvalues.h fail.h io.h gc.h memory.h major_gc.h \ + freelist.h minor_gc.h printexc.h signals.h stacks.h finalise.o: finalise.c callback.h compatibility.h mlvalues.h config.h \ - ../config/m.h ../config/s.h misc.h fail.h roots.h memory.h gc.h \ - major_gc.h freelist.h minor_gc.h signals.h + ../config/m.h ../config/s.h misc.h fail.h roots.h memory.h gc.h \ + major_gc.h freelist.h minor_gc.h signals.h fix_code.o: fix_code.c config.h ../config/m.h ../config/s.h \ - compatibility.h debugger.h misc.h mlvalues.h fix_code.h instruct.h \ - intext.h io.h md5.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ - reverse.h + compatibility.h debugger.h misc.h mlvalues.h fix_code.h instruct.h \ + intext.h io.h md5.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ + reverse.h floats.o: floats.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h memory.h gc.h major_gc.h freelist.h \ - minor_gc.h reverse.h stacks.h + ../config/s.h mlvalues.h fail.h memory.h gc.h major_gc.h freelist.h \ + minor_gc.h reverse.h stacks.h freelist.o: freelist.c config.h ../config/m.h ../config/s.h \ - compatibility.h freelist.h misc.h mlvalues.h gc.h gc_ctrl.h memory.h \ - major_gc.h minor_gc.h + compatibility.h freelist.h misc.h mlvalues.h gc.h gc_ctrl.h memory.h \ + major_gc.h minor_gc.h gc_ctrl.o: gc_ctrl.c alloc.h compatibility.h misc.h config.h \ - ../config/m.h ../config/s.h mlvalues.h compact.h custom.h finalise.h \ - roots.h memory.h gc.h major_gc.h freelist.h minor_gc.h gc_ctrl.h \ - stacks.h + ../config/m.h ../config/s.h mlvalues.h compact.h custom.h finalise.h \ + roots.h memory.h gc.h major_gc.h freelist.h minor_gc.h gc_ctrl.h \ + stacks.h globroots.o: globroots.c memory.h compatibility.h config.h ../config/m.h \ - ../config/s.h gc.h mlvalues.h misc.h major_gc.h freelist.h minor_gc.h \ - roots.h globroots.h + ../config/s.h gc.h mlvalues.h misc.h major_gc.h freelist.h minor_gc.h \ + roots.h globroots.h hash.o: hash.c mlvalues.h compatibility.h config.h ../config/m.h \ - ../config/s.h misc.h custom.h memory.h gc.h major_gc.h freelist.h \ - minor_gc.h hash.h int64_native.h + ../config/s.h misc.h custom.h memory.h gc.h major_gc.h freelist.h \ + minor_gc.h hash.h instrtrace.o: instrtrace.c intern.o: intern.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h callback.h custom.h fail.h gc.h intext.h io.h \ - md5.h memory.h major_gc.h freelist.h minor_gc.h reverse.h + ../config/s.h mlvalues.h callback.h custom.h fail.h gc.h intext.h io.h \ + md5.h memory.h major_gc.h freelist.h minor_gc.h reverse.h interp.o: interp.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h backtrace.h callback.h debugger.h fail.h \ - fix_code.h instrtrace.h instruct.h interp.h major_gc.h freelist.h \ - memory.h gc.h minor_gc.h prims.h signals.h stacks.h jumptbl.h + ../config/s.h mlvalues.h backtrace.h callback.h debugger.h fail.h \ + fix_code.h instrtrace.h instruct.h interp.h major_gc.h freelist.h \ + memory.h gc.h minor_gc.h prims.h signals.h stacks.h jumptbl.h ints.o: ints.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h custom.h fail.h intext.h io.h memory.h gc.h \ - major_gc.h freelist.h minor_gc.h int64_native.h + ../config/s.h mlvalues.h custom.h fail.h intext.h io.h memory.h gc.h \ + major_gc.h freelist.h minor_gc.h io.o: io.c config.h ../config/m.h ../config/s.h compatibility.h alloc.h \ - misc.h mlvalues.h custom.h fail.h io.h memory.h gc.h major_gc.h \ - freelist.h minor_gc.h signals.h sys.h + misc.h mlvalues.h custom.h fail.h io.h memory.h gc.h major_gc.h \ + freelist.h minor_gc.h signals.h sys.h lexing.o: lexing.c fail.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h stacks.h memory.h gc.h major_gc.h freelist.h \ - minor_gc.h + ../config/s.h mlvalues.h stacks.h memory.h gc.h major_gc.h freelist.h \ + minor_gc.h main.o: main.c misc.h compatibility.h config.h ../config/m.h \ - ../config/s.h mlvalues.h sys.h + ../config/s.h mlvalues.h sys.h major_gc.o: major_gc.c compact.h config.h ../config/m.h ../config/s.h \ - compatibility.h misc.h custom.h mlvalues.h fail.h finalise.h roots.h \ - memory.h gc.h major_gc.h freelist.h minor_gc.h gc_ctrl.h weak.h + compatibility.h misc.h custom.h mlvalues.h fail.h finalise.h roots.h \ + memory.h gc.h major_gc.h freelist.h minor_gc.h gc_ctrl.h weak.h md5.o: md5.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h md5.h io.h memory.h gc.h major_gc.h \ - freelist.h minor_gc.h reverse.h + ../config/s.h mlvalues.h fail.h md5.h io.h memory.h gc.h major_gc.h \ + freelist.h minor_gc.h reverse.h memory.o: memory.c fail.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h freelist.h gc.h gc_ctrl.h major_gc.h memory.h \ - minor_gc.h signals.h + ../config/s.h mlvalues.h freelist.h gc.h gc_ctrl.h major_gc.h memory.h \ + minor_gc.h signals.h meta.o: meta.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h fix_code.h interp.h intext.h io.h \ - major_gc.h freelist.h memory.h gc.h minor_gc.h prims.h stacks.h + ../config/s.h mlvalues.h fail.h fix_code.h interp.h intext.h io.h \ + major_gc.h freelist.h memory.h gc.h minor_gc.h prims.h stacks.h minor_gc.o: minor_gc.c config.h ../config/m.h ../config/s.h \ - compatibility.h fail.h misc.h mlvalues.h finalise.h roots.h memory.h \ - gc.h major_gc.h freelist.h minor_gc.h gc_ctrl.h signals.h weak.h + compatibility.h fail.h misc.h mlvalues.h finalise.h roots.h memory.h \ + gc.h major_gc.h freelist.h minor_gc.h gc_ctrl.h signals.h weak.h misc.o: misc.c config.h ../config/m.h ../config/s.h compatibility.h \ - misc.h memory.h gc.h mlvalues.h major_gc.h freelist.h minor_gc.h + misc.h memory.h gc.h mlvalues.h major_gc.h freelist.h minor_gc.h obj.o: obj.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h gc.h interp.h major_gc.h freelist.h \ - memory.h minor_gc.h prims.h + ../config/s.h mlvalues.h fail.h gc.h interp.h major_gc.h freelist.h \ + memory.h minor_gc.h prims.h parsing.o: parsing.c config.h ../config/m.h ../config/s.h compatibility.h \ - mlvalues.h misc.h memory.h gc.h major_gc.h freelist.h minor_gc.h alloc.h + mlvalues.h misc.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ + alloc.h prims.o: prims.c mlvalues.h compatibility.h config.h ../config/m.h \ - ../config/s.h misc.h prims.h + ../config/s.h misc.h prims.h printexc.o: printexc.c backtrace.h mlvalues.h compatibility.h config.h \ - ../config/m.h ../config/s.h misc.h callback.h debugger.h fail.h \ - printexc.h + ../config/m.h ../config/s.h misc.h callback.h debugger.h fail.h \ + printexc.h roots.o: roots.c finalise.h roots.h misc.h compatibility.h config.h \ - ../config/m.h ../config/s.h memory.h gc.h mlvalues.h major_gc.h \ - freelist.h minor_gc.h globroots.h stacks.h + ../config/m.h ../config/s.h memory.h gc.h mlvalues.h major_gc.h \ + freelist.h minor_gc.h globroots.h stacks.h signals.o: signals.c alloc.h compatibility.h misc.h config.h \ - ../config/m.h ../config/s.h mlvalues.h callback.h fail.h memory.h gc.h \ - major_gc.h freelist.h minor_gc.h roots.h signals.h signals_machdep.h \ - sys.h + ../config/m.h ../config/s.h mlvalues.h callback.h fail.h memory.h gc.h \ + major_gc.h freelist.h minor_gc.h roots.h signals.h signals_machdep.h \ + sys.h signals_byt.o: signals_byt.c config.h ../config/m.h ../config/s.h \ - compatibility.h memory.h gc.h mlvalues.h misc.h major_gc.h freelist.h \ - minor_gc.h osdeps.h signals.h signals_machdep.h + compatibility.h memory.h gc.h mlvalues.h misc.h major_gc.h freelist.h \ + minor_gc.h osdeps.h signals.h signals_machdep.h stacks.o: stacks.c config.h ../config/m.h ../config/s.h compatibility.h \ - fail.h misc.h mlvalues.h stacks.h memory.h gc.h major_gc.h freelist.h \ - minor_gc.h + fail.h misc.h mlvalues.h stacks.h memory.h gc.h major_gc.h freelist.h \ + minor_gc.h startup.o: startup.c config.h ../config/m.h ../config/s.h compatibility.h \ - alloc.h misc.h mlvalues.h backtrace.h callback.h custom.h debugger.h \ - dynlink.h exec.h fail.h fix_code.h freelist.h gc_ctrl.h instrtrace.h \ - interp.h intext.h io.h memory.h gc.h major_gc.h minor_gc.h osdeps.h \ - prims.h printexc.h reverse.h signals.h stacks.h sys.h startup.h \ - version.h + alloc.h misc.h mlvalues.h backtrace.h callback.h custom.h debugger.h \ + dynlink.h exec.h fail.h fix_code.h freelist.h gc_ctrl.h instrtrace.h \ + interp.h intext.h io.h memory.h gc.h major_gc.h minor_gc.h osdeps.h \ + prims.h printexc.h reverse.h signals.h stacks.h sys.h startup.h \ + version.h str.o: str.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h int64_native.h + ../config/s.h mlvalues.h fail.h sys.o: sys.c config.h ../config/m.h ../config/s.h compatibility.h alloc.h \ - misc.h mlvalues.h debugger.h fail.h instruct.h osdeps.h signals.h \ - stacks.h memory.h gc.h major_gc.h freelist.h minor_gc.h sys.h + misc.h mlvalues.h debugger.h fail.h instruct.h osdeps.h signals.h \ + stacks.h memory.h gc.h major_gc.h freelist.h minor_gc.h sys.h terminfo.o: terminfo.c config.h ../config/m.h ../config/s.h \ - compatibility.h alloc.h misc.h mlvalues.h fail.h io.h + compatibility.h alloc.h misc.h mlvalues.h fail.h io.h unix.o: unix.c config.h ../config/m.h ../config/s.h compatibility.h \ - memory.h gc.h mlvalues.h misc.h major_gc.h freelist.h minor_gc.h \ - osdeps.h + memory.h gc.h mlvalues.h misc.h major_gc.h freelist.h minor_gc.h \ + osdeps.h weak.o: weak.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h major_gc.h freelist.h memory.h gc.h \ - minor_gc.h + ../config/s.h mlvalues.h fail.h major_gc.h freelist.h memory.h gc.h \ + minor_gc.h win32.o: win32.c fail.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ - osdeps.h signals.h sys.h + ../config/s.h mlvalues.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ + osdeps.h signals.h sys.h alloc.d.o: alloc.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h custom.h major_gc.h freelist.h memory.h gc.h \ - minor_gc.h stacks.h + ../config/s.h mlvalues.h custom.h major_gc.h freelist.h memory.h gc.h \ + minor_gc.h stacks.h array.d.o: array.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h memory.h gc.h major_gc.h freelist.h \ - minor_gc.h + ../config/s.h mlvalues.h fail.h memory.h gc.h major_gc.h freelist.h \ + minor_gc.h backtrace.d.o: backtrace.c config.h ../config/m.h ../config/s.h \ - compatibility.h mlvalues.h misc.h alloc.h io.h instruct.h intext.h \ - exec.h fix_code.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ - startup.h stacks.h sys.h backtrace.h + compatibility.h mlvalues.h misc.h alloc.h io.h instruct.h intext.h \ + exec.h fix_code.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ + startup.h stacks.h sys.h backtrace.h fail.h callback.d.o: callback.c callback.h compatibility.h mlvalues.h config.h \ - ../config/m.h ../config/s.h misc.h fail.h memory.h gc.h major_gc.h \ - freelist.h minor_gc.h interp.h instruct.h fix_code.h stacks.h + ../config/m.h ../config/s.h misc.h fail.h memory.h gc.h major_gc.h \ + freelist.h minor_gc.h interp.h instruct.h fix_code.h stacks.h compact.d.o: compact.c config.h ../config/m.h ../config/s.h compatibility.h \ - finalise.h roots.h misc.h memory.h gc.h mlvalues.h major_gc.h freelist.h \ - minor_gc.h gc_ctrl.h weak.h + finalise.h roots.h misc.h memory.h gc.h mlvalues.h major_gc.h \ + freelist.h minor_gc.h gc_ctrl.h weak.h compare.d.o: compare.c custom.h compatibility.h mlvalues.h config.h \ - ../config/m.h ../config/s.h misc.h fail.h memory.h gc.h major_gc.h \ - freelist.h minor_gc.h + ../config/m.h ../config/s.h misc.h fail.h memory.h gc.h major_gc.h \ + freelist.h minor_gc.h custom.d.o: custom.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h custom.h fail.h memory.h gc.h major_gc.h \ - freelist.h minor_gc.h + ../config/s.h mlvalues.h custom.h fail.h memory.h gc.h major_gc.h \ + freelist.h minor_gc.h debugger.d.o: debugger.c alloc.h compatibility.h misc.h config.h \ - ../config/m.h ../config/s.h mlvalues.h debugger.h fail.h fix_code.h \ - instruct.h intext.h io.h stacks.h memory.h gc.h major_gc.h freelist.h \ - minor_gc.h sys.h + ../config/m.h ../config/s.h mlvalues.h debugger.h fail.h fix_code.h \ + instruct.h intext.h io.h stacks.h memory.h gc.h major_gc.h freelist.h \ + minor_gc.h sys.h dynlink.d.o: dynlink.c config.h ../config/m.h ../config/s.h compatibility.h \ - alloc.h misc.h mlvalues.h dynlink.h fail.h memory.h gc.h major_gc.h \ - freelist.h minor_gc.h osdeps.h prims.h + alloc.h misc.h mlvalues.h dynlink.h fail.h memory.h gc.h major_gc.h \ + freelist.h minor_gc.h osdeps.h prims.h extern.d.o: extern.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h custom.h fail.h gc.h intext.h io.h md5.h \ - memory.h major_gc.h freelist.h minor_gc.h reverse.h + ../config/s.h mlvalues.h custom.h fail.h gc.h intext.h io.h md5.h \ + memory.h major_gc.h freelist.h minor_gc.h reverse.h fail.d.o: fail.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h io.h gc.h memory.h major_gc.h freelist.h \ - minor_gc.h printexc.h signals.h stacks.h + ../config/s.h mlvalues.h fail.h io.h gc.h memory.h major_gc.h \ + freelist.h minor_gc.h printexc.h signals.h stacks.h finalise.d.o: finalise.c callback.h compatibility.h mlvalues.h config.h \ - ../config/m.h ../config/s.h misc.h fail.h roots.h memory.h gc.h \ - major_gc.h freelist.h minor_gc.h signals.h + ../config/m.h ../config/s.h misc.h fail.h roots.h memory.h gc.h \ + major_gc.h freelist.h minor_gc.h signals.h fix_code.d.o: fix_code.c config.h ../config/m.h ../config/s.h \ - compatibility.h debugger.h misc.h mlvalues.h fix_code.h instruct.h \ - intext.h io.h md5.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ - reverse.h + compatibility.h debugger.h misc.h mlvalues.h fix_code.h instruct.h \ + intext.h io.h md5.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ + reverse.h floats.d.o: floats.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h memory.h gc.h major_gc.h freelist.h \ - minor_gc.h reverse.h stacks.h + ../config/s.h mlvalues.h fail.h memory.h gc.h major_gc.h freelist.h \ + minor_gc.h reverse.h stacks.h freelist.d.o: freelist.c config.h ../config/m.h ../config/s.h \ - compatibility.h freelist.h misc.h mlvalues.h gc.h gc_ctrl.h memory.h \ - major_gc.h minor_gc.h + compatibility.h freelist.h misc.h mlvalues.h gc.h gc_ctrl.h memory.h \ + major_gc.h minor_gc.h gc_ctrl.d.o: gc_ctrl.c alloc.h compatibility.h misc.h config.h \ - ../config/m.h ../config/s.h mlvalues.h compact.h custom.h finalise.h \ - roots.h memory.h gc.h major_gc.h freelist.h minor_gc.h gc_ctrl.h \ - stacks.h + ../config/m.h ../config/s.h mlvalues.h compact.h custom.h finalise.h \ + roots.h memory.h gc.h major_gc.h freelist.h minor_gc.h gc_ctrl.h \ + stacks.h globroots.d.o: globroots.c memory.h compatibility.h config.h ../config/m.h \ - ../config/s.h gc.h mlvalues.h misc.h major_gc.h freelist.h minor_gc.h \ - roots.h globroots.h + ../config/s.h gc.h mlvalues.h misc.h major_gc.h freelist.h minor_gc.h \ + roots.h globroots.h hash.d.o: hash.c mlvalues.h compatibility.h config.h ../config/m.h \ - ../config/s.h misc.h custom.h memory.h gc.h major_gc.h freelist.h \ - minor_gc.h hash.h int64_native.h + ../config/s.h misc.h custom.h memory.h gc.h major_gc.h freelist.h \ + minor_gc.h hash.h instrtrace.d.o: instrtrace.c instruct.h misc.h compatibility.h config.h \ - ../config/m.h ../config/s.h mlvalues.h opnames.h prims.h stacks.h \ - memory.h gc.h major_gc.h freelist.h minor_gc.h + ../config/m.h ../config/s.h mlvalues.h opnames.h prims.h stacks.h \ + memory.h gc.h major_gc.h freelist.h minor_gc.h intern.d.o: intern.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h callback.h custom.h fail.h gc.h intext.h io.h \ - md5.h memory.h major_gc.h freelist.h minor_gc.h reverse.h + ../config/s.h mlvalues.h callback.h custom.h fail.h gc.h intext.h io.h \ + md5.h memory.h major_gc.h freelist.h minor_gc.h reverse.h interp.d.o: interp.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h backtrace.h callback.h debugger.h fail.h \ - fix_code.h instrtrace.h instruct.h interp.h major_gc.h freelist.h \ - memory.h gc.h minor_gc.h prims.h signals.h stacks.h + ../config/s.h mlvalues.h backtrace.h callback.h debugger.h fail.h \ + fix_code.h instrtrace.h instruct.h interp.h major_gc.h freelist.h \ + memory.h gc.h minor_gc.h prims.h signals.h stacks.h ints.d.o: ints.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h custom.h fail.h intext.h io.h memory.h gc.h \ - major_gc.h freelist.h minor_gc.h int64_native.h + ../config/s.h mlvalues.h custom.h fail.h intext.h io.h memory.h gc.h \ + major_gc.h freelist.h minor_gc.h io.d.o: io.c config.h ../config/m.h ../config/s.h compatibility.h alloc.h \ - misc.h mlvalues.h custom.h fail.h io.h memory.h gc.h major_gc.h \ - freelist.h minor_gc.h signals.h sys.h + misc.h mlvalues.h custom.h fail.h io.h memory.h gc.h major_gc.h \ + freelist.h minor_gc.h signals.h sys.h lexing.d.o: lexing.c fail.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h stacks.h memory.h gc.h major_gc.h freelist.h \ - minor_gc.h + ../config/s.h mlvalues.h stacks.h memory.h gc.h major_gc.h freelist.h \ + minor_gc.h main.d.o: main.c misc.h compatibility.h config.h ../config/m.h \ - ../config/s.h mlvalues.h sys.h + ../config/s.h mlvalues.h sys.h major_gc.d.o: major_gc.c compact.h config.h ../config/m.h ../config/s.h \ - compatibility.h misc.h custom.h mlvalues.h fail.h finalise.h roots.h \ - memory.h gc.h major_gc.h freelist.h minor_gc.h gc_ctrl.h weak.h + compatibility.h misc.h custom.h mlvalues.h fail.h finalise.h roots.h \ + memory.h gc.h major_gc.h freelist.h minor_gc.h gc_ctrl.h weak.h md5.d.o: md5.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h md5.h io.h memory.h gc.h major_gc.h \ - freelist.h minor_gc.h reverse.h + ../config/s.h mlvalues.h fail.h md5.h io.h memory.h gc.h major_gc.h \ + freelist.h minor_gc.h reverse.h memory.d.o: memory.c fail.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h freelist.h gc.h gc_ctrl.h major_gc.h memory.h \ - minor_gc.h signals.h + ../config/s.h mlvalues.h freelist.h gc.h gc_ctrl.h major_gc.h memory.h \ + minor_gc.h signals.h meta.d.o: meta.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h fix_code.h interp.h intext.h io.h \ - major_gc.h freelist.h memory.h gc.h minor_gc.h prims.h stacks.h + ../config/s.h mlvalues.h fail.h fix_code.h interp.h intext.h io.h \ + major_gc.h freelist.h memory.h gc.h minor_gc.h prims.h stacks.h minor_gc.d.o: minor_gc.c config.h ../config/m.h ../config/s.h \ - compatibility.h fail.h misc.h mlvalues.h finalise.h roots.h memory.h \ - gc.h major_gc.h freelist.h minor_gc.h gc_ctrl.h signals.h weak.h + compatibility.h fail.h misc.h mlvalues.h finalise.h roots.h memory.h \ + gc.h major_gc.h freelist.h minor_gc.h gc_ctrl.h signals.h weak.h misc.d.o: misc.c config.h ../config/m.h ../config/s.h compatibility.h \ - misc.h memory.h gc.h mlvalues.h major_gc.h freelist.h minor_gc.h + misc.h memory.h gc.h mlvalues.h major_gc.h freelist.h minor_gc.h obj.d.o: obj.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h gc.h interp.h major_gc.h freelist.h \ - memory.h minor_gc.h prims.h + ../config/s.h mlvalues.h fail.h gc.h interp.h major_gc.h freelist.h \ + memory.h minor_gc.h prims.h parsing.d.o: parsing.c config.h ../config/m.h ../config/s.h compatibility.h \ - mlvalues.h misc.h memory.h gc.h major_gc.h freelist.h minor_gc.h alloc.h + mlvalues.h misc.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ + alloc.h prims.d.o: prims.c mlvalues.h compatibility.h config.h ../config/m.h \ - ../config/s.h misc.h prims.h + ../config/s.h misc.h prims.h printexc.d.o: printexc.c backtrace.h mlvalues.h compatibility.h config.h \ - ../config/m.h ../config/s.h misc.h callback.h debugger.h fail.h \ - printexc.h + ../config/m.h ../config/s.h misc.h callback.h debugger.h fail.h \ + printexc.h roots.d.o: roots.c finalise.h roots.h misc.h compatibility.h config.h \ - ../config/m.h ../config/s.h memory.h gc.h mlvalues.h major_gc.h \ - freelist.h minor_gc.h globroots.h stacks.h + ../config/m.h ../config/s.h memory.h gc.h mlvalues.h major_gc.h \ + freelist.h minor_gc.h globroots.h stacks.h signals.d.o: signals.c alloc.h compatibility.h misc.h config.h \ - ../config/m.h ../config/s.h mlvalues.h callback.h fail.h memory.h gc.h \ - major_gc.h freelist.h minor_gc.h roots.h signals.h signals_machdep.h \ - sys.h + ../config/m.h ../config/s.h mlvalues.h callback.h fail.h memory.h gc.h \ + major_gc.h freelist.h minor_gc.h roots.h signals.h signals_machdep.h \ + sys.h signals_byt.d.o: signals_byt.c config.h ../config/m.h ../config/s.h \ - compatibility.h memory.h gc.h mlvalues.h misc.h major_gc.h freelist.h \ - minor_gc.h osdeps.h signals.h signals_machdep.h + compatibility.h memory.h gc.h mlvalues.h misc.h major_gc.h freelist.h \ + minor_gc.h osdeps.h signals.h signals_machdep.h stacks.d.o: stacks.c config.h ../config/m.h ../config/s.h compatibility.h \ - fail.h misc.h mlvalues.h stacks.h memory.h gc.h major_gc.h freelist.h \ - minor_gc.h + fail.h misc.h mlvalues.h stacks.h memory.h gc.h major_gc.h freelist.h \ + minor_gc.h startup.d.o: startup.c config.h ../config/m.h ../config/s.h compatibility.h \ - alloc.h misc.h mlvalues.h backtrace.h callback.h custom.h debugger.h \ - dynlink.h exec.h fail.h fix_code.h freelist.h gc_ctrl.h instrtrace.h \ - interp.h intext.h io.h memory.h gc.h major_gc.h minor_gc.h osdeps.h \ - prims.h printexc.h reverse.h signals.h stacks.h sys.h startup.h \ - version.h + alloc.h misc.h mlvalues.h backtrace.h callback.h custom.h debugger.h \ + dynlink.h exec.h fail.h fix_code.h freelist.h gc_ctrl.h instrtrace.h \ + interp.h intext.h io.h memory.h gc.h major_gc.h minor_gc.h osdeps.h \ + prims.h printexc.h reverse.h signals.h stacks.h sys.h startup.h \ + version.h str.d.o: str.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h int64_native.h + ../config/s.h mlvalues.h fail.h sys.d.o: sys.c config.h ../config/m.h ../config/s.h compatibility.h alloc.h \ - misc.h mlvalues.h debugger.h fail.h instruct.h osdeps.h signals.h \ - stacks.h memory.h gc.h major_gc.h freelist.h minor_gc.h sys.h + misc.h mlvalues.h debugger.h fail.h instruct.h osdeps.h signals.h \ + stacks.h memory.h gc.h major_gc.h freelist.h minor_gc.h sys.h terminfo.d.o: terminfo.c config.h ../config/m.h ../config/s.h \ - compatibility.h alloc.h misc.h mlvalues.h fail.h io.h + compatibility.h alloc.h misc.h mlvalues.h fail.h io.h unix.d.o: unix.c config.h ../config/m.h ../config/s.h compatibility.h \ - memory.h gc.h mlvalues.h misc.h major_gc.h freelist.h minor_gc.h \ - osdeps.h + memory.h gc.h mlvalues.h misc.h major_gc.h freelist.h minor_gc.h \ + osdeps.h weak.d.o: weak.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h major_gc.h freelist.h memory.h gc.h \ - minor_gc.h + ../config/s.h mlvalues.h fail.h major_gc.h freelist.h memory.h gc.h \ + minor_gc.h win32.d.o: win32.c fail.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ - osdeps.h signals.h sys.h + ../config/s.h mlvalues.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ + osdeps.h signals.h sys.h alloc.pic.o: alloc.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h custom.h major_gc.h freelist.h memory.h gc.h \ - minor_gc.h stacks.h + ../config/s.h mlvalues.h custom.h major_gc.h freelist.h memory.h gc.h \ + minor_gc.h stacks.h array.pic.o: array.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h memory.h gc.h major_gc.h freelist.h \ - minor_gc.h + ../config/s.h mlvalues.h fail.h memory.h gc.h major_gc.h freelist.h \ + minor_gc.h backtrace.pic.o: backtrace.c config.h ../config/m.h ../config/s.h \ - compatibility.h mlvalues.h misc.h alloc.h io.h instruct.h intext.h \ - exec.h fix_code.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ - startup.h stacks.h sys.h backtrace.h + compatibility.h mlvalues.h misc.h alloc.h io.h instruct.h intext.h \ + exec.h fix_code.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ + startup.h stacks.h sys.h backtrace.h fail.h callback.pic.o: callback.c callback.h compatibility.h mlvalues.h config.h \ - ../config/m.h ../config/s.h misc.h fail.h memory.h gc.h major_gc.h \ - freelist.h minor_gc.h interp.h instruct.h fix_code.h stacks.h + ../config/m.h ../config/s.h misc.h fail.h memory.h gc.h major_gc.h \ + freelist.h minor_gc.h interp.h instruct.h fix_code.h stacks.h compact.pic.o: compact.c config.h ../config/m.h ../config/s.h compatibility.h \ - finalise.h roots.h misc.h memory.h gc.h mlvalues.h major_gc.h freelist.h \ - minor_gc.h gc_ctrl.h weak.h + finalise.h roots.h misc.h memory.h gc.h mlvalues.h major_gc.h \ + freelist.h minor_gc.h gc_ctrl.h weak.h compare.pic.o: compare.c custom.h compatibility.h mlvalues.h config.h \ - ../config/m.h ../config/s.h misc.h fail.h memory.h gc.h major_gc.h \ - freelist.h minor_gc.h + ../config/m.h ../config/s.h misc.h fail.h memory.h gc.h major_gc.h \ + freelist.h minor_gc.h custom.pic.o: custom.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h custom.h fail.h memory.h gc.h major_gc.h \ - freelist.h minor_gc.h + ../config/s.h mlvalues.h custom.h fail.h memory.h gc.h major_gc.h \ + freelist.h minor_gc.h debugger.pic.o: debugger.c alloc.h compatibility.h misc.h config.h \ - ../config/m.h ../config/s.h mlvalues.h debugger.h fail.h fix_code.h \ - instruct.h intext.h io.h stacks.h memory.h gc.h major_gc.h freelist.h \ - minor_gc.h sys.h + ../config/m.h ../config/s.h mlvalues.h debugger.h fail.h fix_code.h \ + instruct.h intext.h io.h stacks.h memory.h gc.h major_gc.h freelist.h \ + minor_gc.h sys.h dynlink.pic.o: dynlink.c config.h ../config/m.h ../config/s.h compatibility.h \ - alloc.h misc.h mlvalues.h dynlink.h fail.h memory.h gc.h major_gc.h \ - freelist.h minor_gc.h osdeps.h prims.h + alloc.h misc.h mlvalues.h dynlink.h fail.h memory.h gc.h major_gc.h \ + freelist.h minor_gc.h osdeps.h prims.h extern.pic.o: extern.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h custom.h fail.h gc.h intext.h io.h md5.h \ - memory.h major_gc.h freelist.h minor_gc.h reverse.h + ../config/s.h mlvalues.h custom.h fail.h gc.h intext.h io.h md5.h \ + memory.h major_gc.h freelist.h minor_gc.h reverse.h fail.pic.o: fail.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h io.h gc.h memory.h major_gc.h freelist.h \ - minor_gc.h printexc.h signals.h stacks.h + ../config/s.h mlvalues.h fail.h io.h gc.h memory.h major_gc.h \ + freelist.h minor_gc.h printexc.h signals.h stacks.h finalise.pic.o: finalise.c callback.h compatibility.h mlvalues.h config.h \ - ../config/m.h ../config/s.h misc.h fail.h roots.h memory.h gc.h \ - major_gc.h freelist.h minor_gc.h signals.h + ../config/m.h ../config/s.h misc.h fail.h roots.h memory.h gc.h \ + major_gc.h freelist.h minor_gc.h signals.h fix_code.pic.o: fix_code.c config.h ../config/m.h ../config/s.h \ - compatibility.h debugger.h misc.h mlvalues.h fix_code.h instruct.h \ - intext.h io.h md5.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ - reverse.h + compatibility.h debugger.h misc.h mlvalues.h fix_code.h instruct.h \ + intext.h io.h md5.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ + reverse.h floats.pic.o: floats.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h memory.h gc.h major_gc.h freelist.h \ - minor_gc.h reverse.h stacks.h + ../config/s.h mlvalues.h fail.h memory.h gc.h major_gc.h freelist.h \ + minor_gc.h reverse.h stacks.h freelist.pic.o: freelist.c config.h ../config/m.h ../config/s.h \ - compatibility.h freelist.h misc.h mlvalues.h gc.h gc_ctrl.h memory.h \ - major_gc.h minor_gc.h + compatibility.h freelist.h misc.h mlvalues.h gc.h gc_ctrl.h memory.h \ + major_gc.h minor_gc.h gc_ctrl.pic.o: gc_ctrl.c alloc.h compatibility.h misc.h config.h \ - ../config/m.h ../config/s.h mlvalues.h compact.h custom.h finalise.h \ - roots.h memory.h gc.h major_gc.h freelist.h minor_gc.h gc_ctrl.h \ - stacks.h + ../config/m.h ../config/s.h mlvalues.h compact.h custom.h finalise.h \ + roots.h memory.h gc.h major_gc.h freelist.h minor_gc.h gc_ctrl.h \ + stacks.h globroots.pic.o: globroots.c memory.h compatibility.h config.h ../config/m.h \ - ../config/s.h gc.h mlvalues.h misc.h major_gc.h freelist.h minor_gc.h \ - roots.h globroots.h + ../config/s.h gc.h mlvalues.h misc.h major_gc.h freelist.h minor_gc.h \ + roots.h globroots.h hash.pic.o: hash.c mlvalues.h compatibility.h config.h ../config/m.h \ - ../config/s.h misc.h custom.h memory.h gc.h major_gc.h freelist.h \ - minor_gc.h hash.h int64_native.h + ../config/s.h misc.h custom.h memory.h gc.h major_gc.h freelist.h \ + minor_gc.h hash.h instrtrace.pic.o: instrtrace.c intern.pic.o: intern.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h callback.h custom.h fail.h gc.h intext.h io.h \ - md5.h memory.h major_gc.h freelist.h minor_gc.h reverse.h + ../config/s.h mlvalues.h callback.h custom.h fail.h gc.h intext.h io.h \ + md5.h memory.h major_gc.h freelist.h minor_gc.h reverse.h interp.pic.o: interp.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h backtrace.h callback.h debugger.h fail.h \ - fix_code.h instrtrace.h instruct.h interp.h major_gc.h freelist.h \ - memory.h gc.h minor_gc.h prims.h signals.h stacks.h jumptbl.h + ../config/s.h mlvalues.h backtrace.h callback.h debugger.h fail.h \ + fix_code.h instrtrace.h instruct.h interp.h major_gc.h freelist.h \ + memory.h gc.h minor_gc.h prims.h signals.h stacks.h jumptbl.h ints.pic.o: ints.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h custom.h fail.h intext.h io.h memory.h gc.h \ - major_gc.h freelist.h minor_gc.h int64_native.h + ../config/s.h mlvalues.h custom.h fail.h intext.h io.h memory.h gc.h \ + major_gc.h freelist.h minor_gc.h io.pic.o: io.c config.h ../config/m.h ../config/s.h compatibility.h alloc.h \ - misc.h mlvalues.h custom.h fail.h io.h memory.h gc.h major_gc.h \ - freelist.h minor_gc.h signals.h sys.h + misc.h mlvalues.h custom.h fail.h io.h memory.h gc.h major_gc.h \ + freelist.h minor_gc.h signals.h sys.h lexing.pic.o: lexing.c fail.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h stacks.h memory.h gc.h major_gc.h freelist.h \ - minor_gc.h + ../config/s.h mlvalues.h stacks.h memory.h gc.h major_gc.h freelist.h \ + minor_gc.h main.pic.o: main.c misc.h compatibility.h config.h ../config/m.h \ - ../config/s.h mlvalues.h sys.h + ../config/s.h mlvalues.h sys.h major_gc.pic.o: major_gc.c compact.h config.h ../config/m.h ../config/s.h \ - compatibility.h misc.h custom.h mlvalues.h fail.h finalise.h roots.h \ - memory.h gc.h major_gc.h freelist.h minor_gc.h gc_ctrl.h weak.h + compatibility.h misc.h custom.h mlvalues.h fail.h finalise.h roots.h \ + memory.h gc.h major_gc.h freelist.h minor_gc.h gc_ctrl.h weak.h md5.pic.o: md5.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h md5.h io.h memory.h gc.h major_gc.h \ - freelist.h minor_gc.h reverse.h + ../config/s.h mlvalues.h fail.h md5.h io.h memory.h gc.h major_gc.h \ + freelist.h minor_gc.h reverse.h memory.pic.o: memory.c fail.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h freelist.h gc.h gc_ctrl.h major_gc.h memory.h \ - minor_gc.h signals.h + ../config/s.h mlvalues.h freelist.h gc.h gc_ctrl.h major_gc.h memory.h \ + minor_gc.h signals.h meta.pic.o: meta.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h fix_code.h interp.h intext.h io.h \ - major_gc.h freelist.h memory.h gc.h minor_gc.h prims.h stacks.h + ../config/s.h mlvalues.h fail.h fix_code.h interp.h intext.h io.h \ + major_gc.h freelist.h memory.h gc.h minor_gc.h prims.h stacks.h minor_gc.pic.o: minor_gc.c config.h ../config/m.h ../config/s.h \ - compatibility.h fail.h misc.h mlvalues.h finalise.h roots.h memory.h \ - gc.h major_gc.h freelist.h minor_gc.h gc_ctrl.h signals.h weak.h + compatibility.h fail.h misc.h mlvalues.h finalise.h roots.h memory.h \ + gc.h major_gc.h freelist.h minor_gc.h gc_ctrl.h signals.h weak.h misc.pic.o: misc.c config.h ../config/m.h ../config/s.h compatibility.h \ - misc.h memory.h gc.h mlvalues.h major_gc.h freelist.h minor_gc.h + misc.h memory.h gc.h mlvalues.h major_gc.h freelist.h minor_gc.h obj.pic.o: obj.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h gc.h interp.h major_gc.h freelist.h \ - memory.h minor_gc.h prims.h + ../config/s.h mlvalues.h fail.h gc.h interp.h major_gc.h freelist.h \ + memory.h minor_gc.h prims.h parsing.pic.o: parsing.c config.h ../config/m.h ../config/s.h compatibility.h \ - mlvalues.h misc.h memory.h gc.h major_gc.h freelist.h minor_gc.h alloc.h + mlvalues.h misc.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ + alloc.h prims.pic.o: prims.c mlvalues.h compatibility.h config.h ../config/m.h \ - ../config/s.h misc.h prims.h + ../config/s.h misc.h prims.h printexc.pic.o: printexc.c backtrace.h mlvalues.h compatibility.h config.h \ - ../config/m.h ../config/s.h misc.h callback.h debugger.h fail.h \ - printexc.h + ../config/m.h ../config/s.h misc.h callback.h debugger.h fail.h \ + printexc.h roots.pic.o: roots.c finalise.h roots.h misc.h compatibility.h config.h \ - ../config/m.h ../config/s.h memory.h gc.h mlvalues.h major_gc.h \ - freelist.h minor_gc.h globroots.h stacks.h + ../config/m.h ../config/s.h memory.h gc.h mlvalues.h major_gc.h \ + freelist.h minor_gc.h globroots.h stacks.h signals.pic.o: signals.c alloc.h compatibility.h misc.h config.h \ - ../config/m.h ../config/s.h mlvalues.h callback.h fail.h memory.h gc.h \ - major_gc.h freelist.h minor_gc.h roots.h signals.h signals_machdep.h \ - sys.h + ../config/m.h ../config/s.h mlvalues.h callback.h fail.h memory.h gc.h \ + major_gc.h freelist.h minor_gc.h roots.h signals.h signals_machdep.h \ + sys.h signals_byt.pic.o: signals_byt.c config.h ../config/m.h ../config/s.h \ - compatibility.h memory.h gc.h mlvalues.h misc.h major_gc.h freelist.h \ - minor_gc.h osdeps.h signals.h signals_machdep.h + compatibility.h memory.h gc.h mlvalues.h misc.h major_gc.h freelist.h \ + minor_gc.h osdeps.h signals.h signals_machdep.h stacks.pic.o: stacks.c config.h ../config/m.h ../config/s.h compatibility.h \ - fail.h misc.h mlvalues.h stacks.h memory.h gc.h major_gc.h freelist.h \ - minor_gc.h + fail.h misc.h mlvalues.h stacks.h memory.h gc.h major_gc.h freelist.h \ + minor_gc.h startup.pic.o: startup.c config.h ../config/m.h ../config/s.h compatibility.h \ - alloc.h misc.h mlvalues.h backtrace.h callback.h custom.h debugger.h \ - dynlink.h exec.h fail.h fix_code.h freelist.h gc_ctrl.h instrtrace.h \ - interp.h intext.h io.h memory.h gc.h major_gc.h minor_gc.h osdeps.h \ - prims.h printexc.h reverse.h signals.h stacks.h sys.h startup.h \ - version.h + alloc.h misc.h mlvalues.h backtrace.h callback.h custom.h debugger.h \ + dynlink.h exec.h fail.h fix_code.h freelist.h gc_ctrl.h instrtrace.h \ + interp.h intext.h io.h memory.h gc.h major_gc.h minor_gc.h osdeps.h \ + prims.h printexc.h reverse.h signals.h stacks.h sys.h startup.h \ + version.h str.pic.o: str.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h int64_native.h + ../config/s.h mlvalues.h fail.h sys.pic.o: sys.c config.h ../config/m.h ../config/s.h compatibility.h alloc.h \ - misc.h mlvalues.h debugger.h fail.h instruct.h osdeps.h signals.h \ - stacks.h memory.h gc.h major_gc.h freelist.h minor_gc.h sys.h + misc.h mlvalues.h debugger.h fail.h instruct.h osdeps.h signals.h \ + stacks.h memory.h gc.h major_gc.h freelist.h minor_gc.h sys.h terminfo.pic.o: terminfo.c config.h ../config/m.h ../config/s.h \ - compatibility.h alloc.h misc.h mlvalues.h fail.h io.h + compatibility.h alloc.h misc.h mlvalues.h fail.h io.h unix.pic.o: unix.c config.h ../config/m.h ../config/s.h compatibility.h \ - memory.h gc.h mlvalues.h misc.h major_gc.h freelist.h minor_gc.h \ - osdeps.h + memory.h gc.h mlvalues.h misc.h major_gc.h freelist.h minor_gc.h \ + osdeps.h weak.pic.o: weak.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h major_gc.h freelist.h memory.h gc.h \ - minor_gc.h + ../config/s.h mlvalues.h fail.h major_gc.h freelist.h memory.h gc.h \ + minor_gc.h win32.pic.o: win32.c fail.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ - osdeps.h signals.h sys.h + ../config/s.h mlvalues.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ + osdeps.h signals.h sys.h diff --git a/byterun/Makefile b/byterun/Makefile index 3ff165458..816dd75e5 100644 --- a/byterun/Makefile +++ b/byterun/Makefile @@ -46,7 +46,7 @@ libcamlrun_shared.so: $(PICOBJS) install:: if test -f libcamlrun_shared.so; then \ - cp libcamlrun_shared.so $(LIBDIR)/libcamlrun_shared.so; fi + cp libcamlrun_shared.so $(INSTALL_LIBDIR)/libcamlrun_shared.so; fi clean:: rm -f libcamlrun_shared.so diff --git a/byterun/Makefile.common b/byterun/Makefile.common index 35e665066..b6bff2194 100755 --- a/byterun/Makefile.common +++ b/byterun/Makefile.common @@ -32,7 +32,8 @@ PRIMS=\ PUBLIC_INCLUDES=\ alloc.h callback.h config.h custom.h fail.h hash.h intext.h \ - memory.h misc.h mlvalues.h printexc.h signals.h compatibility.h + memory.h misc.h mlvalues.h printexc.h signals.h compatibility.h \ + version.h all:: ocamlrun$(EXE) ld.conf libcamlrun.$(A) all-$(RUNTIMED) @@ -48,15 +49,22 @@ ld.conf: ../config/Makefile echo "$(STUBLIBDIR)" > ld.conf echo "$(LIBDIR)" >> ld.conf +# Installation + +INSTALL_BINDIR=$(DESTDIR)$(BINDIR) +INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR) + + install:: - cp ocamlrun$(EXE) $(BINDIR)/ocamlrun$(EXE) - cp libcamlrun.$(A) $(LIBDIR)/libcamlrun.$(A) - cd $(LIBDIR); $(RANLIB) libcamlrun.$(A) - if test -d $(LIBDIR)/caml; then : ; else mkdir $(LIBDIR)/caml; fi + cp ocamlrun$(EXE) $(INSTALL_BINDIR)/ocamlrun$(EXE) + cp libcamlrun.$(A) $(INSTALL_LIBDIR)/libcamlrun.$(A) + cd $(INSTALL_LIBDIR); $(RANLIB) libcamlrun.$(A) + if test -d $(INSTALL_LIBDIR)/caml; then : ; \ + else mkdir $(INSTALL_LIBDIR)/caml; fi for i in $(PUBLIC_INCLUDES); do \ - sed -f ../tools/cleanup-header $$i > $(LIBDIR)/caml/$$i; \ + sed -f ../tools/cleanup-header $$i > $(INSTALL_LIBDIR)/caml/$$i; \ done - cp ld.conf $(LIBDIR)/ld.conf + cp ld.conf $(INSTALL_LIBDIR)/ld.conf .PHONY: install install:: install-$(RUNTIMED) @@ -65,8 +73,8 @@ install-noruntimed: .PHONY: install-noruntimed install-runtimed: - cp ocamlrund$(EXE) $(BINDIR)/ocamlrund$(EXE) - cp libcamlrund.$(A) $(LIBDIR)/libcamlrund.$(A) + cp ocamlrund$(EXE) $(INSTALL_BINDIR)/ocamlrund$(EXE) + cp libcamlrund.$(A) $(INSTALL_LIBDIR)/libcamlrund.$(A) .PHONY: install-runtimed # If primitives contain duplicated lines (e.g. because the code is defined @@ -110,8 +118,8 @@ jumptbl.h : instruct.h sed -n -e '/^ /s/ \([A-Z]\)/ \&\&lbl_\1/gp' \ -e '/^}/q' instruct.h > jumptbl.h -version.h : ../VERSION - echo "#define OCAML_VERSION \"`sed -e 1q ../VERSION`\"" > version.h +version.h : ../VERSION ../tools/make-version-header.sh + ../tools/make-version-header.sh ../VERSION > version.h clean :: rm -f ocamlrun$(EXE) ocamlrund$(EXE) *.$(O) *.$(A) *.$(SO) diff --git a/byterun/alloc.c b/byterun/alloc.c index a1fd2f03e..1fc33b55a 100644 --- a/byterun/alloc.c +++ b/byterun/alloc.c @@ -39,11 +39,13 @@ CAMLexport value caml_alloc (mlsize_t wosize, tag_t tag) }else if (wosize <= Max_young_wosize){ Alloc_small (result, wosize, tag); if (tag < No_scan_tag){ - for (i = 0; i < wosize; i++) Field (result, i) = 0; + for (i = 0; i < wosize; i++) Field (result, i) = Val_unit; } }else{ result = caml_alloc_shr (wosize, tag); - if (tag < No_scan_tag) memset (Bp_val (result), 0, Bsize_wsize (wosize)); + if (tag < No_scan_tag){ + for (i = 0; i < wosize; i++) Field (result, i) = Val_unit; + } result = caml_check_urgent_gc (result); } return result; diff --git a/byterun/alloc.h b/byterun/alloc.h index a0cd41b65..2a640ebe6 100644 --- a/byterun/alloc.h +++ b/byterun/alloc.h @@ -32,11 +32,12 @@ CAMLextern value caml_alloc_string (mlsize_t); /* size in bytes */ CAMLextern value caml_copy_string (char const *); CAMLextern value caml_copy_string_array (char const **); CAMLextern value caml_copy_double (double); -CAMLextern value caml_copy_int32 (int32); /* defined in [ints.c] */ -CAMLextern value caml_copy_int64 (int64); /* defined in [ints.c] */ +CAMLextern value caml_copy_int32 (int32_t); /* defined in [ints.c] */ +CAMLextern value caml_copy_int64 (int64_t); /* defined in [ints.c] */ CAMLextern value caml_copy_nativeint (intnat); /* defined in [ints.c] */ CAMLextern value caml_alloc_array (value (*funct) (char const *), char const ** array); +CAMLextern value caml_alloc_sprintf(const char * format, ...); typedef void (*final_fun)(value); CAMLextern value caml_alloc_final (mlsize_t, /*size in words*/ diff --git a/byterun/array.c b/byterun/array.c index 327f2b564..ba6fd701b 100644 --- a/byterun/array.c +++ b/byterun/array.c @@ -214,9 +214,13 @@ CAMLprim value caml_make_array(value init) || Tag_val(v) != Double_tag) { CAMLreturn (init); } else { - Assert(size < Max_young_wosize); wsize = size * Double_wosize; - res = caml_alloc_small(wsize, Double_array_tag); + if (wsize <= Max_young_wosize) { + res = caml_alloc_small(wsize, Double_array_tag); + } else { + res = caml_alloc_shr(wsize, Double_array_tag); + res = caml_check_urgent_gc(res); + } for (i = 0; i < size; i++) { Store_double_field(res, i, Double_val(Field(init, i))); } diff --git a/byterun/backtrace.c b/byterun/backtrace.c index 1d4fb1e07..6ed56c840 100644 --- a/byterun/backtrace.c +++ b/byterun/backtrace.c @@ -35,6 +35,7 @@ #include "stacks.h" #include "sys.h" #include "backtrace.h" +#include "fail.h" CAMLexport int caml_backtrace_active = 0; CAMLexport int caml_backtrace_pos = 0; @@ -102,6 +103,7 @@ void caml_stash_backtrace(value exn, code_t pc, value * sp, int reraise) caml_backtrace_last_exn = exn; } if (caml_backtrace_buffer == NULL) { + Assert(caml_backtrace_pos == 0); caml_backtrace_buffer = malloc(BACKTRACE_BUFFER_SIZE * sizeof(code_t)); if (caml_backtrace_buffer == NULL) return; } @@ -119,6 +121,17 @@ void caml_stash_backtrace(value exn, code_t pc, value * sp, int reraise) } } +/* In order to prevent the GC from walking through the debug + information (which have no headers), we transform code pointers to + 31/63 bits ocaml integers by shifting them by 1 to the right. We do + not lose information as code pointers are aligned. + + In particular, we do not need to use [caml_initialize] when setting + an array element with such a value. +*/ +#define Val_Codet(p) Val_long((uintnat)p>>1) +#define Codet_Val(v) ((code_t)(Long_val(v)<<1)) + /* returns the next frame pointer (or NULL if none is available); updates *sp to point to the following one, and *trapsp to the next trap frame, which we will skip when we reach it */ @@ -165,7 +178,7 @@ CAMLprim value caml_get_current_callstack(value max_frames_value) { } } - trace = caml_alloc(trace_size, Abstract_tag); + trace = caml_alloc(trace_size, 0); /* then collect the trace */ { @@ -176,36 +189,52 @@ CAMLprim value caml_get_current_callstack(value max_frames_value) { for (trace_pos = 0; trace_pos < trace_size; trace_pos++) { code_t p = caml_next_frame_pointer(&sp, &trapsp); Assert(p != NULL); - /* The assignment below is safe without [caml_initialize], even - if the trace is large and allocated on the old heap, because - we assign values that are outside the OCaml heap. */ - Assert(!(Is_block((value) p) && Is_in_heap((value) p))); - Field(trace, trace_pos) = (value) p; + Field(trace, trace_pos) = Val_Codet(p); } } CAMLreturn(trace); } -/* Read the debugging info contained in the current bytecode executable. - Return an OCaml array of OCaml lists of debug_event records in "events", - or Val_false on failure. */ +/* Read the debugging info contained in the current bytecode executable. */ #ifndef O_BINARY #define O_BINARY 0 #endif +struct ev_info { + code_t ev_pc; + char * ev_filename; + int ev_lnum; + int ev_startchr; + int ev_endchr; +}; + +static int cmp_ev_info(const void *a, const void *b) { + code_t pc_a = ((const struct ev_info*)a)->ev_pc; + code_t pc_b = ((const struct ev_info*)b)->ev_pc; + if (pc_a > pc_b) return 1; + if (pc_a < pc_b) return -1; + return 0; +} + static char *read_debug_info_error = ""; -static value read_debug_info(void) +static uintnat n_events; +static struct ev_info *events = NULL; +static void read_debug_info(void) { CAMLparam0(); - CAMLlocal1(events); + CAMLlocal1(events_heap); char * exec_name; int fd; struct exec_trailer trail; struct channel * chan; - uint32 num_events, orig, i; - value evl, l; + uint32_t num_events, orig, i; + intnat j; + value evl, l, ev_start; + + if(events != NULL) + CAMLreturn0; if (caml_cds_file != NULL) { exec_name = caml_cds_file; @@ -215,54 +244,103 @@ static value read_debug_info(void) fd = caml_attempt_open(&exec_name, &trail, 1); if (fd < 0){ read_debug_info_error = "executable program file not found"; - CAMLreturn(Val_false); + CAMLreturn0; } caml_read_section_descriptors(fd, &trail); if (caml_seek_optional_section(fd, &trail, "DBUG") == -1) { close(fd); read_debug_info_error = "program not linked with -g"; - CAMLreturn(Val_false); + CAMLreturn0; } chan = caml_open_descriptor_in(fd); num_events = caml_getword(chan); - events = caml_alloc(num_events, 0); + n_events = 0; + events_heap = caml_alloc(num_events, 0); for (i = 0; i < num_events; i++) { orig = caml_getword(chan); evl = caml_input_val(chan); + caml_input_val(chan); // Skip the list of absolute directory names /* Relocate events in event list */ for (l = evl; l != Val_int(0); l = Field(l, 1)) { value ev = Field(l, 0); Field(ev, EV_POS) = Val_long(Long_val(Field(ev, EV_POS)) + orig); + n_events++; } /* Record event list */ - Store_field(events, i, evl); + Store_field(events_heap, i, evl); } caml_close_channel(chan); - CAMLreturn(events); + + events = (struct ev_info*)malloc(n_events * sizeof(struct ev_info)); + if(events == NULL) { + read_debug_info_error = "out of memory"; + CAMLreturn0; + } + + j = 0; + for (i = 0; i < num_events; i++) { + for (l = Field(events_heap, i); l != Val_int(0); l = Field(l, 1)) { + uintnat fnsz; + value ev = Field(l, 0); + + events[j].ev_pc = + (code_t)((char*)caml_start_code + Long_val(Field(ev, EV_POS))); + + ev_start = Field (Field (ev, EV_LOC), LOC_START); + + fnsz = caml_string_length(Field (ev_start, POS_FNAME))+1; + events[j].ev_filename = (char*)malloc(fnsz); + if(events[j].ev_filename == NULL) { + for(j--; j >= 0; j--) + free(events[j].ev_filename); + free(events); + events = NULL; + read_debug_info_error = "out of memory"; + CAMLreturn0; + } + memcpy(events[j].ev_filename, String_val (Field (ev_start, POS_FNAME)), + fnsz); + + events[j].ev_lnum = Int_val (Field (ev_start, POS_LNUM)); + events[j].ev_startchr = + Int_val (Field (ev_start, POS_CNUM)) + - Int_val (Field (ev_start, POS_BOL)); + events[j].ev_endchr = + Int_val (Field (Field (Field (ev, EV_LOC), LOC_END), POS_CNUM)) + - Int_val (Field (ev_start, POS_BOL)); + + j++; + } + } + + Assert(j == n_events); + + qsort(events, n_events, sizeof(struct ev_info), cmp_ev_info); + + CAMLreturn0; } -/* Search the event for the given PC. Return Val_false if not found. */ +/* Search the event index for the given PC. Return -1 if not found. */ -static value event_for_location(value events, code_t pc) +static intnat event_for_location(code_t pc) { - mlsize_t i; - value pos, l, ev, ev_pos, best_ev; - - best_ev = 0; + uintnat low = 0, high = n_events; Assert(pc >= caml_start_code && pc < caml_start_code + caml_code_size); - pos = Val_long((char *) pc - (char *) caml_start_code); - for (i = 0; i < Wosize_val(events); i++) { - for (l = Field(events, i); l != Val_int(0); l = Field(l, 1)) { - ev = Field(l, 0); - ev_pos = Field(ev, EV_POS); - if (ev_pos == pos) return ev; - /* ocamlc sometimes moves an event past a following PUSH instruction; - allow mismatch by 1 instruction. */ - if (ev_pos == pos + 8) best_ev = ev; - } + Assert(events != NULL); + while(low+1 < high) { + uintnat m = (low+high)/2; + if(pc < events[m].ev_pc) high = m; + else low = m; } - if (best_ev != 0) return best_ev; - return Val_false; + if(events[low].ev_pc == pc) + return low; + /* ocamlc sometimes moves an event past a following PUSH instruction; + allow mismatch by 1 instruction. */ + if(events[low].ev_pc == pc + 1) + return low; + if(low+1 < n_events && events[low+1].ev_pc == pc + 1) + return low+1; + return -1; } /* Extract location information for the given PC */ @@ -276,28 +354,21 @@ struct loc_info { int loc_endchr; }; -static void extract_location_info(value events, code_t pc, +static void extract_location_info(code_t pc, /*out*/ struct loc_info * li) { - value ev, ev_start; - - ev = event_for_location(events, pc); + intnat ev = event_for_location(pc); li->loc_is_raise = caml_is_instruction(*pc, RAISE) || caml_is_instruction(*pc, RERAISE); - if (ev == Val_false) { + if (ev == -1) { li->loc_valid = 0; return; } li->loc_valid = 1; - ev_start = Field (Field (ev, EV_LOC), LOC_START); - li->loc_filename = String_val (Field (ev_start, POS_FNAME)); - li->loc_lnum = Int_val (Field (ev_start, POS_LNUM)); - li->loc_startchr = - Int_val (Field (ev_start, POS_CNUM)) - - Int_val (Field (ev_start, POS_BOL)); - li->loc_endchr = - Int_val (Field (Field (Field (ev, EV_LOC), LOC_END), POS_CNUM)) - - Int_val (Field (ev_start, POS_BOL)); + li->loc_filename = events[ev].ev_filename; + li->loc_lnum = events[ev].ev_lnum; + li->loc_startchr = events[ev].ev_startchr; + li->loc_endchr = events[ev].ev_endchr; } /* Print location information -- same behavior as in Printexc */ @@ -334,55 +405,47 @@ static void print_location(struct loc_info * li, int index) CAMLexport void caml_print_exception_backtrace(void) { - value events; int i; struct loc_info li; - events = read_debug_info(); - if (events == Val_false) { + read_debug_info(); + if (events == NULL) { fprintf(stderr, "(Cannot print stack backtrace: %s)\n", read_debug_info_error); return; } for (i = 0; i < caml_backtrace_pos; i++) { - extract_location_info(events, caml_backtrace_buffer[i], &li); + extract_location_info(caml_backtrace_buffer[i], &li); print_location(&li, i); } } /* Convert the backtrace to a data structure usable from OCaml */ -CAMLprim value caml_convert_raw_backtrace(value backtrace) -{ - CAMLparam1(backtrace); - CAMLlocal5(events, res, arr, p, fname); - int i; +CAMLprim value caml_convert_raw_backtrace_slot(value backtrace_slot) { + CAMLparam1(backtrace_slot); + CAMLlocal2(p, fname); struct loc_info li; - events = read_debug_info(); - if (events == Val_false) { - res = Val_int(0); /* None */ + read_debug_info(); + if (events == NULL) + caml_failwith(read_debug_info_error); + + extract_location_info(Codet_Val(backtrace_slot), &li); + + if (li.loc_valid) { + fname = caml_copy_string(li.loc_filename); + p = caml_alloc_small(5, 0); + Field(p, 0) = Val_bool(li.loc_is_raise); + Field(p, 1) = fname; + Field(p, 2) = Val_int(li.loc_lnum); + Field(p, 3) = Val_int(li.loc_startchr); + Field(p, 4) = Val_int(li.loc_endchr); } else { - arr = caml_alloc(Wosize_val(backtrace), 0); - for (i = 0; i < Wosize_val(backtrace); i++) { - extract_location_info(events, (code_t)Field(backtrace, i), &li); - if (li.loc_valid) { - fname = caml_copy_string(li.loc_filename); - p = caml_alloc_small(5, 0); - Field(p, 0) = Val_bool(li.loc_is_raise); - Field(p, 1) = fname; - Field(p, 2) = Val_int(li.loc_lnum); - Field(p, 3) = Val_int(li.loc_startchr); - Field(p, 4) = Val_int(li.loc_endchr); - } else { - p = caml_alloc_small(1, 1); - Field(p, 0) = Val_bool(li.loc_is_raise); - } - caml_modify(&Field(arr, i), p); - } - res = caml_alloc_small(1, 0); Field(res, 0) = arr; /* Some */ + p = caml_alloc_small(1, 1); + Field(p, 0) = Val_bool(li.loc_is_raise); } - CAMLreturn(res); + CAMLreturn(p); } /* Get a copy of the latest backtrace */ @@ -391,20 +454,49 @@ CAMLprim value caml_get_exception_raw_backtrace(value unit) { CAMLparam0(); CAMLlocal1(res); - res = caml_alloc(caml_backtrace_pos, Abstract_tag); - if(caml_backtrace_buffer != NULL) - memcpy(&Field(res, 0), caml_backtrace_buffer, - caml_backtrace_pos * sizeof(code_t)); + + res = caml_alloc(caml_backtrace_pos, 0); + if(caml_backtrace_buffer != NULL) { + intnat i; + for(i = 0; i < caml_backtrace_pos; i++) + Field(res, i) = Val_Codet(caml_backtrace_buffer[i]); + } CAMLreturn(res); } -/* the function below is deprecated: see asmrun/backtrace.c */ +/* the function below is deprecated: we previously returned directly + the OCaml-usable representation, instead of the raw backtrace as an + abstract type, but this has a large performance overhead if you + store a lot of backtraces and print only some of them. + + It is not used by the Printexc library anymore, or anywhere else in + the compiler, but we have kept it in case some user still depends + on it as an external. +*/ CAMLprim value caml_get_exception_backtrace(value unit) { CAMLparam0(); - CAMLlocal2(raw, res); - raw = caml_get_exception_raw_backtrace(unit); - res = caml_convert_raw_backtrace(raw); + CAMLlocal4(arr, raw_slot, slot, res); + + read_debug_info(); + if (events == NULL) { + res = Val_int(0); /* None */ + } else { + arr = caml_alloc(caml_backtrace_pos, 0); + if(caml_backtrace_buffer == NULL) { + Assert(caml_backtrace_pos == 0); + } else { + intnat i; + for(i = 0; i < caml_backtrace_pos; i++) { + raw_slot = Val_Codet(caml_backtrace_buffer[i]); + /* caml_convert_raw_backtrace_slot will not fail with + caml_failwith as we checked (events != NULL) already */ + slot = caml_convert_raw_backtrace_slot(raw_slot); + caml_modify(&Field(arr, i), slot); + } + } + res = caml_alloc_small(1, 0); Field(res, 0) = arr; /* Some */ + } CAMLreturn(res); } diff --git a/byterun/callback.c b/byterun/callback.c index 3bd7ea45c..5da37ec9a 100644 --- a/byterun/callback.c +++ b/byterun/callback.c @@ -216,6 +216,7 @@ CAMLprim value caml_register_named_value(value vname, value val) { struct named_value * nv; char * name = String_val(vname); + size_t namelen = strlen(name); unsigned int h = hash_value_name(name); for (nv = named_value_table[h]; nv != NULL; nv = nv->next) { @@ -225,8 +226,8 @@ CAMLprim value caml_register_named_value(value vname, value val) } } nv = (struct named_value *) - caml_stat_alloc(sizeof(struct named_value) + strlen(name)); - strcpy(nv->name, name); + caml_stat_alloc(sizeof(struct named_value) + namelen); + memcpy(nv->name, name, namelen + 1); nv->val = val; nv->next = named_value_table[h]; named_value_table[h] = nv; diff --git a/byterun/config.h b/byterun/config.h index 8cf851613..6c86d1672 100644 --- a/byterun/config.h +++ b/byterun/config.h @@ -25,10 +25,52 @@ #include "compatibility.h" #endif -/* Types for signed chars, 32-bit integers, 64-bit integers, +#ifdef HAS_STDINT_H +#include <stdint.h> +#endif + +/* Types for 32-bit integers, 64-bit integers, and native integers (as wide as a pointer type) */ -typedef signed char schar; +#ifndef ARCH_INT32_TYPE +#if SIZEOF_INT == 4 +#define ARCH_INT32_TYPE int +#define ARCH_UINT32_TYPE unsigned int +#define ARCH_INT32_PRINTF_FORMAT "" +#elif SIZEOF_LONG == 4 +#define ARCH_INT32_TYPE long +#define ARCH_UINT32_TYPE unsigned long +#define ARCH_INT32_PRINTF_FORMAT "l" +#elif SIZEOF_SHORT == 4 +#define ARCH_INT32_TYPE short +#define ARCH_UINT32_TYPE unsigned short +#define ARCH_INT32_PRINTF_FORMAT "" +#else +#error "No 32-bit integer type available" +#endif +#endif + +#ifndef ARCH_INT64_TYPE +#if SIZEOF_LONGLONG == 8 +#define ARCH_INT64_TYPE long long +#define ARCH_UINT64_TYPE unsigned long long +#define ARCH_INT64_PRINTF_FORMAT "ll" +#elif SIZEOF_LONG == 8 +#define ARCH_INT64_TYPE long +#define ARCH_UINT64_TYPE unsigned long +#define ARCH_INT64_PRINTF_FORMAT "l" +#else +#error "No 64-bit integer type available" +#endif +#endif + +#ifndef HAS_STDINT_H +/* Not a C99 compiler, typically MSVC. Define the C99 types we use. */ +typedef ARCH_INT32_TYPE int32_t; +typedef ARCH_UINT32_TYPE uint32_t; +typedef ARCH_INT64_TYPE int64_t; +typedef ARCH_UINT64_TYPE uint64_t; +#endif #if SIZEOF_PTR == SIZEOF_LONG /* Standard models: ILP32 or I32LP64 */ @@ -40,42 +82,15 @@ typedef unsigned long uintnat; typedef int intnat; typedef unsigned int uintnat; #define ARCH_INTNAT_PRINTF_FORMAT "" -#elif SIZEOF_PTR == 8 && defined(ARCH_INT64_TYPE) -/* Win64 model: IL32LLP64 */ -typedef ARCH_INT64_TYPE intnat; -typedef ARCH_UINT64_TYPE uintnat; +#elif SIZEOF_PTR == 8 +/* Win64 model: IL32P64 */ +typedef int64_t intnat; +typedef uint64_t uintnat; #define ARCH_INTNAT_PRINTF_FORMAT ARCH_INT64_PRINTF_FORMAT #else #error "No integer type available to represent pointers" #endif -#if SIZEOF_INT == 4 -typedef int int32; -typedef unsigned int uint32; -#define ARCH_INT32_PRINTF_FORMAT "" -#elif SIZEOF_LONG == 4 -typedef long int32; -typedef unsigned long uint32; -#define ARCH_INT32_PRINTF_FORMAT "l" -#elif SIZEOF_SHORT == 4 -typedef short int32; -typedef unsigned short uint32; -#define ARCH_INT32_PRINTF_FORMAT "" -#else -#error "No 32-bit integer type available" -#endif - -#if defined(ARCH_INT64_TYPE) -typedef ARCH_INT64_TYPE int64; -typedef ARCH_UINT64_TYPE uint64; -#else -# ifdef ARCH_BIG_ENDIAN -typedef struct { uint32 h, l; } uint64, int64; -# else -typedef struct { uint32 l, h; } uint64, int64; -# endif -#endif - /* Endianness of floats */ /* ARCH_FLOAT_ENDIANNESS encodes the byte order of doubles as follows: diff --git a/byterun/debugger.c b/byterun/debugger.c index d64583f2d..6024ed92f 100644 --- a/byterun/debugger.c +++ b/byterun/debugger.c @@ -250,7 +250,6 @@ static void safe_output_value(struct channel *chan, value val) void caml_debugger(enum event_kind event) { - int frame_number; value * frame; intnat i, pos; value val; @@ -258,7 +257,6 @@ void caml_debugger(enum event_kind event) if (dbg_socket == -1) return; /* Not connected to a debugger. */ /* Reset current frame */ - frame_number = 0; frame = caml_extern_sp + 1; /* Report the event to the debugger */ diff --git a/byterun/debugger.h b/byterun/debugger.h index b5079eb3b..e68ef756c 100644 --- a/byterun/debugger.h +++ b/byterun/debugger.h @@ -37,17 +37,17 @@ void caml_debugger_cleanup_fork (void); /* Requests from the debugger to the runtime system */ enum debugger_request { - REQ_SET_EVENT = 'e', /* uint32 pos */ + REQ_SET_EVENT = 'e', /* uint32_t pos */ /* Set an event on the instruction at position pos */ - REQ_SET_BREAKPOINT = 'B', /* uint32 pos, (char k) */ + REQ_SET_BREAKPOINT = 'B', /* uint32_t pos, (char k) */ /* Set a breakpoint at position pos */ /* In profiling mode, the breakpoint kind is set to k */ - REQ_RESET_INSTR = 'i', /* uint32 pos */ + REQ_RESET_INSTR = 'i', /* uint32_t pos */ /* Clear an event or breapoint at position pos, restores initial instr. */ REQ_CHECKPOINT = 'c', /* no args */ /* Checkpoint the runtime system by forking a child process. Reply is pid of child process or -1 if checkpoint failed. */ - REQ_GO = 'g', /* uint32 n */ + REQ_GO = 'g', /* uint32_t n */ /* Run the program for n events. Reply is one of debugger_reply described below. */ REQ_STOP = 's', /* no args */ @@ -59,38 +59,38 @@ enum debugger_request { Reply is stack offset and current pc. */ REQ_GET_FRAME = 'f', /* no args */ /* Return current frame location (stack offset + current pc). */ - REQ_SET_FRAME = 'S', /* uint32 stack_offset */ + REQ_SET_FRAME = 'S', /* uint32_t stack_offset */ /* Set current frame to given stack offset. No reply. */ - REQ_UP_FRAME = 'U', /* uint32 n */ + REQ_UP_FRAME = 'U', /* uint32_t n */ /* Move one frame up. Argument n is size of current frame (in words). Reply is stack offset and current pc, or -1 if top of stack reached. */ - REQ_SET_TRAP_BARRIER = 'b', /* uint32 offset */ + REQ_SET_TRAP_BARRIER = 'b', /* uint32_t offset */ /* Set the trap barrier at the given offset. */ - REQ_GET_LOCAL = 'L', /* uint32 slot_number */ + REQ_GET_LOCAL = 'L', /* uint32_t slot_number */ /* Return the local variable at the given slot in the current frame. Reply is one value. */ - REQ_GET_ENVIRONMENT = 'E', /* uint32 slot_number */ + REQ_GET_ENVIRONMENT = 'E', /* uint32_t slot_number */ /* Return the local variable at the given slot in the heap environment of the current frame. Reply is one value. */ - REQ_GET_GLOBAL = 'G', /* uint32 global_number */ + REQ_GET_GLOBAL = 'G', /* uint32_t global_number */ /* Return the specified global variable. Reply is one value. */ REQ_GET_ACCU = 'A', /* no args */ /* Return the current contents of the accumulator. Reply is one value. */ REQ_GET_HEADER = 'H', /* mlvalue v */ /* As REQ_GET_OBJ, but sends only the header. */ - REQ_GET_FIELD = 'F', /* mlvalue v, uint32 fieldnum */ + REQ_GET_FIELD = 'F', /* mlvalue v, uint32_t fieldnum */ /* As REQ_GET_OBJ, but sends only one field. */ REQ_MARSHAL_OBJ = 'M', /* mlvalue v */ /* Send a copy of the data structure rooted at v, using the same format as [caml_output_value]. */ REQ_GET_CLOSURE_CODE = 'C', /* mlvalue v */ /* Send the code address of the given closure. - Reply is one uint32. */ - REQ_SET_FORK_MODE = 'K' /* uint32 m */ + Reply is one uint32_t. */ + REQ_SET_FORK_MODE = 'K' /* uint32_t m */ /* Set whether to follow the child (m=0) or the parent on fork. */ }; -/* Replies to a REQ_GO request. All replies are followed by three uint32: +/* Replies to a REQ_GO request. All replies are followed by three uint32_t: - the value of the event counter - the position of the stack - the current pc. */ diff --git a/byterun/dynlink.c b/byterun/dynlink.c index f07cf91e3..8b4498b9d 100644 --- a/byterun/dynlink.c +++ b/byterun/dynlink.c @@ -79,9 +79,7 @@ static char * parse_ld_conf(void) stdlib = getenv("OCAMLLIB"); if (stdlib == NULL) stdlib = getenv("CAMLLIB"); if (stdlib == NULL) stdlib = OCAML_STDLIB_DIR; - ldconfname = caml_stat_alloc(strlen(stdlib) + 2 + sizeof(LD_CONF_NAME)); - strcpy(ldconfname, stdlib); - strcat(ldconfname, "/" LD_CONF_NAME); + ldconfname = caml_strconcat(3, stdlib, "/", LD_CONF_NAME); if (stat(ldconfname, &st) == -1) { caml_stat_free(ldconfname); return NULL; diff --git a/byterun/exec.h b/byterun/exec.h index 27f291ec5..7e084acd4 100644 --- a/byterun/exec.h +++ b/byterun/exec.h @@ -39,13 +39,13 @@ struct section_descriptor { char name[4]; /* Section name */ - uint32 len; /* Length of data in bytes */ + uint32_t len; /* Length of data in bytes */ }; /* Structure of the trailer. */ struct exec_trailer { - uint32 num_sections; /* Number of sections */ + uint32_t num_sections; /* Number of sections */ char magic[12]; /* The magic number */ struct section_descriptor * section; /* Not part of file */ }; @@ -54,7 +54,7 @@ struct exec_trailer { /* Magic number for this release */ -#define EXEC_MAGIC "Caml1999X010" +#define EXEC_MAGIC "Caml1999X011" #endif /* CAML_EXEC_H */ diff --git a/byterun/extern.c b/byterun/extern.c index 33fa89a91..f1ebddef3 100644 --- a/byterun/extern.c +++ b/byterun/extern.c @@ -75,10 +75,10 @@ static struct extern_item * extern_stack_limit = extern_stack_init /* Forward declarations */ -static void extern_out_of_memory(void); -static void extern_invalid_argument(char *msg); -static void extern_failwith(char *msg); -static void extern_stack_overflow(void); +static void extern_out_of_memory(void) Noreturn; +static void extern_invalid_argument(char *msg) Noreturn; +static void extern_failwith(char *msg) Noreturn; +static void extern_stack_overflow(void) Noreturn; static struct code_fragment * extern_find_code(char *addr); static void extern_replay_trail(void); static void free_extern_output(void); @@ -720,7 +720,7 @@ CAMLexport void caml_serialize_int_2(int i) extern_ptr += 2; } -CAMLexport void caml_serialize_int_4(int32 i) +CAMLexport void caml_serialize_int_4(int32_t i) { if (extern_ptr + 4 > extern_limit) grow_extern_output(4); extern_ptr[0] = i >> 24; @@ -730,7 +730,7 @@ CAMLexport void caml_serialize_int_4(int32 i) extern_ptr += 4; } -CAMLexport void caml_serialize_int_8(int64 i) +CAMLexport void caml_serialize_int_8(int64_t i) { caml_serialize_block_8(&i, 1); } diff --git a/byterun/fail.c b/byterun/fail.c index 530ca5d13..148e47a99 100644 --- a/byterun/fail.c +++ b/byterun/fail.c @@ -71,11 +71,9 @@ CAMLexport void caml_raise_with_args(value tag, int nargs, value args[]) CAMLexport void caml_raise_with_string(value tag, char const *msg) { - CAMLparam1 (tag); - CAMLlocal1 (vmsg); - - vmsg = caml_copy_string(msg); - caml_raise_with_arg(tag, vmsg); + CAMLparam1(tag); + value v_msg = caml_copy_string(msg); + caml_raise_with_arg(tag, v_msg); CAMLnoreturn; } diff --git a/byterun/fix_code.c b/byterun/fix_code.c index 746f8b750..4fa027502 100644 --- a/byterun/fix_code.c +++ b/byterun/fix_code.c @@ -98,10 +98,10 @@ char * caml_instr_base; void caml_thread_code (code_t code, asize_t len) { code_t p; - int l [STOP + 1]; + int l [FIRST_UNIMPLEMENTED_OP]; int i; - for (i = 0; i <= STOP; i++) { + for (i = 0; i < FIRST_UNIMPLEMENTED_OP; i++) { l [i] = 0; } /* Instructions with one operand */ @@ -125,7 +125,7 @@ void caml_thread_code (code_t code, asize_t len) len /= sizeof(opcode_t); for (p = code; p < code + len; /*nothing*/) { opcode_t instr = *p; - if (instr < 0 || instr > STOP){ + if (instr < 0 || instr >= FIRST_UNIMPLEMENTED_OP){ /* FIXME -- should Assert(false) ? caml_fatal_error_arg ("Fatal error in fix_code: bad opcode (%lx)\n", (char *)(long)instr); @@ -134,12 +134,12 @@ void caml_thread_code (code_t code, asize_t len) } *p++ = (opcode_t)(caml_instr_table[instr] - caml_instr_base); if (instr == SWITCH) { - uint32 sizes = *p++; - uint32 const_size = sizes & 0xFFFF; - uint32 block_size = sizes >> 16; + uint32_t sizes = *p++; + uint32_t const_size = sizes & 0xFFFF; + uint32_t block_size = sizes >> 16; p += const_size + block_size; } else if (instr == CLOSUREREC) { - uint32 nfuncs = *p++; + uint32_t nfuncs = *p++; p++; /* skip nvars */ p += nfuncs; } else { diff --git a/byterun/floats.c b/byterun/floats.c index 9071106f2..d8fdd054b 100644 --- a/byterun/floats.c +++ b/byterun/floats.c @@ -71,68 +71,29 @@ CAMLexport value caml_copy_double(double d) CAMLprim value caml_format_float(value fmt, value arg) { -#define MAX_DIGITS 350 -/* Max number of decimal digits in a "natural" (not artificially padded) - representation of a float. Can be quite big for %f format. - Max exponent for IEEE format is 308 decimal digits. - Rounded up for good measure. */ - char format_buffer[MAX_DIGITS + 20]; - int prec, i; - char * p; - char * dest; value res; double d = Double_val(arg); #ifdef HAS_BROKEN_PRINTF if (isfinite(d)) { #endif - prec = MAX_DIGITS; - for (p = String_val(fmt); *p != 0; p++) { - if (*p >= '0' && *p <= '9') { - i = atoi(p) + MAX_DIGITS; - if (i > prec) prec = i; - break; - } - } - for( ; *p != 0; p++) { - if (*p == '.') { - i = atoi(p+1) + MAX_DIGITS; - if (i > prec) prec = i; - break; - } - } - if (prec < sizeof(format_buffer)) { - dest = format_buffer; - } else { - dest = caml_stat_alloc(prec); - } - sprintf(dest, String_val(fmt), d); - res = caml_copy_string(dest); - if (dest != format_buffer) { - caml_stat_free(dest); - } + res = caml_alloc_sprintf(String_val(fmt), d); #ifdef HAS_BROKEN_PRINTF } else { - if (isnan(d)) - { + if (isnan(d)) { res = caml_copy_string("nan"); - } - else - { + } else { if (d > 0) - { res = caml_copy_string("inf"); - } else - { res = caml_copy_string("-inf"); - } } } #endif return res; } +#if 0 /*CAMLprim*/ value caml_float_of_substring(value vs, value idx, value l) { char parse_buffer[64]; @@ -163,6 +124,7 @@ CAMLprim value caml_format_float(value fmt, value arg) if (buf != parse_buffer) caml_stat_free(buf); caml_failwith("float_of_string"); } +#endif CAMLprim value caml_float_of_string(value vs) { @@ -416,9 +378,9 @@ CAMLprim value caml_log1p_float(value f) union double_as_two_int32 { double d; #if defined(ARCH_BIG_ENDIAN) || (defined(__arm__) && !defined(__ARM_EABI__)) - struct { uint32 h; uint32 l; } i; + struct { uint32_t h; uint32_t l; } i; #else - struct { uint32 l; uint32 h; } i; + struct { uint32_t l; uint32_t h; } i; #endif }; @@ -505,7 +467,7 @@ CAMLprim value caml_classify_float(value vd) } #else union double_as_two_int32 u; - uint32 h, l; + uint32_t h, l; u.d = Double_val(vd); h = u.i.h; l = u.i.l; diff --git a/byterun/gc_ctrl.c b/byterun/gc_ctrl.c index 7e61f0c1b..1ab099da9 100644 --- a/byterun/gc_ctrl.c +++ b/byterun/gc_ctrl.c @@ -321,7 +321,7 @@ CAMLprim value caml_gc_get(value v) res = caml_alloc_tuple (7); Store_field (res, 0, Val_long (Wsize_bsize (caml_minor_heap_size))); /* s */ - Store_field (res, 1,Val_long(Wsize_bsize(caml_major_heap_increment)));/* i */ + Store_field (res, 1, Val_long (caml_major_heap_increment)); /* i */ Store_field (res, 2, Val_long (caml_percent_free)); /* o */ Store_field (res, 3, Val_long (caml_verb_gc)); /* v */ Store_field (res, 4, Val_long (caml_percent_max)); /* O */ diff --git a/byterun/globroots.c b/byterun/globroots.c index ded393e89..d9111eefe 100644 --- a/byterun/globroots.c +++ b/byterun/globroots.c @@ -43,11 +43,11 @@ struct global_root_list { (i.e. 2 * (NUM_LEVELS - 1)). Moreover, the congruential PRNG is faster and guaranteed to be deterministic (to reproduce bugs). */ -static uint32 random_seed = 0; +static uint32_t random_seed = 0; static int random_level(void) { - uint32 r; + uint32_t r; int level = 0; /* Linear congruence with modulus = 2^32, multiplier = 69069 diff --git a/byterun/hash.c b/byterun/hash.c index 61bee20cf..12912d3d2 100644 --- a/byterun/hash.c +++ b/byterun/hash.c @@ -21,12 +21,6 @@ #include "memory.h" #include "hash.h" -#ifdef ARCH_INT64_TYPE -#include "int64_native.h" -#else -#include "int64_emul.h" -#endif - /* The new implementation, based on MurmurHash 3, http://code.google.com/p/smhasher/ */ @@ -47,7 +41,7 @@ h *= 0xc2b2ae35; \ h ^= h >> 16; -CAMLexport uint32 caml_hash_mix_uint32(uint32 h, uint32 d) +CAMLexport uint32_t caml_hash_mix_uint32(uint32_t h, uint32_t d) { MIX(h, d); return h; @@ -55,17 +49,17 @@ CAMLexport uint32 caml_hash_mix_uint32(uint32 h, uint32 d) /* Mix a platform-native integer. */ -CAMLexport uint32 caml_hash_mix_intnat(uint32 h, intnat d) +CAMLexport uint32_t caml_hash_mix_intnat(uint32_t h, intnat d) { - uint32 n; + uint32_t n; #ifdef ARCH_SIXTYFOUR /* Mix the low 32 bits and the high 32 bits, in a way that preserves - 32/64 compatibility: we want n = (uint32) d + 32/64 compatibility: we want n = (uint32_t) d if d is in the range [-2^31, 2^31-1]. */ n = (d >> 32) ^ (d >> 63) ^ d; /* If 0 <= d < 2^31: d >> 32 = 0 d >> 63 = 0 If -2^31 <= d < 0: d >> 32 = -1 d >> 63 = -1 - In both cases, n = (uint32) d. */ + In both cases, n = (uint32_t) d. */ #else n = d; #endif @@ -75,11 +69,9 @@ CAMLexport uint32 caml_hash_mix_intnat(uint32 h, intnat d) /* Mix a 64-bit integer. */ -CAMLexport uint32 caml_hash_mix_int64(uint32 h, int64 d) +CAMLexport uint32_t caml_hash_mix_int64(uint32_t h, int64_t d) { - uint32 hi, lo; - - I64_split(d, hi, lo); + uint32_t hi = (uint32_t) (d >> 32), lo = (uint32_t) d; MIX(h, lo); MIX(h, hi); return h; @@ -90,17 +82,17 @@ CAMLexport uint32 caml_hash_mix_int64(uint32 h, int64 d) Treats all NaNs identically. */ -CAMLexport uint32 caml_hash_mix_double(uint32 hash, double d) +CAMLexport uint32_t caml_hash_mix_double(uint32_t hash, double d) { union { double d; #if defined(ARCH_BIG_ENDIAN) || (defined(__arm__) && !defined(__ARM_EABI__)) - struct { uint32 h; uint32 l; } i; + struct { uint32_t h; uint32_t l; } i; #else - struct { uint32 l; uint32 h; } i; + struct { uint32_t l; uint32_t h; } i; #endif } u; - uint32 h, l; + uint32_t h, l; /* Convert to two 32-bit halves */ u.d = d; h = u.i.h; l = u.i.l; @@ -123,14 +115,14 @@ CAMLexport uint32 caml_hash_mix_double(uint32 hash, double d) Treats all NaNs identically. */ -CAMLexport uint32 caml_hash_mix_float(uint32 hash, float d) +CAMLexport uint32_t caml_hash_mix_float(uint32_t hash, float d) { union { float f; - uint32 i; + uint32_t i; } u; - uint32 n; - /* Convert to int32 */ + uint32_t n; + /* Convert to int32_t */ u.f = d; n = u.i; /* Normalize NaNs */ if ((n & 0x7F800000) == 0x7F800000 && (n & 0x007FFFFF) != 0) { @@ -146,11 +138,11 @@ CAMLexport uint32 caml_hash_mix_float(uint32 hash, float d) /* Mix an OCaml string */ -CAMLexport uint32 caml_hash_mix_string(uint32 h, value s) +CAMLexport uint32_t caml_hash_mix_string(uint32_t h, value s) { mlsize_t len = caml_string_length(s); mlsize_t i; - uint32 w; + uint32_t w; /* Mix by 32-bit blocks (little-endian) */ for (i = 0; i + 4 <= len; i += 4) { @@ -160,7 +152,7 @@ CAMLexport uint32 caml_hash_mix_string(uint32 h, value s) | (Byte_u(s, i+2) << 16) | (Byte_u(s, i+3) << 24); #else - w = *((uint32 *) &Byte_u(s, i)); + w = *((uint32_t *) &Byte_u(s, i)); #endif MIX(h, w); } @@ -174,12 +166,14 @@ CAMLexport uint32 caml_hash_mix_string(uint32 h, value s) default: /*skip*/; /* len & 3 == 0, no extra bytes, do nothing */ } /* Finally, mix in the length. Ignore the upper 32 bits, generally 0. */ - h ^= (uint32) len; + h ^= (uint32_t) len; return h; } /* Maximal size of the queue used for breadth-first traversal. */ #define HASH_QUEUE_SIZE 256 +/* Maximal number of Forward_tag links followed in one step */ +#define MAX_FORWARD_DEREFERENCE 1000 /* The generic hash function */ @@ -190,7 +184,7 @@ CAMLprim value caml_hash(value count, value limit, value seed, value obj) intnat wr; /* One past position of last value in queue */ intnat sz; /* Max number of values to put in queue */ intnat num; /* Max number of meaningful values to see */ - uint32 h; /* Rolling hash */ + uint32_t h; /* Rolling hash */ value v; mlsize_t i, len; @@ -221,7 +215,7 @@ CAMLprim value caml_hash(value count, value limit, value seed, value obj) for (i = 0, len = Wosize_val(v) / Double_wosize; i < len; i++) { h = caml_hash_mix_double(h, Double_field(v, i)); num--; - if (num < 0) break; + if (num <= 0) break; } break; case Abstract_tag: @@ -234,8 +228,15 @@ CAMLprim value caml_hash(value count, value limit, value seed, value obj) v = v - Infix_offset_val(v); goto again; case Forward_tag: - v = Forward_val(v); - goto again; + /* PR#6361: we can have a loop here, so limit the number of + Forward_tag links being followed */ + for (i = MAX_FORWARD_DEREFERENCE; i > 0; i--) { + v = Forward_val(v); + if (Is_long(v) || !Is_in_value_area(v) || Tag_val(v) != Forward_tag) + goto again; + } + /* Give up on this object and move to the next */ + break; case Object_tag: h = caml_hash_mix_intnat(h, Oid_val(v)); num--; @@ -244,7 +245,7 @@ CAMLprim value caml_hash(value count, value limit, value seed, value obj) /* If no hashing function provided, do nothing. */ /* Only use low 32 bits of custom hash, for 32/64 compatibility */ if (Custom_ops_val(v)->hash != NULL) { - uint32 n = (uint32) Custom_ops_val(v)->hash(v); + uint32_t n = (uint32_t) Custom_ops_val(v)->hash(v); h = caml_hash_mix_uint32(h, n); num--; } @@ -407,5 +408,5 @@ CAMLexport value caml_hash_variant(char const * tag) #endif /* Force sign extension of bit 31 for compatibility between 32 and 64-bit platforms */ - return (int32) accu; + return (int32_t) accu; } diff --git a/byterun/hash.h b/byterun/hash.h index 436a8bb16..65613975b 100644 --- a/byterun/hash.h +++ b/byterun/hash.h @@ -18,12 +18,12 @@ #include "mlvalues.h" -CAMLextern uint32 caml_hash_mix_uint32(uint32 h, uint32 d); -CAMLextern uint32 caml_hash_mix_intnat(uint32 h, intnat d); -CAMLextern uint32 caml_hash_mix_int64(uint32 h, int64 d); -CAMLextern uint32 caml_hash_mix_double(uint32 h, double d); -CAMLextern uint32 caml_hash_mix_float(uint32 h, float d); -CAMLextern uint32 caml_hash_mix_string(uint32 h, value s); +CAMLextern uint32_t caml_hash_mix_uint32(uint32_t h, uint32_t d); +CAMLextern uint32_t caml_hash_mix_intnat(uint32_t h, intnat d); +CAMLextern uint32_t caml_hash_mix_int64(uint32_t h, int64_t d); +CAMLextern uint32_t caml_hash_mix_double(uint32_t h, double d); +CAMLextern uint32_t caml_hash_mix_float(uint32_t h, float d); +CAMLextern uint32_t caml_hash_mix_string(uint32_t h, value s); #endif diff --git a/byterun/instrtrace.c b/byterun/instrtrace.c index 2934984d2..0a19fd2f1 100644 --- a/byterun/instrtrace.c +++ b/byterun/instrtrace.c @@ -84,7 +84,7 @@ char * caml_instr_string (code_t pc) char *nam; nam = (instr < 0 || instr > STOP) - ? (sprintf (nambuf, "???%d", instr), nambuf) + ? (snprintf (nambuf, sizeof(nambuf), "???%d", instr), nambuf) : names_of_instructions[instr]; pc++; switch (instr) { @@ -125,7 +125,7 @@ char * caml_instr_string (code_t pc) case OFFSETREF: case OFFSETCLOSURE: case PUSHOFFSETCLOSURE: - sprintf(buf, "%s %d", nam, pc[0]); + snprintf(buf, sizeof(buf), "%s %d", nam, pc[0]); break; /* Instructions with two operands */ case APPTERM: @@ -142,16 +142,16 @@ char * caml_instr_string (code_t pc) case BGEINT: case BULTINT: case BUGEINT: - sprintf(buf, "%s %d, %d", nam, pc[0], pc[1]); + snprintf(buf, sizeof(buf), "%s %d, %d", nam, pc[0], pc[1]); break; case SWITCH: - sprintf(buf, "SWITCH sz%#lx=%ld::ntag%ld nint%ld", + snprintf(buf, sizeof(buf), "SWITCH sz%#lx=%ld::ntag%ld nint%ld", (long) pc[0], (long) pc[0], (unsigned long) pc[0] >> 16, (unsigned long) pc[0] & 0xffff); break; /* Instructions with a C primitive as operand */ case C_CALLN: - sprintf(buf, "%s %d,", nam, pc[0]); + snprintf(buf, sizeof(buf), "%s %d,", nam, pc[0]); pc++; /* fallthrough */ case C_CALL1: @@ -160,12 +160,13 @@ char * caml_instr_string (code_t pc) case C_CALL4: case C_CALL5: if (pc[0] < 0 || pc[0] >= caml_prim_name_table.size) - sprintf(buf, "%s unknown primitive %d", nam, pc[0]); + snprintf(buf, sizeof(buf), "%s unknown primitive %d", nam, pc[0]); else - sprintf(buf, "%s %s", nam, (char *) caml_prim_name_table.contents[pc[0]]); + snprintf(buf, sizeof(buf), "%s %s", + nam, (char *) caml_prim_name_table.contents[pc[0]]); break; default: - sprintf(buf, "%s", nam); + snprintf(buf, sizeof(buf), "%s", nam); break; }; return buf; diff --git a/byterun/instruct.h b/byterun/instruct.h index a643b0f93..f9cc80ee6 100644 --- a/byterun/instruct.h +++ b/byterun/instruct.h @@ -40,7 +40,6 @@ enum instructions { GETSTRINGCHAR, SETSTRINGCHAR, BRANCH, BRANCHIF, BRANCHIFNOT, SWITCH, BOOLNOT, PUSHTRAP, POPTRAP, RAISE, - RERAISE, RAISE_NOTRACE, CHECK_SIGNALS, C_CALL1, C_CALL2, C_CALL3, C_CALL4, C_CALL5, C_CALLN, CONST0, CONST1, CONST2, CONST3, CONSTINT, @@ -55,7 +54,9 @@ enum instructions { BULTINT, BUGEINT, GETPUBMET, GETDYNMET, STOP, - EVENT, BREAK -}; + EVENT, BREAK, + RERAISE, RAISE_NOTRACE, +FIRST_UNIMPLEMENTED_OP}; + #endif /* CAML_INSTRUCT_H */ diff --git a/byterun/int64_emul.h b/byterun/int64_emul.h index ba7904a4f..2554df181 100644 --- a/byterun/int64_emul.h +++ b/byterun/int64_emul.h @@ -28,7 +28,7 @@ #define I64_split(x,hi,lo) (hi = (x).h, lo = (x).l) /* Unsigned comparison */ -static int I64_ucompare(uint64 x, uint64 y) +static int I64_ucompare(uint64_t x, uint64_t y) { if (x.h > y.h) return 1; if (x.h < y.h) return -1; @@ -40,19 +40,19 @@ static int I64_ucompare(uint64 x, uint64 y) #define I64_ult(x, y) (I64_ucompare(x, y) < 0) /* Signed comparison */ -static int I64_compare(int64 x, int64 y) +static int I64_compare(int64_t x, int64_t y) { - if ((int32)x.h > (int32)y.h) return 1; - if ((int32)x.h < (int32)y.h) return -1; + if ((int32_t)x.h > (int32_t)y.h) return 1; + if ((int32_t)x.h < (int32_t)y.h) return -1; if (x.l > y.l) return 1; if (x.l < y.l) return -1; return 0; } /* Negation */ -static int64 I64_neg(int64 x) +static int64_t I64_neg(int64_t x) { - int64 res; + int64_t res; res.l = -x.l; res.h = ~x.h; if (res.l == 0) res.h++; @@ -60,9 +60,9 @@ static int64 I64_neg(int64 x) } /* Addition */ -static int64 I64_add(int64 x, int64 y) +static int64_t I64_add(int64_t x, int64_t y) { - int64 res; + int64_t res; res.l = x.l + y.l; res.h = x.h + y.h; if (res.l < x.l) res.h++; @@ -70,9 +70,9 @@ static int64 I64_add(int64 x, int64 y) } /* Subtraction */ -static int64 I64_sub(int64 x, int64 y) +static int64_t I64_sub(int64_t x, int64_t y) { - int64 res; + int64_t res; res.l = x.l - y.l; res.h = x.h - y.h; if (x.l < y.l) res.h--; @@ -80,13 +80,13 @@ static int64 I64_sub(int64 x, int64 y) } /* Multiplication */ -static int64 I64_mul(int64 x, int64 y) +static int64_t I64_mul(int64_t x, int64_t y) { - int64 res; - uint32 prod00 = (x.l & 0xFFFF) * (y.l & 0xFFFF); - uint32 prod10 = (x.l >> 16) * (y.l & 0xFFFF); - uint32 prod01 = (x.l & 0xFFFF) * (y.l >> 16); - uint32 prod11 = (x.l >> 16) * (y.l >> 16); + int64_t res; + uint32_t prod00 = (x.l & 0xFFFF) * (y.l & 0xFFFF); + uint32_t prod10 = (x.l >> 16) * (y.l & 0xFFFF); + uint32_t prod01 = (x.l & 0xFFFF) * (y.l >> 16); + uint32_t prod11 = (x.l >> 16) * (y.l >> 16); res.l = prod00; res.h = prod11 + (prod01 >> 16) + (prod10 >> 16); prod01 = prod01 << 16; res.l += prod01; if (res.l < prod01) res.h++; @@ -96,39 +96,39 @@ static int64 I64_mul(int64 x, int64 y) } #define I64_is_zero(x) (((x).l | (x).h) == 0) -#define I64_is_negative(x) ((int32) (x).h < 0) +#define I64_is_negative(x) ((int32_t) (x).h < 0) #define I64_is_min_int(x) ((x).l == 0 && (x).h == 0x80000000U) #define I64_is_minus_one(x) (((x).l & (x).h) == 0xFFFFFFFFU) /* Bitwise operations */ -static int64 I64_and(int64 x, int64 y) +static int64_t I64_and(int64_t x, int64_t y) { - int64 res; + int64_t res; res.l = x.l & y.l; res.h = x.h & y.h; return res; } -static int64 I64_or(int64 x, int64 y) +static int64_t I64_or(int64_t x, int64_t y) { - int64 res; + int64_t res; res.l = x.l | y.l; res.h = x.h | y.h; return res; } -static int64 I64_xor(int64 x, int64 y) +static int64_t I64_xor(int64_t x, int64_t y) { - int64 res; + int64_t res; res.l = x.l ^ y.l; res.h = x.h ^ y.h; return res; } /* Shifts */ -static int64 I64_lsl(int64 x, int s) +static int64_t I64_lsl(int64_t x, int s) { - int64 res; + int64_t res; s = s & 63; if (s == 0) return x; if (s < 32) { @@ -141,9 +141,9 @@ static int64 I64_lsl(int64 x, int s) return res; } -static int64 I64_lsr(int64 x, int s) +static int64_t I64_lsr(int64_t x, int s) { - int64 res; + int64_t res; s = s & 63; if (s == 0) return x; if (s < 32) { @@ -156,17 +156,17 @@ static int64 I64_lsr(int64 x, int s) return res; } -static int64 I64_asr(int64 x, int s) +static int64_t I64_asr(int64_t x, int s) { - int64 res; + int64_t res; s = s & 63; if (s == 0) return x; if (s < 32) { res.l = (x.l >> s) | (x.h << (32 - s)); - res.h = (int32) x.h >> s; + res.h = (int32_t) x.h >> s; } else { - res.l = (int32) x.h >> (s - 32); - res.h = (int32) x.h >> 31; + res.l = (int32_t) x.h >> (s - 32); + res.h = (int32_t) x.h >> 31; } return res; } @@ -176,15 +176,15 @@ static int64 I64_asr(int64 x, int s) #define I64_SHL1(x) x.h = (x.h << 1) | (x.l >> 31); x.l <<= 1 #define I64_SHR1(x) x.l = (x.l >> 1) | (x.h << 31); x.h >>= 1 -static void I64_udivmod(uint64 modulus, uint64 divisor, - uint64 * quo, uint64 * mod) +static void I64_udivmod(uint64_t modulus, uint64_t divisor, + uint64_t * quo, uint64_t * mod) { - int64 quotient, mask; + int64_t quotient, mask; int cmp; quotient.h = 0; quotient.l = 0; mask.h = 0; mask.l = 1; - while ((int32) divisor.h >= 0) { + while ((int32_t) divisor.h >= 0) { cmp = I64_ucompare(divisor, modulus); I64_SHL1(divisor); I64_SHL1(mask); @@ -202,27 +202,27 @@ static void I64_udivmod(uint64 modulus, uint64 divisor, *mod = modulus; } -static int64 I64_div(int64 x, int64 y) +static int64_t I64_div(int64_t x, int64_t y) { - int64 q, r; - int32 sign; + int64_t q, r; + int32_t sign; sign = x.h ^ y.h; - if ((int32) x.h < 0) x = I64_neg(x); - if ((int32) y.h < 0) y = I64_neg(y); + if ((int32_t) x.h < 0) x = I64_neg(x); + if ((int32_t) y.h < 0) y = I64_neg(y); I64_udivmod(x, y, &q, &r); if (sign < 0) q = I64_neg(q); return q; } -static int64 I64_mod(int64 x, int64 y) +static int64_t I64_mod(int64_t x, int64_t y) { - int64 q, r; - int32 sign; + int64_t q, r; + int32_t sign; sign = x.h; - if ((int32) x.h < 0) x = I64_neg(x); - if ((int32) y.h < 0) y = I64_neg(y); + if ((int32_t) x.h < 0) x = I64_neg(x); + if ((int32_t) y.h < 0) y = I64_neg(y); I64_udivmod(x, y, &q, &r); if (sign < 0) r = I64_neg(r); return r; @@ -230,49 +230,49 @@ static int64 I64_mod(int64 x, int64 y) /* Coercions */ -static int64 I64_of_int32(int32 x) +static int64_t I64_of_int32(int32_t x) { - int64 res; + int64_t res; res.l = x; res.h = x >> 31; return res; } -#define I64_to_int32(x) ((int32) (x).l) +#define I64_to_int32(x) ((int32_t) (x).l) /* Note: we assume sizeof(intnat) = 4 here, which is true otherwise autoconfiguration would have selected native 64-bit integers */ #define I64_of_intnat I64_of_int32 #define I64_to_intnat I64_to_int32 -static double I64_to_double(int64 x) +static double I64_to_double(int64_t x) { double res; - int32 sign = x.h; + int32_t sign = x.h; if (sign < 0) x = I64_neg(x); res = ldexp((double) x.h, 32) + x.l; if (sign < 0) res = -res; return res; } -static int64 I64_of_double(double f) +static int64_t I64_of_double(double f) { - int64 res; + int64_t res; double frac, integ; int neg; neg = (f < 0); f = fabs(f); frac = modf(ldexp(f, -32), &integ); - res.h = (uint32) integ; - res.l = (uint32) ldexp(frac, 32); + res.h = (uint32_t) integ; + res.l = (uint32_t) ldexp(frac, 32); if (neg) res = I64_neg(res); return res; } -static int64 I64_bswap(int64 x) +static int64_t I64_bswap(int64_t x) { - int64 res; + int64_t res; res.h = (((x.l & 0x000000FF) << 24) | ((x.l & 0x0000FF00) << 8) | ((x.l & 0x00FF0000) >> 8) | diff --git a/byterun/int64_format.h b/byterun/int64_format.h index b0de52720..aa8f1abab 100644 --- a/byterun/int64_format.h +++ b/byterun/int64_format.h @@ -17,7 +17,7 @@ #ifndef CAML_INT64_FORMAT_H #define CAML_INT64_FORMAT_H -static void I64_format(char * buffer, char * fmt, int64 x) +static void I64_format(char * buffer, char * fmt, int64_t x) { static char conv_lower[] = "0123456789abcdef"; static char conv_upper[] = "0123456789ABCDEF"; @@ -26,7 +26,7 @@ static void I64_format(char * buffer, char * fmt, int64 x) int base, width, sign, i, rawlen; char * cvtbl; char * p, * r; - int64 wbase, digit; + int64_t wbase, digit; /* Parsing of format */ justify = '+'; diff --git a/byterun/int64_native.h b/byterun/int64_native.h index e9ffe6749..b6716ada2 100644 --- a/byterun/int64_native.h +++ b/byterun/int64_native.h @@ -18,36 +18,36 @@ #ifndef CAML_INT64_NATIVE_H #define CAML_INT64_NATIVE_H -#define I64_literal(hi,lo) ((int64)(hi) << 32 | (lo)) -#define I64_split(x,hi,lo) (hi = (uint32)((x)>>32), lo = (uint32)(x)) +#define I64_literal(hi,lo) ((int64_t)(hi) << 32 | (lo)) +#define I64_split(x,hi,lo) (hi = (uint32_t)((x)>>32), lo = (uint32_t)(x)) #define I64_compare(x,y) (((x) > (y)) - ((x) < (y))) -#define I64_ult(x,y) ((uint64)(x) < (uint64)(y)) +#define I64_ult(x,y) ((uint64_t)(x) < (uint64_t)(y)) #define I64_neg(x) (-(x)) #define I64_add(x,y) ((x) + (y)) #define I64_sub(x,y) ((x) - (y)) #define I64_mul(x,y) ((x) * (y)) #define I64_is_zero(x) ((x) == 0) #define I64_is_negative(x) ((x) < 0) -#define I64_is_min_int(x) ((x) == ((int64)1 << 63)) +#define I64_is_min_int(x) ((x) == ((int64_t)1 << 63)) #define I64_is_minus_one(x) ((x) == -1) #define I64_div(x,y) ((x) / (y)) #define I64_mod(x,y) ((x) % (y)) #define I64_udivmod(x,y,quo,rem) \ - (*(rem) = (uint64)(x) % (uint64)(y), \ - *(quo) = (uint64)(x) / (uint64)(y)) + (*(rem) = (uint64_t)(x) % (uint64_t)(y), \ + *(quo) = (uint64_t)(x) / (uint64_t)(y)) #define I64_and(x,y) ((x) & (y)) #define I64_or(x,y) ((x) | (y)) #define I64_xor(x,y) ((x) ^ (y)) #define I64_lsl(x,y) ((x) << (y)) #define I64_asr(x,y) ((x) >> (y)) -#define I64_lsr(x,y) ((uint64)(x) >> (y)) +#define I64_lsr(x,y) ((uint64_t)(x) >> (y)) #define I64_to_intnat(x) ((intnat) (x)) #define I64_of_intnat(x) ((intnat) (x)) -#define I64_to_int32(x) ((int32) (x)) -#define I64_of_int32(x) ((int64) (x)) +#define I64_to_int32(x) ((int32_t) (x)) +#define I64_of_int32(x) ((int64_t) (x)) #define I64_to_double(x) ((double)(x)) -#define I64_of_double(x) ((int64)(x)) +#define I64_of_double(x) ((int64_t)(x)) #define I64_bswap(x) ((((x) & 0x00000000000000FFULL) << 56) | \ (((x) & 0x000000000000FF00ULL) << 40) | \ diff --git a/byterun/intern.c b/byterun/intern.c index f03704c32..638ff7287 100644 --- a/byterun/intern.c +++ b/byterun/intern.c @@ -553,7 +553,7 @@ static void intern_add_to_heap(mlsize_t whsize) value caml_input_val(struct channel *chan) { - uint32 magic; + uint32_t magic; mlsize_t block_len, num_objects, whsize; char * block; value res; @@ -663,7 +663,7 @@ static value input_val_from_block(void) CAMLexport value caml_input_value_from_malloc(char * data, intnat ofs) { - uint32 magic; + uint32_t magic; value obj; intern_input = (unsigned char *) data; @@ -681,7 +681,7 @@ CAMLexport value caml_input_value_from_malloc(char * data, intnat ofs) CAMLexport value caml_input_value_from_block(char * data, intnat len) { - uint32 magic; + uint32_t magic; mlsize_t block_len; value obj; @@ -700,7 +700,7 @@ CAMLexport value caml_input_value_from_block(char * data, intnat len) CAMLprim value caml_marshal_data_size(value buff, value ofs) { - uint32 magic; + uint32_t magic; mlsize_t block_len; intern_src = &Byte_u(buff, Long_val(ofs)); @@ -738,7 +738,8 @@ static char * intern_resolve_code_pointer(unsigned char digest[16], static void intern_bad_code_pointer(unsigned char digest[16]) { char msg[256]; - sprintf(msg, "input_value: unknown code module " + snprintf(msg, sizeof(msg), + "input_value: unknown code module " "%02X%02X%02X%02X%02X%02X%02X%02X" "%02X%02X%02X%02X%02X%02X%02X%02X", digest[0], digest[1], digest[2], digest[3], @@ -770,26 +771,26 @@ CAMLexport int caml_deserialize_sint_2(void) return read16s(); } -CAMLexport uint32 caml_deserialize_uint_4(void) +CAMLexport uint32_t caml_deserialize_uint_4(void) { return read32u(); } -CAMLexport int32 caml_deserialize_sint_4(void) +CAMLexport int32_t caml_deserialize_sint_4(void) { return read32s(); } -CAMLexport uint64 caml_deserialize_uint_8(void) +CAMLexport uint64_t caml_deserialize_uint_8(void) { - uint64 i; + uint64_t i; caml_deserialize_block_8(&i, 1); return i; } -CAMLexport int64 caml_deserialize_sint_8(void) +CAMLexport int64_t caml_deserialize_sint_8(void) { - int64 i; + int64_t i; caml_deserialize_block_8(&i, 1); return i; } diff --git a/byterun/interp.c b/byterun/interp.c index 591b51778..e22b28b8b 100644 --- a/byterun/interp.c +++ b/byterun/interp.c @@ -181,14 +181,6 @@ sp is a local copy of the global variable caml_extern_sp. */ #endif #endif -/* Division and modulus madness */ - -#ifdef NONSTANDARD_DIV_MOD -extern intnat caml_safe_div(intnat p, intnat q); -extern intnat caml_safe_mod(intnat p, intnat q); -#endif - - #ifdef DEBUG static intnat caml_bcodcount; #endif @@ -531,10 +523,21 @@ value caml_interprete(code_t prog, asize_t prog_size) int nvars = *pc++; int i; if (nvars > 0) *--sp = accu; - Alloc_small(accu, 1 + nvars, Closure_tag); + if (nvars < Max_young_wosize) { + /* nvars + 1 <= Max_young_wosize, can allocate in minor heap */ + Alloc_small(accu, 1 + nvars, Closure_tag); + for (i = 0; i < nvars; i++) Field(accu, i + 1) = sp[i]; + } else { + /* PR#6385: must allocate in major heap */ + /* caml_alloc_shr and caml_initialize never trigger a GC, + so no need to Setup_for_gc */ + accu = caml_alloc_shr(1 + nvars, Closure_tag); + for (i = 0; i < nvars; i++) caml_initialize(&Field(accu, i + 1), sp[i]); + } + /* The code pointer is not in the heap, so no need to go through + caml_initialize. */ Code_val(accu) = pc + *pc; pc++; - for (i = 0; i < nvars; i++) Field(accu, i + 1) = sp[i]; sp += nvars; Next; } @@ -542,15 +545,25 @@ value caml_interprete(code_t prog, asize_t prog_size) Instruct(CLOSUREREC): { int nfuncs = *pc++; int nvars = *pc++; + mlsize_t blksize = nfuncs * 2 - 1 + nvars; int i; value * p; if (nvars > 0) *--sp = accu; - Alloc_small(accu, nfuncs * 2 - 1 + nvars, Closure_tag); - p = &Field(accu, nfuncs * 2 - 1); - for (i = 0; i < nvars; i++) { - *p++ = sp[i]; + if (blksize <= Max_young_wosize) { + Alloc_small(accu, blksize, Closure_tag); + p = &Field(accu, nfuncs * 2 - 1); + for (i = 0; i < nvars; i++, p++) *p = sp[i]; + } else { + /* PR#6385: must allocate in major heap */ + /* caml_alloc_shr and caml_initialize never trigger a GC, + so no need to Setup_for_gc */ + accu = caml_alloc_shr(blksize, Closure_tag); + p = &Field(accu, nfuncs * 2 - 1); + for (i = 0; i < nvars; i++, p++) caml_initialize(p, sp[i]); } sp += nvars; + /* The code pointers and infix headers are not in the heap, + so no need to go through caml_initialize. */ p = &Field(accu, 0); *p = (value) (pc + pc[0]); *--sp = accu; @@ -780,7 +793,7 @@ value caml_interprete(code_t prog, asize_t prog_size) if (accu == Val_false) pc += *pc; else pc++; Next; Instruct(SWITCH): { - uint32 sizes = *pc++; + uint32_t sizes = *pc++; if (Is_block(accu)) { intnat index = Tag_val(accu); Assert ((uintnat) index < (sizes >> 16)); @@ -962,21 +975,13 @@ value caml_interprete(code_t prog, asize_t prog_size) Instruct(DIVINT): { intnat divisor = Long_val(*sp++); if (divisor == 0) { Setup_for_c_call; caml_raise_zero_divide(); } -#ifdef NONSTANDARD_DIV_MOD - accu = Val_long(caml_safe_div(Long_val(accu), divisor)); -#else accu = Val_long(Long_val(accu) / divisor); -#endif Next; } Instruct(MODINT): { intnat divisor = Long_val(*sp++); if (divisor == 0) { Setup_for_c_call; caml_raise_zero_divide(); } -#ifdef NONSTANDARD_DIV_MOD - accu = Val_long(caml_safe_mod(Long_val(accu), divisor)); -#else accu = Val_long(Long_val(accu) % divisor); -#endif Next; } Instruct(ANDINT): diff --git a/byterun/intext.h b/byterun/intext.h index f7aa655c9..2c108a4ae 100644 --- a/byterun/intext.h +++ b/byterun/intext.h @@ -119,8 +119,8 @@ CAMLextern value caml_input_value_from_block(char * data, intnat len); CAMLextern void caml_serialize_int_1(int i); CAMLextern void caml_serialize_int_2(int i); -CAMLextern void caml_serialize_int_4(int32 i); -CAMLextern void caml_serialize_int_8(int64 i); +CAMLextern void caml_serialize_int_4(int32_t i); +CAMLextern void caml_serialize_int_8(int64_t i); CAMLextern void caml_serialize_float_4(float f); CAMLextern void caml_serialize_float_8(double f); CAMLextern void caml_serialize_block_1(void * data, intnat len); @@ -133,10 +133,10 @@ CAMLextern int caml_deserialize_uint_1(void); CAMLextern int caml_deserialize_sint_1(void); CAMLextern int caml_deserialize_uint_2(void); CAMLextern int caml_deserialize_sint_2(void); -CAMLextern uint32 caml_deserialize_uint_4(void); -CAMLextern int32 caml_deserialize_sint_4(void); -CAMLextern uint64 caml_deserialize_uint_8(void); -CAMLextern int64 caml_deserialize_sint_8(void); +CAMLextern uint32_t caml_deserialize_uint_4(void); +CAMLextern int32_t caml_deserialize_sint_4(void); +CAMLextern uint64_t caml_deserialize_uint_8(void); +CAMLextern int64_t caml_deserialize_sint_8(void); CAMLextern float caml_deserialize_float_4(void); CAMLextern double caml_deserialize_float_8(void); CAMLextern void caml_deserialize_block_1(void * data, intnat len); diff --git a/byterun/ints.c b/byterun/ints.c index 4bf1d332c..056e82aa3 100644 --- a/byterun/ints.c +++ b/byterun/ints.c @@ -96,24 +96,6 @@ static intnat parse_intnat(value s, int nbits) return sign < 0 ? -((intnat) res) : (intnat) res; } -#ifdef NONSTANDARD_DIV_MOD -intnat caml_safe_div(intnat p, intnat q) -{ - uintnat ap = p >= 0 ? p : -p; - uintnat aq = q >= 0 ? q : -q; - uintnat ar = ap / aq; - return (p ^ q) >= 0 ? ar : -ar; -} - -intnat caml_safe_mod(intnat p, intnat q) -{ - uintnat ap = p >= 0 ? p : -p; - uintnat aq = q >= 0 ? q : -q; - uintnat ar = ap % aq; - return p >= 0 ? ar : -ar; -} -#endif - value caml_bswap16_direct(value x) { return ((((x & 0x00FF) << 8) | @@ -142,13 +124,10 @@ CAMLprim value caml_int_of_string(value s) #define FORMAT_BUFFER_SIZE 32 -static char * parse_format(value fmt, - char * suffix, - char format_string[], - char default_format_buffer[], - char *conv) +static char parse_format(value fmt, + char * suffix, + char format_string[FORMAT_BUFFER_SIZE]) { - int prec; char * p; char lastletter; mlsize_t len, len_suffix; @@ -167,41 +146,25 @@ static char * parse_format(value fmt, memmove(p, suffix, len_suffix); p += len_suffix; *p++ = lastletter; *p = 0; - /* Determine space needed for result and allocate it dynamically if needed */ - prec = 22 + 5; /* 22 digits for 64-bit number in octal + 5 extra */ - for (p = String_val(fmt); *p != 0; p++) { - if (*p >= '0' && *p <= '9') { - prec = atoi(p) + 5; - break; - } - } - *conv = lastletter; - if (prec < FORMAT_BUFFER_SIZE) - return default_format_buffer; - else - return caml_stat_alloc(prec + 1); + /* Return the conversion type (last letter) */ + return lastletter; } CAMLprim value caml_format_int(value fmt, value arg) { char format_string[FORMAT_BUFFER_SIZE]; - char default_format_buffer[FORMAT_BUFFER_SIZE]; - char * buffer; char conv; value res; - buffer = parse_format(fmt, ARCH_INTNAT_PRINTF_FORMAT, - format_string, default_format_buffer, &conv); + conv = parse_format(fmt, ARCH_INTNAT_PRINTF_FORMAT, format_string); switch (conv) { case 'u': case 'x': case 'X': case 'o': - sprintf(buffer, format_string, Unsigned_long_val(arg)); + res = caml_alloc_sprintf(format_string, Unsigned_long_val(arg)); break; default: - sprintf(buffer, format_string, Long_val(arg)); + res = caml_alloc_sprintf(format_string, Long_val(arg)); break; } - res = caml_copy_string(buffer); - if (buffer != default_format_buffer) caml_stat_free(buffer); return res; } @@ -209,8 +172,8 @@ CAMLprim value caml_format_int(value fmt, value arg) static int int32_cmp(value v1, value v2) { - int32 i1 = Int32_val(v1); - int32 i2 = Int32_val(v2); + int32_t i1 = Int32_val(v1); + int32_t i2 = Int32_val(v2); return (i1 > i2) - (i1 < i2); } @@ -228,7 +191,7 @@ static void int32_serialize(value v, uintnat * wsize_32, static uintnat int32_deserialize(void * dst) { - *((int32 *) dst) = caml_deserialize_sint_4(); + *((int32_t *) dst) = caml_deserialize_sint_4(); return 4; } @@ -242,7 +205,7 @@ CAMLexport struct custom_operations caml_int32_ops = { custom_compare_ext_default }; -CAMLexport value caml_copy_int32(int32 i) +CAMLexport value caml_copy_int32(int32_t i) { value res = caml_alloc_custom(&caml_int32_ops, 4, 0, 1); Int32_val(res) = i; @@ -263,32 +226,24 @@ CAMLprim value caml_int32_mul(value v1, value v2) CAMLprim value caml_int32_div(value v1, value v2) { - int32 dividend = Int32_val(v1); - int32 divisor = Int32_val(v2); + int32_t dividend = Int32_val(v1); + int32_t divisor = Int32_val(v2); if (divisor == 0) caml_raise_zero_divide(); /* PR#4740: on some processors, division crashes on overflow. Implement the same behavior as for type "int". */ if (dividend == (1<<31) && divisor == -1) return v1; -#ifdef NONSTANDARD_DIV_MOD - return caml_copy_int32(caml_safe_div(dividend, divisor)); -#else return caml_copy_int32(dividend / divisor); -#endif } CAMLprim value caml_int32_mod(value v1, value v2) { - int32 dividend = Int32_val(v1); - int32 divisor = Int32_val(v2); + int32_t dividend = Int32_val(v1); + int32_t divisor = Int32_val(v2); if (divisor == 0) caml_raise_zero_divide(); /* PR#4740: on some processors, modulus crashes if division overflows. Implement the same behavior as for type "int". */ if (dividend == (1<<31) && divisor == -1) return caml_copy_int32(0); -#ifdef NONSTANDARD_DIV_MOD - return caml_copy_int32(caml_safe_mod(dividend, divisor)); -#else return caml_copy_int32(dividend % divisor); -#endif } CAMLprim value caml_int32_and(value v1, value v2) @@ -307,9 +262,9 @@ CAMLprim value caml_int32_shift_right(value v1, value v2) { return caml_copy_int32(Int32_val(v1) >> Int_val(v2)); } CAMLprim value caml_int32_shift_right_unsigned(value v1, value v2) -{ return caml_copy_int32((uint32)Int32_val(v1) >> Int_val(v2)); } +{ return caml_copy_int32((uint32_t)Int32_val(v1) >> Int_val(v2)); } -static int32 caml_swap32(int32 x) +static int32_t caml_swap32(int32_t x) { return (((x & 0x000000FF) << 24) | ((x & 0x0000FF00) << 8) | @@ -330,15 +285,15 @@ CAMLprim value caml_int32_to_int(value v) { return Val_long(Int32_val(v)); } CAMLprim value caml_int32_of_float(value v) -{ return caml_copy_int32((int32)(Double_val(v))); } +{ return caml_copy_int32((int32_t)(Double_val(v))); } CAMLprim value caml_int32_to_float(value v) { return caml_copy_double((double)(Int32_val(v))); } CAMLprim value caml_int32_compare(value v1, value v2) { - int32 i1 = Int32_val(v1); - int32 i2 = Int32_val(v2); + int32_t i1 = Int32_val(v1); + int32_t i2 = Int32_val(v2); int res = (i1 > i2) - (i1 < i2); return Val_int(res); } @@ -346,17 +301,9 @@ CAMLprim value caml_int32_compare(value v1, value v2) CAMLprim value caml_int32_format(value fmt, value arg) { char format_string[FORMAT_BUFFER_SIZE]; - char default_format_buffer[FORMAT_BUFFER_SIZE]; - char * buffer; - char conv; - value res; - buffer = parse_format(fmt, ARCH_INT32_PRINTF_FORMAT, - format_string, default_format_buffer, &conv); - sprintf(buffer, format_string, Int32_val(arg)); - res = caml_copy_string(buffer); - if (buffer != default_format_buffer) caml_stat_free(buffer); - return res; + parse_format(fmt, ARCH_INT32_PRINTF_FORMAT, format_string); + return caml_alloc_sprintf(format_string, Int32_val(arg)); } CAMLprim value caml_int32_of_string(value s) @@ -366,33 +313,27 @@ CAMLprim value caml_int32_of_string(value s) CAMLprim value caml_int32_bits_of_float(value vd) { - union { float d; int32 i; } u; + union { float d; int32_t i; } u; u.d = Double_val(vd); return caml_copy_int32(u.i); } CAMLprim value caml_int32_float_of_bits(value vi) { - union { float d; int32 i; } u; + union { float d; int32_t i; } u; u.i = Int32_val(vi); return caml_copy_double(u.d); } /* 64-bit integers */ -#ifdef ARCH_INT64_TYPE -#include "int64_native.h" -#else -#include "int64_emul.h" -#endif - #ifdef ARCH_ALIGN_INT64 -CAMLexport int64 caml_Int64_val(value v) +CAMLexport int64_t caml_Int64_val(value v) { - union { int32 i[2]; int64 j; } buffer; - buffer.i[0] = ((int32 *) Data_custom_val(v))[0]; - buffer.i[1] = ((int32 *) Data_custom_val(v))[1]; + union { int32_t i[2]; int64_t j; } buffer; + buffer.i[0] = ((int32_t *) Data_custom_val(v))[0]; + buffer.i[1] = ((int32_t *) Data_custom_val(v))[1]; return buffer.j; } @@ -400,17 +341,15 @@ CAMLexport int64 caml_Int64_val(value v) static int int64_cmp(value v1, value v2) { - int64 i1 = Int64_val(v1); - int64 i2 = Int64_val(v2); - return I64_compare(i1, i2); + int64_t i1 = Int64_val(v1); + int64_t i2 = Int64_val(v2); + return (i1 > i2) - (i1 < i2); } static intnat int64_hash(value v) { - int64 x = Int64_val(v); - uint32 lo, hi; - - I64_split(x, hi, lo); + int64_t x = Int64_val(v); + uint32_t lo = (uint32_t) x, hi = (uint32_t) (x >> 32); return hi ^ lo; } @@ -424,12 +363,12 @@ static void int64_serialize(value v, uintnat * wsize_32, static uintnat int64_deserialize(void * dst) { #ifndef ARCH_ALIGN_INT64 - *((int64 *) dst) = caml_deserialize_sint_8(); + *((int64_t *) dst) = caml_deserialize_sint_8(); #else - union { int32 i[2]; int64 j; } buffer; + union { int32_t i[2]; int64_t j; } buffer; buffer.j = caml_deserialize_sint_8(); - ((int32 *) dst)[0] = buffer.i[0]; - ((int32 *) dst)[1] = buffer.i[1]; + ((int32_t *) dst)[0] = buffer.i[0]; + ((int32_t *) dst)[1] = buffer.i[1]; #endif return 8; } @@ -444,74 +383,73 @@ CAMLexport struct custom_operations caml_int64_ops = { custom_compare_ext_default }; -CAMLexport value caml_copy_int64(int64 i) +CAMLexport value caml_copy_int64(int64_t i) { value res = caml_alloc_custom(&caml_int64_ops, 8, 0, 1); #ifndef ARCH_ALIGN_INT64 Int64_val(res) = i; #else - union { int32 i[2]; int64 j; } buffer; + union { int32_t i[2]; int64_t j; } buffer; buffer.j = i; - ((int32 *) Data_custom_val(res))[0] = buffer.i[0]; - ((int32 *) Data_custom_val(res))[1] = buffer.i[1]; + ((int32_t *) Data_custom_val(res))[0] = buffer.i[0]; + ((int32_t *) Data_custom_val(res))[1] = buffer.i[1]; #endif return res; } CAMLprim value caml_int64_neg(value v) -{ return caml_copy_int64(I64_neg(Int64_val(v))); } +{ return caml_copy_int64(- Int64_val(v)); } CAMLprim value caml_int64_add(value v1, value v2) -{ return caml_copy_int64(I64_add(Int64_val(v1), Int64_val(v2))); } +{ return caml_copy_int64(Int64_val(v1) + Int64_val(v2)); } CAMLprim value caml_int64_sub(value v1, value v2) -{ return caml_copy_int64(I64_sub(Int64_val(v1), Int64_val(v2))); } +{ return caml_copy_int64(Int64_val(v1) - Int64_val(v2)); } CAMLprim value caml_int64_mul(value v1, value v2) -{ return caml_copy_int64(I64_mul(Int64_val(v1), Int64_val(v2))); } +{ return caml_copy_int64(Int64_val(v1) * Int64_val(v2)); } + +#define Int64_min_int ((intnat) 1 << (sizeof(intnat) * 8 - 1)) CAMLprim value caml_int64_div(value v1, value v2) { - int64 dividend = Int64_val(v1); - int64 divisor = Int64_val(v2); - if (I64_is_zero(divisor)) caml_raise_zero_divide(); + int64_t dividend = Int64_val(v1); + int64_t divisor = Int64_val(v2); + if (divisor == 0) caml_raise_zero_divide(); /* PR#4740: on some processors, division crashes on overflow. Implement the same behavior as for type "int". */ - if (I64_is_min_int(dividend) && I64_is_minus_one(divisor)) return v1; - return caml_copy_int64(I64_div(Int64_val(v1), divisor)); + if (dividend == ((int64_t)1 << 63) && divisor == -1) return v1; + return caml_copy_int64(Int64_val(v1) / divisor); } CAMLprim value caml_int64_mod(value v1, value v2) { - int64 dividend = Int64_val(v1); - int64 divisor = Int64_val(v2); - if (I64_is_zero(divisor)) caml_raise_zero_divide(); + int64_t dividend = Int64_val(v1); + int64_t divisor = Int64_val(v2); + if (divisor == 0) caml_raise_zero_divide(); /* PR#4740: on some processors, division crashes on overflow. Implement the same behavior as for type "int". */ - if (I64_is_min_int(dividend) && I64_is_minus_one(divisor)) { - int64 zero = I64_literal(0,0); - return caml_copy_int64(zero); - } - return caml_copy_int64(I64_mod(Int64_val(v1), divisor)); + if (dividend == ((int64_t)1 << 63) && divisor == -1) return caml_copy_int64(0); + return caml_copy_int64(Int64_val(v1) % divisor); } CAMLprim value caml_int64_and(value v1, value v2) -{ return caml_copy_int64(I64_and(Int64_val(v1), Int64_val(v2))); } +{ return caml_copy_int64(Int64_val(v1) & Int64_val(v2)); } CAMLprim value caml_int64_or(value v1, value v2) -{ return caml_copy_int64(I64_or(Int64_val(v1), Int64_val(v2))); } +{ return caml_copy_int64(Int64_val(v1) | Int64_val(v2)); } CAMLprim value caml_int64_xor(value v1, value v2) -{ return caml_copy_int64(I64_xor(Int64_val(v1), Int64_val(v2))); } +{ return caml_copy_int64(Int64_val(v1) ^ Int64_val(v2)); } CAMLprim value caml_int64_shift_left(value v1, value v2) -{ return caml_copy_int64(I64_lsl(Int64_val(v1), Int_val(v2))); } +{ return caml_copy_int64(Int64_val(v1) << Int_val(v2)); } CAMLprim value caml_int64_shift_right(value v1, value v2) -{ return caml_copy_int64(I64_asr(Int64_val(v1), Int_val(v2))); } +{ return caml_copy_int64(Int64_val(v1) >> Int_val(v2)); } CAMLprim value caml_int64_shift_right_unsigned(value v1, value v2) -{ return caml_copy_int64(I64_lsr(Int64_val(v1), Int_val(v2))); } +{ return caml_copy_int64((uint64_t) (Int64_val(v1)) >> Int_val(v2)); } #ifdef ARCH_SIXTYFOUR static value caml_swap64(value x) @@ -531,117 +469,111 @@ value caml_int64_direct_bswap(value v) #endif CAMLprim value caml_int64_bswap(value v) -{ return caml_copy_int64(I64_bswap(Int64_val(v))); } +{ + int64_t x = Int64_val(v); + return caml_copy_int64 + (((x & 0x00000000000000FFULL) << 56) | + ((x & 0x000000000000FF00ULL) << 40) | + ((x & 0x0000000000FF0000ULL) << 24) | + ((x & 0x00000000FF000000ULL) << 8) | + ((x & 0x000000FF00000000ULL) >> 8) | + ((x & 0x0000FF0000000000ULL) >> 24) | + ((x & 0x00FF000000000000ULL) >> 40) | + ((x & 0xFF00000000000000ULL) >> 56)); +} CAMLprim value caml_int64_of_int(value v) -{ return caml_copy_int64(I64_of_intnat(Long_val(v))); } +{ return caml_copy_int64((int64_t) (Long_val(v))); } CAMLprim value caml_int64_to_int(value v) -{ return Val_long(I64_to_intnat(Int64_val(v))); } +{ return Val_long((intnat) (Int64_val(v))); } CAMLprim value caml_int64_of_float(value v) -{ return caml_copy_int64(I64_of_double(Double_val(v))); } +{ return caml_copy_int64((int64_t) (Double_val(v))); } CAMLprim value caml_int64_to_float(value v) -{ - int64 i = Int64_val(v); - return caml_copy_double(I64_to_double(i)); -} +{ return caml_copy_double((double) (Int64_val(v))); } CAMLprim value caml_int64_of_int32(value v) -{ return caml_copy_int64(I64_of_int32(Int32_val(v))); } +{ return caml_copy_int64((int64_t) (Int32_val(v))); } CAMLprim value caml_int64_to_int32(value v) -{ return caml_copy_int32(I64_to_int32(Int64_val(v))); } +{ return caml_copy_int32((int32_t) (Int64_val(v))); } CAMLprim value caml_int64_of_nativeint(value v) -{ return caml_copy_int64(I64_of_intnat(Nativeint_val(v))); } +{ return caml_copy_int64((int64_t) (Nativeint_val(v))); } CAMLprim value caml_int64_to_nativeint(value v) -{ return caml_copy_nativeint(I64_to_intnat(Int64_val(v))); } +{ return caml_copy_nativeint((intnat) (Int64_val(v))); } CAMLprim value caml_int64_compare(value v1, value v2) { - int64 i1 = Int64_val(v1); - int64 i2 = Int64_val(v2); - return Val_int(I64_compare(i1, i2)); + int64_t i1 = Int64_val(v1); + int64_t i2 = Int64_val(v2); + return Val_int((i1 > i2) - (i1 < i2)); } -#ifdef ARCH_INT64_PRINTF_FORMAT -#define I64_format(buf,fmt,x) sprintf(buf,fmt,x) -#else -#include "int64_format.h" -#define ARCH_INT64_PRINTF_FORMAT "" -#endif - CAMLprim value caml_int64_format(value fmt, value arg) { char format_string[FORMAT_BUFFER_SIZE]; - char default_format_buffer[FORMAT_BUFFER_SIZE]; - char * buffer; - char conv; - value res; - buffer = parse_format(fmt, ARCH_INT64_PRINTF_FORMAT, - format_string, default_format_buffer, &conv); - I64_format(buffer, format_string, Int64_val(arg)); - res = caml_copy_string(buffer); - if (buffer != default_format_buffer) caml_stat_free(buffer); - return res; + parse_format(fmt, ARCH_INT64_PRINTF_FORMAT, format_string); + return caml_alloc_sprintf(format_string, Int64_val(arg)); } CAMLprim value caml_int64_of_string(value s) { char * p; - uint64 max_uint64 = I64_literal(0xFFFFFFFF, 0xFFFFFFFF); - uint64 max_int64_pos = I64_literal(0x7FFFFFFF, 0xFFFFFFFF); - uint64 max_int64_neg = I64_literal(0x80000000, 0x00000000); - uint64 res, threshold; + uint64_t res, threshold; int sign, base, d; p = parse_sign_and_base(String_val(s), &base, &sign); - I64_udivmod(max_uint64, I64_of_int32(base), &threshold, &res); + threshold = ((uint64_t) -1) / base; d = parse_digit(*p); if (d < 0 || d >= base) caml_failwith("int_of_string"); - res = I64_of_int32(d); + res = d; for (p++; /*nothing*/; p++) { char c = *p; if (c == '_') continue; d = parse_digit(c); if (d < 0 || d >= base) break; /* Detect overflow in multiplication base * res */ - if (I64_ult(threshold, res)) caml_failwith("int_of_string"); - res = I64_add(I64_mul(I64_of_int32(base), res), I64_of_int32(d)); + if (res > threshold) caml_failwith("int_of_string"); + res = base * res + d; /* Detect overflow in addition (base * res) + d */ - if (I64_ult(res, I64_of_int32(d))) caml_failwith("int_of_string"); + if (res < (uint64_t) d) caml_failwith("int_of_string"); } if (p != String_val(s) + caml_string_length(s)){ caml_failwith("int_of_string"); } if (base == 10) { - if (I64_ult((sign >= 0 ? max_int64_pos : max_int64_neg), res)) - caml_failwith("int_of_string"); + /* Signed representation expected, allow -2^63 to 2^63 - 1 only */ + if (sign >= 0) { + if (res >= (uint64_t)1 << 63) caml_failwith("int_of_string"); + } else { + if (res > (uint64_t)1 << 63) caml_failwith("int_of_string"); + } } - if (sign < 0) res = I64_neg(res); + if (sign < 0) res = - res; return caml_copy_int64(res); } CAMLprim value caml_int64_bits_of_float(value vd) { - union { double d; int64 i; int32 h[2]; } u; + union { double d; int64_t i; int32_t h[2]; } u; u.d = Double_val(vd); #if defined(__arm__) && !defined(__ARM_EABI__) - { int32 t = u.h[0]; u.h[0] = u.h[1]; u.h[1] = t; } + { int32_t t = u.h[0]; u.h[0] = u.h[1]; u.h[1] = t; } #endif return caml_copy_int64(u.i); } CAMLprim value caml_int64_float_of_bits(value vi) { - union { double d; int64 i; int32 h[2]; } u; + union { double d; int64_t i; int32_t h[2]; } u; u.i = Int64_val(vi); #if defined(__arm__) && !defined(__ARM_EABI__) - { int32 t = u.h[0]; u.h[0] = u.h[1]; u.h[1] = t; } + { int32_t t = u.h[0]; u.h[0] = u.h[1]; u.h[1] = t; } #endif return caml_copy_double(u.d); } @@ -674,7 +606,7 @@ static void nativeint_serialize(value v, uintnat * wsize_32, #ifdef ARCH_SIXTYFOUR if (l >= -((intnat)1 << 31) && l < ((intnat)1 << 31)) { caml_serialize_int_1(1); - caml_serialize_int_4((int32) l); + caml_serialize_int_4((int32_t) l); } else { caml_serialize_int_1(2); caml_serialize_int_8(l); @@ -745,11 +677,7 @@ CAMLprim value caml_nativeint_div(value v1, value v2) /* PR#4740: on some processors, modulus crashes if division overflows. Implement the same behavior as for type "int". */ if (dividend == Nativeint_min_int && divisor == -1) return v1; -#ifdef NONSTANDARD_DIV_MOD - return caml_copy_nativeint(caml_safe_div(dividend, divisor)); -#else return caml_copy_nativeint(dividend / divisor); -#endif } CAMLprim value caml_nativeint_mod(value v1, value v2) @@ -762,11 +690,7 @@ CAMLprim value caml_nativeint_mod(value v1, value v2) if (dividend == Nativeint_min_int && divisor == -1){ return caml_copy_nativeint(0); } -#ifdef NONSTANDARD_DIV_MOD - return caml_copy_nativeint(caml_safe_mod(dividend, divisor)); -#else return caml_copy_nativeint(dividend % divisor); -#endif } CAMLprim value caml_nativeint_and(value v1, value v2) @@ -834,17 +758,9 @@ CAMLprim value caml_nativeint_compare(value v1, value v2) CAMLprim value caml_nativeint_format(value fmt, value arg) { char format_string[FORMAT_BUFFER_SIZE]; - char default_format_buffer[FORMAT_BUFFER_SIZE]; - char * buffer; - char conv; - value res; - buffer = parse_format(fmt, ARCH_INTNAT_PRINTF_FORMAT, - format_string, default_format_buffer, &conv); - sprintf(buffer, format_string, Nativeint_val(arg)); - res = caml_copy_string(buffer); - if (buffer != default_format_buffer) caml_stat_free(buffer); - return res; + parse_format(fmt, ARCH_INTNAT_PRINTF_FORMAT, format_string); + return caml_alloc_sprintf(format_string, Nativeint_val(arg)); } CAMLprim value caml_nativeint_of_string(value s) diff --git a/byterun/io.c b/byterun/io.c index c1566b72c..bedc0f03a 100644 --- a/byterun/io.c +++ b/byterun/io.c @@ -207,7 +207,7 @@ CAMLexport void caml_flush(struct channel *channel) /* Output data */ -CAMLexport void caml_putword(struct channel *channel, uint32 w) +CAMLexport void caml_putword(struct channel *channel, uint32_t w) { if (! caml_channel_binary_mode(channel)) caml_failwith("output_binary_int: not a binary channel"); @@ -303,10 +303,10 @@ CAMLexport unsigned char caml_refill(struct channel *channel) return (unsigned char)(channel->buff[0]); } -CAMLexport uint32 caml_getword(struct channel *channel) +CAMLexport uint32_t caml_getword(struct channel *channel) { int i; - uint32 res; + uint32_t res; if (! caml_channel_binary_mode(channel)) caml_failwith("input_binary_int: not a binary channel"); @@ -791,21 +791,3 @@ CAMLprim value caml_ml_input_scan_line(value vchannel) Unlock(channel); CAMLreturn (Val_long(res)); } - -/* Conversion between file_offset and int64 */ - -#ifndef ARCH_INT64_TYPE -CAMLexport value caml_Val_file_offset(file_offset fofs) -{ - int64 ofs; - ofs.l = fofs; - ofs.h = 0; - return caml_copy_int64(ofs); -} - -CAMLexport file_offset caml_File_offset_val(value v) -{ - int64 ofs = Int64_val(v); - return (file_offset) ofs.l; -} -#endif diff --git a/byterun/io.h b/byterun/io.h index 1d0917e6c..5a9c0374c 100644 --- a/byterun/io.h +++ b/byterun/io.h @@ -78,12 +78,12 @@ CAMLextern value caml_alloc_channel(struct channel *chan); CAMLextern int caml_flush_partial (struct channel *); CAMLextern void caml_flush (struct channel *); -CAMLextern void caml_putword (struct channel *, uint32); +CAMLextern void caml_putword (struct channel *, uint32_t); CAMLextern int caml_putblock (struct channel *, char *, intnat); CAMLextern void caml_really_putblock (struct channel *, char *, intnat); CAMLextern unsigned char caml_refill (struct channel *); -CAMLextern uint32 caml_getword (struct channel *); +CAMLextern uint32_t caml_getword (struct channel *); CAMLextern int caml_getblock (struct channel *, char *, intnat); CAMLextern int caml_really_getblock (struct channel *, char *, intnat); @@ -107,16 +107,9 @@ CAMLextern struct channel * caml_all_opened_channels; #define Unlock_exn() \ if (caml_channel_mutex_unlock_exn != NULL) (*caml_channel_mutex_unlock_exn)() -/* Conversion between file_offset and int64 */ +/* Conversion between file_offset and int64_t */ -#ifdef ARCH_INT64_TYPE #define Val_file_offset(fofs) caml_copy_int64(fofs) #define File_offset_val(v) ((file_offset) Int64_val(v)) -#else -CAMLextern value caml_Val_file_offset(file_offset fofs); -CAMLextern file_offset caml_File_offset_val(value v); -#define Val_file_offset caml_Val_file_offset -#define File_offset_val caml_File_offset_val -#endif #endif /* CAML_IO_H */ diff --git a/byterun/lexing.c b/byterun/lexing.c index 8242cc7a8..22ef6acde 100644 --- a/byterun/lexing.c +++ b/byterun/lexing.c @@ -49,7 +49,7 @@ struct lexing_table { #if defined(ARCH_BIG_ENDIAN) || SIZEOF_SHORT != 2 #define Short(tbl,n) \ (*((unsigned char *)((tbl) + (n) * 2)) + \ - (*((schar *)((tbl) + (n) * 2 + 1)) << 8)) + (*((signed char *)((tbl) + (n) * 2 + 1)) << 8)) #else #define Short(tbl,n) (((short *)(tbl))[(n)]) #endif diff --git a/byterun/major_gc.c b/byterun/major_gc.c index b3c25b817..a44c8d90a 100644 --- a/byterun/major_gc.c +++ b/byterun/major_gc.c @@ -27,6 +27,12 @@ #include "roots.h" #include "weak.h" +#if defined (NATIVE_CODE) && defined (NO_NAKED_POINTERS) +#define NATIVE_CODE_AND_NO_NAKED_POINTERS +#else +#undef NATIVE_CODE_AND_NO_NAKED_POINTERS +#endif + uintnat caml_percent_free; uintnat caml_major_heap_increment; CAMLexport char *caml_heap_start; @@ -82,7 +88,18 @@ static void realloc_gray_vals (void) void caml_darken (value v, value *p /* not used */) { +#ifdef NATIVE_CODE_AND_NO_NAKED_POINTERS + if (Is_block (v) && Wosize_val (v) > 0) { + /* We insist that naked pointers to outside the heap point to things that + look like values with headers coloured black. This isn't always + strictly necessary but is essential in certain cases---in particular + when the value is allocated in a read-only section. (For the values + where it would be safe it is a performance improvement since we avoid + putting them on the grey list.) */ + CAMLassert (Is_in_heap (v) || Is_black_hd (Hd_val (v))); +#else if (Is_block (v) && Is_in_heap (v)) { +#endif header_t h = Hd_val (v); tag_t t = Tag_hd (h); if (t == Infix_tag){ @@ -124,6 +141,9 @@ static void mark_slice (intnat work) value v, child; header_t hd; mlsize_t size, i; +#ifdef NATIVE_CODE_AND_NO_NAKED_POINTERS + int marking_closure = 0; +#endif caml_gc_message (0x40, "Marking %ld words\n", work); caml_gc_message (0x40, "Subphase = %ld\n", caml_gc_subphase); @@ -132,13 +152,28 @@ static void mark_slice (intnat work) if (gray_vals_ptr > gray_vals){ v = *--gray_vals_ptr; hd = Hd_val(v); +#ifdef NATIVE_CODE_AND_NO_NAKED_POINTERS + marking_closure = + (Tag_hd (hd) == Closure_tag || Tag_hd (hd) == Infix_tag); +#endif Assert (Is_gray_hd (hd)); Hd_val (v) = Blackhd_hd (hd); size = Wosize_hd (hd); if (Tag_hd (hd) < No_scan_tag){ for (i = 0; i < size; i++){ child = Field (v, i); +#ifdef NATIVE_CODE_AND_NO_NAKED_POINTERS + if (Is_block (child) + && Wosize_val (child) > 0 /* Atoms never need to be marked. */ + /* Closure blocks contain code pointers at offsets that cannot + be reliably determined, so we always use the page table when + marking such values. */ + && (!marking_closure || Is_in_heap (child))) { + /* See [caml_darken] for a description of this assertion. */ + CAMLassert (Is_in_heap (child) || Is_black_hd (Hd_val (child))); +#else if (Is_block (child) && Is_in_heap (child)) { +#endif hd = Hd_val (child); if (Tag_hd (hd) == Forward_tag){ value f = Forward_val (child); diff --git a/byterun/md5.c b/byterun/md5.c index 10ac76abc..2dc90a204 100644 --- a/byterun/md5.c +++ b/byterun/md5.c @@ -97,11 +97,11 @@ CAMLexport void caml_md5_block(unsigned char digest[16], #else static void byteReverse(unsigned char * buf, unsigned longs) { - uint32 t; + uint32_t t; do { - t = (uint32) ((unsigned) buf[3] << 8 | buf[2]) << 16 | + t = (uint32_t) ((unsigned) buf[3] << 8 | buf[2]) << 16 | ((unsigned) buf[1] << 8 | buf[0]); - *(uint32 *) buf = t; + *(uint32_t *) buf = t; buf += 4; } while (--longs); } @@ -129,12 +129,12 @@ CAMLexport void caml_MD5Init(struct MD5Context *ctx) CAMLexport void caml_MD5Update(struct MD5Context *ctx, unsigned char *buf, uintnat len) { - uint32 t; + uint32_t t; /* Update bitcount */ t = ctx->bits[0]; - if ((ctx->bits[0] = t + ((uint32) len << 3)) < t) + if ((ctx->bits[0] = t + ((uint32_t) len << 3)) < t) ctx->bits[1]++; /* Carry from low to high */ ctx->bits[1] += len >> 29; @@ -152,7 +152,7 @@ CAMLexport void caml_MD5Update(struct MD5Context *ctx, unsigned char *buf, } memcpy(p, buf, t); byteReverse(ctx->in, 16); - caml_MD5Transform(ctx->buf, (uint32 *) ctx->in); + caml_MD5Transform(ctx->buf, (uint32_t *) ctx->in); buf += t; len -= t; } @@ -161,7 +161,7 @@ CAMLexport void caml_MD5Update(struct MD5Context *ctx, unsigned char *buf, while (len >= 64) { memcpy(ctx->in, buf, 64); byteReverse(ctx->in, 16); - caml_MD5Transform(ctx->buf, (uint32 *) ctx->in); + caml_MD5Transform(ctx->buf, (uint32_t *) ctx->in); buf += 64; len -= 64; } @@ -196,7 +196,7 @@ CAMLexport void caml_MD5Final(unsigned char *digest, struct MD5Context *ctx) /* Two lots of padding: Pad the first block to 64 bytes */ memset(p, 0, count); byteReverse(ctx->in, 16); - caml_MD5Transform(ctx->buf, (uint32 *) ctx->in); + caml_MD5Transform(ctx->buf, (uint32_t *) ctx->in); /* Now fill the next block with 56 bytes */ memset(ctx->in, 0, 56); @@ -207,10 +207,10 @@ CAMLexport void caml_MD5Final(unsigned char *digest, struct MD5Context *ctx) byteReverse(ctx->in, 14); /* Append length in bits and transform */ - ((uint32 *) ctx->in)[14] = ctx->bits[0]; - ((uint32 *) ctx->in)[15] = ctx->bits[1]; + ((uint32_t *) ctx->in)[14] = ctx->bits[0]; + ((uint32_t *) ctx->in)[15] = ctx->bits[1]; - caml_MD5Transform(ctx->buf, (uint32 *) ctx->in); + caml_MD5Transform(ctx->buf, (uint32_t *) ctx->in); byteReverse((unsigned char *) ctx->buf, 4); memcpy(digest, ctx->buf, 16); memset(ctx, 0, sizeof(*ctx)); /* In case it's sensitive */ @@ -233,9 +233,9 @@ CAMLexport void caml_MD5Final(unsigned char *digest, struct MD5Context *ctx) * reflect the addition of 16 longwords of new data. caml_MD5Update blocks * the data and converts bytes into longwords for this routine. */ -CAMLexport void caml_MD5Transform(uint32 *buf, uint32 *in) +CAMLexport void caml_MD5Transform(uint32_t *buf, uint32_t *in) { - register uint32 a, b, c, d; + register uint32_t a, b, c, d; a = buf[0]; b = buf[1]; diff --git a/byterun/md5.h b/byterun/md5.h index d8aff097a..f63667d56 100644 --- a/byterun/md5.h +++ b/byterun/md5.h @@ -26,8 +26,8 @@ CAMLextern void caml_md5_block(unsigned char digest[16], void * data, uintnat len); struct MD5Context { - uint32 buf[4]; - uint32 bits[2]; + uint32_t buf[4]; + uint32_t bits[2]; unsigned char in[64]; }; @@ -35,7 +35,7 @@ CAMLextern void caml_MD5Init (struct MD5Context *context); CAMLextern void caml_MD5Update (struct MD5Context *context, unsigned char *buf, uintnat len); CAMLextern void caml_MD5Final (unsigned char *digest, struct MD5Context *ctx); -CAMLextern void caml_MD5Transform (uint32 *buf, uint32 *in); +CAMLextern void caml_MD5Transform (uint32_t *buf, uint32_t *in); #endif /* CAML_MD5_H */ diff --git a/byterun/memory.c b/byterun/memory.c index 529e5b248..54d91c96d 100644 --- a/byterun/memory.c +++ b/byterun/memory.c @@ -581,14 +581,6 @@ CAMLexport void * caml_stat_alloc (asize_t sz) return result; } -CAMLexport char * caml_stat_alloc_string(value str) -{ - mlsize_t sz = caml_string_length(str) + 1; - char * p = caml_stat_alloc(sz); - memcpy(p, String_val(str), sz); - return p; -} - CAMLexport void caml_stat_free (void * blk) { free (blk); diff --git a/byterun/memory.h b/byterun/memory.h index d1c8f9917..9befa873c 100644 --- a/byterun/memory.h +++ b/byterun/memory.h @@ -41,7 +41,6 @@ CAMLextern void caml_modify (value *, value); CAMLextern void caml_initialize (value *, value); CAMLextern value caml_check_urgent_gc (value); CAMLextern void * caml_stat_alloc (asize_t); /* Size in bytes. */ -CAMLextern char * caml_stat_alloc_string (value); CAMLextern void caml_stat_free (void *); CAMLextern void * caml_stat_resize (void *, asize_t); /* Size in bytes. */ char *caml_alloc_for_heap (asize_t request); /* Size in bytes. */ @@ -267,27 +266,31 @@ CAMLextern struct caml__roots_block *caml_local_roots; /* defined in roots.c */ 0) #define CAMLlocal1(x) \ - value x = 0; \ + value x = Val_unit; \ CAMLxparam1 (x) #define CAMLlocal2(x, y) \ - value x = 0, y = 0; \ + value x = Val_unit, y = Val_unit; \ CAMLxparam2 (x, y) #define CAMLlocal3(x, y, z) \ - value x = 0, y = 0, z = 0; \ + value x = Val_unit, y = Val_unit, z = Val_unit; \ CAMLxparam3 (x, y, z) #define CAMLlocal4(x, y, z, t) \ - value x = 0, y = 0, z = 0, t = 0; \ + value x = Val_unit, y = Val_unit, z = Val_unit, t = Val_unit; \ CAMLxparam4 (x, y, z, t) #define CAMLlocal5(x, y, z, t, u) \ - value x = 0, y = 0, z = 0, t = 0, u = 0; \ + value x = Val_unit, y = Val_unit, z = Val_unit, t = Val_unit, u = Val_unit; \ CAMLxparam5 (x, y, z, t, u) #define CAMLlocalN(x, size) \ - value x [(size)] = { 0, /* 0, 0, ... */ }; \ + value x [(size)]; \ + int caml__i_##x; \ + for (caml__i_##x = 0; caml__i_##x < size; caml__i_##x ++) { \ + x[caml__i_##x] = Val_unit; \ + } \ CAMLxparamN (x, (size)) diff --git a/byterun/misc.c b/byterun/misc.c index 6eeae0f1b..1872a80ac 100644 --- a/byterun/misc.c +++ b/byterun/misc.c @@ -12,6 +12,8 @@ /***********************************************************************/ #include <stdio.h> +#include <string.h> +#include <stdarg.h> #include "config.h" #include "misc.h" #include "memory.h" @@ -24,7 +26,6 @@ int caml_failed_assert (char * expr, char * file, int line) file, line, expr); fflush (stderr); exit (100); - return 1; /* not reached */ } void caml_set_fields (char *bp, unsigned long start, unsigned long filler) @@ -121,3 +122,39 @@ void caml_ext_table_free(struct ext_table * tbl, int free_entries) for (i = 0; i < tbl->size; i++) caml_stat_free(tbl->contents[i]); caml_stat_free(tbl->contents); } + +CAMLexport char * caml_strdup(const char * s) +{ + size_t slen = strlen(s); + char * res = caml_stat_alloc(slen + 1); + memcpy(res, s, slen + 1); + return res; +} + +CAMLexport char * caml_strconcat(int n, ...) +{ + va_list args; + char * res, * p; + size_t len; + int i; + + len = 0; + va_start(args, n); + for (i = 0; i < n; i++) { + const char * s = va_arg(args, const char *); + len += strlen(s); + } + va_end(args); + res = caml_stat_alloc(len + 1); + va_start(args, n); + p = res; + for (i = 0; i < n; i++) { + const char * s = va_arg(args, const char *); + size_t l = strlen(s); + memcpy(p, s, l); + p += l; + } + va_end(args); + *p = 0; + return res; +} diff --git a/byterun/misc.h b/byterun/misc.h index 4fd82af2d..f7b4fdc24 100644 --- a/byterun/misc.h +++ b/byterun/misc.h @@ -61,12 +61,10 @@ typedef char * addr; /* Assertions */ -/* <private> */ - #ifdef DEBUG #define CAMLassert(x) \ ((x) ? (void) 0 : caml_failed_assert ( #x , __FILE__, __LINE__)) -CAMLextern int caml_failed_assert (char *, char *, int); +CAMLextern int caml_failed_assert (char *, char *, int) Noreturn; #else #define CAMLassert(x) ((void) 0) #endif @@ -76,6 +74,13 @@ CAMLextern void caml_fatal_error_arg (char *fmt, char *arg) Noreturn; CAMLextern void caml_fatal_error_arg2 (char *fmt1, char *arg1, char *fmt2, char *arg2) Noreturn; +/* Safe string operations */ + +CAMLextern char * caml_strdup(const char * s); +CAMLextern char * caml_strconcat(int n, ...); /* n args of const char * type */ + +/* <private> */ + /* Data structures */ struct ext_table { @@ -138,6 +143,13 @@ extern void caml_set_fields (char *, unsigned long, unsigned long); #define Assert CAMLassert #endif +/* snprintf emulation for Win32 */ + +#ifdef _WIN32 +extern int caml_snprintf(char * buf, size_t size, const char * format, ...); +#define snprintf caml_snprintf +#endif + /* </private> */ #endif /* CAML_MISC_H */ diff --git a/byterun/mlvalues.h b/byterun/mlvalues.h index 268bcfe9f..a08948eb1 100644 --- a/byterun/mlvalues.h +++ b/byterun/mlvalues.h @@ -38,8 +38,8 @@ extern "C" { bp: Pointer to the first byte of a block. (a char *) op: Pointer to the first field of a block. (a value *) hp: Pointer to the header of a block. (a char *) - int32: Four bytes on all architectures. - int64: Eight bytes on all architectures. + int32_t: Four bytes on all architectures. + int64_t: Eight bytes on all architectures. Remark: A block size is always a multiple of the word size, and at least one word plus the header. @@ -161,7 +161,7 @@ bits 63 10 9 8 7 0 /* Fields are numbered from 0. */ #define Field(x, i) (((value *)(x)) [i]) /* Also an l-value. */ -typedef int32 opcode_t; +typedef int32_t opcode_t; typedef opcode_t * code_t; /* NOTE: [Forward_tag] and [Infix_tag] must be just under @@ -262,12 +262,12 @@ struct custom_operations; /* defined in [custom.h] */ /* Int32.t, Int64.t and Nativeint.t are represented as custom blocks. */ -#define Int32_val(v) (*((int32 *) Data_custom_val(v))) +#define Int32_val(v) (*((int32_t *) Data_custom_val(v))) #define Nativeint_val(v) (*((intnat *) Data_custom_val(v))) #ifndef ARCH_ALIGN_INT64 -#define Int64_val(v) (*((int64 *) Data_custom_val(v))) +#define Int64_val(v) (*((int64_t *) Data_custom_val(v))) #else -CAMLextern int64 caml_Int64_val(value v); +CAMLextern int64_t caml_Int64_val(value v); #define Int64_val(v) caml_Int64_val(v) #endif diff --git a/byterun/obj.c b/byterun/obj.c index 1d7b57910..b045fee26 100644 --- a/byterun/obj.c +++ b/byterun/obj.c @@ -255,3 +255,7 @@ CAMLprim value caml_set_oo_id (value obj) { oo_last_id += 2; return obj; } + +CAMLprim value caml_int_as_pointer (value n) { + return n - 1; +} diff --git a/byterun/osdeps.h b/byterun/osdeps.h index ee0952ac1..8204205f7 100644 --- a/byterun/osdeps.h +++ b/byterun/osdeps.h @@ -61,7 +61,8 @@ extern char * caml_dlerror(void); Return 0 on success, -1 on error; set errno in the case of error. */ extern int caml_read_directory(char * dirname, struct ext_table * contents); -/* Recover executable name if possible (/proc/sef/exe under Linux, GetModuleFileName under Windows). */ +/* Recover executable name if possible (/proc/sef/exe under Linux, + GetModuleFileName under Windows). */ extern int caml_executable_name(char * name, int name_len); #endif /* CAML_OSDEPS_H */ diff --git a/byterun/parsing.c b/byterun/parsing.c index 3c1ced7d1..a857e3922 100644 --- a/byterun/parsing.c +++ b/byterun/parsing.c @@ -63,7 +63,7 @@ struct parser_env { /* Mirrors parser_env in ../stdlib/parsing.ml */ #if defined(ARCH_BIG_ENDIAN) || SIZEOF_SHORT != 2 #define Short(tbl,n) \ (*((unsigned char *)((tbl) + (n) * 2)) + \ - (*((schar *)((tbl) + (n) * 2 + 1)) << 8)) + (*((signed char *)((tbl) + (n) * 2 + 1)) << 8)) #else #define Short(tbl,n) (((short *)(tbl))[n]) #endif diff --git a/byterun/printexc.c b/byterun/printexc.c index 6e70d524c..a371a71f6 100644 --- a/byterun/printexc.c +++ b/byterun/printexc.c @@ -71,7 +71,8 @@ CAMLexport char * caml_format_exception(value exn) if (i > start) add_string(&buf, ", "); v = Field(bucket, i); if (Is_long(v)) { - sprintf(intbuf, "%" ARCH_INTNAT_PRINTF_FORMAT "d", Long_val(v)); + snprintf(intbuf, sizeof(intbuf), + "%" ARCH_INTNAT_PRINTF_FORMAT "d", Long_val(v)); add_string(&buf, intbuf); } else if (Tag_val(v) == String_tag) { add_char(&buf, '"'); @@ -94,7 +95,14 @@ CAMLexport char * caml_format_exception(value exn) } -void caml_fatal_uncaught_exception(value exn) +#ifdef NATIVE_CODE +# define DEBUGGER_IN_USE 0 +#else +# define DEBUGGER_IN_USE caml_debugger_in_use +#endif + +/* Default C implementation in case the OCaml one is not registered. */ +static void default_fatal_uncaught_exception(value exn) { char * msg; value * at_exit; @@ -115,13 +123,21 @@ void caml_fatal_uncaught_exception(value exn) fprintf(stderr, "Fatal error: exception %s\n", msg); free(msg); /* Display the backtrace if available */ - if (caml_backtrace_active -#ifndef NATIVE_CODE - && !caml_debugger_in_use -#endif - ) { + if (caml_backtrace_active && !DEBUGGER_IN_USE) caml_print_exception_backtrace(); - } +} + +void caml_fatal_uncaught_exception(value exn) +{ + value *handle_uncaught_exception; + + handle_uncaught_exception = + caml_named_value("Printexc.handle_uncaught_exception"); + if (handle_uncaught_exception != NULL) + /* [Printexc.handle_uncaught_exception] does not raise exception. */ + caml_callback2(*handle_uncaught_exception, exn, Val_bool(DEBUGGER_IN_USE)); + else + default_fatal_uncaught_exception(exn); /* Terminate the process */ exit(2); } diff --git a/byterun/startup.c b/byterun/startup.c index 80ffe90b5..ab926efe2 100644 --- a/byterun/startup.c +++ b/byterun/startup.c @@ -79,7 +79,7 @@ static void init_atoms(void) /* Read the trailer of a bytecode file */ -static void fixup_endianness_trailer(uint32 * p) +static void fixup_endianness_trailer(uint32_t * p) { #ifndef ARCH_BIG_ENDIAN Reverse_32(p, p); @@ -153,7 +153,7 @@ void caml_read_section_descriptors(int fd, struct exec_trailer *trail) Return the length of the section data in bytes, or -1 if no section found with that name. */ -int32 caml_seek_optional_section(int fd, struct exec_trailer *trail, char *name) +int32_t caml_seek_optional_section(int fd, struct exec_trailer *trail, char *name) { long ofs; int i; @@ -172,9 +172,9 @@ int32 caml_seek_optional_section(int fd, struct exec_trailer *trail, char *name) /* Position fd at the beginning of the section having the given name. Return the length of the section data in bytes. */ -int32 caml_seek_section(int fd, struct exec_trailer *trail, char *name) +int32_t caml_seek_section(int fd, struct exec_trailer *trail, char *name) { - int32 len = caml_seek_optional_section(fd, trail, name); + int32_t len = caml_seek_optional_section(fd, trail, name); if (len == -1) caml_fatal_error_arg("Fatal_error: section `%s' is missing\n", name); return len; @@ -185,7 +185,7 @@ int32 caml_seek_section(int fd, struct exec_trailer *trail, char *name) static char * read_section(int fd, struct exec_trailer *trail, char *name) { - int32 len; + int32_t len; char * data; len = caml_seek_optional_section(fd, trail, name); @@ -246,10 +246,10 @@ static int parse_command_line(char **argv) #endif case 'v': if (!strcmp (argv[i], "-version")){ - printf ("The OCaml runtime, version " OCAML_VERSION "\n"); + printf ("The OCaml runtime, version " OCAML_VERSION_STRING "\n"); exit (0); }else if (!strcmp (argv[i], "-vnum")){ - printf (OCAML_VERSION "\n"); + printf (OCAML_VERSION_STRING "\n"); exit (0); }else{ caml_verb_gc = 0x001+0x004+0x008+0x010+0x020; @@ -374,7 +374,8 @@ CAMLexport void caml_main(char **argv) /* Should we really do that at all? The current executable is ocamlrun itself, it's never a bytecode program. */ - if (fd < 0 && caml_executable_name(proc_self_exe, sizeof(proc_self_exe)) == 0) { + if (fd < 0 + && caml_executable_name(proc_self_exe, sizeof(proc_self_exe)) == 0) { exe_name = proc_self_exe; fd = caml_attempt_open(&exe_name, &trail, 0); } @@ -458,7 +459,7 @@ CAMLexport void caml_startup_code( char **argv) { value res; - char* cds_file; + char * cds_file; char * exe_name; static char proc_self_exe[256]; @@ -472,8 +473,7 @@ CAMLexport void caml_startup_code( #endif cds_file = getenv("CAML_DEBUG_FILE"); if (cds_file != NULL) { - caml_cds_file = caml_stat_alloc(strlen(cds_file) + 1); - strcpy(caml_cds_file, cds_file); + caml_cds_file = caml_strdup(cds_file); } parse_camlrunparam(); exe_name = argv[0]; diff --git a/byterun/startup.h b/byterun/startup.h index 3dda64b33..3268d8875 100644 --- a/byterun/startup.h +++ b/byterun/startup.h @@ -30,9 +30,9 @@ enum { FILE_NOT_FOUND = -1, BAD_BYTECODE = -2 }; extern int caml_attempt_open(char **name, struct exec_trailer *trail, int do_open_script); extern void caml_read_section_descriptors(int fd, struct exec_trailer *trail); -extern int32 caml_seek_optional_section(int fd, struct exec_trailer *trail, +extern int32_t caml_seek_optional_section(int fd, struct exec_trailer *trail, char *name); -extern int32 caml_seek_section(int fd, struct exec_trailer *trail, char *name); +extern int32_t caml_seek_section(int fd, struct exec_trailer *trail, char *name); #endif /* CAML_STARTUP_H */ diff --git a/byterun/str.c b/byterun/str.c index 9e157a816..9c7baa1b1 100644 --- a/byterun/str.c +++ b/byterun/str.c @@ -15,6 +15,8 @@ #include <string.h> #include <ctype.h> +#include <stdio.h> +#include <stdarg.h> #include "alloc.h" #include "fail.h" #include "mlvalues.h" @@ -97,16 +99,9 @@ CAMLprim value caml_string_get32(value str, value index) return caml_copy_int32(res); } -#ifdef ARCH_INT64_TYPE -#include "int64_native.h" -#else -#include "int64_emul.h" -#endif - CAMLprim value caml_string_get64(value str, value index) { - uint32 reshi; - uint32 reslo; + uint64_t res; unsigned char b1, b2, b3, b4, b5, b6, b7, b8; intnat idx = Long_val(index); if (idx < 0 || idx + 7 >= caml_string_length(str)) caml_array_bound_error(); @@ -119,13 +114,17 @@ CAMLprim value caml_string_get64(value str, value index) b7 = Byte_u(str, idx + 6); b8 = Byte_u(str, idx + 7); #ifdef ARCH_BIG_ENDIAN - reshi = b1 << 24 | b2 << 16 | b3 << 8 | b4; - reslo = b5 << 24 | b6 << 16 | b7 << 8 | b8; + res = (uint64_t) b1 << 56 | (uint64_t) b2 << 48 + | (uint64_t) b3 << 40 | (uint64_t) b4 << 32 + | (uint64_t) b5 << 24 | (uint64_t) b6 << 16 + | (uint64_t) b7 << 8 | (uint64_t) b8; #else - reshi = b8 << 24 | b7 << 16 | b6 << 8 | b5; - reslo = b4 << 24 | b3 << 16 | b2 << 8 | b1; + res = (uint64_t) b8 << 56 | (uint64_t) b7 << 48 + | (uint64_t) b6 << 40 | (uint64_t) b5 << 32 + | (uint64_t) b4 << 24 | (uint64_t) b3 << 16 + | (uint64_t) b2 << 8 | (uint64_t) b1; #endif - return caml_copy_int64(I64_literal(reshi,reslo)); + return caml_copy_int64(res); } CAMLprim value caml_string_set16(value str, value index, value newval) @@ -175,30 +174,28 @@ CAMLprim value caml_string_set32(value str, value index, value newval) CAMLprim value caml_string_set64(value str, value index, value newval) { unsigned char b1, b2, b3, b4, b5, b6, b7, b8; - uint32 lo,hi; - int64 val; + int64_t val; intnat idx = Long_val(index); if (idx < 0 || idx + 7 >= caml_string_length(str)) caml_array_bound_error(); val = Int64_val(newval); - I64_split(val,hi,lo); #ifdef ARCH_BIG_ENDIAN - b1 = 0xFF & hi >> 24; - b2 = 0xFF & hi >> 16; - b3 = 0xFF & hi >> 8; - b4 = 0xFF & hi; - b5 = 0xFF & lo >> 24; - b6 = 0xFF & lo >> 16; - b7 = 0xFF & lo >> 8; - b8 = 0xFF & lo; + b1 = 0xFF & val >> 56; + b2 = 0xFF & val >> 48; + b3 = 0xFF & val >> 40; + b4 = 0xFF & val >> 32; + b5 = 0xFF & val >> 24; + b6 = 0xFF & val >> 16; + b7 = 0xFF & val >> 8; + b8 = 0xFF & val; #else - b8 = 0xFF & hi >> 24; - b7 = 0xFF & hi >> 16; - b6 = 0xFF & hi >> 8; - b5 = 0xFF & hi; - b4 = 0xFF & lo >> 24; - b3 = 0xFF & lo >> 16; - b2 = 0xFF & lo >> 8; - b1 = 0xFF & lo; + b8 = 0xFF & val >> 56; + b7 = 0xFF & val >> 48; + b6 = 0xFF & val >> 40; + b5 = 0xFF & val >> 32; + b4 = 0xFF & val >> 24; + b3 = 0xFF & val >> 16; + b2 = 0xFF & val >> 8; + b1 = 0xFF & val; #endif Byte_u(str, idx) = b1; Byte_u(str, idx + 1) = b2; @@ -299,3 +296,68 @@ CAMLprim value caml_bitvect_test(value bv, value n) int pos = Int_val(n); return Val_int(Byte_u(bv, pos >> 3) & (1 << (pos & 7))); } + +CAMLexport value caml_alloc_sprintf(const char * format, ...) +{ + va_list args; + char buf[64]; + int n; + value res; + +#ifndef _WIN32 + /* C99-compliant implementation */ + va_start(args, format); + /* "vsnprintf(dest, sz, format, args)" writes at most "sz" characters + into "dest", including the terminating '\0'. + It returns the number of characters of the formatted string, + excluding the terminating '\0'. */ + n = vsnprintf(buf, sizeof(buf), format, args); + va_end(args); + /* Allocate a Caml string with length "n" as computed by vsnprintf. */ + res = caml_alloc_string(n); + if (n < sizeof(buf)) { + /* All output characters were written to buf, including the + terminating '\0'. Just copy them to the result. */ + memcpy(String_val(res), buf, n); + } else { + /* Re-do the formatting, outputting directly in the Caml string. + Note that caml_alloc_string left room for a '\0' at position n, + so the size passed to vsnprintf is n+1. */ + va_start(args, format); + vsnprintf(String_val(res), n + 1, format, args); + va_end(args); + } + return res; +#else + /* Implementation specific to the Microsoft CRT library */ + va_start(args, format); + /* "_vsnprintf(dest, sz, format, args)" writes at most "sz" characters + into "dest". Let "len" be the number of characters of the formatted + string. + If "len" < "sz", a null terminator was appended, and "len" is returned. + If "len" == "sz", no null termination, and "len" is returned. + If "len" > "sz", a negative value is returned. */ + n = _vsnprintf(buf, sizeof(buf), format, args); + va_end(args); + if (n >= 0 && n <= sizeof(buf)) { + /* All output characters were written to buf. + "n" is the actual length of the output. + Copy the characters to a Caml string of length n. */ + res = caml_alloc_string(n); + memcpy(String_val(res), buf, n); + } else { + /* Determine actual length of output, excluding final '\0' */ + va_start(args, format); + n = _vscprintf(format, args); + va_end(args); + res = caml_alloc_string(n); + /* Re-do the formatting, outputting directly in the Caml string. + Note that caml_alloc_string left room for a '\0' at position n, + so the size passed to _vsnprintf is n+1. */ + va_start(args, format); + _vsnprintf(String_val(res), n + 1, format, args); + va_end(args); + } + return res; +#endif +} diff --git a/byterun/sys.c b/byterun/sys.c index 8b2551a00..cd49dd920 100644 --- a/byterun/sys.c +++ b/byterun/sys.c @@ -48,6 +48,7 @@ #include "signals.h" #include "stacks.h" #include "sys.h" +#include "gc_ctrl.h" static char * error_message(void) { @@ -93,6 +94,17 @@ CAMLexport void caml_sys_io_error(value arg) CAMLprim value caml_sys_exit(value retcode) { + if ((caml_verb_gc & 0x400) != 0) { + /* cf caml_gc_counters */ + double minwords = caml_stat_minor_words + + (double) Wsize_bsize (caml_young_end - caml_young_ptr); + double prowords = caml_stat_promoted_words; + double majwords = caml_stat_major_words + (double) caml_allocated_words; + double allocated_words = + minwords + majwords - prowords; + caml_gc_message(0x400, "## Total allocated words: %ld\n", (long)allocated_words); + } + #ifndef NATIVE_CODE caml_debugger(PROGRAM_EXIT); #endif @@ -125,7 +137,7 @@ CAMLprim value caml_sys_open(value path, value vflags, value vperm) int fd, flags, perm; char * p; - p = caml_stat_alloc_string(path); + p = caml_strdup(String_val(path)); flags = caml_convert_flag_list(vflags, sys_open_flags); perm = Int_val(vperm); /* open on a named FIFO can block (PR#1533) */ @@ -152,13 +164,21 @@ CAMLprim value caml_sys_close(value fd) CAMLprim value caml_sys_file_exists(value name) { +#ifdef _WIN32 + struct _stati64 st; +#else struct stat st; +#endif char * p; int ret; - p = caml_stat_alloc_string(name); + p = caml_strdup(String_val(name)); caml_enter_blocking_section(); +#ifdef _WIN32 + ret = _stati64(p, &st); +#else ret = stat(p, &st); +#endif caml_leave_blocking_section(); caml_stat_free(p); @@ -168,13 +188,21 @@ CAMLprim value caml_sys_file_exists(value name) CAMLprim value caml_sys_is_directory(value name) { CAMLparam1(name); +#ifdef _WIN32 + struct _stati64 st; +#else struct stat st; +#endif char * p; int ret; - p = caml_stat_alloc_string(name); + p = caml_strdup(String_val(name)); caml_enter_blocking_section(); +#ifdef _WIN32 + ret = _stati64(p, &st); +#else ret = stat(p, &st); +#endif caml_leave_blocking_section(); caml_stat_free(p); @@ -191,7 +219,7 @@ CAMLprim value caml_sys_remove(value name) CAMLparam1(name); char * p; int ret; - p = caml_stat_alloc_string(name); + p = caml_strdup(String_val(name)); caml_enter_blocking_section(); ret = unlink(p); caml_leave_blocking_section(); @@ -205,8 +233,8 @@ CAMLprim value caml_sys_rename(value oldname, value newname) char * p_old; char * p_new; int ret; - p_old = caml_stat_alloc_string(oldname); - p_new = caml_stat_alloc_string(newname); + p_old = caml_strdup(String_val(oldname)); + p_new = caml_strdup(String_val(newname)); caml_enter_blocking_section(); ret = rename(p_old, p_new); caml_leave_blocking_section(); @@ -222,7 +250,7 @@ CAMLprim value caml_sys_chdir(value dirname) CAMLparam1(dirname); char * p; int ret; - p = caml_stat_alloc_string(dirname); + p = caml_strdup(String_val(dirname)); caml_enter_blocking_section(); ret = chdir(p); caml_leave_blocking_section(); @@ -289,7 +317,7 @@ CAMLprim value caml_sys_system_command(value command) int status, retcode; char *buf; - buf = caml_stat_alloc_string(command); + buf = caml_strdup(String_val(command)); caml_enter_blocking_section (); status = system(buf); caml_leave_blocking_section (); @@ -430,7 +458,7 @@ CAMLprim value caml_sys_read_directory(value path) int ret; caml_ext_table_init(&tbl, 50); - p = caml_stat_alloc_string(path); + p = caml_strdup(String_val(path)); caml_enter_blocking_section(); ret = caml_read_directory(p, &tbl); caml_leave_blocking_section(); diff --git a/byterun/unix.c b/byterun/unix.c index 491b1e78f..be2c39b15 100644 --- a/byterun/unix.c +++ b/byterun/unix.c @@ -49,11 +49,10 @@ char * caml_decompose_path(struct ext_table * tbl, char * path) { char * p, * q; - int n; + size_t n; if (path == NULL) return NULL; - p = caml_stat_alloc(strlen(path) + 1); - strcpy(p, path); + p = caml_strdup(path); q = p; while (1) { for (n = 0; q[n] != 0 && q[n] != ':'; n++) /*nothing*/; @@ -68,7 +67,7 @@ char * caml_decompose_path(struct ext_table * tbl, char * path) char * caml_search_in_path(struct ext_table * path, char * name) { - char * p, * fullname; + char * p, * dir, * fullname; int i; struct stat st; @@ -76,18 +75,15 @@ char * caml_search_in_path(struct ext_table * path, char * name) if (*p == '/') goto not_found; } for (i = 0; i < path->size; i++) { - fullname = caml_stat_alloc(strlen((char *)(path->contents[i])) + - strlen(name) + 2); - strcpy(fullname, (char *)(path->contents[i])); - if (fullname[0] != 0) strcat(fullname, "/"); - strcat(fullname, name); - if (stat(fullname, &st) == 0 && S_ISREG(st.st_mode)) return fullname; + dir = path->contents[i]; + if (dir[0] == 0) dir = "."; /* empty path component = current dir */ + fullname = caml_strconcat(3, dir, "/", name); + if (stat(fullname, &st) == 0 && S_ISREG(st.st_mode)) + return fullname; caml_stat_free(fullname); } not_found: - fullname = caml_stat_alloc(strlen(name) + 1); - strcpy(fullname, name); - return fullname; + return caml_strdup(name); } #ifdef __CYGWIN32__ @@ -107,31 +103,28 @@ static int cygwin_file_exists(char * name) static char * cygwin_search_exe_in_path(struct ext_table * path, char * name) { - char * p, * fullname; + char * p, * dir, * fullname; int i; for (p = name; *p != 0; p++) { if (*p == '/' || *p == '\\') goto not_found; } for (i = 0; i < path->size; i++) { - fullname = caml_stat_alloc(strlen((char *)(path->contents[i])) + - strlen(name) + 6); - strcpy(fullname, (char *)(path->contents[i])); - strcat(fullname, "/"); - strcat(fullname, name); + dir = path->contents[i]; + if (dir[0] == 0) dir = "."; /* empty path component = current dir */ + fullname = caml_strconcat(3, dir, "/", name); if (cygwin_file_exists(fullname)) return fullname; - strcat(fullname, ".exe"); + caml_stat_free(fullname); + fullname = caml_strconcat(4, dir, "/", name, ".exe"); if (cygwin_file_exists(fullname)) return fullname; caml_stat_free(fullname); } not_found: - fullname = caml_stat_alloc(strlen(name) + 5); - strcpy(fullname, name); - if (cygwin_file_exists(fullname)) return fullname; - strcat(fullname, ".exe"); + if (cygwin_file_exists(name)) return caml_strdup(name); + fullname = caml_strconcat(2, name, ".exe"); if (cygwin_file_exists(fullname)) return fullname; - strcpy(fullname, name); - return fullname; + caml_stat_free(fullname); + return caml_strdup(name); } #endif @@ -156,10 +149,10 @@ char * caml_search_exe_in_path(char * name) char * caml_search_dll_in_path(struct ext_table * path, char * name) { - char * dllname = caml_stat_alloc(strlen(name) + 4); + char * dllname; char * res; - strcpy(dllname, name); - strcat(dllname, ".so"); + + dllname = caml_strconcat(2, name, ".so"); res = caml_search_in_path(path, dllname); caml_stat_free(dllname); return res; @@ -286,7 +279,6 @@ int caml_read_directory(char * dirname, struct ext_table * contents) #else struct direct * e; #endif - char * p; d = opendir(dirname); if (d == NULL) return -1; @@ -294,9 +286,7 @@ int caml_read_directory(char * dirname, struct ext_table * contents) e = readdir(d); if (e == NULL) break; if (strcmp(e->d_name, ".") == 0 || strcmp(e->d_name, "..") == 0) continue; - p = caml_stat_alloc(strlen(e->d_name) + 1); - strcpy(p, e->d_name); - caml_ext_table_add(contents, p); + caml_ext_table_add(contents, caml_strdup(e->d_name)); } closedir(d); return 0; diff --git a/byterun/win32.c b/byterun/win32.c index b2fd4b7e9..67e968321 100644 --- a/byterun/win32.c +++ b/byterun/win32.c @@ -16,6 +16,7 @@ #include <windows.h> #include <stdlib.h> #include <stdio.h> +#include <stdarg.h> #include <io.h> #include <fcntl.h> #include <sys/types.h> @@ -43,8 +44,7 @@ char * caml_decompose_path(struct ext_table * tbl, char * path) int n; if (path == NULL) return NULL; - p = caml_stat_alloc(strlen(path) + 1); - strcpy(p, path); + p = caml_strdup(path); q = p; while (1) { for (n = 0; q[n] != 0 && q[n] != ';'; n++) /*nothing*/; @@ -59,7 +59,7 @@ char * caml_decompose_path(struct ext_table * tbl, char * path) char * caml_search_in_path(struct ext_table * path, char * name) { - char * p, * fullname; + char * p, * dir, * fullname; int i; struct stat st; @@ -67,56 +67,55 @@ char * caml_search_in_path(struct ext_table * path, char * name) if (*p == '/' || *p == '\\') goto not_found; } for (i = 0; i < path->size; i++) { - fullname = caml_stat_alloc(strlen((char *)(path->contents[i])) + - strlen(name) + 2); - strcpy(fullname, (char *)(path->contents[i])); - strcat(fullname, "\\"); - strcat(fullname, name); + dir = path->contents[i]; + if (dir[0] == 0) continue; + /* not sure what empty path components mean under Windows */ + fullname = caml_strconcat(3, dir, "\\", name); caml_gc_message(0x100, "Searching %s\n", (uintnat) fullname); - if (stat(fullname, &st) == 0 && S_ISREG(st.st_mode)) return fullname; + if (stat(fullname, &st) == 0 && S_ISREG(st.st_mode)) + return fullname; caml_stat_free(fullname); } not_found: caml_gc_message(0x100, "%s not found in search path\n", (uintnat) name); - fullname = caml_stat_alloc(strlen(name) + 1); - strcpy(fullname, name); - return fullname; + return caml_strdup(name); } CAMLexport char * caml_search_exe_in_path(char * name) { char * fullname, * filepart; - DWORD pathlen, retcode; + size_t fullnamelen; + DWORD retcode; - pathlen = strlen(name) + 1; - if (pathlen < 256) pathlen = 256; + fullnamelen = strlen(name) + 1; + if (fullnamelen < 256) fullnamelen = 256; while (1) { - fullname = caml_stat_alloc(pathlen); + fullname = caml_stat_alloc(fullnamelen); retcode = SearchPath(NULL, /* use system search path */ name, ".exe", /* add .exe extension if needed */ - pathlen, + fullnamelen, fullname, &filepart); if (retcode == 0) { caml_gc_message(0x100, "%s not found in search path\n", (uintnat) name); - strcpy(fullname, name); - break; + caml_stat_free(fullname); + return caml_strdup(name); } - if (retcode < pathlen) break; + if (retcode < fullnamelen) + return fullname; caml_stat_free(fullname); - pathlen = retcode + 1; + fullnamelen = retcode + 1; } - return fullname; } char * caml_search_dll_in_path(struct ext_table * path, char * name) { - char * dllname = caml_stat_alloc(strlen(name) + 5); + char * dllname; char * res; - strcpy(dllname, name); - strcat(dllname, ".dll"); + + dllname = caml_strconcat(2, name, ".dll"); res = caml_search_in_path(path, dllname); caml_stat_free(dllname); return res; @@ -235,27 +234,27 @@ static void expand_argument(char * arg) static void expand_pattern(char * pat) { + char * prefix, * p, * name; int handle; struct _finddata_t ffblk; - int preflen; + size_t i; handle = _findfirst(pat, &ffblk); if (handle == -1) { store_argument(pat); /* a la Bourne shell */ return; } - for (preflen = strlen(pat); preflen > 0; preflen--) { - char c = pat[preflen - 1]; - if (c == '\\' || c == '/' || c == ':') break; + prefix = caml_strdup(pat); + for (i = strlen(prefix); i > 0; i--) { + char c = prefix[i - 1]; + if (c == '\\' || c == '/' || c == ':') { prefix[i] = 0; break; } } do { - char * name = malloc(preflen + strlen(ffblk.name) + 1); - if (name == NULL) out_of_memory(); - memcpy(name, pat, preflen); - strcpy(name + preflen, ffblk.name); + name = caml_strconcat(2, prefix, ffblk.name); store_argument(name); } while (_findnext(handle, &ffblk) != -1); _findclose(handle); + caml_stat_free(prefix); } @@ -278,7 +277,7 @@ CAMLexport void caml_expand_command_line(int * argcp, char *** argvp) int caml_read_directory(char * dirname, struct ext_table * contents) { - int dirnamelen; + size_t dirnamelen; char * template; #if _MSC_VER <= 1200 int h; @@ -286,28 +285,27 @@ int caml_read_directory(char * dirname, struct ext_table * contents) intptr_t h; #endif struct _finddata_t fileinfo; - char * p; dirnamelen = strlen(dirname); - template = caml_stat_alloc(dirnamelen + 5); - strcpy(template, dirname); - switch (dirname[dirnamelen - 1]) { - case '/': case '\\': case ':': - strcat(template, "*.*"); break; - default: - strcat(template, "\\*.*"); - } + if (dirnamelen > 0 && + (dirname[dirnamelen - 1] == '/' + || dirname[dirnamelen - 1] == '\\' + || dirname[dirnamelen - 1] == ':')) + template = caml_strconcat(2, dirname, "*.*"); + else + template = caml_strconcat(2, dirname, "\\*.*"); h = _findfirst(template, &fileinfo); - caml_stat_free(template); - if (h == -1) return errno == ENOENT ? 0 : -1; + if (h == -1) { + caml_stat_free(template); + return errno == ENOENT ? 0 : -1; + } do { if (strcmp(fileinfo.name, ".") != 0 && strcmp(fileinfo.name, "..") != 0) { - p = caml_stat_alloc(strlen(fileinfo.name) + 1); - strcpy(p, fileinfo.name); - caml_ext_table_add(contents, p); + caml_ext_table_add(contents, caml_strdup(fileinfo.name)); } } while (_findnext(h, &fileinfo) == 0); _findclose(h); + caml_stat_free(template); return 0; } @@ -514,3 +512,30 @@ int caml_executable_name(char * name, int name_len) if (0 == ret || ret >= name_len) return -1; return 0; } + +/* snprintf emulation */ + +int caml_snprintf(char * buf, size_t size, const char * format, ...) +{ + int len; + va_list args; + + if (size > 0) { + va_start(args, format); + len = _vsnprintf(buf, size, format, args); + va_end(args); + if (len >= 0 && len < size) { + /* [len] characters were stored in [buf], + a null-terminator was appended. */ + return len; + } + /* [size] characters were stored in [buf], without null termination. + Put a null terminator, truncating the output. */ + buf[size - 1] = 0; + } + /* Compute the actual length of output, excluding null terminator */ + va_start(args, format); + len = _vscprintf(format, args); + va_end(args); + return len; +} diff --git a/config/Makefile.mingw b/config/Makefile.mingw index 63030dd1f..c20498036 100644 --- a/config/Makefile.mingw +++ b/config/Makefile.mingw @@ -109,8 +109,8 @@ NATIVECCLIBS=-lws2_32 CPP=$(BYTECC) -E ### Flexlink -FLEXLINK=flexlink -chain mingw -stack 16777216 -FLEXDIR=$(shell $(FLEXLINK) -where) +FLEXLINK=flexlink -chain mingw -stack 16777216 -link -static-libgcc +FLEXDIR:=$(shell $(FLEXLINK) -where) IFLEXDIR=-I"$(FLEXDIR)" MKDLL=$(FLEXLINK) MKEXE=$(FLEXLINK) -exe diff --git a/config/Makefile.mingw64 b/config/Makefile.mingw64 index 44784b68a..0a3bdfbd0 100644 --- a/config/Makefile.mingw64 +++ b/config/Makefile.mingw64 @@ -110,7 +110,7 @@ CPP=$(BYTECC) -E ### Flexlink FLEXLINK=flexlink -chain mingw64 -stack 33554432 -FLEXDIR=$(shell $(FLEXLINK) -where) +FLEXDIR:=$(shell $(FLEXLINK) -where) IFLEXDIR=-I"$(FLEXDIR)" MKDLL=$(FLEXLINK) MKEXE=$(FLEXLINK) -exe diff --git a/config/Makefile.msvc b/config/Makefile.msvc index 3ab6c6ebf..abe37bf32 100644 --- a/config/Makefile.msvc +++ b/config/Makefile.msvc @@ -63,7 +63,7 @@ SUPPORTS_SHARED_LIBRARIES=true SHAREDCCCOMPOPTS= NATIVECCPROFOPTS= NATIVECCRPATH= -ASM=ml /nologo /coff /Cp /c /Fo +ASM=ml -nologo -coff -Cp -c -Fo ASPP= ASPPPROFFLAGS= PROFILING=noprof @@ -81,35 +81,35 @@ GRAPHLIB=win32graph ########## Configuration for the bytecode compiler ### Which C compiler to use for the bytecode interpreter. -BYTECC=cl /nologo -D_CRT_SECURE_NO_DEPRECATE +BYTECC=cl -nologo -D_CRT_SECURE_NO_DEPRECATE ### Additional compile-time options for $(BYTECC). (For static linking.) -BYTECCCOMPOPTS=/Ox /MD +BYTECCCOMPOPTS=-O2 -Gy- -MD ### Additional link-time options for $(BYTECC). (For static linking.) BYTECCLINKOPTS= ### Additional compile-time options for $(BYTECC). (For building a DLL.) -DLLCCCOMPOPTS=/Ox /MD +DLLCCCOMPOPTS=-O2 -Gy- -MD ### Libraries needed BYTECCLIBS=advapi32.lib ws2_32.lib NATIVECCLIBS=advapi32.lib ws2_32.lib ### How to invoke the C preprocessor -CPP=cl /nologo /EP +CPP=cl -nologo -EP ### Flexlink FLEXLINK=flexlink -merge-manifest -stack 16777216 -FLEXDIR=$(shell $(FLEXLINK) -where) +FLEXDIR:=$(shell $(FLEXLINK) -where) IFLEXDIR=-I"$(FLEXDIR)" MKDLL=$(FLEXLINK) MKEXE=$(FLEXLINK) -exe MKMAINDLL=$(FLEXLINK) -maindll ### How to build a static library -MKLIB=link /lib /nologo /out:$(1) $(2) -#ml let mklib out files opts = Printf.sprintf "link /lib /nologo /out:%s %s %s" out opts files;; +MKLIB=link -lib -nologo -out:$(1) $(2) +#ml let mklib out files opts = Printf.sprintf "link -lib -nologo -out:%s %s %s" out opts files;; MKSHAREDLIBRPATH= ### Canonicalize the name of a system library @@ -135,16 +135,16 @@ MODEL=default SYSTEM=win32 ### Which C compiler to use for the native-code compiler. -NATIVECC=cl /nologo -D_CRT_SECURE_NO_DEPRECATE +NATIVECC=cl -nologo -D_CRT_SECURE_NO_DEPRECATE ### Additional compile-time options for $(NATIVECC). -NATIVECCCOMPOPTS=/Ox /MD +NATIVECCCOMPOPTS=-O2 -Gy- -MD ### Additional link-time options for $(NATIVECC) NATIVECCLINKOPTS= ### Build partially-linked object file -PACKLD=link /lib /nologo /out:# there must be no space after this '/out:' +PACKLD=link -lib -nologo -out:# there must be no space after this '-out:' ### Clear this to disable compiling ocamldebug WITH_DEBUGGER=ocamldebugger diff --git a/config/Makefile.msvc64 b/config/Makefile.msvc64 index 8437cf4bd..c33ba1fb7 100644 --- a/config/Makefile.msvc64 +++ b/config/Makefile.msvc64 @@ -63,7 +63,7 @@ SUPPORTS_SHARED_LIBRARIES=true SHAREDCCCOMPOPTS= NATIVECCPROFOPTS= NATIVECCRPATH= -ASM=ml64 /nologo /Cp /c /Fo +ASM=ml64 -nologo -Cp -c -Fo ASPP= ASPPPROFFLAGS= PROFILING=noprof @@ -80,19 +80,19 @@ GRAPHLIB=win32graph ########## Configuration for the bytecode compiler ### Which C compiler to use for the bytecode interpreter. -BYTECC=cl /nologo -D_CRT_SECURE_NO_DEPRECATE +BYTECC=cl -nologo -D_CRT_SECURE_NO_DEPRECATE ### Additional compile-time options for $(BYTECC). (For static linking.) -BYTECCCOMPOPTS=/Ox /MD +BYTECCCOMPOPTS=-O2 -Gy- -MD ### Additional compile-time options for $(BYTECC). (For debug version.) -BYTECCDBGCOMPOPTS=-DDEBUG /Zi /W3 /Wp64 +BYTECCDBGCOMPOPTS=-DDEBUG -Zi -W3 -Wp64 ### Additional link-time options for $(BYTECC). (For static linking.) BYTECCLINKOPTS= ### Additional compile-time options for $(BYTECC). (For building a DLL.) -DLLCCCOMPOPTS=/Ox /MD +DLLCCCOMPOPTS=-O2 -Gy- -MD ### Libraries needed #EXTRALIBS=bufferoverflowu.lib # for the old PSDK compiler only @@ -101,19 +101,19 @@ BYTECCLIBS=advapi32.lib ws2_32.lib $(EXTRALIBS) NATIVECCLIBS=advapi32.lib ws2_32.lib $(EXTRALIBS) ### How to invoke the C preprocessor -CPP=cl /nologo /EP +CPP=cl -nologo -EP ### Flexlink FLEXLINK=flexlink -x64 -merge-manifest -stack 33554432 -FLEXDIR=$(shell $(FLEXLINK) -where) +FLEXDIR:=$(shell $(FLEXLINK) -where) IFLEXDIR=-I"$(FLEXDIR)" MKDLL=$(FLEXLINK) MKEXE=$(FLEXLINK) -exe MKMAINDLL=$(FLEXLINK) -maindll ### How to build a static library -MKLIB=link /lib /nologo /machine:AMD64 /out:$(1) $(2) -#ml let mklib out files opts = Printf.sprintf "link /lib /nologo /machine:AMD64 /out:%s %s %s" out opts files;; +MKLIB=link -lib -nologo -machine:AMD64 /out:$(1) $(2) +#ml let mklib out files opts = Printf.sprintf "link -lib -nologo -machine:AMD64 -out:%s %s %s" out opts files;; MKSHAREDLIBRPATH= ### Canonicalize the name of a system library @@ -139,16 +139,16 @@ MODEL=default SYSTEM=win64 ### Which C compiler to use for the native-code compiler. -NATIVECC=cl /nologo +NATIVECC=cl -nologo ### Additional compile-time options for $(NATIVECC). -NATIVECCCOMPOPTS=/Ox /MD +NATIVECCCOMPOPTS=-O2 -Gy- -MD ### Additional link-time options for $(NATIVECC) NATIVECCLINKOPTS= ### Build partially-linked object file -PACKLD=link /lib /nologo /machine:AMD64 /out:# must have no space after '/out:' +PACKLD=link -lib -nologo -machine:AMD64 -out:# must have no space after '-out:' ### Clear this to disable compiling ocamldebug WITH_DEBUGGER=ocamldebugger diff --git a/config/auto-aux/int64align.c b/config/auto-aux/int64align.c index 9ae8a5bc7..c1439869f 100644 --- a/config/auto-aux/int64align.c +++ b/config/auto-aux/int64align.c @@ -16,9 +16,19 @@ #include <setjmp.h> #include "m.h" -ARCH_INT64_TYPE foo; +#if defined(ARCH_INT64_TYPE) +typedef ARCH_INT64_TYPE int64_t; +#elif SIZEOF_LONG == 8 +typedef long int64_t; +#elif SIZEOF_LONGLONG == 8 +typedef long long int64_t; +#else +#error "No 64-bit integer type available" +#endif + +int64_t foo; -void access_int64(ARCH_INT64_TYPE *p) +void access_int64(int64_t *p) { foo = *p; } @@ -39,8 +49,8 @@ int main(void) signal(SIGBUS, sig_handler); #endif if(setjmp(failure) == 0) { - access_int64((ARCH_INT64_TYPE *) n); - access_int64((ARCH_INT64_TYPE *) (n+1)); + access_int64((int64_t *) n); + access_int64((int64_t *) (n+1)); res = 0; } else { res = 1; diff --git a/config/auto-aux/sizes.c b/config/auto-aux/sizes.c index 2700729d4..daa9615d1 100644 --- a/config/auto-aux/sizes.c +++ b/config/auto-aux/sizes.c @@ -15,7 +15,8 @@ int main(int argc, char **argv) { - printf("%d %d %d %d\n", - sizeof(int), sizeof(long), sizeof(long *), sizeof(short)); + printf("%d %d %d %d %d\n", + sizeof(int), sizeof(long), sizeof(long *), sizeof(short), + sizeof(long long)); return 0; } diff --git a/config/s-nt.h b/config/s-nt.h index 6df440b8a..603b05054 100644 --- a/config/s-nt.h +++ b/config/s-nt.h @@ -15,6 +15,9 @@ #define OCAML_OS_TYPE "Win32" +#ifdef __MINGW32__ +#define HAS_STDINT_H +#endif #undef BSD_SIGNALS #define HAS_STRERROR #define HAS_SOCKETS @@ -43,6 +43,7 @@ with_debugger=ocamldebugger with_ocamldoc=ocamldoc with_ocamlbuild=ocamlbuild with_frame_pointers=false +no_naked_pointers=false TOOLPREF="" with_cfi=true @@ -150,6 +151,8 @@ while : ; do with_ocamlbuild="";; -with-frame-pointers|--with-frame-pointers) with_frame_pointers=true;; + -no-naked-pointers|--no-naked-pointers) + no_naked_pointers=true;; -no-cfi|--no-cfi) with_cfi=false;; *) err "Unknown option \"$1\".";; @@ -322,7 +325,7 @@ case "$bytecc,$target" in bytecccompopts="-fno-defer-pop $gcc_warnings -DSHRINKED_GNUC" mathlib="";; *,*-*-darwin*) - bytecccompopts="-fno-defer-pop $gcc_warnings" + bytecccompopts="$gcc_warnings" mathlib="" mkexe="$mkexe -Wl,-no_compact_unwind" # Tell gcc that we can use 32-bit code addresses for threaded code @@ -470,38 +473,39 @@ fi echo "CAMLRUN=$CAMLRUN" >> Makefile # Check the sizes of data types -# OCaml needs a 32 or 64bit architectue and a 32-bit integer type. +# OCaml needs a 32 or 64 bit architecture, a 32-bit integer type and +# a 64-bit integer type inf "Checking the sizes of integers and pointers..." ret=`sh ./runtest sizes.c` +# $1 = sizeof(int) +# $2 = sizeof(long) +# $3 = sizeof(pointers) +# $4 = sizeof(short) +# $5 = sizeof(long long) if test "$?" -eq 0; then set $ret - case "$2,$3" in - 4,4) inf "OK, this is a regular 32 bit architecture." - echo "#undef ARCH_SIXTYFOUR" >> m.h - arch64=false;; - *,8) inf "Wow! A 64 bit architecture!" - echo "#define ARCH_SIXTYFOUR" >> m.h - arch64=true - if test $1 != 4 && test $2 != 4 && test $4 != 4; then - err "Sorry, we can't find a 32-bit integer type\n" \ - "(sizeof(short) = $4, sizeof(int) = $1, sizeof(long) = $2)\n" \ - "OCaml won't run on this architecture." - fi;; - *,*) err "This architecture seems to be neither 32 bits nor 64 bits.\n" \ - "OCaml won't run on this architecture.";; + case "$3" in + 4) inf "OK, this is a regular 32 bit architecture." + echo "#undef ARCH_SIXTYFOUR" >> m.h + arch64=false;; + 8) inf "Wow! A 64 bit architecture!" + echo "#define ARCH_SIXTYFOUR" >> m.h + arch64=true;; + *) err "This architecture seems to be neither 32 bits nor 64 bits.\n" \ + "OCaml won't run on this architecture.";; esac else # For cross-compilation, runtest always fails: add special handling. case "$target" in i686-*-mingw*) inf "OK, this is a regular 32 bit architecture." echo "#undef ARCH_SIXTYFOUR" >> m.h - set 4 4 4 2 + set 4 4 4 2 8 arch64=false;; x86_64-*-mingw*) inf "Wow! A 64 bit architecture!" echo "#define ARCH_SIXTYFOUR" >> m.h - set 4 4 8 2 + set 4 4 8 2 8 arch64=true;; *) err "Since datatype sizes cannot be guessed when cross-compiling,\n" \ "a hardcoded list is used but your architecture isn't known yet.\n" \ @@ -510,56 +514,23 @@ else esac fi +if test $1 != 4 && test $2 != 4 && test $4 != 4; then + err "Sorry, we can't find a 32-bit integer type\n" \ + "(sizeof(short) = $4, sizeof(int) = $1, sizeof(long) = $2)\n" \ + "OCaml won't run on this architecture." +fi + +if test $2 != 8 && test $5 != 8; then + err "Sorry, we can't find a 64-bit integer type\n" \ + "(sizeof(long) = $2, sizeof(long long) = $5)\n" \ + "OCaml won't run on this architecture." +fi + echo "#define SIZEOF_INT $1" >> m.h echo "#define SIZEOF_LONG $2" >> m.h echo "#define SIZEOF_PTR $3" >> m.h echo "#define SIZEOF_SHORT $4" >> m.h - -if test $2 = 8; then - echo "#define ARCH_INT64_TYPE long" >> m.h - echo "#define ARCH_UINT64_TYPE unsigned long" >> m.h - echo '#define ARCH_INT64_PRINTF_FORMAT "l"' >> m.h - int64_native=true -else - sh ./runtest longlong.c - case $? in - 0) inf "64-bit \"long long\" integer type found (printf with \"%ll\")." - echo "#define ARCH_INT64_TYPE long long" >> m.h - echo "#define ARCH_UINT64_TYPE unsigned long long" >> m.h - echo '#define ARCH_INT64_PRINTF_FORMAT "ll"' >> m.h - int64_native=true;; - 1) inf "64-bit \"long long\" integer type found (printf with \"%q\")." - echo "#define ARCH_INT64_TYPE long long" >> m.h - echo "#define ARCH_UINT64_TYPE unsigned long long" >> m.h - echo '#define ARCH_INT64_PRINTF_FORMAT "q"' >> m.h - int64_native=true;; - 2) inf "64-bit \"long long\" integer type found (but no printf)." - echo "#define ARCH_INT64_TYPE long long" >> m.h - echo "#define ARCH_UINT64_TYPE unsigned long long" >> m.h - echo '#undef ARCH_INT64_PRINTF_FORMAT' >> m.h - int64_native=true;; - *) - case "$target" in - *-*-mingw*) - inf "No suitable 64-bit integer type found, will use software emulation." - echo "#define ARCH_INT64_TYPE long long" >> m.h - echo "#define ARCH_UINT64_TYPE unsigned long long" >> m.h - echo '#define ARCH_INT64_PRINTF_FORMAT "I64"' >> m.h - int64_native=true;; - *) - wrn "No suitable 64-bit integer type found, will use software emulation." - echo "#undef ARCH_INT64_TYPE" >> m.h - echo "#undef ARCH_UINT64_TYPE" >> m.h - echo '#undef ARCH_INT64_PRINTF_FORMAT' >> m.h - int64_native=false;; - esac;; - esac -fi - -if test $3 = 8 && test $int64_native = false; then - err "This architecture has 64-bit pointers but no 64-bit integer type.\n" \ - "OCaml won't run on this architecture." -fi +echo "#define SIZEOF_LONGLONG $5" >> m.h # Determine endianness @@ -617,55 +588,31 @@ case "$target" in esac;; esac -if $int64_native; then - case "$target" in - # PR#5088: autodetection is unreliable on ARM. PR#5280: also on MIPS. - sparc*-*-*|hppa*-*-*|arm*-*-*|mips*-*-*) - if test $2 = 8; then - inf "64-bit integers can be word-aligned." - echo "#undef ARCH_ALIGN_INT64" >> m.h - else - inf "64-bit integers must be doubleword-aligned." - echo "#define ARCH_ALIGN_INT64" >> m.h - fi;; - *-*-mingw*) true;; # Nothing is in config/m-nt.h so don't add anything. - *) - sh ./runtest int64align.c - case $? in - 0) inf "64-bit integers can be word-aligned." - echo "#undef ARCH_ALIGN_INT64" >> m.h;; - 1) inf "64-bit integers must be doubleword-aligned." - echo "#define ARCH_ALIGN_INT64" >> m.h;; - *) wrn "Something went wrong during alignment determination for\n" \ - "64-bit integers. I'm going to assume this architecture has\n" \ - "alignment constraints. That's a safe bet: OCaml will work\n" \ - "even if this architecture has actually no alignment\n" \ - "constraints." \ - echo "#define ARCH_ALIGN_INT64" >> m.h;; - esac - esac -else - echo "#undef ARCH_ALIGN_INT64" >> m.h -fi - -# Check semantics of division and modulus - -sh ./runtest divmod.c -case $? in - 0) inf "Native division and modulus have round-towards-zero semantics," \ - "will use them." - echo "#undef NONSTANDARD_DIV_MOD" >> m.h;; - 1) inf "Native division and modulus do not have round-towards-zero" - "semantics, will use software emulation." - echo "#define NONSTANDARD_DIV_MOD" >> m.h;; - *) case $target in - *-*-mingw*) inf "Native division and modulus have round-towards-zero" \ - "semantics, will use them." - echo "#undef NONSTANDARD_DIV_MOD" >> m.h;; - *) wrn "Something went wrong while checking native division and modulus"\ - "please report it at http://http://caml.inria.fr/mantis/" - echo "#define NONSTANDARD_DIV_MOD" >> m.h;; - esac;; +case "$target" in + # PR#5088: autodetection is unreliable on ARM. PR#5280: also on MIPS. + sparc*-*-*|hppa*-*-*|arm*-*-*|mips*-*-*) + if test $2 = 8; then + inf "64-bit integers can be word-aligned." + echo "#undef ARCH_ALIGN_INT64" >> m.h + else + inf "64-bit integers must be doubleword-aligned." + echo "#define ARCH_ALIGN_INT64" >> m.h + fi;; + *-*-mingw*) true;; # Nothing is in config/m-nt.h so don't add anything. + *) + sh ./runtest int64align.c + case $? in + 0) inf "64-bit integers can be word-aligned." + echo "#undef ARCH_ALIGN_INT64" >> m.h;; + 1) inf "64-bit integers must be doubleword-aligned." + echo "#define ARCH_ALIGN_INT64" >> m.h;; + *) wrn "Something went wrong during alignment determination for\n" \ + "64-bit integers. I'm going to assume this architecture has\n" \ + "alignment constraints. That's a safe bet: OCaml will work\n" \ + "even if this architecture has actually no alignment\n" \ + "constraints." \ + echo "#define ARCH_ALIGN_INT64" >> m.h;; + esac esac # Shared library support @@ -793,14 +740,15 @@ if test $with_sharedlibs = "yes"; then sparc*-*-linux*) natdynlink=true;; i686-*-kfreebsd*) natdynlink=true;; x86_64-*-kfreebsd*) natdynlink=true;; - i[345]86-*-freebsd*) natdynlink=true;; + i[3456]86-*-freebsd*) natdynlink=true;; x86_64-*-freebsd*) natdynlink=true;; - i[345]86-*-openbsd*) natdynlink=true;; + i[3456]86-*-openbsd*) natdynlink=true;; x86_64-*-openbsd*) natdynlink=true;; - i[345]86-*-netbsd*) natdynlink=true;; + i[3456]86-*-netbsd*) natdynlink=true;; x86_64-*-netbsd*) natdynlink=true;; i386-*-gnu0.3) natdynlink=true;; arm*-*-linux*) natdynlink=true;; + arm*-*-freebsd*) natdynlink=true;; aarch64-*-linux*) natdynlink=true;; esac fi @@ -851,9 +799,12 @@ case "$target" in armv7*-*-linux-gnueabi) arch=arm; model=armv7; system=linux_eabi;; armv6t2*-*-linux-gnueabi) arch=arm; model=armv6t2; system=linux_eabi;; armv6*-*-linux-gnueabi) arch=arm; model=armv6; system=linux_eabi;; + armv6*-*-freebsd*) arch=arm; model=armv6; system=freebsd;; armv5te*-*-linux-gnueabi) arch=arm; model=armv5te; system=linux_eabi;; armv5*-*-linux-gnueabi) arch=arm; model=armv5; system=linux_eabi;; arm*-*-linux-gnueabi) arch=arm; system=linux_eabi;; + arm*-*-openbsd*) arch=arm; system=bsd;; + zaurus*-*-openbsd*) arch=arm; system=bsd;; x86_64-*-linux*) arch=amd64; system=linux;; x86_64-*-gnu*) arch=amd64; system=gnu;; x86_64-*-freebsd*) arch=amd64; system=freebsd;; @@ -904,7 +855,7 @@ esac asppprofflags='-DPROFILING' case "$arch,$system" in - amd64,macosx) if ./searchpath clang; then + amd64,macosx) if sh ./searchpath clang; then as='clang -arch x86_64 -c' aspp='clang -arch x86_64 -c' else @@ -922,8 +873,12 @@ case "$arch,$system" in sparc,solaris) as="${TOOLPREF}as" case "$cc" in *gcc*) aspp="${TOOLPREF}gcc -c";; - *) aspp="${TOOLPREF}as -P";; + *) aspp="${TOOLPREF}as -P";; esac;; + arm,freebsd) as="${TOOLPREF}cc -c" + aspp="${TOOLPREF}cc -c";; + *,freebsd) as="${TOOLPREF}as" + aspp="${TOOLPREF}cc -c";; amd64,*|arm,*|arm64,*|i386,*|power,bsd*|sparc,*) as="${TOOLPREF}as" aspp="${TOOLPREF}gcc -c";; @@ -939,12 +894,16 @@ case "$arch,$system" in i386,bsd_elf) profiling='prof';; amd64,macosx) profiling='prof';; i386,macosx) profiling='prof';; + sparc,bsd) profiling='prof';; sparc,solaris) profiling='prof' case "$nativecc" in gcc*) ;; *) cc_profile='-xpg';; esac;; amd64,linux) profiling='prof';; + amd64,openbsd) profiling='prof';; amd64,gnu) profiling='prof';; arm,linux*) profiling='prof';; + power,elf) profiling='prof';; + power,bsd*) profiling='prof';; *) profiling='noprof';; esac @@ -1100,6 +1059,11 @@ if sh ./hasgot -i sys/types.h -i sys/socket.h -i netinet/in.h \ echo "#define HAS_IPV6" >> s.h fi +if sh ./hasgot -i stdint.h; then + inf "stdint.h found." + echo "#define HAS_STDINT_H" >> s.h +fi + if sh ./hasgot -i unistd.h; then inf "unistd.h found." echo "#define HAS_UNISTD" >> s.h @@ -1325,6 +1289,11 @@ if test $nargs != "none"; then echo "#define HAS_GETHOSTBYADDR_R $nargs" >> s.h fi +if sh ./hasgot mkstemp; then + inf "mkstemp() found" + echo "#define HAS_MKSTEMP" >> s.h +fi + # Determine if the debugger is supported if test -n "$with_debugger"; then @@ -1379,7 +1348,7 @@ if test "$pthread_wanted" = "yes"; then *) pthread_link="-lpthread" pthread_caml_link="-cclib -lpthread";; esac - if ./hasgot -i pthread.h $pthread_link pthread_self; then + if sh ./hasgot -i pthread.h $pthread_link pthread_self; then inf "POSIX threads library supported." systhread_support=true otherlibraries="$otherlibraries systhreads" @@ -1569,7 +1538,7 @@ if test "x11_include" != "not found"; then if test "$x11_include" = "-I/usr/include"; then x11_include="" fi - if ./hasgot $x11_include $x11_link -i X11/Xlib.h XrmInitialize; then + if sh ./hasgot $x11_include $x11_link -i X11/Xlib.h XrmInitialize; then inf "X11 works" else wrn "Cannot compile X11 program." @@ -1597,8 +1566,8 @@ echo "X11_LINK=$x11_link" >> Makefile # Look for BFD library -if ./hasgot -i bfd.h && \ - ./hasgot -lbfd -ldl -liberty -lz bfd_openr; then +if sh ./hasgot -DPACKAGE=ocaml -i bfd.h && \ + sh ./hasgot -DPACKAGE=ocaml -lbfd -ldl -liberty -lz bfd_openr; then inf "BFD library found." echo "#define HAS_LIBBFD" >> s.h echo "LIBBFD_LINK=-lbfd -ldl -liberty -lz" >> Makefile @@ -1636,6 +1605,9 @@ if test "$with_frame_pointers" = "true"; then fi +if $no_naked_pointers; then + echo "#define NO_NAKED_POINTERS" >> m.h +fi # Final twiddling of compiler options to work around known bugs @@ -1772,7 +1744,11 @@ else else inf " with frame pointers....... no" fi - echo " native dynlink ........... $natdynlink" + if $no_naked_pointers; then + inf " naked pointers forbidden.. yes" + else + inf " naked pointers forbidden.. no" + fi inf " native dynlink ........... $natdynlink" if test "$profiling" = "prof"; then inf " profiling with gprof ..... supported" diff --git a/debugger/.depend b/debugger/.depend index 13de8ede1..b62541619 100644 --- a/debugger/.depend +++ b/debugger/.depend @@ -164,11 +164,13 @@ program_loading.cmx : unix_tools.cmx $(UNIXDIR)/unix.cmx \ program_management.cmo : unix_tools.cmi $(UNIXDIR)/unix.cmi \ time_travel.cmi symbols.cmi question.cmi program_loading.cmi \ primitives.cmi parameters.cmi int64ops.cmi input_handling.cmi history.cmi \ - debugger_config.cmi breakpoints.cmi program_management.cmi + ../typing/envaux.cmi debugger_config.cmi ../utils/config.cmi \ + breakpoints.cmi program_management.cmi program_management.cmx : unix_tools.cmx $(UNIXDIR)/unix.cmx \ time_travel.cmx symbols.cmx question.cmx program_loading.cmx \ primitives.cmx parameters.cmx int64ops.cmx input_handling.cmx history.cmx \ - debugger_config.cmx breakpoints.cmx program_management.cmi + ../typing/envaux.cmx debugger_config.cmx ../utils/config.cmx \ + breakpoints.cmx program_management.cmi question.cmo : primitives.cmi lexer.cmi input_handling.cmi question.cmi question.cmx : primitives.cmx lexer.cmx input_handling.cmx question.cmi show_information.cmo : symbols.cmi source.cmi show_source.cmi printval.cmi \ diff --git a/debugger/Makefile.shared b/debugger/Makefile.shared index d85419eb0..fed1d26da 100644 --- a/debugger/Makefile.shared +++ b/debugger/Makefile.shared @@ -12,8 +12,9 @@ include ../config/Makefile -CAMLC=../ocamlcomp.sh -COMPFLAGS=-warn-error A $(INCLUDES) +ROOTDIR=.. +CAMLC=$(ROOTDIR)/boot/ocamlrun $(ROOTDIR)/ocamlc -nostdlib -I $(ROOTDIR)/stdlib +COMPFLAGS=-warn-error A -safe-string $(INCLUDES) LINKFLAGS=-linkall -I $(UNIXDIR) CAMLYACC=../boot/ocamlyacc YACCFLAGS= @@ -21,6 +22,8 @@ CAMLLEX=../boot/ocamlrun ../boot/ocamllex CAMLDEP=../boot/ocamlrun ../tools/ocamldep DEPFLAGS=$(INCLUDES) +INSTALL_BINDIR=$(DESTDIR)$(BINDIR) + INCLUDES=\ -I ../utils -I ../parsing -I ../typing -I ../bytecomp -I ../toplevel \ -I $(UNIXDIR) @@ -83,7 +86,7 @@ ocamldebug$(EXE): $(OBJS) $(OTHEROBJS) $(CAMLC) $(LINKFLAGS) -o ocamldebug$(EXE) -linkall $(OTHEROBJS) $(OBJS) install: - cp ocamldebug$(EXE) $(BINDIR)/ocamldebug$(EXE) + cp ocamldebug$(EXE) $(INSTALL_BINDIR)/ocamldebug$(EXE) clean:: rm -f ocamldebug$(EXE) diff --git a/debugger/debugcom.ml b/debugger/debugcom.ml index 72702da16..ac91df799 100644 --- a/debugger/debugcom.ml +++ b/debugger/debugcom.ml @@ -187,10 +187,10 @@ let set_trap_barrier pos = let value_size = if 1 lsl 31 = 0 then 4 else 8 let input_remote_value ic = - Misc.input_bytes ic value_size + really_input_string ic value_size let output_remote_value ic v = - output ic v 0 value_size + output_substring ic v 0 value_size exception Marshalling_error @@ -244,7 +244,7 @@ module Remote_value = if input_byte !conn.io_in = 0 then Remote(input_remote_value !conn.io_in) else begin - let buf = Misc.input_bytes !conn.io_in 8 in + let buf = really_input_string !conn.io_in 8 in let floatbuf = float n (* force allocation of a new float *) in String.unsafe_blit buf 0 (Obj.magic floatbuf) 0 8; Local(Obj.repr floatbuf) diff --git a/debugger/input_handling.mli b/debugger/input_handling.mli index 749687ce3..66db47f15 100644 --- a/debugger/input_handling.mli +++ b/debugger/input_handling.mli @@ -49,7 +49,7 @@ val current_prompt : string ref (* Where the user input come from. *) val user_channel : io_channel ref -val read_user_input : string -> int -> int +val read_user_input : bytes -> int -> int (* Stop reading user input. *) val stop_user_input : unit -> unit diff --git a/debugger/main.ml b/debugger/main.ml index 52c1ed995..60cd96a89 100644 --- a/debugger/main.ml +++ b/debugger/main.ml @@ -193,7 +193,7 @@ let main () = (Unix.string_of_inet_addr Unix.inet_addr_loopback)^ ":"^ (string_of_int (10000 + ((Unix.getpid ()) mod 10000))) - | _ -> Filename.concat Filename.temp_dir_name + | _ -> Filename.concat (Filename.get_temp_dir_name ()) ("camldebug" ^ (string_of_int (Unix.getpid ()))) ); begin try diff --git a/debugger/program_loading.ml b/debugger/program_loading.ml index b2d472a7d..1ebbd1e82 100644 --- a/debugger/program_loading.ml +++ b/debugger/program_loading.ml @@ -41,10 +41,35 @@ let get_unix_environment () = String.concat "" (List.map f !Debugger_config.environment) ;; +(* Notes: + 1. This quoting is not the same as [Filename.quote] because the "set" + command is a shell built-in and its quoting rules are different + from regular commands. + 2. Microsoft's documentation omits the double-quote from the list + of characters that need quoting, but that is a mistake (unquoted + quotes are included in the value, but they alter the quoting of + characters between them). + Reference: http://msdn.microsoft.com/en-us/library/bb490954.aspx + *) +let quote_for_windows_shell s = + let b = Buffer.create (20 + String.length s) in + for i = 0 to String.length s - 1 do + begin match s.[i] with + | '<' | '>' | '|' | '&' | '^' | '\"' -> + Buffer.add_char b '^'; + | _ -> () + end; + Buffer.add_char b s.[i]; + done; + Buffer.contents b +;; + (* Returns a command line prefix to set environment for the debuggee *) let get_win32_environment () = (* Note: no space before the & or Windows will add it to the value *) - let f (vname, vvalue) = Printf.sprintf "set %s=%s&" vname vvalue in + let f (vname, vvalue) = + Printf.sprintf "set %s=%s&" vname (quote_for_windows_shell vvalue) + in String.concat "" (List.map f !Debugger_config.environment) (* A generic function for launching the program *) diff --git a/debugger/program_management.ml b/debugger/program_management.ml index c7438b398..48118573e 100644 --- a/debugger/program_management.ml +++ b/debugger/program_management.ml @@ -30,7 +30,7 @@ open Time_travel let file_name = ref (None : string option) (* Default connection handler. *) -let buffer = String.create 1024 +let buffer = Bytes.create 1024 let control_connection pid fd = if (read fd.io_fd buffer 0 1024) = 0 then forget_process fd pid @@ -124,6 +124,8 @@ let initialize_loading () = raise Toplevel; end; Symbols.read_symbols !program_name; + Config.load_path := !Config.load_path @ !Symbols.program_source_dirs; + Envaux.reset_cache (); if !debug_loading then prerr_endline "Opening a socket..."; open_connection !socket_name diff --git a/debugger/source.ml b/debugger/source.ml index c68df3373..af69fbc7b 100644 --- a/debugger/source.ml +++ b/debugger/source.ml @@ -74,7 +74,7 @@ let get_buffer pos mdle = try List.assoc mdle !buffer_list with Not_found -> let inchan = open_in_bin (source_of_module pos mdle) in - let content = Misc.input_bytes inchan (in_channel_length inchan) in + let content = really_input_string inchan (in_channel_length inchan) in let buffer = (content, ref []) in buffer_list := (list_truncate !buffer_max_count ((mdle, buffer)::!buffer_list)); diff --git a/debugger/symbols.ml b/debugger/symbols.ml index 331d5bbdb..1be725332 100644 --- a/debugger/symbols.ml +++ b/debugger/symbols.ml @@ -17,9 +17,14 @@ open Instruct open Debugger_config (* Toplevel *) open Program_loading +module StringSet = Set.Make(String) + let modules = ref ([] : string list) +let program_source_dirs = + ref ([] : string list) + let events = ref ([] : debug_event list) let events_by_pc = @@ -52,13 +57,16 @@ let read_symbols' bytecode_file = raise Toplevel end; let num_eventlists = input_binary_int ic in + let dirs = ref StringSet.empty in let eventlists = ref [] in for i = 1 to num_eventlists do let orig = input_binary_int ic in let evl = (input_value ic : debug_event list) in (* Relocate events in event list *) List.iter (relocate_event orig) evl; - eventlists := evl :: !eventlists + eventlists := evl :: !eventlists; + dirs := + List.fold_left (fun s e -> StringSet.add e s) !dirs (input_value ic) done; begin try ignore (Bytesections.seek_section ic "CODE") @@ -68,12 +76,13 @@ let read_symbols' bytecode_file = set_launching_function (List.assoc "manual" loading_modes) end; close_in_noerr ic; - !eventlists + !eventlists, !dirs let read_symbols bytecode_file = - let all_events = read_symbols' bytecode_file in + let all_events, all_dirs = read_symbols' bytecode_file in modules := []; events := []; + program_source_dirs := StringSet.elements all_dirs; Hashtbl.clear events_by_pc; Hashtbl.clear events_by_module; Hashtbl.clear all_events_by_module; diff --git a/debugger/symbols.mli b/debugger/symbols.mli index 980892e04..883b81aa3 100644 --- a/debugger/symbols.mli +++ b/debugger/symbols.mli @@ -14,6 +14,10 @@ (* Modules used by the program. *) val modules : string list ref +(* Absolute directories containing source code on machine where source was + * compiled *) +val program_source_dirs : string list ref + (* Read debugging info from executable file *) val read_symbols : string -> unit diff --git a/driver/compenv.ml b/driver/compenv.ml index 619670764..82704fd8f 100644 --- a/driver/compenv.ml +++ b/driver/compenv.ml @@ -55,7 +55,7 @@ let last_ppx = ref [] let first_objfiles = ref [] let last_objfiles = ref [] -(* Note: this function is duplicated in optcompile.ml *) +(* Check validity of module name *) let check_unit_name ppf filename name = try begin match name.[0] with @@ -76,10 +76,19 @@ let check_unit_name ppf filename name = with Exit -> () ;; - - - - +(* Compute name of module from output file name *) +let module_of_filename ppf inputfile outputprefix = + let basename = Filename.basename outputprefix in + let name = + try + let pos = String.index basename '.' in + String.sub basename 0 pos + with Not_found -> basename + in + let name = String.capitalize name in + check_unit_name ppf inputfile name; + name +;; type readenv_position = @@ -126,6 +135,10 @@ let setter ppf f name options s = (Warnings.Bad_env_variable ("OCAMLPARAM", Printf.sprintf "bad value for %s" name)) +(* 'can-discard=' specifies which arguments can be discarded without warning + because they are not understood by some versions of OCaml. *) +let can_discard = ref [] + let read_OCAMLPARAM ppf position = try let s = Sys.getenv "OCAMLPARAM" in @@ -137,7 +150,6 @@ let read_OCAMLPARAM ppf position = (Warnings.Bad_env_variable ("OCAMLPARAM", s)); [],[] in - let set name options s = setter ppf (fun b -> b) name options s in let clear name options s = setter ppf (fun b -> not b) name options s in List.iter (fun (name, v) -> @@ -155,7 +167,9 @@ let read_OCAMLPARAM ppf position = | "nolabels" -> set "nolabels" [ classic ] v | "principal" -> set "principal" [ principal ] v | "rectypes" -> set "rectypes" [ recursive_types ] v + | "safe-string" -> clear "safe-string" [ unsafe_string ] v | "strict-sequence" -> set "strict-sequence" [ strict_sequence ] v + | "strict-formats" -> set "strict-formats" [ strict_formats ] v | "thread" -> set "thread" [ use_threads ] v | "unsafe" -> set "unsafe" [ fast ] v | "verbose" -> set "verbose" [ verbose ] v @@ -251,10 +265,16 @@ let read_OCAMLPARAM ppf position = first_objfiles := v :: !first_objfiles end + | "can-discard" -> + can_discard := v ::!can_discard + | _ -> - Printf.eprintf + if not (List.mem name !can_discard) then begin + can_discard := name :: !can_discard; + Printf.eprintf "Warning: discarding value of variable %S in OCAMLPARAM\n%!" name + end ) (match position with Before_args -> before | Before_compile | Before_link -> after) diff --git a/driver/compenv.mli b/driver/compenv.mli index d1d64393a..85d588ef6 100644 --- a/driver/compenv.mli +++ b/driver/compenv.mli @@ -10,7 +10,8 @@ (* *) (***********************************************************************) -val check_unit_name : Format.formatter -> string -> string -> unit +(* val check_unit_name : Format.formatter -> string -> string -> unit *) +val module_of_filename : Format.formatter -> string -> string -> string val output_prefix : string -> string val extract_output : string option -> string diff --git a/driver/compile.ml b/driver/compile.ml index bc9201e26..3b5d2ae07 100644 --- a/driver/compile.ml +++ b/driver/compile.ml @@ -21,17 +21,17 @@ open Compenv (* Keep in sync with the copy in optcompile.ml *) +let tool_name = "ocamlc" + let interface ppf sourcefile outputprefix = Compmisc.init_path false; - let modulename = - String.capitalize(Filename.basename(chop_extension_if_any sourcefile)) in - check_unit_name ppf sourcefile modulename; + let modulename = module_of_filename ppf sourcefile outputprefix in Env.set_unit_name modulename; let initial_env = Compmisc.initial_env () in - let ast = Pparse.parse_interface ppf sourcefile in + let ast = Pparse.parse_interface ~tool_name ppf sourcefile in if !Clflags.dump_parsetree then fprintf ppf "%a@." Printast.interface ast; if !Clflags.dump_source then fprintf ppf "%a@." Pprintast.signature ast; - let tsg = Typemod.transl_signature initial_env ast in + let tsg = Typemod.type_interface initial_env ast in if !Clflags.dump_typedtree then fprintf ppf "%a@." Printtyped.interface tsg; let sg = tsg.sig_type in if !Clflags.print_types then @@ -57,9 +57,7 @@ let (++) x f = f x let implementation ppf sourcefile outputprefix = Compmisc.init_path false; - let modulename = - String.capitalize(Filename.basename(chop_extension_if_any sourcefile)) in - check_unit_name ppf sourcefile modulename; + let modulename = module_of_filename ppf sourcefile outputprefix in Env.set_unit_name modulename; let env = Compmisc.initial_env() in if !Clflags.print_types then begin @@ -74,7 +72,7 @@ let implementation ppf sourcefile outputprefix = Warnings.check_fatal (); Stypes.dump (Some (outputprefix ^ ".annot")) in - try comp (Pparse.parse_implementation ppf sourcefile) + try comp (Pparse.parse_implementation ~tool_name ppf sourcefile) with x -> Stypes.dump (Some (outputprefix ^ ".annot")); raise x @@ -94,12 +92,12 @@ let implementation ppf sourcefile outputprefix = ++ print_if ppf Clflags.dump_lambda Printlambda.lambda ++ Bytegen.compile_implementation modulename ++ print_if ppf Clflags.dump_instr Printinstr.instrlist - ++ Emitcode.to_file oc modulename; + ++ Emitcode.to_file oc modulename objfile; Warnings.check_fatal (); close_out oc; Stypes.dump (Some (outputprefix ^ ".annot")) in - try comp (Pparse.parse_implementation ppf sourcefile) + try comp (Pparse.parse_implementation ~tool_name ppf sourcefile) with x -> close_out oc; remove_file objfile; diff --git a/driver/compmisc.ml b/driver/compmisc.ml index 8f974f4be..a2bc4b83a 100644 --- a/driver/compmisc.ml +++ b/driver/compmisc.ml @@ -40,19 +40,21 @@ let init_path native = toplevel initialization (PR#1775) *) let open_implicit_module m env = - try - Env.open_pers_signature m env - with Not_found -> - Misc.fatal_error (Printf.sprintf "cannot open implicit module %S" m) + let open Asttypes in + let lid = {loc = Location.in_file "command line"; + txt = Longident.Lident m } in + snd (Typemod.type_open_ Override env lid.loc lid) let initial_env () = Ident.reinit(); + let initial = + if !Clflags.unsafe_string then Env.initial_unsafe_string + else Env.initial_safe_string + in let env = - if !Clflags.nopervasives - then Env.initial - else - open_implicit_module "Pervasives" Env.initial + if !Clflags.nopervasives then initial else + open_implicit_module "Pervasives" initial in List.fold_left (fun env m -> open_implicit_module m env - ) env !implicit_modules + ) env (!implicit_modules @ List.rev !Clflags.open_modules) diff --git a/driver/compmisc.mli b/driver/compmisc.mli index 4c8cb0647..032e9fe4a 100644 --- a/driver/compmisc.mli +++ b/driver/compmisc.mli @@ -12,4 +12,3 @@ val init_path : bool -> unit val initial_env : unit -> Env.t - diff --git a/driver/main.ml b/driver/main.ml index cbb645999..f8358a0cb 100644 --- a/driver/main.ml +++ b/driver/main.ml @@ -85,6 +85,7 @@ module Options = Main_args.Make_bytecomp_options (struct let _custom = set custom_runtime let _dllib s = dllibs := Misc.rev_split_words s @ !dllibs let _dllpath s = dllpaths := !dllpaths @ [s] + let _for_pack s = for_package := Some s let _g = set debug let _i () = print_types := true; compile_only := true let _I s = include_dirs := s :: !include_dirs @@ -96,12 +97,14 @@ module Options = Main_args.Make_bytecomp_options (struct let _linkall = set link_everything let _make_runtime () = custom_runtime := true; make_runtime := true; link_everything := true + let _no_alias_deps = set transparent_modules let _no_app_funct = unset applicative_functors let _noassert = set noassert let _nolabels = set classic let _noautolink = set no_auto_link let _nostdlib = set no_std_include let _o s = output_name := Some s + let _open s = open_modules := s :: !open_modules let _output_obj () = output_c_object := true; custom_runtime := true let _pack = set make_package let _pp s = preprocessor := Some s @@ -109,12 +112,14 @@ module Options = Main_args.Make_bytecomp_options (struct let _principal = set principal let _rectypes = set recursive_types let _runtime_variant s = runtime_variant := s + let _safe_string = unset unsafe_string let _short_paths = unset real_paths let _strict_sequence = set strict_sequence + let _strict_formats = set strict_formats let _thread = set use_threads - let _trans_mod = set transparent_modules let _vmthread = set use_vmthreads let _unsafe = set fast + let _unsafe_string = set unsafe_string let _use_prims s = use_prims := s let _use_runtime s = use_runtime := s let _v () = print_version_and_library "compiler" @@ -160,7 +165,8 @@ let main () = Compmisc.init_path false; let extracted_output = extract_output !output_name in let revd = get_objfiles () in - Bytepackager.package_files ppf revd (extracted_output); + Bytepackager.package_files ppf (Compmisc.initial_env ()) + revd (extracted_output); Warnings.check_fatal (); end else if not !compile_only && !objfiles <> [] then begin diff --git a/driver/main_args.ml b/driver/main_args.ml index aba306b54..4f9668c75 100644 --- a/driver/main_args.ml +++ b/driver/main_args.ml @@ -73,9 +73,10 @@ let mk_dtypes f = "-dtypes", Arg.Unit f, " (deprecated) same as -annot" ;; -let mk_for_pack_byt () = - "-for-pack", Arg.String ignore, - "<ident> Ignored (for compatibility with ocamlopt)" +let mk_for_pack_byt f = + "-for-pack", Arg.String f, + "<ident> Generate code that can later be `packed' with\n\ + \ ocamlc -pack -o <ident>.cmo" ;; let mk_for_pack_opt f = @@ -150,10 +151,20 @@ let mk_modern f = "-modern", Arg.Unit f, " (deprecated) same as -labels" ;; +let mk_no_alias_deps f = + "-no-alias-deps", Arg.Unit f, + " Do not record dependencies for module aliases" +;; + let mk_no_app_funct f = "-no-app-funct", Arg.Unit f, " Deactivate applicative functors" ;; +let mk_no_float_const_prop f = + "-no-float-const-prop", Arg.Unit f, + " Deactivate constant propagation for floating-point operations" +;; + let mk_noassert f = "-noassert", Arg.Unit f, " Do not compile assertion checks" ;; @@ -199,6 +210,9 @@ let mk_o f = "-o", Arg.String f, "<file> Set output file name to <file>" ;; +let mk_open f = + "-open", Arg.String f, "<module> Opens the module <module> before typing" + let mk_output_obj f = "-output-obj", Arg.Unit f, " Output a C object file instead of an executable" ;; @@ -243,6 +257,14 @@ let mk_S f = "-S", Arg.Unit f, " Keep intermediate assembly file" ;; +let mk_safe_string f = + "-safe-string", Arg.Unit f, " Make strings immutable" +;; + +let mk_shared f = + "-shared", Arg.Unit f, " Produce a dynlinkable plugin" +;; + let mk_short_paths f = "-short-paths", Arg.Unit f, " Shorten paths in types" ;; @@ -256,24 +278,20 @@ let mk_strict_sequence f = " Left-hand part of a sequence must have type unit" ;; -let mk_shared f = - "-shared", Arg.Unit f, " Produce a dynlinkable plugin" -;; - let mk_thread f = "-thread", Arg.Unit f, " Generate code that supports the system threads library" ;; -let mk_trans_mod f = - "-trans-mod", Arg.Unit f, - " Make typing and linking only depend on normalized paths" - let mk_unsafe f = "-unsafe", Arg.Unit f, " Do not compile bounds checking on array and string access" ;; +let mk_unsafe_string f = + "-unsafe-string", Arg.Unit f, " Make strings mutable (default)" +;; + let mk_use_runtime f = "-use-runtime", Arg.String f, "<file> Generate bytecode for the given runtime system" @@ -385,6 +403,10 @@ let mk_dcombine f = "-dcombine", Arg.Unit f, " (undocumented)" ;; +let mk_dcse f = + "-dcse", Arg.Unit f, " (undocumented)" +;; + let mk_dlive f = "-dlive", Arg.Unit f, " (undocumented)" ;; @@ -425,96 +447,45 @@ let mk_dstartup f = "-dstartup", Arg.Unit f, " (undocumented)" ;; +let mk_opaque f = + "-opaque", Arg.Unit f, + " Does not generate cross-module optimization information\n\ + \ (reduces necessary recompilation on module change)" +;; + +let mk_strict_formats f = + "-strict-formats", Arg.Unit f, + " Reject invalid formats accepted by legacy implementations\n\ + \ (Warning: Invalid formats may behave differently from\n\ + \ previous OCaml versions, and will become always-rejected\n\ + \ in future OCaml versions. You should use this flag\n\ + \ to detect and fix invalid formats.)" +;; + let mk__ f = "-", Arg.String f, "<file> Treat <file> as a file name (even if it starts with `-')" ;; -module type Bytecomp_options = sig - val _a : unit -> unit - val _absname : unit -> unit - val _annot : unit -> unit - val _binannot : unit -> unit - val _c : unit -> unit - val _cc : string -> unit - val _cclib : string -> unit - val _ccopt : string -> unit - val _compat_32 : unit -> unit - val _config : unit -> unit - val _custom : unit -> unit - val _dllib : string -> unit - val _dllpath : string -> unit - val _g : unit -> unit - val _i : unit -> unit - val _I : string -> unit - val _impl : string -> unit - val _intf : string -> unit - val _intf_suffix : string -> unit - val _keep_locs : unit -> unit - val _labels : unit -> unit - val _linkall : unit -> unit - val _make_runtime : unit -> unit - val _no_app_funct : unit -> unit - val _noassert : unit -> unit - val _noautolink : unit -> unit - val _nolabels : unit -> unit - val _nostdlib : unit -> unit - val _o : string -> unit - val _output_obj : unit -> unit - val _pack : unit -> unit - val _pp : string -> unit - val _ppx : string -> unit - val _principal : unit -> unit - val _rectypes : unit -> unit - val _runtime_variant : string -> unit - val _short_paths : unit -> unit - val _strict_sequence : unit -> unit - val _trans_mod : unit -> unit - val _thread : unit -> unit - val _vmthread : unit -> unit - val _unsafe : unit -> unit - val _use_runtime : string -> unit - val _v : unit -> unit - val _version : unit -> unit - val _vnum : unit -> unit - val _verbose : unit -> unit - val _w : string -> unit - val _warn_error : string -> unit - val _warn_help : unit -> unit - val _where : unit -> unit - - val _nopervasives : unit -> unit - val _use_prims : string -> unit - val _dsource : unit -> unit - val _dparsetree : unit -> unit - val _dtypedtree : unit -> unit - val _drawlambda : unit -> unit - val _dlambda : unit -> unit - val _dinstr : unit -> unit - - val anonymous : string -> unit -end;; - -module type Bytetop_options = sig +module type Common_options = sig val _absname : unit -> unit val _I : string -> unit - val _init : string -> unit val _labels : unit -> unit + val _no_alias_deps : unit -> unit val _no_app_funct : unit -> unit val _noassert : unit -> unit - val _noinit : unit -> unit val _nolabels : unit -> unit - val _noprompt : unit -> unit - val _nopromptcont : unit -> unit val _nostdlib : unit -> unit + val _open : string -> unit val _ppx : string -> unit val _principal : unit -> unit val _rectypes : unit -> unit + val _safe_string : unit -> unit val _short_paths : unit -> unit - val _stdin: unit -> unit val _strict_sequence : unit -> unit - val _trans_mod : unit -> unit + val _strict_formats : unit -> unit val _unsafe : unit -> unit + val _unsafe_string : unit -> unit val _version : unit -> unit val _vnum : unit -> unit val _w : string -> unit @@ -526,126 +497,81 @@ module type Bytetop_options = sig val _dtypedtree : unit -> unit val _drawlambda : unit -> unit val _dlambda : unit -> unit - val _dinstr : unit -> unit val anonymous : string -> unit end;; -module type Optcomp_options = sig +module type Compiler_options = sig val _a : unit -> unit - val _absname : unit -> unit val _annot : unit -> unit val _binannot : unit -> unit val _c : unit -> unit val _cc : string -> unit val _cclib : string -> unit val _ccopt : string -> unit - val _compact : unit -> unit val _config : unit -> unit val _for_pack : string -> unit val _g : unit -> unit val _i : unit -> unit - val _I : string -> unit val _impl : string -> unit - val _inline : int -> unit val _intf : string -> unit val _intf_suffix : string -> unit val _keep_locs : unit -> unit - val _labels : unit -> unit val _linkall : unit -> unit - val _no_app_funct : unit -> unit - val _noassert : unit -> unit val _noautolink : unit -> unit - val _nodynlink : unit -> unit - val _nolabels : unit -> unit - val _nostdlib : unit -> unit val _o : string -> unit val _output_obj : unit -> unit - val _p : unit -> unit val _pack : unit -> unit val _pp : string -> unit - val _ppx : string -> unit val _principal : unit -> unit val _rectypes : unit -> unit val _runtime_variant : string -> unit - val _S : unit -> unit - val _shared : unit -> unit + val _safe_string : unit -> unit val _short_paths : unit -> unit - val _strict_sequence : unit -> unit - val _trans_mod : unit -> unit val _thread : unit -> unit - val _unsafe : unit -> unit val _v : unit -> unit val _verbose : unit -> unit - val _version : unit -> unit - val _vnum : unit -> unit - val _w : string -> unit - val _warn_error : string -> unit - val _warn_help : unit -> unit val _where : unit -> unit - val _nopervasives : unit -> unit - val _dsource : unit -> unit - val _dparsetree : unit -> unit - val _dtypedtree : unit -> unit - val _drawlambda : unit -> unit - val _dlambda : unit -> unit - val _dclambda : unit -> unit - val _dcmm : unit -> unit - val _dsel : unit -> unit - val _dcombine : unit -> unit - val _dlive : unit -> unit - val _dspill : unit -> unit - val _dsplit : unit -> unit - val _dinterf : unit -> unit - val _dprefer : unit -> unit - val _dalloc : unit -> unit - val _dreload : unit -> unit - val _dscheduling : unit -> unit - val _dlinear : unit -> unit - val _dstartup : unit -> unit +end +;; - val anonymous : string -> unit +module type Bytecomp_options = sig + include Common_options + include Compiler_options + val _compat_32 : unit -> unit + val _custom : unit -> unit + val _dllib : string -> unit + val _dllpath : string -> unit + val _make_runtime : unit -> unit + val _vmthread : unit -> unit + val _use_runtime : string -> unit + + val _dinstr : unit -> unit + + val _use_prims : string -> unit end;; -module type Opttop_options = sig - val _absname : unit -> unit - val _compact : unit -> unit - val _I : string -> unit +module type Bytetop_options = sig + include Common_options val _init : string -> unit - val _inline : int -> unit - val _labels : unit -> unit - val _no_app_funct : unit -> unit - val _noassert : unit -> unit val _noinit : unit -> unit - val _nolabels : unit -> unit val _noprompt : unit -> unit val _nopromptcont : unit -> unit - val _nostdlib : unit -> unit - val _ppx : string -> unit - val _principal : unit -> unit - val _rectypes : unit -> unit - val _S : unit -> unit - val _short_paths : unit -> unit val _stdin : unit -> unit - val _strict_sequence : unit -> unit - val _trans_mod : unit -> unit - val _unsafe : unit -> unit - val _version : unit -> unit - val _vnum : unit -> unit - val _w : string -> unit - val _warn_error : string -> unit - val _warn_help : unit -> unit - val _dsource : unit -> unit - val _dparsetree : unit -> unit - val _dtypedtree : unit -> unit - val _drawlambda : unit -> unit - val _dlambda : unit -> unit + val _dinstr : unit -> unit +end;; + +module type Optcommon_options = sig + val _compact : unit -> unit + val _inline : int -> unit + val _dclambda : unit -> unit val _dcmm : unit -> unit val _dsel : unit -> unit val _dcombine : unit -> unit + val _dcse : unit -> unit val _dlive : unit -> unit val _dspill : unit -> unit val _dsplit : unit -> unit @@ -656,8 +582,30 @@ module type Opttop_options = sig val _dscheduling : unit -> unit val _dlinear : unit -> unit val _dstartup : unit -> unit +end;; - val anonymous : string -> unit +module type Optcomp_options = sig + include Common_options + include Compiler_options + include Optcommon_options + val _no_float_const_prop : unit -> unit + val _nodynlink : unit -> unit + val _p : unit -> unit + val _pp : string -> unit + val _S : unit -> unit + val _shared : unit -> unit + val _opaque : unit -> unit +end;; + +module type Opttop_options = sig + include Common_options + include Optcommon_options + val _init : string -> unit + val _noinit : unit -> unit + val _noprompt : unit -> unit + val _nopromptcont : unit -> unit + val _S : unit -> unit + val _stdin : unit -> unit end;; module type Arg_list = sig @@ -681,7 +629,7 @@ struct mk_dllib F._dllib; mk_dllpath F._dllpath; mk_dtypes F._annot; - mk_for_pack_byt (); + mk_for_pack_byt F._for_pack; mk_g_byt F._g; mk_i F._i; mk_I F._I; @@ -695,12 +643,14 @@ struct mk_make_runtime F._make_runtime; mk_make_runtime_2 F._make_runtime; mk_modern F._labels; + mk_no_alias_deps F._no_alias_deps; mk_no_app_funct F._no_app_funct; mk_noassert F._noassert; mk_noautolink_byt F._noautolink; mk_nolabels F._nolabels; mk_nostdlib F._nostdlib; mk_o F._o; + mk_open F._open; mk_output_obj F._output_obj; mk_pack_byt F._pack; mk_pp F._pp; @@ -708,11 +658,13 @@ struct mk_principal F._principal; mk_rectypes F._rectypes; mk_runtime_variant F._runtime_variant; + mk_safe_string F._safe_string; mk_short_paths F._short_paths; mk_strict_sequence F._strict_sequence; - mk_trans_mod F._trans_mod; + mk_strict_formats F._strict_formats; mk_thread F._thread; mk_unsafe F._unsafe; + mk_unsafe_string F._unsafe_string; mk_use_runtime F._use_runtime; mk_use_runtime_2 F._use_runtime; mk_v F._v; @@ -724,6 +676,7 @@ struct mk_warn_error F._warn_error; mk_warn_help F._warn_help; mk_where F._where; + mk__ F.anonymous; mk_nopervasives F._nopervasives; mk_use_prims F._use_prims; @@ -733,8 +686,6 @@ struct mk_drawlambda F._drawlambda; mk_dlambda F._dlambda; mk_dinstr F._dinstr; - - mk__ F.anonymous; ] end;; @@ -745,6 +696,7 @@ struct mk_I F._I; mk_init F._init; mk_labels F._labels; + mk_no_alias_deps F._no_alias_deps; mk_no_app_funct F._no_app_funct; mk_noassert F._noassert; mk_noinit F._noinit; @@ -752,19 +704,23 @@ struct mk_noprompt F._noprompt; mk_nopromptcont F._nopromptcont; mk_nostdlib F._nostdlib; + mk_open F._open; mk_ppx F._ppx; mk_principal F._principal; mk_rectypes F._rectypes; + mk_safe_string F._safe_string; mk_short_paths F._short_paths; mk_stdin F._stdin; mk_strict_sequence F._strict_sequence; - mk_trans_mod F._trans_mod; + mk_strict_formats F._strict_formats; mk_unsafe F._unsafe; + mk_unsafe_string F._unsafe_string; mk_version F._version; mk_vnum F._vnum; mk_w F._w; mk_warn_error F._warn_error; mk_warn_help F._warn_help; + mk__ F.anonymous; mk_dsource F._dsource; mk_dparsetree F._dparsetree; @@ -772,8 +728,6 @@ struct mk_drawlambda F._drawlambda; mk_dlambda F._dlambda; mk_dinstr F._dinstr; - - mk__ F.anonymous; ] end;; @@ -802,13 +756,16 @@ struct mk_keep_locs F._keep_locs; mk_labels F._labels; mk_linkall F._linkall; + mk_no_alias_deps F._no_alias_deps; mk_no_app_funct F._no_app_funct; + mk_no_float_const_prop F._no_float_const_prop; mk_noassert F._noassert; mk_noautolink_opt F._noautolink; mk_nodynlink F._nodynlink; mk_nolabels F._nolabels; mk_nostdlib F._nostdlib; mk_o F._o; + mk_open F._open; mk_output_obj F._output_obj; mk_p F._p; mk_pack_opt F._pack; @@ -818,12 +775,14 @@ struct mk_rectypes F._rectypes; mk_runtime_variant F._runtime_variant; mk_S F._S; + mk_safe_string F._safe_string; mk_shared F._shared; mk_short_paths F._short_paths; mk_strict_sequence F._strict_sequence; - mk_trans_mod F._trans_mod; + mk_strict_formats F._strict_formats; mk_thread F._thread; mk_unsafe F._unsafe; + mk_unsafe_string F._unsafe_string; mk_v F._v; mk_verbose F._verbose; mk_version F._version; @@ -832,6 +791,7 @@ struct mk_warn_error F._warn_error; mk_warn_help F._warn_help; mk_where F._where; + mk__ F.anonymous; mk_nopervasives F._nopervasives; mk_dsource F._dsource; @@ -843,6 +803,7 @@ struct mk_dcmm F._dcmm; mk_dsel F._dsel; mk_dcombine F._dcombine; + mk_dcse F._dcse; mk_dlive F._dlive; mk_dspill F._dspill; mk_dsplit F._dsplit; @@ -853,8 +814,7 @@ struct mk_dscheduling F._dscheduling; mk_dlinear F._dlinear; mk_dstartup F._dstartup; - - mk__ F.anonymous; + mk_opaque F._opaque; ] end;; @@ -866,6 +826,7 @@ module Make_opttop_options (F : Opttop_options) = struct mk_init F._init; mk_inline F._inline; mk_labels F._labels; + mk_no_alias_deps F._no_alias_deps; mk_no_app_funct F._no_app_funct; mk_noassert F._noassert; mk_noinit F._noinit; @@ -873,20 +834,24 @@ module Make_opttop_options (F : Opttop_options) = struct mk_noprompt F._noprompt; mk_nopromptcont F._nopromptcont; mk_nostdlib F._nostdlib; + mk_open F._open; mk_ppx F._ppx; mk_principal F._principal; mk_rectypes F._rectypes; mk_S F._S; + mk_safe_string F._safe_string; mk_short_paths F._short_paths; mk_stdin F._stdin; mk_strict_sequence F._strict_sequence; - mk_trans_mod F._trans_mod; + mk_strict_formats F._strict_formats; mk_unsafe F._unsafe; + mk_unsafe_string F._unsafe_string; mk_version F._version; mk_vnum F._vnum; mk_w F._w; mk_warn_error F._warn_error; mk_warn_help F._warn_help; + mk__ F.anonymous; mk_dsource F._dsource; mk_dparsetree F._dparsetree; @@ -896,6 +861,7 @@ module Make_opttop_options (F : Opttop_options) = struct mk_dcmm F._dcmm; mk_dsel F._dsel; mk_dcombine F._dcombine; + mk_dcse F._dcse; mk_dlive F._dlive; mk_dspill F._dspill; mk_dsplit F._dsplit; @@ -906,7 +872,5 @@ module Make_opttop_options (F : Opttop_options) = struct mk_dscheduling F._dscheduling; mk_dlinear F._dlinear; mk_dstartup F._dstartup; - - mk__ F.anonymous; ] end;; diff --git a/driver/main_args.mli b/driver/main_args.mli index 67a6c681d..95b7c69e3 100644 --- a/driver/main_args.mli +++ b/driver/main_args.mli @@ -10,93 +10,25 @@ (* *) (***********************************************************************) -module type Bytecomp_options = - sig - val _a : unit -> unit - val _absname : unit -> unit - val _annot : unit -> unit - val _binannot : unit -> unit - val _c : unit -> unit - val _cc : string -> unit - val _cclib : string -> unit - val _ccopt : string -> unit - val _compat_32 : unit -> unit - val _config : unit -> unit - val _custom : unit -> unit - val _dllib : string -> unit - val _dllpath : string -> unit - val _g : unit -> unit - val _i : unit -> unit - val _I : string -> unit - val _impl : string -> unit - val _intf : string -> unit - val _intf_suffix : string -> unit - val _keep_locs : unit -> unit - val _labels : unit -> unit - val _linkall : unit -> unit - val _make_runtime : unit -> unit - val _no_app_funct : unit -> unit - val _noassert : unit -> unit - val _noautolink : unit -> unit - val _nolabels : unit -> unit - val _nostdlib : unit -> unit - val _o : string -> unit - val _output_obj : unit -> unit - val _pack : unit -> unit - val _pp : string -> unit - val _ppx : string -> unit - val _principal : unit -> unit - val _rectypes : unit -> unit - val _runtime_variant : string -> unit - val _short_paths : unit -> unit - val _strict_sequence : unit -> unit - val _trans_mod : unit -> unit - val _thread : unit -> unit - val _vmthread : unit -> unit - val _unsafe : unit -> unit - val _use_runtime : string -> unit - val _v : unit -> unit - val _version : unit -> unit - val _vnum : unit -> unit - val _verbose : unit -> unit - val _w : string -> unit - val _warn_error : string -> unit - val _warn_help : unit -> unit - val _where : unit -> unit - - val _nopervasives : unit -> unit - val _use_prims : string -> unit - val _dsource : unit -> unit - val _dparsetree : unit -> unit - val _dtypedtree : unit -> unit - val _drawlambda : unit -> unit - val _dlambda : unit -> unit - val _dinstr : unit -> unit - - val anonymous : string -> unit - end -;; - -module type Bytetop_options = sig +module type Common_options = sig val _absname : unit -> unit val _I : string -> unit - val _init : string -> unit val _labels : unit -> unit + val _no_alias_deps : unit -> unit val _no_app_funct : unit -> unit val _noassert : unit -> unit - val _noinit : unit -> unit val _nolabels : unit -> unit - val _noprompt : unit -> unit - val _nopromptcont : unit -> unit val _nostdlib : unit -> unit + val _open : string -> unit val _ppx : string -> unit val _principal : unit -> unit val _rectypes : unit -> unit + val _safe_string : unit -> unit val _short_paths : unit -> unit - val _stdin : unit -> unit val _strict_sequence : unit -> unit - val _trans_mod : unit -> unit + val _strict_formats : unit -> unit val _unsafe : unit -> unit + val _unsafe_string : unit -> unit val _version : unit -> unit val _vnum : unit -> unit val _w : string -> unit @@ -108,126 +40,82 @@ module type Bytetop_options = sig val _dtypedtree : unit -> unit val _drawlambda : unit -> unit val _dlambda : unit -> unit - val _dinstr : unit -> unit val anonymous : string -> unit -end;; +end -module type Optcomp_options = sig +module type Compiler_options = sig val _a : unit -> unit - val _absname : unit -> unit val _annot : unit -> unit val _binannot : unit -> unit val _c : unit -> unit val _cc : string -> unit val _cclib : string -> unit val _ccopt : string -> unit - val _compact : unit -> unit val _config : unit -> unit val _for_pack : string -> unit val _g : unit -> unit val _i : unit -> unit - val _I : string -> unit val _impl : string -> unit - val _inline : int -> unit val _intf : string -> unit val _intf_suffix : string -> unit val _keep_locs : unit -> unit - val _labels : unit -> unit val _linkall : unit -> unit - val _no_app_funct : unit -> unit - val _noassert : unit -> unit val _noautolink : unit -> unit - val _nodynlink : unit -> unit - val _nolabels : unit -> unit - val _nostdlib : unit -> unit val _o : string -> unit val _output_obj : unit -> unit - val _p : unit -> unit val _pack : unit -> unit val _pp : string -> unit - val _ppx : string -> unit val _principal : unit -> unit val _rectypes : unit -> unit val _runtime_variant : string -> unit - val _S : unit -> unit - val _shared : unit -> unit + val _safe_string : unit -> unit val _short_paths : unit -> unit - val _strict_sequence : unit -> unit - val _trans_mod : unit -> unit val _thread : unit -> unit - val _unsafe : unit -> unit val _v : unit -> unit val _verbose : unit -> unit - val _version : unit -> unit - val _vnum : unit -> unit - val _w : string -> unit - val _warn_error : string -> unit - val _warn_help : unit -> unit val _where : unit -> unit val _nopervasives : unit -> unit - val _dsource : unit -> unit - val _dparsetree : unit -> unit - val _dtypedtree : unit -> unit - val _drawlambda : unit -> unit - val _dlambda : unit -> unit - val _dclambda : unit -> unit - val _dcmm : unit -> unit - val _dsel : unit -> unit - val _dcombine : unit -> unit - val _dlive : unit -> unit - val _dspill : unit -> unit - val _dsplit : unit -> unit - val _dinterf : unit -> unit - val _dprefer : unit -> unit - val _dalloc : unit -> unit - val _dreload : unit -> unit - val _dscheduling : unit -> unit - val _dlinear : unit -> unit - val _dstartup : unit -> unit +end +;; - val anonymous : string -> unit +module type Bytecomp_options = sig + include Common_options + include Compiler_options + val _compat_32 : unit -> unit + val _custom : unit -> unit + val _dllib : string -> unit + val _dllpath : string -> unit + val _make_runtime : unit -> unit + val _vmthread : unit -> unit + val _use_runtime : string -> unit + + val _dinstr : unit -> unit + + val _use_prims : string -> unit end;; -module type Opttop_options = sig - val _absname : unit -> unit - val _compact : unit -> unit - val _I : string -> unit +module type Bytetop_options = sig + include Common_options val _init : string -> unit - val _inline : int -> unit - val _labels : unit -> unit - val _no_app_funct : unit -> unit - val _noassert : unit -> unit val _noinit : unit -> unit - val _nolabels : unit -> unit val _noprompt : unit -> unit val _nopromptcont : unit -> unit - val _nostdlib : unit -> unit - val _ppx : string -> unit - val _principal : unit -> unit - val _rectypes : unit -> unit - val _S : unit -> unit - val _short_paths : unit -> unit val _stdin : unit -> unit - val _strict_sequence : unit -> unit - val _trans_mod : unit -> unit - val _unsafe : unit -> unit - val _version : unit -> unit - val _vnum : unit -> unit - val _w : string -> unit - val _warn_error : string -> unit - val _warn_help : unit -> unit - val _dsource : unit -> unit - val _dparsetree : unit -> unit - val _dtypedtree : unit -> unit - val _drawlambda : unit -> unit - val _dlambda : unit -> unit + val _dinstr : unit -> unit +end;; + +module type Optcommon_options = sig + val _compact : unit -> unit + val _inline : int -> unit + val _dclambda : unit -> unit val _dcmm : unit -> unit val _dsel : unit -> unit val _dcombine : unit -> unit + val _dcse : unit -> unit val _dlive : unit -> unit val _dspill : unit -> unit val _dsplit : unit -> unit @@ -238,8 +126,30 @@ module type Opttop_options = sig val _dscheduling : unit -> unit val _dlinear : unit -> unit val _dstartup : unit -> unit +end;; - val anonymous : string -> unit +module type Optcomp_options = sig + include Common_options + include Compiler_options + include Optcommon_options + val _no_float_const_prop : unit -> unit + val _nodynlink : unit -> unit + val _p : unit -> unit + val _pp : string -> unit + val _S : unit -> unit + val _shared : unit -> unit + val _opaque : unit -> unit +end;; + +module type Opttop_options = sig + include Common_options + include Optcommon_options + val _init : string -> unit + val _noinit : unit -> unit + val _noprompt : unit -> unit + val _nopromptcont : unit -> unit + val _S : unit -> unit + val _stdin : unit -> unit end;; module type Arg_list = sig diff --git a/driver/optcompile.ml b/driver/optcompile.ml index 625c0223e..f0ef78d1c 100644 --- a/driver/optcompile.ml +++ b/driver/optcompile.ml @@ -22,17 +22,17 @@ open Compenv (* Keep in sync with the copy in compile.ml *) +let tool_name = "ocamlopt" + let interface ppf sourcefile outputprefix = Compmisc.init_path false; - let modulename = - String.capitalize(Filename.basename(chop_extension_if_any sourcefile)) in - check_unit_name ppf sourcefile modulename; + let modulename = module_of_filename ppf sourcefile outputprefix in Env.set_unit_name modulename; let initial_env = Compmisc.initial_env () in - let ast = Pparse.parse_interface ppf sourcefile in + let ast = Pparse.parse_interface ~tool_name ppf sourcefile in if !Clflags.dump_parsetree then fprintf ppf "%a@." Printast.interface ast; if !Clflags.dump_source then fprintf ppf "%a@." Pprintast.signature ast; - let tsg = Typemod.transl_signature initial_env ast in + let tsg = Typemod.type_interface initial_env ast in if !Clflags.dump_typedtree then fprintf ppf "%a@." Printtyped.interface tsg; let sg = tsg.sig_type in if !Clflags.print_types then @@ -59,9 +59,7 @@ let (+++) (x, y) f = (x, f y) let implementation ppf sourcefile outputprefix = Compmisc.init_path true; - let modulename = - String.capitalize(Filename.basename(chop_extension_if_any sourcefile)) in - check_unit_name ppf sourcefile modulename; + let modulename = module_of_filename ppf sourcefile outputprefix in Env.set_unit_name modulename; let env = Compmisc.initial_env() in Compilenv.reset ?packname:!Clflags.for_package modulename; @@ -94,7 +92,7 @@ let implementation ppf sourcefile outputprefix = Warnings.check_fatal (); Stypes.dump (Some (outputprefix ^ ".annot")) in - try comp (Pparse.parse_implementation ppf sourcefile) + try comp (Pparse.parse_implementation ~tool_name ppf sourcefile) with x -> Stypes.dump (Some (outputprefix ^ ".annot")); remove_file objfile; diff --git a/driver/optmain.ml b/driver/optmain.ml index d04ad76b1..947d43073 100644 --- a/driver/optmain.ml +++ b/driver/optmain.ml @@ -93,13 +93,16 @@ module Options = Main_args.Make_optcomp_options (struct let _keep_locs = set keep_locs let _labels = clear classic let _linkall = set link_everything + let _no_alias_deps = set transparent_modules let _no_app_funct = clear applicative_functors + let _no_float_const_prop = clear float_const_prop let _noassert = set noassert let _noautolink = set no_auto_link let _nodynlink = clear dlcode let _nolabels = set classic let _nostdlib = set no_std_include let _o s = output_name := Some s + let _open s = open_modules := s :: !open_modules let _output_obj = set output_c_object let _p = set gprofile let _pack = set make_package @@ -108,13 +111,15 @@ module Options = Main_args.Make_optcomp_options (struct let _principal = set principal let _rectypes = set recursive_types let _runtime_variant s = runtime_variant := s + let _safe_string = clear unsafe_string let _short_paths = clear real_paths let _strict_sequence = set strict_sequence - let _trans_mod = set transparent_modules + let _strict_formats = set strict_formats let _shared () = shared := true; dlcode := true let _S = set keep_asm_file let _thread = set use_threads let _unsafe = set fast + let _unsafe_string = set unsafe_string let _v () = print_version_and_library "native-code compiler" let _version () = print_version_string () let _vnum () = print_version_string () @@ -134,6 +139,7 @@ module Options = Main_args.Make_optcomp_options (struct let _dcmm = set dump_cmm let _dsel = set dump_selection let _dcombine = set dump_combine + let _dcse = set dump_cse let _dlive () = dump_live := true; Printmach.print_live := true let _dspill = set dump_spill let _dsplit = set dump_split @@ -144,6 +150,7 @@ module Options = Main_args.Make_optcomp_options (struct let _dscheduling = set dump_scheduling let _dlinear = set dump_linear let _dstartup = set keep_startup_file + let _opaque = set opaque let anonymous = anonymous end);; @@ -172,7 +179,8 @@ let main () = else if !make_package then begin Compmisc.init_path true; let target = extract_output !output_name in - Asmpackager.package_files ppf (get_objfiles ()) target; + Asmpackager.package_files ppf (Compmisc.initial_env ()) + (get_objfiles ()) target; Warnings.check_fatal (); end else if !shared then begin diff --git a/driver/pparse.ml b/driver/pparse.ml index 7f9974da7..4b2553f27 100644 --- a/driver/pparse.ml +++ b/driver/pparse.ml @@ -39,6 +39,10 @@ let remove_preprocessed inputfile = None -> () | Some _ -> Misc.remove_file inputfile + +(* Note: some of the functions here should go to Ast_mapper instead, + which would encapsulate the "binary AST" protocol. *) + let write_ast magic ast = let fn = Filename.temp_file "camlppx" "" in let oc = open_out_bin fn in @@ -64,7 +68,7 @@ let apply_rewriter magic fn_in ppx = (* check magic before passing to the next ppx *) let ic = open_in_bin fn_out in let buffer = - try Misc.input_bytes ic (String.length magic) with End_of_file -> "" in + try really_input_string ic (String.length magic) with End_of_file -> "" in close_in ic; if buffer <> magic then begin Misc.remove_file fn_out; @@ -75,7 +79,7 @@ let apply_rewriter magic fn_in ppx = let read_ast magic fn = let ic = open_in_bin fn in try - let buffer = Misc.input_bytes ic (String.length magic) in + let buffer = really_input_string ic (String.length magic) in assert(buffer = magic); (* already checked by apply_rewriter *) Location.input_name := input_value ic; let ast = input_value ic in @@ -87,25 +91,44 @@ let read_ast magic fn = Misc.remove_file fn; raise exn -let apply_rewriters magic ast = +let rewrite magic ast ppxs = + read_ast magic + (List.fold_left (apply_rewriter magic) (write_ast magic ast) + (List.rev ppxs)) + +let apply_rewriters_str ?(restore = true) ~tool_name ast = match !Clflags.all_ppx with | [] -> ast | ppxs -> - let fn = - List.fold_left (apply_rewriter magic) (write_ast magic ast) - (List.rev ppxs) - in - read_ast magic fn + let ast = Ast_mapper.add_ppx_context_str ~tool_name ast in + let ast = rewrite Config.ast_impl_magic_number ast ppxs in + Ast_mapper.drop_ppx_context_str ~restore ast + +let apply_rewriters_sig ?(restore = true) ~tool_name ast = + match !Clflags.all_ppx with + | [] -> ast + | ppxs -> + let ast = Ast_mapper.add_ppx_context_sig ~tool_name ast in + let ast = rewrite Config.ast_intf_magic_number ast ppxs in + Ast_mapper.drop_ppx_context_sig ~restore ast + +let apply_rewriters ?restore ~tool_name magic ast = + if magic = Config.ast_impl_magic_number then + Obj.magic (apply_rewriters_str ?restore ~tool_name (Obj.magic ast)) + else if magic = Config.ast_intf_magic_number then + Obj.magic (apply_rewriters_sig ?restore ~tool_name (Obj.magic ast)) + else + assert false (* Parse a file or get a dumped syntax tree from it *) exception Outdated_version -let file ppf inputfile parse_fun ast_magic = +let file ppf ~tool_name inputfile parse_fun ast_magic = let ic = open_in_bin inputfile in let is_ast_file = try - let buffer = Misc.input_bytes ic (String.length ast_magic) in + let buffer = really_input_string ic (String.length ast_magic) in if buffer = ast_magic then true else if String.sub buffer 0 9 = String.sub ast_magic 0 9 then raise Outdated_version @@ -134,7 +157,7 @@ let file ppf inputfile parse_fun ast_magic = with x -> close_in ic; raise x in close_in ic; - apply_rewriters ast_magic ast + apply_rewriters ~restore:false ~tool_name ast_magic ast let report_error ppf = function | CannotRun cmd -> @@ -151,11 +174,11 @@ let () = | _ -> None ) -let parse_all parse_fun magic ppf sourcefile = +let parse_all ~tool_name parse_fun magic ppf sourcefile = Location.input_name := sourcefile; let inputfile = preprocess sourcefile in let ast = - try file ppf inputfile parse_fun magic + try file ppf ~tool_name inputfile parse_fun magic with exn -> remove_preprocessed inputfile; raise exn @@ -163,7 +186,9 @@ let parse_all parse_fun magic ppf sourcefile = remove_preprocessed inputfile; ast -let parse_implementation ppf sourcefile = - parse_all Parse.implementation Config.ast_impl_magic_number ppf sourcefile -let parse_interface ppf sourcefile = - parse_all Parse.interface Config.ast_intf_magic_number ppf sourcefile +let parse_implementation ppf ~tool_name sourcefile = + parse_all ~tool_name Parse.implementation + Config.ast_impl_magic_number ppf sourcefile +let parse_interface ppf ~tool_name sourcefile = + parse_all ~tool_name Parse.interface + Config.ast_intf_magic_number ppf sourcefile diff --git a/driver/pparse.mli b/driver/pparse.mli index 6a53f3fa9..bcff4e781 100644 --- a/driver/pparse.mli +++ b/driver/pparse.mli @@ -20,10 +20,17 @@ exception Error of error val preprocess : string -> string val remove_preprocessed : string -> unit -val file : formatter -> string -> (Lexing.lexbuf -> 'a) -> string -> 'a -val apply_rewriters : string -> 'a -> 'a +val file : formatter -> tool_name:string -> string -> (Lexing.lexbuf -> 'a) -> string -> 'a +val apply_rewriters: ?restore:bool -> tool_name:string -> string -> 'a -> 'a + (** If [restore = true] (the default), cookies set by external rewriters will be + kept for later calls. *) + +val apply_rewriters_str: ?restore:bool -> tool_name:string -> Parsetree.structure -> Parsetree.structure +val apply_rewriters_sig: ?restore:bool -> tool_name:string -> Parsetree.signature -> Parsetree.signature + + val report_error : formatter -> error -> unit -val parse_implementation: formatter -> string -> Parsetree.structure -val parse_interface: formatter -> string -> Parsetree.signature +val parse_implementation: formatter -> tool_name:string -> string -> Parsetree.structure +val parse_interface: formatter -> tool_name:string -> string -> Parsetree.signature diff --git a/experimental/doligez/check-bounds.diff b/experimental/doligez/check-bounds.diff new file mode 100644 index 000000000..c2e079521 --- /dev/null +++ b/experimental/doligez/check-bounds.diff @@ -0,0 +1,149 @@ +Patch taken from: + https://github.com/mshinwell/ocaml/commits/4.02-block-bounds + +diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml +index 01eff9c..b498b58 100644 +--- a/asmcomp/cmmgen.ml ++++ b/asmcomp/cmmgen.ml +@@ -22,6 +22,13 @@ open Clambda + open Cmm + open Cmx_format + ++let do_check_field_access = true ++(* ++ match try Some (Sys.getenv "BOUNDS") with Not_found -> None with ++ | None | Some "" -> false ++ | Some _ -> true ++*) ++ + (* Local binding of complex expressions *) + + let bind name arg fn = +@@ -494,6 +501,35 @@ let get_tag ptr = + let get_size ptr = + Cop(Clsr, [header ptr; Cconst_int 10]) + ++(* Bounds checks upon field access, for debugging the compiler *) ++ ++let check_field_access ptr field_index if_success = ++ if not do_check_field_access then ++ if_success ++ else ++ let field_index = Cconst_int field_index in ++ (* If [ptr] points at an infix header, we need to move it back to the "main" ++ [Closure_tag] header. *) ++ let ptr = ++ Cifthenelse (Cop (Ccmpi Cne, [get_tag ptr; Cconst_int Obj.infix_tag]), ++ ptr, ++ Cop (Csuba, [ptr; ++ Cop (Cmuli, [get_size ptr (* == Infix_offset_val(ptr) *); ++ Cconst_int size_addr])])) ++ in ++ let not_too_small = Cop (Ccmpi Cge, [field_index; Cconst_int 0]) in ++ let not_too_big = Cop (Ccmpi Clt, [field_index; get_size ptr]) in ++ let failure = ++ Cop (Cextcall ("caml_field_access_out_of_bounds_error", typ_addr, false, ++ Debuginfo.none), ++ [ptr; field_index]) ++ in ++ Cifthenelse (not_too_small, ++ Cifthenelse (not_too_big, ++ if_success, ++ failure), ++ failure) ++ + (* Array indexing *) + + let log2_size_addr = Misc.log2 size_addr +@@ -1550,13 +1586,18 @@ and transl_prim_1 p arg dbg = + return_unit(remove_unit (transl arg)) + (* Heap operations *) + | Pfield n -> +- get_field (transl arg) n ++ let ptr = transl arg in ++ let body = get_field ptr n in ++ check_field_access ptr n body + | Pfloatfield n -> + let ptr = transl arg in +- box_float( +- Cop(Cload Double_u, +- [if n = 0 then ptr +- else Cop(Cadda, [ptr; Cconst_int(n * size_float)])])) ++ let body = ++ box_float( ++ Cop(Cload Double_u, ++ [if n = 0 then ptr ++ else Cop(Cadda, [ptr; Cconst_int(n * size_float)])])) ++ in ++ check_field_access ptr n body + | Pint_as_pointer -> + Cop(Cadda, [transl arg; Cconst_int (-1)]) + (* Exceptions *) +@@ -1649,20 +1690,25 @@ and transl_prim_1 p arg dbg = + and transl_prim_2 p arg1 arg2 dbg = + match p with + (* Heap operations *) +- Psetfield(n, ptr) -> +- if ptr then +- return_unit(Cop(Cextcall("caml_modify", typ_void, false,Debuginfo.none), +- [field_address (transl arg1) n; transl arg2])) +- else +- return_unit(set_field (transl arg1) n (transl arg2)) ++ Psetfield(n, is_ptr) -> ++ let ptr = transl arg1 in ++ let body = ++ if is_ptr then ++ Cop(Cextcall("caml_modify", typ_void, false,Debuginfo.none), ++ [field_address ptr n; transl arg2]) ++ else ++ set_field ptr n (transl arg2) ++ in ++ check_field_access ptr n (return_unit body) + | Psetfloatfield n -> + let ptr = transl arg1 in +- return_unit( ++ let body = + Cop(Cstore Double_u, + [if n = 0 then ptr + else Cop(Cadda, [ptr; Cconst_int(n * size_float)]); +- transl_unbox_float arg2])) +- ++ transl_unbox_float arg2]) ++ in ++ check_field_access ptr n (return_unit body) + (* Boolean operations *) + | Psequand -> + Cifthenelse(test_bool(transl arg1), transl arg2, Cconst_int 1) +diff --git a/asmrun/fail.c b/asmrun/fail.c +index cb2c1cb..4f67c74 100644 +--- a/asmrun/fail.c ++++ b/asmrun/fail.c +@@ -15,6 +15,7 @@ + + #include <stdio.h> + #include <signal.h> ++#include <assert.h> + #include "alloc.h" + #include "fail.h" + #include "io.h" +@@ -180,3 +181,20 @@ int caml_is_special_exception(value exn) { + || exn == (value) caml_exn_Assert_failure + || exn == (value) caml_exn_Undefined_recursive_module; + } ++ ++void caml_field_access_out_of_bounds_error(value v_block, intnat index) ++{ ++ assert(Is_block(v_block)); ++ fprintf(stderr, "Fatal error: out-of-bounds access to field %ld ", index); ++ fprintf(stderr, "of block at %p (%s, size %ld, tag %d)\n", ++ (void*) v_block, ++ Is_young(v_block) ? "in minor heap" ++ : Is_in_heap(v_block) ? "in major heap" ++ : Is_in_value_area(v_block) ? "in static data" ++ : "out-of-heap", ++ (long) Wosize_val(v_block), (int) Tag_val(v_block)); ++ fflush(stderr); ++ /* This error may have occurred in places where it is not reasonable to ++ attempt to continue. */ ++ abort(); ++} diff --git a/experimental/frisch/extension_points.txt b/experimental/frisch/extension_points.txt index 7d87a06ac..f9d4e774a 100644 --- a/experimental/frisch/extension_points.txt +++ b/experimental/frisch/extension_points.txt @@ -78,10 +78,11 @@ Attributes on items: let x1 = ... [@@id1] [@@id2] and x2 = ... [@@id3] [@@id4] - The [@@id s] form, when used at the beginning of a signature or - structure, or after a double semi-colon (;;), defines an attribute - which stands as a stand-alone signature or structure item (not - attached to another item). +Floating attributes: + + The [@@@id s] form defines an attribute which stands as a + stand-alone signature or structure item (not attached to another + item). Example: @@ -89,13 +90,13 @@ Attributes on items: [@@id1] type t [@@id2] - ;; [@@id3] [@@id4] - ;; [@@id5] + [@@@id3] [@@@id4] + [@@@id5] type s [@@id6] end - Here, id1, id3, id4, id5 are stand-alone attributes, while + Here, id1, id3, id4, id5 are floating attributes, while id2 is attached to the type t and id6 is attached to the type s. === Extension nodes @@ -121,6 +122,7 @@ As other structure item, signature item, class field or class type field, attributes can be attached to a [%%id s] extension node. + === Alternative syntax for attributes and extensions on specific kinds of nodes All expression constructions starting with a keyword (EXPR = KW REST) support an @@ -164,6 +166,10 @@ begin[@foo] ... end ==== (begin ... end)[@foo] match%foo e with ... ==== [%foo match e with ...] +The let-binding form of structure items also supports this form: + +let%foo x = ... ==== [%%foo let x = ...] + === Quoted strings Quoted strings gives a different syntax to write string literals in @@ -249,9 +255,21 @@ to represent attributes. It is now possible to start a signature or a structure with a ";;" token and to have two successive ";;" tokens. Rationale: - It makes it possible to always prefix a "standalone" attribute by ";;" independently - from its context (this will work at the beginning of the signature/structure and after - another item finished with ";;"). + In an intermediate version of this branch, floating attributes shared + the same syntax as item attributes, with the constraints that they + had to appear either at the beginning of their structure or signature, + or after ";;". The relaxation above made is possible to always prefix + a floating attributes by ";;" independently of its context. + + Floating attributes now have a custom syntax [@@@id], but this changes + is harmless, and the same argument holds for toplevel expressions: + it is always possile to write: + + ;; print_endline "bla";; + + without having to care about whether the previous structure item + ends with ";;" or not. + -- Relaxing the syntax for exception declarations @@ -507,9 +525,9 @@ the revised syntax to distinguish "A x y" from "A (x, y)" (the second one being wrapped in an extra fake tuple) and get a proper error message if "A (x, y)" was used with a constructor expecting two arguments. -If really required, the same feature could be restored by storing the -flag as an attribute (with very light support in the type-checker), in -order to avoid polluting the official Parsetree. +The feature has been preserved, but the information that a +Pexp_construct/Ppat_constructo node has an "exact arity" is now +propagated used as am attribute "ocaml.explicit_arity" on that node. --- Split Pexp_function into Pexp_function/Pexp_fun diff --git a/lex/Makefile b/lex/Makefile index f54de0020..cb5df8b41 100644 --- a/lex/Makefile +++ b/lex/Makefile @@ -13,7 +13,7 @@ # The lexer generator CAMLC=../boot/ocamlrun ../boot/ocamlc -strict-sequence -nostdlib -I ../boot CAMLOPT=../boot/ocamlrun ../ocamlopt -nostdlib -I ../stdlib -COMPFLAGS=-w +33..39 -warn-error A -bin-annot +COMPFLAGS=-w +33..39 -warn-error A -bin-annot -safe-string CAMLYACC=../boot/ocamlyacc YACCFLAGS=-v CAMLLEX=../boot/ocamlrun ../boot/ocamllex @@ -34,7 +34,7 @@ ocamllex.opt: $(OBJS:.cmo=.cmx) clean:: rm -f ocamllex ocamllex.opt - rm -f *.cmo *.cmi *.cmx *.o *~ + rm -f *.cmo *.cmi *.cmx *.cmt *.cmti *.o *~ parser.ml parser.mli: parser.mly $(CAMLYACC) $(YACCFLAGS) parser.mly diff --git a/lex/common.ml b/lex/common.ml index 13b48fac6..9b86ba111 100644 --- a/lex/common.ml +++ b/lex/common.ml @@ -47,7 +47,7 @@ let update_tracker tr = fprintf tr.oc "# %d \"%s\"\n" (tr.cur_line+1) tr.file; ;; -let copy_buffer = String.create 1024 +let copy_buffer = Bytes.create 1024 let copy_chars_unix ic oc start stop = let n = ref (stop - start) in diff --git a/lex/compact.ml b/lex/compact.ml index 1f620ab8d..f468a557d 100644 --- a/lex/compact.ml +++ b/lex/compact.ml @@ -92,13 +92,13 @@ type t_compact = mutable c_last_used : int ; } let create_compact () = - { c_trans = Array.create 1024 0 ; - c_check = Array.create 1024 (-1) ; + { c_trans = Array.make 1024 0 ; + c_check = Array.make 1024 (-1) ; c_last_used = 0 ; } let reset_compact c = - c.c_trans <- Array.create 1024 0 ; - c.c_check <- Array.create 1024 (-1) ; + c.c_trans <- Array.make 1024 0 ; + c.c_check <- Array.make 1024 (-1) ; c.c_last_used <- 0 (* One compacted table for transitions, one other for memory actions *) @@ -110,9 +110,9 @@ let grow_compact c = let old_trans = c.c_trans and old_check = c.c_check in let n = Array.length old_trans in - c.c_trans <- Array.create (2*n) 0; + c.c_trans <- Array.make (2*n) 0; Array.blit old_trans 0 c.c_trans 0 c.c_last_used; - c.c_check <- Array.create (2*n) (-1); + c.c_check <- Array.make (2*n) (-1); Array.blit old_check 0 c.c_check 0 c.c_last_used let do_pack state_num orig compact = @@ -142,8 +142,8 @@ let do_pack state_num orig compact = (base, default) let pack_moves state_num move_t = - let move_v = Array.create 257 0 - and move_m = Array.create 257 0 in + let move_v = Array.make 257 0 + and move_m = Array.make 257 0 in for i = 0 to 256 do let act,c = move_t.(i) in move_v.(i) <- (match act with Backtrack -> -1 | Goto n -> n) ; @@ -175,12 +175,12 @@ type lex_tables = let compact_tables state_v = let n = Array.length state_v in - let base = Array.create n 0 - and backtrk = Array.create n (-1) - and default = Array.create n 0 - and base_code = Array.create n 0 - and backtrk_code = Array.create n 0 - and default_code = Array.create n 0 in + let base = Array.make n 0 + and backtrk = Array.make n (-1) + and default = Array.make n 0 + and base_code = Array.make n 0 + and backtrk_code = Array.make n 0 + and default_code = Array.make n 0 in for i = 0 to n - 1 do match state_v.(i) with | Perform (n,c) -> diff --git a/lex/cset.ml b/lex/cset.ml index 8c3d176fa..f4581ba37 100644 --- a/lex/cset.ml +++ b/lex/cset.ml @@ -81,7 +81,7 @@ let complement s = diff all_chars s let env_to_array env = match env with | [] -> assert false | (_,x)::rem -> - let res = Array.create 257 x in + let res = Array.make 257 x in List.iter (fun (c,y) -> List.iter diff --git a/lex/lexgen.ml b/lex/lexgen.ml index 035e3fe6c..503b08fa4 100644 --- a/lex/lexgen.ml +++ b/lex/lexgen.ml @@ -589,7 +589,7 @@ let rec firstpos = function (* Berry-sethi followpos *) let followpos size entry_list = - let v = Array.create size TransSet.empty in + let v = Array.make size TransSet.empty in let rec fill s = function | Empty|Action _|Tag _ -> () | Chars (n,_) -> v.(n) <- s @@ -1132,7 +1132,7 @@ let make_tag_entry id start act a r = match a with | _ -> r let extract_tags l = - let envs = Array.create (List.length l) TagMap.empty in + let envs = Array.make (List.length l) TagMap.empty in List.iter (fun (act,m,_) -> envs.(act) <- @@ -1186,7 +1186,7 @@ let make_dfa lexdef = done ; eprintf "%d states\n" !next_state_num ; *) - let actions = Array.create !next_state_num (Perform (0,[])) in + let actions = Array.make !next_state_num (Perform (0,[])) in List.iter (fun (act, i) -> actions.(i) <- act) states; (* Useless state reset, so as to restrict GC roots *) reset_state () ; diff --git a/lex/output.ml b/lex/output.ml index 2e7700257..638260c2b 100644 --- a/lex/output.ml +++ b/lex/output.ml @@ -77,7 +77,7 @@ let output_entry sourcefile ic oc has_refill oci e = output_args e.auto_args (fun oc x -> if x > 0 then - fprintf oc "lexbuf.Lexing.lex_mem <- Array.create %d (-1) ; " x) + fprintf oc "lexbuf.Lexing.lex_mem <- Array.make %d (-1) ; " x) e.auto_mem_size (output_memory_actions " ") init_moves e.auto_name diff --git a/lex/outputbis.ml b/lex/outputbis.ml index 333cbc2a2..709ec0eec 100644 --- a/lex/outputbis.ml +++ b/lex/outputbis.ml @@ -20,7 +20,7 @@ let output_auto_defs oc has_refill = output_string oc "let __ocaml_lex_init_lexbuf lexbuf mem_size =\ \n let pos = lexbuf.Lexing.lex_curr_pos in\ -\n lexbuf.Lexing.lex_mem <- Array.create mem_size (-1) ;\ +\n lexbuf.Lexing.lex_mem <- Array.make mem_size (-1) ;\ \n lexbuf.Lexing.lex_start_pos <- pos ;\ \n lexbuf.Lexing.lex_last_pos <- pos ;\ \n lexbuf.Lexing.lex_last_action <- -1\ diff --git a/lex/parser.mly b/lex/parser.mly index f0742e38e..459b78707 100644 --- a/lex/parser.mly +++ b/lex/parser.mly @@ -65,7 +65,8 @@ let as_cset = function %% lexer_definition: - header named_regexps refill_handler Trule definition other_definitions header Tend + header named_regexps refill_handler Trule definition other_definitions + header Tend { {header = $1; refill_handler = $3; entrypoints = $5 :: List.rev $6; diff --git a/lex/table.ml b/lex/table.ml index fb5a6128e..715d90758 100644 --- a/lex/table.ml +++ b/lex/table.ml @@ -15,12 +15,12 @@ type 'a t = {mutable next : int ; mutable data : 'a array} let default_size = 32 ;; -let create x = {next = 0 ; data = Array.create default_size x} +let create x = {next = 0 ; data = Array.make default_size x} and reset t = t.next <- 0 ;; let incr_table table new_size = - let t = Array.create new_size table.data.(0) in + let t = Array.make new_size table.data.(0) in Array.blit table.data 0 t 0 (Array.length table.data) ; table.data <- t diff --git a/man/Makefile b/man/Makefile index 916ea24a8..c1c2df375 100644 --- a/man/Makefile +++ b/man/Makefile @@ -12,10 +12,13 @@ include ../config/Makefile -DIR=$(MANDIR)/man$(MANEXT) +INSTALL_DIR=$(DESTDIR)$(MANDIR)/man$(MANEXT) install: - for i in *.m; do cp $$i $(DIR)/`basename $$i .m`.$(MANEXT); done - echo '.so man$(MANEXT)/ocamlc.$(MANEXT)' > $(DIR)/ocamlc.opt.$(MANEXT) - echo '.so man$(MANEXT)/ocamlopt.$(MANEXT)' > $(DIR)/ocamlopt.opt.$(MANEXT) - echo '.so man$(MANEXT)/ocamlcp.$(MANEXT)' > $(DIR)/ocamloptp.$(MANEXT) + for i in *.m; do cp $$i $(INSTALL_DIR)/`basename $$i .m`.$(MANEXT); done + echo '.so man$(MANEXT)/ocamlc.$(MANEXT)' \ + > $(INSTALL_DIR)/ocamlc.opt.$(MANEXT) + echo '.so man$(MANEXT)/ocamlopt.$(MANEXT)' \ + > $(INSTALL_DIR)/ocamlopt.opt.$(MANEXT) + echo '.so man$(MANEXT)/ocamlcp.$(MANEXT)' \ + > $(INSTALL_DIR)/ocamloptp.$(MANEXT) diff --git a/man/ocaml.m b/man/ocaml.m index b393b771c..79f81df0a 100644 --- a/man/ocaml.m +++ b/man/ocaml.m @@ -133,11 +133,18 @@ window. Do not include the standard library directory in the list of directories searched for source and compiled files. .TP +.BI \-open \ module +Opens the given module before starting the toplevel. If several +.B \-open +options are given, they are processed in order, just as if +the statements open! module1;; ... open! moduleN;; were input. +.TP .BI \-ppx \ command After parsing, pipe the abstract syntax tree through the preprocessor .IR command . -The format of the input and output of the preprocessor -are not yet documented. +The module +.BR Ast_mapper (3) +implements the external interface of a preprocessor. .TP .B \-principal Check information path during type-checking, to make sure that all @@ -157,6 +164,12 @@ Allow arbitrary recursive types during type-checking. By default, only recursive types where the recursion goes through an object type are supported. .TP +.B \-safe\-string +Enforce the separation between types +.BR string \ and\ bytes , +thereby making strings read-only. This will become the default in +a future version of OCaml. +.TP .B \-short\-paths When a type is visible under several module-paths, use the shortest one when printing the type's name in inferred interfaces and error and @@ -177,13 +190,20 @@ constructs). Programs compiled with are therefore slightly faster, but unsafe: anything can happen if the program accesses an array or string outside of its bounds. .TP +.B \-unsafe\-string +Identify the types +.BR string \ and\ bytes , +thereby making strings writable. For reasons of backward compatibility, +this is the default setting for the moment, but this will change in a future +version of OCaml. +.TP .B \-version Print version string and exit. .TP .B \-vnum Print short version number and exit. .TP -.BI \-w \ warning-list +.BI \-w \ warning\-list Enable or disable warnings according to the argument .IR warning-list . See @@ -192,7 +212,7 @@ for the syntax of the .I warning\-list argument. .TP -.BI \-warn-error \ warning-list +.BI \-warn\-error \ warning\-list Mark as fatal the warnings described by the argument .IR warning\-list . Note that a warning is not triggered (and does not trigger an error) if diff --git a/man/ocamlc.m b/man/ocamlc.m index 1d3c56faa..090f1c686 100644 --- a/man/ocamlc.m +++ b/man/ocamlc.m @@ -396,6 +396,9 @@ bytecode executables produced with the option .B ocamlc\ \-use\-runtime .IR runtime-name . .TP +.B \-no-alias-deps +Do not record dependencies for module aliases. +.TP .B \-no\-app\-funct Deactivates the applicative behaviour of functors. With this option, each functor application generates new types in its result and @@ -446,6 +449,18 @@ packed object file produced. If the .B \-output\-obj option is given, specify the name of the output file produced. +This can also be used when compiling an interface or implementation +file, without linking, in which case it sets the name of the cmi or +cmo file, and also sets the module name to the file name up to the +first dot. +.TP +.BI \-open \ module +Opens the given module before processing the interface or +implementation files. If several +.B \-open +options are given, they are processed in order, just as if +the statements open! module1;; ... open! moduleN;; were added +at the top of each file. .TP .B \-output\-obj Cause the linker to produce a C object file instead of a bytecode @@ -487,8 +502,9 @@ implementation (.ml) file. .BI \-ppx \ command After parsing, pipe the abstract syntax tree through the preprocessor .IR command . -The format of the input and output of the preprocessor -are not yet documented. +The module +.BR Ast_mapper (3) +implements the external interface of a preprocessor. .TP .B \-principal Check information path during type-checking, to make sure that all @@ -519,6 +535,12 @@ then the .B d suffix is supported and gives a debug version of the runtime. .TP +.B \-safe\-string +Enforce the separation between types +.BR string \ and\ bytes , +thereby making strings read-only. This will become the default in +a future version of OCaml. +.TP .B \-short\-paths When a type is visible under several module-paths, use the shortest one when printing the type's name in inferred interfaces and error and @@ -541,6 +563,13 @@ are therefore slightly faster, but unsafe: anything can happen if the program accesses an array or string outside of its bounds. .TP +.B \-unsafe\-string +Identify the types +.BR string \ and\ bytes , +thereby making strings writable. For reasons of backward compatibility, +this is the default setting for the moment, but this will change in a future +version of OCaml. +.TP .BI \-use\-runtime \ runtime\-name Generate a bytecode executable file that can be executed on the custom runtime system @@ -773,7 +802,7 @@ mutually recursive types. \ \ Unused constructor. 38 -\ \ Unused exception constructor. +\ \ Unused extension constructor. 39 \ \ Unused rec flag. @@ -875,7 +904,7 @@ Note: it is not recommended to use the .B \-warn\-error option in production code, because it will almost certainly prevent compiling your program with later versions of OCaml when they add new -warnings. +warnings or modify existing warnings. The default setting is .B \-warn\-error\ -a (all warnings are non-fatal). diff --git a/man/ocamldoc.m b/man/ocamldoc.m index b25833aec..ca0a23348 100644 --- a/man/ocamldoc.m +++ b/man/ocamldoc.m @@ -181,7 +181,7 @@ Several .B -load options can be given. .TP -.BI \-m flags +.BI \-m \ flags Specify merge options between interfaces and implementations. .I flags can be one or several of the following characters: @@ -442,11 +442,11 @@ option: Generate man pages only for modules, module types, classes and class types, instead of pages for all elements. .TP -.BI \-man\-suffix suffix +.BI \-man\-suffix \ suffix Set the suffix used for generated man filenames. Default is o, as in .IR List.o . .TP -.BI \-man\-section section +.BI \-man\-section \ section Set the section number used for generated man filenames. Default is 3. diff --git a/man/ocamlopt.m b/man/ocamlopt.m index d00cbf99d..fb20ca99c 100644 --- a/man/ocamlopt.m +++ b/man/ocamlopt.m @@ -316,6 +316,9 @@ flag forces all subsequent links of programs involving that library to link all the modules contained in the library. .TP +.B \-no-alias-deps +Do not record dependencies for module aliases. +.TP .B \-no\-app\-funct Deactivates the applicative behaviour of functors. With this option, each functor application generates new types in its result and @@ -364,6 +367,18 @@ If the option is given, specify the name of the output file produced. If the .B \-shared option is given, specify the name of plugin file produced. +This can also be used when compiling an interface or implementation +file, without linking, in which case it sets the name of the cmi or +cmo file, and also sets the module name to the file name up to the +first dot. +.TP +.BI \-open \ module +Opens the given module before processing the interface or +implementation files. If several +.B \-open +options are given, they are processed in order, just as if +the statements open! module1;; ... open! moduleN;; were added +at the top of each file. .TP .B \-output\-obj Cause the linker to produce a C object file instead of an executable @@ -442,8 +457,9 @@ errors, the intermediate file is deleted afterwards. .BI \-ppx \ command After parsing, pipe the abstract syntax tree through the preprocessor .IR command . -The format of the input and output of the preprocessor -are not yet documented. +The module +.BR Ast_mapper (3) +implements the external interface of a preprocessor. .TP .B \-principal Check information path during type-checking, to make sure that all @@ -475,6 +491,12 @@ code for the source file is saved in the file .IR x .s. .TP +.B \-safe\-string +Enforce the separation between types +.BR string \ and\ bytes , +thereby making strings read-only. This will become the default in +a future version of OCaml. +.TP .B \-shared Build a plugin (usually .cmxs) that can be dynamically loaded with the @@ -522,6 +544,13 @@ program or continue with an unspecified result instead of raising a .B Division_by_zero exception. .TP +.B \-unsafe\-string +Identify the types +.BR string \ and\ bytes , +thereby making strings writable. For reasons of backward compatibility, +this is the default setting for the moment, but this will change in a future +version of OCaml. +.TP .B \-v Print the version number of the compiler and the location of the standard library directory, then exit. @@ -563,7 +592,7 @@ Note: it is not recommended to use the .B \-warn\-error option in production code, because it will almost certainly prevent compiling your program with later versions of OCaml when they add new -warnings. +warnings or modify existing warnings. The default setting is .B \-warn\-error\ -a (all warnings are non-fatal). @@ -631,6 +660,37 @@ Generate SPARC version 9 code. The default is to generate code for SPARC version 7, which runs on all SPARC processors. +.SH OPTIONS FOR THE ARM ARCHITECTURE +The ARM code generator supports the following additional options: +.TP +.B \-farch=armv4|armv5|armv5te|armv6|armv6t2|armv7 +Select the ARM target architecture +.TP +.B \-ffpu=soft|vfpv2|vfpv3\-d16|vfpv3 +Select the floating-point hardware +.TP +.B \-fPIC +Generate position-independent machine code. +.TP +.B \-fno\-PIC +Generate position-dependent machine code. This is the default. +.TP +.B \-fthumb +Enable Thumb/Thumb-2 code generation +.TP +.B \-fno\-thumb +Disable Thumb/Thumb-2 code generation +.P +The default values for target architecture, floating-point hardware +and thumb usage were selected at configure-time when building +.B ocamlopt +itself. This configuration can be inspected using +.BR ocamlopt\ \-config . +Target architecture depends on the "model" setting, while +floating-point hardware and thumb support are determined from the ABI +setting in "system" ( +.BR linux_eabi or linux_eabihf ). + .SH SEE ALSO .BR ocamlc (1). .br diff --git a/ocamlbuild/.depend b/ocamlbuild/.depend index 5e0c7e660..3b67d873d 100644 --- a/ocamlbuild/.depend +++ b/ocamlbuild/.depend @@ -1,6 +1,6 @@ bool.cmi : command.cmi : tags.cmi signatures.cmi -configuration.cmi : tags.cmi pathname.cmi +configuration.cmi : tags.cmi pathname.cmi loc.cmi digest_cache.cmi : discard_printf.cmi : display.cmi : tags.cmi @@ -48,13 +48,15 @@ tools.cmi : tags.cmi pathname.cmi bool.cmo : bool.cmi bool.cmx : bool.cmi command.cmo : tags.cmi shell.cmi param_tags.cmi my_unix.cmi my_std.cmi \ - log.cmi lexers.cmi command.cmi + log.cmi lexers.cmi const.cmo command.cmi command.cmx : tags.cmx shell.cmx param_tags.cmx my_unix.cmx my_std.cmx \ - log.cmx lexers.cmx command.cmi + log.cmx lexers.cmx const.cmx command.cmi configuration.cmo : tags.cmi param_tags.cmi my_std.cmi log.cmi loc.cmi \ - lexers.cmi glob.cmi configuration.cmi + lexers.cmi glob.cmi const.cmo configuration.cmi configuration.cmx : tags.cmx param_tags.cmx my_std.cmx log.cmx loc.cmx \ - lexers.cmx glob.cmx configuration.cmi + lexers.cmx glob.cmx const.cmx configuration.cmi +const.cmo : +const.cmx : digest_cache.cmo : shell.cmi pathname.cmi options.cmi my_unix.cmi my_std.cmi \ digest_cache.cmi digest_cache.cmx : shell.cmx pathname.cmx options.cmx my_unix.cmx my_std.cmx \ @@ -67,8 +69,10 @@ exit_codes.cmo : exit_codes.cmi exit_codes.cmx : exit_codes.cmi fda.cmo : pathname.cmi options.cmi log.cmi hygiene.cmi fda.cmi fda.cmx : pathname.cmx options.cmx log.cmx hygiene.cmx fda.cmi -findlib.cmo : my_unix.cmi my_std.cmi lexers.cmi command.cmi findlib.cmi -findlib.cmx : my_unix.cmx my_std.cmx lexers.cmx command.cmx findlib.cmi +findlib.cmo : my_unix.cmi my_std.cmi lexers.cmi const.cmo command.cmi \ + findlib.cmi +findlib.cmx : my_unix.cmx my_std.cmx lexers.cmx const.cmx command.cmx \ + findlib.cmi flags.cmo : tags.cmi param_tags.cmi log.cmi command.cmi bool.cmi flags.cmi flags.cmx : tags.cmx param_tags.cmx log.cmx command.cmx bool.cmx flags.cmi glob.cmo : my_std.cmi glob_lexer.cmi glob_ast.cmi bool.cmi glob.cmi @@ -93,14 +97,14 @@ main.cmo : tools.cmi tags.cmi solver.cmi slurp.cmi shell.cmi rule.cmi \ resource.cmi report.cmi plugin.cmi pathname.cmi param_tags.cmi \ options.cmi ocaml_utils.cmi ocaml_specific.cmi ocaml_dependencies.cmi \ my_unix.cmi my_std.cmi log.cmi loc.cmi lexers.cmi hooks.cmi flags.cmi \ - fda.cmi exit_codes.cmi digest_cache.cmi configuration.cmi command.cmi \ - main.cmi + fda.cmi exit_codes.cmi digest_cache.cmi const.cmo configuration.cmi \ + command.cmi main.cmi main.cmx : tools.cmx tags.cmx solver.cmx slurp.cmx shell.cmx rule.cmx \ resource.cmx report.cmx plugin.cmx pathname.cmx param_tags.cmx \ options.cmx ocaml_utils.cmx ocaml_specific.cmx ocaml_dependencies.cmx \ my_unix.cmx my_std.cmx log.cmx loc.cmx lexers.cmx hooks.cmx flags.cmx \ - fda.cmx exit_codes.cmx digest_cache.cmx configuration.cmx command.cmx \ - main.cmi + fda.cmx exit_codes.cmx digest_cache.cmx const.cmx configuration.cmx \ + command.cmx main.cmi my_std.cmo : my_std.cmi my_std.cmx : my_std.cmi my_unix.cmo : my_std.cmi my_unix.cmi @@ -132,9 +136,11 @@ ocaml_tools.cmx : tools.cmx tags.cmx rule.cmx pathname.cmx options.cmx \ ocaml_utils.cmx ocaml_compiler.cmx my_std.cmx flags.cmx command.cmx \ ocaml_tools.cmi ocaml_utils.cmo : tools.cmi tags.cmi pathname.cmi param_tags.cmi options.cmi \ - my_std.cmi log.cmi lexers.cmi flags.cmi command.cmi ocaml_utils.cmi + my_std.cmi log.cmi lexers.cmi flags.cmi const.cmo command.cmi \ + ocaml_utils.cmi ocaml_utils.cmx : tools.cmx tags.cmx pathname.cmx param_tags.cmx options.cmx \ - my_std.cmx log.cmx lexers.cmx flags.cmx command.cmx ocaml_utils.cmi + my_std.cmx log.cmx lexers.cmx flags.cmx const.cmx command.cmx \ + ocaml_utils.cmi ocamlbuild.cmo : ocamlbuild_unix_plugin.cmi ocamlbuild.cmi ocamlbuild.cmx : ocamlbuild_unix_plugin.cmx ocamlbuild.cmi ocamlbuild_config.cmo : @@ -152,9 +158,9 @@ ocamlbuild_where.cmx : ocamlbuild_config.cmx ocamlbuild_where.cmi ocamlbuildlight.cmo : ocamlbuildlight.cmi ocamlbuildlight.cmx : ocamlbuildlight.cmi options.cmo : shell.cmi ocamlbuild_where.cmi ocamlbuild_config.cmo \ - my_std.cmi log.cmi lexers.cmi command.cmi options.cmi + my_std.cmi log.cmi lexers.cmi const.cmo command.cmi options.cmi options.cmx : shell.cmx ocamlbuild_where.cmx ocamlbuild_config.cmx \ - my_std.cmx log.cmx lexers.cmx command.cmx options.cmi + my_std.cmx log.cmx lexers.cmx const.cmx command.cmx options.cmi param_tags.cmo : tags.cmi my_std.cmi log.cmi loc.cmi lexers.cmi \ param_tags.cmi param_tags.cmx : tags.cmx my_std.cmx log.cmx loc.cmx lexers.cmx \ @@ -165,10 +171,10 @@ pathname.cmx : shell.cmx options.cmx my_unix.cmx my_std.cmx log.cmx glob.cmx \ pathname.cmi plugin.cmo : tools.cmi tags.cmi shell.cmi rule.cmi pathname.cmi \ param_tags.cmi options.cmi ocamlbuild_where.cmi my_unix.cmi my_std.cmi \ - log.cmi command.cmi plugin.cmi + log.cmi const.cmo command.cmi plugin.cmi plugin.cmx : tools.cmx tags.cmx shell.cmx rule.cmx pathname.cmx \ param_tags.cmx options.cmx ocamlbuild_where.cmx my_unix.cmx my_std.cmx \ - log.cmx command.cmx plugin.cmi + log.cmx const.cmx command.cmx plugin.cmi ppcache.cmo : shell.cmi pathname.cmi my_std.cmi log.cmi command.cmi \ ppcache.cmi ppcache.cmx : shell.cmx pathname.cmx my_std.cmx log.cmx command.cmx \ @@ -177,10 +183,10 @@ report.cmo : solver.cmi resource.cmi my_std.cmi log.cmi glob.cmi report.cmi report.cmx : solver.cmx resource.cmx my_std.cmx log.cmx glob.cmx report.cmi resource.cmo : slurp.cmi shell.cmi pathname.cmi options.cmi my_unix.cmi \ my_std.cmi log.cmi lexers.cmi glob_ast.cmi glob.cmi digest_cache.cmi \ - command.cmi resource.cmi + const.cmo command.cmi resource.cmi resource.cmx : slurp.cmx shell.cmx pathname.cmx options.cmx my_unix.cmx \ my_std.cmx log.cmx lexers.cmx glob_ast.cmx glob.cmx digest_cache.cmx \ - command.cmx resource.cmi + const.cmx command.cmx resource.cmi rule.cmo : shell.cmi resource.cmi pathname.cmi options.cmi my_std.cmi \ log.cmi digest_cache.cmi command.cmi rule.cmi rule.cmx : shell.cmx resource.cmx pathname.cmx options.cmx my_std.cmx \ diff --git a/ocamlbuild/Makefile b/ocamlbuild/Makefile index ec3b999ea..b40d0eada 100644 --- a/ocamlbuild/Makefile +++ b/ocamlbuild/Makefile @@ -12,16 +12,18 @@ include ../config/Makefile -OCAMLRUN = ../boot/ocamlrun -OCAMLC = ../ocamlcomp.sh -OCAMLOPT = ../ocamlcompopt.sh -OCAMLDEP = $(OCAMLRUN) ../tools/ocamldep -OCAMLLEX = $(OCAMLRUN) ../boot/ocamllex -CP = cp -COMPFLAGS= -warn-error A -w L -w R -w Z -I ../otherlibs/$(UNIXLIB) +ROOTDIR = .. +OCAMLRUN = $(ROOTDIR)/boot/ocamlrun +OCAMLC = $(OCAMLRUN) $(ROOTDIR)/ocamlc -nostdlib -I $(ROOTDIR)/stdlib +OCAMLOPT = $(OCAMLRUN) $(ROOTDIR)/ocamlopt -nostdlib -I $(ROOTDIR)/stdlib +OCAMLDEP = $(OCAMLRUN) $(ROOTDIR)/tools/ocamldep +OCAMLLEX = $(OCAMLRUN) $(ROOTDIR)/boot/ocamllex +CP = cp +COMPFLAGS= -warn-error A -w L -w R -w Z -I ../otherlibs/$(UNIXLIB) -safe-string LINKFLAGS= -I ../otherlibs/$(UNIXLIB) PACK_CMO=\ + const.cmo \ loc.cmo \ discard_printf.cmo \ signatures.cmi \ @@ -72,6 +74,7 @@ EXTRA_CMO=\ PACK_CMX=$(PACK_CMO:.cmo=.cmx) EXTRA_CMX=$(EXTRA_CMO:.cmo=.cmx) +EXTRA_CMI=$(EXTRA_CMO:.cmo=.cmi) INSTALL_LIB=\ ocamlbuildlib.cma \ @@ -85,6 +88,9 @@ INSTALL_LIB_OPT=\ ocamlbuild_pack.cmx \ $(EXTRA_CMO:.cmo=.cmx) $(EXTRA_CMO:.cmo=.$(O)) +INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR)/ocamlbuild +INSTALL_BINDIR=$(DESTDIR)$(BINDIR) + all: ocamlbuild.byte ocamlbuildlib.cma # ocamlbuildlight.byte ocamlbuildlightlib.cma allopt: ocamlbuild.native ocamlbuildlib.cmxa @@ -157,19 +163,19 @@ beforedepend:: glob_lexer.ml # Installation install: - $(CP) ocamlbuild.byte $(BINDIR)/ocamlbuild$(EXE) - $(CP) ocamlbuild.byte $(BINDIR)/ocamlbuild.byte$(EXE) - mkdir -p $(LIBDIR)/ocamlbuild - $(CP) $(INSTALL_LIB) $(LIBDIR)/ocamlbuild/ + $(CP) ocamlbuild.byte $(INSTALL_BINDIR)/ocamlbuild$(EXE) + $(CP) ocamlbuild.byte $(INSTALL_BINDIR)/ocamlbuild.byte$(EXE) + mkdir -p $(INSTALL_LIBDIR) + $(CP) $(INSTALL_LIB) $(INSTALL_LIBDIR)/ installopt: if test -f ocamlbuild.native; then $(MAKE) installopt_really; fi installopt_really: - $(CP) ocamlbuild.native $(BINDIR)/ocamlbuild$(EXE) - $(CP) ocamlbuild.native $(BINDIR)/ocamlbuild.native$(EXE) - mkdir -p $(LIBDIR)/ocamlbuild - $(CP) $(INSTALL_LIB_OPT) $(LIBDIR)/ocamlbuild/ + $(CP) ocamlbuild.native $(INSTALL_BINDIR)/ocamlbuild$(EXE) + $(CP) ocamlbuild.native $(INSTALL_BINDIR)/ocamlbuild.native$(EXE) + mkdir -p $(INSTALL_LIBDIR) + $(CP) $(INSTALL_LIB_OPT) $(INSTALL_LIBDIR)/ # The generic rules @@ -193,7 +199,11 @@ clean:: depend: beforedepend $(OCAMLDEP) *.mli *.ml > .depend +$(EXTRA_CMI): ocamlbuild_pack.cmi +$(EXTRA_CMO): ocamlbuild_pack.cmo ocamlbuild_pack.cmi +$(EXTRA_CMX): ocamlbuild_pack.cmx ocamlbuild_pack.cmi + include .depend -.PHONY: all allopt clean beforedepend +.PHONY: all allopt clean beforedepend .PHONY: install installopt installopt_really depend diff --git a/ocamlbuild/Makefile.noboot b/ocamlbuild/Makefile.noboot index 0679e0ccd..313e56891 100644 --- a/ocamlbuild/Makefile.noboot +++ b/ocamlbuild/Makefile.noboot @@ -17,11 +17,13 @@ include ../config/Makefile # Various commands and dir ########################## -CAMLRUN = ../boot/ocamlrun -OCAMLC = ../ocamlcomp.sh -OCAMLOPT = ../ocamlcompopt.sh -OCAMLDEP = $(CAMLRUN) ../tools/ocamldep -OCAMLLEX = $(CAMLRUN) ../boot/ocamllex + +ROOTDIR = .. +OCAMLRUN = $(ROOTDIR)/boot/ocamlrun +OCAMLC = $(OCAMLRUN) $(ROOTDIR)/ocamlc -nostdlib -I $(ROOTDIR)/stdlib +OCAMLOPT = $(OCAMLRUN) $(ROOTDIR)/ocamlopt -nostdlib -I $(ROOTDIR)/stdlib +OCAMLDEP = $(OCAMLRUN) $(ROOTDIR)/tools/ocamldep +OCAMLLEX = $(OCAMLRUN) $(ROOTDIR)/boot/ocamllex OCAMLLIB = $(LIBDIR) OCAMLBIN = $(BINDIR) @@ -35,10 +37,9 @@ OCAMLBUILD_LIBCMA=ocamlbuildlib.cma OCAMLBUILD_LIBCMI=ocamlbuildlib.cmi OCAMLBUILD_LIBCMXA=ocamlbuild.cmxa OCAMLBUILD_LIBA=ocamlbuild.$(A) -INSTALL_LIBDIR=$(OCAMLLIB)/ocamlbuild +INSTALL_LIBDIR=$(DESTDIR)$(OCAMLLIB)/ocamlbuild INSTALL_CUSTOMDIR=$(INSTALL_LIBDIR)/custom -INSTALL_BINDIR=$(OCAMLBIN) -INSTALL_MANODIR=$(MANDIR)/man3 +INSTALL_BINDIR=$(DESTDIR)$(OCAMLBIN) INSTALL_MLIS= INSTALL_CMIS=$(INSTALL_MLIS:.mli=.cmi) @@ -55,7 +56,7 @@ INCLUDES_NODEP= -I $(OCAMLSRCDIR)/stdlib \ INCLUDES=$(INCLUDES_DEP) $(INCLUDES_NODEP) -COMPFLAGS=$(INCLUDES) -warn-error A +COMPFLAGS=$(INCLUDES) -warn-error A -safe-string LINKFLAGS=$(INCLUDES) CMOFILES_PACK= \ diff --git a/ocamlbuild/command.ml b/ocamlbuild/command.ml index f5887cd6a..fc6e07cf4 100644 --- a/ocamlbuild/command.ml +++ b/ocamlbuild/command.ml @@ -99,10 +99,7 @@ let env_path = lazy begin Lexers.parse_environment_path in let paths = - try - parse_path (Lexing.from_string path_var) - with Lexers.Error (msg,pos) -> raise (Lexers.Error ("$PATH: " ^ msg, pos)) - in + parse_path Const.Source.path (Lexing.from_string path_var) in let norm_current_dir_name path = if path = "" then Filename.current_dir_name else path in diff --git a/ocamlbuild/configuration.ml b/ocamlbuild/configuration.ml index 551acae6d..6290e60a9 100644 --- a/ocamlbuild/configuration.ml +++ b/ocamlbuild/configuration.ml @@ -18,31 +18,35 @@ open Lexers type t = Lexers.conf -let acknowledge_config config = - let ack (tag, loc) = Param_tags.acknowledge (Some loc) tag in +let acknowledge_config source config = + let ack (tag, loc) = Param_tags.acknowledge source (Some loc) tag in List.iter (fun (_, config) -> List.iter ack config.plus_tags) config let cache = Hashtbl.create 107 let (configs, add_config) = let configs = ref [] in (fun () -> !configs), - (fun config -> - acknowledge_config config; + (fun source config -> + acknowledge_config source config; configs := config :: !configs; Hashtbl.clear cache) let parse_lexbuf ?dir source lexbuf = - lexbuf.Lexing.lex_curr_p <- - { lexbuf.Lexing.lex_curr_p with Lexing.pos_fname = source }; - let conf = Lexers.conf_lines dir lexbuf in - add_config conf + let conf = Lexers.conf_lines dir source lexbuf in + add_config source conf -let parse_string s = - parse_lexbuf (Printf.sprintf "STRING(%s)" s) (Lexing.from_string s) +let parse_string ?source s = + let source = match source with + | Some source -> source + | None -> Const.Source.configuration + in + parse_lexbuf source (lexbuf_of_string s) let parse_file ?dir file = with_input_file file begin fun ic -> - parse_lexbuf ?dir file (Lexing.from_channel ic) + let lexbuf = Lexing.from_channel ic in + set_lexbuf_fname file lexbuf; + parse_lexbuf ?dir Const.Source.file lexbuf end let key_match = Glob.eval diff --git a/ocamlbuild/configuration.mli b/ocamlbuild/configuration.mli index 1f8856aac..2bfd6bb88 100644 --- a/ocamlbuild/configuration.mli +++ b/ocamlbuild/configuration.mli @@ -18,7 +18,7 @@ (** Incorporate a newline-separated configuration string into the current configuration. Will usually raising an [Invalid_arg] with an appropriately explicit message in case of error. *) -val parse_string : string -> unit +val parse_string : ?source:Loc.source -> string -> unit (** [parse_file ?dir fn] incorporates the configuration file named [fn], prefixing its glob patterns with [dir] if given. *) diff --git a/ocamlbuild/const.ml b/ocamlbuild/const.ml new file mode 100644 index 000000000..dac877890 --- /dev/null +++ b/ocamlbuild/const.ml @@ -0,0 +1,11 @@ +module Source = struct + let file = "file" + let command_line = "command-line" + let path = "path" + let ocamlfind_query = "ocamlfind query" + let ocamldep = "ocamldep" + let target_pattern = "target pattern" + let builtin = "builtin configuration" + let configuration = "configuration" + let plugin_tag = "plugin tag" +end diff --git a/ocamlbuild/display.ml b/ocamlbuild/display.ml index 725d351bb..2e0b1e39e 100644 --- a/ocamlbuild/display.ml +++ b/ocamlbuild/display.ml @@ -51,7 +51,7 @@ type sophisticated_display = { ds_columns : int; (** Number of columns in dssplay *) mutable ds_jobs : int; (** Number of jobs launched or cached *) mutable ds_jobs_cached : int; (** Number of jobs cached *) - ds_tagline : string; (** Current tagline *) + ds_tagline : bytes; (** Current tagline *) mutable ds_seen_tags : Tags.t; (** Tags that we have encountered *) ds_pathname_length : int; (** How much space for displaying pathnames ? *) ds_tld : tagline_description; (** Description for the tagline *) @@ -105,7 +105,7 @@ let uncached = " ";; let cache_chars = 1;; (* ***) (*** create_tagline *) -let create_tagline description = String.make (List.length description) '-';; +let create_tagline description = Bytes.make (List.length description) '-';; (* ***) (*** create *) let create @@ -184,7 +184,7 @@ let print_shortened_pathname length oc u = let n = String.length dots in let k = length - n in output_string oc dots; - output oc u (m - k) k; + output_substring oc u (m - k) k; end (* ***) (*** Layout @@ -216,7 +216,7 @@ let redraw_sophisticated ds = ds.ds_jobs_cached (print_shortened_pathname ds.ds_pathname_length) ds.ds_last_target (if ds.ds_last_cached then cached else uncached) - ds.ds_tagline + (Bytes.to_string ds.ds_tagline) ticker; fp oc "%a%!" ANSI.clear_to_eol () ;; @@ -292,17 +292,17 @@ let update_tagline_from_tags ds = let tags = ds.ds_last_tags in let rec loop i = function | [] -> - for j = i to String.length tagline - 1 do - tagline.[j] <- '-' + for j = i to Bytes.length tagline - 1 do + Bytes.set tagline j '-' done | (tag, c) :: rest -> if Tags.mem tag tags then - tagline.[i] <- Char.uppercase c + Bytes.set tagline i (Char.uppercase c) else if Tags.mem tag ds.ds_seen_tags then - tagline.[i] <- Char.lowercase c + Bytes.set tagline i (Char.lowercase c) else - tagline.[i] <- '-'; + Bytes.set tagline i '-'; loop (i + 1) rest in loop 0 ds.ds_tld; diff --git a/ocamlbuild/findlib.ml b/ocamlbuild/findlib.ml index 199bc4fd2..18f4d2c95 100644 --- a/ocamlbuild/findlib.ml +++ b/ocamlbuild/findlib.ml @@ -74,15 +74,19 @@ let rec query name = with Not_found -> try let n, d, v, a_byte, lo, l = - run_and_parse Lexers.ocamlfind_query + run_and_parse + (Lexers.ocamlfind_query Const.Source.ocamlfind_query) "%s query -l -predicates byte %s" ocamlfind name in let a_native = - run_and_parse Lexers.trim_blanks + run_and_parse + (Lexers.trim_blanks Const.Source.ocamlfind_query) "%s query -a-format -predicates native %s" ocamlfind name in let deps = - run_and_parse Lexers.blank_sep_strings "%s query -r -p-format %s" ocamlfind name + run_and_parse + (Lexers.blank_sep_strings Const.Source.ocamlfind_query) + "%s query -r -p-format %s" ocamlfind name in let deps = List.filter ((<>) n) deps in let deps = diff --git a/ocamlbuild/lexers.mli b/ocamlbuild/lexers.mli index a59d7589b..5b14f04c0 100644 --- a/ocamlbuild/lexers.mli +++ b/ocamlbuild/lexers.mli @@ -20,29 +20,29 @@ type conf_values = type conf = (Glob.globber * conf_values) list -val ocamldep_output : Lexing.lexbuf -> (string * string list) list -val space_sep_strings : Lexing.lexbuf -> string list -val blank_sep_strings : Lexing.lexbuf -> string list -val comma_sep_strings : Lexing.lexbuf -> string list -val comma_or_blank_sep_strings : Lexing.lexbuf -> string list -val trim_blanks : Lexing.lexbuf -> string +val ocamldep_output : Loc.source -> Lexing.lexbuf -> (string * string list) list +val space_sep_strings : Loc.source -> Lexing.lexbuf -> string list +val blank_sep_strings : Loc.source -> Lexing.lexbuf -> string list +val comma_sep_strings : Loc.source -> Lexing.lexbuf -> string list +val comma_or_blank_sep_strings : Loc.source -> Lexing.lexbuf -> string list +val trim_blanks : Loc.source -> Lexing.lexbuf -> string (* Parse an environment path (i.e. $PATH). This is a colon separated string. Note: successive colons means an empty string. Example: ":aaa:bbb:::ccc:" -> [""; "aaa"; "bbb"; ""; ""; "ccc"; ""] *) -val parse_environment_path : Lexing.lexbuf -> string list +val parse_environment_path : Loc.source -> Lexing.lexbuf -> string list (* Same one, for Windows (PATH is ;-separated) *) -val parse_environment_path_w : Lexing.lexbuf -> string list +val parse_environment_path_w : Loc.source -> Lexing.lexbuf -> string list -val conf_lines : string option -> Lexing.lexbuf -> conf -val path_scheme : bool -> Lexing.lexbuf -> +val conf_lines : string option -> Loc.source -> Lexing.lexbuf -> conf +val path_scheme : bool -> Loc.source -> Lexing.lexbuf -> [ `Word of string | `Var of (string * Glob.globber) ] list -val ocamlfind_query : Lexing.lexbuf -> +val ocamlfind_query : Loc.source -> Lexing.lexbuf -> string * string * string * string * string * string -val tag_gen : Lexing.lexbuf -> string * string option +val tag_gen : Loc.source -> Lexing.lexbuf -> string * string option diff --git a/ocamlbuild/lexers.mll b/ocamlbuild/lexers.mll index 797337d85..d0b8cfdb1 100644 --- a/ocamlbuild/lexers.mll +++ b/ocamlbuild/lexers.mll @@ -15,8 +15,10 @@ { exception Error of (string * Loc.location) -let error lexbuf fmt = - Printf.ksprintf (fun s -> raise (Error (s, Loc.of_lexbuf lexbuf))) fmt +let error source lexbuf fmt = + Printf.ksprintf (fun s -> + raise (Error (s, Loc.of_lexbuf source lexbuf)) + ) fmt open Glob_ast @@ -28,13 +30,16 @@ type conf = (Glob.globber * conf_values) list let empty = { plus_tags = []; minus_tags = [] } -let locate lexbuf txt = - (txt, Loc.of_lexbuf lexbuf) +let locate source lexbuf txt = + (txt, Loc.of_lexbuf source lexbuf) + +let sublex lexer s = lexer (Lexing.from_string s) } let newline = ('\n' | '\r' | "\r\n") let space = [' ' '\t' '\012'] let space_or_esc_nl = (space | '\\' newline) +let sp = space_or_esc_nl let blank = newline | space let not_blank = [^' ' '\t' '\012' '\n' '\r'] let not_space_nor_comma = [^' ' '\t' '\012' ','] @@ -46,118 +51,122 @@ let tag = normal+ | ( normal+ ':' normal+ ) | normal+ '(' [^ ')' ]* ')' let variable = [ 'a'-'z' 'A'-'Z' '_' '-' '0'-'9' ]* let pattern = ([^ '(' ')' '\\' ] | '\\' [ '(' ')' ])* -rule ocamldep_output = parse - | ([^ ':' '\n' '\r' ]+ as k) ':' { let x = (k, space_sep_strings_nl lexbuf) in x :: ocamldep_output lexbuf } +rule ocamldep_output source = parse + | ([^ ':' '\n' '\r' ]+ as k) ':' { let x = (k, space_sep_strings_nl source lexbuf) in x :: ocamldep_output source lexbuf } | eof { [] } - | _ { error lexbuf "Expecting colon followed by space-separated module name list" } + | _ { error source lexbuf "Expecting colon followed by space-separated module name list" } -and space_sep_strings_nl = parse - | space* (not_blank+ as word) { word :: space_sep_strings_nl lexbuf } +and space_sep_strings_nl source = parse + | space* (not_blank+ as word) { word :: space_sep_strings_nl source lexbuf } | space* newline { Lexing.new_line lexbuf; [] } - | _ { error lexbuf "Expecting space-separated strings terminated with newline" } + | _ { error source lexbuf "Expecting space-separated strings terminated with newline" } -and space_sep_strings = parse - | space* (not_blank+ as word) { word :: space_sep_strings lexbuf } +and space_sep_strings source = parse + | space* (not_blank+ as word) { word :: space_sep_strings source lexbuf } | space* newline? eof { [] } - | _ { error lexbuf "Expecting space-separated strings" } + | _ { error source lexbuf "Expecting space-separated strings" } -and blank_sep_strings = parse - | blank* '#' not_newline* newline { blank_sep_strings lexbuf } +and blank_sep_strings source = parse + | blank* '#' not_newline* newline { blank_sep_strings source lexbuf } | blank* '#' not_newline* eof { [] } - | blank* (not_blank+ as word) { word :: blank_sep_strings lexbuf } + | blank* (not_blank+ as word) { word :: blank_sep_strings source lexbuf } | blank* eof { [] } - | _ { error lexbuf "Expecting blank-separated strings" } + | _ { error source lexbuf "Expecting blank-separated strings" } -and comma_sep_strings = parse +and comma_sep_strings source = parse | space* (not_space_nor_comma+ as word) space* eof { [word] } - | space* (not_space_nor_comma+ as word) { word :: comma_sep_strings_aux lexbuf } + | space* (not_space_nor_comma+ as word) { word :: comma_sep_strings_aux source lexbuf } | space* eof { [] } - | _ { error lexbuf "Expecting comma-separated strings (1)" } -and comma_sep_strings_aux = parse - | space* ',' space* (not_space_nor_comma+ as word) { word :: comma_sep_strings_aux lexbuf } + | _ { error source lexbuf "Expecting comma-separated strings (1)" } +and comma_sep_strings_aux source = parse + | space* ',' space* (not_space_nor_comma+ as word) { word :: comma_sep_strings_aux source lexbuf } | space* eof { [] } - | _ { error lexbuf "Expecting comma-separated strings (2)" } + | _ { error source lexbuf "Expecting comma-separated strings (2)" } -and comma_or_blank_sep_strings = parse +and comma_or_blank_sep_strings source = parse | space* (not_space_nor_comma+ as word) space* eof { [word] } - | space* (not_space_nor_comma+ as word) { word :: comma_or_blank_sep_strings_aux lexbuf } + | space* (not_space_nor_comma+ as word) { word :: comma_or_blank_sep_strings_aux source lexbuf } | space* eof { [] } - | _ { error lexbuf "Expecting (comma|blank)-separated strings (1)" } -and comma_or_blank_sep_strings_aux = parse - | space* ',' space* (not_space_nor_comma+ as word) { word :: comma_or_blank_sep_strings_aux lexbuf } - | space* (not_space_nor_comma+ as word) { word :: comma_or_blank_sep_strings_aux lexbuf } + | _ { error source lexbuf "Expecting (comma|blank)-separated strings (1)" } +and comma_or_blank_sep_strings_aux source = parse + | space* ',' space* (not_space_nor_comma+ as word) { word :: comma_or_blank_sep_strings_aux source lexbuf } + | space* (not_space_nor_comma+ as word) { word :: comma_or_blank_sep_strings_aux source lexbuf } | space* eof { [] } - | _ { error lexbuf "Expecting (comma|blank)-separated strings (2)" } + | _ { error source lexbuf "Expecting (comma|blank)-separated strings (2)" } -and parse_environment_path_w = parse - | ([^ ';']* as word) { word :: parse_environment_path_aux_w lexbuf } - | ';' ([^ ';']* as word) { "" :: word :: parse_environment_path_aux_w lexbuf } +and parse_environment_path_w source = parse + | ([^ ';']* as word) { word :: parse_environment_path_aux_w source lexbuf } + | ';' ([^ ';']* as word) { "" :: word :: parse_environment_path_aux_w source lexbuf } | eof { [] } -and parse_environment_path_aux_w = parse - | ';' ([^ ';']* as word) { word :: parse_environment_path_aux_w lexbuf } +and parse_environment_path_aux_w source = parse + | ';' ([^ ';']* as word) { word :: parse_environment_path_aux_w source lexbuf } | eof { [] } - | _ { error lexbuf "Impossible: expecting colon-separated strings" } + | _ { error source lexbuf "Impossible: expecting colon-separated strings" } -and parse_environment_path = parse - | ([^ ':']* as word) { word :: parse_environment_path_aux lexbuf } - | ':' ([^ ':']* as word) { "" :: word :: parse_environment_path_aux lexbuf } +and parse_environment_path source = parse + | ([^ ':']* as word) { word :: parse_environment_path_aux source lexbuf } + | ':' ([^ ':']* as word) { "" :: word :: parse_environment_path_aux source lexbuf } | eof { [] } -and parse_environment_path_aux = parse - | ':' ([^ ':']* as word) { word :: parse_environment_path_aux lexbuf } +and parse_environment_path_aux source = parse + | ':' ([^ ':']* as word) { word :: parse_environment_path_aux source lexbuf } | eof { [] } - | _ { error lexbuf "Impossible: expecting colon-separated strings" } + | _ { error source lexbuf "Impossible: expecting colon-separated strings" } -and conf_lines dir = parse - | space* '#' not_newline* newline { Lexing.new_line lexbuf; conf_lines dir lexbuf } +and conf_lines dir source = parse + | space* '#' not_newline* newline { Lexing.new_line lexbuf; conf_lines dir source lexbuf } | space* '#' not_newline* eof { [] } - | space* newline { Lexing.new_line lexbuf; conf_lines dir lexbuf } + | space* newline { Lexing.new_line lexbuf; conf_lines dir source lexbuf } | space* eof { [] } - | space* (not_newline_nor_colon+ as k) space* ':' space* + | space* (not_newline_nor_colon+ as k) (sp* as s1) ':' (sp* as s2) { let bexpr = try Glob.parse ?dir k - with exn -> error lexbuf "Invalid globbing pattern %S" k (Printexc.to_string exn) + with exn -> error source lexbuf "Invalid globbing pattern %S" k (Printexc.to_string exn) in - let v1 = conf_value empty lexbuf in - let v2 = conf_values v1 lexbuf in - Lexing.new_line lexbuf; (* FIXME values may have escaped newlines *) - let rest = conf_lines dir lexbuf in (bexpr,v2) :: rest + sublex (count_lines lexbuf) s1; sublex (count_lines lexbuf) s2; + let v1 = conf_value empty source lexbuf in + let v2 = conf_values v1 source lexbuf in + let rest = conf_lines dir source lexbuf in (bexpr,v2) :: rest } - | _ { error lexbuf "Invalid line syntax" } - -and conf_value x = parse - | '-' (tag as tag) { { (x) with minus_tags = locate lexbuf tag :: x.minus_tags } } - | '+'? (tag as tag) { { (x) with plus_tags = locate lexbuf tag :: x.plus_tags } } - | (_ | eof) { error lexbuf "Invalid tag modifier only '+ or '-' are allowed as prefix for tag" } - -and conf_values x = parse - | space_or_esc_nl* ',' space_or_esc_nl* { conf_values (conf_value x lexbuf) lexbuf } - | (newline | eof) { x } - | (_ | eof) { error lexbuf "Only ',' separated tags are alllowed" } - -and path_scheme patt_allowed = parse + | _ { error source lexbuf "Invalid line syntax" } + +and conf_value x source = parse + | '-' (tag as tag) { { (x) with minus_tags = locate source lexbuf tag :: x.minus_tags } } + | '+'? (tag as tag) { { (x) with plus_tags = locate source lexbuf tag :: x.plus_tags } } + | (_ | eof) { error source lexbuf "Invalid tag modifier only '+ or '-' are allowed as prefix for tag" } + +and conf_values x source = parse + | (sp* as s1) ',' (sp* as s2) { + sublex (count_lines lexbuf) s1; sublex (count_lines lexbuf) s2; + conf_values (conf_value x source lexbuf) source lexbuf + } + | newline { Lexing.new_line lexbuf; x } + | eof { x } + | _ { error source lexbuf "Only ',' separated tags are alllowed" } + +and path_scheme patt_allowed source = parse | ([^ '%' ]+ as prefix) - { `Word prefix :: path_scheme patt_allowed lexbuf } + { `Word prefix :: path_scheme patt_allowed source lexbuf } | "%(" (variable as var) ')' - { `Var (var, Bool.True) :: path_scheme patt_allowed lexbuf } + { `Var (var, Bool.True) :: path_scheme patt_allowed source lexbuf } | "%(" (variable as var) ':' (pattern as patt) ')' { if patt_allowed then let patt = My_std.String.implode (unescape (Lexing.from_string patt)) in - `Var (var, Glob.parse patt) :: path_scheme patt_allowed lexbuf + `Var (var, Glob.parse patt) :: path_scheme patt_allowed source lexbuf else - error lexbuf "Patterns are not allowed in this pathname (%%(%s:%s) only in ~prod)" var patt } + error source lexbuf "Patterns are not allowed in this pathname (%%(%s:%s) only in ~prod)" var patt } | '%' - { `Var ("", Bool.True) :: path_scheme patt_allowed lexbuf } + { `Var ("", Bool.True) :: path_scheme patt_allowed source lexbuf } | eof { [] } - | _ { error lexbuf "Bad pathanme scheme" } + | _ { error source lexbuf "Bad pathanme scheme" } and unescape = parse | '\\' (['(' ')'] as c) { c :: unescape lexbuf } | _ as c { c :: unescape lexbuf } | eof { [] } -and ocamlfind_query = parse +and ocamlfind_query source = parse | newline* "package:" space* (not_newline* as n) newline+ "description:" space* (not_newline* as d) newline+ @@ -166,11 +175,17 @@ and ocamlfind_query = parse "linkopts:" space* (not_newline* as lo) newline+ "location:" space* (not_newline* as l) newline+ { n, d, v, a, lo, l } - | _ { error lexbuf "Bad ocamlfind query" } + | _ { error source lexbuf "Bad ocamlfind query" } -and trim_blanks = parse +and trim_blanks source = parse | blank* (not_blank* as word) blank* { word } - | _ { error lexbuf "Bad input for trim_blanks" } + | _ { error source lexbuf "Bad input for trim_blanks" } -and tag_gen = parse +and tag_gen source = parse | (normal+ as name) ('(' ([^')']* as param) ')')? { name, param } + | _ { error source lexbuf "Not a valid parametrized tag" } + +and count_lines lb = parse + | space* { count_lines lb lexbuf } + | '\\' newline { Lexing.new_line lb; count_lines lb lexbuf } + | eof { () } diff --git a/ocamlbuild/loc.ml b/ocamlbuild/loc.ml index 2bf3900e8..7a324c161 100644 --- a/ocamlbuild/loc.ml +++ b/ocamlbuild/loc.ml @@ -4,26 +4,31 @@ open Lexing -type location = position * position +(* We use a loosely structural type so that this bit of code can be + easily reused by project that would wish it, without introducing + any type-compatibility burden. *) +type source = string (* "file", "environment variable", "command-line option" ... *) +type location = source * position * position let file loc = loc.pos_fname let line loc = loc.pos_lnum let char loc = loc.pos_cnum - loc.pos_bol -let print_loc ppf (start, end_) = +let print_loc ppf (source, start, end_) = let open Format in let print one_or_two ppf (start_num, end_num) = if one_or_two then fprintf ppf " %d" start_num else fprintf ppf "s %d-%d" start_num end_num in - fprintf ppf "File %S, line%a, character%a:@." + fprintf ppf "%s %S, line%a, character%a:@." + (String.capitalize source) (file start) (print (line start = line end_)) (line start, line end_) (print (line start = line end_ && char start = char end_)) (char start, char end_) -let of_lexbuf lexbuf = - (lexbuf.lex_start_p, lexbuf.lex_curr_p) +let of_lexbuf source lexbuf = + (source, lexbuf.lex_start_p, lexbuf.lex_curr_p) let print_loc_option ppf = function | None -> () diff --git a/ocamlbuild/loc.mli b/ocamlbuild/loc.mli index 9ed842ef2..c5768bc1c 100644 --- a/ocamlbuild/loc.mli +++ b/ocamlbuild/loc.mli @@ -1,6 +1,7 @@ -type location = Lexing.position * Lexing.position +type source = string +type location = source * Lexing.position * Lexing.position val print_loc : Format.formatter -> location -> unit val print_loc_option : Format.formatter -> location option -> unit -val of_lexbuf : Lexing.lexbuf -> location +val of_lexbuf : source -> Lexing.lexbuf -> location diff --git a/ocamlbuild/log.ml b/ocamlbuild/log.ml index 380c9a59a..d50969e34 100644 --- a/ocamlbuild/log.ml +++ b/ocamlbuild/log.ml @@ -48,7 +48,31 @@ let update () = Display.update !-internal_display let event ?pretend x = Display.event !-internal_display ?pretend x let display x = Display.display !-internal_display x +let do_at_end = Queue.create () +let already_asked = Hashtbl.create 10 + +let at_end_always ~name thunk = + if not (Hashtbl.mem already_asked name) then begin + Hashtbl.add already_asked name (); + Queue.add thunk do_at_end; + end + +let at_end ~name thunk = at_end_always ~name (function + | `Quiet -> () + | `Success | `Error -> thunk `Error) +let at_failure ~name thunk = at_end_always ~name (function + | `Success | `Quiet -> () + | `Error -> thunk `Error) + let finish ?how () = + while not (Queue.is_empty do_at_end) do + let actions = Queue.copy do_at_end in + Queue.clear do_at_end; + (* calling a thunk may add new actions again, hence the loop *) + Queue.iter (fun thunk -> + thunk (match how with None -> `Quiet | Some how -> how) + ) actions; + done; match !internal_display with | None -> () | Some d -> Display.finish ?how d diff --git a/ocamlbuild/log.mli b/ocamlbuild/log.mli index a414608a6..413a476dd 100644 --- a/ocamlbuild/log.mli +++ b/ocamlbuild/log.mli @@ -32,3 +32,13 @@ val finish : ?how:[`Success|`Error|`Quiet] -> unit -> unit val display : (out_channel -> unit) -> unit val update : unit -> unit val mode : string -> bool + +(** Wrap logging event so that only fire at the end of the compilation + process, possibly depending on the termination status. + + The name is used to avoid printing the same hint/warning twice, + even if [at_end] is called several times. Use different names for + distinct events. +*) +val at_end : name:string -> ([> `Error | `Quiet ] -> unit) -> unit +val at_failure : name:string -> ([> `Error ] -> unit) -> unit diff --git a/ocamlbuild/main.ml b/ocamlbuild/main.ml index 5f86f7932..07ca9c065 100644 --- a/ocamlbuild/main.ml +++ b/ocamlbuild/main.ml @@ -56,9 +56,12 @@ let show_documentation () = this means that even if they were not part of any flag declaration, they should be marked as useful, to avoid the "unused tag" warning. *) let builtin_useful_tags = - Tags.of_list - ["include"; "traverse"; "not_hygienic"; - "pack"; "ocamlmklib"; "native"; "thread"; "nopervasives"] + Tags.of_list [ + "include"; "traverse"; "not_hygienic"; + "pack"; "ocamlmklib"; "native"; "thread"; + "nopervasives"; "use_menhir"; "ocamldep"; + "thread"; + ] ;; let proceed () = @@ -78,7 +81,7 @@ let proceed () = let target_dirs = List.union [] (List.map Pathname.dirname !Options.targets) in - Configuration.parse_string + Configuration.parse_string ~source:Const.Source.builtin "<**/*.ml> or <**/*.mli> or <**/*.mlpack> or <**/*.ml.depends>: ocaml\n\ <**/*.byte>: ocaml, byte, program\n\ <**/*.odoc>: ocaml, doc\n\ @@ -90,16 +93,21 @@ let proceed () = <**/*.cmx>: ocaml, native\n\ "; + List.iter + (Configuration.parse_string ~source:Const.Source.command_line) + !Options.tag_lines; + Configuration.tag_any !Options.tags; - if !Options.recursive - || Sys.file_exists (* authorized since we're not in build *) "_tags" - || Sys.file_exists (* authorized since we're not in build *) "myocamlbuild.ml" + if !Options.recursive || Options.ocamlbuild_project_heuristic () then Configuration.tag_any ["traverse"]; (* options related to findlib *) - List.iter - (fun pkg -> Configuration.tag_any [Param_tags.make "package" pkg]) - !Options.ocaml_pkgs; + if !Options.use_ocamlfind then + List.iter + (fun pkg -> + let tag = Param_tags.make "package" pkg in + Configuration.tag_any [tag]) + !Options.ocaml_pkgs; begin match !Options.ocaml_syntax with | Some syntax -> Configuration.tag_any [Param_tags.make "syntax" syntax] @@ -110,7 +118,7 @@ let proceed () = let entry_include_dirs = ref [] in let entry = Slurp.filter - begin fun path name _ -> + begin fun path name () -> let dir = if path = Filename.current_dir_name then None @@ -118,8 +126,21 @@ let proceed () = Some path in let path_name = path/name in - if name = "_tags" then - ignore (Configuration.parse_file ?dir path_name); + + if name = "_tags" then begin + let tags_path = + (* PR#6482: remember that this code is run lazily by the Slurp command, + and may run only after the working directory has been changed. + + On the other hand, always using the absolute path makes + error messages longer and more frigthening in case of + syntax error in the _tags file. So we use the absolute + path only when necessary -- the working directory has + changed. *) + if Sys.getcwd () = Pathname.pwd then path_name + else Pathname.pwd / path_name in + ignore (Configuration.parse_file ?dir tags_path); + end; (List.mem name ["_oasis"] || (String.length name > 0 && name.[0] <> '_')) && (name <> !Options.build_dir && not (List.mem name !Options.exclude_dirs)) @@ -148,18 +169,15 @@ let proceed () = let tags = tags_of_pathname (path/name) in not (Tags.mem "not_hygienic" tags) && not (Tags.mem "precious" tags) end entry in + Slurp.force hygiene_entry; if !Options.hygiene && not first_run_for_plugin then - Fda.inspect hygiene_entry - else - Slurp.force hygiene_entry; + Fda.inspect hygiene_entry; let entry = hygiene_entry in Hooks.call_hook Hooks.After_hygiene; Options.include_dirs := Pathname.current_dir_name :: List.rev !entry_include_dirs; dprintf 3 "include directories are:@ %a" print_string_list !Options.include_dirs; Options.entry := Some entry; - List.iter Configuration.parse_string !Options.tag_lines; - Hooks.call_hook Hooks.Before_rules; Ocaml_specific.init (); Hooks.call_hook Hooks.After_rules; @@ -282,8 +300,10 @@ let main () = Log.finish ~how:`Quiet (); Pervasives.exit rc | Solver.Failed backtrace -> - Log.raw_dprintf (-1) "@[<v0>@[<2>Solver failed:@ %a@]@\n@[<v2>Backtrace:%a@]@]@." - Report.print_backtrace_analyze backtrace Report.print_backtrace backtrace; + Log.raw_dprintf (-1) "@[<v0>@[<2>Solver failed:@ %a@]@." + Report.print_backtrace_analyze backtrace; + Log.raw_dprintf 1 "@[<v2>Backtrace:%a@]@]@." + Report.print_backtrace backtrace; exit rc_solver_failed | Failure s -> Log.eprintf "Failure:@ %s." s; diff --git a/ocamlbuild/my_std.ml b/ocamlbuild/my_std.ml index e0d2c8a9c..4dce7a0cf 100644 --- a/ocamlbuild/my_std.ml +++ b/ocamlbuild/my_std.ml @@ -180,14 +180,7 @@ module String = struct in loop s 0 let tr patt subst text = - let len = length text in - let text = copy text in - let rec loop pos = - if pos < len then begin - (if text.[pos] = patt then text.[pos] <- subst); - loop (pos + 1) - end - in loop 0; text + String.map (fun c -> if c = patt then subst else c) text (*** is_prefix : is u a prefix of v ? *) let is_prefix u v = @@ -211,23 +204,23 @@ module String = struct let rev s = let sl = String.length s in - let s' = String.create sl in + let s' = Bytes.create sl in for i = 0 to sl - 1 do - s'.[i] <- s.[sl - i - 1] + Bytes.set s' i s.[sl - i - 1] done; - s';; + Bytes.to_string s';; let implode l = match l with | [] -> "" | cs -> - let r = create (List.length cs) in + let r = Bytes.create (List.length cs) in let pos = ref 0 in List.iter begin fun c -> - unsafe_set r !pos c; + Bytes.unsafe_set r !pos c; incr pos end cs; - r + Bytes.to_string r let explode s = let sl = String.length s in @@ -307,16 +300,14 @@ let with_output_file ?(bin=false) x f = let read_file x = with_input_file ~bin:true x begin fun ic -> let len = in_channel_length ic in - let buf = String.create len in - let () = really_input ic buf 0 len in - buf + really_input_string ic len end let copy_chan ic oc = let m = in_channel_length ic in let m = (m lsr 12) lsl 12 in let m = max 16384 (min Sys.max_string_length m) in - let buf = String.create m in + let buf = Bytes.create m in let rec loop () = let len = input ic buf 0 m in if len > 0 then begin @@ -419,3 +410,22 @@ let memo3 f = with Not_found -> let res = f x y z in (Hashtbl.add cache (x,y,z) res; res) + +let set_lexbuf_fname fname lexbuf = + let open Lexing in + lexbuf.lex_start_p <- { lexbuf.lex_start_p with pos_fname = fname }; + lexbuf.lex_curr_p <- { lexbuf.lex_curr_p with pos_fname = fname }; + () + +let lexbuf_of_string ?name content = + let lexbuf = Lexing.from_string content in + let fname = match name with + | Some name -> name + | None -> + (* 40: hope the location will fit one line of 80 chars *) + if String.length content < 40 && not (String.contains content '\n') then + String.escaped content + else "" + in + set_lexbuf_fname fname lexbuf; + lexbuf diff --git a/ocamlbuild/my_std.mli b/ocamlbuild/my_std.mli index 403c4e961..d7e146370 100644 --- a/ocamlbuild/my_std.mli +++ b/ocamlbuild/my_std.mli @@ -62,3 +62,6 @@ val filename_concat : string -> string -> string val invalid_arg' : ('a, Format.formatter, unit, 'b) format4 -> 'a include Signatures.MISC + +val set_lexbuf_fname : string -> Lexing.lexbuf -> unit +val lexbuf_of_string : ?name:string -> string -> Lexing.lexbuf diff --git a/ocamlbuild/my_unix.ml b/ocamlbuild/my_unix.ml index 43692d321..fa1c5d45f 100644 --- a/ocamlbuild/my_unix.ml +++ b/ocamlbuild/my_unix.ml @@ -127,13 +127,13 @@ let execute_many ?max_jobs = implem.execute_many ?max_jobs let run_and_read cmd = let bufsiz = 2048 in - let buf = String.create bufsiz in + let buf = Bytes.create bufsiz in let totalbuf = Buffer.create 4096 in implem.run_and_open cmd begin fun ic -> let rec loop pos = let len = input ic buf 0 bufsiz in if len > 0 then begin - Buffer.add_substring totalbuf buf 0 len; + Buffer.add_subbytes totalbuf buf 0 len; loop (pos + len) end in loop 0; Buffer.contents totalbuf diff --git a/ocamlbuild/ocaml_compiler.ml b/ocamlbuild/ocaml_compiler.ml index e21618ee0..c270a7f63 100644 --- a/ocamlbuild/ocaml_compiler.ml +++ b/ocamlbuild/ocaml_compiler.ml @@ -116,10 +116,30 @@ let prepare_compile build ml = match mandatory, res with | _, Good _ -> () | `mandatory, Bad exn -> - if !Options.ignore_auto then - dprintf 3 "Warning: Failed to build the module \ - %s requested by ocamldep" name - else raise exn + if not !Options.ignore_auto then raise exn; + dprintf 3 + "Warning: Failed to build the module %s requested by ocamldep." + name; + if not (!Options.recursive || Options.ocamlbuild_project_heuristic ()) + then Log.at_failure ~name:"a module failed to build, + while recursive traversal was disabled by fragile heuristic; + hint that having a _tags or myocamlbuild.ml would maybe solve + the build error" + (fun `Error -> + eprintf "Hint:@ Recursive@ traversal@ of@ subdirectories@ \ + was@ not@ enabled@ for@ this@ build,@ as@ the@ working@ \ + directory does@ not@ look@ like@ an@ ocamlbuild@ project@ \ + (no@ '_tags'@ or@ 'myocamlbuild.ml'@ file).@ \ + If@ you@ have@ modules@ in@ subdirectories,@ you@ should@ add@ \ + the@ option@ \"-r\"@ or@ create@ an@ empty@ '_tags'@ file.@\n\ + @\n\ + To@ enable@ recursive@ traversal@ for@ some@ subdirectories@ \ + only,@ you@ can@ use@ the@ following@ '_tags'@ file:@\n\ + @[<v 4>@,\ + true: -traverse@,\ + <dir1> or <dir2>: traverse@,\ + @]" + ); | `just_try, Bad _ -> () end modules results diff --git a/ocamlbuild/ocaml_specific.ml b/ocamlbuild/ocaml_specific.ml index 1b41c0842..037d119e6 100644 --- a/ocamlbuild/ocaml_specific.ml +++ b/ocamlbuild/ocaml_specific.ml @@ -598,18 +598,24 @@ let () = (fun param -> S [A "-for-pack"; A param]); pflag ["ocaml"; "native"; "compile"] "inline" (fun param -> S [A "-inline"; A param]); - pflag ["ocaml"; "compile"] "pp" - (fun param -> S [A "-pp"; A param]); - pflag ["ocaml"; "ocamldep"] "pp" - (fun param -> S [A "-pp"; A param]); - pflag ["ocaml"; "doc"] "pp" - (fun param -> S [A "-pp"; A param]); - pflag ["ocaml"; "infer_interface"] "pp" - (fun param -> S [A "-pp"; A param]); + List.iter (fun pp -> + pflag ["ocaml"; "compile"] pp + (fun param -> S [A ("-" ^ pp); A param]); + pflag ["ocaml"; "ocamldep"] pp + (fun param -> S [A ("-" ^ pp); A param]); + pflag ["ocaml"; "doc"] pp + (fun param -> S [A ("-" ^ pp); A param]); + pflag ["ocaml"; "infer_interface"] pp + (fun param -> S [A ("-" ^ pp); A param]) + ) ["pp"; "ppx"]; pflag ["ocaml";"compile";] "warn" (fun param -> S [A "-w"; A param]); pflag ["ocaml";"compile";] "warn_error" (fun param -> S [A "-warn-error"; A param]); + pflag ["ocaml"; "ocamldep"] "open" + (fun param -> S [A "-open"; A param]); + pflag ["ocaml"; "compile"] "open" + (fun param -> S [A "-open"; A param]); () let camlp4_flags camlp4s = @@ -665,6 +671,10 @@ flag ["ocaml"; "link"; "byte"; "output_obj"] (A"-output-obj");; flag ["ocaml"; "dtypes"; "compile"] (A "-dtypes");; flag ["ocaml"; "annot"; "compile"] (A "-annot");; flag ["ocaml"; "bin_annot"; "compile"] (A "-bin-annot");; +flag ["ocaml"; "safe_string"; "compile"] (A "-safe-string");; +flag ["ocaml"; "safe_string"; "infer_interface"] (A "-safe-string");; +flag ["ocaml"; "unsafe_string"; "compile"] (A "-unsafe-string");; +flag ["ocaml"; "unsafe_string"; "infer_interface"] (A "-unsafe-string");; flag ["ocaml"; "short_paths"; "compile"] (A "-short-paths");; flag ["ocaml"; "short_paths"; "infer_interface"] (A "-short-paths");; flag ["ocaml"; "rectypes"; "compile"] (A "-rectypes");; @@ -678,6 +688,15 @@ flag ["ocaml"; "link"; "profile"; "native"] (A "-p");; flag ["ocaml"; "link"; "program"; "custom"; "byte"] (A "-custom");; flag ["ocaml"; "link"; "library"; "custom"; "byte"] (A "-custom");; flag ["ocaml"; "compile"; "profile"; "native"] (A "-p");; +flag ["ocaml"; "compile"; "no_alias_deps";] (A "-no-alias-deps");; +flag ["ocaml"; "compile"; "strict_formats";] (A "-strict-formats");; +flag ["ocaml"; "native"; "compile"; "opaque";] (A "-opaque");; +flag ["ocaml"; "native"; "compile"; "no_float_const_prop";] (A "-no-float-const-prop"); +flag ["ocaml"; "compile"; "keep_locs";] (A "-keep-locs"); +flag ["ocaml"; "absname"; "compile"] (A "-absname");; +flag ["ocaml"; "absname"; "infer_interface"] (A "-absname");; +flag ["ocaml"; "byte"; "compile"; "compat_32";] (A "-compat-32"); + (* threads, with or without findlib *) flag ["ocaml"; "compile"; "thread"] (A "-thread");; diff --git a/ocamlbuild/ocaml_utils.ml b/ocamlbuild/ocaml_utils.ml index 592769637..409f0a069 100644 --- a/ocamlbuild/ocaml_utils.ml +++ b/ocamlbuild/ocaml_utils.ml @@ -80,7 +80,8 @@ let expand_module = let string_list_of_file file = with_input_file file begin fun ic -> - Lexers.blank_sep_strings (Lexing.from_channel ic) + Lexers.blank_sep_strings + Const.Source.file (Lexing.from_channel ic) end let print_path_list = Pathname.print_path_list @@ -149,7 +150,8 @@ let read_path_dependencies = let depends = path-.-"depends" in with_input_file depends begin fun ic -> let ocamldep_output = - try Lexers.ocamldep_output (Lexing.from_channel ic) + try Lexers.ocamldep_output + Const.Source.ocamldep (Lexing.from_channel ic) with Lexers.Error (msg,_) -> raise (Ocamldep_error(Printf.sprintf "Ocamldep.ocamldep: bad output (%s)" msg)) in let deps = List.fold_right begin fun (path, deps) acc -> diff --git a/ocamlbuild/ocamlbuild_executor.ml b/ocamlbuild/ocamlbuild_executor.ml index 53fcad120..298f9b4dd 100644 --- a/ocamlbuild/ocamlbuild_executor.ml +++ b/ocamlbuild/ocamlbuild_executor.ml @@ -59,22 +59,19 @@ let output_lines prefix oc buffer = let m = String.length u in let output_line i j = output_string oc prefix; - output oc u i (j - i); + output_substring oc u i (j - i); output_char oc '\n' in let rec loop i = - if i = m then - () + if i < m then + let j = + try String.index_from u i '\n' + with Not_found -> m + in + output_line i j; + loop (j + 1) else - begin - try - let j = String.index_from u i '\n' in - output_line i j; - loop (j + 1) - with - | Not_found -> - output_line i m - end + () in loop 0 ;; @@ -190,7 +187,7 @@ let execute (* ***) (*** do_read *) let do_read = - let u = String.create 4096 in + let u = Bytes.create 4096 in fun ?(loop=false) fd job -> (*if job.job_dying then () @@ -199,9 +196,13 @@ let execute let rec iteration () = let m = try - read fd u 0 (String.length u) + read fd u 0 (Bytes.length u) with - | Unix.Unix_error(_,_,_) -> 0 + | Unix.Unix_error(e,_,_) -> + let msg = error_message e in + display (fun oc -> fp oc + "Error while reading stdout/stderr: %s\n" msg); + 0 in if m = 0 then if job.job_dying then @@ -210,7 +211,7 @@ let execute terminate job else begin - Buffer.add_substring job.job_buffer u 0 m; + Buffer.add_subbytes job.job_buffer u 0 m; if loop then iteration () else @@ -237,6 +238,11 @@ let execute (*display begin fun oc -> fp oc "Terminating job %a\n%!" print_job_id job.job_id; end;*) decr jobs_active; + + (* PR#5371: we would get EAGAIN below otherwise *) + clear_nonblock (doi job.job_stdout); + clear_nonblock (doi job.job_stderr); + do_read ~loop:true (doi job.job_stdout) job; do_read ~loop:true (doi job.job_stderr) job; outputs := FDM.remove (doi job.job_stdout) (FDM.remove (doi job.job_stderr) !outputs); diff --git a/ocamlbuild/ocamlbuild_pack.mlpack b/ocamlbuild/ocamlbuild_pack.mlpack index 83f1065f4..450592f53 100644 --- a/ocamlbuild/ocamlbuild_pack.mlpack +++ b/ocamlbuild/ocamlbuild_pack.mlpack @@ -1,3 +1,4 @@ +Const Loc Log My_unix diff --git a/ocamlbuild/options.ml b/ocamlbuild/options.ml index 78cee6373..5ee512200 100644 --- a/ocamlbuild/options.ml +++ b/ocamlbuild/options.ml @@ -23,6 +23,7 @@ open Format open Command let entry = ref None +let project_root_dir = ref None let build_dir = ref (Filename.concat (Sys.getcwd ()) "_build") let include_dirs = ref [] let exclude_dirs = ref [] @@ -38,7 +39,7 @@ let make_links = ref true let nostdlib = ref false let use_menhir = ref false let catch_errors = ref true -let use_ocamlfind = ref true +let use_ocamlfind = ref false (* Currently only ocamlfind and menhir is defined as no-core tool, perhaps later we need something better *) @@ -141,7 +142,8 @@ let use_jocaml () = ;; let add_to rxs x = - let xs = Lexers.comma_or_blank_sep_strings (Lexing.from_string x) in + let xs = Lexers.comma_or_blank_sep_strings + Const.Source.command_line (Lexing.from_string x) in rxs := xs :: !rxs let add_to' rxs x = if x <> dummy then @@ -217,8 +219,10 @@ let spec = ref ( "-classic-display", Set Log.classic_display, " Display executed commands the old-fashioned way"; "-use-menhir", Set use_menhir, " Use menhir instead of ocamlyacc"; "-use-jocaml", Unit use_jocaml, " Use jocaml compilers instead of ocaml ones"; - "-use-ocamlfind", Set use_ocamlfind, " Option deprecated. Now enabled by default. Use -no-ocamlfind to disable"; - "-no-ocamlfind", Clear use_ocamlfind, " Don't use ocamlfind"; + "-use-ocamlfind", Set use_ocamlfind, " Use the 'ocamlfind' wrapper instead of \ + using Findlib directly to determine command-line arguments. \ + Use -no-ocamlfind to disable."; + "-no-ocamlfind", Clear use_ocamlfind, " Don't use ocamlfind."; "-j", Set_int Command.jobs, "<N> Allow N jobs at once (0 for unlimited)"; @@ -270,6 +274,8 @@ let init () = parse_argv argv' !spec anon_fun usage_msg; Shell.mkdir_p !build_dir; + project_root_dir := Some (Sys.getcwd ()); + let () = let log = !log_file_internal in if log = "" then Log.init None @@ -285,18 +291,33 @@ let init () = in if !use_ocamlfind then begin - ocamlfind_cmd := A "ocamlfind"; - let cmd = Command.string_of_command_spec !ocamlfind_cmd in - begin try ignore(Command.search_in_path cmd) - with Not_found -> failwith "ocamlfind not found on path, but -no-ocamlfind not used" end; - (* TODO: warning message when using an option such as -ocamlc *) + begin try ignore(Command.search_in_path "ocamlfind") + with Not_found -> + failwith "ocamlfind not found on path, but -no-ocamlfind not used" + end; + + let with_ocamlfind (command_name, command_ref) = + command_ref := match !command_ref with + | Sh user_command -> + (* this command has been set by the user + using an -ocamlc, -ocamlopt, etc. flag; + + not all such combinations make sense (eg. "ocamlfind + /my/special/path/to/ocamlc" will make ocamlfind choke), + but the user will see the error and hopefully fix the + flags. *) + ocamlfind & (Sh user_command); + | _ -> ocamlfind & A command_name + in (* Note that plugins can still modify these variables After_options. This design decision can easily be changed. *) - ocamlc := ocamlfind & A"ocamlc"; - ocamlopt := ocamlfind & A"ocamlopt"; - ocamldep := ocamlfind & A"ocamldep"; - ocamldoc := ocamlfind & A"ocamldoc"; - ocamlmktop := ocamlfind & A"ocamlmktop"; + List.iter with_ocamlfind [ + "ocamlc", ocamlc; + "ocamlopt", ocamlopt; + "ocamldep", ocamldep; + "ocamldoc", ocamldoc; + "ocamlmktop", ocamlmktop; + ] end; let reorder x y = x := !x @ (List.concat (List.rev !y)) in @@ -334,3 +355,17 @@ let init () = ignore_list := List.map String.capitalize !ignore_list ;; + +(* The current heuristic: we know we are in an ocamlbuild project if + either _tags or myocamlbuild.ml are present at the root. This + heuristic has been documented and explained to users, so it should + not be changed. *) +let ocamlbuild_project_heuristic () = + let root_dir = match !project_root_dir with + | None -> Sys.getcwd () + | Some dir -> dir in + let at_root file = Filename.concat root_dir file in + Sys.file_exists (* authorized since we're not in build *) + (at_root "_tags") + || Sys.file_exists (* authorized since we're not in build *) + (at_root "myocamlbuild.ml") diff --git a/ocamlbuild/options.mli b/ocamlbuild/options.mli index b450c8451..0a0d39c4b 100644 --- a/ocamlbuild/options.mli +++ b/ocamlbuild/options.mli @@ -15,12 +15,20 @@ include Signatures.OPTIONS with type command_spec = Command.spec -(* this option is not in Signatures.OPTIONS yet because adding tags to +(* This option is not in Signatures.OPTIONS yet because adding tags to the compilation of the plugin is a recent feature that may still be subject to change, so the interface may not be stable; besides, there is obviously little to gain from tweaking that option from inside the plugin itself... *) val plugin_tags : string list ref +(* Returns 'true' if we heuristically infer that we are run from an + ocamlbuild projet (either _tags or myocamlbuild.ml are present). + + This information is used to decide whether to enable recursive + traversal of subdirectories by default. +*) +val ocamlbuild_project_heuristic : unit -> bool + val entry : bool Slurp.entry option ref val init : unit -> unit diff --git a/ocamlbuild/param_tags.ml b/ocamlbuild/param_tags.ml index 1ccccc604..456239031 100644 --- a/ocamlbuild/param_tags.ml +++ b/ocamlbuild/param_tags.ml @@ -10,6 +10,7 @@ (* *) (***********************************************************************) +open My_std (* Original author: Romain Bardou *) @@ -32,10 +33,10 @@ let only_once f = let declare name action = Hashtbl.add declared_tags name (only_once action) -let parse tag = Lexers.tag_gen (Lexing.from_string tag) +let parse source tag = Lexers.tag_gen source (lexbuf_of_string tag) -let acknowledge maybe_loc tag = - acknowledged_tags := (parse tag, maybe_loc) :: !acknowledged_tags +let acknowledge source maybe_loc tag = + acknowledged_tags := (parse source tag, maybe_loc) :: !acknowledged_tags let really_acknowledge ?(quiet=false) ((name, param), maybe_loc) = match param with @@ -51,8 +52,9 @@ let really_acknowledge ?(quiet=false) ((name, param), maybe_loc) = Loc.print_loc_option maybe_loc name param; List.iter (fun f -> f param) actions -let partial_init ?quiet tags = - Tags.iter (fun tag -> really_acknowledge ?quiet (parse tag, None)) tags +let partial_init ?quiet source tags = + let parse_noloc tag = (parse source tag, None) in + Tags.iter (fun tag -> really_acknowledge ?quiet (parse_noloc tag)) tags let init () = List.iter really_acknowledge (My_std.List.ordered_unique !acknowledged_tags) diff --git a/ocamlbuild/param_tags.mli b/ocamlbuild/param_tags.mli index 22c081256..061139413 100644 --- a/ocamlbuild/param_tags.mli +++ b/ocamlbuild/param_tags.mli @@ -22,7 +22,7 @@ if a tag of the form [name(param)] is [acknowledge]d. A given tag may be declared several times with different actions. All actions will be executed, in the order they were declared. *) -val acknowledge: Loc.location option -> string -> unit +val acknowledge: Loc.source -> Loc.location option -> string -> unit (** Acknowledge a tag. If the tag is of the form [X(Y)], and have been declared using [declare], @@ -37,7 +37,7 @@ This will make effective all instantiations [foo(bar)] such that the parametrized tag [foo] has been [declare]d and [foo(bar)] has been [acknowledge]d after the last [init] call. *) -val partial_init: ?quiet:bool -> Tags.t -> unit +val partial_init: ?quiet:bool -> Loc.source -> Tags.t -> unit (** Initialize a list of tags This will make effective the instances [foo(bar)] appearing diff --git a/ocamlbuild/plugin.ml b/ocamlbuild/plugin.ml index eb831e722..e4d18363d 100644 --- a/ocamlbuild/plugin.ml +++ b/ocamlbuild/plugin.ml @@ -202,7 +202,7 @@ module Make(U:sig end) = precisely those that will be used during the compilation of the plugin, and no more. *) - Param_tags.partial_init plugin_tags; + Param_tags.partial_init Const.Source.plugin_tag plugin_tags; let cmd = (* The argument order is important: we carefully put the diff --git a/ocamlbuild/resource.ml b/ocamlbuild/resource.ml index 4121d194a..229d77129 100644 --- a/ocamlbuild/resource.ml +++ b/ocamlbuild/resource.ml @@ -17,6 +17,8 @@ open Format open Log open Pathname.Operators + +type t = Pathname.t module Resources = Set.Make(Pathname) let print = Pathname.print @@ -312,7 +314,8 @@ end = struct let mk (pattern_allowed, s) = List.map begin function | `Var(var_name, globber) -> V(var_name, globber) | `Word s -> A s - end (Lexers.path_scheme pattern_allowed (Lexing.from_string s)) + end (Lexers.path_scheme pattern_allowed + Const.Source.target_pattern (lexbuf_of_string s)) let mk = memo mk diff --git a/ocamlbuild/resource.mli b/ocamlbuild/resource.mli index 0ec15d36e..eb75d3db9 100644 --- a/ocamlbuild/resource.mli +++ b/ocamlbuild/resource.mli @@ -18,6 +18,7 @@ open Pathname type resource_pattern type env +type t = Pathname.t module Resources : Set.S with type elt = t module Cache : diff --git a/ocamlbuild/testsuite/findlibonly.ml b/ocamlbuild/testsuite/findlibonly.ml index 7be8b0fdd..d159ad47b 100644 --- a/ocamlbuild/testsuite/findlibonly.ml +++ b/ocamlbuild/testsuite/findlibonly.ml @@ -32,4 +32,11 @@ let () = test "PredicateFlag" ~matching:[_build [M.f "test.ml.depends"]] ~targets:("test.ml.depends", []) ();; +let () = test "ToolsFlagsConflict" + ~description:"PR#6300: conflicts between -ocamlc and -use-ocamlfind options" + ~options:[`use_ocamlfind; `ocamlc "\"ocamlc -annot\""] + ~tree:[T.f "test.ml" ~content:"let x = 1"] + ~matching:[_build [M.f "test.annot"; M.f "test.byte"]] + ~targets:("test.byte", []) ();; + run ~root:"_test_findlibonly";; diff --git a/ocamlbuild/testsuite/internal.ml b/ocamlbuild/testsuite/internal.ml index 5d3c28840..d0071543f 100644 --- a/ocamlbuild/testsuite/internal.ml +++ b/ocamlbuild/testsuite/internal.ml @@ -162,7 +162,7 @@ let () = test "OutputObj" let () = test "StrictSequenceFlag" ~options:[`no_ocamlfind; `quiet] - ~description:"-strict_sequence tag" + ~description:"strict_sequence tag" ~tree:[T.f "hello.ml" ~content:"let () = 1; ()"; T.f "_tags" ~content:"true: strict_sequence\n"] ~failing_msg:"File \"hello.ml\", line 1, characters 9-10: @@ -170,6 +170,17 @@ Error: This expression has type int but an expression was expected of type unit\nCommand exited with code 2." ~targets:("hello.byte",[]) ();; +let () = test "StrictFormatsFlag" + ~options:[`no_ocamlfind; `quiet] + ~description:"strict_format tag" + ~tree:[T.f "hello.ml" ~content:"let _ = Printf.printf \"%.10s\""; + T.f "_tags" ~content:"true: strict_formats\n"] + ~failing_msg:"File \"hello.ml\", line 1, characters 22-29: +Error: invalid format \"%.10s\": at character number 0, \ +`precision' is incompatible with 's' in sub-format \"%.10s\" +Command exited with code 2." + ~targets:("hello.byte",[]) ();; + let () = test "PrincipalFlag" ~options:[`no_ocamlfind; `quiet] ~description:"-principal tag" @@ -251,4 +262,56 @@ let () = test "PluginTagsWarning" in absence of plugin file \"myocamlbuild.ml\"" ~targets:("main.ml", []) ();; +let () = test "TagsInNonHygienic" + ~description:"Regression test for PR#6482, where a _tags \ + in a non-traversed directory would cause \ + ocamlbuild to abort" + ~options:[`no_ocamlfind] + ~tree:[ + T.f "main.ml" ~content:""; + T.d "deps" [T.f "_tags" ~content:""]; + T.f "_tags" ~content:"<deps>: not_hygienic\n"; + ] + ~matching:[M.f "main.byte"] + ~targets:("main.byte",[]) ();; + +let () = test "TagsNewlines" + ~description:"Regression test for PR#6087 about placement \ + of newline-escaping backslashes" + ~options:[`no_ocamlfind] + ~tree:[ + T.f "main.ml" ~content:""; + T.f "_tags" ~content: +"<foo>: debug,\\ +rectypes +<bar>: \\ +debug, rectypes +<baz>\\ +: debug, rectypes +"; + ] + ~matching:[M.f "main.byte"] + ~targets:("main.byte",[]) ();; + +let () = test "OpenTag" + ~description:"Test the parametrized tag for the new -open feature" + ~options:[`no_ocamlfind] + ~tree:[ + T.f "test.ml" ~content:"let _ = map rev [ []; [3;2] ]"; + T.f "_tags" ~content: "<test.*>: open(List)"; + ] + ~matching:[M.f "test.byte"] + ~targets:("test.byte",[]) ();; + +let () = test "OpenDependencies" + ~description:"Test dependency computation for the new -open feature (PR#6584)" + ~options:[`no_ocamlfind] + ~tree:[ + T.f "a.ml" ~content:"let x = 1"; + T.f "b.ml" ~content:"print_int x; print_newline ()"; + T.f "_tags" ~content: "<b.*>: open(A)"; + ] + ~matching:[M.f "b.byte"] + ~targets:("b.byte",[]) ();; + run ~root:"_test_internal";; diff --git a/ocamldoc/.depend b/ocamldoc/.depend index 38e932e35..0f692a22c 100644 --- a/ocamldoc/.depend +++ b/ocamldoc/.depend @@ -32,16 +32,16 @@ odoc_ast.cmo : ../typing/types.cmi ../typing/typedtree.cmi \ ../typing/predef.cmi ../typing/path.cmi ../parsing/parsetree.cmi \ odoc_value.cmo odoc_types.cmi odoc_type.cmo odoc_sig.cmi \ odoc_parameter.cmo odoc_name.cmi odoc_module.cmo odoc_messages.cmo \ - odoc_global.cmi odoc_exception.cmo odoc_env.cmi odoc_class.cmo \ - ../utils/misc.cmi ../parsing/location.cmi ../typing/ident.cmi \ - ../parsing/asttypes.cmi odoc_ast.cmi + odoc_global.cmi odoc_extension.cmo odoc_exception.cmo odoc_env.cmi \ + odoc_class.cmo ../utils/misc.cmi ../parsing/location.cmi \ + ../typing/ident.cmi ../parsing/asttypes.cmi odoc_ast.cmi odoc_ast.cmx : ../typing/types.cmx ../typing/typedtree.cmx \ ../typing/predef.cmx ../typing/path.cmx ../parsing/parsetree.cmi \ odoc_value.cmx odoc_types.cmx odoc_type.cmx odoc_sig.cmx \ odoc_parameter.cmx odoc_name.cmx odoc_module.cmx odoc_messages.cmx \ - odoc_global.cmx odoc_exception.cmx odoc_env.cmx odoc_class.cmx \ - ../utils/misc.cmx ../parsing/location.cmx ../typing/ident.cmx \ - ../parsing/asttypes.cmi odoc_ast.cmi + odoc_global.cmx odoc_extension.cmx odoc_exception.cmx odoc_env.cmx \ + odoc_class.cmx ../utils/misc.cmx ../parsing/location.cmx \ + ../typing/ident.cmx ../parsing/asttypes.cmi odoc_ast.cmi odoc_class.cmo : ../typing/types.cmi odoc_value.cmo odoc_types.cmi \ odoc_parameter.cmo odoc_name.cmi odoc_class.cmx : ../typing/types.cmx odoc_value.cmx odoc_types.cmx \ @@ -62,12 +62,12 @@ odoc_control.cmo : odoc_control.cmx : odoc_cross.cmo : odoc_value.cmo odoc_types.cmi odoc_type.cmo odoc_search.cmi \ odoc_scan.cmo odoc_parameter.cmo odoc_name.cmi odoc_module.cmo \ - odoc_misc.cmi odoc_messages.cmo odoc_global.cmi odoc_exception.cmo \ - odoc_class.cmo odoc_cross.cmi + odoc_misc.cmi odoc_messages.cmo odoc_global.cmi odoc_extension.cmo \ + odoc_exception.cmo odoc_class.cmo odoc_cross.cmi odoc_cross.cmx : odoc_value.cmx odoc_types.cmx odoc_type.cmx odoc_search.cmx \ odoc_scan.cmx odoc_parameter.cmx odoc_name.cmx odoc_module.cmx \ - odoc_misc.cmx odoc_messages.cmx odoc_global.cmx odoc_exception.cmx \ - odoc_class.cmx odoc_cross.cmi + odoc_misc.cmx odoc_messages.cmx odoc_global.cmx odoc_extension.cmx \ + odoc_exception.cmx odoc_class.cmx odoc_cross.cmi odoc_dag2html.cmo : odoc_info.cmi odoc_dag2html.cmi odoc_dag2html.cmx : odoc_info.cmx odoc_dag2html.cmi odoc_dep.cmo : ../parsing/parsetree.cmi odoc_type.cmo odoc_print.cmi \ @@ -84,6 +84,10 @@ odoc_env.cmx : ../typing/types.cmx ../typing/printtyp.cmx \ ../typing/btype.cmx odoc_env.cmi odoc_exception.cmo : ../typing/types.cmi odoc_types.cmi odoc_name.cmi odoc_exception.cmx : ../typing/types.cmx odoc_types.cmx odoc_name.cmx +odoc_extension.cmo : ../typing/types.cmi odoc_types.cmi odoc_name.cmi \ + ../parsing/asttypes.cmi +odoc_extension.cmx : ../typing/types.cmx odoc_types.cmx odoc_name.cmx \ + ../parsing/asttypes.cmi odoc_gen.cmo : odoc_texi.cmo odoc_module.cmo odoc_man.cmo odoc_latex.cmo \ odoc_html.cmo odoc_dot.cmo odoc_gen.cmi odoc_gen.cmx : odoc_texi.cmx odoc_module.cmx odoc_man.cmx odoc_latex.cmx \ @@ -99,15 +103,15 @@ odoc_html.cmx : odoc_text.cmx odoc_ocamlhtml.cmx odoc_messages.cmx \ odoc_info.cmo : ../typing/printtyp.cmi odoc_value.cmo odoc_types.cmi \ odoc_type.cmo odoc_text.cmi odoc_str.cmi odoc_search.cmi odoc_scan.cmo \ odoc_print.cmi odoc_parameter.cmo odoc_name.cmi odoc_module.cmo \ - odoc_misc.cmi odoc_global.cmi odoc_exception.cmo odoc_dep.cmo \ - odoc_config.cmi odoc_comments.cmi odoc_class.cmo odoc_analyse.cmi \ - ../parsing/location.cmi odoc_info.cmi + odoc_misc.cmi odoc_global.cmi odoc_extension.cmo odoc_exception.cmo \ + odoc_dep.cmo odoc_config.cmi odoc_comments.cmi odoc_class.cmo \ + odoc_analyse.cmi ../parsing/location.cmi odoc_info.cmi odoc_info.cmx : ../typing/printtyp.cmx odoc_value.cmx odoc_types.cmx \ odoc_type.cmx odoc_text.cmx odoc_str.cmx odoc_search.cmx odoc_scan.cmx \ odoc_print.cmx odoc_parameter.cmx odoc_name.cmx odoc_module.cmx \ - odoc_misc.cmx odoc_global.cmx odoc_exception.cmx odoc_dep.cmx \ - odoc_config.cmx odoc_comments.cmx odoc_class.cmx odoc_analyse.cmx \ - ../parsing/location.cmx odoc_info.cmi + odoc_misc.cmx odoc_global.cmx odoc_extension.cmx odoc_exception.cmx \ + odoc_dep.cmx odoc_config.cmx odoc_comments.cmx odoc_class.cmx \ + odoc_analyse.cmx ../parsing/location.cmx odoc_info.cmi odoc_inherit.cmo : odoc_inherit.cmx : odoc_latex.cmo : odoc_to_text.cmo odoc_messages.cmo odoc_latex_style.cmo \ @@ -126,10 +130,12 @@ odoc_man.cmx : odoc_str.cmx odoc_print.cmx odoc_misc.cmx odoc_messages.cmx \ odoc_info.cmx ../utils/misc.cmx ../parsing/asttypes.cmi odoc_merge.cmo : odoc_value.cmo odoc_types.cmi odoc_type.cmo \ odoc_parameter.cmo odoc_name.cmi odoc_module.cmo odoc_messages.cmo \ - odoc_global.cmi odoc_exception.cmo odoc_class.cmo odoc_merge.cmi + odoc_global.cmi odoc_extension.cmo odoc_exception.cmo odoc_class.cmo \ + odoc_merge.cmi odoc_merge.cmx : odoc_value.cmx odoc_types.cmx odoc_type.cmx \ odoc_parameter.cmx odoc_name.cmx odoc_module.cmx odoc_messages.cmx \ - odoc_global.cmx odoc_exception.cmx odoc_class.cmx odoc_merge.cmi + odoc_global.cmx odoc_extension.cmx odoc_exception.cmx odoc_class.cmx \ + odoc_merge.cmi odoc_messages.cmo : ../utils/config.cmi odoc_messages.cmx : ../utils/config.cmx odoc_misc.cmo : ../typing/types.cmi ../typing/predef.cmi ../typing/path.cmi \ @@ -139,9 +145,11 @@ odoc_misc.cmx : ../typing/types.cmx ../typing/predef.cmx ../typing/path.cmx \ odoc_types.cmx odoc_messages.cmx ../parsing/longident.cmx \ ../typing/ctype.cmx ../typing/btype.cmx odoc_misc.cmi odoc_module.cmo : ../typing/types.cmi odoc_value.cmo odoc_types.cmi \ - odoc_type.cmo odoc_name.cmi odoc_exception.cmo odoc_class.cmo + odoc_type.cmo odoc_name.cmi odoc_extension.cmo odoc_exception.cmo \ + odoc_class.cmo odoc_module.cmx : ../typing/types.cmx odoc_value.cmx odoc_types.cmx \ - odoc_type.cmx odoc_name.cmx odoc_exception.cmx odoc_class.cmx + odoc_type.cmx odoc_name.cmx odoc_extension.cmx odoc_exception.cmx \ + odoc_class.cmx odoc_name.cmo : ../typing/path.cmi odoc_misc.cmi ../typing/ident.cmi \ odoc_name.cmi odoc_name.cmx : ../typing/path.cmx odoc_misc.cmx ../typing/ident.cmx \ @@ -157,38 +165,40 @@ odoc_print.cmo : ../typing/types.cmi ../typing/printtyp.cmi \ odoc_print.cmx : ../typing/types.cmx ../typing/printtyp.cmx \ ../utils/misc.cmx odoc_print.cmi odoc_scan.cmo : odoc_value.cmo odoc_types.cmi odoc_type.cmo odoc_module.cmo \ - odoc_exception.cmo odoc_class.cmo + odoc_extension.cmo odoc_exception.cmo odoc_class.cmo odoc_scan.cmx : odoc_value.cmx odoc_types.cmx odoc_type.cmx odoc_module.cmx \ - odoc_exception.cmx odoc_class.cmx + odoc_extension.cmx odoc_exception.cmx odoc_class.cmx odoc_search.cmo : odoc_value.cmo odoc_types.cmi odoc_type.cmo \ - odoc_parameter.cmo odoc_name.cmi odoc_module.cmo odoc_exception.cmo \ - odoc_class.cmo odoc_search.cmi + odoc_parameter.cmo odoc_name.cmi odoc_module.cmo odoc_extension.cmo \ + odoc_exception.cmo odoc_class.cmo odoc_search.cmi odoc_search.cmx : odoc_value.cmx odoc_types.cmx odoc_type.cmx \ - odoc_parameter.cmx odoc_name.cmx odoc_module.cmx odoc_exception.cmx \ - odoc_class.cmx odoc_search.cmi + odoc_parameter.cmx odoc_name.cmx odoc_module.cmx odoc_extension.cmx \ + odoc_exception.cmx odoc_class.cmx odoc_search.cmi odoc_see_lexer.cmo : odoc_parser.cmi odoc_see_lexer.cmx : odoc_parser.cmx odoc_sig.cmo : ../typing/types.cmi ../typing/typedtree.cmi \ ../typing/path.cmi ../parsing/parsetree.cmi odoc_value.cmo odoc_types.cmi \ odoc_type.cmo odoc_parameter.cmo odoc_name.cmi odoc_module.cmo \ odoc_misc.cmi odoc_messages.cmo odoc_merge.cmi odoc_global.cmi \ - odoc_exception.cmo odoc_env.cmi odoc_class.cmo ../utils/misc.cmi \ - ../parsing/location.cmi ../typing/ident.cmi ../typing/btype.cmi \ - ../parsing/asttypes.cmi odoc_sig.cmi + odoc_extension.cmo odoc_exception.cmo odoc_env.cmi odoc_class.cmo \ + ../utils/misc.cmi ../parsing/location.cmi ../typing/ident.cmi \ + ../typing/ctype.cmi ../typing/btype.cmi ../parsing/asttypes.cmi \ + odoc_sig.cmi odoc_sig.cmx : ../typing/types.cmx ../typing/typedtree.cmx \ ../typing/path.cmx ../parsing/parsetree.cmi odoc_value.cmx odoc_types.cmx \ odoc_type.cmx odoc_parameter.cmx odoc_name.cmx odoc_module.cmx \ odoc_misc.cmx odoc_messages.cmx odoc_merge.cmx odoc_global.cmx \ - odoc_exception.cmx odoc_env.cmx odoc_class.cmx ../utils/misc.cmx \ - ../parsing/location.cmx ../typing/ident.cmx ../typing/btype.cmx \ - ../parsing/asttypes.cmi odoc_sig.cmi + odoc_extension.cmx odoc_exception.cmx odoc_env.cmx odoc_class.cmx \ + ../utils/misc.cmx ../parsing/location.cmx ../typing/ident.cmx \ + ../typing/ctype.cmx ../typing/btype.cmx ../parsing/asttypes.cmi \ + odoc_sig.cmi odoc_str.cmo : ../typing/types.cmi ../typing/printtyp.cmi odoc_value.cmo \ odoc_type.cmo odoc_print.cmi odoc_name.cmi odoc_misc.cmi \ - odoc_messages.cmo odoc_exception.cmo odoc_class.cmo \ + odoc_messages.cmo odoc_extension.cmo odoc_exception.cmo odoc_class.cmo \ ../parsing/asttypes.cmi odoc_str.cmi odoc_str.cmx : ../typing/types.cmx ../typing/printtyp.cmx odoc_value.cmx \ odoc_type.cmx odoc_print.cmx odoc_name.cmx odoc_misc.cmx \ - odoc_messages.cmx odoc_exception.cmx odoc_class.cmx \ + odoc_messages.cmx odoc_extension.cmx odoc_exception.cmx odoc_class.cmx \ ../parsing/asttypes.cmi odoc_str.cmi odoc_test.cmo : odoc_info.cmi odoc_gen.cmi odoc_args.cmi odoc_test.cmx : odoc_info.cmx odoc_gen.cmx odoc_args.cmx @@ -219,8 +229,7 @@ odoc_value.cmx : ../typing/types.cmx ../typing/printtyp.cmx odoc_types.cmx \ odoc_analyse.cmi : odoc_module.cmo odoc_global.cmi odoc_args.cmi : odoc_gen.cmi odoc_ast.cmi : ../typing/types.cmi ../typing/typedtree.cmi \ - ../typing/path.cmi ../parsing/parsetree.cmi odoc_sig.cmi odoc_name.cmi \ - odoc_module.cmo + ../parsing/parsetree.cmi odoc_sig.cmi odoc_name.cmi odoc_module.cmo odoc_comments.cmi : odoc_types.cmi odoc_module.cmo odoc_comments_global.cmi : odoc_config.cmi : @@ -232,7 +241,8 @@ odoc_gen.cmi : odoc_texi.cmo odoc_module.cmo odoc_man.cmo odoc_latex.cmo \ odoc_global.cmi : odoc_types.cmi odoc_info.cmi : ../typing/types.cmi odoc_value.cmo odoc_types.cmi \ odoc_type.cmo odoc_search.cmi odoc_parameter.cmo odoc_module.cmo \ - odoc_global.cmi odoc_exception.cmo odoc_class.cmo ../parsing/location.cmi + odoc_global.cmi odoc_extension.cmo odoc_exception.cmo odoc_class.cmo \ + ../parsing/location.cmi odoc_merge.cmi : odoc_types.cmi odoc_module.cmo odoc_misc.cmi : ../typing/types.cmi odoc_types.cmi ../parsing/longident.cmi odoc_name.cmi : ../typing/path.cmi ../parsing/longident.cmi \ @@ -240,11 +250,11 @@ odoc_name.cmi : ../typing/path.cmi ../parsing/longident.cmi \ odoc_parser.cmi : odoc_types.cmi odoc_print.cmi : ../typing/types.cmi odoc_search.cmi : odoc_value.cmo odoc_types.cmi odoc_type.cmo \ - odoc_module.cmo odoc_exception.cmo odoc_class.cmo + odoc_module.cmo odoc_extension.cmo odoc_exception.cmo odoc_class.cmo odoc_sig.cmi : ../typing/types.cmi ../parsing/parsetree.cmi odoc_types.cmi \ odoc_type.cmo odoc_name.cmi odoc_module.cmo odoc_env.cmi odoc_class.cmo odoc_str.cmi : ../typing/types.cmi odoc_value.cmo odoc_type.cmo \ - odoc_exception.cmo odoc_class.cmo + odoc_extension.cmo odoc_exception.cmo odoc_class.cmo odoc_text.cmi : odoc_types.cmi odoc_text_parser.cmi : odoc_types.cmi odoc_types.cmi : ../parsing/location.cmi diff --git a/ocamldoc/Makefile b/ocamldoc/Makefile index 6de33180d..7a487c6ca 100644 --- a/ocamldoc/Makefile +++ b/ocamldoc/Makefile @@ -14,14 +14,15 @@ include ../config/Makefile # Various commands and dir ########################## -CAMLRUN=../boot/ocamlrun -OCAMLC = ../ocamlcomp.sh -OCAMLOPT = ../ocamlcompopt.sh -OCAMLDEP = $(CAMLRUN) ../tools/ocamldep -OCAMLLEX = $(CAMLRUN) ../boot/ocamllex -OCAMLYACC= ../boot/ocamlyacc -OCAMLLIB = $(LIBDIR) -OCAMLBIN = $(BINDIR) +ROOTDIR = .. +OCAMLRUN = $(ROOTDIR)/boot/ocamlrun +OCAMLC = $(OCAMLRUN) $(ROOTDIR)/ocamlc -nostdlib -I $(ROOTDIR)/stdlib +OCAMLOPT = $(OCAMLRUN) $(ROOTDIR)/ocamlopt -nostdlib -I $(ROOTDIR)/stdlib +OCAMLDEP = $(OCAMLRUN) $(ROOTDIR)/tools/ocamldep +OCAMLLEX = $(OCAMLRUN) $(ROOTDIR)/boot/ocamllex +OCAMLYACC = $(ROOTDIR)/yacc/ocamlyacc +OCAMLLIB = $(LIBDIR) +OCAMLBIN = $(BINDIR) OCAMLPP=-pp './remove_DEBUG' @@ -36,10 +37,11 @@ OCAMLDOC_LIBCMA=odoc_info.cma OCAMLDOC_LIBCMI=odoc_info.cmi OCAMLDOC_LIBCMXA=odoc_info.cmxa OCAMLDOC_LIBA=odoc_info.$(A) -INSTALL_LIBDIR=$(OCAMLLIB)/ocamldoc +INSTALL_LIBDIR=$(DESTDIR)$(OCAMLLIB)/ocamldoc INSTALL_CUSTOMDIR=$(INSTALL_LIBDIR)/custom -INSTALL_BINDIR=$(OCAMLBIN) -INSTALL_MANODIR=$(MANDIR)/man3 +INSTALL_BINDIR=$(DESTDIR)$(OCAMLBIN) +#MANO: man ocamldoc +INSTALL_MANODIR=$(DESTDIR)$(MANDIR)/man3 INSTALL_MLIS=odoc_info.mli INSTALL_CMIS=$(INSTALL_MLIS:.mli=.cmi) @@ -74,7 +76,7 @@ INCLUDES_NODEP= -I $(OCAMLSRCDIR)/stdlib \ INCLUDES=$(INCLUDES_DEP) $(INCLUDES_NODEP) -COMPFLAGS=$(INCLUDES) -warn-error A +COMPFLAGS=$(INCLUDES) -warn-error A -safe-string LINKFLAGS=$(INCLUDES) -nostdlib CMOFILES= odoc_config.cmo \ @@ -89,6 +91,7 @@ CMOFILES= odoc_config.cmo \ odoc_parameter.cmo\ odoc_value.cmo\ odoc_type.cmo\ + odoc_extension.cmo\ odoc_exception.cmo\ odoc_class.cmo\ odoc_module.cmo\ @@ -145,6 +148,7 @@ OCAMLCMXFILES=$(OCAMLCMOFILES:.cmo=.cmx) STDLIB_MLIS=../stdlib/*.mli \ + ../parsing/*.mli \ ../otherlibs/$(UNIXLIB)/unix.mli \ ../otherlibs/str/str.mli \ ../otherlibs/bigarray/bigarray.mli \ @@ -169,16 +173,23 @@ debug: $(MAKE) OCAMLPP="" $(OCAMLDOC): $(EXECMOFILES) - $(OCAMLC) -o $@ -linkall unix.cma str.cma dynlink.cma $(OCAMLSRCDIR)/compilerlibs/ocamlcommon.cma $(LINKFLAGS) $(OCAMLCMOFILES) $(EXECMOFILES) + $(OCAMLC) -o $@ -linkall unix.cma str.cma dynlink.cma \ + $(OCAMLSRCDIR)/compilerlibs/ocamlcommon.cma \ + $(LINKFLAGS) $(OCAMLCMOFILES) $(EXECMOFILES) $(OCAMLDOC_OPT): $(EXECMXFILES) - $(OCAMLOPT) -o $@ -linkall unix.cmxa str.cmxa dynlink.cmxa $(OCAMLSRCDIR)/compilerlibs/ocamlcommon.cmxa $(LINKFLAGS) $(OCAMLCMXFILES) $(EXECMXFILES) + $(OCAMLOPT) -o $@ -linkall unix.cmxa str.cmxa dynlink.cmxa \ + $(OCAMLSRCDIR)/compilerlibs/ocamlcommon.cmxa \ + $(LINKFLAGS) $(OCAMLCMXFILES) $(EXECMXFILES) $(OCAMLDOC_LIBCMA): $(LIBCMOFILES) - $(OCAMLC) -a -o $@ $(LINKFLAGS) $(OCAMLSRCDIR)/tools/depend.cmo $(LIBCMOFILES) + $(OCAMLC) -a -o $@ $(LINKFLAGS) $(OCAMLSRCDIR)/tools/depend.cmo \ + $(LIBCMOFILES) $(OCAMLDOC_LIBCMXA): $(LIBCMXFILES) - $(OCAMLOPT) -a -o $@ $(LINKFLAGS) $(OCAMLSRCDIR)/tools/depend.cmx $(LIBCMXFILES) + $(OCAMLOPT) -a -o $@ $(LINKFLAGS) $(OCAMLSRCDIR)/tools/depend.cmx \ + $(LIBCMXFILES) manpages: stdlib_man/Pervasives.3o +html_doc: stdlib_html/Pervasives.html dot: $(EXECMOFILES) $(OCAMLDOC_RUN) -dot -dot-reduce -o ocamldoc.dot $(INCLUDES) \ @@ -240,7 +251,7 @@ install: dummy if test -d stdlib_man; then $(CP) stdlib_man/* $(INSTALL_MANODIR); else : ; fi installopt: - if test -f $(OCAMLDOC_OPT) ; then $(MAKE) installopt_really ; fi + if test -f $(OCAMLDOC_OPT); then $(MAKE) installopt_really ; fi installopt_really: if test -d $(INSTALL_BINDIR); then : ; else $(MKDIR) $(INSTALL_BINDIR); fi @@ -304,6 +315,13 @@ stdlib_man/Pervasives.3o: $(STDLIB_MLIS) -t "OCaml library" -man-mini \ $(STDLIB_MLIS) +stdlib_html/Pervasives.html: $(STDLIB_MLIS) + $(MKDIR) stdlib_html + $(OCAMLDOC_RUN) -d stdlib_html -html $(INCLUDES) \ + -t "OCaml library" \ + $(STDLIB_MLIS) + + autotest_stdlib: dummy $(MKDIR) $@ $(OCAMLDOC_RUN) -g autotest/odoc_test.cmo\ diff --git a/ocamldoc/Makefile.nt b/ocamldoc/Makefile.nt index ff4b3fdc2..22cd36eb0 100644 --- a/ocamldoc/Makefile.nt +++ b/ocamldoc/Makefile.nt @@ -14,14 +14,15 @@ include ../config/Makefile # Various commands and dir ########################## -CAMLRUN=../boot/ocamlrun -OCAMLC = ../ocamlcomp.sh -OCAMLOPT = ../ocamlcompopt.sh -OCAMLDEP = $(CAMLRUN) ../tools/ocamldep -OCAMLLEX = $(CAMLRUN) ../boot/ocamllex -OCAMLYACC= ../boot/ocamlyacc -OCAMLLIB = $(LIBDIR) -OCAMLBIN = $(BINDIR) +ROOTDIR = .. +OCAMLRUN = $(ROOTDIR)/boot/ocamlrun +OCAMLC = $(OCAMLRUN) $(ROOTDIR)/ocamlc -nostdlib -I $(ROOTDIR)/stdlib +OCAMLOPT = $(OCAMLRUN) $(ROOTDIR)/ocamlopt -nostdlib -I $(ROOTDIR)/stdlib +OCAMLDEP = $(OCAMLRUN) $(ROOTDIR)/tools/ocamldep +OCAMLLEX = $(OCAMLRUN) $(ROOTDIR)/boot/ocamllex +OCAMLYACC = $(ROOTDIR)/yacc/ocamlyacc +OCAMLLIB = $(LIBDIR) +OCAMLBIN = $(BINDIR) OCAMLPP=-pp "grep -v DEBUG" @@ -36,9 +37,9 @@ OCAMLDOC_LIBCMA=odoc_info.cma OCAMLDOC_LIBCMI=odoc_info.cmi OCAMLDOC_LIBCMXA=odoc_info.cmxa OCAMLDOC_LIBA=odoc_info.$(A) -INSTALL_LIBDIR=$(OCAMLLIB)/ocamldoc +INSTALL_LIBDIR=$(DESTDIR)$(OCAMLLIB)/ocamldoc INSTALL_CUSTOMDIR=$(INSTALL_LIBDIR)/custom -INSTALL_BINDIR=$(OCAMLBIN) +INSTALL_BINDIR=$(DESTDIR)$(OCAMLBIN) INSTALL_MLIS=odoc_info.mli INSTALL_CMIS=$(INSTALL_MLIS:.mli=.cmi) @@ -57,13 +58,13 @@ INCLUDES_DEP=-I $(OCAMLSRCDIR)/parsing \ INCLUDES_NODEP= -I $(OCAMLSRCDIR)/stdlib \ -I $(OCAMLSRCDIR)/otherlibs/str \ -I $(OCAMLSRCDIR)/otherlibs/dynlink \ - -I $(OCAMLSRCDIR)/otherlibs/win32unix \ + -I $(OCAMLSRCDIR)/otherlibs/$(UNIXLIB) \ -I $(OCAMLSRCDIR)/otherlibs/num \ - -I $(OCAMLSRCDIR)/otherlibs/win32graph + -I $(OCAMLSRCDIR)/otherlibs/$(GRAPHLIB) INCLUDES=$(INCLUDES_DEP) $(INCLUDES_NODEP) -COMPFLAGS=$(INCLUDES) -warn-error A +COMPFLAGS=$(INCLUDES) -warn-error A -safe-string LINKFLAGS=$(INCLUDES) -nostdlib CMOFILES= odoc_config.cmo \ @@ -78,6 +79,7 @@ CMOFILES= odoc_config.cmo \ odoc_parameter.cmo\ odoc_value.cmo\ odoc_type.cmo\ + odoc_extension.cmo\ odoc_exception.cmo\ odoc_class.cmo\ odoc_module.cmo\ @@ -119,7 +121,6 @@ EXECMOFILES=$(CMOFILES) \ odoc_args.cmo \ odoc.cmo - EXECMXFILES= $(EXECMOFILES:.cmo=.cmx) EXECMIFILES= $(EXECMOFILES:.cmo=.cmi) @@ -133,25 +134,35 @@ OCAMLCMOFILES= \ OCAMLCMXFILES=$(OCAMLCMOFILES:.cmo=.cmx) -all: exe lib +all: + $(MAKEREC) exe + $(MAKEREC) lib + exe: $(OCAMLDOC) lib: $(OCAMLDOC_LIBCMA) $(OCAMLDOC_LIBCMI) opt.opt: exeopt libopt exeopt: $(OCAMLDOC_OPT) libopt: $(OCAMLDOC_LIBCMXA) $(OCAMLDOC_LIBCMI) + debug: - $(MAKE) OCAMLPP="" + $(MAKEREC) OCAMLPP="" $(OCAMLDOC): $(EXECMOFILES) - $(OCAMLC) -o $@ -linkall unix.cma str.cma dynlink.cma $(OCAMLSRCDIR)/compilerlibs/ocamlcommon.cma $(LINKFLAGS) $(OCAMLCMOFILES) $(EXECMOFILES) + $(OCAMLC) -o $@ -linkall unix.cma str.cma dynlink.cma \ + $(OCAMLSRCDIR)/compilerlibs/ocamlcommon.cma \ + $(LINKFLAGS) $(OCAMLCMOFILES) $(EXECMOFILES) $(OCAMLDOC_OPT): $(EXECMXFILES) - $(OCAMLOPT) -o $@ unix.cmxa str.cmxa dynlink.cmxa $(OCAMLSRCDIR)/compilerlibs/ocamlcommon.cmxa $(LINKFLAGS) $(OCAMLCMXFILES) $(EXECMXFILES) + $(OCAMLOPT) -o $@ -linkall unix.cmxa str.cmxa dynlink.cmxa \ + $(OCAMLSRCDIR)/compilerlibs/ocamlcommon.cmxa \ + $(LINKFLAGS) $(OCAMLCMXFILES) $(EXECMXFILES) $(OCAMLDOC_LIBCMA): $(LIBCMOFILES) - $(OCAMLC) -a -o $@ $(LINKFLAGS) $(OCAMLCMOFILES) $(LIBCMOFILES) + $(OCAMLC) -a -o $@ $(LINKFLAGS) $(OCAMLSRCDIR)/tools/depend.cmo \ + $(LIBCMOFILES) $(OCAMLDOC_LIBCMXA): $(LIBCMXFILES) - $(OCAMLOPT) -a -o $@ $(LINKFLAGS) $(OCAMLCMXFILES) $(LIBCMXFILES) + $(OCAMLOPT) -a -o $@ $(LINKFLAGS) $(OCAMLSRCDIR)/tools/depend.cmx \ + $(LIBCMXFILES) # Parsers and lexers dependencies : ################################### @@ -220,7 +231,7 @@ installopt_really: ############################ clean:: dummy - @rm -f *~ /#*/# + @rm -f *~ \#*\# @rm -f $(OCAMLDOC) $(OCAMLDOC_OPT) *.cma *.cmxa *.cmo *.cmi *.cmx *.$(A) *.$(O) @rm -f odoc_parser.output odoc_text_parser.output @rm -f odoc_lexer.ml odoc_text_lexer.ml odoc_see_lexer.ml odoc_ocamlhtml.ml diff --git a/ocamldoc/generators/odoc_todo.ml b/ocamldoc/generators/odoc_todo.ml index 31545feef..9dbf9f375 100644 --- a/ocamldoc/generators/odoc_todo.ml +++ b/ocamldoc/generators/odoc_todo.ml @@ -18,6 +18,7 @@ module Naming = Odoc_html.Naming open Odoc_info.Value open Odoc_info.Module open Odoc_info.Type +open Odoc_info.Extension open Odoc_info.Exception open Odoc_info.Class @@ -115,6 +116,12 @@ struct (Odoc_html.Naming.complete_type_target t) t.ty_info + method scan_extension_constructor x = + self#gen_if_tag + x.xt_name + (Odoc_html.Naming.complete_extension_target x) + x.xt_type_extension.te_info + method scan_exception e = self#gen_if_tag e.ex_name @@ -144,6 +151,7 @@ struct | Odoc_module.Element_class c -> self#scan_class c | Odoc_module.Element_class_type ct -> self#scan_class_type ct | Odoc_module.Element_value v -> self#scan_value v + | Odoc_module.Element_type_extension te -> self#scan_type_extension te | Odoc_module.Element_exception e -> self#scan_exception e | Odoc_module.Element_type t -> self#scan_type t | Odoc_module.Element_module_comment t -> self#scan_module_comment t diff --git a/ocamldoc/odoc_analyse.ml b/ocamldoc/odoc_analyse.ml index 98f73617d..fd69b0a74 100644 --- a/ocamldoc/odoc_analyse.ml +++ b/ocamldoc/odoc_analyse.ml @@ -33,10 +33,13 @@ let init_path () = (** Return the initial environment in which compilation proceeds. *) let initial_env () = + let initial = + if !Clflags.unsafe_string then Env.initial_unsafe_string + else Env.initial_safe_string + in try - if !Clflags.nopervasives - then Env.initial - else Env.open_pers_signature "Pervasives" Env.initial + if !Clflags.nopervasives then initial else + Env.open_pers_signature "Pervasives" initial with Not_found -> fatal_error "cannot open pervasives.cmi" @@ -53,6 +56,9 @@ let (++) x f = f x (** Analysis of an implementation file. Returns (Some typedtree) if no error occured, else None and an error message is printed.*) + +let tool_name = "ocamldoc" + let process_implementation_file ppf sourcefile = init_path (); let prefixname = Filename.chop_extension sourcefile in @@ -61,7 +67,10 @@ let process_implementation_file ppf sourcefile = let inputfile = preprocess sourcefile in let env = initial_env () in try - let parsetree = Pparse.file Format.err_formatter inputfile Parse.implementation ast_impl_magic_number in + let parsetree = + Pparse.file ~tool_name Format.err_formatter inputfile + Parse.implementation ast_impl_magic_number + in let typedtree = Typemod.type_implementation sourcefile prefixname modulename env parsetree @@ -89,8 +98,11 @@ let process_interface_file ppf sourcefile = let modulename = String.capitalize(Filename.basename prefixname) in Env.set_unit_name modulename; let inputfile = preprocess sourcefile in - let ast = Pparse.file Format.err_formatter inputfile Parse.interface ast_intf_magic_number in - let sg = Typemod.transl_signature (initial_env()) ast in + let ast = + Pparse.file ~tool_name Format.err_formatter inputfile + Parse.interface ast_intf_magic_number + in + let sg = Typemod.type_interface (initial_env()) ast in Warnings.check_fatal (); (ast, sg, inputfile) @@ -318,6 +330,7 @@ let rec remove_module_elements_between_stop keep eles = else f keep q | Odoc_module.Element_value _ + | Odoc_module.Element_type_extension _ | Odoc_module.Element_exception _ | Odoc_module.Element_type _ -> if keep then @@ -427,7 +440,7 @@ let analyse_files ?(init=[]) files = ); if !Odoc_global.sort_modules then - Sort.list (fun m1 -> fun m2 -> m1.Odoc_module.m_name < m2.Odoc_module.m_name) merged_modules + List.sort (fun m1 m2 -> compare m1.Odoc_module.m_name m2.Odoc_module.m_name) merged_modules else merged_modules diff --git a/ocamldoc/odoc_ast.ml b/ocamldoc/odoc_ast.ml index 18e474a79..ce71070ef 100644 --- a/ocamldoc/odoc_ast.ml +++ b/ocamldoc/odoc_ast.ml @@ -25,6 +25,7 @@ module Name = Odoc_name open Odoc_parameter open Odoc_value open Odoc_type +open Odoc_extension open Odoc_exception open Odoc_class open Odoc_module @@ -48,8 +49,8 @@ module Typedtree_search = | T of string | C of string | CT of string + | X of string | E of string - | ER of string | P of string | IM of string @@ -75,10 +76,13 @@ module Typedtree_search = mods | Typedtree.Tstr_modtype mtd -> Hashtbl.add table (MT (Name.from_ident mtd.mtd_id)) tt - | Typedtree.Tstr_exception decl -> - Hashtbl.add table (E (Name.from_ident decl.cd_id)) tt - | Typedtree.Tstr_exn_rebind (ident, _, _, _, _) -> - Hashtbl.add table (ER (Name.from_ident ident)) tt + | Typedtree.Tstr_typext te -> begin + match te.tyext_constructors with + [] -> assert false + | ext :: _ -> Hashtbl.add table (X (Name.from_ident ext.ext_id)) tt + end + | Typedtree.Tstr_exception ext -> + Hashtbl.add table (E (Name.from_ident ext.ext_id)) tt | Typedtree.Tstr_type ident_type_decl_list -> List.iter (fun td -> @@ -129,14 +133,14 @@ module Typedtree_search = | (Typedtree.Tstr_modtype mtd) -> mtd | _ -> assert false - let search_exception table name = - match Hashtbl.find table (E name) with - | (Typedtree.Tstr_exception decl) -> decl + let search_extension table name = + match Hashtbl.find table (X name) with + | (Typedtree.Tstr_typext tyext) -> tyext | _ -> assert false - let search_exception_rebind table name = - match Hashtbl.find table (ER name) with - | (Typedtree.Tstr_exn_rebind (_, _, p, _, _)) -> p + let search_exception table name = + match Hashtbl.find table (E name) with + | (Typedtree.Tstr_exception ext) -> ext | _ -> assert false let search_type_declaration table name = @@ -679,6 +683,9 @@ module Analyser = | (Parsetree.Pcf_initializer exp) -> iter acc_inher acc_fields exp.Parsetree.pexp_loc.Location.loc_end.Lexing.pos_cnum q + | Parsetree.Pcf_attribute _ -> + iter acc_inher acc_fields loc.Location.loc_end.Lexing.pos_cnum q + | Parsetree.Pcf_extension _ -> assert false in iter [] [] last_pos (p_cls.Parsetree.pcstr_fields) @@ -890,10 +897,10 @@ module Analyser = let tt_get_included_module_list tt_structure = let f acc item = match item.str_desc with - Typedtree.Tstr_include (mod_expr, _, _) -> + Typedtree.Tstr_include incl -> acc @ [ { (* A VOIR : chercher dans les modules et les module types, avec quel env ? *) - im_name = tt_name_from_module_expr mod_expr ; + im_name = tt_name_from_module_expr incl.incl_mod ; im_module = None ; im_info = None ; } @@ -979,9 +986,17 @@ module Analyser = and n2 = Ident.name ident in n1 = n2 | _ -> false) + | Element_type_extension te -> + let l = + filter_extension_constructors_with_module_type_constraint + te.te_constructors lsig + in + te.te_constructors <- l; + if l <> [] then (fun _ -> true) + else (fun _ -> false) | Element_exception e -> (function - Types.Sig_exception (ident,_) -> + Types.Sig_typext (ident,_,_) -> let n1 = Name.simple e.ex_name and n2 = Ident.name ident in n1 = n2 @@ -1007,6 +1022,19 @@ module Analyser = in List.filter pred l + and filter_extension_constructors_with_module_type_constraint l lsig = + let pred xt = + List.exists + (function + Types.Sig_typext (ident, _, _) -> + let n1 = Name.simple xt.xt_name + and n2 = Ident.name ident in + n1 = n2 + | _ -> false) + lsig + in + List.filter pred l + (** Analysis of a parse tree structure with a typed tree, to return module elements.*) let rec analyse_structure env current_module_name last_pos pos_limit parsetree typedtree = print_DEBUG "Odoc_ast:analyse_struture"; @@ -1178,10 +1206,7 @@ module Analyser = | td :: _ -> td.Parsetree.ptype_loc.Location.loc_start.Lexing.pos_cnum in let (maybe_more, name_comment_list) = - Sig.name_comment_from_type_kind - loc_end - pos_limit2 - type_decl.Parsetree.ptype_kind + Sig.name_comment_from_type_decl loc_end pos_limit2 type_decl in let tt_type_decl = try Typedtree_search.search_type_declaration table name @@ -1215,7 +1240,8 @@ module Analyser = ty_manifest = (match tt_type_decl.Types.type_manifest with None -> None - | Some t -> Some (Odoc_env.subst_type new_env t)); + | Some t -> + Some (Sig.manifest_structure new_env name_comment_list t)); ty_loc = { loc_impl = Some loc ; loc_inter = None } ; ty_code = ( @@ -1238,61 +1264,158 @@ module Analyser = let (maybe_more, eles) = f ~first: true 0 loc.Location.loc_start.Lexing.pos_cnum name_typedecl_list in (maybe_more, new_env, eles) - | Parsetree.Pstr_exception excep_decl -> - let name = excep_decl.Parsetree.pcd_name in - (* a new exception is defined *) - let complete_name = Name.concat current_module_name name.txt in - (* we get the exception declaration in the typed tree *) - let tt_excep_decl = - try Typedtree_search.search_exception table name.txt - with Not_found -> - raise (Failure (Odoc_messages.exception_not_found_in_typedtree complete_name)) + | Parsetree.Pstr_typext tyext -> + (* we get the extension declaration in the typed tree *) + let tt_tyext = + match tyext.Parsetree.ptyext_constructors with + [] -> assert false + | ext :: _ -> + try + Typedtree_search.search_extension table ext.Parsetree.pext_name.txt + with Not_found -> + raise (Failure + (Odoc_messages.extension_not_found_in_typedtree + (Name.concat current_module_name ext.Parsetree.pext_name.txt))) + in + let new_env = + List.fold_left + (fun acc_env -> fun {Parsetree.pext_name = { txt = name }} -> + let complete_name = Name.concat current_module_name name in + Odoc_env.add_extension acc_env complete_name + ) + env + tyext.Parsetree.ptyext_constructors in - let new_env = Odoc_env.add_exception env complete_name in let loc_start = loc.Location.loc_start.Lexing.pos_cnum in let loc_end = loc.Location.loc_end.Lexing.pos_cnum in - let new_ex = + let new_te = { - ex_name = complete_name ; - ex_info = comment_opt ; - ex_args = List.map (fun ctyp -> - Odoc_env.subst_type new_env ctyp.ctyp_type) - tt_excep_decl.cd_args; - ex_alias = None ; - ex_loc = { loc_impl = Some loc ; loc_inter = None } ; - ex_code = + te_info = comment_opt; + te_type_name = + Odoc_env.full_type_name new_env (Name.from_path tt_tyext.tyext_path); + te_type_parameters = + List.map (fun (ctyp, _) -> Odoc_env.subst_type new_env ctyp.ctyp_type) tt_tyext.tyext_params; + te_private = tt_tyext.tyext_private; + te_constructors = []; + te_loc = { loc_impl = Some loc ; loc_inter = None } ; + te_code = ( - if !Odoc_global.keep_code then - Some (get_string_of_file loc_start loc_end) - else - None + if !Odoc_global.keep_code then + Some (get_string_of_file loc_start loc_end) + else + None ) ; } in - (0, new_env, [ Element_exception new_ex ]) + let rec analyse_extension_constructors maybe_more exts_acc tt_ext_list = + match tt_ext_list with + [] -> (maybe_more, List.rev exts_acc) + | tt_ext :: q -> + let complete_name = Name.concat current_module_name tt_ext.ext_name.txt in + let ext_loc_end = tt_ext.ext_loc.Location.loc_end.Lexing.pos_cnum in + let new_xt = + match tt_ext.ext_kind with + Text_decl(args, ret_type) -> + let xt_args = + match args with + | Cstr_tuple l -> Cstr_tuple (List.map (fun ctyp -> Odoc_env.subst_type new_env ctyp.ctyp_type) l) + | Cstr_record _ -> assert false + in + { + xt_name = complete_name; + xt_args; + xt_ret = + may_map (fun ctyp -> Odoc_env.subst_type new_env ctyp.ctyp_type) ret_type; + xt_type_extension = new_te; + xt_alias = None; + xt_loc = { loc_impl = Some tt_ext.ext_loc ; loc_inter = None } ; + xt_text = None; + } + | Text_rebind(path, _) -> + { + xt_name = complete_name; + xt_args = Cstr_tuple []; + xt_ret = None; + xt_type_extension = new_te; + xt_alias = + Some { + xa_name = Odoc_env.full_extension_constructor_name env (Name.from_path path); + xa_xt = None; + }; + xt_loc = { loc_impl = Some tt_ext.ext_loc ; loc_inter = None } ; + xt_text = None; + } + in + let pos_limit2 = + match q with + [] -> pos_limit + | next :: _ -> + next.ext_loc.Location.loc_start.Lexing.pos_cnum + in + let s = get_string_of_file ext_loc_end pos_limit2 in + let (maybe_more, comment_opt) = My_ir.just_after_special !file_name s in + new_xt.xt_text <- comment_opt; + analyse_extension_constructors maybe_more (new_xt :: exts_acc) q + in + let (maybe_more, exts) = analyse_extension_constructors 0 [] tt_tyext.tyext_constructors in + new_te.te_constructors <- exts; + (maybe_more, new_env, [ Element_type_extension new_te ]) - | Parsetree.Pstr_exn_rebind (name, _, _) -> + | Parsetree.Pstr_exception ext -> + let name = ext.Parsetree.pext_name in (* a new exception is defined *) let complete_name = Name.concat current_module_name name.txt in - (* we get the exception rebind in the typed tree *) - let tt_path = - try Typedtree_search.search_exception_rebind table name.txt + (* we get the exception declaration in the typed tree *) + let tt_ext = + try Typedtree_search.search_exception table name.txt with Not_found -> raise (Failure (Odoc_messages.exception_not_found_in_typedtree complete_name)) in - let new_env = Odoc_env.add_exception env complete_name in - let new_ex = - { - ex_name = complete_name ; - ex_info = comment_opt ; - ex_args = [] ; - ex_alias = Some { ea_name = (Odoc_env.full_exception_name env (Name.from_path tt_path)) ; - ea_ex = None ; } ; - ex_loc = { loc_impl = Some loc ; loc_inter = None } ; - ex_code = None ; - } + let new_env = Odoc_env.add_extension env complete_name in + let new_ext = + match tt_ext.ext_kind with + Text_decl(tt_args, tt_ret_type) -> + let loc_start = loc.Location.loc_start.Lexing.pos_cnum in + let loc_end = loc.Location.loc_end.Lexing.pos_cnum in + let ex_args = + match tt_args with + | Cstr_tuple l -> Cstr_tuple (List.map (fun c -> Odoc_env.subst_type env c.ctyp_type) l) + | Cstr_record l -> assert false (* TODO *) + in + { + ex_name = complete_name ; + ex_info = comment_opt ; + ex_args; + ex_ret = + Misc.may_map + (fun ctyp -> Odoc_env.subst_type new_env ctyp.ctyp_type) + tt_ret_type; + ex_alias = None ; + ex_loc = { loc_impl = Some loc ; loc_inter = None } ; + ex_code = + ( + if !Odoc_global.keep_code then + Some (get_string_of_file loc_start loc_end) + else + None + ) ; + } + | Text_rebind(tt_path, _) -> + { + ex_name = complete_name ; + ex_info = comment_opt ; + ex_args = Cstr_tuple [] ; + ex_ret = None ; + ex_alias = + Some { ea_name = + Odoc_env.full_extension_constructor_name + env (Name.from_path tt_path) ; + ea_ex = None ; } ; + ex_loc = { loc_impl = Some loc ; loc_inter = None } ; + ex_code = None ; + } in - (0, new_env, [ Element_exception new_ex ]) + (0, new_env, [ Element_exception new_ext ]) | Parsetree.Pstr_module {Parsetree.pmb_name=name; pmb_expr=module_expr} -> ( @@ -1434,7 +1557,7 @@ module Analyser = in (0, new_env2, [ Element_module_type mt ]) - | Parsetree.Pstr_open (_ovf, longident, _attrs) -> + | Parsetree.Pstr_open _ -> (* A VOIR : enrichir l'environnement quand open ? *) let ele_comments = match comment_opt with None -> [] @@ -1544,7 +1667,7 @@ module Analyser = in (0, new_env, f ~first: true loc.Location.loc_start.Lexing.pos_cnum class_type_decl_list) - | Parsetree.Pstr_include (module_expr, _attrs) -> + | Parsetree.Pstr_include incl -> (* we add a dummy included module which will be replaced by a correct one at the end of the module analysis, to use the Path.t of the included modules in the typdtree. *) diff --git a/ocamldoc/odoc_ast.mli b/ocamldoc/odoc_ast.mli index dc5a2a3ff..c3db304ea 100644 --- a/ocamldoc/odoc_ast.mli +++ b/ocamldoc/odoc_ast.mli @@ -30,20 +30,15 @@ module Typedtree_search : @raise Not_found if the module was not found.*) val search_module : tab -> string -> Typedtree.module_expr - (** This function returns the [Types.module_type] associated to the given module type name, + (** This function returns the [Typedtree.module_type] associated to the given module type name, in the given table. @raise Not_found if the module type was not found.*) val search_module_type : tab -> string -> Typedtree.module_type_declaration - (** This function returns the [Types.exception_declaration] associated to the given exception name, + (** This function returns the [Typedtree.type_extension] associated to the given extension name, in the given table. - @raise Not_found if the exception was not found.*) - val search_exception : tab -> string -> Typedtree.constructor_declaration - - (** This function returns the [Path.t] associated to the given exception rebind name, - in the table. - @raise Not_found if the exception rebind was not found.*) - val search_exception_rebind : tab -> string -> Path.t + @raise Not_found if the extension was not found.*) + val search_extension : tab -> string -> Typedtree.type_extension (** This function returns the [Typedtree.type_declaration] associated to the given type name, in the given table. @@ -55,7 +50,7 @@ module Typedtree_search : @raise Not_found if the class was not found. *) val search_class_exp : tab -> string -> (Typedtree.class_expr * (Types.type_expr list)) - (** This function returns the [Types.cltype_declaration] associated to the given class type name, + (** This function returns the [Typedtree.class_type_declaration] associated to the given class type name, in the given table. @raise Not_found if the class type was not found. *) val search_class_type_declaration : tab -> string -> Typedtree.class_type_declaration diff --git a/ocamldoc/odoc_cross.ml b/ocamldoc/odoc_cross.ml index 70c3c0eb2..28e6ae5bf 100644 --- a/ocamldoc/odoc_cross.ml +++ b/ocamldoc/odoc_cross.ml @@ -15,6 +15,7 @@ module Name = Odoc_name open Odoc_module open Odoc_class +open Odoc_extension open Odoc_exception open Odoc_types open Odoc_value @@ -60,6 +61,7 @@ module P_alias = let p_recfield _ _ _ = false let p_const _ _ _ = false let p_type t _ = (false, false) + let p_extension x _ = x.xt_alias <> None let p_exception e _ = e.ex_alias <> None let p_attribute a _ = false let p_method m _ = false @@ -79,6 +81,9 @@ let (module_aliases : (Name.t, Name.t * alias_state) Hashtbl.t) = Hashtbl.create (** Couples of module or module type name aliases. *) let module_and_modtype_aliases = Hashtbl.create 13;; +(** Couples of extension name aliases. *) +let extension_aliases = Hashtbl.create 13;; + (** Couples of exception name aliases. *) let exception_aliases = Hashtbl.create 13;; @@ -102,6 +107,15 @@ let rec build_alias_list = function | _ -> () ); build_alias_list q + | (Odoc_search.Res_extension x) :: q -> + ( + match x.xt_alias with + None -> () + | Some xa -> + Hashtbl.add extension_aliases + x.xt_name (xa.xa_name,Alias_to_resolve) + ); + build_alias_list q | (Odoc_search.Res_exception e) :: q -> ( match e.ex_alias with @@ -119,6 +133,7 @@ let rec build_alias_list = function let get_alias_names module_list = Hashtbl.clear module_aliases; Hashtbl.clear module_and_modtype_aliases; + Hashtbl.clear extension_aliases; Hashtbl.clear exception_aliases; build_alias_list (Search_alias.search module_list 0) @@ -183,6 +198,7 @@ let kind_name_exists kind = | RK_class_type -> (fun e -> match e with Odoc_search.Res_class_type _ -> true | _ -> false) | RK_value -> (fun e -> match e with Odoc_search.Res_value _ -> true | _ -> false) | RK_type -> (fun e -> match e with Odoc_search.Res_type _ -> true | _ -> false) + | RK_extension -> (fun e -> match e with Odoc_search.Res_extension _ -> true | _ -> false) | RK_exception -> (fun e -> match e with Odoc_search.Res_exception _ -> true | _ -> false) | RK_attribute -> (fun e -> match e with Odoc_search.Res_attribute _ -> true | _ -> false) | RK_method -> (fun e -> match e with Odoc_search.Res_method _ -> true | _ -> false) @@ -200,6 +216,7 @@ let class_exists = kind_name_exists RK_class let class_type_exists = kind_name_exists RK_class_type let value_exists = kind_name_exists RK_value let type_exists = kind_name_exists RK_type +let extension_exists = kind_name_exists RK_extension let exception_exists = kind_name_exists RK_exception let attribute_exists = kind_name_exists RK_attribute let method_exists = kind_name_exists RK_method @@ -238,6 +255,14 @@ let lookup_class_type name = | Odoc_search.Res_class_type c -> c | _ -> assert false +let lookup_extension name = + match List.find + (fun k -> match k with Odoc_search.Res_extension _ -> true | _ -> false) + (get_known_elements name) + with + | Odoc_search.Res_extension x -> x + | _ -> assert false + let lookup_exception name = match List.find (fun k -> match k with Odoc_search.Res_exception _ -> true | _ -> false) @@ -262,6 +287,8 @@ class scan = method! scan_type_pre t = add_known_element t.ty_name (Odoc_search.Res_type t); true + method! scan_extension_constructor x = + add_known_element x.xt_name (Odoc_search.Res_extension x) method! scan_exception e = add_known_element e.ex_name (Odoc_search.Res_exception e) method! scan_attribute a = @@ -298,6 +325,7 @@ type not_found_name = | NF_c of Name.t | NF_ct of Name.t | NF_cct of Name.t + | NF_xt of Name.t | NF_ex of Name.t (** Functions to find and associate aliases elements. *) @@ -466,6 +494,7 @@ and associate_in_module_element module_list m_name (acc_b_modif, acc_incomplete_ | Element_class cl -> associate_in_class module_list (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) cl | Element_class_type ct -> associate_in_class_type module_list (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) ct | Element_value _ -> (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) + | Element_type_extension te -> associate_in_type_extension module_list (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) te | Element_exception ex -> ( match ex.ex_alias with @@ -617,6 +646,29 @@ and associate_in_class_type module_list (acc_b_modif, acc_incomplete_top_module_ in iter_kind (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) ct.clt_kind +and associate_in_type_extension module_list (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) te = + List.fold_left + (fun (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) xt -> + match xt.xt_alias with + None -> (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) + | Some xa -> + match xa.xa_xt with + Some _ -> + (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) + | None -> + let xt_opt = + try Some (lookup_extension xa.xa_name) + with Not_found -> None + in + match xt_opt with + None -> (acc_b_modif, (Name.head xt.xt_name) :: acc_incomplete_top_module_names, (NF_xt xa.xa_name) :: acc_names_not_found) + | Some x -> + xa.xa_xt <- Some x ; + (true, acc_incomplete_top_module_names, acc_names_not_found)) + (acc_b_modif, acc_incomplete_top_module_names, acc_names_not_found) + te.te_constructors + + (*************************************************************) (** Association of types to elements referenced in comments .*) @@ -630,6 +682,7 @@ let not_found_of_kind kind name = | RK_class_type -> Odoc_messages.cross_class_type_not_found | RK_value -> Odoc_messages.cross_value_not_found | RK_type -> Odoc_messages.cross_type_not_found + | RK_extension -> Odoc_messages.cross_extension_not_found | RK_exception -> Odoc_messages.cross_exception_not_found | RK_attribute -> Odoc_messages.cross_attribute_not_found | RK_method -> Odoc_messages.cross_method_not_found @@ -687,6 +740,7 @@ let rec assoc_comments_text_elements parent_name module_list t_ele = | Odoc_search.Res_class_type ct -> (ct.clt_name, RK_class_type) | Odoc_search.Res_value v -> (v.val_name, RK_value) | Odoc_search.Res_type t -> (t.ty_name, RK_type) + | Odoc_search.Res_extension x -> (x.xt_name, RK_extension) | Odoc_search.Res_exception e -> (e.ex_name, RK_exception) | Odoc_search.Res_attribute a -> (a.att_value.val_name, RK_attribute) | Odoc_search.Res_method m -> (m.met_value.val_name, RK_method) @@ -747,6 +801,7 @@ let rec assoc_comments_text_elements parent_name module_list t_ele = | RK_class_type -> class_type_exists | RK_value -> value_exists | RK_type -> type_exists + | RK_extension -> extension_exists | RK_exception -> exception_exists | RK_attribute -> attribute_exists | RK_method -> method_exists @@ -817,6 +872,8 @@ let rec assoc_comments_module_element parent_name module_list m_ele = Element_class_type (assoc_comments_class_type module_list ct) | Element_value v -> Element_value (assoc_comments_value module_list v) + | Element_type_extension te -> + Element_type_extension (assoc_comments_type_extension parent_name module_list te) | Element_exception e -> Element_exception (assoc_comments_exception module_list e) | Element_type t -> @@ -938,6 +995,15 @@ and assoc_comments_value module_list v = assoc_comments_parameter_list parent module_list v.val_parameters; v +and assoc_comments_extension_constructor module_list x = + let parent = Name.father x.xt_name in + x.xt_text <- ao (assoc_comments_info parent module_list) x.xt_text + +and assoc_comments_type_extension parent_name module_list te = + te.te_info <- ao (assoc_comments_info parent_name module_list) te.te_info; + List.iter (assoc_comments_extension_constructor module_list) te.te_constructors; + te + and assoc_comments_exception module_list e = let parent = Name.father e.ex_name in e.ex_info <- ao (assoc_comments_info parent module_list) e.ex_info ; @@ -956,6 +1022,7 @@ and assoc_comments_type module_list t = List.iter (fun rf -> rf.rf_text <- ao (assoc_comments_info parent module_list) rf.rf_text) fl + | Type_open -> () ); t @@ -1018,6 +1085,7 @@ let associate module_list = | NF_c n -> Odoc_messages.cross_class_not_found n | NF_ct n -> Odoc_messages.cross_class_type_not_found n | NF_cct n -> Odoc_messages.cross_class_or_class_type_not_found n + | NF_xt n -> Odoc_messages.cross_extension_not_found n | NF_ex n -> Odoc_messages.cross_exception_not_found n ); ) diff --git a/ocamldoc/odoc_dag2html.ml b/ocamldoc/odoc_dag2html.ml index 44a0aa9c1..74119e6e8 100644 --- a/ocamldoc/odoc_dag2html.ml +++ b/ocamldoc/odoc_dag2html.ml @@ -387,10 +387,10 @@ let group_by_common_children d list = let copy_data d = {elem = d.elem; span = d.span};; let insert_columns t nb j = - let t1 = Array.create (Array.length t.table) [| |] in + let t1 = Array.make (Array.length t.table) [| |] in for i = 0 to Array.length t.table - 1 do let line = t.table.(i) in - let line1 = Array.create (Array.length line + nb) line.(0) in + let line1 = Array.make (Array.length line + nb) line.(0) in t1.(i) <- line1; let rec loop k = if k = Array.length line then () diff --git a/ocamldoc/odoc_dep.ml b/ocamldoc/odoc_dep.ml index f2934ee3e..b0393fe86 100644 --- a/ocamldoc/odoc_dep.ml +++ b/ocamldoc/odoc_dep.ml @@ -147,33 +147,31 @@ let type_deps t = l := s2 :: !l ; s2 in + let ty t = + let s = Odoc_print.string_of_type_expr t in + ignore (Str.global_substitute re f s) + in (match t.T.ty_kind with T.Type_abstract -> () | T.Type_variant cl -> List.iter (fun c -> - List.iter - (fun e -> - let s = Odoc_print.string_of_type_expr e in - ignore (Str.global_substitute re f s) - ) - c.T.vc_args + match c.T.vc_args with + | T.Cstr_tuple l -> List.iter ty l + | T.Cstr_record l -> List.iter (fun r -> ty r.T.rf_type) l ) cl | T.Type_record rl -> - List.iter - (fun r -> - let s = Odoc_print.string_of_type_expr r.T.rf_type in - ignore (Str.global_substitute re f s) - ) - rl + List.iter (fun r -> ty r.T.rf_type) rl + | T.Type_open -> () ); (match t.T.ty_manifest with None -> () - | Some e -> - let s = Odoc_print.string_of_type_expr e in - ignore (Str.global_substitute re f s) + | Some (T.Object_type fields) -> + List.iter (fun r -> ty r.T.of_type) fields + | Some (T.Other e) -> + ty e ); !l diff --git a/ocamldoc/odoc_env.ml b/ocamldoc/odoc_env.ml index 02d1e3a21..3e0590585 100644 --- a/ocamldoc/odoc_env.ml +++ b/ocamldoc/odoc_env.ml @@ -26,7 +26,7 @@ type env = { env_classes : env_element list ; env_modules : env_element list ; env_module_types : env_element list ; - env_exceptions : env_element list ; + env_extensions : env_element list ; } let empty = { @@ -36,7 +36,7 @@ let empty = { env_classes = [] ; env_modules = [] ; env_module_types = [] ; - env_exceptions = [] ; + env_extensions = [] ; } (** Add a signature to an environment. *) @@ -52,7 +52,7 @@ let rec add_signature env root ?rel signat = match item with Types.Sig_value (ident, _) -> { env with env_values = (rel_name ident, qualify ident) :: env.env_values } | Types.Sig_type (ident,_,_) -> { env with env_types = (rel_name ident, qualify ident) :: env.env_types } - | Types.Sig_exception (ident, _) -> { env with env_exceptions = (rel_name ident, qualify ident) :: env.env_exceptions } + | Types.Sig_typext (ident, _, _) -> { env with env_extensions = (rel_name ident, qualify ident) :: env.env_extensions } | Types.Sig_module (ident, md, _) -> let env2 = match md.Types.md_type with (* A VOIR : le cas ou c'est un identificateur, dans ce cas on n'a pas de signature *) @@ -77,9 +77,9 @@ let rec add_signature env root ?rel signat = in List.fold_left f env signat -let add_exception env full_name = +let add_extension env full_name = let simple_name = Name.simple full_name in - { env with env_exceptions = (simple_name, full_name) :: env.env_exceptions } + { env with env_extensions = (simple_name, full_name) :: env.env_extensions } let add_type env full_name = let simple_name = Name.simple full_name in @@ -146,11 +146,11 @@ let full_value_name env n = try List.assoc n env.env_values with Not_found -> n -let full_exception_name env n = - try List.assoc n env.env_exceptions +let full_extension_constructor_name env n = + try List.assoc n env.env_extensions with Not_found -> - print_DEBUG ("Exception "^n^" not found with env="); - List.iter (fun (sn, fn) -> print_DEBUG ("("^sn^", "^fn^")")) env.env_exceptions; + print_DEBUG ("Extension "^n^" not found with env="); + List.iter (fun (sn, fn) -> print_DEBUG ("("^sn^", "^fn^")")) env.env_extensions; n let full_class_name env n = diff --git a/ocamldoc/odoc_env.mli b/ocamldoc/odoc_env.mli index cafdd52ed..4e1e8606d 100644 --- a/ocamldoc/odoc_env.mli +++ b/ocamldoc/odoc_env.mli @@ -22,7 +22,7 @@ val empty : env (** Extending an environment *) val add_signature : env -> string -> ?rel:string -> Types.signature -> env -val add_exception : env -> Odoc_name.t -> env +val add_extension : env -> Odoc_name.t -> env val add_type : env -> Odoc_name.t -> env val add_value : env -> Odoc_name.t -> env val add_module : env -> Odoc_name.t -> env @@ -48,8 +48,8 @@ val full_type_name : env -> Odoc_name.t -> Odoc_name.t (** Get the fully qualified value name from a name.*) val full_value_name : env -> Odoc_name.t -> Odoc_name.t -(** Get the fully qualified exception name from a name.*) -val full_exception_name : env -> Odoc_name.t -> Odoc_name.t +(** Get the fully qualified extension name from a name.*) +val full_extension_constructor_name : env -> Odoc_name.t -> Odoc_name.t (** Get the fully qualified class name from a name.*) val full_class_name : env -> Odoc_name.t -> Odoc_name.t diff --git a/ocamldoc/odoc_exception.ml b/ocamldoc/odoc_exception.ml index a62cb7b7d..c65f384e5 100644 --- a/ocamldoc/odoc_exception.ml +++ b/ocamldoc/odoc_exception.ml @@ -22,7 +22,8 @@ type exception_alias = { and t_exception = { ex_name : Name.t ; mutable ex_info : Odoc_types.info option ; (** optional user information *) - ex_args : Types.type_expr list ; (** the types of the parameters *) + ex_args : Odoc_type.constructor_args ; (** the types of the parameters *) + ex_ret: Types.type_expr option ; (** the optional return type *) ex_alias : exception_alias option ; mutable ex_loc : Odoc_types.location ; mutable ex_code : string option ; diff --git a/ocamldoc/odoc_extension.ml b/ocamldoc/odoc_extension.ml new file mode 100644 index 000000000..7b3da5f4b --- /dev/null +++ b/ocamldoc/odoc_extension.ml @@ -0,0 +1,46 @@ +(***********************************************************************) +(* OCamldoc *) +(* *) +(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2001 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(** Representation and manipulation of type extensions. *) + +module Name = Odoc_name + +type private_flag = Asttypes.private_flag = + Private | Public + +type extension_alias = { + xa_name : Name.t ; + mutable xa_xt : t_extension_constructor option ; + } + +and t_extension_constructor = { + xt_name : Name.t ; + xt_args: Odoc_type.constructor_args; + xt_ret: Types.type_expr option ; (** the optional return type of the extension *) + xt_type_extension: t_type_extension ; (** the type extension containing this constructor *) + xt_alias: extension_alias option ; + mutable xt_loc: Odoc_types.location ; + mutable xt_text: Odoc_types.info option ; (** optional user description *) + } + +and t_type_extension = { + mutable te_info : Odoc_types.info option ; (** optional user information *) + te_type_name : Name.t; + te_type_parameters : Types.type_expr list; + te_private : private_flag; + mutable te_constructors: t_extension_constructor list; + mutable te_loc : Odoc_types.location ; + mutable te_code : string option ; + } + +let extension_constructors te = te.te_constructors diff --git a/ocamldoc/odoc_html.ml b/ocamldoc/odoc_html.ml index 3bee9838b..0c5293ea1 100644 --- a/ocamldoc/odoc_html.ml +++ b/ocamldoc/odoc_html.ml @@ -18,6 +18,7 @@ open Odoc_info open Parameter open Value open Type +open Extension open Exception open Class open Module @@ -42,6 +43,9 @@ module Naming = (** The prefix for functions marks. *) let mark_function = "FUN" + (** The prefix for extensions marks. *) + let mark_extension = "EXTENSION" + (** The prefix for exceptions marks. *) let mark_exception = "EXCEPTION" @@ -100,6 +104,10 @@ module Naming = let recfield_target t f = target mark_type_elt (Printf.sprintf "%s.%s" (Name.simple t.ty_name) f.rf_name) + (** Return the link target for the given object field. *) + let objfield_target t f = target mark_type_elt + (Printf.sprintf "%s.%s" (Name.simple t.ty_name) f.of_name) + (** Return the complete link target for the given type. *) let complete_type_target t = complete_target mark_type t.ty_name @@ -110,6 +118,12 @@ module Naming = let complete_const_target = complete_recfield_target + (** Return the link target for the given extension. *) + let extension_target x = target mark_extension (Name.simple x.xt_name) + + (** Return the complete link target for the given extension. *) + let complete_extension_target x = complete_target mark_extension x.xt_name + (** Return the link target for the given exception. *) let exception_target e = target mark_exception (Name.simple e.ex_name) @@ -261,9 +275,9 @@ class virtual text = List.iter (self#html_of_text_element b) t (** Print the html code for the [text_element] in parameter. *) - method html_of_text_element b te = + method html_of_text_element b txt = print_DEBUG "text::html_of_text_element"; - match te with + match txt with | Odoc_info.Raw s -> self#html_of_Raw b s | Odoc_info.Code s -> self#html_of_Code b s | Odoc_info.CodePre s -> self#html_of_CodePre b s @@ -454,6 +468,7 @@ class virtual text = (html_file, h name) | Odoc_info.RK_value -> (Naming.complete_target Naming.mark_value name, h name) | Odoc_info.RK_type -> (Naming.complete_target Naming.mark_type name, h name) + | Odoc_info.RK_extension -> (Naming.complete_target Naming.mark_extension name, h name) | Odoc_info.RK_exception -> (Naming.complete_target Naming.mark_exception name, h name) | Odoc_info.RK_attribute -> (Naming.complete_target Naming.mark_attribute name, h name) | Odoc_info.RK_method -> (Naming.complete_target Naming.mark_method name, h name) @@ -515,6 +530,7 @@ class virtual text = in bp b "<ul class=\"indexlist\">\n"; index_if_not_empty self#list_types self#index_types Odoc_messages.index_of_types; + index_if_not_empty self#list_extensions self#index_extensions Odoc_messages.index_of_extensions; index_if_not_empty self#list_exceptions self#index_exceptions Odoc_messages.index_of_exceptions; index_if_not_empty self#list_values self#index_values Odoc_messages.index_of_values; index_if_not_empty self#list_attributes self#index_attributes Odoc_messages.index_of_attributes; @@ -527,6 +543,8 @@ class virtual text = method virtual list_types : Odoc_info.Type.t_type list method virtual index_types : string + method virtual list_extensions : Odoc_info.Extension.t_extension_constructor list + method virtual index_extensions : string method virtual list_exceptions : Odoc_info.Exception.t_exception list method virtual index_exceptions : string method virtual list_values : Odoc_info.Value.t_value list @@ -888,6 +906,8 @@ class html = method index_values = Printf.sprintf "%s_values.html" self#index_prefix (** The file for the index of types. *) method index_types = Printf.sprintf "%s_types.html" self#index_prefix + (** The file for the index of extensions. *) + method index_extensions = Printf.sprintf "%s_extensions.html" self#index_prefix (** The file for the index of exceptions. *) method index_exceptions = Printf.sprintf "%s_exceptions.html" self#index_prefix (** The file for the index of attributes. *) @@ -913,6 +933,9 @@ class html = (** The list of values. Filled in the [generate] method. *) val mutable list_values = [] method list_values = list_values + (** The list of extensions. Filled in the [generate] method. *) + val mutable list_extensions = [] + method list_extensions = list_extensions (** The list of exceptions. Filled in the [generate] method. *) val mutable list_exceptions = [] method list_exceptions = list_exceptions @@ -1012,6 +1035,7 @@ class html = ) ); link_if_not_empty self#list_types Odoc_messages.index_of_types self#index_types; + link_if_not_empty self#list_extensions Odoc_messages.index_of_extensions self#index_extensions; link_if_not_empty self#list_exceptions Odoc_messages.index_of_exceptions self#index_exceptions; link_if_not_empty self#list_values Odoc_messages.index_of_values self#index_values; link_if_not_empty self#list_attributes Odoc_messages.index_of_attributes self#index_attributes; @@ -1179,7 +1203,7 @@ class html = s_final in let s2 = Str.global_substitute - (Str.regexp "\\([A-Z]\\([a-zA-Z_'0-9]\\)*\\.\\)+\\([A-Z][a-zA-Z_'0-9]*\\)") + (Str.regexp "\\([A-Z]\\([a-zA-Z_'0-9]\\)*\\)\\(\\.[A-Z][a-zA-Z_'0-9]*\\)*") f s in @@ -1194,12 +1218,18 @@ class html = bs b "</code>" (** Print html code to display a [Types.type_expr list]. *) - method html_of_type_expr_list ?par b m_name sep l = - print_DEBUG "html#html_of_type_expr_list"; - let s = Odoc_info.string_of_type_list ?par sep l in - print_DEBUG "html#html_of_type_expr_list: 1"; + method html_of_cstr_args ?par b m_name sep l = + print_DEBUG "html#html_of_cstr_args"; + let s = + match l with + | Cstr_tuple l -> + Odoc_info.string_of_type_list ?par sep l + | Cstr_record l -> + Odoc_info.string_of_record l + in + print_DEBUG "html#html_of_cstr_args: 1"; let s2 = newline_to_indented_br s in - print_DEBUG "html#html_of_type_expr_list: 2"; + print_DEBUG "html#html_of_cstr_args: 2"; bs b "<code class=\"type\">"; bs b (self#create_fully_qualified_idents_links m_name s2); bs b "</code>" @@ -1321,7 +1351,7 @@ class html = self#html_of_module_type_kind b father p.mp_kind; self#html_of_text b [ Code (") "^s_arrow)] - method html_of_module_element b father ele = + method html_of_module_element b m_name ele = match ele with Element_module m -> self#html_of_module b ~complete: false m @@ -1335,6 +1365,8 @@ class html = self#html_of_class_type b ~complete: false ct | Element_value v -> self#html_of_value b v + | Element_type_extension te -> + self#html_of_type_extension b m_name te | Element_exception e -> self#html_of_exception b e | Element_type t -> @@ -1424,6 +1456,84 @@ class html = self#html_of_described_parameter_list b (Name.father v.val_name) v.val_parameters ) + (** Print html code for a type extension. *) + method html_of_type_extension b m_name te = + Odoc_info.reset_type_names (); + bs b "<pre><code>"; + bs b ((self#keyword "type")^" "); + let s = Odoc_info.string_of_type_extension_param_list te in + let s2 = newline_to_indented_br s in + bs b "<code class=\"type\">"; + bs b (self#create_fully_qualified_idents_links m_name s2); + bs b "</code>"; + (match te.te_type_parameters with [] -> () | _ -> bs b " "); + bs b (self#create_fully_qualified_idents_links m_name te.te_type_name); + bs b " += "; + if te.te_private = Asttypes.Private then bs b "private "; + bs b "</code></pre>"; + bs b "<table class=\"typetable\">\n"; + let print_one x = + let father = Name.father x.xt_name in + bs b "<tr>\n<td align=\"left\" valign=\"top\" >\n"; + bs b "<code>"; + bs b (self#keyword "|"); + bs b "</code></td>\n<td align=\"left\" valign=\"top\" >\n"; + bs b "<code>"; + bp b "<span id=\"%s\">%s</span>" + (Naming.extension_target x) + (Name.simple x.xt_name); + ( + match x.xt_args, x.xt_ret with + Cstr_tuple [], None -> () + | l,None -> + bs b (" " ^ (self#keyword "of") ^ " "); + self#html_of_cstr_args ~par: false b father " * " l; + | Cstr_tuple [],Some r -> + bs b (" " ^ (self#keyword ":") ^ " "); + self#html_of_type_expr b father r; + | l,Some r -> + bs b (" " ^ (self#keyword ":") ^ " "); + self#html_of_cstr_args ~par: false b father " * " l; + bs b (" " ^ (self#keyword "->") ^ " "); + self#html_of_type_expr b father r; + ); + ( + match x.xt_alias with + None -> () + | Some xa -> + bs b " = "; + ( + match xa.xa_xt with + None -> bs b xa.xa_name + | Some x -> + bp b "<a href=\"%s\">%s</a>" (Naming.complete_extension_target x) x.xt_name + ) + ); + bs b "</code></td>\n"; + ( + match x.xt_text with + None -> () + | Some t -> + bs b "<td class=\"typefieldcomment\" align=\"left\" valign=\"top\" >"; + bs b "<code>"; + bs b "(*"; + bs b "</code></td>"; + bs b "<td class=\"typefieldcomment\" align=\"left\" valign=\"top\" >"; + self#html_of_info b (Some t); + bs b "</td>"; + bs b "<td class=\"typefieldcomment\" align=\"left\" valign=\"bottom\" >"; + bs b "<code>"; + bs b "*)"; + bs b "</code></td>"; + ); + bs b "\n</tr>" + in + print_concat b "\n" print_one te.te_constructors; + bs b "</table>\n"; + bs b "\n"; + self#html_of_info b te.te_info; + bs b "\n" + (** Print html code for an exception. *) method html_of_exception b e = Odoc_info.reset_type_names (); @@ -1434,12 +1544,21 @@ class html = bs b (Name.simple e.ex_name); bs b "</span>"; ( - match e.ex_args with - [] -> () - | _ -> - bs b (" "^(self#keyword "of")^" "); - self#html_of_type_expr_list - ~par: false b (Name.father e.ex_name) " * " e.ex_args + match e.ex_args, e.ex_ret with + Cstr_tuple [], None -> () + | l,None -> + bs b (" "^(self#keyword "of")^" "); + self#html_of_cstr_args + ~par: false b (Name.father e.ex_name) " * " e.ex_args + | Cstr_tuple [],Some r -> + bs b (" " ^ (self#keyword ":") ^ " "); + self#html_of_type_expr b (Name.father e.ex_name) r; + | l,Some r -> + bs b (" " ^ (self#keyword ":") ^ " "); + self#html_of_cstr_args + ~par: false b (Name.father e.ex_name) " * " l; + bs b (" " ^ (self#keyword "->") ^ " "); + self#html_of_type_expr b (Name.father e.ex_name) r; ); ( match e.ex_alias with @@ -1460,12 +1579,32 @@ class html = method html_of_type b t = Odoc_info.reset_type_names (); let father = Name.father t.ty_name in + let print_field_prefix () = + bs b "<tr>\n<td align=\"left\" valign=\"top\" >\n"; + bs b "<code> </code>"; + bs b "</td>\n<td align=\"left\" valign=\"top\" >\n"; + bs b "<code>"; + in + let print_field_comment = function + | None -> () + | Some t -> + bs b "<td class=\"typefieldcomment\" align=\"left\" valign=\"top\" >"; + bs b "<code>"; + bs b "(*"; + bs b "</code></td>"; + bs b "<td class=\"typefieldcomment\" align=\"left\" valign=\"top\" >"; + self#html_of_info b (Some t); + bs b "</td><td class=\"typefieldcomment\" align=\"left\" valign=\"bottom\" >"; + bs b "<code>*)</code></td>" + in bs b (match t.ty_manifest, t.ty_kind with - None, Type_abstract -> "\n<pre>" + None, Type_abstract + | None, Type_open -> "\n<pre>" | None, Type_variant _ | None, Type_record _ -> "\n<pre><code>" - | Some _, Type_abstract -> "\n<pre>" + | Some _, Type_abstract + | Some _, Type_open -> "\n<pre>" | Some _, Type_variant _ | Some _, Type_record _ -> "\n<pre>" ); @@ -1479,7 +1618,25 @@ class html = ( match t.ty_manifest with None -> () - | Some typ -> + | Some (Object_type fields) -> + bs b "= "; + if priv then bs b "private "; + bs b "<</pre>"; + bs b "<table class=\"typetable\">\n" ; + let print_one f = + print_field_prefix () ; + bp b "<span id=\"%s\">%s</span> : " + (Naming.objfield_target t f) + f.of_name; + self#html_of_type_expr b father f.of_type; + bs b ";</code></td>\n"; + print_field_comment f.of_text ; + bs b "\n</tr>" + in + print_concat b "\n" print_one fields; + bs b "</table>\n>\n"; + bs b " " + | Some (Other typ) -> bs b "= "; if priv then bs b "private "; self#html_of_type_expr b father typ; @@ -1508,16 +1665,16 @@ class html = (self#constructor constr.vc_name); ( match constr.vc_args, constr.vc_ret with - [], None -> () + Cstr_tuple [], None -> () | l,None -> bs b (" " ^ (self#keyword "of") ^ " "); - self#html_of_type_expr_list ~par: false b father " * " l; - | [],Some r -> + self#html_of_cstr_args ~par: false b father " * " l; + | Cstr_tuple [],Some r -> bs b (" " ^ (self#keyword ":") ^ " "); self#html_of_type_expr b father r; | l,Some r -> bs b (" " ^ (self#keyword ":") ^ " "); - self#html_of_type_expr_list ~par: false b father " * " l; + self#html_of_cstr_args ~par: false b father " * " l; bs b (" " ^ (self#keyword "->") ^ " "); self#html_of_type_expr b father r; ); @@ -1582,6 +1739,9 @@ class html = in print_concat b "\n" print_one l; bs b "</table>\n}\n" + | Type_open -> + bs b "= .."; + bs b "</pre>" ); bs b "\n"; self#html_of_info b t.ty_info; @@ -2313,7 +2473,7 @@ class html = bs b "<hr width=\"100%\">\n"; (* module elements *) List.iter - (self#html_of_module_element b (Name.father mt.mt_name)) + (self#html_of_module_element b mt.mt_name) (Module.module_type_elements mt); bs b "</body></html>"; @@ -2396,7 +2556,7 @@ class html = (* module elements *) List.iter - (self#html_of_module_element b (Name.father modu.m_name)) + (self#html_of_module_element b modu.m_name) (Module.module_elements modu); bs b "</body></html>"; @@ -2474,6 +2634,16 @@ class html = Odoc_messages.index_of_values self#index_values + (** Generate the extensions index in the file [index_extensions.html]. *) + method generate_extensions_index module_list = + self#generate_elements_index + self#list_extensions + (fun x -> x.xt_name) + (fun x -> x.xt_type_extension.te_info) + (fun x -> Naming.complete_extension_target x) + Odoc_messages.index_of_extensions + self#index_extensions + (** Generate the exceptions index in the file [index_exceptions.html]. *) method generate_exceptions_index module_list = self#generate_elements_index @@ -2561,6 +2731,7 @@ class html = self#init_style ; (* init the lists of elements *) list_values <- Odoc_info.Search.values module_list ; + list_extensions <- Odoc_info.Search.extensions module_list ; list_exceptions <- Odoc_info.Search.exceptions module_list ; list_types <- Odoc_info.Search.types module_list ; list_attributes <- Odoc_info.Search.attributes module_list ; @@ -2612,6 +2783,7 @@ class html = try self#generate_index module_list; self#generate_values_index module_list ; + self#generate_extensions_index module_list ; self#generate_exceptions_index module_list ; self#generate_types_index module_list ; self#generate_attributes_index module_list ; diff --git a/ocamldoc/odoc_info.ml b/ocamldoc/odoc_info.ml index 4a6c21419..0fadbd482 100644 --- a/ocamldoc/odoc_info.ml +++ b/ocamldoc/odoc_info.ml @@ -19,6 +19,7 @@ type ref_kind = Odoc_types.ref_kind = | RK_class_type | RK_value | RK_type + | RK_extension | RK_exception | RK_attribute | RK_method @@ -90,6 +91,7 @@ let dummy_loc = { loc_impl = None ; loc_inter = None } module Name = Odoc_name module Parameter = Odoc_parameter +module Extension = Odoc_extension module Exception = Odoc_exception module Type = Odoc_type module Value = Odoc_value @@ -128,6 +130,8 @@ let string_of_type_list ?par sep type_list = Odoc_str.string_of_type_list ?par s let string_of_type_param_list t = Odoc_str.string_of_type_param_list t +let string_of_type_extension_param_list te = Odoc_str.string_of_type_extension_param_list te + let string_of_class_type_param_list l = Odoc_str.string_of_class_type_param_list l let string_of_module_type = Odoc_print.string_of_module_type @@ -139,6 +143,9 @@ let string_of_text t = Odoc_misc.string_of_text t let string_of_info i = Odoc_misc.string_of_info i let string_of_type t = Odoc_str.string_of_type t +let string_of_record t = Odoc_str.string_of_record t + +let string_of_type_extension te = Odoc_str.string_of_type_extension te let string_of_exception e = Odoc_str.string_of_exception e @@ -290,6 +297,7 @@ module Search = | Res_class_type of Class.t_class_type | Res_value of Value.t_value | Res_type of Type.t_type + | Res_extension of Extension.t_extension_constructor | Res_exception of Exception.t_exception | Res_attribute of Value.t_attribute | Res_method of Value.t_method @@ -302,6 +310,7 @@ module Search = let search_by_name = Odoc_search.Search_by_name.search let values = Odoc_search.values + let extensions = Odoc_search.extensions let exceptions = Odoc_search.exceptions let types = Odoc_search.types let attributes = Odoc_search.attributes diff --git a/ocamldoc/odoc_info.mli b/ocamldoc/odoc_info.mli index 76e28df64..d1b98e224 100644 --- a/ocamldoc/odoc_info.mli +++ b/ocamldoc/odoc_info.mli @@ -20,6 +20,7 @@ type ref_kind = Odoc_types.ref_kind = | RK_class_type | RK_value | RK_type + | RK_extension | RK_exception | RK_attribute | RK_method @@ -169,6 +170,47 @@ module Parameter : val type_by_name : parameter -> string -> Types.type_expr end +(** Representation and manipulation of extensions. *) +module Extension : + sig + type private_flag = Odoc_extension.private_flag = + Private | Public + + (** Used when the extension is a rebind of another extension, + when we have [extension Xt = Target_xt].*) + type extension_alias = Odoc_extension.extension_alias = + { + xa_name : Name.t ; (** The complete name of the target extension. *) + mutable xa_xt : t_extension_constructor option ; (** The target extension, if we found it.*) + } + + and t_extension_constructor = Odoc_extension.t_extension_constructor = + { + xt_name : Name.t ; + xt_args: Odoc_type.constructor_args; + xt_ret: Types.type_expr option ; (** the optional return type of the extension *) + xt_type_extension: t_type_extension ; (** the type extension containing this constructor *) + xt_alias: extension_alias option ; (** [None] when the extension is not a rebind. *) + mutable xt_loc: Odoc_types.location ; + mutable xt_text: Odoc_types.info option ; (** optional user description *) + } + + and t_type_extension = Odoc_extension.t_type_extension = + { + mutable te_info : info option ; (** Information found in the optional associated comment. *) + te_type_name : Name.t ; (** The type of the extension *) + te_type_parameters : Types.type_expr list; + te_private : private_flag ; + mutable te_constructors: t_extension_constructor list; + mutable te_loc : location ; + mutable te_code : string option ; + } + + (** Access to the extensions in a group. *) + val extension_constructors : t_type_extension -> t_extension_constructor list + + end + (** Representation and manipulation of exceptions. *) module Exception : sig @@ -184,7 +226,8 @@ module Exception : { ex_name : Name.t ; mutable ex_info : info option ; (** Information found in the optional associated comment. *) - ex_args : Types.type_expr list ; (** The types of the parameters. *) + ex_args : Odoc_type.constructor_args; + ex_ret : Types.type_expr option ; (** The the optional return type of the exception. *) ex_alias : exception_alias option ; (** [None] when the exception is not a rebind. *) mutable ex_loc : location ; mutable ex_code : string option ; @@ -197,15 +240,6 @@ module Type : type private_flag = Odoc_type.private_flag = Private | Public - (** Description of a variant type constructor. *) - type variant_constructor = Odoc_type.variant_constructor = - { - vc_name : string ; (** Name of the constructor. *) - vc_args : Types.type_expr list ; (** Arguments of the constructor. *) - vc_ret : Types.type_expr option ; - mutable vc_text : info option ; (** Optional description in the associated comment. *) - } - (** Description of a record type field. *) type record_field = Odoc_type.record_field = { @@ -215,6 +249,19 @@ module Type : mutable rf_text : info option ; (** Optional description in the associated comment.*) } + (** Description of a variant type constructor. *) + type constructor_args = Odoc_type.constructor_args = + | Cstr_record of record_field list + | Cstr_tuple of Types.type_expr list + + type variant_constructor = Odoc_type.variant_constructor = + { + vc_name : string ; (** Name of the constructor. *) + vc_args : constructor_args; + vc_ret : Types.type_expr option ; + mutable vc_text : info option ; (** Optional description in the associated comment. *) + } + (** The various kinds of a type. *) type type_kind = Odoc_type.type_kind = Type_abstract (** Type is abstract, for example [type t]. *) @@ -222,6 +269,17 @@ module Type : (** constructors *) | Type_record of record_field list (** fields *) + | Type_open (** Type is open *) + + type object_field = Odoc_type.object_field = { + of_name : string ; + of_type : Types.type_expr ; + mutable of_text : Odoc_types.info option ; (** optional user description *) + } + + type type_manifest = Odoc_type.type_manifest = + | Other of Types.type_expr (** Type manifest directly taken from Typedtre. *) + | Object_type of object_field list (** Representation of a type. *) type t_type = Odoc_type.t_type = @@ -232,7 +290,7 @@ module Type : (** type parameters: (type, covariant, contravariant) *) ty_kind : type_kind; (** Type kind. *) ty_private : private_flag; (** Private or public type. *) - ty_manifest : Types.type_expr option; (** Type manifest. *) + ty_manifest : type_manifest option ; mutable ty_loc : location ; mutable ty_code : string option; } @@ -410,6 +468,7 @@ module Module : | Element_class of Class.t_class | Element_class_type of Class.t_class_type | Element_value of Value.t_value + | Element_type_extension of Extension.t_type_extension | Element_exception of Exception.t_exception | Element_type of Type.t_type | Element_module_comment of text @@ -518,6 +577,9 @@ module Module : (** Access to the included modules of a module. *) val module_included_modules : ?trans:bool-> t_module -> included_module list + (** Access to the type extensions of a module. *) + val module_type_extensions : ?trans:bool-> t_module -> Extension.t_type_extension list + (** Access to the exceptions of a module. *) val module_exceptions : ?trans:bool-> t_module -> Exception.t_exception list @@ -630,6 +692,10 @@ val string_of_type_list : ?par: bool -> string -> Types.type_expr list -> string for the given type. *) val string_of_type_param_list : Type.t_type -> string +(** This function returns a string to represent the list of type parameters + for the given type extension. *) +val string_of_type_extension_param_list : Extension.t_type_extension -> string + (** This function returns a string to represent the given list of type parameters of a class or class type, with a given separator. *) @@ -659,6 +725,11 @@ val string_of_info : info -> string (** @return a string to describe the given type. *) val string_of_type : Type.t_type -> string +val string_of_record : Type.record_field list -> string + +(** @return a string to describe the given type extension. *) +val string_of_type_extension : Extension.t_type_extension -> string + (** @return a string to describe the given exception. *) val string_of_exception : Exception.t_exception -> string @@ -789,6 +860,7 @@ module Search : | Res_class_type of Class.t_class_type | Res_value of Value.t_value | Res_type of Type.t_type + | Res_extension of Extension.t_extension_constructor | Res_exception of Exception.t_exception | Res_attribute of Value.t_attribute | Res_method of Value.t_method @@ -805,6 +877,9 @@ module Search : (** A function to search all the values in a list of modules. *) val values : Module.t_module list -> Value.t_value list + (** A function to search all the extensions in a list of modules. *) + val extensions : Module.t_module list -> Extension.t_extension_constructor list + (** A function to search all the exceptions in a list of modules. *) val exceptions : Module.t_module list -> Exception.t_exception list @@ -844,11 +919,27 @@ module Scan : method scan_type_const : Type.t_type -> Type.variant_constructor -> unit method scan_type_recfield : Type.t_type -> Type.record_field -> unit method scan_type : Type.t_type -> unit + method scan_extension_constructor : Extension.t_extension_constructor -> unit method scan_exception : Exception.t_exception -> unit method scan_attribute : Value.t_attribute -> unit method scan_method : Value.t_method -> unit method scan_included_module : Module.included_module -> unit + (** Scan of a type extension *) + + (** Overide this method to perform controls on the extension's type, + private and info. This method is called before scanning the + extension's constructors. + @return true if the extension's constructors must be scanned.*) + method scan_type_extension_pre : Extension.t_type_extension -> bool + + (** This method scans the constructors of the given type extension. *) + method scan_type_extension_constructors : Extension.t_type_extension -> unit + + (** Scan of a type extension. Should not be overridden. It calls [scan_type_extension_pre] + and if [scan_type_extension_pre] returns [true], then it calls scan_type_extension_constructors.*) + method scan_type_extension : Extension.t_type_extension -> unit + (** Scan of a class. *) (** Scan of a comment inside a class. *) diff --git a/ocamldoc/odoc_latex.ml b/ocamldoc/odoc_latex.ml index 90dba5fa3..b2145d1bc 100644 --- a/ocamldoc/odoc_latex.ml +++ b/ocamldoc/odoc_latex.ml @@ -18,6 +18,7 @@ open Odoc_info open Parameter open Value open Type +open Extension open Exception open Class open Module @@ -37,6 +38,7 @@ let latex_titles = ref [ let latex_value_prefix = ref Odoc_messages.default_latex_value_prefix let latex_type_prefix = ref Odoc_messages.default_latex_type_prefix let latex_type_elt_prefix = ref Odoc_messages.default_latex_type_elt_prefix +let latex_extension_prefix = ref Odoc_messages.default_latex_extension_prefix let latex_exception_prefix = ref Odoc_messages.default_latex_exception_prefix let latex_module_prefix = ref Odoc_messages.default_latex_module_prefix let latex_module_type_prefix = ref Odoc_messages.default_latex_module_type_prefix @@ -234,6 +236,9 @@ class text = (** Make a correct label from a module type name. *) method module_type_label ?no_ name = !latex_module_type_prefix^(self#label ?no_ name) + (** Make a correct label from an extension name. *) + method extension_label ?no_ name = !latex_extension_prefix^(self#label ?no_ name) + (** Make a correct label from an exception name. *) method exception_label ?no_ name = !latex_exception_prefix^(self#label ?no_ name) @@ -257,8 +262,8 @@ class text = List.iter (self#latex_of_text_element fmt) t (** Print the LaTeX code for the [text_element] in parameter. *) - method latex_of_text_element fmt te = - match te with + method latex_of_text_element fmt txt = + match txt with | Odoc_info.Raw s -> self#latex_of_Raw fmt s | Odoc_info.Code s -> self#latex_of_Code fmt s | Odoc_info.CodePre s -> self#latex_of_CodePre fmt s @@ -411,6 +416,7 @@ class text = | Odoc_info.RK_class_type -> self#class_type_label | Odoc_info.RK_value -> self#value_label | Odoc_info.RK_type -> self#type_label + | Odoc_info.RK_extension -> self#extension_label | Odoc_info.RK_exception -> self#exception_label | Odoc_info.RK_attribute -> self#attribute_label | Odoc_info.RK_method -> self#method_label @@ -533,53 +539,181 @@ class latex = let priv = t.ty_private = Asttypes.Private in ( match t.ty_manifest with - None -> () - | Some typ -> + | Some (Other typ) -> p fmt2 " = %s%s" (if priv then "private " else "") (self#normal_type mod_name typ) + | _ -> () ); let s_type3 = p fmt2 " %s" ( match t.ty_kind with - Type_abstract -> "" + Type_abstract -> + begin match t.ty_manifest with + | Some (Object_type _) -> + "= " ^ (if priv then "private" else "") ^ " <" + | _ -> "" + end | Type_variant _ -> "="^(if priv then " private" else "") | Type_record _ -> "= "^(if priv then "private " else "")^"{" + | Type_open -> "= .." ) ; flush2 () in let defs = + let entry_comment = function + | None -> [] + | Some t -> + let s = + ps fmt2 "\\begin{ocamldoccomment}\n"; + self#latex_of_info fmt2 (Some t); + ps fmt2 "\n\\end{ocamldoccomment}\n"; + flush2 () + in + [ Latex s] + in match t.ty_kind with - Type_abstract -> [] + | Type_abstract -> + begin match t.ty_manifest with + | Some (Object_type l) -> + let fields = + List.map (fun r -> + let s_field = + p fmt2 + "@[<h 6> %s :@ %s ;" + r.of_name + (self#normal_type mod_name r.of_type); + flush2 () + in + [ CodePre s_field ] @ (entry_comment r.of_text) + ) l + in + List.flatten fields @ [ CodePre ">" ] + + | None | Some (Other _) -> [] + end | Type_variant l -> - (List.flatten - (List.map - (fun constr -> - let s_cons = - p fmt2 "@[<h 6> | %s" constr.vc_name; - ( - match constr.vc_args, constr.vc_ret with - [], None -> () - | l, None -> - p fmt2 " %s@ %s" - "of" - (self#normal_type_list ~par: false mod_name " * " l) - | [], Some r -> - p fmt2 " %s@ %s" - ":" - (self#normal_type mod_name r) - | l, Some r -> - p fmt2 " %s@ %s@ %s@ %s" - ":" - (self#normal_type_list ~par: false mod_name " * " l) - "->" - (self#normal_type mod_name r) - ); - flush2 () + let constructors = + List.map (fun constr -> + let s_cons = + p fmt2 "@[<h 6> | %s" constr.vc_name ; + begin match constr.vc_args, constr.vc_ret with + | Cstr_tuple [], None -> () + | l, None -> + p fmt2 " of@ %s" + (self#normal_cstr_args ~par: false mod_name l) + | Cstr_tuple [], Some r -> + p fmt2 " :@ %s" + (self#normal_type mod_name r) + | l, Some r -> + p fmt2 " :@ %s@ %s@ %s" + (self#normal_cstr_args ~par: false mod_name l) + "->" + (self#normal_type mod_name r) + end ; + flush2 () + in + [ CodePre s_cons ] @ (entry_comment constr.vc_text) + ) l + in + List.flatten constructors + | Type_record l -> + let fields = + List.map (fun r -> + let s_field = + p fmt2 + "@[<h 6> %s%s :@ %s ;" + (if r.rf_mutable then "mutable " else "") + r.rf_name + (self#normal_type mod_name r.rf_type); + flush2 () + in + [ CodePre s_field ] @ (entry_comment r.rf_text) + ) l + in + List.flatten fields @ [ CodePre "}" ] + | Type_open -> + (* FIXME ? *) + [] + in + let defs2 = (CodePre s_type3) :: defs in + let rec iter = function + [] -> [] + | [e] -> [e] + | (CodePre s1) :: (CodePre s2) :: q -> + iter ((CodePre (s1^"\n"^s2)) :: q) + | e :: q -> + e :: (iter q) + in + (iter defs2) @ + [Latex ("\\index{"^(self#label s_name)^"@\\verb`"^(self#label ~no_:false s_name)^"`}\n")] @ + (self#text_of_info t.ty_info) + in + self#latex_of_text fmt + ((Latex (self#make_label (self#type_label t.ty_name))) :: text) + + (** Print LaTeX code for a type extension. *) + method latex_of_type_extension mod_name fmt te = + let text = + let (fmt2, flush2) = new_fmt () in + Odoc_info.reset_type_names () ; + Format.fprintf fmt2 "@[<h 2>type "; + ( + match te.te_type_parameters with + [] -> () + | [p] -> + ps fmt2 (self#normal_type mod_name p); + ps fmt2 " " + | l -> + ps fmt2 "("; + print_concat fmt2 ", " (fun p -> ps fmt2 (self#normal_type mod_name p)) l; + ps fmt2 ") " + ); + ps fmt2 (self#relative_idents mod_name te.te_type_name); + p fmt2 " +=%s" (if te.te_private = Asttypes.Private then " private" else "") ; + let s_type3 = flush2 () in + let defs = + (List.flatten + (List.map + (fun x -> + let father = Name.father x.xt_name in + let s_cons = + p fmt2 "@[<h 6> | %s" (Name.simple x.xt_name); + ( + match x.xt_args, x.xt_ret with + Cstr_tuple [], None -> () + | l, None -> + p fmt2 " %s@ %s" + "of" + (self#normal_cstr_args ~par: false father l) + | Cstr_tuple [], Some r -> + p fmt2 " %s@ %s" + ":" + (self#normal_type father r) + | l, Some r -> + p fmt2 " %s@ %s@ %s@ %s" + ":" + (self#normal_cstr_args ~par: false father l) + "->" + (self#normal_type father r) + ); + ( + match x.xt_alias with + None -> () + | Some xa -> + p fmt2 " = %s" + ( + match xa.xa_xt with + None -> xa.xa_name + | Some x -> x.xt_name + ) + ); + flush2 () in - [ CodePre s_cons ] @ - (match constr.vc_text with + [ Latex (self#make_label (self#extension_label x.xt_name)); + CodePre s_cons ] @ + (match x.xt_text with None -> [] | Some t -> let s = @@ -591,38 +725,9 @@ class latex = [ Latex s] ) ) - l + te.te_constructors ) ) - | Type_record l -> - (List.flatten - (List.map - (fun r -> - let s_field = - p fmt2 - "@[<h 6> %s%s :@ %s ;" - (if r.rf_mutable then "mutable " else "") - r.rf_name - (self#normal_type mod_name r.rf_type); - flush2 () - in - [ CodePre s_field ] @ - (match r.rf_text with - None -> [] - | Some t -> - let s = - ps fmt2 "\\begin{ocamldoccomment}\n"; - self#latex_of_info fmt2 (Some t); - ps fmt2 "\n\\end{ocamldoccomment}\n"; - flush2 () - in - [ Latex s] - ) - ) - l - ) - ) @ - [ CodePre "}" ] in let defs2 = (CodePre s_type3) :: defs in let rec iter = function @@ -634,11 +739,9 @@ class latex = e :: (iter q) in (iter defs2) @ - [Latex ("\\index{"^(self#label s_name)^"@\\verb`"^(self#label ~no_:false s_name)^"`}\n")] @ - (self#text_of_info t.ty_info) + (self#text_of_info te.te_info) in - self#latex_of_text fmt - ((Latex (self#make_label (self#type_label t.ty_name))) :: text) + self#latex_of_text fmt text (** Print LaTeX code for an exception. *) method latex_of_exception fmt e = @@ -1034,6 +1137,7 @@ class latex = | Element_class c -> self#latex_of_class fmt c | Element_class_type ct -> self#latex_of_class_type fmt ct | Element_value v -> self#latex_of_value fmt v + | Element_type_extension te -> self#latex_of_type_extension module_name fmt te | Element_exception e -> self#latex_of_exception fmt e | Element_type t -> self#latex_of_type fmt t | Element_module_comment t -> self#latex_of_text fmt t diff --git a/ocamldoc/odoc_man.ml b/ocamldoc/odoc_man.ml index 8a252d631..13733ba8e 100644 --- a/ocamldoc/odoc_man.ml +++ b/ocamldoc/odoc_man.ml @@ -15,6 +15,7 @@ open Odoc_info open Parameter open Value open Type +open Extension open Exception open Class open Module @@ -281,8 +282,8 @@ class man = Str.global_replace (Str.regexp "[ ]*\n[ ]*") " " s (** Print the groff string for a text element. *) - method man_of_text_element b te = - match te with + method man_of_text_element b txt = + match txt with | Odoc_info.Raw s -> bs b (self#escape s) | Odoc_info.Code s -> bs b "\n.B "; @@ -382,8 +383,14 @@ class man = bs b "\n" (** Print groff string to display a [Types.type_expr list].*) - method man_of_type_expr_list ?par b m_name sep l = - let s = Odoc_str.string_of_type_list ?par sep l in + method man_of_cstr_args ?par b m_name sep l = + let s = + match l with + | Cstr_tuple l -> + Odoc_str.string_of_type_list ?par sep l + | Cstr_record l -> + Odoc_str.string_of_record l + in let s2 = Str.global_replace (Str.regexp "\n") "\n.B " s in bs b "\n.B "; bs b (self#relative_idents m_name s2); @@ -421,6 +428,74 @@ class man = self#man_of_info b v.val_info; bs b "\n.sp\n" + (** Print groff string code for a type extension. *) + method man_of_type_extension b m_name te = + Odoc_info.reset_type_names () ; + bs b ".I type "; + ( + match te.te_type_parameters with + [] -> () + | l -> + let s = Odoc_str.string_of_type_extension_param_list te in + let s2 = Str.global_replace (Str.regexp "\n") "\n.B " s in + bs b "\n.B "; + bs b (self#relative_idents m_name s2); + bs b "\n"; + bs b ".I " + ); + bs b (self#relative_idents m_name te.te_type_name); + bs b " \n"; + bs b "+="; + if te.te_private = Asttypes.Private then bs b " private"; + bs b "\n "; + List.iter + (fun x -> + let father = Name.father x.xt_name in + bs b ("| "^(Name.simple x.xt_name)); + ( + match x.xt_args, x.xt_ret with + | Cstr_tuple [], None -> bs b "\n" + | l, None -> + bs b "\n.B of "; + self#man_of_cstr_args ~par: false b father " * " l; + | Cstr_tuple [], Some r -> + bs b "\n.B : "; + self#man_of_type_expr b father r; + | l, Some r -> + bs b "\n.B : "; + self#man_of_cstr_args ~par: false b father " * " l; + bs b ".B -> "; + self#man_of_type_expr b father r; + ); + ( + match x.xt_alias with + None -> () + | Some xa -> + bs b ".B = "; + bs b + ( + match xa.xa_xt with + None -> xa.xa_name + | Some x -> x.xt_name + ); + bs b "\n" + ); + ( + match x.xt_text with + None -> + bs b " " + | Some t -> + bs b ".I \" \"\n"; + bs b "(* "; + self#man_of_info b (Some t); + bs b " *)\n " + ) + ) + te.te_constructors; + bs b "\n.sp\n"; + self#man_of_info b te.te_info; + bs b "\n.sp\n" + (** Print groff string code for an exception. *) method man_of_exception b e = Odoc_info.reset_type_names () ; @@ -428,13 +503,23 @@ class man = bs b (Name.simple e.ex_name); bs b " \n"; ( - match e.ex_args with - [] -> () - | _ -> + match e.ex_args, e.ex_ret with + | Cstr_tuple [], None -> () + | l, None -> bs b ".B of "; - self#man_of_type_expr_list + self#man_of_cstr_args ~par: false b (Name.father e.ex_name) " * " e.ex_args + | Cstr_tuple [], Some r -> + bs b ".B : "; + self#man_of_type_expr b (Name.father e.ex_name) r + | l, Some r -> + bs b ".B : "; + self#man_of_cstr_args + ~par: false + b (Name.father e.ex_name) " * " l; + bs b ".B -> "; + self#man_of_type_expr b (Name.father e.ex_name) r ); ( match e.ex_alias with @@ -456,6 +541,13 @@ class man = method man_of_type b t = Odoc_info.reset_type_names () ; let father = Name.father t.ty_name in + let field_comment = function + | None -> () + | Some t -> + bs b " (* "; + self#man_of_info b (Some t); + bs b " *) " + in bs b ".I type "; self#man_of_type_expr_param_list b father t; ( @@ -469,7 +561,18 @@ class man = ( match t.ty_manifest with None -> () - | Some typ -> + | Some (Object_type l) -> + bs b "= "; + if priv then bs b "private "; + bs b "<"; + List.iter (fun r -> + bs b (r.of_name^" : "); + self#man_of_type_expr b father r.of_type; + bs b ";"; + field_comment r.of_text ; + ) l; + bs b "\n >\n" + | Some (Other typ) -> bs b "= "; if priv then bs b "private "; self#man_of_type_expr b father typ @@ -478,80 +581,68 @@ class man = match t.ty_kind with Type_abstract -> () | Type_variant l -> - bs b "="; - if priv then bs b " private"; - bs b "\n "; - List.iter - (fun constr -> - bs b ("| "^constr.vc_name); - ( - match constr.vc_args, constr.vc_text,constr.vc_ret with - | [], None, None -> bs b "\n " - | [], (Some t), None -> - bs b " (*\n"; - self#man_of_info b (Some t); - bs b "*)\n " - | l, None, None -> - bs b "\n.B of "; - self#man_of_type_expr_list ~par: false b father " * " l; - bs b " " - | l, (Some t), None -> - bs b "\n.B of "; - self#man_of_type_expr_list ~par: false b father " * " l; - bs b ".I \" \"\n"; - bs b "(*\n"; - self#man_of_info b (Some t); - bs b "*)\n" - | [], None, Some r -> - bs b "\n.B : "; - self#man_of_type_expr b father r; - bs b " " - | [], (Some t), Some r -> - bs b "\n.B : "; - self#man_of_type_expr b father r; - bs b ".I \" \"\n"; - bs b "(*\n"; - self#man_of_info b (Some t); - bs b "*)\n " - | l, None, Some r -> - bs b "\n.B : "; - self#man_of_type_expr_list ~par: false b father " * " l; - bs b ".B -> "; - self#man_of_type_expr b father r; - bs b " " - | l, (Some t), Some r -> - bs b "\n.B of "; - self#man_of_type_expr_list ~par: false b father " * " l; - bs b ".B -> "; - self#man_of_type_expr b father r; - bs b ".I \" \"\n"; - bs b "(*\n"; - self#man_of_info b (Some t); - bs b "*)\n " - ) - ) - l + bs b "="; + if priv then bs b " private"; + bs b "\n "; + List.iter (fun constr -> + bs b ("| "^constr.vc_name); + let print_text t = + bs b " (* "; + self#man_of_info b (Some t); + bs b " *)\n " + in + match constr.vc_args, constr.vc_text,constr.vc_ret with + | Cstr_tuple [], None, None -> bs b "\n " + | Cstr_tuple [], (Some t), None -> + print_text t + | l, None, None -> + bs b "\n.B of "; + self#man_of_cstr_args ~par: false b father " * " l; + bs b " " + | l, (Some t), None -> + bs b "\n.B of "; + self#man_of_cstr_args ~par: false b father " * " l; + bs b ".I \" \"\n"; + print_text t + | Cstr_tuple [], None, Some r -> + bs b "\n.B : "; + self#man_of_type_expr b father r; + bs b " " + | Cstr_tuple [], (Some t), Some r -> + bs b "\n.B : "; + self#man_of_type_expr b father r; + bs b ".I \" \"\n"; + print_text t + | l, None, Some r -> + bs b "\n.B : "; + self#man_of_cstr_args ~par: false b father " * " l; + bs b ".B -> "; + self#man_of_type_expr b father r; + bs b " " + | l, (Some t), Some r -> + bs b "\n.B of "; + self#man_of_cstr_args ~par: false b father " * " l; + bs b ".B -> "; + self#man_of_type_expr b father r; + bs b ".I \" \"\n"; + print_text t + ) l + | Type_record l -> bs b "= "; if priv then bs b "private "; bs b "{"; - List.iter - (fun r -> - bs b (if r.rf_mutable then "\n\n.B mutable \n" else "\n "); - bs b (r.rf_name^" : "); - self#man_of_type_expr b father r.rf_type; - bs b ";"; - ( - match r.rf_text with - None -> () - | Some t -> - bs b " (*\n"; - self#man_of_info b (Some t); - bs b "*) " - ); - ) - l; + List.iter (fun r -> + bs b (if r.rf_mutable then "\n\n.B mutable \n" else "\n "); + bs b (r.rf_name^" : "); + self#man_of_type_expr b father r.rf_type; + bs b ";"; + field_comment r.rf_text ; + ) l; bs b "\n }\n" + | Type_open -> + bs b "= .."; + bs b "\n" ); bs b "\n.sp\n"; self#man_of_info b t.ty_info; @@ -724,6 +815,34 @@ class man = self#man_of_text b [Code ("=== "^(Odoc_misc.string_of_text text)^" ===")]; bs b "\n.PP\n" + method man_of_recfield b modname f = + bs b ".I "; + if f.rf_mutable then bs b (Odoc_messages.mutab^" "); + bs b (f.rf_name^" : "); + self#man_of_type_expr b modname f.rf_type; + bs b "\n.sp\n"; + self#man_of_info b f.rf_text; + bs b "\n.sp\n" + + method man_of_const b modname c = + bs b ".I "; + bs b (c.vc_name^" "); + (match c.vc_args with + | Cstr_tuple [] -> () + | Cstr_tuple (h::q) -> + bs b "of "; + self#man_of_type_expr b modname h; + List.iter + (fun ty -> + bs b " * "; + self#man_of_type_expr b modname ty) + q + | Cstr_record _ -> bs b "{ ... }" + ); + bs b "\n.sp\n"; + self#man_of_info b c.vc_text; + bs b "\n.sp\n" + (** Print groff string for an included module. *) method man_of_included_module b m_name im = bs b ".I include "; @@ -858,6 +977,42 @@ class man = incr Odoc_info.errors ; prerr_endline s + method man_of_module_type_body b mt = + self#man_of_info b mt.mt_info; + bs b "\n.sp\n"; + + (* parameters for functors *) + self#man_of_module_parameter_list b "" (Module.module_type_parameters mt); + (* a large blank *) + bs b "\n.sp\n.sp\n"; + + (* module elements *) + List.iter + (fun ele -> + match ele with + Element_module m -> + self#man_of_module b m + | Element_module_type mt -> + self#man_of_modtype b mt + | Element_included_module im -> + self#man_of_included_module b mt.mt_name im + | Element_class c -> + self#man_of_class b c + | Element_class_type ct -> + self#man_of_class_type b ct + | Element_value v -> + self#man_of_value b v + | Element_type_extension te -> + self#man_of_type_extension b mt.mt_name te + | Element_exception e -> + self#man_of_exception b e + | Element_type t -> + self#man_of_type b t + | Element_module_comment text -> + self#man_of_module_comment b text + ) + (Module.module_type_elements mt); + (** Generate the man file for the given module type. @raise Failure if an error occurs.*) method generate_for_module_type mt = @@ -895,38 +1050,7 @@ class man = self#man_of_module_type b (Name.father mt.mt_name) t ); bs b "\n.sp\n"; - self#man_of_info b mt.mt_info; - bs b "\n.sp\n"; - - (* parameters for functors *) - self#man_of_module_parameter_list b "" (Module.module_type_parameters mt); - (* a large blank *) - bs b "\n.sp\n.sp\n"; - - (* module elements *) - List.iter - (fun ele -> - match ele with - Element_module m -> - self#man_of_module b m - | Element_module_type mt -> - self#man_of_modtype b mt - | Element_included_module im -> - self#man_of_included_module b mt.mt_name im - | Element_class c -> - self#man_of_class b c - | Element_class_type ct -> - self#man_of_class_type b ct - | Element_value v -> - self#man_of_value b v - | Element_exception e -> - self#man_of_exception b e - | Element_type t -> - self#man_of_type b t - | Element_module_comment text -> - self#man_of_module_comment b text - ) - (Module.module_type_elements mt); + self#man_of_module_type_body b mt; Buffer.output_buffer chanout b; close_out chanout @@ -936,6 +1060,42 @@ class man = incr Odoc_info.errors ; prerr_endline s + method man_of_module_body b m = + self#man_of_info b m.m_info; + bs b "\n.sp\n"; + + (* parameters for functors *) + self#man_of_module_parameter_list b "" (Module.module_parameters m); + (* a large blank *) + bs b "\n.sp\n.sp\n"; + + (* module elements *) + List.iter + (fun ele -> + match ele with + Element_module m -> + self#man_of_module b m + | Element_module_type mt -> + self#man_of_modtype b mt + | Element_included_module im -> + self#man_of_included_module b m.m_name im + | Element_class c -> + self#man_of_class b c + | Element_class_type ct -> + self#man_of_class_type b ct + | Element_value v -> + self#man_of_value b v + | Element_type_extension te -> + self#man_of_type_extension b m.m_name te + | Element_exception e -> + self#man_of_exception b e + | Element_type t -> + self#man_of_type b t + | Element_module_comment text -> + self#man_of_module_comment b text + ) + (Module.module_elements m); + (** Generate the man file for the given module. @raise Failure if an error occurs.*) method generate_for_module m = @@ -969,39 +1129,7 @@ class man = bs b " : "; self#man_of_module_type b (Name.father m.m_name) m.m_type; bs b "\n.sp\n"; - self#man_of_info b m.m_info; - bs b "\n.sp\n"; - - (* parameters for functors *) - self#man_of_module_parameter_list b "" (Module.module_parameters m); - (* a large blank *) - bs b "\n.sp\n.sp\n"; - - (* module elements *) - List.iter - (fun ele -> - match ele with - Element_module m -> - self#man_of_module b m - | Element_module_type mt -> - self#man_of_modtype b mt - | Element_included_module im -> - self#man_of_included_module b m.m_name im - | Element_class c -> - self#man_of_class b c - | Element_class_type ct -> - self#man_of_class_type b ct - | Element_value v -> - self#man_of_value b v - | Element_exception e -> - self#man_of_exception b e - | Element_type t -> - self#man_of_type b t - | Element_module_comment text -> - self#man_of_module_comment b text - ) - (Module.module_elements m); - + self#man_of_module_body b m; Buffer.output_buffer chanout b; close_out chanout @@ -1010,7 +1138,7 @@ class man = raise (Failure s) (** Create the groups of elements to generate pages for. *) - method create_groups module_list = + method create_groups mini module_list = let name res_ele = match res_ele with Res_module m -> m.m_name @@ -1019,6 +1147,7 @@ class man = | Res_class_type ct -> ct.clt_name | Res_value v -> Name.simple v.val_name | Res_type t -> Name.simple t.ty_name + | Res_extension x -> Name.simple x.xt_name | Res_exception e -> Name.simple e.ex_name | Res_attribute a -> Name.simple a.att_value.val_name | Res_method m -> Name.simple m.met_value.val_name @@ -1028,7 +1157,13 @@ class man = in let all_items_pre = Odoc_info.Search.search_by_name module_list (Str.regexp ".*") in let all_items = List.filter - (fun r -> match r with Res_section _ -> false | _ -> true) + (fun r -> + match r with + Res_section _ -> false + | Res_module _ | Res_module_type _ + | Res_class _ | Res_class_type _ -> true + | _ -> not mini + ) all_items_pre in let sorted_items = List.sort (fun e1 -> fun e2 -> compare (name e1) (name e2)) all_items in @@ -1062,6 +1197,7 @@ class man = | Res_class_type ct -> ct.clt_name | Res_value v -> v.val_name | Res_type t -> t.ty_name + | Res_extension x -> x.xt_name | Res_exception e -> e.ex_name | Res_attribute a -> a.att_value.val_name | Res_method m -> m.met_value.val_name @@ -1091,6 +1227,9 @@ class man = | Res_type t -> bs b ("\n.SH "^Odoc_messages.modul^" "^(Name.father t.ty_name)^"\n"); self#man_of_type b t + | Res_extension x -> + bs b ("\n.SH "^Odoc_messages.modul^" "^(Name.father x.xt_name)^"\n"); + self#man_of_type_extension b (Name.father x.xt_name) x.xt_type_extension | Res_exception e -> bs b ("\n.SH "^Odoc_messages.modul^" "^(Name.father e.ex_name)^"\n"); self#man_of_exception b e @@ -1106,7 +1245,45 @@ class man = | Res_class_type ct -> bs b ("\n.SH "^Odoc_messages.modul^" "^(Name.father ct.clt_name)^"\n"); self#man_of_class_type b ct - | _ -> + | Res_recfield (ty,f) -> + bs b ("\n.SH Type "^(ty.ty_name)^"\n"); + self#man_of_recfield b (Name.father ty.ty_name) f + | Res_const (ty,c) -> + bs b ("\n.SH Type "^(ty.ty_name)^"\n"); + self#man_of_const b (Name.father ty.ty_name) c + | Res_module m -> + if Name.father m.m_name <> "" then + begin + bs b ("\n.SH "^Odoc_messages.modul^" "^(Name.father m.m_name)^"\n"); + bs b (Odoc_messages.modul^"\n"); + bs b (".BI \""^(Name.simple m.m_name)^"\"\n"); + bs b " : "; + self#man_of_module_type b (Name.father m.m_name) m.m_type; + end + else + begin + bs b ("\n.SH "^Odoc_messages.modul^" "^m.m_name^"\n"); + bs b " : "; + self#man_of_module_type b (Name.father m.m_name) m.m_type; + end; + bs b "\n.sp\n"; + self#man_of_module_body b m + + | Res_module_type mt -> + bs b ("\n.SH "^Odoc_messages.modul^" "^(Name.father mt.mt_name)^"\n"); + bs b (Odoc_messages.module_type^"\n"); + bs b (".BI \""^(Name.simple mt.mt_name)^"\"\n"); + bs b " = "; + ( + match mt.mt_type with + None -> () + | Some t -> + self#man_of_module_type b (Name.father mt.mt_name) t + ); + bs b "\n.sp\n"; + self#man_of_module_type_body b mt + + | Res_section _ -> (* normalement on ne peut pas avoir de module ici. *) () in @@ -1120,8 +1297,8 @@ class man = (** Generate all the man pages from a module list. *) method generate module_list = - let sorted_module_list = Sort.list (fun m1 -> fun m2 -> m1.m_name < m2.m_name) module_list in - let groups = self#create_groups sorted_module_list in + let sorted_module_list = List.sort (fun m1 m2 -> compare m1.m_name m2.m_name) module_list in + let groups = self#create_groups !man_mini sorted_module_list in let f group = match group with [] -> @@ -1130,11 +1307,7 @@ class man = | [Res_module_type mt] -> self#generate_for_module_type mt | [Res_class cl] -> self#generate_for_class cl | [Res_class_type ct] -> self#generate_for_class_type ct - | l -> - if !man_mini then - () - else - self#generate_for_group l + | l -> self#generate_for_group l in List.iter f groups end diff --git a/ocamldoc/odoc_merge.ml b/ocamldoc/odoc_merge.ml index eda6491ec..443cc3d8a 100644 --- a/ocamldoc/odoc_merge.ml +++ b/ocamldoc/odoc_merge.ml @@ -18,6 +18,7 @@ module Name = Odoc_name open Odoc_parameter open Odoc_value open Odoc_type +open Odoc_extension open Odoc_exception open Odoc_class open Odoc_module @@ -287,12 +288,41 @@ let merge_types merge_options mli ml = in List.iter f l1 + | Type_open, Type_open -> + () + | _ -> if !Odoc_global.inverse_merge_ml_mli then () else raise (Failure (Odoc_messages.different_types mli.ty_name)) +(** merge of two t_type_extension, one for a .mli, another for the .ml. + The .mli type is completed with the information in the .ml type. + Information for the extension constructors is merged separately + by [merge_extension_constructor]. *) +let merge_type_extension merge_options mli ml = + mli.te_info <- merge_info_opt merge_options mli.te_info ml.te_info; + mli.te_loc <- { mli.te_loc with loc_impl = ml.te_loc.loc_impl } ; + mli.te_code <- (match mli.te_code with None -> ml.te_code | _ -> mli.te_code) + +(** merge of two t_extension_constructor, one for a .mli, another for the .ml. + The .mli type is completed with the information in the .ml type. *) +let merge_extension_constructor merge_options mli ml = + let new_desc = + match mli.xt_text, ml.xt_text with + None, None -> None + | Some d, None + | None, Some d -> Some d + | Some d1, Some d2 -> + if List.mem Merge_description merge_options then + Some (merge_info merge_options d1 d2) + else + Some d1 + in + mli.xt_text <- new_desc + + (** Merge of two param_info, one from a .mli, one from a .ml. The text fields are not handled but will be recreated from the i_params field of the info structure. @@ -498,6 +528,33 @@ let merge_class_types merge_options mli ml = let rec merge_module_types merge_options mli ml = mli.mt_info <- merge_info_opt merge_options mli.mt_info ml.mt_info; mli.mt_loc <- { mli.mt_loc with loc_impl = ml.mt_loc.loc_impl } ; + (* merge type extensions *) + List.iter + (fun te -> + let rec f exts elems = + match exts, elems with + [], _ + | _, [] -> () + | _, (Element_type_extension te2 :: rest) -> + let merge_ext xt = + try + let xt2 = + List.find (fun xt2 -> xt.xt_name = xt2.xt_name) + te2.te_constructors + in + merge_extension_constructor merge_options xt xt2; + true + with Not_found -> false + in + let merged, unmerged = List.partition merge_ext exts in + if merged <> [] then merge_type_extension merge_options te te2; + f unmerged rest + | _, (_ :: rest) -> f exts rest + in + (* we look for the extensions in reverse order *) + f te.te_constructors (List.rev (Odoc_module.module_type_elements ml)) + ) + (Odoc_module.module_type_type_extensions mli); (* merge exceptions *) List.iter (fun ex -> @@ -746,6 +803,33 @@ and merge_modules merge_options mli ml = mli.m_code <- code; mli.m_code_intf <- code_intf; + (* merge type extensions *) + List.iter + (fun te -> + let rec f exts elems = + match exts, elems with + [], _ + | _, [] -> () + | _, (Element_type_extension te2 :: rest) -> + let merge_ext xt = + try + let xt2 = + List.find (fun xt2 -> xt.xt_name = xt2.xt_name) + te2.te_constructors + in + merge_extension_constructor merge_options xt xt2; + true + with Not_found -> false + in + let merged, unmerged = List.partition merge_ext exts in + if merged <> [] then merge_type_extension merge_options te te2; + f unmerged rest + | _, (_ :: rest) -> f exts rest + in + (* we look for the extensions in reverse order *) + f te.te_constructors (List.rev (Odoc_module.module_elements ml)) + ) + (Odoc_module.module_type_extensions mli); (* merge exceptions *) List.iter (fun ex -> diff --git a/ocamldoc/odoc_messages.ml b/ocamldoc/odoc_messages.ml index 2d6327bba..4c409a3a1 100644 --- a/ocamldoc/odoc_messages.ml +++ b/ocamldoc/odoc_messages.ml @@ -132,6 +132,11 @@ let latex_type_elt_prefix = "<string>\n\t\tUse <string> as prefix for the LaTeX labels of type elements.\n"^ "\t\t(default is \""^default_latex_type_elt_prefix^"\")" +let default_latex_extension_prefix = "extension:" +let latex_extension_prefix = + "<string>\n\t\tUse <string> as prefix for the LaTeX labels of extensions.\n"^ + "\t\t(default is \""^default_latex_extension_prefix^"\")" + let default_latex_exception_prefix = "exception:" let latex_exception_prefix = "<string>\n\t\tUse <string> as prefix for the LaTeX labels of exceptions.\n"^ @@ -258,6 +263,7 @@ let unknown_extension f = "Unknown extension for file "^f^"." let two_implementations name = "There are two implementations of module "^name^"." let two_interfaces name = "There are two interfaces of module "^name^"." let too_many_module_objects name = "There are too many interfaces/implementation of module "^name^"." +let extension_not_found_in_implementation ext m = "Extension "^ext^" was not found in implementation of module "^m^"." let exception_not_found_in_implementation exc m = "Exception "^exc^" was not found in implementation of module "^m^"." let type_not_found_in_implementation exc m = "Type "^exc^" was not found in implementation of module "^m^"." let module_not_found_in_implementation m m2 = "Module "^m^" was not found in implementation of module "^m2^"." @@ -271,11 +277,13 @@ let method_type_not_found cl met = "The type of the method "^met^" could not be let module_not_found m m2 = "The module "^m2^" could not be found in the signature of module "^m^"." let module_type_not_found m mt = "The module type "^mt^" could not be found in the signature of module "^m^"." let value_not_found m v = "The value "^v^" could not be found in the signature of module "^m^"." +let extension_not_found m e = "The extension "^e^" could not be found in the signature of module "^m^"." let exception_not_found m e = "The exception "^e^" could not be found in the signature of module "^m^"." let type_not_found m t = "The type "^t^" could not be found in the signature of module "^m^"." let class_not_found m c = "The class "^c^" could not be found in the signature of module "^m^"." let class_type_not_found m c = "The class type "^c^" could not be found in the signature of module "^m^"." let type_not_found_in_typedtree t = "Type "^t^" was not found in typed tree." +let extension_not_found_in_typedtree x = "Extension "^x^" was not found in typed tree." let exception_not_found_in_typedtree e = "Exception "^e^" was not found in typed tree." let module_type_not_found_in_typedtree mt = "Module type "^mt^" was not found in typed tree." let module_not_found_in_typedtree m = "Module "^m^" was not found in typed tree." @@ -293,6 +301,7 @@ let cross_module_or_module_type_not_found n = "Module or module type "^n^" not f let cross_class_not_found n = "Class "^n^" not found" let cross_class_type_not_found n = "class type "^n^" not found" let cross_class_or_class_type_not_found n = "Class or class type "^n^" not found" +let cross_extension_not_found n = "Extension "^n^" not found" let cross_exception_not_found n = "Exception "^n^" not found" let cross_element_not_found n = "Element "^n^" not found" let cross_method_not_found n = "Method "^n^" not found" @@ -329,6 +338,7 @@ let modules = "Modules" let functors = "Functors" let values = "Simple values" let types = "Types" +let extensions = "Extensions" let exceptions = "Exceptions" let record = "Record" let variant = "Variant" @@ -363,6 +373,7 @@ let documentation = "Documentation" let index_of = "Index of" let top = "Top" let index_of_values = index_of^" values" +let index_of_extensions = index_of^" extensions" let index_of_exceptions = index_of^" exceptions" let index_of_types = index_of^" types" let index_of_attributes = index_of^" class attributes" diff --git a/ocamldoc/odoc_misc.ml b/ocamldoc/odoc_misc.ml index c762ade2a..e938dbe67 100644 --- a/ocamldoc/odoc_misc.ml +++ b/ocamldoc/odoc_misc.ml @@ -23,7 +23,7 @@ let no_blanks s = let input_file_as_string nom = let chanin = open_in_bin nom in let len = 1024 in - let s = String.create len in + let s = Bytes.create len in let buf = Buffer.create len in let rec iter () = try @@ -32,7 +32,7 @@ let input_file_as_string nom = () else ( - Buffer.add_substring buf s 0 n; + Buffer.add_subbytes buf s 0 n; iter () ) with @@ -313,8 +313,8 @@ let get_titles_in_text t = | Odoc_types.Index_list -> () | Odoc_types.Custom (_, t) -> iter_text t | Odoc_types.Target _ -> () - and iter_text te = - List.iter iter_ele te + and iter_text txt = + List.iter iter_ele txt in iter_text t; List.rev !l diff --git a/ocamldoc/odoc_module.ml b/ocamldoc/odoc_module.ml index b1bedfa77..9ed2b1771 100644 --- a/ocamldoc/odoc_module.ml +++ b/ocamldoc/odoc_module.ml @@ -24,6 +24,7 @@ type module_element = | Element_class of Odoc_class.t_class | Element_class_type of Odoc_class.t_class_type | Element_value of Odoc_value.t_value + | Element_type_extension of Odoc_extension.t_type_extension | Element_exception of Odoc_exception.t_exception | Element_type of Odoc_type.t_type | Element_module_comment of Odoc_types.text @@ -127,6 +128,17 @@ let types l = [] l +(** Returns the list of type extensions from a list of module_element. *) +let type_extensions l = + List.fold_left + (fun acc -> fun ele -> + match ele with + Element_type_extension x -> acc @ [x] + | _ -> acc + ) + [] + l + (** Returns the list of exceptions from a list of module_element. *) let exceptions l = List.fold_left @@ -301,7 +313,11 @@ let module_simple_values ?(trans=true) m = @param trans indicates if, for aliased modules, we must perform a transitive search.*) let module_types ?(trans=true) m = types (module_elements ~trans m) -(** Returns the list of excptions of a module. +(** Returns the list of type extensions of a module. + @param trans indicates if, for aliased modules, we must perform a transitive search.*) +let module_type_extensions ?(trans=true) m = type_extensions (module_elements ~trans m) + +(** Returns the list of exceptions of a module. @param trans indicates if, for aliased modules, we must perform a transitive search.*) let module_exceptions ?(trans=true) m = exceptions (module_elements ~trans m) @@ -463,7 +479,11 @@ let module_type_values ?(trans=true) m = values (module_type_elements ~trans m) @param trans indicates if, for aliased modules, we must perform a transitive search.*) let module_type_types ?(trans=true) m = types (module_type_elements ~trans m) -(** Returns the list of excptions of a module. +(** Returns the list of type extensions of a module. + @param trans indicates if, for aliased modules, we must perform a transitive search.*) +let module_type_type_extensions ?(trans=true) m = type_extensions (module_type_elements ~trans m) + +(** Returns the list of exceptions of a module. @param trans indicates if, for aliased modules, we must perform a transitive search.*) let module_type_exceptions ?(trans=true) m = exceptions (module_type_elements ~trans m) diff --git a/ocamldoc/odoc_print.ml b/ocamldoc/odoc_print.ml index 3fa826af9..56a85e5fd 100644 --- a/ocamldoc/odoc_print.ml +++ b/ocamldoc/odoc_print.ml @@ -25,13 +25,9 @@ let new_fmt () = let (type_fmt, flush_type_fmt) = new_fmt () let _ = - let (out, flush, outnewline, outspace) = - pp_get_all_formatter_output_functions type_fmt () - in - pp_set_all_formatter_output_functions type_fmt - ~out ~flush - ~newline: (fun () -> out "\n " 0 3) - ~spaces: outspace + let outfuns = pp_get_formatter_out_functions type_fmt () in + pp_set_formatter_out_functions type_fmt + {outfuns with out_newline = fun () -> outfuns.out_string "\n " 0 3} let (modtype_fmt, flush_modtype_fmt) = new_fmt () diff --git a/ocamldoc/odoc_scan.ml b/ocamldoc/odoc_scan.ml index e507c48b7..e6c19f29d 100644 --- a/ocamldoc/odoc_scan.ml +++ b/ocamldoc/odoc_scan.ml @@ -38,12 +38,32 @@ class scanner = Odoc_type.Type_abstract -> () | Odoc_type.Type_variant l -> List.iter (self#scan_type_const t) l | Odoc_type.Type_record l -> List.iter (self#scan_type_recfield t) l + | Odoc_type.Type_open -> () + method scan_extension_constructor (e : Odoc_extension.t_extension_constructor) = () method scan_exception (e : Odoc_exception.t_exception) = () method scan_attribute (a : Odoc_value.t_attribute) = () method scan_method (m : Odoc_value.t_method) = () method scan_included_module (im : Odoc_module.included_module) = () + (** Scan of a type extension *) + + (** Overide this method to perform controls on the extension's type, + private and info. This method is called before scanning the + extensions's constructors. + @return true if the extension's constructors must be scanned.*) + method scan_type_extension_pre (x: Odoc_extension.t_type_extension) = true + + (** This method scans the constructors of the given type extension. *) + method scan_type_extension_constructors (x: Odoc_extension.t_type_extension) = + List.iter self#scan_extension_constructor (Odoc_extension.extension_constructors x) + + (** Scan of a type extension. Should not be overridden. It calls [scan_type_extension_pre] + and if [scan_type_extension_pre] returns [true], then it calls scan_type_extension_constructors.*) + method scan_type_extension (x: Odoc_extension.t_type_extension) = + if self#scan_type_extension_pre x then self#scan_type_extension_constructors x + + (** Scan of a class. *) (** Scan of a comment inside a class. *) @@ -117,6 +137,7 @@ class scanner = | Odoc_module.Element_class c -> self#scan_class c | Odoc_module.Element_class_type ct -> self#scan_class_type ct | Odoc_module.Element_value v -> self#scan_value v + | Odoc_module.Element_type_extension x -> self#scan_type_extension x | Odoc_module.Element_exception e -> self#scan_exception e | Odoc_module.Element_type t -> self#scan_type t | Odoc_module.Element_module_comment t -> self#scan_module_comment t @@ -148,6 +169,7 @@ class scanner = | Odoc_module.Element_class c -> self#scan_class c | Odoc_module.Element_class_type ct -> self#scan_class_type ct | Odoc_module.Element_value v -> self#scan_value v + | Odoc_module.Element_type_extension x -> self#scan_type_extension x | Odoc_module.Element_exception e -> self#scan_exception e | Odoc_module.Element_type t -> self#scan_type t | Odoc_module.Element_module_comment t -> self#scan_module_comment t diff --git a/ocamldoc/odoc_search.ml b/ocamldoc/odoc_search.ml index 4e76d9fe4..763b71602 100644 --- a/ocamldoc/odoc_search.ml +++ b/ocamldoc/odoc_search.ml @@ -16,6 +16,7 @@ module Name = Odoc_name open Odoc_parameter open Odoc_value open Odoc_type +open Odoc_extension open Odoc_exception open Odoc_class open Odoc_module @@ -27,6 +28,7 @@ type result_element = | Res_class_type of t_class_type | Res_value of t_value | Res_type of t_type + | Res_extension of t_extension_constructor | Res_exception of t_exception | Res_attribute of t_attribute | Res_method of t_method @@ -47,6 +49,7 @@ module type Predicates = val p_recfield : t_type -> record_field -> t -> bool val p_const : t_type -> variant_constructor -> t -> bool val p_type : t_type -> t -> (bool * bool) + val p_extension : t_extension_constructor -> t -> bool val p_exception : t_exception -> t -> bool val p_attribute : t_attribute -> t -> bool val p_method : t_method -> t -> bool @@ -113,9 +116,19 @@ module Search = List.flatten (List.map (fun rf -> search_recfield t rf v) l) | Type_variant l -> List.flatten (List.map (fun rf -> search_const t rf v) l) + | Type_open -> [] in if ok then (Res_type t) :: l else l + let search_extension_constructor xt v = + if P.p_extension xt v then [Res_extension xt] else [] + + let search_type_extension te v = + List.fold_left + (fun acc -> fun xt -> acc @ (search_extension_constructor xt v)) + [] + (Odoc_extension.extension_constructors te) + let search_exception e v = if P.p_exception e v then [Res_exception e] else [] let search_attribute a v = if P.p_attribute a v then [Res_attribute a] else [] @@ -202,6 +215,12 @@ module Search = [] (Odoc_module.module_type_types mt) in + let res_ext = + List.fold_left + (fun acc -> fun te -> acc @ (search_type_extension te v)) + [] + (Odoc_module.module_type_type_extensions mt) + in let res_exc = List.fold_left (fun acc -> fun e -> acc @ (search_exception e v)) @@ -233,7 +252,7 @@ module Search = [] (Odoc_module.module_type_comments mt) in - let l = res_val @ res_typ @ res_exc @ res_mod @ + let l = res_val @ res_typ @ res_ext @ res_exc @ res_mod @ res_modtyp @ res_cl @ res_cltyp @ res_sec in l @@ -261,6 +280,12 @@ module Search = [] (Odoc_module.module_types m) in + let res_ext = + List.fold_left + (fun acc -> fun te -> acc @ (search_type_extension te v)) + [] + (Odoc_module.module_type_extensions m) + in let res_exc = List.fold_left (fun acc -> fun e -> acc @ (search_exception e v)) @@ -292,7 +317,7 @@ module Search = [] (Odoc_module.module_comments m) in - let l = res_val @ res_typ @ res_exc @ res_mod @ + let l = res_val @ res_typ @ res_ext @ res_exc @ res_mod @ res_modtyp @ res_cl @ res_cltyp @ res_sec in l @@ -334,6 +359,7 @@ module P_name = let name = Printf.sprintf "%s.%s" t.ty_name f.vc_name in name =~ r let p_type t r = (true, t.ty_name =~ r) + let p_extension x r = x.xt_name =~ r let p_exception e r = e.ex_name =~ r let p_attribute a r = a.att_value.val_name =~ r let p_method m r = m.met_value.val_name =~ r @@ -353,6 +379,7 @@ module P_values = let p_recfield _ _ _ = false let p_const _ _ _ = false let p_type _ _ = (false, false) + let p_extension _ _ = false let p_exception _ _ = false let p_attribute _ _ = false let p_method _ _ = false @@ -369,6 +396,34 @@ let values l = in iter [] l_ele +module P_extensions = + struct + type t = unit + let p_module _ _ = (true, false) + let p_module_type _ _ = (true, false) + let p_class _ _ = (false, false) + let p_class_type _ _ = (false, false) + let p_value _ _ = false + let p_recfield _ _ _ = false + let p_const _ _ _ = false + let p_type _ _ = (false, false) + let p_extension _ _ = true + let p_exception _ _ = false + let p_attribute _ _ = false + let p_method _ _ = false + let p_section _ _ = false + end +module Search_extensions = Search ( P_extensions ) +let extensions l = + let l_ele = Search_extensions.search l () in + let p x1 x2 = x1.xt_name = x2.xt_name in + let rec iter acc = function + (Res_extension x) :: q -> if List.exists (p x) acc then iter acc q else iter (x :: acc) q + | _ :: q -> iter acc q + | [] -> acc + in + iter [] l_ele + module P_exceptions = struct type t = unit @@ -380,6 +435,7 @@ module P_exceptions = let p_recfield _ _ _ = false let p_const _ _ _ = false let p_type _ _ = (false, false) + let p_extension _ _ = false let p_exception _ _ = true let p_attribute _ _ = false let p_method _ _ = false @@ -407,6 +463,7 @@ module P_types = let p_recfield _ _ _ = false let p_const _ _ _ = false let p_type _ _ = (false, true) + let p_extension _ _ = false let p_exception _ _ = false let p_attribute _ _ = false let p_method _ _ = false @@ -434,6 +491,7 @@ module P_attributes = let p_recfield _ _ _ = false let p_const _ _ _ = false let p_type _ _ = (false, false) + let p_extension _ _ = false let p_exception _ _ = false let p_attribute _ _ = true let p_method _ _ = false @@ -461,6 +519,7 @@ module P_methods = let p_recfield _ _ _ = false let p_const _ _ _ = false let p_type _ _ = (false, false) + let p_extension _ _ = false let p_exception _ _ = false let p_attribute _ _ = false let p_method _ _ = true @@ -488,6 +547,7 @@ module P_classes = let p_recfield _ _ _ = false let p_const _ _ _ = false let p_type _ _ = (false, false) + let p_extension _ _ = false let p_exception _ _ = false let p_attribute _ _ = false let p_method _ _ = false @@ -515,6 +575,7 @@ module P_class_types = let p_recfield _ _ _ = false let p_const _ _ _ = false let p_type _ _ = (false, false) + let p_extension _ _ = false let p_exception _ _ = false let p_attribute _ _ = false let p_method _ _ = false @@ -542,6 +603,7 @@ module P_modules = let p_recfield _ _ _ = false let p_const _ _ _ = false let p_type _ _ = (false, false) + let p_extension _ _ = false let p_exception _ _ = false let p_attribute _ _ = false let p_method _ _ = false @@ -569,6 +631,7 @@ module P_module_types = let p_recfield _ _ _ = false let p_const _ _ _ = false let p_type _ _ = (false, false) + let p_extension _ _ = false let p_exception _ _ = false let p_attribute _ _ = false let p_method _ _ = false @@ -639,6 +702,15 @@ let module_type_exists mods regexp = ) l +let extension_exists mods regexp = + let l = Search_by_name.search mods regexp in + List.exists + (function + Res_extension _ -> true + | _ -> false + ) + l + let exception_exists mods regexp = let l = Search_by_name.search mods regexp in List.exists diff --git a/ocamldoc/odoc_search.mli b/ocamldoc/odoc_search.mli index bd101aa55..e0d9f2c27 100644 --- a/ocamldoc/odoc_search.mli +++ b/ocamldoc/odoc_search.mli @@ -20,6 +20,7 @@ type result_element = | Res_class_type of Odoc_class.t_class_type | Res_value of Odoc_value.t_value | Res_type of Odoc_type.t_type + | Res_extension of Odoc_extension.t_extension_constructor | Res_exception of Odoc_exception.t_exception | Res_attribute of Odoc_value.t_attribute | Res_method of Odoc_value.t_method @@ -46,6 +47,8 @@ module type Predicates = val p_recfield : Odoc_type.t_type -> Odoc_type.record_field -> t -> bool val p_const : Odoc_type.t_type -> Odoc_type.variant_constructor -> t -> bool val p_type : Odoc_type.t_type -> t -> (bool * bool) + val p_extension : + Odoc_extension.t_extension_constructor -> t -> bool val p_exception : Odoc_exception.t_exception -> t -> bool val p_attribute : Odoc_value.t_attribute -> t -> bool val p_method : Odoc_value.t_method -> t -> bool @@ -73,6 +76,14 @@ module Search : (** search in a type *) val search_type : Odoc_type.t_type -> P.t -> result_element list + (** search in an extension constructor *) + val search_extension_constructor : + Odoc_extension.t_extension_constructor -> P.t -> result_element list + + (** search in a type extension *) + val search_type_extension : + Odoc_extension.t_type_extension -> P.t -> result_element list + (** search in an exception *) val search_exception : Odoc_exception.t_exception -> P.t -> result_element list @@ -116,6 +127,8 @@ module P_name : val p_recfield : Odoc_type.t_type -> Odoc_type.record_field -> Str.regexp -> bool val p_const : Odoc_type.t_type -> Odoc_type.variant_constructor -> Str.regexp -> bool val p_type : Odoc_type.t_type -> Str.regexp -> (bool * bool) + val p_extension : + Odoc_extension.t_extension_constructor -> Str.regexp -> bool val p_exception : Odoc_exception.t_exception -> Str.regexp -> bool val p_attribute : Odoc_value.t_attribute -> Str.regexp -> bool val p_method : Odoc_value.t_method -> Str.regexp -> bool @@ -129,6 +142,10 @@ module Search_by_name : val search_recfield : Odoc_type.t_type -> Odoc_type.record_field -> P_name.t -> result_element list val search_const : Odoc_type.t_type -> Odoc_type.variant_constructor -> P_name.t -> result_element list val search_type : Odoc_type.t_type -> P_name.t -> result_element list + val search_extension_constructor : + Odoc_extension.t_extension_constructor -> P_name.t -> result_element list + val search_type_extension : + Odoc_extension.t_type_extension -> P_name.t -> result_element list val search_exception : Odoc_exception.t_exception -> P_name.t -> result_element list val search_attribute : @@ -148,6 +165,10 @@ module Search_by_name : (** A function to search all the values in a list of modules. *) val values : Odoc_module.t_module list -> Odoc_value.t_value list +(** A function to search all the extension constructors in a list of modules. *) +val extensions : + Odoc_module.t_module list -> Odoc_extension.t_extension_constructor list + (** A function to search all the exceptions in a list of modules. *) val exceptions : Odoc_module.t_module list -> Odoc_exception.t_exception list @@ -196,6 +217,10 @@ val class_exists : Odoc_module.t_module list -> Str.regexp -> bool in the given module list.*) val class_type_exists : Odoc_module.t_module list -> Str.regexp -> bool +(** Return [true] if an extension with the given complete name (regexp) exists + in the given module list.*) +val extension_exists : Odoc_module.t_module list -> Str.regexp -> bool + (** Return [true] if a exception with the given complete name (regexp) exists in the given module list.*) val exception_exists : Odoc_module.t_module list -> Str.regexp -> bool diff --git a/ocamldoc/odoc_sig.ml b/ocamldoc/odoc_sig.ml index 627938453..c2d365118 100644 --- a/ocamldoc/odoc_sig.ml +++ b/ocamldoc/odoc_sig.ml @@ -24,6 +24,7 @@ module Name = Odoc_name open Odoc_parameter open Odoc_value open Odoc_type +open Odoc_extension open Odoc_exception open Odoc_class open Odoc_module @@ -38,8 +39,7 @@ module Signature_search = | T of string | C of string | CT of string - | E of string - | ER of string + | X of string | P of string type tab = (ele, Types.signature_item) Hashtbl.t @@ -48,8 +48,8 @@ module Signature_search = match signat with Types.Sig_value (ident, _) -> Hashtbl.add table (V (Name.from_ident ident)) signat - | Types.Sig_exception (ident, _) -> - Hashtbl.add table (E (Name.from_ident ident)) signat + | Types.Sig_typext (ident, _, _) -> + Hashtbl.add table (X (Name.from_ident ident)) signat | Types.Sig_type (ident, _, _) -> Hashtbl.add table (T (Name.from_ident ident)) signat | Types.Sig_class (ident, _, _) -> @@ -71,10 +71,9 @@ module Signature_search = | (Types.Sig_value (_, val_desc)) -> val_desc.Types.val_type | _ -> assert false - let search_exception table name = - match Hashtbl.find table (E name) with - | (Types.Sig_exception (_, type_expr_list)) -> - type_expr_list + let search_extension table name = + match Hashtbl.find table (X name) with + | (Types.Sig_typext (_, ext, _)) -> ext | _ -> assert false let search_type table name = @@ -169,10 +168,44 @@ module Analyser = let merge_infos = Odoc_merge.merge_info_opt Odoc_types.all_merge_options - let name_comment_from_type_kind pos_end pos_limit tk = - match tk with - Parsetree.Ptype_abstract -> - (0, []) + let name_comment_from_type_decl pos_end pos_limit ty_decl = + match ty_decl.Parsetree.ptype_kind with + | Parsetree.Ptype_abstract -> + let open Parsetree in + begin match ty_decl.ptype_manifest with + | None -> (0, []) + | Some core_ty -> + begin match core_ty.ptyp_desc with + | Ptyp_object (fields, _) -> + let rec f = function + | [] -> [] + | ("",_,_) :: _ -> + (* Fields with no name have been eliminated previously. *) + assert false + + | (name, _atts, ct) :: [] -> + let pos = ct.Parsetree.ptyp_loc.Location.loc_end.Lexing.pos_cnum in + let s = get_string_of_file pos pos_end in + let (_,comment_opt) = My_ir.just_after_special !file_name s in + [name, comment_opt] + | (name, _atts, ct) :: ((name2, _atts2, ct2) as ele2) :: q -> + let pos = ct.Parsetree.ptyp_loc.Location.loc_end.Lexing.pos_cnum in + let pos2 = ct2.Parsetree.ptyp_loc.Location.loc_start.Lexing.pos_cnum in + let s = get_string_of_file pos pos2 in + let (_,comment_opt) = My_ir.just_after_special !file_name s in + (name, comment_opt) :: (f (ele2 :: q)) + in + let is_named_field field = + match field with + | ("",_,_) -> false + | _ -> true + in + (0, f @@ List.filter is_named_field fields) + + | _ -> (0, []) + end + end + | Parsetree.Ptype_variant cons_core_type_list_list -> let rec f acc cons_core_type_list_list = let open Parsetree in @@ -187,6 +220,7 @@ module Analyser = let (len, comment_opt) = My_ir.just_after_special !file_name s in (len, acc @ [ (pcd.pcd_name.txt, comment_opt) ]) | pcd :: (pcd2 :: _ as q) -> + (* TODO: support annotations on fields for inline records *) let pos_end_first = pcd.pcd_loc.Location.loc_end.Lexing.pos_cnum in let pos_start_second = pcd2.pcd_loc.Location.loc_start.Lexing.pos_cnum in let s = get_string_of_file pos_end_first pos_start_second in @@ -213,21 +247,58 @@ module Analyser = (name.txt, comment_opt) :: (f (ele2 :: q)) in (0, f name_mutable_type_list) + | Parsetree.Ptype_open -> + (0, []) + + + let manifest_structure env name_comment_list type_expr = + match type_expr.desc with + | Tobject (fields, _) -> + let f (field_name, _, type_expr) = + let comment_opt = + try List.assoc field_name name_comment_list + with Not_found -> None + in { + of_name = field_name ; + of_type = Odoc_env.subst_type env type_expr ; + of_text = comment_opt ; + } + in + Object_type (List.map f @@ fst @@ Ctype.flatten_fields fields) + | _ -> Other (Odoc_env.subst_type env type_expr) + + let get_field env name_comment_list {Types.ld_id=field_name;ld_mutable=mutable_flag;ld_type=type_expr} = + let field_name = Ident.name field_name in + let comment_opt = + try List.assoc field_name name_comment_list + with Not_found -> None + in + { + rf_name = field_name ; + rf_mutable = mutable_flag = Mutable ; + rf_type = Odoc_env.subst_type env type_expr ; + rf_text = comment_opt + } let get_type_kind env name_comment_list type_kind = match type_kind with Types.Type_abstract -> Odoc_type.Type_abstract | Types.Type_variant l -> - let f {Types.cd_id=constructor_name;cd_args=type_expr_list;cd_res=ret_type} = + let f {Types.cd_id=constructor_name;cd_args;cd_res=ret_type} = let constructor_name = Ident.name constructor_name in let comment_opt = - try List.assoc constructor_name name_comment_list + try List.assoc constructor_name name_comment_list with Not_found -> None in + let vc_args = + match cd_args with + | Cstr_tuple l -> Cstr_tuple (List.map (Odoc_env.subst_type env) l) + | Cstr_record l -> Cstr_record (List.map (get_field env []) l) + in { vc_name = constructor_name ; - vc_args = List.map (Odoc_env.subst_type env) type_expr_list ; + vc_args; vc_ret = may_map (Odoc_env.subst_type env) ret_type; vc_text = comment_opt } @@ -235,20 +306,11 @@ module Analyser = Odoc_type.Type_variant (List.map f l) | Types.Type_record (l, _) -> - let f {Types.ld_id=field_name;ld_mutable=mutable_flag;ld_type=type_expr} = - let field_name = Ident.name field_name in - let comment_opt = - try List.assoc field_name name_comment_list - with Not_found -> None - in - { - rf_name = field_name ; - rf_mutable = mutable_flag = Mutable ; - rf_type = Odoc_env.subst_type env type_expr ; - rf_text = comment_opt - } - in - Odoc_type.Type_record (List.map f l) + Odoc_type.Type_record (List.map (get_field env name_comment_list) l) + + | Types.Type_open -> + Odoc_type.Type_open + let erased_names_of_constraints constraints acc = List.fold_right (fun constraint_ acc -> @@ -267,6 +329,7 @@ module Analyser = | Parsetree.Psig_attribute _ | Parsetree.Psig_extension _ | Parsetree.Psig_value _ + | Parsetree.Psig_typext _ | Parsetree.Psig_exception _ | Parsetree.Psig_open _ | Parsetree.Psig_include _ @@ -297,7 +360,8 @@ module Analyser = match ele2.Parsetree.pctf_desc with Parsetree.Pctf_val (_, _, _, _) | Parsetree.Pctf_method (_, _, _, _) - | Parsetree.Pctf_constraint (_, _) -> loc.Location.loc_start.Lexing.pos_cnum + | Parsetree.Pctf_constraint (_, _) + | Parsetree.Pctf_attribute _ -> loc.Location.loc_start.Lexing.pos_cnum | Parsetree.Pctf_inherit class_type -> class_type.Parsetree.pcty_loc.Location.loc_start.Lexing.pos_cnum | Parsetree.Pctf_extension _ -> assert false @@ -456,6 +520,11 @@ module Analyser = in let (inher_l, eles) = f (pos_end + maybe_more) q in (inh :: inher_l , eles_comments @ eles) + | Parsetree.Pctf_attribute _ -> + let (comment_opt, eles_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in + let (inher_l, eles) = f loc.Location.loc_end.Lexing.pos_cnum q in + (inher_l, eles_comments @ eles) + | Parsetree.Pctf_extension _ -> assert false in f last_pos class_type_field_list @@ -550,18 +619,105 @@ module Analyser = let new_env = Odoc_env.add_value env v.val_name in (maybe_more, new_env, [ Element_value v ]) - | Parsetree.Psig_exception exception_decl -> - let name = exception_decl.Parsetree.pcd_name in - let types_excep_decl = - try Signature_search.search_exception table name.txt + | Parsetree.Psig_typext tyext -> + let new_env, types_ext_list, last_ext = + List.fold_left + (fun (env_acc, exts_acc, _) -> fun {Parsetree.pext_name = { txt = name }} -> + let complete_name = Name.concat current_module_name name in + let env_acc = Odoc_env.add_extension env_acc complete_name in + let types_ext = + try Signature_search.search_extension table name + with Not_found -> + raise (Failure (Odoc_messages.extension_not_found current_module_name name)) + in + env_acc, ((name, types_ext) :: exts_acc), Some types_ext + ) + (env, [], None) + tyext.Parsetree.ptyext_constructors + in + let ty_path, ty_params, priv = + match last_ext with + None -> assert false + | Some ext -> ext.ext_type_path, ext.ext_type_params, ext.ext_private + in + let new_te = + { + te_info = comment_opt; + te_type_name = + Odoc_env.full_type_name new_env (Name.from_path ty_path); + te_type_parameters = + List.map (Odoc_env.subst_type new_env) ty_params; + te_private = priv; + te_constructors = []; + te_loc = { loc_impl = None ; loc_inter = Some sig_item_loc} ; + te_code = + ( + if !Odoc_global.keep_code then + Some (get_string_of_file pos_start_ele pos_end_ele) + else + None + ) ; + } + in + let rec analyse_extension_constructors maybe_more exts_acc types_ext_list = + match types_ext_list with + [] -> (maybe_more, List.rev exts_acc) + | (name, types_ext) :: q -> + let ext_loc_end = types_ext.Types.ext_loc.Location.loc_end.Lexing.pos_cnum in + let xt_args = + match types_ext.ext_args with + | Cstr_tuple l -> Cstr_tuple (List.map (Odoc_env.subst_type new_env) l) + | Cstr_record l -> Cstr_record (List.map (get_field new_env []) l) + in + let new_x = + { + xt_name = Name.concat current_module_name name ; + xt_args; + xt_ret = may_map (Odoc_env.subst_type new_env) types_ext.ext_ret_type ; + xt_type_extension = new_te; + xt_alias = None ; + xt_loc = { loc_impl = None ; loc_inter = Some types_ext.Types.ext_loc} ; + xt_text = None; + } + in + let pos_limit2 = + match q with + [] -> pos_limit + | (_, next) :: _ -> next.Types.ext_loc.Location.loc_start.Lexing.pos_cnum + in + let s = get_string_of_file ext_loc_end pos_limit2 in + let (maybe_more, comment_opt) = My_ir.just_after_special !file_name s in + new_x.xt_text <- comment_opt; + analyse_extension_constructors maybe_more (new_x :: exts_acc) q + in + let (maybe_more, exts) = analyse_extension_constructors 0 [] types_ext_list in + new_te.te_constructors <- exts; + let (maybe_more2, info_after_opt) = + My_ir.just_after_special + !file_name + (get_string_of_file (pos_end_ele + maybe_more) pos_limit) + in + new_te.te_info <- merge_infos new_te.te_info info_after_opt ; + (maybe_more + maybe_more2, new_env, [ Element_type_extension new_te ]) + + | Parsetree.Psig_exception ext -> + let name = ext.Parsetree.pext_name in + let types_ext = + try Signature_search.search_extension table name.txt with Not_found -> raise (Failure (Odoc_messages.exception_not_found current_module_name name.txt)) in + let ex_args = + match types_ext.ext_args with + | Cstr_tuple l -> Cstr_tuple (List.map (Odoc_env.subst_type env) l) + | Cstr_record l -> Cstr_record (List.map (get_field env []) l) + in let e = { ex_name = Name.concat current_module_name name.txt ; ex_info = comment_opt ; - ex_args = List.map (Odoc_env.subst_type env) types_excep_decl.exn_args ; + ex_args; + ex_ret = may_map (Odoc_env.subst_type env) types_ext.ext_ret_type ; ex_alias = None ; ex_loc = { loc_impl = None ; loc_inter = Some sig_item_loc } ; ex_code = @@ -579,7 +735,7 @@ module Analyser = (get_string_of_file pos_end_ele pos_limit) in e.ex_info <- merge_infos e.ex_info info_after_opt ; - let new_env = Odoc_env.add_exception env e.ex_name in + let new_env = Odoc_env.add_extension env e.ex_name in (maybe_more, new_env, [ Element_exception e ]) | Parsetree.Psig_type name_type_decl_list -> @@ -613,10 +769,10 @@ module Analyser = | td :: _ -> td.Parsetree.ptype_loc.Location.loc_start.Lexing.pos_cnum in let (maybe_more, name_comment_list) = - name_comment_from_type_kind + name_comment_from_type_decl type_decl.Parsetree.ptype_loc.Location.loc_end.Lexing.pos_cnum pos_limit2 - type_decl.Parsetree.ptype_kind + type_decl in print_DEBUG ("Type "^name.txt^" : "^(match assoc_com with None -> "sans commentaire" | Some c -> Odoc_misc.string_of_info c)); let f_DEBUG (name, c_opt) = print_DEBUG ("constructor/field "^name^": "^(match c_opt with None -> "sans commentaire" | Some c -> Odoc_misc.string_of_info c)) in @@ -645,9 +801,11 @@ module Analyser = ty_kind = type_kind; ty_private = sig_type_decl.Types.type_private; ty_manifest = - (match sig_type_decl.Types.type_manifest with - None -> None - | Some t -> Some (Odoc_env.subst_type new_env t)); + begin match sig_type_decl.Types.type_manifest with + | None -> None + | Some t -> + Some (manifest_structure env name_comment_list t) + end ; ty_loc = { loc_impl = None ; loc_inter = Some sig_item_loc } ; ty_code = ( @@ -866,7 +1024,7 @@ module Analyser = in (maybe_more, new_env2, [ Element_module_type mt ]) - | Parsetree.Psig_include (module_type, _attrs) -> + | Parsetree.Psig_include incl -> let rec f = function Parsetree.Pmty_ident longident -> Name.from_longident longident.txt @@ -885,7 +1043,7 @@ module Analyser = end | Parsetree.Pmty_extension _ -> assert false in - let name = f module_type.Parsetree.pmty_desc in + let name = f incl.Parsetree.pincl_mod.Parsetree.pmty_desc in let full_name = Odoc_env.full_module_or_module_type_name env name in let im = { @@ -1148,11 +1306,19 @@ module Analyser = and analyse_module_kind ?(erased = Name.Set.empty) env current_module_name module_type sig_module_type = match module_type.Parsetree.pmty_desc with - Parsetree.Pmty_ident longident - | Parsetree.Pmty_alias longident -> + | Parsetree.Pmty_ident longident -> let k = analyse_module_type_kind env current_module_name module_type sig_module_type in Module_with ( k, "" ) - + | Parsetree.Pmty_alias longident -> + begin + match sig_module_type with + Types.Mty_alias path -> + let alias_name = Odoc_env.full_module_name env (Name.from_path path) in + let ma = { ma_name = alias_name ; ma_module = None } in + Module_alias ma + | _ -> + raise (Failure "Parsetree.Pmty_alias _ but not Types.Mty_alias _") + end | Parsetree.Pmty_signature signature -> ( let signature = filter_out_erased_items_from_signature erased signature in diff --git a/ocamldoc/odoc_sig.mli b/ocamldoc/odoc_sig.mli index f0c3c4a13..5dc4b4c8c 100644 --- a/ocamldoc/odoc_sig.mli +++ b/ocamldoc/odoc_sig.mli @@ -27,10 +27,10 @@ module Signature_search : @raise Not_found if error.*) val search_value : tab -> string -> Types.type_expr - (** This function returns the type expression list for the exception whose name is given, + (** This function returns the Types.extension_constructor for the extension whose name is given, in the given table. @raise Not_found if error.*) - val search_exception : tab -> string -> Types.exception_declaration + val search_extension : tab -> string -> Types.extension_constructor (** This function returns the Types.type_declaration for the type whose name is given, in the given table. @@ -42,7 +42,7 @@ module Signature_search : @raise Not_found if error.*) val search_class : tab -> string -> Types.class_declaration - (** This function returns the Types.cltype_declaration for the class type whose name is given, + (** This function returns the Types.class_type_declaration for the class type whose name is given, in the given table. @raise Not_found if error.*) val search_class_type : tab -> string -> Types.class_type_declaration @@ -139,8 +139,14 @@ module Analyser : [pos_end] is last char of the complete type definition. [pos_limit] is the position of the last char we could use to look for a comment, i.e. usually the beginning on the next element.*) - val name_comment_from_type_kind : - int -> int -> Parsetree.type_kind -> int * (string * Odoc_types.info option) list + val name_comment_from_type_decl : + int -> int -> Parsetree.type_declaration -> int * (string * Odoc_types.info option) list + + (** This function converts a [Types.type_expr] into a [Odoc_type.type_kind], + by associating the comment found in the parstree of each object field, if any. *) + val manifest_structure : + Odoc_env.env -> (string * Odoc_types.info option) list -> + Types.type_expr -> Odoc_type.type_manifest (** This function converts a [Types.type_kind] into a [Odoc_type.type_kind], by associating the comment found in the parsetree of each constructor/field, if any.*) diff --git a/ocamldoc/odoc_str.ml b/ocamldoc/odoc_str.ml index 3c45c5070..1536640e5 100644 --- a/ocamldoc/odoc_str.ml +++ b/ocamldoc/odoc_str.ml @@ -15,7 +15,8 @@ module Name = Odoc_name let string_of_variance t (co,cn) = - if t.Odoc_type.ty_kind = Odoc_type.Type_abstract && + if ( t.Odoc_type.ty_kind = Odoc_type.Type_abstract || + t.Odoc_type.ty_kind = Odoc_type.Type_open ) && t.Odoc_type.ty_manifest = None then match (co, cn) with @@ -106,6 +107,23 @@ let string_of_type_param_list t = ) (if par then ")" else "") +let string_of_type_extension_param_list te = + let par = + match te.Odoc_extension.te_type_parameters with + [] | [_] -> false + | _ -> true + in + Printf.sprintf "%s%s%s" + (if par then "(" else "") + (raw_string_of_type_list ", " + (List.map + (fun typ -> ("", typ)) + te.Odoc_extension.te_type_parameters + ) + ) + (if par then ")" else "") + + let string_of_class_type_param_list l = let par = match l with @@ -153,93 +171,176 @@ let bool_of_private = function | Asttypes.Private -> true | _ -> false +let field_doc_str = function + | None -> "" + | Some t -> Printf.sprintf "(* %s *)" (Odoc_misc.string_of_info t) + +let string_of_record l = + let module M = Odoc_type in + let module P = Printf in + P.sprintf "{\n%s\n}" ( + String.concat "\n" ( + List.map (fun field -> + P.sprintf " %s%s : %s;%s" + (if field.M.rf_mutable then "mutable " else "") field.M.rf_name + (Odoc_print.string_of_type_expr field.M.rf_type) + (field_doc_str field.M.rf_text) + ) l + ) + ) + let string_of_type t = let module M = Odoc_type in - "type "^ - (String.concat "" - (List.map - (fun (p, co, cn) -> - (string_of_variance t (co, cn))^ - (Odoc_print.string_of_type_expr p)^" " + let module P = Printf in + let priv = bool_of_private t.M.ty_private in + let parameters_str = + String.concat " " ( + List.map (fun (p, co, cn) -> + (string_of_variance t (co, cn)) ^ (Odoc_print.string_of_type_expr p) + ) t.M.ty_parameters + ) + in + let manifest_str = + match t.M.ty_manifest with + | None -> "" + | Some (M.Object_type fields) -> + P.sprintf "= %s<\n%s\n>\n" (if priv then "private " else "") ( + String.concat "\n" ( + List.map (fun field -> + P.sprintf " %s : %s;%s" field.M.of_name + (Odoc_print.string_of_type_expr field.M.of_type) + (field_doc_str field.M.of_text) + ) fields ) - t.M.ty_parameters ) - )^ - let priv = bool_of_private (t.M.ty_private) in - (Name.simple t.M.ty_name)^" "^ - (match t.M.ty_manifest with - None -> "" - | Some typ -> + | Some (M.Other typ) -> "= " ^ (if priv then "private " else "" ) ^ - (Odoc_print.string_of_type_expr typ)^" " - )^ - (match t.M.ty_kind with - M.Type_abstract -> - "" - | M.Type_variant l -> - "="^(if priv then " private" else "")^"\n"^ - (String.concat "" - (List.map - (fun cons -> - " | "^cons.M.vc_name^ - (match cons.M.vc_args,cons.M.vc_ret with - | [], None -> "" - | l, None -> - " of " ^ - (String.concat " * " - (List.map - (fun t -> "("^Odoc_print.string_of_type_expr t^")") l)) - | [], Some r -> " : " ^ Odoc_print.string_of_type_expr r - | l, Some r -> - " : " ^ - (String.concat " * " - (List.map - (fun t -> "("^Odoc_print.string_of_type_expr t^")") l)) - ^ " -> " ^ Odoc_print.string_of_type_expr r - )^ - (match cons.M.vc_text with - None -> - "" - | Some t -> - "(* "^(Odoc_misc.string_of_info t)^" *)" - )^"\n" - ) - l - ) + (Odoc_print.string_of_type_expr typ) ^ " " + in + let type_kind_str = + match t.M.ty_kind with + | M.Type_abstract -> "" + | M.Type_variant l -> + P.sprintf "=%s\n%s\n" (if priv then " private" else "") ( + String.concat "\n" ( + List.map (fun cons -> + let comment = + match cons.M.vc_text with + | None -> "" + | Some t -> P.sprintf "(* %s *)" (Odoc_misc.string_of_info t) + in + let string_of_parameters = function + | M.Cstr_tuple l -> + String.concat " * " ( + List.map (fun t -> "("^Odoc_print.string_of_type_expr t^")") l + ) + | M.Cstr_record l -> + string_of_record l + in + P.sprintf " | %s%s%s" cons.M.vc_name ( + match cons.M.vc_args, cons.M.vc_ret with + | M.Cstr_tuple [], None -> "" + | li, None -> " of " ^ (string_of_parameters li) + | M.Cstr_tuple [], Some r -> " : " ^ Odoc_print.string_of_type_expr r + | li, Some r -> + P.sprintf " : %s -> %s" (string_of_parameters li) + (Odoc_print.string_of_type_expr r) + ) comment + ) l + ) ) + + | M.Type_open -> + "= .." (* FIXME MG: when introducing new constuctors next time, + thanks to setup a minimal correct output *) | M.Type_record l -> - "= "^(if priv then "private " else "")^"{\n"^ - (String.concat "" - (List.map - (fun record -> - " "^(if record.M.rf_mutable then "mutable " else "")^ - record.M.rf_name^" : "^ - (Odoc_print.string_of_type_expr record.M.rf_type)^";"^ - (match record.M.rf_text with - None -> - "" - | Some t -> - "(* "^(Odoc_misc.string_of_info t)^" *)" - )^"\n" - ) - l - ) - )^ - "}\n" - )^ - (match t.M.ty_info with - None -> "" - | Some info -> Odoc_misc.string_of_info info) + P.sprintf "= %s{\n%s\n}\n" (if priv then "private " else "") + (string_of_record l) + in + P.sprintf "type %s %s %s%s%s" parameters_str (Name.simple t.M.ty_name) + manifest_str type_kind_str + (match t.M.ty_info with + | None -> "" + | Some info -> Odoc_misc.string_of_info info) + +let string_of_type_extension te = + let module M = Odoc_extension in + let module T = Odoc_type in + "type " + ^(String.concat "" + (List.map + (fun p -> (Odoc_print.string_of_type_expr p)^" ") + te.M.te_type_parameters + )) + ^te.M.te_type_name + ^" += " + ^(if (bool_of_private te.M.te_private) then "private " else "") + ^"\n" + ^(String.concat "" + (List.map + (fun x -> + " | " + ^(Name.simple x.M.xt_name) + ^(match x.M.xt_args, x.M.xt_ret with + | T.Cstr_tuple [], None -> "" + | T.Cstr_tuple l, None -> + " of " ^ + (String.concat " * " + (List.map + (fun t -> "("^Odoc_print.string_of_type_expr t^")") l)) + | T.Cstr_tuple [], Some r -> " : " ^ Odoc_print.string_of_type_expr r + | T.Cstr_tuple l, Some r -> + " : " ^ + (String.concat " * " + (List.map + (fun t -> "("^Odoc_print.string_of_type_expr t^")") l)) + ^ " -> " ^ Odoc_print.string_of_type_expr r + | T.Cstr_record _, _ -> + assert false + ) + ^(match x.M.xt_alias with + None -> "" + | Some xa -> + " = "^ + (match xa.M.xa_xt with + None -> xa.M.xa_name + | Some x2 -> x2.M.xt_name + ) + ) + ^(match x.M.xt_text with + None -> + "" + | Some t -> + "(* "^(Odoc_misc.string_of_info t)^" *)" + )^"\n" + ) + te.M.te_constructors)) + ^(match te.M.te_info with + None -> "" + | Some i -> Odoc_misc.string_of_info i + ) let string_of_exception e = + let module T = Odoc_type in let module M = Odoc_exception in "exception "^(Name.simple e.M.ex_name)^ - (match e.M.ex_args with - [] -> "" - | _ ->" : "^ - (String.concat " -> " - (List.map (fun t -> "("^(Odoc_print.string_of_type_expr t)^")") e.M.ex_args) - ) + (match e.M.ex_args, e.M.ex_ret with + T.Cstr_tuple [], None -> "" + | T.Cstr_tuple l,None -> + " of "^ + (String.concat " * " + (List.map (fun t -> "("^(Odoc_print.string_of_type_expr t)^")") l)) + | T.Cstr_tuple [],Some r -> + " : "^ + (Odoc_print.string_of_type_expr r) + | T.Cstr_tuple l,Some r -> + " : "^ + (String.concat " * " + (List.map (fun t -> "("^(Odoc_print.string_of_type_expr t)^")") l))^ + " -> "^ + (Odoc_print.string_of_type_expr r) + | T.Cstr_record _, _ -> + assert false )^ (match e.M.ex_alias with None -> "" diff --git a/ocamldoc/odoc_str.mli b/ocamldoc/odoc_str.mli index 44278bb0f..925deddad 100644 --- a/ocamldoc/odoc_str.mli +++ b/ocamldoc/odoc_str.mli @@ -25,6 +25,10 @@ val string_of_type_list : ?par: bool -> string -> Types.type_expr list -> string for the given type. *) val string_of_type_param_list : Odoc_type.t_type -> string +(** This function returns a string to represent the list of type parameters + for the given type extension. *) +val string_of_type_extension_param_list : Odoc_extension.t_type_extension -> string + (** This function returns a string to represent the given list of type parameters of a class or class type, with a given separator. *) @@ -33,10 +37,15 @@ val string_of_class_type_param_list : Types.type_expr list -> string (** @return a string to describe the given type. *) val string_of_type : Odoc_type.t_type -> string +val string_of_record : Odoc_type.record_field list -> string + (** @return a string to display the parameters of the given class, in the same form as the compiler. *) val string_of_class_params : Odoc_class.t_class -> string +(** @return a string to describe the given type extension. *) +val string_of_type_extension : Odoc_extension.t_type_extension -> string + (** @return a string to describe the given exception. *) val string_of_exception : Odoc_exception.t_exception -> string diff --git a/ocamldoc/odoc_test.ml b/ocamldoc/odoc_test.ml index cd7b5fa04..c68e85326 100644 --- a/ocamldoc/odoc_test.ml +++ b/ocamldoc/odoc_test.ml @@ -53,10 +53,11 @@ struct p fmt "# type %s:\n" t.ty_name; if self#must_display_types then ( - p fmt "# manifest (Odoc_info.string_of_type_expr):\n<[%s]>\n" + p fmt "# manifest :\n<[%s]>\n" (match t.ty_manifest with None -> "None" - | Some e -> Odoc_info.string_of_type_expr e + | Some (Object_type _fields) -> "< object type >" (* TODO *) + | Some (Other e) -> Odoc_info.string_of_type_expr e ); ); diff --git a/ocamldoc/odoc_texi.ml b/ocamldoc/odoc_texi.ml index 95354caac..afa4d49f7 100644 --- a/ocamldoc/odoc_texi.ml +++ b/ocamldoc/odoc_texi.ml @@ -16,6 +16,7 @@ open Odoc_info open Parameter open Value open Type +open Extension open Exception open Class open Module @@ -42,24 +43,20 @@ let is = function let pad_to n s = let len = String.length s in - if len < n - then - let s' = String.make n ' ' in - String.blit s 0 s' 0 len ; s' - else s + if len < n then s ^ String.make (n - len) ' ' else s let indent nb_sp s = let c = ref 0 in let len = pred (String.length s) in for i = 0 to len do if s.[i] = '\n' then incr c done ; - let s' = String.make (succ len + (succ !c) * nb_sp ) ' ' in + let s' = Bytes.make (succ len + (succ !c) * nb_sp ) ' ' in c := nb_sp ; for i = 0 to len do - s'.[!c] <- s.[i] ; + Bytes.set s' !c s.[i] ; if s.[i] = '\n' then c := !c + nb_sp ; incr c done ; - s' + Bytes.to_string s' type subparts = [ | `Module of Odoc_info.Module.t_module @@ -102,6 +99,7 @@ let module_subparts = type indices = [ | `Type + | `Extension | `Exception | `Value | `Class_att @@ -114,6 +112,7 @@ type indices = [ let indices = function | `Type -> "ty" + | `Extension -> "xt" | `Exception -> "ex" | `Value -> "va" | `Class_att -> "ca" @@ -125,6 +124,7 @@ let indices = function let indices_names = [ "Types" , "ty" ; + "Extensions" , "xt" ; "Exceptions" , "ex" ; "Values" , "va" ; "Class attributes", "ca" ; @@ -440,17 +440,16 @@ class texi = | Raw s -> Raw (Str.global_replace re "\n" s) | List tel -> List (List.map self#fix_linebreaks tel) | Enum tel -> Enum (List.map self#fix_linebreaks tel) - | te -> te) t + | txt -> txt) t method private soft_fix_linebreaks = let re = Str.regexp "\n[ \t]*" in fun ind t -> - let rep = String.make (succ ind) ' ' in - rep.[0] <- '\n' ; + let rep = "\n" ^ String.make ind ' ' in List.map (function | Raw s -> Raw (Str.global_replace re rep s) - | te -> te) t + | txt -> txt) t (** {3 [text] values generation} Generates [text] values out of description parts. @@ -639,17 +638,27 @@ class texi = Printf.sprintf "(%s) " (String.concat ", " (List.map f l)) - method string_of_type_args (args:Types.type_expr list) (ret:Types.type_expr option) = + method string_of_type_args (args:constructor_args) (ret:Types.type_expr option) = + let f = function + | Cstr_tuple l -> Odoc_info.string_of_type_list " * " l + | Cstr_record l -> Odoc_info.string_of_record l + in match args, ret with - | [], None -> "" - | args, None -> " of " ^ (Odoc_info.string_of_type_list " * " args) - | [], Some r -> " : " ^ (Odoc_info.string_of_type_expr r) - | args, Some r -> " : " ^ (Odoc_info.string_of_type_list " * " args) ^ + | Cstr_tuple [], None -> "" + | args, None -> " of " ^ (f args) + | Cstr_tuple [], Some r -> " : " ^ (Odoc_info.string_of_type_expr r) + | args, Some r -> " : " ^ (f args) ^ " -> " ^ (Odoc_info.string_of_type_expr r) (** Return Texinfo code for a type. *) method texi_of_type ty = Odoc_info.reset_type_names () ; + let entry_doc = function + | None -> [ Newline ] + | Some t -> + (Raw (indent 5 "\n(*\n") :: (self#soft_fix_linebreaks 8 (self#text_of_info (Some t)))) + @ [ Raw " *)" ; Newline ] + in let t = [ self#fixedblock ( [ Newline ; minus ; Raw "type " ; @@ -658,10 +667,24 @@ class texi = let priv = ty.ty_private = Asttypes.Private in ( match ty.ty_manifest with | None -> [] - | Some typ -> + | Some (Other typ) -> (Raw " = ") :: (Raw (if priv then "private " else "")) :: - (self#text_of_short_type_expr (Name.father ty.ty_name) typ) ) @ + (self#text_of_short_type_expr (Name.father ty.ty_name) typ) + | Some (Object_type l) -> + (Raw (" = "^(if priv then "private " else "")^"{\n")) :: + (List.flatten + (List.map + (fun r -> + [ Raw (" " ^ r.of_name ^ " : ") ] @ + (self#text_of_short_type_expr + (Name.father r.of_name) + r.of_type) @ + [ Raw " ;" ] @ + (entry_doc r.of_text)) + l ) ) + @ [ Raw " }" ] + ) @ ( match ty.ty_kind with | Type_abstract -> [ Newline ] @@ -673,13 +696,8 @@ class texi = (Raw (" | " ^ constr.vc_name)) :: (Raw (self#string_of_type_args constr.vc_args constr.vc_ret)) :: - (match constr.vc_text with - | None -> [ Newline ] - | Some t -> - (Raw (indent 5 "\n(*\n ") :: - self#soft_fix_linebreaks 8 (self#text_of_info (Some t))) @ - [ Raw " *)" ; Newline ] - ) ) l ) ) + (entry_doc constr.vc_text) + ) l ) ) | Type_record l -> (Raw (" = "^(if priv then "private " else "")^"{\n")) :: (List.flatten @@ -690,19 +708,61 @@ class texi = (Name.father r.rf_name) r.rf_type) @ [ Raw " ;" ] @ - (match r.rf_text with - | None -> [ Newline ] - | Some t -> - ((Raw (indent 5 "\n(*\n ")) :: - (self#soft_fix_linebreaks 8 (self#text_of_info (Some t)))) @ - [ Raw " *)" ; Newline ] ) ) + (entry_doc r.rf_text) + ) l ) ) @ [ Raw " }" ] + | Type_open -> [ Raw " = .." ; Newline ] ) ) ; self#index `Type ty.ty_name ; Newline ] @ (self#text_of_info ty.ty_info) in self#texi_of_text t + (** Return Texinfo code for a type extension. *) + method texi_of_type_extension m_name te = + Odoc_info.reset_type_names () ; + let t = + ( self#fixedblock ( + [ Newline ; minus ; + Raw "type " ; + Raw (match te.te_type_parameters with + | [] -> "" + | [ tp ] -> + Printf.sprintf "%s " + (Odoc_info.string_of_type_expr tp) + | l -> + Printf.sprintf "(%s) " + (String.concat ", " + (List.map Odoc_info.string_of_type_expr l))) ; + Raw (self#relative_idents m_name te.te_type_name) ; + Raw (" +=" ^ + (if te.te_private = Asttypes.Private + then " private" else "")^"\n") ] @ + (List.flatten + (List.map + (fun x -> + (Raw (" | " ^ (Name.simple x.xt_name))) :: + (Raw (self#string_of_type_args + x.xt_args x.xt_ret)) :: + (match x.xt_alias with + | None -> [] + | Some xa -> + [ Raw " = " ; + Raw ( match xa.xa_xt with + | None -> xa.xa_name + | Some x -> x.xt_name ) ]) @ + (match x.xt_text with + | None -> [ Newline ] + | Some t -> + (Raw (indent 5 "\n(* ") :: + self#soft_fix_linebreaks 8 + (self#text_of_info (Some t))) @ + [ Raw " *)" ; Newline ] ) @ + [self#index `Extension x.xt_name ] ) + te.te_constructors ) ) ) ) :: + (self#text_of_info te.te_info) in + self#texi_of_text t + (** Return Texinfo code for an exception. *) method texi_of_exception e = Odoc_info.reset_type_names () ; @@ -710,7 +770,7 @@ class texi = [ self#fixedblock ( [ Newline ; minus ; Raw "exception " ; Raw (Name.simple e.ex_name) ; - Raw (self#string_of_type_args e.ex_args None) ] @ + Raw (self#string_of_type_args e.ex_args e.ex_ret) ] @ (match e.ex_alias with | None -> [] | Some ea -> [ Raw " = " ; Raw @@ -838,6 +898,7 @@ class texi = | Element_class c -> self#texi_of_class c | Element_class_type ct -> self#texi_of_class_type ct | Element_value v -> self#texi_of_value v + | Element_type_extension te -> self#texi_of_type_extension module_name te | Element_exception e -> self#texi_of_exception e | Element_type t -> self#texi_of_type t | Element_module_comment t -> @@ -1198,6 +1259,7 @@ class texi = method scan_for_index_in_mod = function (* no recursion *) | Element_value _ -> self#do_index `Value + | Element_type_extension _ -> self#do_index `Extension | Element_exception _ -> self#do_index `Exception | Element_type _ -> self#do_index `Type | Element_included_module _ diff --git a/ocamldoc/odoc_text.ml b/ocamldoc/odoc_text.ml index 4fd30e0ee..eb3c56269 100644 --- a/ocamldoc/odoc_text.ml +++ b/ocamldoc/odoc_text.ml @@ -128,6 +128,7 @@ module Texter = | RK_class_type -> "classtype" | RK_value -> "val" | RK_type -> "type" + | RK_extension -> "extension" | RK_exception -> "exception" | RK_attribute -> "attribute" | RK_method -> "method" diff --git a/ocamldoc/odoc_text_lexer.mll b/ocamldoc/odoc_text_lexer.mll index aaaff1057..c8dda36aa 100644 --- a/ocamldoc/odoc_text_lexer.mll +++ b/ocamldoc/odoc_text_lexer.mll @@ -151,6 +151,7 @@ let end_verb = blank_nl"v}" let begin_ele_ref = "{!"blank_nl | "{!" let begin_val_ref = "{!val:"blank_nl | "{!val:" let begin_typ_ref = "{!type:"blank_nl | "{!type:" +let begin_ext_ref = "{!extension:"blank_nl | "{!extension:" let begin_exc_ref = "{!exception:"blank_nl | "{!exception:" let begin_mod_ref = "{!module:"blank_nl | "{!module:" let begin_modt_ref = "{!modtype:"blank_nl | "{!modtype:" @@ -529,6 +530,23 @@ rule main = parse ) } +| begin_ext_ref + { + incr_cpts lexbuf ; + if !verb_mode || !target_mode || !code_pre_mode || !open_brackets >= 1 then + Char (Lexing.lexeme lexbuf) + else + if not !ele_ref_mode then + ( + ele_ref_mode := true; + EXT_REF + ) + else + ( + Char (Lexing.lexeme lexbuf) + ) + } + | begin_exc_ref { incr_cpts lexbuf ; diff --git a/ocamldoc/odoc_text_parser.mly b/ocamldoc/odoc_text_parser.mly index c10425ccb..b4118c4f2 100644 --- a/ocamldoc/odoc_text_parser.mly +++ b/ocamldoc/odoc_text_parser.mly @@ -52,6 +52,7 @@ let print_DEBUG s = print_string s; print_newline () %token ELE_REF %token VAL_REF %token TYP_REF +%token EXT_REF %token EXC_REF %token MOD_REF %token MODT_REF @@ -113,6 +114,7 @@ ele_ref_kind: ELE_REF { None } | VAL_REF { Some RK_value } | TYP_REF { Some RK_type } +| EXT_REF { Some RK_extension } | EXC_REF { Some RK_exception } | MOD_REF { Some RK_module } | MODT_REF { Some RK_module_type } diff --git a/ocamldoc/odoc_to_text.ml b/ocamldoc/odoc_to_text.ml index c91387570..ce328b0da 100644 --- a/ocamldoc/odoc_to_text.ml +++ b/ocamldoc/odoc_to_text.ml @@ -231,6 +231,10 @@ class virtual to_text = method normal_type_list ?par m_name sep t = self#relative_idents m_name (Odoc_info.string_of_type_list ?par sep t) + method normal_cstr_args ?par m_name = function + | Cstr_tuple l -> self#normal_type_list ?par m_name " * " l + | Cstr_record _ -> "{...}" (* TODO *) + (** Get a string for a list of class or class type type parameters where all idents are relative. *) method normal_class_type_param_list m_name t = @@ -336,29 +340,38 @@ class virtual to_text = (** @return [text] value for an exception. *) method text_of_exception e = let s_name = Name.simple e.ex_name in + let father = Name.father e.ex_name in Format.fprintf Format.str_formatter "@[<hov 2>exception %s" s_name ; - (match e.ex_args with - [] -> () - | _ -> - Format.fprintf Format.str_formatter "@ of " - ); - let s = self#normal_type_list - ~par: false (Name.father e.ex_name) " * " e.ex_args - in - let s2 = - Format.fprintf Format.str_formatter "%s" s ; - (match e.ex_alias with - None -> () - | Some ea -> - Format.fprintf Format.str_formatter " = %s" - ( - match ea.ea_ex with - None -> ea.ea_name - | Some e -> e.ex_name - ) - ); - Format.flush_str_formatter () - in + (match e.ex_args, e.ex_ret with + Cstr_tuple [], None -> () + | Cstr_tuple l, None -> + Format.fprintf Format.str_formatter " %s@ %s" + "of" + (self#normal_type_list ~par: false father " * " l) + | Cstr_tuple [], Some r -> + Format.fprintf Format.str_formatter " %s@ %s" + ":" + (self#normal_type father r) + | Cstr_tuple l, Some r -> + Format.fprintf Format.str_formatter " %s@ %s@ %s@ %s" + ":" + (self#normal_type_list ~par: false father " * " l) + "->" + (self#normal_type father r) + | Cstr_record _, _ -> + assert false + ); + (match e.ex_alias with + None -> () + | Some ea -> + Format.fprintf Format.str_formatter " = %s" + ( + match ea.ea_ex with + None -> ea.ea_name + | Some e -> e.ex_name + ) + ); + let s2 = Format.flush_str_formatter () in [ CodePre s2 ] @ [Latex ("\\index{"^(self#label s_name)^"@\\verb`"^(self#label ~no_:false s_name)^"`}\n")] @ (self#text_of_info e.ex_info) diff --git a/ocamldoc/odoc_type.ml b/ocamldoc/odoc_type.ml index ef9699e60..f9bd9cda1 100644 --- a/ocamldoc/odoc_type.ml +++ b/ocamldoc/odoc_type.ml @@ -17,14 +17,6 @@ module Name = Odoc_name type private_flag = Asttypes.private_flag = Private | Public -(** Description of a variant type constructor. *) -type variant_constructor = { - vc_name : string ; - vc_args : Types.type_expr list ; (** arguments of the constructor *) - vc_ret : Types.type_expr option ; - mutable vc_text : Odoc_types.info option ; (** optional user description *) - } - (** Description of a record type field. *) type record_field = { rf_name : string ; @@ -33,6 +25,18 @@ type record_field = { mutable rf_text : Odoc_types.info option ; (** optional user description *) } +type constructor_args = + | Cstr_record of record_field list + | Cstr_tuple of Types.type_expr list + +(** Description of a variant type constructor. *) +type variant_constructor = { + vc_name : string ; + vc_args : constructor_args ; + vc_ret : Types.type_expr option ; + mutable vc_text : Odoc_types.info option ; (** optional user description *) + } + (** The various kinds of type. *) type type_kind = Type_abstract @@ -40,6 +44,17 @@ type type_kind = (** constructors *) | Type_record of record_field list (** fields *) + | Type_open + +type object_field = { + of_name : string ; + of_type : Types.type_expr ; + mutable of_text : Odoc_types.info option ; (** optional user description *) +} + +type type_manifest = + | Other of Types.type_expr (** Type manifest directly taken from Typedtre. *) + | Object_type of object_field list (** Representation of a type. *) type t_type = { @@ -49,7 +64,7 @@ type t_type = { (** type parameters: (type, covariant, contravariant) *) ty_kind : type_kind ; ty_private : private_flag; - ty_manifest : Types.type_expr option; (** type manifest *) + ty_manifest : type_manifest option; mutable ty_loc : Odoc_types.location ; mutable ty_code : string option; } diff --git a/ocamldoc/odoc_types.ml b/ocamldoc/odoc_types.ml index eccc852d6..9d7824aae 100644 --- a/ocamldoc/odoc_types.ml +++ b/ocamldoc/odoc_types.ml @@ -17,6 +17,7 @@ type ref_kind = | RK_class_type | RK_value | RK_type + | RK_extension | RK_exception | RK_attribute | RK_method diff --git a/ocamldoc/odoc_types.mli b/ocamldoc/odoc_types.mli index 7819a2346..f9456ccd8 100644 --- a/ocamldoc/odoc_types.mli +++ b/ocamldoc/odoc_types.mli @@ -20,6 +20,7 @@ type ref_kind = | RK_class_type | RK_value | RK_type + | RK_extension | RK_exception | RK_attribute | RK_method diff --git a/otherlibs/Makefile b/otherlibs/Makefile index 6c3e58aa6..397497dd5 100644 --- a/otherlibs/Makefile +++ b/otherlibs/Makefile @@ -13,8 +13,9 @@ # Common Makefile for otherlibs on the Unix ports -CAMLC=$(ROOTDIR)/ocamlcomp.sh -CAMLOPT=$(ROOTDIR)/ocamlcompopt.sh +CAMLC=$(ROOTDIR)/boot/ocamlrun $(ROOTDIR)/ocamlc -nostdlib -I $(ROOTDIR)/stdlib +CAMLOPT=$(ROOTDIR)/boot/ocamlrun $(ROOTDIR)/ocamlopt -nostdlib \ + -I $(ROOTDIR)/stdlib CFLAGS=-I$(ROOTDIR)/byterun -O $(SHAREDCCCOMPOPTS) $(EXTRACFLAGS) include ../Makefile.shared diff --git a/otherlibs/Makefile.nt b/otherlibs/Makefile.nt index aafb4217c..6d16f8d27 100644 --- a/otherlibs/Makefile.nt +++ b/otherlibs/Makefile.nt @@ -13,10 +13,9 @@ # Common Makefile for otherlibs on the Win32/MinGW ports -CAMLC=$(CAMLRUN) $(ROOTDIR)/ocamlc -nostdlib -I $(ROOTDIR)/stdlib -w s -CAMLOPT=$(CAMLRUN) $(ROOTDIR)/ocamlopt -nostdlib -I $(ROOTDIR)/stdlib -w s -CFLAGS=-I$(ROOTDIR)/byterun $(SHAREDCCCOMPOPTS) $(EXTRACFLAGS) +include ../Makefile + +# The Unix version now works fine under Windows -include ../Makefile.shared # Note .. is the current directory (this makefile is included from # a subdirectory) diff --git a/otherlibs/Makefile.shared b/otherlibs/Makefile.shared index 751a15870..9bed5f760 100644 --- a/otherlibs/Makefile.shared +++ b/otherlibs/Makefile.shared @@ -19,7 +19,7 @@ include $(ROOTDIR)/config/Makefile # Compilation options CC=$(BYTECC) CAMLRUN=$(ROOTDIR)/boot/ocamlrun -COMPFLAGS=-w +33..39 -warn-error A -bin-annot -g $(EXTRACAMLFLAGS) +COMPFLAGS=-w +33..39 -warn-error A -bin-annot -g -safe-string $(EXTRACAMLFLAGS) MKLIB=$(CAMLRUN) $(ROOTDIR)/tools/ocamlmklib # Variables to be defined by individual libraries: @@ -56,18 +56,21 @@ $(LIBNAME).cmxs: $(LIBNAME).cmxa lib$(CLIBNAME).$(A) lib$(CLIBNAME).$(A): $(COBJS) $(MKLIB) -oc $(CLIBNAME) $(COBJS) $(LDOPTS) +INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR) +INSTALL_STUBLIBDIR=$(DESTDIR)$(STUBLIBDIR) + install:: if test -f dll$(CLIBNAME)$(EXT_DLL); then \ - cp dll$(CLIBNAME)$(EXT_DLL) $(STUBLIBDIR)/; fi - cp lib$(CLIBNAME).$(A) $(LIBDIR)/ - cd $(LIBDIR); $(RANLIB) lib$(CLIBNAME).$(A) - cp $(LIBNAME).cma $(CMIFILES) $(CMIFILES:.cmi=.mli) $(LIBDIR)/ - if test -n "$(HEADERS)"; then cp $(HEADERS) $(LIBDIR)/caml/; fi + cp dll$(CLIBNAME)$(EXT_DLL) $(INSTALL_STUBLIBDIR)/; fi + cp lib$(CLIBNAME).$(A) $(INSTALL_LIBDIR)/ + cd $(INSTALL_LIBDIR); $(RANLIB) lib$(CLIBNAME).$(A) + cp $(LIBNAME).cma $(CMIFILES) $(CMIFILES:.cmi=.mli) $(INSTALL_LIBDIR)/ + if test -n "$(HEADERS)"; then cp $(HEADERS) $(INSTALL_LIBDIR)/caml/; fi installopt: - cp $(CAMLOBJS_NAT) $(LIBNAME).cmxa $(LIBNAME).$(A) $(LIBDIR)/ - cd $(LIBDIR); $(RANLIB) $(LIBNAME).a - if test -f $(LIBNAME).cmxs; then cp $(LIBNAME).cmxs $(LIBDIR)/; fi + cp $(CAMLOBJS_NAT) $(LIBNAME).cmxa $(LIBNAME).$(A) $(INSTALL_LIBDIR)/ + cd $(INSTALL_LIBDIR); $(RANLIB) $(LIBNAME).a + if test -f $(LIBNAME).cmxs; then cp $(LIBNAME).cmxs $(INSTALL_LIBDIR)/; fi partialclean: rm -f *.cm* diff --git a/otherlibs/bigarray/.depend b/otherlibs/bigarray/.depend index 4df63a3e3..889328a33 100644 --- a/otherlibs/bigarray/.depend +++ b/otherlibs/bigarray/.depend @@ -1,21 +1,21 @@ bigarray_stubs.o: bigarray_stubs.c ../../byterun/alloc.h \ - ../../byterun/misc.h ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/mlvalues.h bigarray.h \ - ../../byterun/config.h ../../byterun/mlvalues.h ../../byterun/custom.h \ - ../../byterun/fail.h ../../byterun/intext.h ../../byterun/io.h \ - ../../byterun/hash.h ../../byterun/memory.h ../../byterun/gc.h \ - ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h ../../byterun/int64_native.h + ../../byterun/misc.h ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/mlvalues.h bigarray.h \ + ../../byterun/config.h ../../byterun/mlvalues.h ../../byterun/custom.h \ + ../../byterun/fail.h ../../byterun/intext.h ../../byterun/io.h \ + ../../byterun/hash.h ../../byterun/memory.h ../../byterun/gc.h \ + ../../byterun/major_gc.h ../../byterun/freelist.h \ + ../../byterun/minor_gc.h mmap_unix.o: mmap_unix.c bigarray.h ../../byterun/config.h \ - ../../byterun/../config/m.h ../../byterun/../config/s.h \ - ../../byterun/mlvalues.h ../../byterun/config.h ../../byterun/misc.h \ - ../../byterun/custom.h ../../byterun/mlvalues.h ../../byterun/fail.h \ - ../../byterun/io.h ../../byterun/sys.h ../../byterun/signals.h + ../../byterun/../config/m.h ../../byterun/../config/s.h \ + ../../byterun/mlvalues.h ../../byterun/config.h ../../byterun/misc.h \ + ../../byterun/custom.h ../../byterun/mlvalues.h ../../byterun/fail.h \ + ../../byterun/io.h ../../byterun/sys.h ../../byterun/signals.h mmap_win32.o: mmap_win32.c bigarray.h ../../byterun/config.h \ - ../../byterun/../config/m.h ../../byterun/../config/s.h \ - ../../byterun/mlvalues.h ../../byterun/config.h ../../byterun/misc.h \ - ../../byterun/alloc.h ../../byterun/mlvalues.h ../../byterun/custom.h \ - ../../byterun/fail.h ../../byterun/sys.h ../unix/unixsupport.h + ../../byterun/../config/m.h ../../byterun/../config/s.h \ + ../../byterun/mlvalues.h ../../byterun/config.h ../../byterun/misc.h \ + ../../byterun/alloc.h ../../byterun/mlvalues.h ../../byterun/custom.h \ + ../../byterun/fail.h ../../byterun/sys.h ../unix/unixsupport.h bigarray.cmi : bigarray.cmo : bigarray.cmi bigarray.cmx : bigarray.cmi diff --git a/otherlibs/bigarray/bigarray.mli b/otherlibs/bigarray/bigarray.mli index 058c25904..b3016a717 100644 --- a/otherlibs/bigarray/bigarray.mli +++ b/otherlibs/bigarray/bigarray.mli @@ -108,7 +108,7 @@ type ('a, 'b) kind = let zero : type a b. (a, b) kind -> a = function | Float32 -> 0.0 | Complex32 -> Complex.zero | Float64 -> 0.0 | Complex64 -> Complex.zero - | Int8_signed -> 0 | Int8_unsigned -> 0 + | Int8_signed -> 0 | Int8_unsigned -> 0 | Int16_signed -> 0 | Int16_unsigned -> 0 | Int32 -> 0l | Int64 -> 0L | Int -> 0 | Nativeint -> 0n diff --git a/otherlibs/bigarray/bigarray_stubs.c b/otherlibs/bigarray/bigarray_stubs.c index b8c768afa..f2ccb92ba 100644 --- a/otherlibs/bigarray/bigarray_stubs.c +++ b/otherlibs/bigarray/bigarray_stubs.c @@ -279,9 +279,9 @@ value caml_ba_get_N(value vb, value * vind, int nind) case CAML_BA_UINT16: return Val_int(((uint16 *) b->data)[offset]); case CAML_BA_INT32: - return caml_copy_int32(((int32 *) b->data)[offset]); + return caml_copy_int32(((int32_t *) b->data)[offset]); case CAML_BA_INT64: - return caml_copy_int64(((int64 *) b->data)[offset]); + return caml_copy_int64(((int64_t *) b->data)[offset]); case CAML_BA_NATIVE_INT: return caml_copy_nativeint(((intnat *) b->data)[offset]); case CAML_BA_CAML_INT: @@ -293,7 +293,7 @@ value caml_ba_get_N(value vb, value * vind, int nind) { double * p = ((double *) b->data) + offset * 2; return copy_two_doubles(p[0], p[1]); } case CAML_BA_CHAR: - return Val_int(((char *) b->data)[offset]); + return Val_int(((unsigned char *) b->data)[offset]); } } @@ -386,16 +386,9 @@ CAMLprim value caml_ba_uint8_get32(value vb, value vind) return caml_copy_int32(res); } -#ifdef ARCH_INT64_TYPE -#include "int64_native.h" -#else -#include "int64_emul.h" -#endif - CAMLprim value caml_ba_uint8_get64(value vb, value vind) { - uint32 reshi; - uint32 reslo; + uint64_t res; unsigned char b1, b2, b3, b4, b5, b6, b7, b8; intnat idx = Long_val(vind); struct caml_ba_array * b = Caml_ba_array_val(vb); @@ -409,13 +402,17 @@ CAMLprim value caml_ba_uint8_get64(value vb, value vind) b7 = ((unsigned char*) b->data)[idx+6]; b8 = ((unsigned char*) b->data)[idx+7]; #ifdef ARCH_BIG_ENDIAN - reshi = b1 << 24 | b2 << 16 | b3 << 8 | b4; - reslo = b5 << 24 | b6 << 16 | b7 << 8 | b8; + res = (uint64_t) b1 << 56 | (uint64_t) b2 << 48 + | (uint64_t) b3 << 40 | (uint64_t) b4 << 32 + | (uint64_t) b5 << 24 | (uint64_t) b6 << 16 + | (uint64_t) b7 << 8 | (uint64_t) b8; #else - reshi = b8 << 24 | b7 << 16 | b6 << 8 | b5; - reslo = b4 << 24 | b3 << 16 | b2 << 8 | b1; + res = (uint64_t) b8 << 56 | (uint64_t) b7 << 48 + | (uint64_t) b6 << 40 | (uint64_t) b5 << 32 + | (uint64_t) b4 << 24 | (uint64_t) b3 << 16 + | (uint64_t) b2 << 8 | (uint64_t) b1; #endif - return caml_copy_int64(I64_literal(reshi,reslo)); + return caml_copy_int64(res); } /* Generic write to a big array */ @@ -450,9 +447,9 @@ static value caml_ba_set_aux(value vb, value * vind, intnat nind, value newval) case CAML_BA_UINT16: ((int16 *) b->data)[offset] = Int_val(newval); break; case CAML_BA_INT32: - ((int32 *) b->data)[offset] = Int32_val(newval); break; + ((int32_t *) b->data)[offset] = Int32_val(newval); break; case CAML_BA_INT64: - ((int64 *) b->data)[offset] = Int64_val(newval); break; + ((int64_t *) b->data)[offset] = Int64_val(newval); break; case CAML_BA_NATIVE_INT: ((intnat *) b->data)[offset] = Nativeint_val(newval); break; case CAML_BA_CAML_INT: @@ -579,31 +576,29 @@ CAMLprim value caml_ba_uint8_set32(value vb, value vind, value newval) CAMLprim value caml_ba_uint8_set64(value vb, value vind, value newval) { unsigned char b1, b2, b3, b4, b5, b6, b7, b8; - uint32 lo,hi; intnat idx = Long_val(vind); - int64 val; + int64_t val; struct caml_ba_array * b = Caml_ba_array_val(vb); if (idx < 0 || idx >= b->dim[0] - 7) caml_array_bound_error(); val = Int64_val(newval); - I64_split(val,hi,lo); #ifdef ARCH_BIG_ENDIAN - b1 = 0xFF & hi >> 24; - b2 = 0xFF & hi >> 16; - b3 = 0xFF & hi >> 8; - b4 = 0xFF & hi; - b5 = 0xFF & lo >> 24; - b6 = 0xFF & lo >> 16; - b7 = 0xFF & lo >> 8; - b8 = 0xFF & lo; + b1 = 0xFF & val >> 56; + b2 = 0xFF & val >> 48; + b3 = 0xFF & val >> 40; + b4 = 0xFF & val >> 32; + b5 = 0xFF & val >> 24; + b6 = 0xFF & val >> 16; + b7 = 0xFF & val >> 8; + b8 = 0xFF & val; #else - b8 = 0xFF & hi >> 24; - b7 = 0xFF & hi >> 16; - b6 = 0xFF & hi >> 8; - b5 = 0xFF & hi; - b4 = 0xFF & lo >> 24; - b3 = 0xFF & lo >> 16; - b2 = 0xFF & lo >> 8; - b1 = 0xFF & lo; + b8 = 0xFF & val >> 56; + b7 = 0xFF & val >> 48; + b6 = 0xFF & val >> 40; + b5 = 0xFF & val >> 32; + b4 = 0xFF & val >> 24; + b3 = 0xFF & val >> 16; + b2 = 0xFF & val >> 8; + b1 = 0xFF & val; #endif ((unsigned char*) b->data)[idx] = b1; ((unsigned char*) b->data)[idx+1] = b2; @@ -755,7 +750,7 @@ static int caml_ba_compare(value v1, value v2) case CAML_BA_FLOAT64: DO_FLOAT_COMPARISON(double); case CAML_BA_CHAR: - DO_INTEGER_COMPARISON(char); + DO_INTEGER_COMPARISON(uint8); case CAML_BA_SINT8: DO_INTEGER_COMPARISON(int8); case CAML_BA_UINT8: @@ -765,22 +760,9 @@ static int caml_ba_compare(value v1, value v2) case CAML_BA_UINT16: DO_INTEGER_COMPARISON(uint16); case CAML_BA_INT32: - DO_INTEGER_COMPARISON(int32); + DO_INTEGER_COMPARISON(int32_t); case CAML_BA_INT64: -#ifdef ARCH_INT64_TYPE - DO_INTEGER_COMPARISON(int64); -#else - { int64 * p1 = b1->data; int64 * p2 = b2->data; - for (n = 0; n < num_elts; n++) { - int64 e1 = *p1++; int64 e2 = *p2++; - if ((int32)e1.h > (int32)e2.h) return 1; - if ((int32)e1.h < (int32)e2.h) return -1; - if (e1.l > e2.l) return 1; - if (e1.l < e2.l) return -1; - } - return 0; - } -#endif + DO_INTEGER_COMPARISON(int64_t); case CAML_BA_CAML_INT: case CAML_BA_NATIVE_INT: DO_INTEGER_COMPARISON(intnat); @@ -798,7 +780,7 @@ static intnat caml_ba_hash(value v) { struct caml_ba_array * b = Caml_ba_array_val(v); intnat num_elts, n; - uint32 h, w; + uint32_t h, w; int i; num_elts = 1; @@ -838,7 +820,7 @@ static intnat caml_ba_hash(value v) } case CAML_BA_INT32: { - uint32 * p = b->data; + uint32_t * p = b->data; if (num_elts > 64) num_elts = 64; for (n = 0; n < num_elts; n++, p++) h = caml_hash_mix_uint32(h, *p); break; @@ -853,7 +835,7 @@ static intnat caml_ba_hash(value v) } case CAML_BA_INT64: { - int64 * p = b->data; + int64_t * p = b->data; if (num_elts > 32) num_elts = 32; for (n = 0; n < num_elts; n++, p++) h = caml_hash_mix_int64(h, *p); break; @@ -896,7 +878,7 @@ static void caml_ba_serialize_longarray(void * data, } else { caml_serialize_int_1(0); for (n = 0, p = data; n < num_elts; n++, p++) - caml_serialize_int_4((int32) *p); + caml_serialize_int_4((int32_t) *p); } #else caml_serialize_int_1(0); @@ -1187,7 +1169,7 @@ CAMLprim value caml_ba_fill(value vb, value vinit) case CAML_BA_SINT8: case CAML_BA_UINT8: { int init = Int_val(vinit); - char * p; + unsigned char * p; for (p = b->data; num_elts > 0; p++, num_elts--) *p = init; break; } @@ -1199,14 +1181,14 @@ CAMLprim value caml_ba_fill(value vb, value vinit) break; } case CAML_BA_INT32: { - int32 init = Int32_val(vinit); - int32 * p; + int32_t init = Int32_val(vinit); + int32_t * p; for (p = b->data; num_elts > 0; p++, num_elts--) *p = init; break; } case CAML_BA_INT64: { - int64 init = Int64_val(vinit); - int64 * p; + int64_t init = Int64_val(vinit); + int64_t * p; for (p = b->data; num_elts > 0; p++, num_elts--) *p = init; break; } diff --git a/otherlibs/bigarray/mmap_unix.c b/otherlibs/bigarray/mmap_unix.c index 8a93a06b1..cdcfe3ce3 100644 --- a/otherlibs/bigarray/mmap_unix.c +++ b/otherlibs/bigarray/mmap_unix.c @@ -153,7 +153,7 @@ CAMLprim value caml_ba_map_file(value vfd, value vkind, value vlayout, } } /* Determine offset so that the mapping starts at the given file pos */ - page = getpagesize(); + page = sysconf(_SC_PAGESIZE); delta = (uintnat) startpos % page; /* Do the mmap */ shared = Bool_val(vshared) ? MAP_SHARED : MAP_PRIVATE; @@ -189,7 +189,7 @@ CAMLprim value caml_ba_map_file_bytecode(value * argv, int argn) void caml_ba_unmap_file(void * addr, uintnat len) { #if defined(HAS_MMAP) - uintnat page = getpagesize(); + uintnat page = sysconf(_SC_PAGESIZE); uintnat delta = (uintnat) addr % page; if (len == 0) return; /* PR#5463 */ addr = (void *)((uintnat)addr - delta); diff --git a/otherlibs/dynlink/Makefile b/otherlibs/dynlink/Makefile index 67b160aa4..6284a5283 100644 --- a/otherlibs/dynlink/Makefile +++ b/otherlibs/dynlink/Makefile @@ -15,10 +15,14 @@ include ../../config/Makefile -CAMLC=../../boot/ocamlrun ../../ocamlc -CAMLOPT=../../ocamlcompopt.sh +ROOTDIR = ../.. +OCAMLRUN = $(ROOTDIR)/boot/ocamlrun +OCAMLC = $(OCAMLRUN) $(ROOTDIR)/ocamlc -nostdlib -I $(ROOTDIR)/stdlib +OCAMLOPT = $(OCAMLRUN) $(ROOTDIR)/ocamlopt -nostdlib -I $(ROOTDIR)/stdlib + INCLUDES=-I ../../utils -I ../../typing -I ../../bytecomp -I ../../asmcomp -COMPFLAGS=-w +33..39 -warn-error A -bin-annot -I ../../stdlib $(INCLUDES) +COMPFLAGS=-w +33..39 -warn-error A -bin-annot -safe-string \ + -I ../../stdlib $(INCLUDES) OBJS=dynlinkaux.cmo dynlink.cmo @@ -47,38 +51,40 @@ all: dynlink.cma extract_crc allopt: dynlink.cmxa dynlink.cma: $(OBJS) - $(CAMLC) $(COMPFLAGS) -ccopt "$(NATDYNLINKOPTS)" -a -o dynlink.cma \ + $(OCAMLC) $(COMPFLAGS) -ccopt "$(NATDYNLINKOPTS)" -a -o dynlink.cma \ $(OBJS) dynlink.cmxa: $(NATOBJS) - $(CAMLOPT) $(COMPFLAGS) -ccopt "$(NATDYNLINKOPTS)" -a -o dynlink.cmxa \ + $(OCAMLOPT) $(COMPFLAGS) -ccopt "$(NATDYNLINKOPTS)" -a -o dynlink.cmxa \ $(NATOBJS) dynlinkaux.cmo: $(COMPILEROBJS) - $(CAMLC) $(COMPFLAGS) -pack -o dynlinkaux.cmo $(COMPILEROBJS) + $(OCAMLC) $(COMPFLAGS) -pack -o dynlinkaux.cmo $(COMPILEROBJS) dynlinkaux.cmi: dynlinkaux.cmo dynlink.cmx: dynlink.cmi natdynlink.ml cp natdynlink.ml dynlink.mlopt - $(CAMLOPT) -c $(COMPFLAGS) -impl dynlink.mlopt + $(OCAMLOPT) -c $(COMPFLAGS) -impl dynlink.mlopt rm -f dynlink.mlopt extract_crc: dynlink.cma extract_crc.cmo - $(CAMLC) $(COMPFLAGS) -o extract_crc dynlink.cma extract_crc.cmo + $(OCAMLC) $(COMPFLAGS) -o extract_crc dynlink.cma extract_crc.cmo + +INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR) install: - cp dynlink.cmi dynlink.cma dynlink.mli $(LIBDIR) - cp extract_crc $(LIBDIR)/extract_crc$(EXE) + cp dynlink.cmi dynlink.cma dynlink.mli $(INSTALL_LIBDIR) + cp extract_crc $(INSTALL_LIBDIR)/extract_crc$(EXE) installopt: if $(NATDYNLINK); then \ - cp $(NATOBJS) dynlink.cmxa dynlink.$(A) $(LIBDIR) && \ - cd $(LIBDIR) && $(RANLIB) dynlink.$(A); \ + cp $(NATOBJS) dynlink.cmxa dynlink.$(A) $(INSTALL_LIBDIR) && \ + cd $(INSTALL_LIBDIR) && $(RANLIB) dynlink.$(A); \ fi partialclean: - rm -f extract_crc *.cm[ioax] *.cmxa + rm -f extract_crc *.cm[ioaxt] *.cmti *.cmxa clean: partialclean rm -f *.$(A) *.$(O) *.so *.dll dynlink.mlopt @@ -86,13 +92,13 @@ clean: partialclean .SUFFIXES: .ml .mli .cmo .cmi .cmx .mli.cmi: - $(CAMLC) -c $(COMPFLAGS) $< + $(OCAMLC) -c $(COMPFLAGS) $< .ml.cmo: - $(CAMLC) -c $(COMPFLAGS) $< + $(OCAMLC) -c $(COMPFLAGS) $< .ml.cmx: - $(CAMLOPT) -c $(COMPFLAGS) $< + $(OCAMLOPT) -c $(COMPFLAGS) $< depend: diff --git a/otherlibs/dynlink/dynlink.ml b/otherlibs/dynlink/dynlink.ml index fee98f1c1..47409ad36 100644 --- a/otherlibs/dynlink/dynlink.ml +++ b/otherlibs/dynlink/dynlink.ml @@ -79,13 +79,16 @@ let allow_extension = ref true let check_consistency file_name cu = try List.iter - (fun (name, crc) -> - if name = cu.cu_name then - Consistbl.set !crc_interfaces name crc file_name - else if !allow_extension then - Consistbl.check !crc_interfaces name crc file_name - else - Consistbl.check_noadd !crc_interfaces name crc file_name) + (fun (name, crco) -> + match crco with + None -> () + | Some crc -> + if name = cu.cu_name then + Consistbl.set !crc_interfaces name crc file_name + else if !allow_extension then + Consistbl.check !crc_interfaces name crc file_name + else + Consistbl.check_noadd !crc_interfaces name crc file_name) cu.cu_imports with Consistbl.Inconsistency(name, user, auth) -> raise(Error(Inconsistent_import name)) @@ -113,15 +116,21 @@ let prohibit names = (* Initialize the crc_interfaces table with a list of units with fixed CRCs *) let add_available_units units = - List.iter (fun (unit, crc) -> Consistbl.set !crc_interfaces unit crc "") - units + List.iter + (fun (unit, crc) -> Consistbl.set !crc_interfaces unit crc "") + units (* Default interface CRCs: those found in the current executable *) let default_crcs = ref [] let default_available_units () = clear_available_units(); - add_available_units !default_crcs; + List.iter + (fun (unit, crco) -> + match crco with + None -> () + | Some crc -> Consistbl.set !crc_interfaces unit crc "") + !default_crcs; allow_extension := true (* Initialize the linker tables and everything *) @@ -152,7 +161,9 @@ let digest_interface unit loadpath = raise (Error(File_not_found shortname)) in let ic = open_in_bin filename in try - let buffer = Misc.input_bytes ic (String.length Config.cmi_magic_number) in + let buffer = + really_input_string ic (String.length Config.cmi_magic_number) + in if buffer <> Config.cmi_magic_number then begin close_in ic; raise(Error(Corrupted_interface filename)) @@ -161,7 +172,7 @@ let digest_interface unit loadpath = close_in ic; let crc = match cmi.Cmi_format.cmi_crcs with - (_, crc) :: _ -> crc + (_, Some crc) :: _ -> crc | _ -> raise(Error(Corrupted_interface filename)) in crc @@ -189,7 +200,7 @@ let check_unsafe_module cu = (* Load in-core and execute a bytecode object file *) -external register_code_fragment: string -> int -> string -> unit +external register_code_fragment: bytes -> int -> string -> unit = "caml_register_code_fragment" let load_compunit ic file_name file_digest compunit = @@ -199,14 +210,14 @@ let load_compunit ic file_name file_digest compunit = let code_size = compunit.cu_codesize + 8 in let code = Meta.static_alloc code_size in unsafe_really_input ic code 0 compunit.cu_codesize; - String.unsafe_set code compunit.cu_codesize (Char.chr Opcodes.opRETURN); - String.unsafe_set code (compunit.cu_codesize + 1) '\000'; - String.unsafe_set code (compunit.cu_codesize + 2) '\000'; - String.unsafe_set code (compunit.cu_codesize + 3) '\000'; - String.unsafe_set code (compunit.cu_codesize + 4) '\001'; - String.unsafe_set code (compunit.cu_codesize + 5) '\000'; - String.unsafe_set code (compunit.cu_codesize + 6) '\000'; - String.unsafe_set code (compunit.cu_codesize + 7) '\000'; + Bytes.unsafe_set code compunit.cu_codesize (Char.chr Opcodes.opRETURN); + Bytes.unsafe_set code (compunit.cu_codesize + 1) '\000'; + Bytes.unsafe_set code (compunit.cu_codesize + 2) '\000'; + Bytes.unsafe_set code (compunit.cu_codesize + 3) '\000'; + Bytes.unsafe_set code (compunit.cu_codesize + 4) '\001'; + Bytes.unsafe_set code (compunit.cu_codesize + 5) '\000'; + Bytes.unsafe_set code (compunit.cu_codesize + 6) '\000'; + Bytes.unsafe_set code (compunit.cu_codesize + 7) '\000'; let initial_symtable = Symtable.current_state() in begin try Symtable.patch_object code compunit.cu_reloc; @@ -242,7 +253,7 @@ let loadfile file_name = seek_in ic 0; try let buffer = - try Misc.input_bytes ic (String.length Config.cmo_magic_number) + try really_input_string ic (String.length Config.cmo_magic_number) with End_of_file -> raise (Error (Not_a_bytecode_file file_name)) in if buffer = Config.cmo_magic_number then begin diff --git a/otherlibs/dynlink/dynlink.mli b/otherlibs/dynlink/dynlink.mli index 4ced87606..98ded877c 100644 --- a/otherlibs/dynlink/dynlink.mli +++ b/otherlibs/dynlink/dynlink.mli @@ -43,17 +43,22 @@ val adapt_filename : string -> string (** {6 Access control} *) val allow_only: string list -> unit -(** [allow_only units] restricts the compilation units that dynamically-linked - units can reference: it only allows references to the units named in - list [units]. References to any other compilation unit will cause - a [Unavailable_unit] error during [loadfile] or [loadfile_private]. - - Initially (just after calling [init]), all compilation units composing - the program currently running are available for reference from - dynamically-linked units. [allow_only] can be used to grant access - to some of them only, e.g. to the units that compose the API for +(** [allow_only units] restricts the compilation units that + dynamically-linked units can reference: it forbids all references + to units other than those named in the list [units]. References + to any other compilation unit will cause a [Unavailable_unit] + error during [loadfile] or [loadfile_private]. + + Initially (or after calling [default_available_units]) all + compilation units composing the program currently running are + available for reference from dynamically-linked units. + [allow_only] can be used to restrict access to a subset of these + units, e.g. to the units that compose the API for dynamically-linked code, and prevent access to all other units, - e.g. private, internal modules of the running program. *) + e.g. private, internal modules of the running program. If + [allow_only] is called several times, access will be restricted to + the intersection of the given lists (i.e. a call to [allow_only] + can never increase the set of available units). *) val prohibit: string list -> unit (** [prohibit units] prohibits dynamically-linked units from referencing diff --git a/otherlibs/dynlink/natdynlink.ml b/otherlibs/dynlink/natdynlink.ml index fd06d7c70..597d60fb5 100644 --- a/otherlibs/dynlink/natdynlink.ml +++ b/otherlibs/dynlink/natdynlink.ml @@ -15,9 +15,9 @@ type handle -external ndl_open: string -> bool -> handle * string = "caml_natdynlink_open" +external ndl_open: string -> bool -> handle * bytes = "caml_natdynlink_open" external ndl_run: handle -> string -> unit = "caml_natdynlink_run" -external ndl_getmap: unit -> string = "caml_natdynlink_getmap" +external ndl_getmap: unit -> bytes = "caml_natdynlink_getmap" external ndl_globals_inited: unit -> int = "caml_natdynlink_globals_inited" type linking_error = @@ -41,11 +41,7 @@ exception Error of error open Cmx_format (* Copied from config.ml to avoid dependencies *) -let cmxs_magic_number = "Caml2007D001" - -(* Copied from compilenv.ml to avoid dependencies *) -let cmx_not_found_crc = - "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +let cmxs_magic_number = "Caml2007D002" let dll_filename fname = if Filename.is_implicit fname then Filename.concat (Sys.getcwd ()) fname @@ -59,7 +55,7 @@ let read_file filename priv = if Obj.tag (Obj.repr res) = Obj.string_tag then raise (Error (Cannot_open_dll (Obj.magic res))); - let header : dynheader = Marshal.from_string data 0 in + let header : dynheader = Marshal.from_bytes data 0 in if header.dynu_magic <> cmxs_magic_number then raise(Error(Not_a_bytecode_file dll)); (dll, handle, header.dynu_units) @@ -92,7 +88,7 @@ let inited = ref false let default_available_units () = let map : (string*Digest.t*Digest.t*string list) list = - Marshal.from_string (ndl_getmap ()) 0 in + Marshal.from_bytes (ndl_getmap ()) 0 in let exe = Sys.executable_name in let rank = ref 0 in global_state := @@ -114,23 +110,26 @@ let init () = let add_check_ifaces allow_ext filename ui ifaces = List.fold_left - (fun ifaces (name, crc) -> - if name = ui.dynu_name - then StrMap.add name (crc,filename) ifaces - else - try - let (old_crc,old_src) = StrMap.find name ifaces in - if old_crc <> crc - then raise(Error(Inconsistent_import(name))) - else ifaces - with Not_found -> - if allow_ext then StrMap.add name (crc,filename) ifaces - else raise (Error(Unavailable_unit name)) + (fun ifaces (name, crco) -> + match crco with + None -> ifaces + | Some crc -> + if name = ui.dynu_name + then StrMap.add name (crc,filename) ifaces + else + try + let (old_crc,old_src) = StrMap.find name ifaces in + if old_crc <> crc + then raise(Error(Inconsistent_import(name))) + else ifaces + with Not_found -> + if allow_ext then StrMap.add name (crc,filename) ifaces + else raise (Error(Unavailable_unit name)) ) ifaces ui.dynu_imports_cmi let check_implems filename ui implems = List.iter - (fun (name, crc) -> + (fun (name, crco) -> match name with |"Out_of_memory" |"Sys_error" @@ -147,13 +146,15 @@ let check_implems filename ui implems = | _ -> try let (old_crc,old_src,state) = StrMap.find name implems in - if crc <> cmx_not_found_crc && old_crc <> crc - then raise(Error(Inconsistent_implementation(name))) - else match state with - | Check_inited i -> - if ndl_globals_inited() < i - then raise(Error(Unavailable_unit name)) - | Loaded -> () + match crco with + Some crc when old_crc <> crc -> + raise(Error(Inconsistent_implementation(name))) + | _ -> + match state with + | Check_inited i -> + if ndl_globals_inited() < i + then raise(Error(Unavailable_unit name)) + | Loaded -> () with Not_found -> raise (Error(Unavailable_unit name)) ) ui.dynu_imports_cmx diff --git a/otherlibs/graph/.depend b/otherlibs/graph/.depend index b4b531d43..ab9faa619 100644 --- a/otherlibs/graph/.depend +++ b/otherlibs/graph/.depend @@ -1,63 +1,103 @@ -color.o: color.c libgraph.h ../../byterun/mlvalues.h \ - ../../byterun/compatibility.h ../../byterun/config.h \ - ../../byterun/../config/m.h ../../byterun/../config/s.h \ - ../../byterun/misc.h -draw.o: draw.c libgraph.h ../../byterun/mlvalues.h \ - ../../byterun/compatibility.h ../../byterun/config.h \ - ../../byterun/../config/m.h ../../byterun/../config/s.h \ - ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h -dump_img.o: dump_img.c libgraph.h ../../byterun/mlvalues.h \ - ../../byterun/compatibility.h ../../byterun/config.h \ - ../../byterun/../config/m.h ../../byterun/../config/s.h \ - ../../byterun/misc.h image.h ../../byterun/alloc.h \ - ../../byterun/mlvalues.h ../../byterun/memory.h ../../byterun/gc.h \ - ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h -events.o: events.c libgraph.h ../../byterun/mlvalues.h \ - ../../byterun/compatibility.h ../../byterun/config.h \ - ../../byterun/../config/m.h ../../byterun/../config/s.h \ - ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \ - ../../byterun/signals.h -fill.o: fill.c libgraph.h ../../byterun/mlvalues.h \ - ../../byterun/compatibility.h ../../byterun/config.h \ - ../../byterun/../config/m.h ../../byterun/../config/s.h \ - ../../byterun/misc.h ../../byterun/memory.h ../../byterun/gc.h \ - ../../byterun/mlvalues.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/minor_gc.h -image.o: image.c libgraph.h ../../byterun/mlvalues.h \ - ../../byterun/compatibility.h ../../byterun/config.h \ - ../../byterun/../config/m.h ../../byterun/../config/s.h \ - ../../byterun/misc.h image.h ../../byterun/alloc.h \ - ../../byterun/mlvalues.h ../../byterun/custom.h -make_img.o: make_img.c libgraph.h ../../byterun/mlvalues.h \ - ../../byterun/compatibility.h ../../byterun/config.h \ - ../../byterun/../config/m.h ../../byterun/../config/s.h \ - ../../byterun/misc.h image.h ../../byterun/memory.h ../../byterun/gc.h \ - ../../byterun/mlvalues.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/minor_gc.h -open.o: open.c libgraph.h ../../byterun/mlvalues.h \ - ../../byterun/compatibility.h ../../byterun/config.h \ - ../../byterun/../config/m.h ../../byterun/../config/s.h \ - ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \ - ../../byterun/callback.h ../../byterun/fail.h ../../byterun/memory.h \ - ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h -point_col.o: point_col.c libgraph.h ../../byterun/mlvalues.h \ - ../../byterun/compatibility.h ../../byterun/config.h \ - ../../byterun/../config/m.h ../../byterun/../config/s.h \ - ../../byterun/misc.h -sound.o: sound.c libgraph.h ../../byterun/mlvalues.h \ - ../../byterun/compatibility.h ../../byterun/config.h \ - ../../byterun/../config/m.h ../../byterun/../config/s.h \ - ../../byterun/misc.h -subwindow.o: subwindow.c libgraph.h ../../byterun/mlvalues.h \ - ../../byterun/compatibility.h ../../byterun/config.h \ - ../../byterun/../config/m.h ../../byterun/../config/s.h \ - ../../byterun/misc.h -text.o: text.c libgraph.h ../../byterun/mlvalues.h \ - ../../byterun/compatibility.h ../../byterun/config.h \ - ../../byterun/../config/m.h ../../byterun/../config/s.h \ - ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h +color.o: color.c libgraph.h \ + \ + \ + \ + ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/misc.h \ + +draw.o: draw.c libgraph.h \ + \ + \ + \ + ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ + ../../byterun/mlvalues.h +dump_img.o: dump_img.c libgraph.h \ + \ + \ + \ + ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/misc.h image.h \ + ../../byterun/alloc.h ../../byterun/mlvalues.h ../../byterun/memory.h \ + ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \ + ../../byterun/minor_gc.h +events.o: events.c libgraph.h \ + \ + \ + \ + ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ + ../../byterun/mlvalues.h ../../byterun/signals.h +fill.o: fill.c libgraph.h \ + \ + \ + \ + ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/memory.h \ + ../../byterun/gc.h ../../byterun/mlvalues.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/minor_gc.h +image.o: image.c libgraph.h \ + \ + \ + \ + ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/misc.h image.h \ + ../../byterun/alloc.h ../../byterun/mlvalues.h ../../byterun/custom.h +make_img.o: make_img.c libgraph.h \ + \ + \ + \ + ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/misc.h image.h \ + ../../byterun/memory.h ../../byterun/gc.h ../../byterun/mlvalues.h \ + ../../byterun/major_gc.h ../../byterun/freelist.h \ + ../../byterun/minor_gc.h +open.o: open.c libgraph.h \ + \ + \ + \ + ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ + ../../byterun/mlvalues.h ../../byterun/callback.h ../../byterun/fail.h \ + ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/minor_gc.h +point_col.o: point_col.c libgraph.h \ + \ + \ + \ + ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/misc.h +sound.o: sound.c libgraph.h \ + \ + \ + \ + ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/misc.h +subwindow.o: subwindow.c libgraph.h \ + \ + \ + \ + ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/misc.h +text.o: text.c libgraph.h \ + \ + \ + \ + ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ + ../../byterun/mlvalues.h graphics.cmi : graphicsX11.cmi : graphics.cmo : graphics.cmi diff --git a/otherlibs/graph/libgraph.h b/otherlibs/graph/libgraph.h index e75ee801c..71204e313 100644 --- a/otherlibs/graph/libgraph.h +++ b/otherlibs/graph/libgraph.h @@ -15,6 +15,7 @@ #include <X11/Xlib.h> #include <X11/Xutil.h> #include <mlvalues.h> +#include <misc.h> struct canvas { int w, h; /* Dimensions of the drawable */ @@ -73,7 +74,7 @@ extern int caml_gr_bits_per_pixel; #endif #endif -extern void caml_gr_fail(char *fmt, char *arg); +extern void caml_gr_fail(char *fmt, char *arg) Noreturn; extern void caml_gr_check_open(void); extern unsigned long caml_gr_pixel_rgb(int rgb); extern int caml_gr_rgb_pixel(long unsigned int pixel); diff --git a/otherlibs/graph/open.c b/otherlibs/graph/open.c index e3529d42d..14a00eafd 100644 --- a/otherlibs/graph/open.c +++ b/otherlibs/graph/open.c @@ -244,8 +244,7 @@ value caml_gr_window_id(void) value caml_gr_set_window_title(value n) { if (window_name != NULL) stat_free(window_name); - window_name = caml_stat_alloc(strlen(String_val(n))+1); - strcpy(window_name, String_val(n)); + window_name = caml_strdup(String_val(n)); if (caml_gr_initialized) { XStoreName(caml_gr_display, caml_gr_window.win, window_name); XSetIconName(caml_gr_display, caml_gr_window.win, window_name); diff --git a/otherlibs/num/.depend b/otherlibs/num/.depend index 32d691cc8..51b180f5d 100644 --- a/otherlibs/num/.depend +++ b/otherlibs/num/.depend @@ -1,6 +1,6 @@ bng.o: bng.c bng.h ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/compatibility.h bng_amd64.c \ - bng_digit.c + ../../byterun/../config/s.h ../../byterun/compatibility.h bng_amd64.c \ + bng_digit.c bng_amd64.o: bng_amd64.c bng_arm64.o: bng_arm64.c bng_digit.o: bng_digit.c @@ -8,14 +8,14 @@ bng_ia32.o: bng_ia32.c bng_ppc.o: bng_ppc.c bng_sparc.o: bng_sparc.c nat_stubs.o: nat_stubs.c ../../byterun/alloc.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/mlvalues.h \ - ../../byterun/config.h ../../byterun/custom.h ../../byterun/intext.h \ - ../../byterun/io.h ../../byterun/fail.h ../../byterun/hash.h \ - ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/minor_gc.h \ - ../../byterun/mlvalues.h bng.h nat.h + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/mlvalues.h \ + ../../byterun/config.h ../../byterun/custom.h ../../byterun/intext.h \ + ../../byterun/io.h ../../byterun/fail.h ../../byterun/hash.h \ + ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/minor_gc.h \ + ../../byterun/mlvalues.h bng.h nat.h arith_flags.cmi : arith_status.cmi : big_int.cmi : nat.cmi diff --git a/otherlibs/num/arith_flags.ml b/otherlibs/num/arith_flags.ml index 048d4f8db..df109ae9f 100644 --- a/otherlibs/num/arith_flags.ml +++ b/otherlibs/num/arith_flags.ml @@ -11,8 +11,6 @@ (* *) (***********************************************************************) -(* $Id$ *) - let error_when_null_denominator_flag = ref true;; let normalize_ratio_flag = ref false;; diff --git a/otherlibs/num/arith_flags.mli b/otherlibs/num/arith_flags.mli index 653942431..791446c24 100644 --- a/otherlibs/num/arith_flags.mli +++ b/otherlibs/num/arith_flags.mli @@ -11,8 +11,6 @@ (* *) (***********************************************************************) -(* $Id$ *) - val error_when_null_denominator_flag : bool ref val normalize_ratio_flag : bool ref val normalize_ratio_when_printing_flag : bool ref diff --git a/otherlibs/num/arith_status.ml b/otherlibs/num/arith_status.ml index 0f9deb363..585db9d01 100644 --- a/otherlibs/num/arith_status.ml +++ b/otherlibs/num/arith_status.ml @@ -11,8 +11,6 @@ (* *) (***********************************************************************) -(* $Id$ *) - open Arith_flags;; let get_error_when_null_denominator () = diff --git a/otherlibs/num/arith_status.mli b/otherlibs/num/arith_status.mli index 170e8cd4c..cc0289daa 100644 --- a/otherlibs/num/arith_status.mli +++ b/otherlibs/num/arith_status.mli @@ -11,8 +11,6 @@ (* *) (***********************************************************************) -(* $Id$ *) - (** Flags that control rational arithmetic. *) val arith_status: unit -> unit diff --git a/otherlibs/num/big_int.ml b/otherlibs/num/big_int.ml index 6b5249641..847d15832 100644 --- a/otherlibs/num/big_int.ml +++ b/otherlibs/num/big_int.ml @@ -11,8 +11,6 @@ (* *) (***********************************************************************) -(* $Id$ *) - open Int_misc open Nat @@ -627,15 +625,15 @@ let square_big_int bi = else s <- the round number and the result_int is false *) let round_futur_last_digit s off_set length = let l = pred (length + off_set) in - if Char.code(String.get s l) >= Char.code '5' + if Char.code(Bytes.get s l) >= Char.code '5' then let rec round_rec l = if l < off_set then true else begin - let current_char = String.get s l in + let current_char = Bytes.get s l in if current_char = '9' then - (String.set s l '0'; round_rec (pred l)) + (Bytes.set s l '0'; round_rec (pred l)) else - (String.set s l (Char.chr (succ (Char.code current_char))); + (Bytes.set s l (Char.chr (succ (Char.code current_char))); false) end in round_rec (pred l) @@ -654,17 +652,19 @@ let approx_big_int prec bi = (big_int_of_string "963295986")) (big_int_of_string "100000000")))) in let s = - string_of_big_int (div_big_int bi (power_int_positive_int 10 n)) in + Bytes.unsafe_of_string + (string_of_big_int (div_big_int bi (power_int_positive_int 10 n))) + in let (sign, off, len) = - if String.get s 0 = '-' + if Bytes.get s 0 = '-' then ("-", 1, succ prec) else ("", 0, prec) in if (round_futur_last_digit s off (succ prec)) then (sign^"1."^(String.make prec '0')^"e"^ - (string_of_int (n + 1 - off + String.length s))) - else (sign^(String.sub s off 1)^"."^ - (String.sub s (succ off) (pred prec)) - ^"e"^(string_of_int (n - succ off + String.length s))) + (string_of_int (n + 1 - off + Bytes.length s))) + else (sign^(Bytes.sub_string s off 1)^"."^ + (Bytes.sub_string s (succ off) (pred prec)) + ^"e"^(string_of_int (n - succ off + Bytes.length s))) (* Logical operations *) diff --git a/otherlibs/num/big_int.mli b/otherlibs/num/big_int.mli index fc75153ef..738730a79 100644 --- a/otherlibs/num/big_int.mli +++ b/otherlibs/num/big_int.mli @@ -11,8 +11,6 @@ (* *) (***********************************************************************) -(* $Id$ *) - (** Operations on arbitrary-precision integers. Big integers (type [big_int]) are signed integers of arbitrary size. @@ -189,5 +187,5 @@ val nat_of_big_int : big_int -> nat val big_int_of_nat : nat -> big_int val base_power_big_int: int -> int -> big_int -> big_int val sys_big_int_of_string: string -> int -> int -> big_int -val round_futur_last_digit : string -> int -> int -> bool +val round_futur_last_digit : bytes -> int -> int -> bool val approx_big_int: int -> big_int -> string diff --git a/otherlibs/num/int_misc.ml b/otherlibs/num/int_misc.ml index 99713b916..f8a91ee3a 100644 --- a/otherlibs/num/int_misc.ml +++ b/otherlibs/num/int_misc.ml @@ -11,8 +11,6 @@ (* *) (***********************************************************************) -(* $Id$ *) - (* Some extra operations on integers *) let rec gcd_int i1 i2 = diff --git a/otherlibs/num/int_misc.mli b/otherlibs/num/int_misc.mli index 7f465c5ad..6146732d4 100644 --- a/otherlibs/num/int_misc.mli +++ b/otherlibs/num/int_misc.mli @@ -11,8 +11,6 @@ (* *) (***********************************************************************) -(* $Id$ *) - (* Some extra operations on integers *) val gcd_int: int -> int -> int diff --git a/otherlibs/num/nat.ml b/otherlibs/num/nat.ml index 981f83539..90cb471c1 100644 --- a/otherlibs/num/nat.ml +++ b/otherlibs/num/nat.ml @@ -11,8 +11,6 @@ (* *) (***********************************************************************) -(* $Id$ *) - open Int_misc type nat;; @@ -284,18 +282,15 @@ let raw_string_of_digit nat off = and s1 = string_of_int (nth_digit_nat a_1 0) in let len = String.length s1 in if leading_digits < 10 then begin - let result = String.make (max_superscript_10_power_in_int+1) '0' in - String.set result 0 - (Char.chr (48 + leading_digits)); - String.blit s1 0 - result (String.length result - len) len; - result + let result = Bytes.make (max_superscript_10_power_in_int+1) '0' in + Bytes.set result 0 (Char.chr (48 + leading_digits)); + String.blit s1 0 result (Bytes.length result - len) len; + Bytes.to_string result end else begin - let result = String.make (max_superscript_10_power_in_int+2) '0' in + let result = Bytes.make (max_superscript_10_power_in_int+2) '0' in String.blit (string_of_int leading_digits) 0 result 0 2; - String.blit s1 0 - result (String.length result - len) len; - result + String.blit s1 0 result (Bytes.length result - len) len; + Bytes.to_string result end end @@ -346,7 +341,7 @@ let int_to_string int s pos_ref base times = let i = ref int and j = ref times in while ((!i != 0) || (!j != 0)) && (!pos_ref != -1) do - String.set s !pos_ref (String.get digits (!i mod base)); + Bytes.set s !pos_ref (String.get digits (!i mod base)); decr pos_ref; decr j; i := !i / base @@ -468,7 +463,7 @@ let unadjusted_string_of_nat nat off len_nat = if len > biggest_int / (succ pmax) then failwith "number too long" else let len_s = (succ pmax) * len in - let s = String.make len_s '0' + let s = Bytes.make len_s '0' and pos_ref = ref len_s in len_copy := pred !len_copy; blit_nat copy1 0 nat off len; @@ -490,7 +485,7 @@ let unadjusted_string_of_nat nat off len_nat = blit_nat copy1 0 copy2 0 !len_copy; set_digit_nat copy1 !len_copy 0 done; - s + Bytes.unsafe_to_string s let string_of_nat nat = let s = unadjusted_string_of_nat nat 0 (length_nat nat) diff --git a/otherlibs/num/nat.mli b/otherlibs/num/nat.mli index 39f1c5908..f9e279b64 100644 --- a/otherlibs/num/nat.mli +++ b/otherlibs/num/nat.mli @@ -11,8 +11,6 @@ (* *) (***********************************************************************) -(* $Id$ *) - (* Module [Nat]: operations on natural numbers *) type nat diff --git a/otherlibs/num/nat_stubs.c b/otherlibs/num/nat_stubs.c index 9a62759fa..d718a0538 100644 --- a/otherlibs/num/nat_stubs.c +++ b/otherlibs/num/nat_stubs.c @@ -347,9 +347,9 @@ static void serialize_nat(value nat, if (len >= ((mlsize_t)1 << 32)) failwith("output_value: nat too big"); #endif - serialize_int_4((int32) len); + serialize_int_4((int32_t) len); #if defined(ARCH_SIXTYFOUR) && defined(ARCH_BIG_ENDIAN) - { int32 * p; + { int32_t * p; mlsize_t i; for (i = len, p = Data_custom_val(nat); i > 0; i -= 2, p += 2) { serialize_int_4(p[1]); /* low 32 bits of 64-bit digit */ @@ -369,7 +369,7 @@ static uintnat deserialize_nat(void * dst) len = deserialize_uint_4(); #if defined(ARCH_SIXTYFOUR) && defined(ARCH_BIG_ENDIAN) - { uint32 * p; + { uint32_t * p; mlsize_t i; for (i = len, p = dst; i > 1; i -= 2, p += 2) { p[1] = deserialize_uint_4(); /* low 32 bits of 64-bit digit */ @@ -385,7 +385,7 @@ static uintnat deserialize_nat(void * dst) deserialize_block_4(dst, len); #if defined(ARCH_SIXTYFOUR) if (len & 1){ - ((uint32 *) dst)[len] = 0; + ((uint32_t *) dst)[len] = 0; ++ len; } #endif @@ -396,7 +396,7 @@ static uintnat deserialize_nat(void * dst) static intnat hash_nat(value v) { bngsize len, i; - uint32 h; + uint32_t h; len = bng_num_digits(&Digit_val(v,0), Wosize_val(v) - 1); h = 0; @@ -406,10 +406,10 @@ static intnat hash_nat(value v) /* Mix the two 32-bit halves as if we were on a 32-bit platform, namely low 32 bits first, then high 32 bits. Also, ignore final 32 bits if they are zero. */ - h = caml_hash_mix_uint32(h, (uint32) d); + h = caml_hash_mix_uint32(h, (uint32_t) d); d = d >> 32; if (d == 0 && i + 1 == len) break; - h = caml_hash_mix_uint32(h, (uint32) d); + h = caml_hash_mix_uint32(h, (uint32_t) d); #else h = caml_hash_mix_uint32(h, d); #endif diff --git a/otherlibs/num/num.ml b/otherlibs/num/num.ml index 4ede5ee49..67499e267 100644 --- a/otherlibs/num/num.ml +++ b/otherlibs/num/num.ml @@ -11,8 +11,6 @@ (* *) (***********************************************************************) -(* $Id$ *) - open Int_misc open Nat open Big_int diff --git a/otherlibs/num/num.mli b/otherlibs/num/num.mli index 177333847..6425085e6 100644 --- a/otherlibs/num/num.mli +++ b/otherlibs/num/num.mli @@ -11,8 +11,6 @@ (* *) (***********************************************************************) -(* $Id$ *) - (** Operation on arbitrary-precision numbers. Numbers (type [num]) are arbitrary-precision rational numbers, diff --git a/otherlibs/num/ratio.ml b/otherlibs/num/ratio.ml index fe0170f29..5bb04b647 100644 --- a/otherlibs/num/ratio.ml +++ b/otherlibs/num/ratio.ml @@ -438,7 +438,8 @@ let approx_ratio_fix n r = r.denominator)) in (* Round up and add 1 in front if needed *) let s2 = - if round_futur_last_digit s1 0 (String.length s1) + if round_futur_last_digit (Bytes.unsafe_of_string s1) 0 + (String.length s1) then "1" ^ s1 else s1 in let l2 = String.length s2 - 1 in @@ -447,18 +448,18 @@ let approx_ratio_fix n r = if s2 without last digit is yy with <= n digits: <sign> 0 . 0yy *) if l2 > n then begin - let s = String.make (l2 + 2) '0' in - String.set s 0 (if sign_r = -1 then '-' else '+'); + let s = Bytes.make (l2 + 2) '0' in + Bytes.set s 0 (if sign_r = -1 then '-' else '+'); String.blit s2 0 s 1 (l2 - n); - String.set s (l2 - n + 1) '.'; + Bytes.set s (l2 - n + 1) '.'; String.blit s2 (l2 - n) s (l2 - n + 2) n; - s + Bytes.unsafe_to_string s end else begin - let s = String.make (n + 3) '0' in - String.set s 0 (if sign_r = -1 then '-' else '+'); - String.set s 2 '.'; + let s = Bytes.make (n + 3) '0' in + Bytes.set s 0 (if sign_r = -1 then '-' else '+'); + Bytes.set s 2 '.'; String.blit s2 0 s (n + 3 - l2) l2; - s + Bytes.unsafe_to_string s end end else begin (* Dubious; what is this code supposed to do? *) @@ -468,10 +469,10 @@ let approx_ratio_fix n r = (base_power_big_int 10 (-n) r.denominator)) in let len = succ (String.length s) in - let s' = String.make len '0' in - String.set s' 0 (if sign_r = -1 then '-' else '+'); + let s' = Bytes.make len '0' in + Bytes.set s' 0 (if sign_r = -1 then '-' else '+'); String.blit s 0 s' 1 (pred len); - s' + Bytes.unsafe_to_string s' end (* Number of digits of the decimal representation of an int *) @@ -488,11 +489,8 @@ let approx_ratio_exp n r = else let sign_r = sign_ratio r and i = ref (n + 3) in - if sign_r = 0 - then - let s = String.make (n + 5) '0' in - (String.blit "+0." 0 s 0 3); - (String.blit "e0" 0 s !i 2); s + if sign_r = 0 then + String.concat "" ["+0."; String.make n '0'; "e0"] else let msd = msd_ratio (abs_ratio r) in let k = n - msd in @@ -508,28 +506,29 @@ let approx_ratio_exp n r = 10 k (abs_big_int r.numerator)) r.denominator) in string_of_nat nat) in - if (round_futur_last_digit s 0 (String.length s)) + if round_futur_last_digit (Bytes.unsafe_of_string s) 0 + (String.length s) then let m = num_decimal_digits_int (succ msd) in - let str = String.make (n + m + 4) '0' in + let str = Bytes.make (n + m + 4) '0' in (String.blit (if sign_r = -1 then "-1." else "+1.") 0 str 0 3); - String.set str !i ('e'); + Bytes.set str !i ('e'); incr i; (if m = 0 - then String.set str !i '0' + then Bytes.set str !i '0' else String.blit (string_of_int (succ msd)) 0 str !i m); - str + Bytes.unsafe_to_string str else let m = num_decimal_digits_int (succ msd) and p = n + 3 in - let str = String.make (succ (m + p)) '0' in + let str = Bytes.make (succ (m + p)) '0' in (String.blit (if sign_r = -1 then "-0." else "+0.") 0 str 0 3); (String.blit s 0 str 3 n); - String.set str p 'e'; + Bytes.set str p 'e'; (if m = 0 - then String.set str (succ p) '0' + then Bytes.set str (succ p) '0' else (String.blit (string_of_int (succ msd)) 0 str (succ p) m)); - str + Bytes.unsafe_to_string str (* String approximation of a rational with a fixed number of significant *) (* digits printed *) diff --git a/otherlibs/num/ratio.mli b/otherlibs/num/ratio.mli index 408aea9b4..7c9809f14 100644 --- a/otherlibs/num/ratio.mli +++ b/otherlibs/num/ratio.mli @@ -11,8 +11,6 @@ (* *) (***********************************************************************) -(* $Id$ *) - (** Operation on rational numbers. This module is used to support the implementation of {!Num} and diff --git a/otherlibs/str/.depend b/otherlibs/str/.depend index b0ff35895..5be8377c2 100644 --- a/otherlibs/str/.depend +++ b/otherlibs/str/.depend @@ -1,9 +1,9 @@ strstubs.o: strstubs.c ../../byterun/mlvalues.h \ - ../../byterun/compatibility.h ../../byterun/config.h \ - ../../byterun/../config/m.h ../../byterun/../config/s.h \ - ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \ - ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/minor_gc.h ../../byterun/fail.h + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/../config/m.h ../../byterun/../config/s.h \ + ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \ + ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/minor_gc.h ../../byterun/fail.h str.cmi : str.cmo : str.cmi str.cmx : str.cmi diff --git a/otherlibs/str/str.ml b/otherlibs/str/str.ml index b9b8c1536..ffaea89ba 100644 --- a/otherlibs/str/str.ml +++ b/otherlibs/str/str.ml @@ -25,16 +25,18 @@ let last_chars s n = String.sub s (String.length s - n) n module Charset = struct - type t = string (* of length 32 *) + type t = bytes (* of length 32 *) - (*let empty = String.make 32 '\000'*) - let full = String.make 32 '\255' + (*let empty = Bytes.make 32 '\000'*) + let full = Bytes.make 32 '\255' - let make_empty () = String.make 32 '\000' + let make_empty () = Bytes.make 32 '\000' let add s c = let i = Char.code c in - s.[i lsr 3] <- Char.chr(Char.code s.[i lsr 3] lor (1 lsl (i land 7))) + Bytes.set s (i lsr 3) + (Char.chr (Char.code (Bytes.get s (i lsr 3)) + lor (1 lsl (i land 7)))) let add_range s c1 c2 = for i = Char.code c1 to Char.code c2 do add s (Char.chr i) done @@ -46,23 +48,26 @@ module Charset = let s = make_empty () in add_range s c1 c2; s *) let complement s = - let r = String.create 32 in + let r = Bytes.create 32 in for i = 0 to 31 do - r.[i] <- Char.chr(Char.code s.[i] lxor 0xFF) + Bytes.set r i (Char.chr(Char.code (Bytes.get s i) lxor 0xFF)) done; r let union s1 s2 = - let r = String.create 32 in + let r = Bytes.create 32 in for i = 0 to 31 do - r.[i] <- Char.chr(Char.code s1.[i] lor Char.code s2.[i]) + Bytes.set r i (Char.chr(Char.code (Bytes.get s1 i) + lor Char.code (Bytes.get s2 i))) done; r let disjoint s1 s2 = try for i = 0 to 31 do - if Char.code s1.[i] land Char.code s2.[i] <> 0 then raise Exit + if Char.code (Bytes.get s1 i) land Char.code (Bytes.get s2 i) + <> 0 + then raise Exit done; true with Exit -> @@ -70,7 +75,7 @@ module Charset = let iter fn s = for i = 0 to 31 do - let c = Char.code s.[i] in + let c = Char.code (Bytes.get s i) in if c <> 0 then for j = 0 to 7 do if c land (1 lsl j) <> 0 then fn (Char.chr ((i lsl 3) + j)) @@ -78,8 +83,8 @@ module Charset = done let expand s = - let r = String.make 256 '\000' in - iter (fun c -> r.[Char.code c] <- '\001') s; + let r = Bytes.make 256 '\000' in + iter (fun c -> Bytes.set r (Char.code c) '\001') s; r let fold_case s = @@ -201,14 +206,14 @@ let charclass_of_regexp fold_case re = | CharClass(cl, compl) -> (cl, compl) | _ -> assert false in let cl2 = if fold_case then Charset.fold_case cl1 else cl1 in - if compl then Charset.complement cl2 else cl2 + Bytes.to_string (if compl then Charset.complement cl2 else cl2) (* The case fold table: maps characters to their lowercase equivalent *) let fold_case_table = - let t = String.create 256 in - for i = 0 to 255 do t.[i] <- Char.lowercase(Char.chr i) done; - t + let t = Bytes.create 256 in + for i = 0 to 255 do Bytes.set t i (Char.lowercase(Char.chr i)) done; + Bytes.to_string t module StringMap = Map.Make(struct type t = string let compare (x:t) y = compare x y end) @@ -292,7 +297,7 @@ let compile fold_case re = | CharClass(cl, compl) -> let cl1 = if fold_case then Charset.fold_case cl else cl in let cl2 = if compl then Charset.complement cl1 else cl1 in - emit_instr op_CHARCLASS (cpool_index cl2) + emit_instr op_CHARCLASS (cpool_index (Bytes.to_string cl2)) | Seq rl -> emit_seq_code rl | Alt(r1, r2) -> @@ -412,7 +417,7 @@ let compile fold_case re = let start_pos = if start = Charset.full then -1 - else cpool_index (Charset.expand start') in + else cpool_index (Bytes.to_string (Charset.expand start')) in let constantpool = Array.make !cpoolpos "" in StringMap.iter (fun str idx -> constantpool.(idx) <- str) !cpool; { prog = Array.sub !prog 0 !progpos; @@ -553,16 +558,19 @@ let regexp_case_fold e = compile true (parse e) let quote s = let len = String.length s in - let buf = String.create (2 * len) in + let buf = Bytes.create (2 * len) in let pos = ref 0 in for i = 0 to len - 1 do match s.[i] with '[' | ']' | '*' | '.' | '\\' | '?' | '+' | '^' | '$' as c -> - buf.[!pos] <- '\\'; buf.[!pos + 1] <- c; pos := !pos + 2 + Bytes.set buf !pos '\\'; + Bytes.set buf (!pos + 1) c; + pos := !pos + 2 | c -> - buf.[!pos] <- c; pos := !pos + 1 + Bytes.set buf !pos c; + pos := !pos + 1 done; - String.sub buf 0 !pos + Bytes.sub_string buf 0 !pos let regexp_string s = compile false (String s) diff --git a/otherlibs/systhreads/.depend b/otherlibs/systhreads/.depend index 93b01d687..85add2e59 100644 --- a/otherlibs/systhreads/.depend +++ b/otherlibs/systhreads/.depend @@ -1,14 +1,14 @@ st_stubs.o: st_stubs.c ../../byterun/alloc.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/mlvalues.h \ - ../../byterun/backtrace.h ../../byterun/callback.h \ - ../../byterun/custom.h ../../byterun/fail.h ../../byterun/io.h \ - ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/minor_gc.h ../../byterun/misc.h \ - ../../byterun/mlvalues.h ../../byterun/printexc.h ../../byterun/roots.h \ - ../../byterun/memory.h ../../byterun/signals.h ../../byterun/stacks.h \ - ../../byterun/sys.h threads.h st_posix.h + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/mlvalues.h \ + ../../byterun/backtrace.h ../../byterun/callback.h \ + ../../byterun/custom.h ../../byterun/fail.h ../../byterun/io.h \ + ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/minor_gc.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h ../../byterun/printexc.h ../../byterun/roots.h \ + ../../byterun/memory.h ../../byterun/signals.h ../../byterun/stacks.h \ + ../../byterun/sys.h threads.h st_posix.h condition.cmi : mutex.cmi event.cmi : mutex.cmi : diff --git a/otherlibs/systhreads/Makefile b/otherlibs/systhreads/Makefile index 3da02c260..a08bf34b4 100644 --- a/otherlibs/systhreads/Makefile +++ b/otherlibs/systhreads/Makefile @@ -13,10 +13,13 @@ include ../../config/Makefile -CAMLC=../../ocamlcomp.sh -I ../unix -CAMLOPT=../../ocamlcompopt.sh -I ../unix +ROOTDIR=../.. +CAMLC=$(ROOTDIR)/boot/ocamlrun $(ROOTDIR)/ocamlc -nostdlib \ + -I $(ROOTDIR)/stdlib -I $(ROOTDIR)/otherlibs/unix +CAMLOPT=$(ROOTDIR)/boot/ocamlrun $(ROOTDIR)/ocamlopt -nostdlib \ + -I $(ROOTDIR)/stdlib -I $(ROOTDIR)/otherlibs/unix MKLIB=../../boot/ocamlrun ../../tools/ocamlmklib -COMPFLAGS=-w +33..39 -warn-error A -g -bin-annot +COMPFLAGS=-w +33..39 -warn-error A -g -bin-annot -safe-string BYTECODE_C_OBJS=st_stubs_b.o NATIVECODE_C_OBJS=st_stubs_n.o @@ -69,21 +72,27 @@ partialclean: clean: partialclean rm -f *.o *.a *.so +INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR) +INSTALL_STUBLIBDIR=$(DESTDIR)$(STUBLIBDIR) + install: - if test -f dllthreads.so; then cp dllthreads.so $(STUBLIBDIR)/dllthreads.so; fi - cp libthreads.a $(LIBDIR)/libthreads.a - cd $(LIBDIR); $(RANLIB) libthreads.a - if test -d $(LIBDIR)/threads; then :; else mkdir $(LIBDIR)/threads; fi - cp $(THREAD_OBJS:.cmo=.cmi) threads.cma $(LIBDIR)/threads - rm -f $(LIBDIR)/threads/stdlib.cma - cp thread.mli mutex.mli condition.mli event.mli threadUnix.mli $(LIBDIR) - cp threads.h $(LIBDIR)/caml/threads.h + if test -f dllthreads.so; then \ + cp dllthreads.so $(INSTALL_STUBLIBDIR)/dllthreads.so; fi + cp libthreads.a $(INSTALL_LIBDIR)/libthreads.a + cd $(INSTALL_LIBDIR); $(RANLIB) libthreads.a + if test -d $(INSTALL_LIBDIR)/threads; then :; \ + else mkdir $(INSTALL_LIBDIR)/threads; fi + cp $(THREAD_OBJS:.cmo=.cmi) threads.cma $(INSTALL_LIBDIR)/threads + rm -f $(INSTALL_LIBDIR)/threads/stdlib.cma + cp thread.mli mutex.mli condition.mli event.mli threadUnix.mli \ + $(INSTALL_LIBDIR) + cp threads.h $(INSTALL_LIBDIR)/caml/threads.h installopt: - cp libthreadsnat.a $(LIBDIR)/libthreadsnat.a - cd $(LIBDIR); $(RANLIB) libthreadsnat.a - cp $(THREAD_OBJS:.cmo=.cmx) threads.cmxa threads.a $(LIBDIR)/threads - cd $(LIBDIR)/threads; $(RANLIB) threads.a + cp libthreadsnat.a $(INSTALL_LIBDIR)/libthreadsnat.a + cd $(INSTALL_LIBDIR); $(RANLIB) libthreadsnat.a + cp $(THREAD_OBJS:.cmo=.cmx) threads.cmxa threads.a $(INSTALL_LIBDIR)/threads + cd $(INSTALL_LIBDIR)/threads; $(RANLIB) threads.a .SUFFIXES: .ml .mli .cmo .cmi .cmx diff --git a/otherlibs/systhreads/Makefile.nt b/otherlibs/systhreads/Makefile.nt index 225146cce..341176146 100644 --- a/otherlibs/systhreads/Makefile.nt +++ b/otherlibs/systhreads/Makefile.nt @@ -70,18 +70,21 @@ partialclean: clean: partialclean rm -f *.dll *.$(A) *.$(O) +INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR) +INSTALL_STUBLIBDIR=$(DESTDIR)$(STUBLIBDIR) + install: - cp dllthreads.dll $(STUBLIBDIR)/dllthreads.dll - cp libthreads.$(A) $(LIBDIR)/libthreads.$(A) - mkdir -p $(LIBDIR)/threads - cp $(CMIFILES) threads.cma $(LIBDIR)/threads - rm -f $(LIBDIR)/threads/stdlib.cma - cp threads.h $(LIBDIR)/caml/threads.h + cp dllthreads.dll $(INSTALL_STUBLIBDIR)/dllthreads.dll + cp libthreads.$(A) $(INSTALL_LIBDIR)/libthreads.$(A) + mkdir -p $(INSTALL_LIBDIR)/threads + cp $(CMIFILES) threads.cma $(INSTALL_LIBDIR)/threads + rm -f $(INSTALL_LIBDIR)/threads/stdlib.cma + cp threads.h $(INSTALL_LIBDIR)/caml/threads.h installopt: - cp libthreadsnat.$(A) $(LIBDIR)/libthreadsnat.$(A) - cp $(THREAD_OBJS:.cmo=.cmx) threads.cmxa threads.$(A) $(LIBDIR)/threads - cp threads.cmxs $(LIBDIR)/threads + cp libthreadsnat.$(A) $(INSTALL_LIBDIR)/libthreadsnat.$(A) + cp $(THREAD_OBJS:.cmo=.cmx) threads.cmxa threads.$(A) $(INSTALL_LIBDIR)/threads + cp threads.cmxs $(INSTALL_LIBDIR)/threads .SUFFIXES: .ml .mli .cmo .cmi .cmx diff --git a/otherlibs/systhreads/event.ml b/otherlibs/systhreads/event.ml index 1feac525f..68d8a5b45 100644 --- a/otherlibs/systhreads/event.ml +++ b/otherlibs/systhreads/event.ml @@ -69,7 +69,7 @@ let do_aborts abort_env genev performed = let basic_sync abort_env genev = let performed = ref (-1) in let condition = Condition.create() in - let bev = Array.create (Array.length genev) + let bev = Array.make (Array.length genev) (fst (genev.(0)) performed condition 0) in for i = 1 to Array.length genev - 1 do bev.(i) <- (fst genev.(i)) performed condition i @@ -143,7 +143,7 @@ let sync ev = let basic_poll abort_env genev = let performed = ref (-1) in let condition = Condition.create() in - let bev = Array.create(Array.length genev) + let bev = Array.make(Array.length genev) (fst genev.(0) performed condition 0) in for i = 1 to Array.length genev - 1 do bev.(i) <- fst genev.(i) performed condition i diff --git a/otherlibs/systhreads/threadUnix.ml b/otherlibs/systhreads/threadUnix.ml index 335afcb09..c18f75bb4 100644 --- a/otherlibs/systhreads/threadUnix.ml +++ b/otherlibs/systhreads/threadUnix.ml @@ -26,6 +26,7 @@ let waitpid = Unix.waitpid let system = Unix.system let read = Unix.read let write = Unix.write +let write_substring = Unix.write_substring let select = Unix.select let timed_read fd buff ofs len timeout = @@ -38,6 +39,9 @@ let timed_write fd buff ofs len timeout = then Unix.write fd buff ofs len else raise (Unix_error(ETIMEDOUT, "timed_write", "")) +let timed_write_substring fd buff ofs len timeout = + timed_write fd (Bytes.unsafe_of_string buff) ofs len timeout + let pipe = Unix.pipe let open_process_in = Unix.open_process_in @@ -52,6 +56,8 @@ external connect : file_descr -> sockaddr -> unit = "unix_connect" let recv = Unix.recv let recvfrom = Unix.recvfrom let send = Unix.send +let send_substring = Unix.send_substring let sendto = Unix.sendto +let sendto_substring = Unix.sendto_substring let open_connection = Unix.open_connection diff --git a/otherlibs/systhreads/threadUnix.mli b/otherlibs/systhreads/threadUnix.mli index 63d27335f..cac796b92 100644 --- a/otherlibs/systhreads/threadUnix.mli +++ b/otherlibs/systhreads/threadUnix.mli @@ -30,24 +30,29 @@ val system : string -> Unix.process_status (** {6 Basic input/output} *) -val read : Unix.file_descr -> string -> int -> int -> int -val write : Unix.file_descr -> string -> int -> int -> int +val read : Unix.file_descr -> bytes -> int -> int -> int +val write : Unix.file_descr -> bytes -> int -> int -> int +val write_substring : Unix.file_descr -> string -> int -> int -> int (** {6 Input/output with timeout} *) val timed_read : Unix.file_descr -> - string -> int -> int -> float -> int + bytes -> int -> int -> float -> int (** See {!ThreadUnix.timed_write}. *) val timed_write : Unix.file_descr -> - string -> int -> int -> float -> int + bytes -> int -> int -> float -> int (** Behave as {!ThreadUnix.read} and {!ThreadUnix.write}, except that [Unix_error(ETIMEDOUT,_,_)] is raised if no data is available for reading or ready for writing after [d] seconds. The delay [d] is given in the fifth argument, in seconds. *) +val timed_write_substring : + Unix.file_descr -> string -> int -> int -> float -> int +(** See {!ThreadUnix.timed_write}. *) + (** {6 Polling} *) val select : @@ -72,12 +77,16 @@ val socket : Unix.socket_domain -> Unix.socket_type -> int -> Unix.file_descr val accept : Unix.file_descr -> Unix.file_descr * Unix.sockaddr val connect : Unix.file_descr -> Unix.sockaddr -> unit -val recv : Unix.file_descr -> string -> +val recv : Unix.file_descr -> bytes -> int -> int -> Unix.msg_flag list -> int -val recvfrom : Unix.file_descr -> string -> int -> int -> +val recvfrom : Unix.file_descr -> bytes -> int -> int -> Unix.msg_flag list -> int * Unix.sockaddr -val send : Unix.file_descr -> string -> int -> int -> +val send : Unix.file_descr -> bytes -> int -> int -> Unix.msg_flag list -> int -val sendto : Unix.file_descr -> string -> int -> int -> +val send_substring : Unix.file_descr -> string -> int -> int -> + Unix.msg_flag list -> int +val sendto : Unix.file_descr -> bytes -> int -> int -> + Unix.msg_flag list -> Unix.sockaddr -> int +val sendto_substring : Unix.file_descr -> string -> int -> int -> Unix.msg_flag list -> Unix.sockaddr -> int val open_connection : Unix.sockaddr -> in_channel * out_channel diff --git a/otherlibs/threads/.depend b/otherlibs/threads/.depend index 091feb639..3a6c7f02b 100644 --- a/otherlibs/threads/.depend +++ b/otherlibs/threads/.depend @@ -1,35 +1,32 @@ scheduler.o: scheduler.c ../../byterun/alloc.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/mlvalues.h \ - ../../byterun/backtrace.h ../../byterun/callback.h \ - ../../byterun/config.h ../../byterun/fail.h ../../byterun/io.h \ - ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/minor_gc.h ../../byterun/misc.h \ - ../../byterun/mlvalues.h ../../byterun/printexc.h ../../byterun/roots.h \ - ../../byterun/memory.h ../../byterun/signals.h ../../byterun/stacks.h \ - ../../byterun/sys.h + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/mlvalues.h \ + ../../byterun/backtrace.h ../../byterun/callback.h \ + ../../byterun/config.h ../../byterun/fail.h ../../byterun/io.h \ + ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/minor_gc.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h ../../byterun/printexc.h ../../byterun/roots.h \ + ../../byterun/memory.h ../../byterun/signals.h ../../byterun/stacks.h \ + ../../byterun/sys.h condition.cmi : mutex.cmi event.cmi : -marshal.cmi : mutex.cmi : -pervasives.cmi : -thread.cmi : unix.cmi -threadUnix.cmi : unix.cmi -unix.cmi : +thread.cmi : unix.cmo +threadUnix.cmi : unix.cmo condition.cmo : thread.cmi mutex.cmi condition.cmi condition.cmx : thread.cmx mutex.cmx condition.cmi event.cmo : mutex.cmi condition.cmi event.cmi event.cmx : mutex.cmx condition.cmx event.cmi -marshal.cmo : pervasives.cmi marshal.cmi -marshal.cmx : pervasives.cmx marshal.cmi +marshal.cmo : +marshal.cmx : mutex.cmo : thread.cmi mutex.cmi mutex.cmx : thread.cmx mutex.cmi -pervasives.cmo : unix.cmi pervasives.cmi -pervasives.cmx : unix.cmx pervasives.cmi -thread.cmo : unix.cmi thread.cmi +pervasives.cmo : unix.cmo +pervasives.cmx : unix.cmx +thread.cmo : unix.cmo thread.cmi thread.cmx : unix.cmx thread.cmi -threadUnix.cmo : unix.cmi thread.cmi threadUnix.cmi +threadUnix.cmo : unix.cmo thread.cmi threadUnix.cmi threadUnix.cmx : unix.cmx thread.cmx threadUnix.cmi -unix.cmo : unix.cmi -unix.cmx : unix.cmi +unix.cmo : +unix.cmx : diff --git a/otherlibs/threads/Makefile b/otherlibs/threads/Makefile index 3aa6c2acf..1c4434f5b 100644 --- a/otherlibs/threads/Makefile +++ b/otherlibs/threads/Makefile @@ -15,9 +15,11 @@ include ../../config/Makefile CC=$(BYTECC) CFLAGS=-I../../byterun -O $(BYTECCCOMPOPTS) $(SHAREDCCCOMPOPTS) -g -CAMLC=../../ocamlcomp.sh -I ../unix +ROOTDIR=../.. +CAMLC=$(ROOTDIR)/boot/ocamlrun $(ROOTDIR)/ocamlc -nostdlib \ + -I $(ROOTDIR)/stdlib -I $(ROOTDIR)/otherlibs/unix MKLIB=../../boot/ocamlrun ../../tools/ocamlmklib -COMPFLAGS=-w +33..39 -warn-error A -bin-annot +COMPFLAGS=-w +33..39 -warn-error A -bin-annot -safe-string C_OBJS=scheduler.o @@ -25,7 +27,7 @@ CAML_OBJS=thread.cmo mutex.cmo condition.cmo event.cmo threadUnix.cmo LIB=../../stdlib -LIB_OBJS=pervasives.cmo \ +LIB_OBJS=$(LIB)/camlinternalFormatBasics.cmo pervasives.cmo \ $(LIB)/array.cmo $(LIB)/list.cmo $(LIB)/char.cmo $(LIB)/string.cmo \ $(LIB)/sys.cmo $(LIB)/sort.cmo marshal.cmo $(LIB)/obj.cmo \ $(LIB)/int32.cmo $(LIB)/int64.cmo $(LIB)/nativeint.cmo \ @@ -95,15 +97,18 @@ clean: partialclean rm -f libvmthreads.a dllvmthreads.so *.o rm -f pervasives.mli marshal.mli unix.mli +INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR) +INSTALL_STUBLIBDIR=$(DESTDIR)$(STUBLIBDIR) + install: - if test -f dllvmthreads.so; then cp dllvmthreads.so $(STUBLIBDIR)/.; fi - mkdir -p $(LIBDIR)/vmthreads - cp libvmthreads.a $(LIBDIR)/vmthreads/libvmthreads.a - cd $(LIBDIR)/vmthreads; $(RANLIB) libvmthreads.a + if test -f dllvmthreads.so; then cp dllvmthreads.so $(INSTALL_STUBLIBDIR)/.; fi + mkdir -p $(INSTALL_LIBDIR)/vmthreads + cp libvmthreads.a $(INSTALL_LIBDIR)/vmthreads/libvmthreads.a + cd $(INSTALL_LIBDIR)/vmthreads; $(RANLIB) libvmthreads.a cp thread.cmi mutex.cmi condition.cmi event.cmi threadUnix.cmi \ - threads.cma stdlib.cma unix.cma $(LIBDIR)/vmthreads + threads.cma stdlib.cma unix.cma $(INSTALL_LIBDIR)/vmthreads cp thread.mli mutex.mli condition.mli event.mli threadUnix.mli \ - $(LIBDIR)/vmthreads + $(INSTALL_LIBDIR)/vmthreads installopt: @@ -115,9 +120,6 @@ installopt: .ml.cmo: $(CAMLC) -c $(COMPFLAGS) $< -.ml.cmx: - $(CAMLOPT) -c $(COMPFLAGS) $< - depend: gcc -MM $(CFLAGS) *.c > .depend ../../boot/ocamlrun ../../tools/ocamldep *.mli *.ml >> .depend diff --git a/otherlibs/threads/event.ml b/otherlibs/threads/event.ml index 1feac525f..68d8a5b45 100644 --- a/otherlibs/threads/event.ml +++ b/otherlibs/threads/event.ml @@ -69,7 +69,7 @@ let do_aborts abort_env genev performed = let basic_sync abort_env genev = let performed = ref (-1) in let condition = Condition.create() in - let bev = Array.create (Array.length genev) + let bev = Array.make (Array.length genev) (fst (genev.(0)) performed condition 0) in for i = 1 to Array.length genev - 1 do bev.(i) <- (fst genev.(i)) performed condition i @@ -143,7 +143,7 @@ let sync ev = let basic_poll abort_env genev = let performed = ref (-1) in let condition = Condition.create() in - let bev = Array.create(Array.length genev) + let bev = Array.make(Array.length genev) (fst genev.(0) performed condition 0) in for i = 1 to Array.length genev - 1 do bev.(i) <- fst genev.(i) performed condition i diff --git a/otherlibs/threads/marshal.ml b/otherlibs/threads/marshal.ml index c71ca83d0..005e96437 100644 --- a/otherlibs/threads/marshal.ml +++ b/otherlibs/threads/marshal.ml @@ -16,6 +16,9 @@ type extern_flags = | Closures | Compat_32 +external to_bytes: 'a -> extern_flags list -> bytes + = "caml_output_value_to_string" + external to_string: 'a -> extern_flags list -> string = "caml_output_value_to_string" @@ -23,35 +26,34 @@ let to_channel chan v flags = output_string chan (to_string v flags) external to_buffer_unsafe: - string -> int -> int -> 'a -> extern_flags list -> int + bytes -> int -> int -> 'a -> extern_flags list -> int = "caml_output_value_to_buffer" let to_buffer buff ofs len v flags = - if ofs < 0 || len < 0 || ofs + len > String.length buff + if ofs < 0 || len < 0 || ofs + len > Bytes.length buff then invalid_arg "Marshal.to_buffer: substring out of bounds" else to_buffer_unsafe buff ofs len v flags -let to_buffer' ~buf ~pos ~len v ~mode = to_buffer buf pos len v mode - -external from_string_unsafe: string -> int -> 'a +external from_channel: in_channel -> 'a = "caml_input_value" +external from_bytes_unsafe: bytes -> int -> 'a = "caml_input_value_from_string" -external data_size_unsafe: string -> int -> int = "caml_marshal_data_size" +external data_size_unsafe: bytes -> int -> int = "caml_marshal_data_size" let header_size = 20 let data_size buff ofs = - if ofs < 0 || ofs > String.length buff - header_size + if ofs < 0 || ofs > Bytes.length buff - header_size then invalid_arg "Marshal.data_size" else data_size_unsafe buff ofs let total_size buff ofs = header_size + data_size buff ofs -let from_string buff ofs = - if ofs < 0 || ofs > String.length buff - header_size - then invalid_arg "Marshal.from_size" +let from_bytes buff ofs = + if ofs < 0 || ofs > Bytes.length buff - header_size + then invalid_arg "Marshal.from_bytes" else begin let len = data_size_unsafe buff ofs in - if ofs > String.length buff - (header_size + len) - then invalid_arg "Marshal.from_string" - else from_string_unsafe buff ofs + if ofs > Bytes.length buff - (header_size + len) + then invalid_arg "Marshal.from_bytes" + else from_bytes_unsafe buff ofs end -let from_channel = Pervasives.input_value +let from_string buff ofs = from_bytes (Bytes.unsafe_of_string buff) ofs diff --git a/otherlibs/threads/pervasives.ml b/otherlibs/threads/pervasives.ml index 402e01b87..e6f1cc16b 100644 --- a/otherlibs/threads/pervasives.ml +++ b/otherlibs/threads/pervasives.ml @@ -27,6 +27,7 @@ let () = register_named_value "Pervasives.array_bound_error" (Invalid_argument "index out of bounds") + external raise : exn -> 'a = "%raise" external raise_notrace : exn -> 'a = "%raise_notrace" @@ -37,68 +38,80 @@ exception Exit (* Composition operators *) -external (|>) : 'a -> ('a -> 'b) -> 'b = "%revapply" +external ( |> ) : 'a -> ('a -> 'b) -> 'b = "%revapply" external ( @@ ) : ('a -> 'b) -> 'a -> 'b = "%apply" +(* Debugging *) + +external __LOC__ : string = "%loc_LOC" +external __FILE__ : string = "%loc_FILE" +external __LINE__ : int = "%loc_LINE" +external __MODULE__ : string = "%loc_MODULE" +external __POS__ : string * int * int * int = "%loc_POS" + +external __LOC_OF__ : 'a -> string * 'a = "%loc_LOC" +external __LINE_OF__ : 'a -> int * 'a = "%loc_LINE" +external __POS_OF__ : 'a -> (string * int * int * int) * 'a = "%loc_POS" + (* Comparisons *) -external (=) : 'a -> 'a -> bool = "%equal" -external (<>) : 'a -> 'a -> bool = "%notequal" -external (<) : 'a -> 'a -> bool = "%lessthan" -external (>) : 'a -> 'a -> bool = "%greaterthan" -external (<=) : 'a -> 'a -> bool = "%lessequal" -external (>=) : 'a -> 'a -> bool = "%greaterequal" -external compare: 'a -> 'a -> int = "%compare" +external ( = ) : 'a -> 'a -> bool = "%equal" +external ( <> ) : 'a -> 'a -> bool = "%notequal" +external ( < ) : 'a -> 'a -> bool = "%lessthan" +external ( > ) : 'a -> 'a -> bool = "%greaterthan" +external ( <= ) : 'a -> 'a -> bool = "%lessequal" +external ( >= ) : 'a -> 'a -> bool = "%greaterequal" +external compare : 'a -> 'a -> int = "%compare" let min x y = if x <= y then x else y let max x y = if x >= y then x else y -external (==) : 'a -> 'a -> bool = "%eq" -external (!=) : 'a -> 'a -> bool = "%noteq" +external ( == ) : 'a -> 'a -> bool = "%eq" +external ( != ) : 'a -> 'a -> bool = "%noteq" (* Boolean operations *) external not : bool -> bool = "%boolnot" -external (&) : bool -> bool -> bool = "%sequand" -external (&&) : bool -> bool -> bool = "%sequand" -external (or) : bool -> bool -> bool = "%sequor" -external (||) : bool -> bool -> bool = "%sequor" +external ( & ) : bool -> bool -> bool = "%sequand" +external ( && ) : bool -> bool -> bool = "%sequand" +external ( or ) : bool -> bool -> bool = "%sequor" +external ( || ) : bool -> bool -> bool = "%sequor" (* Integer operations *) -external (~-) : int -> int = "%negint" -external (~+) : int -> int = "%identity" +external ( ~- ) : int -> int = "%negint" +external ( ~+ ) : int -> int = "%identity" external succ : int -> int = "%succint" external pred : int -> int = "%predint" -external (+) : int -> int -> int = "%addint" -external (-) : int -> int -> int = "%subint" +external ( + ) : int -> int -> int = "%addint" +external ( - ) : int -> int -> int = "%subint" external ( * ) : int -> int -> int = "%mulint" -external (/) : int -> int -> int = "%divint" -external (mod) : int -> int -> int = "%modint" +external ( / ) : int -> int -> int = "%divint" +external ( mod ) : int -> int -> int = "%modint" let abs x = if x >= 0 then x else -x -external (land) : int -> int -> int = "%andint" -external (lor) : int -> int -> int = "%orint" -external (lxor) : int -> int -> int = "%xorint" +external ( land ) : int -> int -> int = "%andint" +external ( lor ) : int -> int -> int = "%orint" +external ( lxor ) : int -> int -> int = "%xorint" let lnot x = x lxor (-1) -external (lsl) : int -> int -> int = "%lslint" -external (lsr) : int -> int -> int = "%lsrint" -external (asr) : int -> int -> int = "%asrint" +external ( lsl ) : int -> int -> int = "%lslint" +external ( lsr ) : int -> int -> int = "%lsrint" +external ( asr ) : int -> int -> int = "%asrint" -let min_int = 1 lsl (if 1 lsl 31 = 0 then 30 else 62) -let max_int = min_int - 1 +let max_int = (-1) lsr 1 +let min_int = max_int + 1 (* Floating-point operations *) -external (~-.) : float -> float = "%negfloat" -external (~+.) : float -> float = "%identity" -external (+.) : float -> float -> float = "%addfloat" -external (-.) : float -> float -> float = "%subfloat" +external ( ~-. ) : float -> float = "%negfloat" +external ( ~+. ) : float -> float = "%identity" +external ( +. ) : float -> float -> float = "%addfloat" +external ( -. ) : float -> float -> float = "%subfloat" external ( *. ) : float -> float -> float = "%mulfloat" -external (/.) : float -> float -> float = "%divfloat" +external ( /. ) : float -> float -> float = "%divfloat" external ( ** ) : float -> float -> float = "caml_power_float" "pow" "float" external exp : float -> float = "caml_exp_float" "exp" "float" external expm1 : float -> float = "caml_expm1_float" "caml_expm1" "float" @@ -107,7 +120,7 @@ external asin : float -> float = "caml_asin_float" "asin" "float" external atan : float -> float = "caml_atan_float" "atan" "float" external atan2 : float -> float -> float = "caml_atan2_float" "atan2" "float" external hypot : float -> float -> float - = "caml_hypot_float" "caml_hypot" "float" + = "caml_hypot_float" "caml_hypot" "float" external cos : float -> float = "caml_cos_float" "cos" "float" external cosh : float -> float = "caml_cosh_float" "cosh" "float" external log : float -> float = "caml_log_float" "log" "float" @@ -122,7 +135,7 @@ external ceil : float -> float = "caml_ceil_float" "ceil" "float" external floor : float -> float = "caml_floor_float" "floor" "float" external abs_float : float -> float = "%absfloat" external copysign : float -> float -> float - = "caml_copysign_float" "caml_copysign" "float" + = "caml_copysign_float" "caml_copysign" "float" external mod_float : float -> float -> float = "caml_fmod_float" "fmod" "float" external frexp : float -> float * int = "caml_frexp_float" external ldexp : float -> int -> float = "caml_ldexp_float" @@ -151,21 +164,26 @@ type fpclass = | FP_zero | FP_infinite | FP_nan -external classify_float: float -> fpclass = "caml_classify_float" +external classify_float : float -> fpclass = "caml_classify_float" -(* String operations -- more in module String *) +(* String and byte sequence operations -- more in modules String and Bytes *) external string_length : string -> int = "%string_length" -external string_create: int -> string = "caml_create_string" -external string_blit : string -> int -> string -> int -> int -> unit +external bytes_length : bytes -> int = "%string_length" +external bytes_create : int -> bytes = "caml_create_string" +external string_blit : string -> int -> bytes -> int -> int -> unit = "caml_blit_string" "noalloc" +external bytes_blit : bytes -> int -> bytes -> int -> int -> unit + = "caml_blit_string" "noalloc" +external bytes_unsafe_to_string : bytes -> string = "%identity" +external bytes_unsafe_of_string : string -> bytes = "%identity" -let (^) s1 s2 = +let ( ^ ) s1 s2 = let l1 = string_length s1 and l2 = string_length s2 in - let s = string_create (l1 + l2) in + let s = bytes_create (l1 + l2) in string_blit s1 0 s 0 l1; string_blit s2 0 s l1 l2; - s + bytes_unsafe_to_string s (* Character operations -- more in module Char *) @@ -185,17 +203,17 @@ external snd : 'a * 'b -> 'b = "%field1" (* References *) -type 'a ref = { mutable contents: 'a } -external ref: 'a -> 'a ref = "%makemutable" -external (!): 'a ref -> 'a = "%field0" -external (:=): 'a ref -> 'a -> unit = "%setfield0" -external incr: int ref -> unit = "%incr" -external decr: int ref -> unit = "%decr" +type 'a ref = { mutable contents : 'a } +external ref : 'a -> 'a ref = "%makemutable" +external ( ! ) : 'a ref -> 'a = "%field0" +external ( := ) : 'a ref -> 'a -> unit = "%setfield0" +external incr : int ref -> unit = "%incr" +external decr : int ref -> unit = "%decr" (* String conversion functions *) -external format_int: string -> int -> string = "caml_format_int" -external format_float: string -> float -> string = "caml_format_float" +external format_int : string -> int -> string = "caml_format_int" +external format_float : string -> float -> string = "caml_format_float" let string_of_bool b = if b then "true" else "false" @@ -208,13 +226,14 @@ let string_of_int n = format_int "%d" n external int_of_string : string -> int = "caml_int_of_string" +external string_get : string -> int -> char = "%string_safe_get" let valid_float_lexem s = let l = string_length s in let rec loop i = if i >= l then s ^ "." else - match s.[i] with - | '0' .. '9' | '-' -> loop (i+1) + match string_get s i with + | '0' .. '9' | '-' -> loop (i + 1) | _ -> s in loop 0 @@ -226,7 +245,7 @@ external float_of_string : string -> float = "caml_float_of_string" (* List operations -- more in module List *) -let rec (@) l1 l2 = +let rec ( @ ) l1 l2 = match l1 with [] -> l2 | hd :: tl -> hd :: (tl @ l2) @@ -236,8 +255,9 @@ let rec (@) l1 l2 = type in_channel type out_channel -external open_descriptor_out: int -> out_channel = "caml_ml_open_descriptor_out" -external open_descriptor_in: int -> in_channel = "caml_ml_open_descriptor_in" +external open_descriptor_out : int -> out_channel + = "caml_ml_open_descriptor_out" +external open_descriptor_in : int -> in_channel = "caml_ml_open_descriptor_in" let stdin = open_descriptor_in 0 let stdout = open_descriptor_out 1 @@ -267,7 +287,7 @@ type open_flag = | Open_creat | Open_trunc | Open_excl | Open_binary | Open_text | Open_nonblock -external open_desc: string -> open_flag list -> int -> int = "caml_sys_open" +external open_desc : string -> open_flag list -> int -> int = "caml_sys_open" let open_out_gen mode perm name = open_descriptor_out(open_desc name mode perm) @@ -303,7 +323,7 @@ let flush_all () = iter l in iter (out_channels_list ()) -external unsafe_output_partial : out_channel -> string -> int -> int -> int +external unsafe_output_partial : out_channel -> bytes -> int -> int -> int = "caml_ml_output_partial" let rec unsafe_output oc buf pos len = @@ -327,15 +347,19 @@ let rec output_char oc c = with Sys_blocked_io -> wait_outchan oc 1; output_char oc c +let output_bytes oc s = + unsafe_output oc s 0 (bytes_length s) + let output_string oc s = - unsafe_output oc s 0 (string_length s) + unsafe_output oc (bytes_unsafe_of_string s) 0 (string_length s) let output oc s ofs len = - if ofs < 0 || len < 0 || ofs > string_length s - len + if ofs < 0 || len < 0 || ofs > bytes_length s - len then invalid_arg "output" else unsafe_output oc s ofs len -let output' oc ~buf ~pos ~len = output oc buf pos len +let output_substring oc s ofs len = + output oc (bytes_unsafe_of_string s) ofs len let rec output_byte oc b = try @@ -389,7 +413,7 @@ let rec input_char ic = with Sys_blocked_io -> wait_inchan ic; input_char ic -external unsafe_input_blocking : in_channel -> string -> int -> int -> int +external unsafe_input_blocking : in_channel -> bytes -> int -> int -> int = "caml_ml_input" let rec unsafe_input ic s ofs len = @@ -399,7 +423,7 @@ let rec unsafe_input ic s ofs len = wait_inchan ic; unsafe_input ic s ofs len let input ic s ofs len = - if ofs < 0 || len < 0 || ofs > string_length s - len + if ofs < 0 || len < 0 || ofs > bytes_length s - len then invalid_arg "input" else unsafe_input ic s ofs len @@ -408,35 +432,42 @@ let rec unsafe_really_input ic s ofs len = let r = unsafe_input ic s ofs len in if r = 0 then raise End_of_file - else unsafe_really_input ic s (ofs+r) (len-r) + else unsafe_really_input ic s (ofs + r) (len - r) end let really_input ic s ofs len = - if ofs < 0 || len < 0 || ofs > string_length s - len + if ofs < 0 || len < 0 || ofs > bytes_length s - len then invalid_arg "really_input" else unsafe_really_input ic s ofs len +let really_input_string ic len = + let s = bytes_create len in + really_input ic s 0 len; + bytes_unsafe_to_string s + +external bytes_set : bytes -> int -> char -> unit = "%string_safe_set" + let input_line ic = - let buf = ref (string_create 128) in + let buf = ref (bytes_create 128) in let pos = ref 0 in begin try while true do - if !pos = string_length !buf then begin - let newbuf = string_create (2 * !pos) in - string_blit !buf 0 newbuf 0 !pos; + if !pos = bytes_length !buf then begin + let newbuf = bytes_create (2 * !pos) in + bytes_blit !buf 0 newbuf 0 !pos; buf := newbuf end; let c = input_char ic in if c = '\n' then raise Exit; - !buf.[!pos] <- c; + bytes_set !buf !pos c; incr pos done with Exit -> () | End_of_file -> if !pos = 0 then raise End_of_file end; - let res = string_create !pos in - string_blit !buf 0 res 0 !pos; - res + let res = bytes_create !pos in + bytes_blit !buf 0 res 0 !pos; + bytes_unsafe_to_string res let rec input_byte ic = try @@ -452,15 +483,15 @@ let input_binary_int ic = let b4 = input_byte ic in (n1 lsl 24) + (b2 lsl 16) + (b3 lsl 8) + b4 -external unmarshal : string -> int -> 'a = "caml_input_value_from_string" -external marshal_data_size : string -> int -> int = "caml_marshal_data_size" +external unmarshal : bytes -> int -> 'a = "caml_input_value_from_string" +external marshal_data_size : bytes -> int -> int = "caml_marshal_data_size" let input_value ic = - let header = string_create 20 in + let header = bytes_create 20 in really_input ic header 0 20; let bsize = marshal_data_size header 0 in - let buffer = string_create (20 + bsize) in - string_blit header 0 buffer 0 20; + let buffer = bytes_create (20 + bsize) in + bytes_blit header 0 buffer 0 20; really_input ic buffer 20 bsize; unmarshal buffer 0 @@ -476,6 +507,7 @@ external set_binary_mode_in : in_channel -> bool -> unit let print_char c = output_char stdout c let print_string s = output_string stdout s +let print_bytes s = output_bytes stdout s let print_int i = output_string stdout (string_of_int i) let print_float f = output_string stdout (string_of_float f) let print_endline s = @@ -486,6 +518,7 @@ let print_newline () = output_char stdout '\n'; flush stdout let prerr_char c = output_char stderr c let prerr_string s = output_string stderr s +let prerr_bytes s = output_bytes stderr s let prerr_int i = output_string stderr (string_of_int i) let prerr_float f = output_string stderr (string_of_float f) let prerr_endline s = @@ -512,33 +545,25 @@ module LargeFile = end (* Formats *) + +type ('a, 'b, 'c, 'd, 'e, 'f) format6 + = ('a, 'b, 'c, 'd, 'e, 'f) CamlinternalFormatBasics.format6 + = Format of ('a, 'b, 'c, 'd, 'e, 'f) CamlinternalFormatBasics.fmt + * string + type ('a, 'b, 'c, 'd) format4 = ('a, 'b, 'c, 'c, 'c, 'd) format6 type ('a, 'b, 'c) format = ('a, 'b, 'c, 'c) format4 +let string_of_format (Format (fmt, str)) = str + external format_of_string : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> ('a, 'b, 'c, 'd, 'e, 'f) format6 = "%identity" -external format_to_string : - ('a, 'b, 'c, 'd, 'e, 'f) format6 -> string = "%identity" -external string_to_format : - string -> ('a, 'b, 'c, 'd, 'e, 'f) format6 = "%identity" - -let (( ^^ ) : - ('a, 'b, 'c, 'd, 'e, 'f) format6 -> - ('f, 'b, 'c, 'e, 'g, 'h) format6 -> - ('a, 'b, 'c, 'd, 'g, 'h) format6) = - fun fmt1 fmt2 -> - string_to_format (format_to_string fmt1 ^ "%," ^ format_to_string fmt2) -;; - -let string_of_format fmt = - let s = format_to_string fmt in - let l = string_length s in - let r = string_create l in - string_blit s 0 r 0 l; - r +let (^^) (Format (fmt1, str1)) (Format (fmt2, str2)) = + Format (CamlinternalFormatBasics.concat_fmt fmt1 fmt2, + str1 ^ "%," ^ str2) (* Miscellaneous *) diff --git a/otherlibs/threads/threadUnix.ml b/otherlibs/threads/threadUnix.ml index fe5ef4fdf..c086c1f55 100644 --- a/otherlibs/threads/threadUnix.ml +++ b/otherlibs/threads/threadUnix.ml @@ -22,6 +22,8 @@ let system = Unix.system let read = Unix.read let write = Unix.write let single_write = Unix.single_write +let write_substring = Unix.write_substring +let single_write_substring = Unix.single_write_substring let select = Unix.select let pipe = Unix.pipe let open_process_in = Unix.open_process_in @@ -36,7 +38,9 @@ let connect = Unix.connect let recv = Unix.recv let recvfrom = Unix.recvfrom let send = Unix.send +let send_substring = Unix.send_substring let sendto = Unix.sendto +let sendto_substring = Unix.sendto_substring let open_connection = Unix.open_connection let establish_server = Unix.establish_server @@ -57,3 +61,6 @@ let rec timed_write fd buff ofs len timeout = timed_write fd buff ofs len timeout end else raise (Unix_error(ETIMEDOUT, "timed_write", "")) + +let timed_write_substring fd buff ofs len timeout = + timed_write fd (Bytes.unsafe_of_string buff) ofs len timeout diff --git a/otherlibs/threads/threadUnix.mli b/otherlibs/threads/threadUnix.mli index 4ebe28f4f..52862f98a 100644 --- a/otherlibs/threads/threadUnix.mli +++ b/otherlibs/threads/threadUnix.mli @@ -30,21 +30,27 @@ val system : string -> Unix.process_status (** {6 Basic input/output} *) -val read : Unix.file_descr -> string -> int -> int -> int -val write : Unix.file_descr -> string -> int -> int -> int -val single_write : Unix.file_descr -> string -> int -> int -> int +val read : Unix.file_descr -> bytes -> int -> int -> int +val write : Unix.file_descr -> bytes -> int -> int -> int +val single_write : Unix.file_descr -> bytes -> int -> int -> int +val write_substring : Unix.file_descr -> string -> int -> int -> int +val single_write_substring : Unix.file_descr -> string -> int -> int -> int (** {6 Input/output with timeout} *) -val timed_read : Unix.file_descr -> string -> int -> int -> float -> int +val timed_read : Unix.file_descr -> bytes -> int -> int -> float -> int (** See {!ThreadUnix.timed_write}. *) -val timed_write : Unix.file_descr -> string -> int -> int -> float -> int +val timed_write : Unix.file_descr -> bytes -> int -> int -> float -> int (** Behave as {!ThreadUnix.read} and {!ThreadUnix.write}, except that [Unix_error(ETIMEDOUT,_,_)] is raised if no data is available for reading or ready for writing after [d] seconds. The delay [d] is given in the fifth argument, in seconds. *) +val timed_write_substring : + Unix.file_descr -> string -> int -> int -> float -> int +(** See {!ThreadUnix.timed_write}. *) + (** {6 Polling} *) val select : @@ -74,13 +80,18 @@ val socketpair : val accept : Unix.file_descr -> Unix.file_descr * Unix.sockaddr val connect : Unix.file_descr -> Unix.sockaddr -> unit val recv : - Unix.file_descr -> string -> int -> int -> Unix.msg_flag list -> int + Unix.file_descr -> bytes -> int -> int -> Unix.msg_flag list -> int val recvfrom : - Unix.file_descr -> string -> int -> int -> Unix.msg_flag list -> + Unix.file_descr -> bytes -> int -> int -> Unix.msg_flag list -> int * Unix.sockaddr val send : + Unix.file_descr -> bytes -> int -> int -> Unix.msg_flag list -> int +val send_substring : Unix.file_descr -> string -> int -> int -> Unix.msg_flag list -> int val sendto : + Unix.file_descr -> bytes -> int -> int -> Unix.msg_flag list -> + Unix.sockaddr -> int +val sendto_substring : Unix.file_descr -> string -> int -> int -> Unix.msg_flag list -> Unix.sockaddr -> int val open_connection : Unix.sockaddr -> in_channel * out_channel diff --git a/otherlibs/threads/unix.ml b/otherlibs/threads/unix.ml index 80ea7aed6..a397ec404 100644 --- a/otherlibs/threads/unix.ml +++ b/otherlibs/threads/unix.ml @@ -205,15 +205,15 @@ external openfile : string -> open_flag list -> file_perm -> file_descr = "unix_open" external close : file_descr -> unit = "unix_close" -external unsafe_read : file_descr -> string -> int -> int -> int = "unix_read" -external unsafe_write : file_descr -> string -> int -> int -> int +external unsafe_read : file_descr -> bytes -> int -> int -> int = "unix_read" +external unsafe_write : file_descr -> bytes -> int -> int -> int = "unix_write" -external unsafe_single_write : file_descr -> string -> int -> int -> int +external unsafe_single_write : file_descr -> bytes -> int -> int -> int = "unix_single_write" let rec read fd buf ofs len = try - if ofs < 0 || len < 0 || ofs > String.length buf - len + if ofs < 0 || len < 0 || ofs > Bytes.length buf - len then invalid_arg "Unix.read" else unsafe_read fd buf ofs len with Unix_error((EAGAIN | EWOULDBLOCK), _, _) -> @@ -221,7 +221,7 @@ let rec read fd buf ofs len = let rec write fd buf ofs len = try - if ofs < 0 || len < 0 || ofs > String.length buf - len + if ofs < 0 || len < 0 || ofs > Bytes.length buf - len then invalid_arg "Unix.write" else unsafe_write fd buf ofs len with Unix_error((EAGAIN | EWOULDBLOCK), _, _) -> @@ -229,12 +229,18 @@ let rec write fd buf ofs len = let rec single_write fd buf ofs len = try - if ofs < 0 || len < 0 || ofs > String.length buf - len - then invalid_arg "Unix.partial_write" + if ofs < 0 || len < 0 || ofs > Bytes.length buf - len + then invalid_arg "Unix.single_write" else unsafe_single_write fd buf ofs len with Unix_error((EAGAIN | EWOULDBLOCK), _, _) -> wait_write fd; single_write fd buf ofs len +let write_substring fd buf ofs len = + write fd (Bytes.unsafe_of_string buf) ofs len + +let single_write_substring fd buf ofs len = + single_write fd (Bytes.unsafe_of_string buf) ofs len + external in_channel_of_descr : file_descr -> in_channel = "caml_ml_open_descriptor_in" external out_channel_of_descr : file_descr -> out_channel @@ -591,21 +597,21 @@ let connect s addr = ignore(getpeername s) external unsafe_recv : - file_descr -> string -> int -> int -> msg_flag list -> int + file_descr -> bytes -> int -> int -> msg_flag list -> int = "unix_recv" external unsafe_recvfrom : - file_descr -> string -> int -> int -> msg_flag list -> int * sockaddr + file_descr -> bytes -> int -> int -> msg_flag list -> int * sockaddr = "unix_recvfrom" external unsafe_send : - file_descr -> string -> int -> int -> msg_flag list -> int + file_descr -> bytes -> int -> int -> msg_flag list -> int = "unix_send" external unsafe_sendto : - file_descr -> string -> int -> int -> msg_flag list -> sockaddr -> int + file_descr -> bytes -> int -> int -> msg_flag list -> sockaddr -> int = "unix_sendto" "unix_sendto_native" let rec recv fd buf ofs len flags = try - if ofs < 0 || len < 0 || ofs > String.length buf - len + if ofs < 0 || len < 0 || ofs > Bytes.length buf - len then invalid_arg "Unix.recv" else unsafe_recv fd buf ofs len flags with Unix_error((EAGAIN | EWOULDBLOCK), _, _) -> @@ -613,7 +619,7 @@ let rec recv fd buf ofs len flags = let rec recvfrom fd buf ofs len flags = try - if ofs < 0 || len < 0 || ofs > String.length buf - len + if ofs < 0 || len < 0 || ofs > Bytes.length buf - len then invalid_arg "Unix.recvfrom" else unsafe_recvfrom fd buf ofs len flags with Unix_error((EAGAIN | EWOULDBLOCK), _, _) -> @@ -622,7 +628,7 @@ let rec recvfrom fd buf ofs len flags = let rec send fd buf ofs len flags = try - if ofs < 0 || len < 0 || ofs > String.length buf - len + if ofs < 0 || len < 0 || ofs > Bytes.length buf - len then invalid_arg "Unix.send" else unsafe_send fd buf ofs len flags with Unix_error((EAGAIN | EWOULDBLOCK), _, _) -> @@ -631,13 +637,19 @@ let rec send fd buf ofs len flags = let rec sendto fd buf ofs len flags addr = try - if ofs < 0 || len < 0 || ofs > String.length buf - len + if ofs < 0 || len < 0 || ofs > Bytes.length buf - len then invalid_arg "Unix.sendto" else unsafe_sendto fd buf ofs len flags addr with Unix_error((EAGAIN | EWOULDBLOCK), _, _) -> wait_write fd; sendto fd buf ofs len flags addr +let send_substring fd buf ofs len flags = + send fd (Bytes.unsafe_of_string buf) ofs len flags + +let sendto_substring fd buf ofs len flags addr = + sendto fd (Bytes.unsafe_of_string buf) ofs len flags addr + type socket_bool_option = SO_DEBUG | SO_BROADCAST diff --git a/otherlibs/unix/.depend b/otherlibs/unix/.depend index f3f79821d..85eee1b85 100644 --- a/otherlibs/unix/.depend +++ b/otherlibs/unix/.depend @@ -1,498 +1,503 @@ accept.o: accept.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ - ../../byterun/mlvalues.h ../../byterun/fail.h ../../byterun/memory.h \ - ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h \ - socketaddr.h ../../byterun/misc.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ + ../../byterun/mlvalues.h ../../byterun/fail.h ../../byterun/memory.h \ + ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \ + ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h \ + socketaddr.h ../../byterun/misc.h access.o: access.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ - ../../byterun/mlvalues.h ../../byterun/memory.h ../../byterun/gc.h \ - ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ + ../../byterun/mlvalues.h ../../byterun/memory.h ../../byterun/gc.h \ + ../../byterun/major_gc.h ../../byterun/freelist.h \ + ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h addrofstr.o: addrofstr.c ../../byterun/mlvalues.h \ - ../../byterun/compatibility.h ../../byterun/config.h \ - ../../byterun/../config/m.h ../../byterun/../config/s.h \ - ../../byterun/misc.h ../../byterun/memory.h ../../byterun/gc.h \ - ../../byterun/mlvalues.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/minor_gc.h ../../byterun/fail.h \ - unixsupport.h socketaddr.h ../../byterun/misc.h + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/../config/m.h ../../byterun/../config/s.h \ + ../../byterun/misc.h ../../byterun/memory.h ../../byterun/gc.h \ + ../../byterun/mlvalues.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/minor_gc.h ../../byterun/fail.h \ + unixsupport.h socketaddr.h ../../byterun/misc.h alarm.o: alarm.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/misc.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/misc.h unixsupport.h bind.o: bind.c ../../byterun/fail.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/mlvalues.h \ - ../../byterun/mlvalues.h unixsupport.h socketaddr.h ../../byterun/misc.h + ../../byterun/misc.h ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/mlvalues.h \ + ../../byterun/mlvalues.h unixsupport.h socketaddr.h \ + ../../byterun/misc.h chdir.o: chdir.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/memory.h \ - ../../byterun/gc.h ../../byterun/mlvalues.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/minor_gc.h \ - ../../byterun/signals.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/memory.h \ + ../../byterun/gc.h ../../byterun/mlvalues.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/minor_gc.h \ + ../../byterun/signals.h unixsupport.h chmod.o: chmod.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/memory.h \ - ../../byterun/gc.h ../../byterun/mlvalues.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/minor_gc.h \ - ../../byterun/signals.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/memory.h \ + ../../byterun/gc.h ../../byterun/mlvalues.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/minor_gc.h \ + ../../byterun/signals.h unixsupport.h chown.o: chown.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/memory.h \ - ../../byterun/gc.h ../../byterun/mlvalues.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/minor_gc.h \ - ../../byterun/signals.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/memory.h \ + ../../byterun/gc.h ../../byterun/mlvalues.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/minor_gc.h \ + ../../byterun/signals.h unixsupport.h chroot.o: chroot.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/memory.h \ - ../../byterun/gc.h ../../byterun/mlvalues.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/minor_gc.h \ - ../../byterun/signals.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/memory.h \ + ../../byterun/gc.h ../../byterun/mlvalues.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/minor_gc.h \ + ../../byterun/signals.h unixsupport.h close.o: close.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/signals.h \ - ../../byterun/mlvalues.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/misc.h \ + ../../byterun/signals.h ../../byterun/mlvalues.h unixsupport.h closedir.o: closedir.c ../../byterun/mlvalues.h \ - ../../byterun/compatibility.h ../../byterun/config.h \ - ../../byterun/../config/m.h ../../byterun/../config/s.h \ - ../../byterun/misc.h ../../byterun/memory.h ../../byterun/gc.h \ - ../../byterun/mlvalues.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/minor_gc.h \ - ../../byterun/signals.h unixsupport.h + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/../config/m.h ../../byterun/../config/s.h \ + ../../byterun/misc.h ../../byterun/memory.h ../../byterun/gc.h \ + ../../byterun/mlvalues.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/minor_gc.h \ + ../../byterun/signals.h unixsupport.h connect.o: connect.c ../../byterun/fail.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/mlvalues.h \ - ../../byterun/mlvalues.h ../../byterun/signals.h unixsupport.h \ - socketaddr.h ../../byterun/misc.h + ../../byterun/misc.h ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/mlvalues.h \ + ../../byterun/mlvalues.h ../../byterun/signals.h unixsupport.h \ + socketaddr.h ../../byterun/misc.h cst2constr.o: cst2constr.c ../../byterun/mlvalues.h \ - ../../byterun/compatibility.h ../../byterun/config.h \ - ../../byterun/../config/m.h ../../byterun/../config/s.h \ - ../../byterun/misc.h ../../byterun/fail.h ../../byterun/mlvalues.h \ - cst2constr.h + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/../config/m.h ../../byterun/../config/s.h \ + ../../byterun/misc.h ../../byterun/fail.h ../../byterun/mlvalues.h \ + cst2constr.h cstringv.o: cstringv.c ../../byterun/mlvalues.h \ - ../../byterun/compatibility.h ../../byterun/config.h \ - ../../byterun/../config/m.h ../../byterun/../config/s.h \ - ../../byterun/misc.h ../../byterun/memory.h ../../byterun/gc.h \ - ../../byterun/mlvalues.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/minor_gc.h unixsupport.h + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/../config/m.h ../../byterun/../config/s.h \ + ../../byterun/misc.h ../../byterun/memory.h ../../byterun/gc.h \ + ../../byterun/mlvalues.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/minor_gc.h unixsupport.h dup.o: dup.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/misc.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/misc.h unixsupport.h dup2.o: dup2.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/misc.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/misc.h unixsupport.h envir.o: envir.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ - ../../byterun/mlvalues.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ + ../../byterun/mlvalues.h errmsg.o: errmsg.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ - ../../byterun/mlvalues.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ + ../../byterun/mlvalues.h execv.o: execv.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/memory.h \ - ../../byterun/gc.h ../../byterun/mlvalues.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/minor_gc.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/memory.h \ + ../../byterun/gc.h ../../byterun/mlvalues.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/minor_gc.h unixsupport.h execve.o: execve.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/memory.h \ - ../../byterun/gc.h ../../byterun/mlvalues.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/minor_gc.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/memory.h \ + ../../byterun/gc.h ../../byterun/mlvalues.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/minor_gc.h unixsupport.h execvp.o: execvp.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/memory.h \ - ../../byterun/gc.h ../../byterun/mlvalues.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/minor_gc.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/memory.h \ + ../../byterun/gc.h ../../byterun/mlvalues.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/minor_gc.h unixsupport.h exit.o: exit.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/misc.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/misc.h unixsupport.h fchmod.o: fchmod.c ../../byterun/fail.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/mlvalues.h \ - ../../byterun/mlvalues.h ../../byterun/signals.h unixsupport.h + ../../byterun/misc.h ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/mlvalues.h \ + ../../byterun/mlvalues.h ../../byterun/signals.h unixsupport.h fchown.o: fchown.c ../../byterun/fail.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/mlvalues.h \ - ../../byterun/mlvalues.h ../../byterun/signals.h unixsupport.h + ../../byterun/misc.h ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/mlvalues.h \ + ../../byterun/mlvalues.h ../../byterun/signals.h unixsupport.h fcntl.o: fcntl.c ../../byterun/fail.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/mlvalues.h \ - ../../byterun/mlvalues.h unixsupport.h + ../../byterun/misc.h ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/mlvalues.h \ + ../../byterun/mlvalues.h unixsupport.h fork.o: fork.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/misc.h \ - ../../byterun/debugger.h ../../byterun/mlvalues.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/misc.h \ + ../../byterun/debugger.h ../../byterun/mlvalues.h unixsupport.h ftruncate.o: ftruncate.c ../../byterun/fail.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/mlvalues.h \ - ../../byterun/mlvalues.h ../../byterun/io.h ../../byterun/signals.h \ - unixsupport.h + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/mlvalues.h \ + ../../byterun/mlvalues.h ../../byterun/io.h ../../byterun/signals.h \ + unixsupport.h getaddrinfo.o: getaddrinfo.c ../../byterun/mlvalues.h \ - ../../byterun/compatibility.h ../../byterun/config.h \ - ../../byterun/../config/m.h ../../byterun/../config/s.h \ - ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \ - ../../byterun/fail.h ../../byterun/memory.h ../../byterun/gc.h \ - ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h \ - cst2constr.h socketaddr.h ../../byterun/misc.h + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/../config/m.h ../../byterun/../config/s.h \ + ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \ + ../../byterun/fail.h ../../byterun/memory.h ../../byterun/gc.h \ + ../../byterun/major_gc.h ../../byterun/freelist.h \ + ../../byterun/minor_gc.h ../../byterun/misc.h ../../byterun/signals.h \ + unixsupport.h cst2constr.h socketaddr.h getcwd.o: getcwd.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ - ../../byterun/mlvalues.h ../../byterun/fail.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ + ../../byterun/mlvalues.h ../../byterun/fail.h unixsupport.h getegid.o: getegid.c ../../byterun/mlvalues.h \ - ../../byterun/compatibility.h ../../byterun/config.h \ - ../../byterun/../config/m.h ../../byterun/../config/s.h \ - ../../byterun/misc.h unixsupport.h + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/../config/m.h ../../byterun/../config/s.h \ + ../../byterun/misc.h unixsupport.h geteuid.o: geteuid.c ../../byterun/mlvalues.h \ - ../../byterun/compatibility.h ../../byterun/config.h \ - ../../byterun/../config/m.h ../../byterun/../config/s.h \ - ../../byterun/misc.h unixsupport.h + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/../config/m.h ../../byterun/../config/s.h \ + ../../byterun/misc.h unixsupport.h getgid.o: getgid.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/misc.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/misc.h unixsupport.h getgr.o: getgr.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/fail.h \ - ../../byterun/mlvalues.h ../../byterun/alloc.h ../../byterun/memory.h \ - ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/fail.h \ + ../../byterun/mlvalues.h ../../byterun/alloc.h ../../byterun/memory.h \ + ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \ + ../../byterun/minor_gc.h unixsupport.h getgroups.o: getgroups.c ../../byterun/mlvalues.h \ - ../../byterun/compatibility.h ../../byterun/config.h \ - ../../byterun/../config/m.h ../../byterun/../config/s.h \ - ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \ - ../../byterun/fail.h unixsupport.h + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/../config/m.h ../../byterun/../config/s.h \ + ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \ + ../../byterun/fail.h unixsupport.h gethost.o: gethost.c ../../byterun/mlvalues.h \ - ../../byterun/compatibility.h ../../byterun/config.h \ - ../../byterun/../config/m.h ../../byterun/../config/s.h \ - ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \ - ../../byterun/fail.h ../../byterun/memory.h ../../byterun/gc.h \ - ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h \ - socketaddr.h ../../byterun/misc.h + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/../config/m.h ../../byterun/../config/s.h \ + ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \ + ../../byterun/fail.h ../../byterun/memory.h ../../byterun/gc.h \ + ../../byterun/major_gc.h ../../byterun/freelist.h \ + ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h \ + socketaddr.h ../../byterun/misc.h gethostname.o: gethostname.c ../../byterun/mlvalues.h \ - ../../byterun/compatibility.h ../../byterun/config.h \ - ../../byterun/../config/m.h ../../byterun/../config/s.h \ - ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \ - ../../byterun/fail.h unixsupport.h + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/../config/m.h ../../byterun/../config/s.h \ + ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \ + ../../byterun/fail.h unixsupport.h getlogin.o: getlogin.c ../../byterun/mlvalues.h \ - ../../byterun/compatibility.h ../../byterun/config.h \ - ../../byterun/../config/m.h ../../byterun/../config/s.h \ - ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \ - unixsupport.h + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/../config/m.h ../../byterun/../config/s.h \ + ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \ + unixsupport.h getnameinfo.o: getnameinfo.c ../../byterun/mlvalues.h \ - ../../byterun/compatibility.h ../../byterun/config.h \ - ../../byterun/../config/m.h ../../byterun/../config/s.h \ - ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \ - ../../byterun/fail.h ../../byterun/memory.h ../../byterun/gc.h \ - ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h \ - socketaddr.h ../../byterun/misc.h + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/../config/m.h ../../byterun/../config/s.h \ + ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \ + ../../byterun/fail.h ../../byterun/memory.h ../../byterun/gc.h \ + ../../byterun/major_gc.h ../../byterun/freelist.h \ + ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h \ + socketaddr.h ../../byterun/misc.h getpeername.o: getpeername.c ../../byterun/fail.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/mlvalues.h \ - ../../byterun/mlvalues.h unixsupport.h socketaddr.h ../../byterun/misc.h + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/mlvalues.h \ + ../../byterun/mlvalues.h unixsupport.h socketaddr.h \ + ../../byterun/misc.h getpid.o: getpid.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/misc.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/misc.h unixsupport.h getppid.o: getppid.c ../../byterun/mlvalues.h \ - ../../byterun/compatibility.h ../../byterun/config.h \ - ../../byterun/../config/m.h ../../byterun/../config/s.h \ - ../../byterun/misc.h unixsupport.h + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/../config/m.h ../../byterun/../config/s.h \ + ../../byterun/misc.h unixsupport.h getproto.o: getproto.c ../../byterun/mlvalues.h \ - ../../byterun/compatibility.h ../../byterun/config.h \ - ../../byterun/../config/m.h ../../byterun/../config/s.h \ - ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \ - ../../byterun/fail.h ../../byterun/memory.h ../../byterun/gc.h \ - ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h unixsupport.h + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/../config/m.h ../../byterun/../config/s.h \ + ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \ + ../../byterun/fail.h ../../byterun/memory.h ../../byterun/gc.h \ + ../../byterun/major_gc.h ../../byterun/freelist.h \ + ../../byterun/minor_gc.h unixsupport.h getpw.o: getpw.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ - ../../byterun/mlvalues.h ../../byterun/memory.h ../../byterun/gc.h \ - ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h ../../byterun/fail.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ + ../../byterun/mlvalues.h ../../byterun/memory.h ../../byterun/gc.h \ + ../../byterun/major_gc.h ../../byterun/freelist.h \ + ../../byterun/minor_gc.h ../../byterun/fail.h unixsupport.h getserv.o: getserv.c ../../byterun/mlvalues.h \ - ../../byterun/compatibility.h ../../byterun/config.h \ - ../../byterun/../config/m.h ../../byterun/../config/s.h \ - ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \ - ../../byterun/fail.h ../../byterun/memory.h ../../byterun/gc.h \ - ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h unixsupport.h + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/../config/m.h ../../byterun/../config/s.h \ + ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \ + ../../byterun/fail.h ../../byterun/memory.h ../../byterun/gc.h \ + ../../byterun/major_gc.h ../../byterun/freelist.h \ + ../../byterun/minor_gc.h unixsupport.h getsockname.o: getsockname.c ../../byterun/fail.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/mlvalues.h \ - ../../byterun/mlvalues.h unixsupport.h socketaddr.h ../../byterun/misc.h + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/mlvalues.h \ + ../../byterun/mlvalues.h unixsupport.h socketaddr.h \ + ../../byterun/misc.h gettimeofday.o: gettimeofday.c ../../byterun/mlvalues.h \ - ../../byterun/compatibility.h ../../byterun/config.h \ - ../../byterun/../config/m.h ../../byterun/../config/s.h \ - ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \ - ../../byterun/fail.h unixsupport.h + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/../config/m.h ../../byterun/../config/s.h \ + ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \ + ../../byterun/fail.h unixsupport.h getuid.o: getuid.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/misc.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/misc.h unixsupport.h gmtime.o: gmtime.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ - ../../byterun/mlvalues.h ../../byterun/fail.h ../../byterun/memory.h \ - ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ + ../../byterun/mlvalues.h ../../byterun/fail.h ../../byterun/memory.h \ + ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \ + ../../byterun/minor_gc.h unixsupport.h initgroups.o: initgroups.c ../../byterun/mlvalues.h \ - ../../byterun/compatibility.h ../../byterun/config.h \ - ../../byterun/../config/m.h ../../byterun/../config/s.h \ - ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \ - ../../byterun/fail.h unixsupport.h + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/../config/m.h ../../byterun/../config/s.h \ + ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \ + ../../byterun/fail.h unixsupport.h isatty.o: isatty.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/misc.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/misc.h unixsupport.h itimer.o: itimer.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ - ../../byterun/mlvalues.h ../../byterun/fail.h ../../byterun/memory.h \ - ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ + ../../byterun/mlvalues.h ../../byterun/fail.h ../../byterun/memory.h \ + ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \ + ../../byterun/minor_gc.h unixsupport.h kill.o: kill.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/fail.h \ - ../../byterun/mlvalues.h unixsupport.h ../../byterun/signals.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/fail.h \ + ../../byterun/mlvalues.h unixsupport.h ../../byterun/signals.h link.o: link.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/memory.h \ - ../../byterun/gc.h ../../byterun/mlvalues.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/minor_gc.h \ - ../../byterun/signals.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/memory.h \ + ../../byterun/gc.h ../../byterun/mlvalues.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/minor_gc.h \ + ../../byterun/signals.h unixsupport.h listen.o: listen.c ../../byterun/fail.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/mlvalues.h \ - ../../byterun/mlvalues.h unixsupport.h + ../../byterun/misc.h ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/mlvalues.h \ + ../../byterun/mlvalues.h unixsupport.h lockf.o: lockf.c ../../byterun/fail.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/mlvalues.h \ - ../../byterun/mlvalues.h ../../byterun/signals.h unixsupport.h + ../../byterun/misc.h ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/mlvalues.h \ + ../../byterun/mlvalues.h ../../byterun/signals.h unixsupport.h lseek.o: lseek.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ - ../../byterun/mlvalues.h ../../byterun/io.h ../../byterun/signals.h \ - unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ + ../../byterun/mlvalues.h ../../byterun/io.h ../../byterun/signals.h \ + unixsupport.h mkdir.o: mkdir.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/memory.h \ - ../../byterun/gc.h ../../byterun/mlvalues.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/minor_gc.h \ - ../../byterun/signals.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/memory.h \ + ../../byterun/gc.h ../../byterun/mlvalues.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/minor_gc.h \ + ../../byterun/signals.h unixsupport.h mkfifo.o: mkfifo.c ../../byterun/fail.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/mlvalues.h \ - ../../byterun/mlvalues.h ../../byterun/memory.h ../../byterun/gc.h \ - ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h + ../../byterun/misc.h ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/mlvalues.h \ + ../../byterun/mlvalues.h ../../byterun/memory.h ../../byterun/gc.h \ + ../../byterun/major_gc.h ../../byterun/freelist.h \ + ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h nice.o: nice.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/misc.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/misc.h unixsupport.h open.o: open.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ - ../../byterun/mlvalues.h ../../byterun/memory.h ../../byterun/gc.h \ - ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ + ../../byterun/mlvalues.h ../../byterun/memory.h ../../byterun/gc.h \ + ../../byterun/major_gc.h ../../byterun/freelist.h \ + ../../byterun/minor_gc.h ../../byterun/misc.h ../../byterun/signals.h \ + unixsupport.h opendir.o: opendir.c ../../byterun/mlvalues.h \ - ../../byterun/compatibility.h ../../byterun/config.h \ - ../../byterun/../config/m.h ../../byterun/../config/s.h \ - ../../byterun/misc.h ../../byterun/memory.h ../../byterun/gc.h \ - ../../byterun/mlvalues.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/minor_gc.h ../../byterun/alloc.h \ - ../../byterun/signals.h unixsupport.h + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/../config/m.h ../../byterun/../config/s.h \ + ../../byterun/misc.h ../../byterun/memory.h ../../byterun/gc.h \ + ../../byterun/mlvalues.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/minor_gc.h ../../byterun/alloc.h \ + ../../byterun/signals.h unixsupport.h pipe.o: pipe.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ - ../../byterun/mlvalues.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ + ../../byterun/mlvalues.h unixsupport.h putenv.o: putenv.c ../../byterun/fail.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/mlvalues.h \ - ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/minor_gc.h \ - ../../byterun/mlvalues.h unixsupport.h + ../../byterun/misc.h ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/mlvalues.h \ + ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/minor_gc.h \ + ../../byterun/mlvalues.h unixsupport.h read.o: read.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/memory.h \ - ../../byterun/gc.h ../../byterun/mlvalues.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/minor_gc.h \ - ../../byterun/signals.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/memory.h \ + ../../byterun/gc.h ../../byterun/mlvalues.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/minor_gc.h \ + ../../byterun/signals.h unixsupport.h readdir.o: readdir.c ../../byterun/mlvalues.h \ - ../../byterun/compatibility.h ../../byterun/config.h \ - ../../byterun/../config/m.h ../../byterun/../config/s.h \ - ../../byterun/misc.h ../../byterun/fail.h ../../byterun/mlvalues.h \ - ../../byterun/alloc.h ../../byterun/signals.h unixsupport.h + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/../config/m.h ../../byterun/../config/s.h \ + ../../byterun/misc.h ../../byterun/fail.h ../../byterun/mlvalues.h \ + ../../byterun/alloc.h ../../byterun/signals.h unixsupport.h readlink.o: readlink.c ../../byterun/mlvalues.h \ - ../../byterun/compatibility.h ../../byterun/config.h \ - ../../byterun/../config/m.h ../../byterun/../config/s.h \ - ../../byterun/misc.h ../../byterun/memory.h ../../byterun/gc.h \ - ../../byterun/mlvalues.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/minor_gc.h ../../byterun/alloc.h \ - ../../byterun/fail.h ../../byterun/signals.h unixsupport.h + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/../config/m.h ../../byterun/../config/s.h \ + ../../byterun/misc.h ../../byterun/memory.h ../../byterun/gc.h \ + ../../byterun/mlvalues.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/minor_gc.h ../../byterun/alloc.h \ + ../../byterun/fail.h ../../byterun/signals.h unixsupport.h rename.o: rename.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/memory.h \ - ../../byterun/gc.h ../../byterun/mlvalues.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/minor_gc.h \ - ../../byterun/signals.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/memory.h \ + ../../byterun/gc.h ../../byterun/mlvalues.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/minor_gc.h \ + ../../byterun/signals.h unixsupport.h rewinddir.o: rewinddir.c ../../byterun/fail.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/mlvalues.h \ - ../../byterun/mlvalues.h unixsupport.h + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/mlvalues.h \ + ../../byterun/mlvalues.h unixsupport.h rmdir.o: rmdir.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/memory.h \ - ../../byterun/gc.h ../../byterun/mlvalues.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/minor_gc.h \ - ../../byterun/signals.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/memory.h \ + ../../byterun/gc.h ../../byterun/mlvalues.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/minor_gc.h \ + ../../byterun/signals.h unixsupport.h select.o: select.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ - ../../byterun/mlvalues.h ../../byterun/fail.h ../../byterun/memory.h \ - ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ + ../../byterun/mlvalues.h ../../byterun/fail.h ../../byterun/memory.h \ + ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \ + ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h sendrecv.o: sendrecv.c ../../byterun/mlvalues.h \ - ../../byterun/compatibility.h ../../byterun/config.h \ - ../../byterun/../config/m.h ../../byterun/../config/s.h \ - ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \ - ../../byterun/fail.h ../../byterun/memory.h ../../byterun/gc.h \ - ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h \ - socketaddr.h ../../byterun/misc.h + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/../config/m.h ../../byterun/../config/s.h \ + ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \ + ../../byterun/fail.h ../../byterun/memory.h ../../byterun/gc.h \ + ../../byterun/major_gc.h ../../byterun/freelist.h \ + ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h \ + socketaddr.h ../../byterun/misc.h setgid.o: setgid.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/misc.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/misc.h unixsupport.h setgroups.o: setgroups.c ../../byterun/mlvalues.h \ - ../../byterun/compatibility.h ../../byterun/config.h \ - ../../byterun/../config/m.h ../../byterun/../config/s.h \ - ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \ - ../../byterun/fail.h ../../byterun/memory.h ../../byterun/gc.h \ - ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h unixsupport.h + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/../config/m.h ../../byterun/../config/s.h \ + ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \ + ../../byterun/fail.h ../../byterun/memory.h ../../byterun/gc.h \ + ../../byterun/major_gc.h ../../byterun/freelist.h \ + ../../byterun/minor_gc.h unixsupport.h setsid.o: setsid.c ../../byterun/fail.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/mlvalues.h \ - ../../byterun/mlvalues.h unixsupport.h + ../../byterun/misc.h ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/mlvalues.h \ + ../../byterun/mlvalues.h unixsupport.h setuid.o: setuid.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/misc.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/misc.h unixsupport.h shutdown.o: shutdown.c ../../byterun/fail.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/mlvalues.h \ - ../../byterun/mlvalues.h unixsupport.h + ../../byterun/misc.h ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/mlvalues.h \ + ../../byterun/mlvalues.h unixsupport.h signals.o: signals.c ../../byterun/alloc.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/mlvalues.h \ - ../../byterun/fail.h ../../byterun/memory.h ../../byterun/gc.h \ - ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h ../../byterun/mlvalues.h \ - ../../byterun/signals.h unixsupport.h + ../../byterun/misc.h ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/mlvalues.h \ + ../../byterun/fail.h ../../byterun/memory.h ../../byterun/gc.h \ + ../../byterun/major_gc.h ../../byterun/freelist.h \ + ../../byterun/minor_gc.h ../../byterun/mlvalues.h \ + ../../byterun/signals.h unixsupport.h sleep.o: sleep.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/signals.h \ - ../../byterun/mlvalues.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/misc.h \ + ../../byterun/signals.h ../../byterun/mlvalues.h unixsupport.h socket.o: socket.c ../../byterun/fail.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/mlvalues.h \ - ../../byterun/mlvalues.h unixsupport.h + ../../byterun/misc.h ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/mlvalues.h \ + ../../byterun/mlvalues.h unixsupport.h socketaddr.o: socketaddr.c ../../byterun/mlvalues.h \ - ../../byterun/compatibility.h ../../byterun/config.h \ - ../../byterun/../config/m.h ../../byterun/../config/s.h \ - ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \ - ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/minor_gc.h unixsupport.h \ - socketaddr.h ../../byterun/misc.h + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/../config/m.h ../../byterun/../config/s.h \ + ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \ + ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/minor_gc.h unixsupport.h \ + socketaddr.h ../../byterun/misc.h socketpair.o: socketpair.c ../../byterun/mlvalues.h \ - ../../byterun/compatibility.h ../../byterun/config.h \ - ../../byterun/../config/m.h ../../byterun/../config/s.h \ - ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \ - ../../byterun/fail.h unixsupport.h + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/../config/m.h ../../byterun/../config/s.h \ + ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \ + ../../byterun/fail.h unixsupport.h sockopt.o: sockopt.c ../../byterun/mlvalues.h \ - ../../byterun/compatibility.h ../../byterun/config.h \ - ../../byterun/../config/m.h ../../byterun/../config/s.h \ - ../../byterun/misc.h ../../byterun/memory.h ../../byterun/gc.h \ - ../../byterun/mlvalues.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/minor_gc.h ../../byterun/alloc.h \ - ../../byterun/fail.h unixsupport.h socketaddr.h ../../byterun/misc.h + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/../config/m.h ../../byterun/../config/s.h \ + ../../byterun/misc.h ../../byterun/memory.h ../../byterun/gc.h \ + ../../byterun/mlvalues.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/minor_gc.h ../../byterun/alloc.h \ + ../../byterun/fail.h unixsupport.h socketaddr.h ../../byterun/misc.h stat.o: stat.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/memory.h \ - ../../byterun/gc.h ../../byterun/mlvalues.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/minor_gc.h ../../byterun/alloc.h \ - ../../byterun/signals.h unixsupport.h cst2constr.h ../../byterun/io.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/memory.h \ + ../../byterun/gc.h ../../byterun/mlvalues.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/minor_gc.h ../../byterun/alloc.h \ + ../../byterun/signals.h unixsupport.h cst2constr.h ../../byterun/io.h strofaddr.o: strofaddr.c ../../byterun/mlvalues.h \ - ../../byterun/compatibility.h ../../byterun/config.h \ - ../../byterun/../config/m.h ../../byterun/../config/s.h \ - ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \ - ../../byterun/fail.h unixsupport.h socketaddr.h ../../byterun/misc.h + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/../config/m.h ../../byterun/../config/s.h \ + ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \ + ../../byterun/fail.h unixsupport.h socketaddr.h ../../byterun/misc.h symlink.o: symlink.c ../../byterun/fail.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/mlvalues.h \ - ../../byterun/mlvalues.h ../../byterun/memory.h ../../byterun/gc.h \ - ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h + ../../byterun/misc.h ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/mlvalues.h \ + ../../byterun/mlvalues.h ../../byterun/memory.h ../../byterun/gc.h \ + ../../byterun/major_gc.h ../../byterun/freelist.h \ + ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h termios.o: termios.c ../../byterun/mlvalues.h \ - ../../byterun/compatibility.h ../../byterun/config.h \ - ../../byterun/../config/m.h ../../byterun/../config/s.h \ - ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \ - ../../byterun/fail.h unixsupport.h + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/../config/m.h ../../byterun/../config/s.h \ + ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \ + ../../byterun/fail.h unixsupport.h time.o: time.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ - ../../byterun/mlvalues.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ + ../../byterun/mlvalues.h unixsupport.h times.o: times.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ - ../../byterun/mlvalues.h ../../byterun/memory.h ../../byterun/gc.h \ - ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ + ../../byterun/mlvalues.h ../../byterun/memory.h ../../byterun/gc.h \ + ../../byterun/major_gc.h ../../byterun/freelist.h \ + ../../byterun/minor_gc.h unixsupport.h truncate.o: truncate.c ../../byterun/mlvalues.h \ - ../../byterun/compatibility.h ../../byterun/config.h \ - ../../byterun/../config/m.h ../../byterun/../config/s.h \ - ../../byterun/misc.h ../../byterun/memory.h ../../byterun/gc.h \ - ../../byterun/mlvalues.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/minor_gc.h ../../byterun/fail.h \ - ../../byterun/signals.h ../../byterun/io.h unixsupport.h + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/../config/m.h ../../byterun/../config/s.h \ + ../../byterun/misc.h ../../byterun/memory.h ../../byterun/gc.h \ + ../../byterun/mlvalues.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/minor_gc.h ../../byterun/fail.h \ + ../../byterun/signals.h ../../byterun/io.h unixsupport.h umask.o: umask.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/misc.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/misc.h unixsupport.h unixsupport.o: unixsupport.c ../../byterun/mlvalues.h \ - ../../byterun/compatibility.h ../../byterun/config.h \ - ../../byterun/../config/m.h ../../byterun/../config/s.h \ - ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \ - ../../byterun/callback.h ../../byterun/memory.h ../../byterun/gc.h \ - ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h ../../byterun/fail.h unixsupport.h cst2constr.h + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/../config/m.h ../../byterun/../config/s.h \ + ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \ + ../../byterun/callback.h ../../byterun/memory.h ../../byterun/gc.h \ + ../../byterun/major_gc.h ../../byterun/freelist.h \ + ../../byterun/minor_gc.h ../../byterun/fail.h unixsupport.h \ + cst2constr.h unlink.o: unlink.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/memory.h \ - ../../byterun/gc.h ../../byterun/mlvalues.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/minor_gc.h \ - ../../byterun/signals.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/memory.h \ + ../../byterun/gc.h ../../byterun/mlvalues.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/minor_gc.h \ + ../../byterun/signals.h unixsupport.h utimes.o: utimes.c ../../byterun/fail.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/mlvalues.h \ - ../../byterun/mlvalues.h ../../byterun/memory.h ../../byterun/gc.h \ - ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h + ../../byterun/misc.h ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/mlvalues.h \ + ../../byterun/mlvalues.h ../../byterun/memory.h ../../byterun/gc.h \ + ../../byterun/major_gc.h ../../byterun/freelist.h \ + ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h wait.o: wait.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ - ../../byterun/mlvalues.h ../../byterun/fail.h ../../byterun/memory.h \ - ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ + ../../byterun/mlvalues.h ../../byterun/fail.h ../../byterun/memory.h \ + ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \ + ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h write.o: write.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/memory.h \ - ../../byterun/gc.h ../../byterun/mlvalues.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/minor_gc.h \ - ../../byterun/signals.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/memory.h \ + ../../byterun/gc.h ../../byterun/mlvalues.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/minor_gc.h \ + ../../byterun/signals.h unixsupport.h unix.cmi : unixLabels.cmi : unix.cmi unix.cmo : unix.cmi diff --git a/otherlibs/unix/access.c b/otherlibs/unix/access.c index 9af8a6f95..7df4f9c5f 100644 --- a/otherlibs/unix/access.c +++ b/otherlibs/unix/access.c @@ -47,7 +47,7 @@ CAMLprim value unix_access(value path, value perms) int ret, cv_flags; cv_flags = convert_flag_list(perms, access_permission_table); - p = caml_stat_alloc_string(path); + p = caml_strdup(String_val(path)); caml_enter_blocking_section(); ret = access(p, cv_flags); caml_leave_blocking_section(); diff --git a/otherlibs/unix/addrofstr.c b/otherlibs/unix/addrofstr.c index e17841f95..a2830ba59 100644 --- a/otherlibs/unix/addrofstr.c +++ b/otherlibs/unix/addrofstr.c @@ -73,7 +73,7 @@ CAMLprim value unix_inet_addr_of_string(value s) #else struct in_addr address; address.s_addr = inet_addr(String_val(s)); - if (address.s_addr == (uint32) -1) failwith("inet_addr_of_string"); + if (address.s_addr == (uint32_t) -1) failwith("inet_addr_of_string"); return alloc_inet_addr(&address); #endif } diff --git a/otherlibs/unix/chdir.c b/otherlibs/unix/chdir.c index 4b93b5fc8..0d5326a0d 100644 --- a/otherlibs/unix/chdir.c +++ b/otherlibs/unix/chdir.c @@ -21,7 +21,7 @@ CAMLprim value unix_chdir(value path) CAMLparam1(path); char * p; int ret; - p = caml_stat_alloc_string(path); + p = caml_strdup(String_val(path)); caml_enter_blocking_section(); ret = chdir(p); caml_leave_blocking_section(); diff --git a/otherlibs/unix/chmod.c b/otherlibs/unix/chmod.c index a04215521..90dd6024f 100644 --- a/otherlibs/unix/chmod.c +++ b/otherlibs/unix/chmod.c @@ -23,7 +23,7 @@ CAMLprim value unix_chmod(value path, value perm) CAMLparam2(path, perm); char * p; int ret; - p = caml_stat_alloc_string(path); + p = caml_strdup(String_val(path)); caml_enter_blocking_section(); ret = chmod(p, Int_val(perm)); caml_leave_blocking_section(); diff --git a/otherlibs/unix/chown.c b/otherlibs/unix/chown.c index 0b118fb40..697f44771 100644 --- a/otherlibs/unix/chown.c +++ b/otherlibs/unix/chown.c @@ -21,7 +21,7 @@ CAMLprim value unix_chown(value path, value uid, value gid) CAMLparam1(path); char * p; int ret; - p = caml_stat_alloc_string(path); + p = caml_strdup(String_val(path)); caml_enter_blocking_section(); ret = chown(p, Int_val(uid), Int_val(gid)); caml_leave_blocking_section(); diff --git a/otherlibs/unix/chroot.c b/otherlibs/unix/chroot.c index 7c9517c11..b41c09ff0 100644 --- a/otherlibs/unix/chroot.c +++ b/otherlibs/unix/chroot.c @@ -21,7 +21,7 @@ CAMLprim value unix_chroot(value path) CAMLparam1(path); char * p; int ret; - p = caml_stat_alloc_string(path); + p = caml_strdup(String_val(path)); caml_enter_blocking_section(); ret = chroot(p); caml_leave_blocking_section(); diff --git a/otherlibs/unix/getaddrinfo.c b/otherlibs/unix/getaddrinfo.c index cf3bb4a52..28d8903a3 100644 --- a/otherlibs/unix/getaddrinfo.c +++ b/otherlibs/unix/getaddrinfo.c @@ -16,6 +16,7 @@ #include <alloc.h> #include <fail.h> #include <memory.h> +#include <misc.h> #include <signals.h> #include "unixsupport.h" #include "cst2constr.h" @@ -56,27 +57,22 @@ CAMLprim value unix_getaddrinfo(value vnode, value vserv, value vopts) { CAMLparam3(vnode, vserv, vopts); CAMLlocal3(vres, v, e); - mlsize_t len; char * node, * serv; struct addrinfo hints; struct addrinfo * res, * r; int retcode; /* Extract "node" parameter */ - len = string_length(vnode); - if (len == 0) { + if (caml_string_length(vnode) == 0) { node = NULL; } else { - node = caml_stat_alloc(len + 1); - strcpy(node, String_val(vnode)); + node = caml_strdup(String_val(vnode)); } /* Extract "service" parameter */ - len = string_length(vserv); - if (len == 0) { + if (caml_string_length(vserv) == 0) { serv = NULL; } else { - serv = caml_stat_alloc(len + 1); - strcpy(serv, String_val(vserv)); + serv = caml_strdup(String_val(vserv)); } /* Parse options, set hints */ memset(&hints, 0, sizeof(hints)); diff --git a/otherlibs/unix/gethost.c b/otherlibs/unix/gethost.c index 607b6c35f..8d5bb03f5 100644 --- a/otherlibs/unix/gethost.c +++ b/otherlibs/unix/gethost.c @@ -127,7 +127,7 @@ CAMLprim value unix_gethostbyname(value name) char * hostname; #if HAS_GETHOSTBYNAME_R || GETHOSTBYNAME_IS_REENTRANT - hostname = caml_stat_alloc_string(name); + hostname = caml_strdup(String_val(name)); #else hostname = String_val(name); #endif diff --git a/otherlibs/unix/link.c b/otherlibs/unix/link.c index 8110bf583..c71118a59 100644 --- a/otherlibs/unix/link.c +++ b/otherlibs/unix/link.c @@ -22,8 +22,8 @@ CAMLprim value unix_link(value path1, value path2) char * p1; char * p2; int ret; - p1 = caml_stat_alloc_string(path1); - p2 = caml_stat_alloc_string(path2); + p1 = caml_strdup(String_val(path1)); + p2 = caml_strdup(String_val(path2)); caml_enter_blocking_section(); ret = link(p1, p2); caml_leave_blocking_section(); diff --git a/otherlibs/unix/mkdir.c b/otherlibs/unix/mkdir.c index 6a7bb18c2..d72a066c5 100644 --- a/otherlibs/unix/mkdir.c +++ b/otherlibs/unix/mkdir.c @@ -23,7 +23,7 @@ CAMLprim value unix_mkdir(value path, value perm) CAMLparam2(path, perm); char * p; int ret; - p = caml_stat_alloc_string(path); + p = caml_strdup(String_val(path)); caml_enter_blocking_section(); ret = mkdir(p, Int_val(perm)); caml_leave_blocking_section(); diff --git a/otherlibs/unix/mkfifo.c b/otherlibs/unix/mkfifo.c index ef440a25b..a00bcf2d0 100644 --- a/otherlibs/unix/mkfifo.c +++ b/otherlibs/unix/mkfifo.c @@ -26,7 +26,7 @@ CAMLprim value unix_mkfifo(value path, value mode) CAMLparam2(path, mode); char * p; int ret; - p = caml_stat_alloc_string(path); + p = caml_strdup(String_val(path)); caml_enter_blocking_section(); ret = mkfifo(p, Int_val(mode)); caml_leave_blocking_section(); @@ -48,7 +48,7 @@ CAMLprim value unix_mkfifo(value path, value mode) CAMLparam2(path, mode); char * p; int ret; - p = caml_stat_alloc_string(path); + p = caml_strdup(String_val(path)); caml_enter_blocking_section(); ret = mknod(p, (Int_val(mode) & 07777) | S_IFIFO, 0); caml_leave_blocking_section(); diff --git a/otherlibs/unix/open.c b/otherlibs/unix/open.c index c98819aab..32c332f23 100644 --- a/otherlibs/unix/open.c +++ b/otherlibs/unix/open.c @@ -14,6 +14,7 @@ #include <mlvalues.h> #include <alloc.h> #include <memory.h> +#include <misc.h> #include <signals.h> #include "unixsupport.h" #include <string.h> @@ -62,7 +63,7 @@ CAMLprim value unix_open(value path, value flags, value perm) char * p; cv_flags = convert_flag_list(flags, open_flag_table); - p = caml_stat_alloc_string(path); + p = caml_strdup(String_val(path)); /* open on a named FIFO can block (PR#1533) */ enter_blocking_section(); fd = open(p, cv_flags, Int_val(perm)); diff --git a/otherlibs/unix/opendir.c b/otherlibs/unix/opendir.c index 57a331888..9cb6829cd 100644 --- a/otherlibs/unix/opendir.c +++ b/otherlibs/unix/opendir.c @@ -30,7 +30,7 @@ CAMLprim value unix_opendir(value path) value res; char * p; - p = caml_stat_alloc_string(path); + p = caml_strdup(String_val(path)); caml_enter_blocking_section(); d = opendir(p); caml_leave_blocking_section(); diff --git a/otherlibs/unix/readlink.c b/otherlibs/unix/readlink.c index d129aebfe..5706ba035 100644 --- a/otherlibs/unix/readlink.c +++ b/otherlibs/unix/readlink.c @@ -36,7 +36,7 @@ CAMLprim value unix_readlink(value path) char buffer[PATH_MAX]; int len; char * p; - p = caml_stat_alloc_string(path); + p = caml_strdup(String_val(path)); caml_enter_blocking_section(); len = readlink(p, buffer, sizeof(buffer) - 1); caml_leave_blocking_section(); diff --git a/otherlibs/unix/rename.c b/otherlibs/unix/rename.c index e63a06e36..78da70948 100644 --- a/otherlibs/unix/rename.c +++ b/otherlibs/unix/rename.c @@ -23,8 +23,8 @@ CAMLprim value unix_rename(value path1, value path2) char * p1; char * p2; int ret; - p1 = caml_stat_alloc_string(path1); - p2 = caml_stat_alloc_string(path2); + p1 = caml_strdup(String_val(path1)); + p2 = caml_strdup(String_val(path2)); caml_enter_blocking_section(); ret = rename(p1, p2); caml_leave_blocking_section(); diff --git a/otherlibs/unix/rmdir.c b/otherlibs/unix/rmdir.c index 28cef33d8..12d521a72 100644 --- a/otherlibs/unix/rmdir.c +++ b/otherlibs/unix/rmdir.c @@ -21,7 +21,7 @@ CAMLprim value unix_rmdir(value path) CAMLparam1(path); char * p; int ret; - p = caml_stat_alloc_string(path); + p = caml_strdup(String_val(path)); caml_enter_blocking_section(); ret = rmdir(p); caml_leave_blocking_section(); diff --git a/otherlibs/unix/stat.c b/otherlibs/unix/stat.c index 9825802a0..f6d8c06d3 100644 --- a/otherlibs/unix/stat.c +++ b/otherlibs/unix/stat.c @@ -75,7 +75,7 @@ CAMLprim value unix_stat(value path) int ret; struct stat buf; char * p; - p = caml_stat_alloc_string(path); + p = caml_strdup(String_val(path)); caml_enter_blocking_section(); ret = stat(p, &buf); caml_leave_blocking_section(); @@ -92,7 +92,7 @@ CAMLprim value unix_lstat(value path) int ret; struct stat buf; char * p; - p = caml_stat_alloc_string(path); + p = caml_strdup(String_val(path)); caml_enter_blocking_section(); #ifdef HAS_SYMLINK ret = lstat(p, &buf); @@ -126,7 +126,7 @@ CAMLprim value unix_stat_64(value path) int ret; struct stat buf; char * p; - p = caml_stat_alloc_string(path); + p = caml_strdup(String_val(path)); caml_enter_blocking_section(); ret = stat(p, &buf); caml_leave_blocking_section(); @@ -141,7 +141,7 @@ CAMLprim value unix_lstat_64(value path) int ret; struct stat buf; char * p; - p = caml_stat_alloc_string(path); + p = caml_strdup(String_val(path)); caml_enter_blocking_section(); #ifdef HAS_SYMLINK ret = lstat(p, &buf); diff --git a/otherlibs/unix/symlink.c b/otherlibs/unix/symlink.c index 41ba02019..d1dbf37c5 100644 --- a/otherlibs/unix/symlink.c +++ b/otherlibs/unix/symlink.c @@ -25,8 +25,8 @@ CAMLprim value unix_symlink(value path1, value path2) char * p1; char * p2; int ret; - p1 = caml_stat_alloc_string(path1); - p2 = caml_stat_alloc_string(path2); + p1 = caml_strdup(String_val(path1)); + p2 = caml_strdup(String_val(path2)); caml_enter_blocking_section(); ret = symlink(p1, p2); caml_leave_blocking_section(); diff --git a/otherlibs/unix/truncate.c b/otherlibs/unix/truncate.c index c5b3a1159..520320ebb 100644 --- a/otherlibs/unix/truncate.c +++ b/otherlibs/unix/truncate.c @@ -29,7 +29,7 @@ CAMLprim value unix_truncate(value path, value len) CAMLparam2(path, len); char * p; int ret; - p = caml_stat_alloc_string(path); + p = caml_strdup(String_val(path)); caml_enter_blocking_section(); ret = truncate(p, Long_val(len)); caml_leave_blocking_section(); @@ -45,7 +45,7 @@ CAMLprim value unix_truncate_64(value path, value vlen) char * p; int ret; file_offset len = File_offset_val(vlen); - p = caml_stat_alloc_string(path); + p = caml_strdup(String_val(path)); caml_enter_blocking_section(); ret = truncate(p, len); caml_leave_blocking_section(); diff --git a/otherlibs/unix/unix.ml b/otherlibs/unix/unix.ml index 8bd935f4c..d18b338ad 100644 --- a/otherlibs/unix/unix.ml +++ b/otherlibs/unix/unix.ml @@ -237,27 +237,34 @@ external openfile : string -> open_flag list -> file_perm -> file_descr = "unix_open" external close : file_descr -> unit = "unix_close" -external unsafe_read : file_descr -> string -> int -> int -> int = "unix_read" -external unsafe_write : file_descr -> string -> int -> int -> int = "unix_write" -external unsafe_single_write : file_descr -> string -> int -> int -> int +external unsafe_read : file_descr -> bytes -> int -> int -> int + = "unix_read" +external unsafe_write : file_descr -> bytes -> int -> int -> int = "unix_write" +external unsafe_single_write : file_descr -> bytes -> int -> int -> int = "unix_single_write" let read fd buf ofs len = - if ofs < 0 || len < 0 || ofs > String.length buf - len + if ofs < 0 || len < 0 || ofs > Bytes.length buf - len then invalid_arg "Unix.read" else unsafe_read fd buf ofs len let write fd buf ofs len = - if ofs < 0 || len < 0 || ofs > String.length buf - len + if ofs < 0 || len < 0 || ofs > Bytes.length buf - len then invalid_arg "Unix.write" else unsafe_write fd buf ofs len (* write misbehaves because it attempts to write all data by making repeated calls to the Unix write function (see comment in write.c and unix.mli). - partial_write fixes this by never calling write twice. *) + single_write fixes this by never calling write twice. *) let single_write fd buf ofs len = - if ofs < 0 || len < 0 || ofs > String.length buf - len + if ofs < 0 || len < 0 || ofs > Bytes.length buf - len then invalid_arg "Unix.single_write" else unsafe_single_write fd buf ofs len +let write_substring fd buf ofs len = + write fd (Bytes.unsafe_of_string buf) ofs len + +let single_write_substring fd buf ofs len = + single_write fd (Bytes.unsafe_of_string buf) ofs len + external in_channel_of_descr : file_descr -> in_channel = "caml_ml_open_descriptor_in" external out_channel_of_descr : file_descr -> out_channel @@ -529,35 +536,41 @@ external getsockname : file_descr -> sockaddr = "unix_getsockname" external getpeername : file_descr -> sockaddr = "unix_getpeername" external unsafe_recv : - file_descr -> string -> int -> int -> msg_flag list -> int + file_descr -> bytes -> int -> int -> msg_flag list -> int = "unix_recv" external unsafe_recvfrom : - file_descr -> string -> int -> int -> msg_flag list -> int * sockaddr + file_descr -> bytes -> int -> int -> msg_flag list -> int * sockaddr = "unix_recvfrom" external unsafe_send : - file_descr -> string -> int -> int -> msg_flag list -> int + file_descr -> bytes -> int -> int -> msg_flag list -> int = "unix_send" external unsafe_sendto : - file_descr -> string -> int -> int -> msg_flag list -> sockaddr -> int + file_descr -> bytes -> int -> int -> msg_flag list -> sockaddr -> int = "unix_sendto" "unix_sendto_native" let recv fd buf ofs len flags = - if ofs < 0 || len < 0 || ofs > String.length buf - len + if ofs < 0 || len < 0 || ofs > Bytes.length buf - len then invalid_arg "Unix.recv" else unsafe_recv fd buf ofs len flags let recvfrom fd buf ofs len flags = - if ofs < 0 || len < 0 || ofs > String.length buf - len + if ofs < 0 || len < 0 || ofs > Bytes.length buf - len then invalid_arg "Unix.recvfrom" else unsafe_recvfrom fd buf ofs len flags let send fd buf ofs len flags = - if ofs < 0 || len < 0 || ofs > String.length buf - len + if ofs < 0 || len < 0 || ofs > Bytes.length buf - len then invalid_arg "Unix.send" else unsafe_send fd buf ofs len flags let sendto fd buf ofs len flags addr = - if ofs < 0 || len < 0 || ofs > String.length buf - len + if ofs < 0 || len < 0 || ofs > Bytes.length buf - len then invalid_arg "Unix.sendto" else unsafe_sendto fd buf ofs len flags addr +let send_substring fd buf ofs len flags = + send fd (Bytes.unsafe_of_string buf) ofs len flags + +let sendto_substring fd buf ofs len flags addr = + sendto fd (Bytes.unsafe_of_string buf) ofs len flags addr + type socket_bool_option = SO_DEBUG | SO_BROADCAST diff --git a/otherlibs/unix/unix.mli b/otherlibs/unix/unix.mli index d8a15753e..dea5cb30b 100644 --- a/otherlibs/unix/unix.mli +++ b/otherlibs/unix/unix.mli @@ -11,7 +11,11 @@ (* *) (***********************************************************************) -(** Interface to the Unix system *) +(** Interface to the Unix system. + + Note: all the functions of this module (except [error_message] and + [handle_unix_error]) are liable to raise the [Unix_error] + exception whenever the underlying system call signals an error. *) (** {6 Error report} *) @@ -259,23 +263,31 @@ val openfile : string -> open_flag list -> file_perm -> file_descr val close : file_descr -> unit (** Close a file descriptor. *) -val read : file_descr -> string -> int -> int -> int -(** [read fd buff ofs len] reads [len] characters from descriptor - [fd], storing them in string [buff], starting at position [ofs] - in string [buff]. Return the number of characters actually read. *) +val read : file_descr -> bytes -> int -> int -> int +(** [read fd buff ofs len] reads [len] bytes from descriptor [fd], + storing them in byte sequence [buff], starting at position [ofs] in + [buff]. Return the number of bytes actually read. *) -val write : file_descr -> string -> int -> int -> int -(** [write fd buff ofs len] writes [len] characters to descriptor - [fd], taking them from string [buff], starting at position [ofs] - in string [buff]. Return the number of characters actually - written. [write] repeats the writing operation until all characters - have been written or an error occurs. *) +val write : file_descr -> bytes -> int -> int -> int +(** [write fd buff ofs len] writes [len] bytes to descriptor [fd], + taking them from byte sequence [buff], starting at position [ofs] + in [buff]. Return the number of bytes actually written. [write] + repeats the writing operation until all bytes have been written or + an error occurs. *) -val single_write : file_descr -> string -> int -> int -> int +val single_write : file_descr -> bytes -> int -> int -> int (** Same as [write], but attempts to write only once. Thus, if an error occurs, [single_write] guarantees that no data has been written. *) +val write_substring : file_descr -> string -> int -> int -> int +(** Same as [write], but take the data from a string instead of a byte + sequence. *) + +val single_write_substring : file_descr -> string -> int -> int -> int +(** Same as [single_write], but take the data from a string instead of + a byte sequence. *) + (** {6 Interfacing with the standard input/output library} *) @@ -283,12 +295,27 @@ val single_write : file_descr -> string -> int -> int -> int val in_channel_of_descr : file_descr -> in_channel (** Create an input channel reading from the given descriptor. The channel is initially in binary mode; use - [set_binary_mode_in ic false] if text mode is desired. *) + [set_binary_mode_in ic false] if text mode is desired. + Beware that channels are buffered so more characters may have been + read from the file descriptor than those accessed using channel functions. + Channels also keep a copy of the current position in the file. + + You need to explicitly close all channels created with this function. + Closing the channel also closes the underlying file descriptor (unless + it was already closed). *) val out_channel_of_descr : file_descr -> out_channel (** Create an output channel writing on the given descriptor. The channel is initially in binary mode; use - [set_binary_mode_out oc false] if text mode is desired. *) + [set_binary_mode_out oc false] if text mode is desired. + Beware that channels are buffered so you may have to [flush] them + to ensure that all data has been sent to the file descriptor. + Channels also keep a copy of the current position in the file. + + You need to explicitly close all channels created with this function. + Closing the channel flushes the data and closes the underlying file + descriptor (unless it has already been closed, in which case the + buffered data is lost).*) val descr_of_in_channel : in_channel -> file_descr (** Return the descriptor corresponding to an input channel. *) @@ -799,8 +826,8 @@ val setitimer : its previous status. The [s] argument is interpreted as follows: [s.it_value], if nonzero, is the time to the next timer expiration; [s.it_interval], if nonzero, specifies a value to - be used in reloading it_value when the timer expires. - Setting [s.it_value] to zero disable the timer. + be used in reloading [it_value] when the timer expires. + Setting [s.it_value] to zero disables the timer. Setting [s.it_interval] to zero causes the timer to be disabled after its next expiration. *) @@ -994,20 +1021,28 @@ type msg_flag = (** The flags for {!Unix.recv}, {!Unix.recvfrom}, {!Unix.send} and {!Unix.sendto}. *) -val recv : file_descr -> string -> int -> int -> msg_flag list -> int +val recv : file_descr -> bytes -> int -> int -> msg_flag list -> int (** Receive data from a connected socket. *) val recvfrom : - file_descr -> string -> int -> int -> msg_flag list -> int * sockaddr + file_descr -> bytes -> int -> int -> msg_flag list -> int * sockaddr (** Receive data from an unconnected socket. *) -val send : file_descr -> string -> int -> int -> msg_flag list -> int +val send : file_descr -> bytes -> int -> int -> msg_flag list -> int (** Send data over a connected socket. *) +val send_substring : file_descr -> string -> int -> int -> msg_flag list -> int +(** Same as [send], but take the data from a string instead of a byte + sequence. *) + val sendto : - file_descr -> string -> int -> int -> msg_flag list -> sockaddr -> int + file_descr -> bytes -> int -> int -> msg_flag list -> sockaddr -> int (** Send data over an unconnected socket. *) +val sendto_substring : + file_descr -> string -> int -> int -> msg_flag list -> sockaddr -> int +(** Same as [sendto], but take the data from a string instead of a + byte sequence. *) (** {6 Socket options} *) diff --git a/otherlibs/unix/unixLabels.mli b/otherlibs/unix/unixLabels.mli index 4dc411b0b..76ff890b1 100644 --- a/otherlibs/unix/unixLabels.mli +++ b/otherlibs/unix/unixLabels.mli @@ -236,10 +236,14 @@ type open_flag = Unix.open_flag = | O_TRUNC (** Truncate to 0 length if existing *) | O_EXCL (** Fail if existing *) | O_NOCTTY (** Don't make this dev a controlling tty *) - | O_DSYNC (** Writes complete as `Synchronised I/O data integrity completion' *) - | O_SYNC (** Writes complete as `Synchronised I/O file integrity completion' *) - | O_RSYNC (** Reads complete as writes (depending on O_SYNC/O_DSYNC) *) - | O_SHARE_DELETE (** Windows only: allow the file to be deleted while still open *) + | O_DSYNC (** Writes complete as `Synchronised I/O data + integrity completion' *) + | O_SYNC (** Writes complete as `Synchronised I/O file + integrity completion' *) + | O_RSYNC (** Reads complete as writes (depending + on O_SYNC/O_DSYNC) *) + | O_SHARE_DELETE (** Windows only: allow the file to be deleted + while still open *) | O_CLOEXEC (** Set the close-on-exec flag on the descriptor returned by {!openfile} *) (** The flags to {!UnixLabels.openfile}. *) @@ -257,23 +261,32 @@ val openfile : string -> mode:open_flag list -> perm:file_perm -> file_descr val close : file_descr -> unit (** Close a file descriptor. *) -val read : file_descr -> buf:string -> pos:int -> len:int -> int -(** [read fd buff ofs len] reads [len] characters from descriptor - [fd], storing them in string [buff], starting at position [ofs] - in string [buff]. Return the number of characters actually read. *) +val read : file_descr -> buf:bytes -> pos:int -> len:int -> int +(** [read fd buff ofs len] reads [len] bytes from descriptor [fd], + storing them in byte sequence [buff], starting at position [ofs] in + [buff]. Return the number of bytes actually read. *) -val write : file_descr -> buf:string -> pos:int -> len:int -> int -(** [write fd buff ofs len] writes [len] characters to descriptor - [fd], taking them from string [buff], starting at position [ofs] - in string [buff]. Return the number of characters actually - written. [write] repeats the writing operation until all characters - have been written or an error occurs. *) +val write : file_descr -> buf:bytes -> pos:int -> len:int -> int +(** [write fd buff ofs len] writes [len] bytes to descriptor [fd], + taking them from byte sequence [buff], starting at position [ofs] + in [buff]. Return the number of bytes actually written. [write] + repeats the writing operation until all bytes have been written or + an error occurs. *) -val single_write : file_descr -> buf:string -> pos:int -> len:int -> int +val single_write : file_descr -> buf:bytes -> pos:int -> len:int -> int (** Same as [write], but attempts to write only once. Thus, if an error occurs, [single_write] guarantees that no data has been written. *) +val write_substring : file_descr -> buf:string -> pos:int -> len:int -> int +(** Same as [write], but take the data from a string instead of a byte + sequence. *) + +val single_write_substring : + file_descr -> buf:string -> pos:int -> len:int -> int +(** Same as [single_write], but take the data from a string instead of + a byte sequence. *) + (** {6 Interfacing with the standard input/output library} *) @@ -772,9 +785,11 @@ val utimes : string -> access:float -> modif:float -> unit type interval_timer = Unix.interval_timer = ITIMER_REAL - (** decrements in real time, and sends the signal [SIGALRM] when expired.*) + (** decrements in real time, and sends the signal [SIGALRM] when + expired.*) | ITIMER_VIRTUAL - (** decrements in process virtual time, and sends [SIGVTALRM] when expired. *) + (** decrements in process virtual time, and sends [SIGVTALRM] when + expired. *) | ITIMER_PROF (** (for profiling) decrements both when the process is running and when the system is running on behalf of the @@ -994,23 +1009,34 @@ type msg_flag = Unix.msg_flag = {!UnixLabels.send} and {!UnixLabels.sendto}. *) val recv : - file_descr -> buf:string -> pos:int -> len:int -> mode:msg_flag list -> int + file_descr -> buf:bytes -> pos:int -> len:int -> mode:msg_flag list -> int (** Receive data from a connected socket. *) val recvfrom : - file_descr -> buf:string -> pos:int -> len:int -> mode:msg_flag list -> + file_descr -> buf:bytes -> pos:int -> len:int -> mode:msg_flag list -> int * sockaddr (** Receive data from an unconnected socket. *) val send : - file_descr -> buf:string -> pos:int -> len:int -> mode:msg_flag list -> int + file_descr -> buf:bytes -> pos:int -> len:int -> mode:msg_flag list -> int (** Send data over a connected socket. *) +val send_substring : + file_descr -> buf:string -> pos:int -> len:int -> mode:msg_flag list -> int +(** Same as [send], but take the data from a string instead of a byte + sequence. *) + val sendto : - file_descr -> buf:string -> pos:int -> len:int -> mode:msg_flag list -> + file_descr -> buf:bytes -> pos:int -> len:int -> mode:msg_flag list -> addr:sockaddr -> int (** Send data over an unconnected socket. *) +val sendto_substring : + file_descr -> bug:string -> pos:int -> len:int -> mode:msg_flag list + -> sockaddr -> int +(** Same as [sendto], but take the data from a string instead of a + byte sequence. *) + (** {6 Socket options} *) @@ -1031,12 +1057,12 @@ type socket_bool_option = ([true]/[false]) value. *) type socket_int_option = - SO_SNDBUF (** Size of send buffer *) - | SO_RCVBUF (** Size of received buffer *) - | SO_ERROR (** Deprecated. Use {!Unix.getsockopt_error} instead. *) - | SO_TYPE (** Report the socket type *) - | SO_RCVLOWAT (** Minimum number of bytes to process for input operations *) - | SO_SNDLOWAT (** Minimum number of bytes to process for output operations *) + SO_SNDBUF (** Size of send buffer *) + | SO_RCVBUF (** Size of received buffer *) + | SO_ERROR (** Deprecated. Use {!Unix.getsockopt_error} instead. *) + | SO_TYPE (** Report the socket type *) + | SO_RCVLOWAT (** Minimum number of bytes to process for input operations *) + | SO_SNDLOWAT (** Minimum number of bytes to process for output operations *) (** The socket options that can be consulted with {!UnixLabels.getsockopt_int} and modified with {!UnixLabels.setsockopt_int}. These options have an integer value. *) @@ -1071,17 +1097,21 @@ val setsockopt_int : file_descr -> socket_int_option -> int -> unit (** Same as {!Unix.setsockopt} for an integer-valued socket option. *) val getsockopt_optint : file_descr -> socket_optint_option -> int option -(** Same as {!Unix.getsockopt} for a socket option whose value is an [int option]. *) +(** Same as {!Unix.getsockopt} for a socket option whose value is + an [int option]. *) val setsockopt_optint : file_descr -> socket_optint_option -> int option -> unit -(** Same as {!Unix.setsockopt} for a socket option whose value is an [int option]. *) +(** Same as {!Unix.setsockopt} for a socket option whose value is + an [int option]. *) val getsockopt_float : file_descr -> socket_float_option -> float -(** Same as {!Unix.getsockopt} for a socket option whose value is a floating-point number. *) +(** Same as {!Unix.getsockopt} for a socket option whose value is a + floating-point number. *) val setsockopt_float : file_descr -> socket_float_option -> float -> unit -(** Same as {!Unix.setsockopt} for a socket option whose value is a floating-point number. *) +(** Same as {!Unix.setsockopt} for a socket option whose value is a + floating-point number. *) val getsockopt_error : file_descr -> error option (** Return the error condition associated with the given socket, diff --git a/otherlibs/unix/unlink.c b/otherlibs/unix/unlink.c index 4a4a513e3..ae63f69a1 100644 --- a/otherlibs/unix/unlink.c +++ b/otherlibs/unix/unlink.c @@ -21,7 +21,7 @@ CAMLprim value unix_unlink(value path) CAMLparam1(path); char * p; int ret; - p = caml_stat_alloc_string(path); + p = caml_strdup(String_val(path)); caml_enter_blocking_section(); ret = unlink(p); caml_leave_blocking_section(); diff --git a/otherlibs/unix/utimes.c b/otherlibs/unix/utimes.c index bb84c43e5..0c3b77d1b 100644 --- a/otherlibs/unix/utimes.c +++ b/otherlibs/unix/utimes.c @@ -38,7 +38,7 @@ CAMLprim value unix_utimes(value path, value atime, value mtime) t = × else t = (struct utimbuf *) NULL; - p = caml_stat_alloc_string(path); + p = caml_strdup(String_val(path)); caml_enter_blocking_section(); ret = utime(p, t); caml_leave_blocking_section(); @@ -70,7 +70,7 @@ CAMLprim value unix_utimes(value path, value atime, value mtime) t = tv; else t = (struct timeval *) NULL; - p = caml_stat_alloc_string(path); + p = caml_strdup(String_val(path)); caml_enter_blocking_section(); ret = utimes(p, t); caml_leave_blocking_section(); diff --git a/otherlibs/win32graph/draw.c b/otherlibs/win32graph/draw.c index fc6cf1022..11426734b 100644 --- a/otherlibs/win32graph/draw.c +++ b/otherlibs/win32graph/draw.c @@ -57,12 +57,12 @@ CAMLprim value caml_gr_moveto(value vx, value vy) return Val_unit; } -CAMLprim value caml_gr_current_x(void) +CAMLprim value caml_gr_current_x(value unit) { return Val_int(grwindow.grx); } -CAMLprim value caml_gr_current_y(void) +CAMLprim value caml_gr_current_y(value unit) { return Val_int(grwindow.gry); } @@ -311,7 +311,7 @@ CAMLprim value caml_gr_show_bitmap(value filename,int x,int y) -CAMLprim value caml_gr_get_mousex(void) +CAMLprim value caml_gr_get_mousex(value unit) { POINT pt; GetCursorPos(&pt); @@ -319,7 +319,7 @@ CAMLprim value caml_gr_get_mousex(void) return pt.x; } -CAMLprim value caml_gr_get_mousey(void) +CAMLprim value caml_gr_get_mousey(value unit) { POINT pt; GetCursorPos(&pt); diff --git a/otherlibs/win32graph/open.c b/otherlibs/win32graph/open.c index 5e62da5d3..ded2e28ae 100644 --- a/otherlibs/win32graph/open.c +++ b/otherlibs/win32graph/open.c @@ -37,7 +37,7 @@ MSG msg; static char *szOcamlWindowClass = "OcamlWindowClass"; static BOOL gr_initialized = 0; -CAMLprim value caml_gr_clear_graph(void); +CAMLprim value caml_gr_clear_graph(value unit); HANDLE hInst; HFONT CreationFont(char *name) @@ -48,7 +48,8 @@ HFONT CreationFont(char *name) CurrentFont.lfWeight = FW_NORMAL; CurrentFont.lfHeight = grwindow.CurrentFontSize; CurrentFont.lfPitchAndFamily = (BYTE) (FIXED_PITCH | FF_MODERN); - strcpy(CurrentFont.lfFaceName, name); /* Courier */ + strncpy(CurrentFont.lfFaceName, name, sizeof(CurrentFont.lfFaceName)); + CurrentFont.lfFaceName[sizeof(CurrentFont.lfFaceName) - 1] = 0; return (CreateFontIndirect(&CurrentFont)); } @@ -99,7 +100,7 @@ static LRESULT CALLBACK GraphicsWndProc(HWND hwnd,UINT msg,WPARAM wParam,LPARAM // End application case WM_DESTROY: ResetForClose(hwnd); - gr_check_open(); + gr_check_open(); break; } caml_gr_handle_event(msg, wParam, lParam); @@ -267,7 +268,7 @@ CAMLprim value caml_gr_open_graph(value arg) return Val_unit; } -CAMLprim value caml_gr_close_graph(void) +CAMLprim value caml_gr_close_graph(value unit) { if (gr_initialized) { PostMessage(grwindow.hwnd, WM_CLOSE, 0, 0); @@ -276,7 +277,7 @@ CAMLprim value caml_gr_close_graph(void) return Val_unit; } -CAMLprim value caml_gr_clear_graph(void) +CAMLprim value caml_gr_clear_graph(value unit) { gr_check_open(); if(grremember_mode) { @@ -290,13 +291,13 @@ CAMLprim value caml_gr_clear_graph(void) return Val_unit; } -CAMLprim value caml_gr_size_x(void) +CAMLprim value caml_gr_size_x(value unit) { gr_check_open(); return Val_int(grwindow.width); } -CAMLprim value caml_gr_size_y(void) +CAMLprim value caml_gr_size_y(value unit) { gr_check_open(); return Val_int(grwindow.height); @@ -311,7 +312,7 @@ CAMLprim value caml_gr_resize_window (value vx, value vy) return Val_unit; } -CAMLprim value caml_gr_synchronize(void) +CAMLprim value caml_gr_synchronize(value unit) { gr_check_open(); BitBlt(grwindow.gc,0,0,grwindow.width,grwindow.height, @@ -336,7 +337,7 @@ CAMLprim value caml_gr_sigio_signal(value unit) return Val_unit; } -CAMLprim value caml_gr_sigio_handler(void) +CAMLprim value caml_gr_sigio_handler(value unit) { return Val_unit; } diff --git a/otherlibs/win32unix/createprocess.c b/otherlibs/win32unix/createprocess.c index 0e1e37a24..3858a39b8 100644 --- a/otherlibs/win32unix/createprocess.c +++ b/otherlibs/win32unix/createprocess.c @@ -53,9 +53,11 @@ value win_create_process_native(value cmd, value cmdline, value env, /* Create the process */ if (! CreateProcess(exefile, String_val(cmdline), NULL, NULL, TRUE, flags, envp, NULL, &si, &pi)) { + caml_stat_free(exefile); win32_maperr(GetLastError()); uerror("create_process", cmd); } + caml_stat_free(exefile); CloseHandle(pi.hThread); /* Return the process handle as pseudo-PID (this is consistent with the wait() emulation in the MSVC C library */ diff --git a/otherlibs/win32unix/sendrecv.c b/otherlibs/win32unix/sendrecv.c index f2745fb19..32532553f 100644 --- a/otherlibs/win32unix/sendrecv.c +++ b/otherlibs/win32unix/sendrecv.c @@ -22,7 +22,8 @@ static int msg_flag_table[] = { MSG_OOB, MSG_DONTROUTE, MSG_PEEK }; -CAMLprim value unix_recv(value sock, value buff, value ofs, value len, value flags) +CAMLprim value unix_recv(value sock, value buff, value ofs, value len, + value flags) { SOCKET s = Socket_val(sock); int flg = convert_flag_list(flags, msg_flag_table); @@ -47,7 +48,8 @@ CAMLprim value unix_recv(value sock, value buff, value ofs, value len, value fla return Val_int(ret); } -CAMLprim value unix_recvfrom(value sock, value buff, value ofs, value len, value flags) +CAMLprim value unix_recvfrom(value sock, value buff, value ofs, value len, + value flags) { SOCKET s = Socket_val(sock); int flg = convert_flag_list(flags, msg_flag_table); @@ -81,7 +83,8 @@ CAMLprim value unix_recvfrom(value sock, value buff, value ofs, value len, value return res; } -CAMLprim value unix_send(value sock, value buff, value ofs, value len, value flags) +CAMLprim value unix_send(value sock, value buff, value ofs, value len, + value flags) { SOCKET s = Socket_val(sock); int flg = convert_flag_list(flags, msg_flag_table); @@ -104,7 +107,8 @@ CAMLprim value unix_send(value sock, value buff, value ofs, value len, value fla return Val_int(ret); } -value unix_sendto_native(value sock, value buff, value ofs, value len, value flags, value dest) +value unix_sendto_native(value sock, value buff, value ofs, value len, + value flags, value dest) { SOCKET s = Socket_val(sock); int flg = convert_flag_list(flags, msg_flag_table); diff --git a/otherlibs/win32unix/unix.ml b/otherlibs/win32unix/unix.ml index 6c271ade2..b74f063e8 100644 --- a/otherlibs/win32unix/unix.ml +++ b/otherlibs/win32unix/unix.ml @@ -176,26 +176,32 @@ type file_perm = int external openfile : string -> open_flag list -> file_perm -> file_descr = "unix_open" external close : file_descr -> unit = "unix_close" -external unsafe_read : file_descr -> string -> int -> int -> int +external unsafe_read : file_descr -> bytes -> int -> int -> int = "unix_read" -external unsafe_write : file_descr -> string -> int -> int -> int +external unsafe_write : file_descr -> bytes -> int -> int -> int = "unix_write" -external unsafe_single_write : file_descr -> string -> int -> int -> int +external unsafe_single_write : file_descr -> bytes -> int -> int -> int = "unix_single_write" let read fd buf ofs len = - if ofs < 0 || len < 0 || ofs > String.length buf - len + if ofs < 0 || len < 0 || ofs > Bytes.length buf - len then invalid_arg "Unix.read" else unsafe_read fd buf ofs len let write fd buf ofs len = - if ofs < 0 || len < 0 || ofs > String.length buf - len + if ofs < 0 || len < 0 || ofs > Bytes.length buf - len then invalid_arg "Unix.write" else unsafe_write fd buf ofs len let single_write fd buf ofs len = - if ofs < 0 || len < 0 || ofs > String.length buf - len + if ofs < 0 || len < 0 || ofs > Bytes.length buf - len then invalid_arg "Unix.single_write" else unsafe_single_write fd buf ofs len +let write_substring fd buf ofs len = + write fd (Bytes.unsafe_of_string buf) ofs len + +let single_write_substring fd buf ofs len = + single_write fd (Bytes.unsafe_of_string buf) ofs len + (* Interfacing with the standard input/output library *) external in_channel_of_descr: file_descr -> in_channel @@ -535,35 +541,41 @@ external getsockname : file_descr -> sockaddr = "unix_getsockname" external getpeername : file_descr -> sockaddr = "unix_getpeername" external unsafe_recv : - file_descr -> string -> int -> int -> msg_flag list -> int + file_descr -> bytes -> int -> int -> msg_flag list -> int = "unix_recv" external unsafe_recvfrom : - file_descr -> string -> int -> int -> msg_flag list -> int * sockaddr + file_descr -> bytes -> int -> int -> msg_flag list -> int * sockaddr = "unix_recvfrom" external unsafe_send : - file_descr -> string -> int -> int -> msg_flag list -> int + file_descr -> bytes -> int -> int -> msg_flag list -> int = "unix_send" external unsafe_sendto : - file_descr -> string -> int -> int -> msg_flag list -> sockaddr -> int + file_descr -> bytes -> int -> int -> msg_flag list -> sockaddr -> int = "unix_sendto" "unix_sendto_native" let recv fd buf ofs len flags = - if ofs < 0 || len < 0 || ofs > String.length buf - len + if ofs < 0 || len < 0 || ofs > Bytes.length buf - len then invalid_arg "Unix.recv" else unsafe_recv fd buf ofs len flags let recvfrom fd buf ofs len flags = - if ofs < 0 || len < 0 || ofs > String.length buf - len + if ofs < 0 || len < 0 || ofs > Bytes.length buf - len then invalid_arg "Unix.recvfrom" else unsafe_recvfrom fd buf ofs len flags let send fd buf ofs len flags = - if ofs < 0 || len < 0 || ofs > String.length buf - len + if ofs < 0 || len < 0 || ofs > Bytes.length buf - len then invalid_arg "Unix.send" else unsafe_send fd buf ofs len flags let sendto fd buf ofs len flags addr = - if ofs < 0 || len < 0 || ofs > String.length buf - len + if ofs < 0 || len < 0 || ofs > Bytes.length buf - len then invalid_arg "Unix.sendto" else unsafe_sendto fd buf ofs len flags addr +let send_substring fd buf ofs len flags = + send fd (Bytes.unsafe_of_string buf) ofs len flags + +let sendto_substring fd buf ofs len flags addr = + sendto fd (Bytes.unsafe_of_string buf) ofs len flags addr + type socket_bool_option = SO_DEBUG | SO_BROADCAST @@ -796,7 +808,7 @@ external win_create_process : string -> string -> string option -> let make_cmdline args = let maybe_quote f = - if String.contains f ' ' || String.contains f '\"' + if String.contains f ' ' || String.contains f '\"' || f = "" then Filename.quote f else f in String.concat " " (List.map maybe_quote (Array.to_list args)) diff --git a/parsing/ast_helper.ml b/parsing/ast_helper.ml index ec70235f0..f53cb2928 100644 --- a/parsing/ast_helper.ml +++ b/parsing/ast_helper.ml @@ -29,7 +29,8 @@ let with_default_loc l f = with exn -> default_loc := old; raise exn module Typ = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = {ptyp_desc = d; ptyp_loc = loc; ptyp_attributes = attrs} + let mk ?(loc = !default_loc) ?(attrs = []) d = + {ptyp_desc = d; ptyp_loc = loc; ptyp_attributes = attrs} let attr d a = {d with ptyp_attributes = d.ptyp_attributes @ [a]} let any ?loc ?attrs () = mk ?loc ?attrs Ptyp_any @@ -52,7 +53,8 @@ module Typ = struct end module Pat = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = {ppat_desc = d; ppat_loc = loc; ppat_attributes = attrs} + let mk ?(loc = !default_loc) ?(attrs = []) d = + {ppat_desc = d; ppat_loc = loc; ppat_attributes = attrs} let attr d a = {d with ppat_attributes = d.ppat_attributes @ [a]} let any ?loc ?attrs () = mk ?loc ?attrs Ppat_any @@ -70,11 +72,13 @@ module Pat = struct let type_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_type a) let lazy_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_lazy a) let unpack ?loc ?attrs a = mk ?loc ?attrs (Ppat_unpack a) + let exception_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_exception a) let extension ?loc ?attrs a = mk ?loc ?attrs (Ppat_extension a) end module Exp = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = {pexp_desc = d; pexp_loc = loc; pexp_attributes = attrs} + let mk ?(loc = !default_loc) ?(attrs = []) d = + {pexp_desc = d; pexp_loc = loc; pexp_attributes = attrs} let attr d a = {d with pexp_attributes = d.pexp_attributes @ [a]} let ident ?loc ?attrs a = mk ?loc ?attrs (Pexp_ident a) @@ -121,7 +125,8 @@ module Exp = struct end module Mty = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = {pmty_desc = d; pmty_loc = loc; pmty_attributes = attrs} + let mk ?(loc = !default_loc) ?(attrs = []) d = + {pmty_desc = d; pmty_loc = loc; pmty_attributes = attrs} let attr d a = {d with pmty_attributes = d.pmty_attributes @ [a]} let ident ?loc ?attrs a = mk ?loc ?attrs (Pmty_ident a) @@ -134,12 +139,14 @@ module Mty = struct end module Mod = struct -let mk ?(loc = !default_loc) ?(attrs = []) d = {pmod_desc = d; pmod_loc = loc; pmod_attributes = attrs} +let mk ?(loc = !default_loc) ?(attrs = []) d = + {pmod_desc = d; pmod_loc = loc; pmod_attributes = attrs} let attr d a = {d with pmod_attributes = d.pmod_attributes @ [a]} let ident ?loc ?attrs x = mk ?loc ?attrs (Pmod_ident x) let structure ?loc ?attrs x = mk ?loc ?attrs (Pmod_structure x) - let functor_ ?loc ?attrs arg arg_ty body = mk ?loc ?attrs (Pmod_functor (arg, arg_ty, body)) + let functor_ ?loc ?attrs arg arg_ty body = + mk ?loc ?attrs (Pmod_functor (arg, arg_ty, body)) let apply ?loc ?attrs m1 m2 = mk ?loc ?attrs (Pmod_apply (m1, m2)) let constraint_ ?loc ?attrs m mty = mk ?loc ?attrs (Pmod_constraint (m, mty)) let unpack ?loc ?attrs e = mk ?loc ?attrs (Pmod_unpack e) @@ -151,12 +158,13 @@ module Sig = struct let value ?loc a = mk ?loc (Psig_value a) let type_ ?loc a = mk ?loc (Psig_type a) + let type_extension ?loc a = mk ?loc (Psig_typext a) let exception_ ?loc a = mk ?loc (Psig_exception a) let module_ ?loc a = mk ?loc (Psig_module a) let rec_module ?loc a = mk ?loc (Psig_recmodule a) let modtype ?loc a = mk ?loc (Psig_modtype a) - let open_ ?loc ?(attrs = []) a b = mk ?loc (Psig_open (a, b, attrs)) - let include_ ?loc ?(attrs = []) a = mk ?loc (Psig_include (a, attrs)) + let open_ ?loc a = mk ?loc (Psig_open a) + let include_ ?loc a = mk ?loc (Psig_include a) let class_ ?loc a = mk ?loc (Psig_class a) let class_type ?loc a = mk ?loc (Psig_class_type a) let extension ?loc ?(attrs = []) a = mk ?loc (Psig_extension (a, attrs)) @@ -170,15 +178,15 @@ module Str = struct let value ?loc a b = mk ?loc (Pstr_value (a, b)) let primitive ?loc a = mk ?loc (Pstr_primitive a) let type_ ?loc a = mk ?loc (Pstr_type a) + let type_extension ?loc a = mk ?loc (Pstr_typext a) let exception_ ?loc a = mk ?loc (Pstr_exception a) - let exn_rebind ?loc ?(attrs = []) a b = mk ?loc (Pstr_exn_rebind (a, b, attrs)) let module_ ?loc a = mk ?loc (Pstr_module a) let rec_module ?loc a = mk ?loc (Pstr_recmodule a) let modtype ?loc a = mk ?loc (Pstr_modtype a) - let open_ ?loc ?(attrs = []) a b = mk ?loc (Pstr_open (a, b, attrs)) + let open_ ?loc a = mk ?loc (Pstr_open a) let class_ ?loc a = mk ?loc (Pstr_class a) let class_type ?loc a = mk ?loc (Pstr_class_type a) - let include_ ?loc ?(attrs = []) a = mk ?loc (Pstr_include (a, attrs)) + let include_ ?loc a = mk ?loc (Pstr_include a) let extension ?loc ?(attrs = []) a = mk ?loc (Pstr_extension (a, attrs)) let attribute ?loc a = mk ?loc (Pstr_attribute a) end @@ -230,6 +238,7 @@ module Ctf = struct let method_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pctf_method (a, b, c, d)) let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pctf_constraint (a, b)) let extension ?loc ?attrs a = mk ?loc ?attrs (Pctf_extension a) + let attribute ?loc a = mk ?loc (Pctf_attribute a) end module Cf = struct @@ -247,6 +256,7 @@ module Cf = struct let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pcf_constraint (a, b)) let initializer_ ?loc ?attrs a = mk ?loc ?attrs (Pcf_initializer a) let extension ?loc ?attrs a = mk ?loc ?attrs (Pcf_extension a) + let attribute ?loc a = mk ?loc (Pcf_attribute a) let virtual_ ct = Cfk_virtual ct let concrete o e = Cfk_concrete (o, e) @@ -293,17 +303,38 @@ module Mb = struct } end +module Opn = struct + let mk ?(loc = !default_loc) ?(attrs = []) ?(override = Fresh) lid = + { + popen_lid = lid; + popen_override = override; + popen_loc = loc; + popen_attributes = attrs; + } +end + +module Incl = struct + let mk ?(loc = !default_loc) ?(attrs = []) mexpr = + { + pincl_mod = mexpr; + pincl_loc = loc; + pincl_attributes = attrs; + } +end + module Vb = struct - let mk ?(attrs = []) pat expr = + let mk ?(loc = !default_loc) ?(attrs = []) pat expr = { pvb_pat = pat; pvb_expr = expr; pvb_attributes = attrs; + pvb_loc = loc; } end module Ci = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(virt = Concrete) ?(params = []) name expr = + let mk ?(loc = !default_loc) ?(attrs = []) ?(virt = Concrete) ?(params = []) + name expr = { pci_virt = virt; pci_params = params; @@ -352,6 +383,43 @@ module Type = struct } end +(** Type extensions *) +module Te = struct + let mk ?(attrs = []) ?(params = []) ?(priv = Public) path constructors = + { + ptyext_path = path; + ptyext_params = params; + ptyext_constructors = constructors; + ptyext_private = priv; + ptyext_attributes = attrs; + } + + let constructor ?(loc = !default_loc) ?(attrs = []) name kind = + { + pext_name = name; + pext_kind = kind; + pext_loc = loc; + pext_attributes = attrs; + } + + let decl ?(loc = !default_loc) ?(attrs = []) ?(args = Pcstr_tuple []) ?res name = + { + pext_name = name; + pext_kind = Pext_decl(args, res); + pext_loc = loc; + pext_attributes = attrs; + } + + let rebind ?(loc = !default_loc) ?(attrs = []) name lid = + { + pext_name = name; + pext_kind = Pext_rebind lid; + pext_loc = loc; + pext_attributes = attrs; + } +end + + module Csig = struct let mk self fields = { @@ -367,73 +435,3 @@ module Cstr = struct pcstr_fields = fields; } end - -module Convenience = struct - open Location - - let may_tuple tup = function - | [] -> None - | [x] -> Some x - | l -> Some (tup ?loc:None ?attrs:None l) - - let lid s = mkloc (Longident.parse s) !default_loc - let tuple l = Exp.tuple l - let constr s args = Exp.construct (lid s) (may_tuple Exp.tuple args) - let nil () = constr "[]" [] - let unit () = constr "()" [] - let cons hd tl = constr "::" [hd; tl] - let list l = List.fold_right cons l (nil ()) - let str s = Exp.constant (Const_string (s, None)) - let int x = Exp.constant (Const_int x) - let char x = Exp.constant (Const_char x) - let float x = Exp.constant (Const_float (string_of_float x)) - let record ?over l = - Exp.record (List.map (fun (s, e) -> (lid s, e)) l) over - let func l = Exp.function_ (List.map (fun (p, e) -> Exp.case p e) l) - let lam ?(label = "") ?default pat exp = Exp.fun_ label default pat exp - let app f l = Exp.apply f (List.map (fun a -> "", a) l) - let evar s = Exp.ident (lid s) - let let_in ?(recursive = false) b body = - Exp.let_ (if recursive then Recursive else Nonrecursive) b body - - let pvar s = Pat.var (mkloc s !default_loc) - let pconstr s args = Pat.construct (lid s) (may_tuple Pat.tuple args) - let precord ?(closed = Open) l = Pat.record (List.map (fun (s, e) -> (lid s, e)) l) closed - let pnil () = pconstr "[]" [] - let pcons hd tl = pconstr "::" [hd; tl] - let punit () = pconstr "()" [] - let plist l = List.fold_right pcons l (pnil ()) - let ptuple l = Pat.tuple l - - let pstr s = Pat.constant (Const_string (s, None)) - let pint x = Pat.constant (Const_int x) - let pchar x = Pat.constant (Const_char x) - let pfloat x = Pat.constant (Const_float (string_of_float x)) - - let tconstr c l = Typ.constr (lid c) l - - let get_str = function - | {pexp_desc=Pexp_constant (Const_string (s, _)); _} -> Some s - | e -> None - - let get_lid = function - | {pexp_desc=Pexp_ident{txt=id;_};_} -> - Some (String.concat "." (Longident.flatten id)) - | _ -> None - - let find_attr s attrs = - try Some (snd (List.find (fun (x, _) -> x.txt = s) attrs)) - with Not_found -> None - - let expr_of_payload = function - | PStr [{pstr_desc=Pstr_eval(e, _)}] -> Some e - | _ -> None - - let find_attr_expr s attrs = - match find_attr s attrs with - | Some e -> expr_of_payload e - | None -> None - - let has_attr s attrs = - find_attr s attrs <> None -end diff --git a/parsing/ast_helper.mli b/parsing/ast_helper.mli index 70db00404..847d428f6 100644 --- a/parsing/ast_helper.mli +++ b/parsing/ast_helper.mli @@ -38,15 +38,20 @@ module Typ : val any: ?loc:loc -> ?attrs:attrs -> unit -> core_type val var: ?loc:loc -> ?attrs:attrs -> string -> core_type - val arrow: ?loc:loc -> ?attrs:attrs -> label -> core_type -> core_type -> core_type + val arrow: ?loc:loc -> ?attrs:attrs -> label -> core_type -> core_type + -> core_type val tuple: ?loc:loc -> ?attrs:attrs -> core_type list -> core_type val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type - val object_: ?loc:loc -> ?attrs:attrs -> (string * core_type) list -> closed_flag -> core_type + val object_: ?loc:loc -> ?attrs:attrs -> + (string * attributes * core_type) list -> closed_flag -> + core_type val class_: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type val alias: ?loc:loc -> ?attrs:attrs -> core_type -> string -> core_type - val variant: ?loc:loc -> ?attrs:attrs -> row_field list -> closed_flag -> label list option -> core_type + val variant: ?loc:loc -> ?attrs:attrs -> row_field list -> closed_flag + -> label list option -> core_type val poly: ?loc:loc -> ?attrs:attrs -> string list -> core_type -> core_type - val package: ?loc:loc -> ?attrs:attrs -> lid -> (lid * core_type) list -> core_type + val package: ?loc:loc -> ?attrs:attrs -> lid -> (lid * core_type) list + -> core_type val extension: ?loc:loc -> ?attrs:attrs -> extension -> core_type val force_poly: core_type -> core_type @@ -66,13 +71,15 @@ module Pat: val tuple: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern val construct: ?loc:loc -> ?attrs:attrs -> lid -> pattern option -> pattern val variant: ?loc:loc -> ?attrs:attrs -> label -> pattern option -> pattern - val record: ?loc:loc -> ?attrs:attrs -> (lid * pattern) list -> closed_flag -> pattern + val record: ?loc:loc -> ?attrs:attrs -> (lid * pattern) list -> closed_flag + -> pattern val array: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern val or_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern -> pattern val constraint_: ?loc:loc -> ?attrs:attrs -> pattern -> core_type -> pattern val type_: ?loc:loc -> ?attrs:attrs -> lid -> pattern val lazy_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern val unpack: ?loc:loc -> ?attrs:attrs -> str -> pattern + val exception_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern val extension: ?loc:loc -> ?attrs:attrs -> extension -> pattern end @@ -84,30 +91,46 @@ module Exp: val ident: ?loc:loc -> ?attrs:attrs -> lid -> expression val constant: ?loc:loc -> ?attrs:attrs -> constant -> expression - val let_: ?loc:loc -> ?attrs:attrs -> rec_flag -> value_binding list -> expression -> expression - val fun_: ?loc:loc -> ?attrs:attrs -> label -> expression option -> pattern -> expression -> expression + val let_: ?loc:loc -> ?attrs:attrs -> rec_flag -> value_binding list + -> expression -> expression + val fun_: ?loc:loc -> ?attrs:attrs -> label -> expression option -> pattern + -> expression -> expression val function_: ?loc:loc -> ?attrs:attrs -> case list -> expression - val apply: ?loc:loc -> ?attrs:attrs -> expression -> (label * expression) list -> expression - val match_: ?loc:loc -> ?attrs:attrs -> expression -> case list -> expression + val apply: ?loc:loc -> ?attrs:attrs -> expression + -> (label * expression) list -> expression + val match_: ?loc:loc -> ?attrs:attrs -> expression -> case list + -> expression val try_: ?loc:loc -> ?attrs:attrs -> expression -> case list -> expression val tuple: ?loc:loc -> ?attrs:attrs -> expression list -> expression - val construct: ?loc:loc -> ?attrs:attrs -> lid -> expression option -> expression - val variant: ?loc:loc -> ?attrs:attrs -> label -> expression option -> expression - val record: ?loc:loc -> ?attrs:attrs -> (lid * expression) list -> expression option -> expression + val construct: ?loc:loc -> ?attrs:attrs -> lid -> expression option + -> expression + val variant: ?loc:loc -> ?attrs:attrs -> label -> expression option + -> expression + val record: ?loc:loc -> ?attrs:attrs -> (lid * expression) list + -> expression option -> expression val field: ?loc:loc -> ?attrs:attrs -> expression -> lid -> expression - val setfield: ?loc:loc -> ?attrs:attrs -> expression -> lid -> expression -> expression + val setfield: ?loc:loc -> ?attrs:attrs -> expression -> lid -> expression + -> expression val array: ?loc:loc -> ?attrs:attrs -> expression list -> expression - val ifthenelse: ?loc:loc -> ?attrs:attrs -> expression -> expression -> expression option -> expression - val sequence: ?loc:loc -> ?attrs:attrs -> expression -> expression -> expression - val while_: ?loc:loc -> ?attrs:attrs -> expression -> expression -> expression - val for_: ?loc:loc -> ?attrs:attrs -> pattern -> expression -> expression -> direction_flag -> expression -> expression - val coerce: ?loc:loc -> ?attrs:attrs -> expression -> core_type option -> core_type -> expression - val constraint_: ?loc:loc -> ?attrs:attrs -> expression -> core_type -> expression + val ifthenelse: ?loc:loc -> ?attrs:attrs -> expression -> expression + -> expression option -> expression + val sequence: ?loc:loc -> ?attrs:attrs -> expression -> expression + -> expression + val while_: ?loc:loc -> ?attrs:attrs -> expression -> expression + -> expression + val for_: ?loc:loc -> ?attrs:attrs -> pattern -> expression -> expression + -> direction_flag -> expression -> expression + val coerce: ?loc:loc -> ?attrs:attrs -> expression -> core_type option + -> core_type -> expression + val constraint_: ?loc:loc -> ?attrs:attrs -> expression -> core_type + -> expression val send: ?loc:loc -> ?attrs:attrs -> expression -> string -> expression val new_: ?loc:loc -> ?attrs:attrs -> lid -> expression val setinstvar: ?loc:loc -> ?attrs:attrs -> str -> expression -> expression - val override: ?loc:loc -> ?attrs:attrs -> (str * expression) list -> expression - val letmodule: ?loc:loc -> ?attrs:attrs -> str -> module_expr -> expression -> expression + val override: ?loc:loc -> ?attrs:attrs -> (str * expression) list + -> expression + val letmodule: ?loc:loc -> ?attrs:attrs -> str -> module_expr -> expression + -> expression val assert_: ?loc:loc -> ?attrs:attrs -> expression -> expression val lazy_: ?loc:loc -> ?attrs:attrs -> expression -> expression val poly: ?loc:loc -> ?attrs:attrs -> expression -> core_type option -> expression @@ -129,12 +152,23 @@ module Val: (** Type declarations *) module Type: sig - val mk: ?loc:loc -> ?attrs:attrs -> ?params:(str option * variance) list -> ?cstrs:(core_type * core_type * loc) list -> ?kind:type_kind -> ?priv:private_flag -> ?manifest:core_type -> str -> type_declaration + val mk: ?loc:loc -> ?attrs:attrs -> ?params:(core_type * variance) list -> ?cstrs:(core_type * core_type * loc) list -> ?kind:type_kind -> ?priv:private_flag -> ?manifest:core_type -> str -> type_declaration val constructor: ?loc:loc -> ?attrs:attrs -> ?args:constructor_arguments -> ?res:core_type -> str -> constructor_declaration val field: ?loc:loc -> ?attrs:attrs -> ?mut:mutable_flag -> str -> core_type -> label_declaration end +(** Type extensions *) +module Te: + sig + val mk: ?attrs:attrs -> ?params:(core_type * variance) list -> ?priv:private_flag -> lid -> extension_constructor list -> type_extension + + val constructor: ?loc:loc -> ?attrs:attrs -> str -> extension_constructor_kind -> extension_constructor + + val decl: ?loc:loc -> ?attrs:attrs -> ?args:constructor_arguments -> ?res:core_type -> str -> extension_constructor + val rebind: ?loc:loc -> ?attrs:attrs -> str -> lid -> extension_constructor + end + (** {2 Module language} *) (** Module type expressions *) @@ -176,12 +210,13 @@ module Sig: val value: ?loc:loc -> value_description -> signature_item val type_: ?loc:loc -> type_declaration list -> signature_item - val exception_: ?loc:loc -> constructor_declaration -> signature_item + val type_extension: ?loc:loc -> type_extension -> signature_item + val exception_: ?loc:loc -> extension_constructor -> signature_item val module_: ?loc:loc -> module_declaration -> signature_item val rec_module: ?loc:loc -> module_declaration list -> signature_item val modtype: ?loc:loc -> module_type_declaration -> signature_item - val open_: ?loc:loc -> ?attrs:attrs -> override_flag -> lid -> signature_item - val include_: ?loc:loc -> ?attrs:attrs -> module_type -> signature_item + val open_: ?loc:loc -> open_description -> signature_item + val include_: ?loc:loc -> include_description -> signature_item val class_: ?loc:loc -> class_description list -> signature_item val class_type: ?loc:loc -> class_type_declaration list -> signature_item val extension: ?loc:loc -> ?attrs:attrs -> extension -> signature_item @@ -197,15 +232,15 @@ module Str: val value: ?loc:loc -> rec_flag -> value_binding list -> structure_item val primitive: ?loc:loc -> value_description -> structure_item val type_: ?loc:loc -> type_declaration list -> structure_item - val exception_: ?loc:loc -> constructor_declaration -> structure_item - val exn_rebind: ?loc:loc -> ?attrs:attrs -> str -> lid -> structure_item + val type_extension: ?loc:loc -> type_extension -> structure_item + val exception_: ?loc:loc -> extension_constructor -> structure_item val module_: ?loc:loc -> module_binding -> structure_item val rec_module: ?loc:loc -> module_binding list -> structure_item val modtype: ?loc:loc -> module_type_declaration -> structure_item - val open_: ?loc:loc -> ?attrs:attrs -> override_flag -> lid -> structure_item + val open_: ?loc:loc -> open_description -> structure_item val class_: ?loc:loc -> class_declaration list -> structure_item val class_type: ?loc:loc -> class_type_declaration list -> structure_item - val include_: ?loc:loc -> ?attrs:attrs -> module_expr -> structure_item + val include_: ?loc:loc -> include_declaration -> structure_item val extension: ?loc:loc -> ?attrs:attrs -> extension -> structure_item val attribute: ?loc:loc -> attribute -> structure_item end @@ -228,11 +263,23 @@ module Mb: val mk: ?loc:loc -> ?attrs:attrs -> str -> module_expr -> module_binding end +(* Opens *) +module Opn: + sig + val mk: ?loc: loc -> ?attrs:attrs -> ?override:override_flag -> lid -> open_description + end + +(* Includes *) +module Incl: + sig + val mk: ?loc: loc -> ?attrs:attrs -> 'a -> 'a include_infos + end + (** Value bindings *) module Vb: sig - val mk: ?attrs:attrs -> pattern -> expression -> value_binding + val mk: ?loc: loc -> ?attrs:attrs -> pattern -> expression -> value_binding end @@ -261,6 +308,7 @@ module Ctf: val method_: ?loc:loc -> ?attrs:attrs -> string -> private_flag -> virtual_flag -> core_type -> class_type_field val constraint_: ?loc:loc -> ?attrs:attrs -> core_type -> core_type -> class_type_field val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_type_field + val attribute: ?loc:loc -> attribute -> class_type_field end (** Class expressions *) @@ -290,6 +338,7 @@ module Cf: val constraint_: ?loc:loc -> ?attrs:attrs -> core_type -> core_type -> class_field val initializer_: ?loc:loc -> ?attrs:attrs -> expression -> class_field val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_field + val attribute: ?loc:loc -> attribute -> class_field val virtual_: core_type -> class_field_kind val concrete: override_flag -> expression -> class_field_kind @@ -298,7 +347,7 @@ module Cf: (** Classes *) module Ci: sig - val mk: ?loc:loc -> ?attrs:attrs -> ?virt:virtual_flag -> ?params:(str * variance) list -> str -> 'a -> 'a class_infos + val mk: ?loc:loc -> ?attrs:attrs -> ?virt:virtual_flag -> ?params:(core_type * variance) list -> str -> 'a -> 'a class_infos end (** Class signatures *) @@ -312,71 +361,3 @@ module Cstr: sig val mk: pattern -> class_field list -> class_structure end - - -(** {2 Convenience functions} *) - -(** Convenience functions to help build and deconstruct AST fragments. *) -module Convenience : - sig - - (** {2 Misc} *) - - val lid: string -> lid - - (** {2 Expressions} *) - - val evar: string -> expression - val let_in: ?recursive:bool -> value_binding list -> expression -> expression - - val constr: string -> expression list -> expression - val record: ?over:expression -> (string * expression) list -> expression - val tuple: expression list -> expression - - val nil: unit -> expression - val cons: expression -> expression -> expression - val list: expression list -> expression - - val unit: unit -> expression - - val func: (pattern * expression) list -> expression - val lam: ?label:string -> ?default:expression -> pattern -> expression -> expression - val app: expression -> expression list -> expression - - val str: string -> expression - val int: int -> expression - val char: char -> expression - val float: float -> expression - - (** {2 Patterns} *) - - val pvar: string -> pattern - val pconstr: string -> pattern list -> pattern - val precord: ?closed:closed_flag -> (string * pattern) list -> pattern - val ptuple: pattern list -> pattern - - val pnil: unit -> pattern - val pcons: pattern -> pattern -> pattern - val plist: pattern list -> pattern - - val pstr: string -> pattern - val pint: int -> pattern - val pchar: char -> pattern - val pfloat: float -> pattern - - val punit: unit -> pattern - - - (** {2 Types} *) - - val tconstr: string -> core_type list -> core_type - - (** {2 AST deconstruction} *) - - val get_str: expression -> string option - val get_lid: expression -> string option - - val has_attr: string -> attributes -> bool - val find_attr: string -> attributes -> payload option - val find_attr_expr: string -> attributes -> expression option - end diff --git a/parsing/ast_mapper.ml b/parsing/ast_mapper.ml index 246319e4d..aa9fdbfca 100644 --- a/parsing/ast_mapper.ml +++ b/parsing/ast_mapper.ml @@ -12,10 +12,13 @@ (* A generic Parsetree mapping class *) -;; [@@warning "+9"] +(* +[@@@ocaml.warning "+9"] (* Ensure that record patterns don't miss any field. *) +*) +open Asttypes open Parsetree open Ast_helper open Location @@ -32,18 +35,26 @@ type mapper = { class_signature: mapper -> class_signature -> class_signature; class_structure: mapper -> class_structure -> class_structure; class_type: mapper -> class_type -> class_type; - class_type_declaration: mapper -> class_type_declaration -> class_type_declaration; + class_type_declaration: mapper -> class_type_declaration + -> class_type_declaration; class_type_field: mapper -> class_type_field -> class_type_field; - constructor_declaration: mapper -> constructor_declaration -> constructor_declaration; + constructor_declaration: mapper -> constructor_declaration + -> constructor_declaration; expr: mapper -> expression -> expression; extension: mapper -> extension -> extension; + extension_constructor: mapper -> extension_constructor + -> extension_constructor; + include_declaration: mapper -> include_declaration -> include_declaration; + include_description: mapper -> include_description -> include_description; label_declaration: mapper -> label_declaration -> label_declaration; location: mapper -> Location.t -> Location.t; module_binding: mapper -> module_binding -> module_binding; module_declaration: mapper -> module_declaration -> module_declaration; module_expr: mapper -> module_expr -> module_expr; module_type: mapper -> module_type -> module_type; - module_type_declaration: mapper -> module_type_declaration -> module_type_declaration; + module_type_declaration: mapper -> module_type_declaration + -> module_type_declaration; + open_description: mapper -> open_description -> open_description; pat: mapper -> pattern -> pattern; payload: mapper -> payload -> payload; signature: mapper -> signature -> signature; @@ -52,6 +63,7 @@ type mapper = { structure_item: mapper -> structure_item -> structure_item; typ: mapper -> core_type -> core_type; type_declaration: mapper -> type_declaration -> type_declaration; + type_extension: mapper -> type_extension -> type_extension; type_kind: mapper -> type_kind -> type_kind; value_binding: mapper -> value_binding -> value_binding; value_description: mapper -> value_description -> value_description; @@ -70,7 +82,8 @@ module T = struct (* Type expressions for the core language *) let row_field sub = function - | Rtag (l, b, tl) -> Rtag (l, b, List.map (sub.typ sub) tl) + | Rtag (l, attrs, b, tl) -> + Rtag (l, sub.attributes sub attrs, b, List.map (sub.typ sub) tl) | Rinherit t -> Rinherit (sub.typ sub t) let map sub {ptyp_desc = desc; ptyp_loc = loc; ptyp_attributes = attrs} = @@ -86,7 +99,8 @@ module T = struct | Ptyp_constr (lid, tl) -> constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl) | Ptyp_object (l, o) -> - object_ ~loc ~attrs (List.map (map_snd (sub.typ sub)) l) o + let f (s, a, t) = (s, sub.attributes sub a, sub.typ sub t) in + object_ ~loc ~attrs (List.map f l) o | Ptyp_class (lid, tl) -> class_ ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl) | Ptyp_alias (t, s) -> alias ~loc ~attrs (sub.typ sub t) s @@ -106,9 +120,10 @@ module T = struct ptype_attributes; ptype_loc} = Type.mk (map_loc sub ptype_name) - ~params:(List.map (map_fst (map_opt (map_loc sub))) ptype_params) + ~params:(List.map (map_fst (sub.typ sub)) ptype_params) ~priv:ptype_private - ~cstrs:(List.map (map_tuple3 (sub.typ sub) (sub.typ sub) (sub.location sub)) + ~cstrs:(List.map + (map_tuple3 (sub.typ sub) (sub.typ sub) (sub.location sub)) ptype_cstrs) ~kind:(sub.type_kind sub ptype_kind) ?manifest:(map_opt (sub.typ sub) ptype_manifest) @@ -120,6 +135,42 @@ module T = struct | Ptype_variant l -> Ptype_variant (List.map (sub.constructor_declaration sub) l) | Ptype_record l -> Ptype_record (List.map (sub.label_declaration sub) l) + | Ptype_open -> Ptype_open + + let map_constructor_arguments sub = function + | Pcstr_tuple l -> Pcstr_tuple (List.map (sub.typ sub) l) + | Pcstr_record l -> + Pcstr_record (List.map (sub.label_declaration sub) l) + + let map_type_extension sub + {ptyext_path; ptyext_params; + ptyext_constructors; + ptyext_private; + ptyext_attributes} = + Te.mk + (map_loc sub ptyext_path) + (List.map (sub.extension_constructor sub) ptyext_constructors) + ~params:(List.map (map_fst (sub.typ sub)) ptyext_params) + ~priv:ptyext_private + ~attrs:(sub.attributes sub ptyext_attributes) + + let map_extension_constructor_kind sub = function + Pext_decl(ctl, cto) -> + Pext_decl(map_constructor_arguments sub ctl, map_opt (sub.typ sub) cto) + | Pext_rebind li -> + Pext_rebind (map_loc sub li) + + let map_extension_constructor sub + {pext_name; + pext_kind; + pext_loc; + pext_attributes} = + Te.constructor + (map_loc sub pext_name) + (map_extension_constructor_kind sub pext_kind) + ~loc:(sub.location sub pext_loc) + ~attrs:(sub.attributes sub pext_attributes) + end module CT = struct @@ -146,6 +197,7 @@ module CT = struct | Pctf_method (s, p, v, t) -> method_ ~loc ~attrs s p v (sub.typ sub t) | Pctf_constraint (t1, t2) -> constraint_ ~loc ~attrs (sub.typ sub t1) (sub.typ sub t2) + | Pctf_attribute x -> attribute ~loc (sub.attribute sub x) | Pctf_extension x -> extension ~loc ~attrs (sub.extension sub x) let map_signature sub {pcsig_self; pcsig_fields} = @@ -190,15 +242,14 @@ module MT = struct match desc with | Psig_value vd -> value ~loc (sub.value_description sub vd) | Psig_type l -> type_ ~loc (List.map (sub.type_declaration sub) l) - | Psig_exception ed -> exception_ ~loc (sub.constructor_declaration sub ed) + | Psig_typext te -> type_extension ~loc (sub.type_extension sub te) + | Psig_exception ed -> exception_ ~loc (sub.extension_constructor sub ed) | Psig_module x -> module_ ~loc (sub.module_declaration sub x) | Psig_recmodule l -> rec_module ~loc (List.map (sub.module_declaration sub) l) | Psig_modtype x -> modtype ~loc (sub.module_type_declaration sub x) - | Psig_open (ovf, lid, attrs) -> - open_ ~loc ~attrs:(sub.attributes sub attrs) ovf (map_loc sub lid) - | Psig_include (mt, attrs) -> - include_ ~loc (sub.module_type sub mt) ~attrs:(sub.attributes sub attrs) + | Psig_open x -> open_ ~loc (sub.open_description sub x) + | Psig_include x -> include_ ~loc (sub.include_description sub x) | Psig_class l -> class_ ~loc (List.map (sub.class_description sub) l) | Psig_class_type l -> class_type ~loc (List.map (sub.class_type_declaration sub) l) @@ -225,7 +276,8 @@ module M = struct | Pmod_apply (m1, m2) -> apply ~loc ~attrs (sub.module_expr sub m1) (sub.module_expr sub m2) | Pmod_constraint (m, mty) -> - constraint_ ~loc ~attrs (sub.module_expr sub m) (sub.module_type sub mty) + constraint_ ~loc ~attrs (sub.module_expr sub m) + (sub.module_type sub mty) | Pmod_unpack e -> unpack ~loc ~attrs (sub.expr sub e) | Pmod_extension x -> extension ~loc ~attrs (sub.extension sub x) @@ -238,20 +290,16 @@ module M = struct | Pstr_value (r, vbs) -> value ~loc r (List.map (sub.value_binding sub) vbs) | Pstr_primitive vd -> primitive ~loc (sub.value_description sub vd) | Pstr_type l -> type_ ~loc (List.map (sub.type_declaration sub) l) - | Pstr_exception ed -> exception_ ~loc (sub.constructor_declaration sub ed) - | Pstr_exn_rebind (s, lid, attrs) -> - exn_rebind ~loc (map_loc sub s) (map_loc sub lid) - ~attrs:(sub.attributes sub attrs) + | Pstr_typext te -> type_extension ~loc (sub.type_extension sub te) + | Pstr_exception ed -> exception_ ~loc (sub.extension_constructor sub ed) | Pstr_module x -> module_ ~loc (sub.module_binding sub x) | Pstr_recmodule l -> rec_module ~loc (List.map (sub.module_binding sub) l) | Pstr_modtype x -> modtype ~loc (sub.module_type_declaration sub x) - | Pstr_open (ovf, lid, attrs) -> - open_ ~loc ~attrs:(sub.attributes sub attrs) ovf (map_loc sub lid) + | Pstr_open x -> open_ ~loc (sub.open_description sub x) | Pstr_class l -> class_ ~loc (List.map (sub.class_declaration sub) l) | Pstr_class_type l -> class_type ~loc (List.map (sub.class_type_declaration sub) l) - | Pstr_include (e, attrs) -> - include_ ~loc (sub.module_expr sub e) ~attrs:(sub.attributes sub attrs) + | Pstr_include x -> include_ ~loc (sub.include_declaration sub x) | Pstr_extension (x, attrs) -> extension ~loc (sub.extension sub x) ~attrs:(sub.attributes sub attrs) | Pstr_attribute x -> attribute ~loc (sub.attribute sub x) @@ -298,7 +346,8 @@ module E = struct (map_opt (sub.expr sub) e3) | Pexp_sequence (e1, e2) -> sequence ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) - | Pexp_while (e1, e2) -> while_ ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) + | Pexp_while (e1, e2) -> + while_ ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) | Pexp_for (p, e1, e2, d, e3) -> for_ ~loc ~attrs (sub.pat sub p) (sub.expr sub e1) (sub.expr sub e2) d (sub.expr sub e3) @@ -347,8 +396,8 @@ module P = struct construct ~loc ~attrs (map_loc sub l) (map_opt (sub.pat sub) p) | Ppat_variant (l, p) -> variant ~loc ~attrs l (map_opt (sub.pat sub) p) | Ppat_record (lpl, cf) -> - record ~loc ~attrs (List.map (map_tuple (map_loc sub) (sub.pat sub)) lpl) - cf + record ~loc ~attrs + (List.map (map_tuple (map_loc sub) (sub.pat sub)) lpl) cf | Ppat_array pl -> array ~loc ~attrs (List.map (sub.pat sub) pl) | Ppat_or (p1, p2) -> or_ ~loc ~attrs (sub.pat sub p1) (sub.pat sub p2) | Ppat_constraint (p, t) -> @@ -356,6 +405,7 @@ module P = struct | Ppat_type s -> type_ ~loc ~attrs (map_loc sub s) | Ppat_lazy p -> lazy_ ~loc ~attrs (sub.pat sub p) | Ppat_unpack s -> unpack ~loc ~attrs (map_loc sub s) + | Ppat_exception p -> exception_ ~loc ~attrs (sub.pat sub p) | Ppat_extension x -> extension ~loc ~attrs (sub.extension sub x) end @@ -400,6 +450,7 @@ module CE = struct | Pcf_constraint (t1, t2) -> constraint_ ~loc ~attrs (sub.typ sub t1) (sub.typ sub t2) | Pcf_initializer e -> initializer_ ~loc ~attrs (sub.expr sub e) + | Pcf_attribute x -> attribute ~loc (sub.attribute sub x) | Pcf_extension x -> extension ~loc ~attrs (sub.extension sub x) let map_structure sub {pcstr_self; pcstr_fields} = @@ -411,8 +462,8 @@ module CE = struct let class_infos sub f {pci_virt; pci_params = pl; pci_name; pci_expr; pci_loc; pci_attributes} = Ci.mk - ~virt:pci_virt - ~params:(List.map (map_fst (map_loc sub)) pl) + ~virt:pci_virt + ~params:(List.map (map_fst (sub.typ sub)) pl) (map_loc sub pci_name) (f pci_expr) ~loc:(sub.location sub pci_loc) @@ -447,7 +498,8 @@ let default_mapper = type_declaration = T.map_type_declaration; type_kind = T.map_type_kind; typ = T.map; - + type_extension = T.map_type_extension; + extension_constructor = T.map_extension_constructor; value_description = (fun this {pval_name; pval_type; pval_prim; pval_loc; pval_attributes} -> @@ -487,26 +539,46 @@ let default_mapper = ~loc:(this.location this pmb_loc) ); + + open_description = + (fun this {popen_lid; popen_override; popen_attributes; popen_loc} -> + Opn.mk (map_loc this popen_lid) + ~override:popen_override + ~loc:(this.location this popen_loc) + ~attrs:(this.attributes this popen_attributes) + ); + + + include_description = + (fun this {pincl_mod; pincl_attributes; pincl_loc} -> + Incl.mk (this.module_type this pincl_mod) + ~loc:(this.location this pincl_loc) + ~attrs:(this.attributes this pincl_attributes) + ); + + include_declaration = + (fun this {pincl_mod; pincl_attributes; pincl_loc} -> + Incl.mk (this.module_expr this pincl_mod) + ~loc:(this.location this pincl_loc) + ~attrs:(this.attributes this pincl_attributes) + ); + + value_binding = - (fun this {pvb_pat; pvb_expr; pvb_attributes} -> + (fun this {pvb_pat; pvb_expr; pvb_attributes; pvb_loc} -> Vb.mk (this.pat this pvb_pat) (this.expr this pvb_expr) + ~loc:(this.location this pvb_loc) ~attrs:(this.attributes this pvb_attributes) ); constructor_declaration = (fun this {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} -> - let args = - match pcd_args with - | Pcstr_tuple l -> Pcstr_tuple (List.map (this.typ this) l) - | Pcstr_record l -> - Pcstr_record (List.map (this.label_declaration this) l) - in Type.constructor (map_loc this pcd_name) - ~args + ~args:(T.map_constructor_arguments this pcd_args) ?res:(map_opt (this.typ this) pcd_res) ~loc:(this.location this pcd_loc) ~attrs:(this.attributes this pcd_attributes) @@ -547,23 +619,235 @@ let default_mapper = ); } +let rec extension_of_error {loc; msg; if_highlight; sub} = + { loc; txt = "ocaml.error" }, + PStr ([Str.eval (Exp.constant (Const_string (msg, None))); + Str.eval (Exp.constant (Const_string (if_highlight, None)))] @ + (List.map (fun ext -> Str.extension (extension_of_error ext)) sub)) + +let attribute_of_warning loc s = + { loc; txt = "ocaml.ppwarning" }, + PStr ([Str.eval ~loc (Exp.constant (Const_string (s, None)))]) + +module StringMap = Map.Make(struct + type t = string + let compare = compare +end) + +let cookies = ref StringMap.empty + +let get_cookie k = + try Some (StringMap.find k !cookies) + with Not_found -> None + +let set_cookie k v = + cookies := StringMap.add k v !cookies + +let tool_name_ref = ref "_none_" + +let tool_name () = !tool_name_ref + + +module PpxContext = struct + open Longident + open Asttypes + open Ast_helper + + let lid name = { txt = Lident name; loc = Location.none } + + let make_string x = Exp.constant (Const_string (x, None)) + + let make_bool x = + if x + then Exp.construct (lid "true") None + else Exp.construct (lid "false") None + + let rec make_list f lst = + match lst with + | x :: rest -> + Exp.construct (lid "::") (Some (Exp.tuple [f x; make_list f rest])) + | [] -> + Exp.construct (lid "[]") None + + let make_pair f1 f2 (x1, x2) = + Exp.tuple [f1 x1; f2 x2] + + let make_option f opt = + match opt with + | Some x -> Exp.construct (lid "Some") (Some (f x)) + | None -> Exp.construct (lid "None") None + + let get_cookies () = + lid "cookies", + make_list (make_pair make_string (fun x -> x)) + (StringMap.bindings !cookies) + + let mk fields = + { txt = "ocaml.ppx.context"; loc = Location.none }, + Parsetree.PStr [Str.eval (Exp.record fields None)] + + let make ~tool_name () = + let fields = + [ + lid "tool_name", make_string tool_name; + lid "include_dirs", make_list make_string !Clflags.include_dirs; + lid "load_path", make_list make_string !Config.load_path; + lid "open_modules", make_list make_string !Clflags.open_modules; + lid "for_package", make_option make_string !Clflags.for_package; + lid "debug", make_bool !Clflags.debug; + get_cookies () + ] + in + mk fields + + let get_fields = function + | PStr [{pstr_desc = Pstr_eval + ({ pexp_desc = Pexp_record (fields, None) }, [])}] -> + fields + | _ -> + raise_errorf "Internal error: invalid [@@@ocaml.ppx.context] syntax" + + let restore fields = + let field name payload = + let rec get_string = function + | { pexp_desc = Pexp_constant (Const_string (str, None)) } -> str + | _ -> + raise_errorf + "Internal error: invalid [@@@ocaml.ppx.context { %s }] string syntax" + name + and get_bool pexp = + match pexp with + | {pexp_desc = Pexp_construct ({txt = Longident.Lident "true"}, None)} -> + true + | {pexp_desc = Pexp_construct ({txt = Longident.Lident "false"}, None)} -> + false + | _ -> + raise_errorf + "Internal error: invalid [@@@ocaml.ppx.context { %s }] bool syntax" + name + and get_list elem = function + | {pexp_desc = + Pexp_construct ({txt = Longident.Lident "::"}, + Some {pexp_desc = Pexp_tuple [exp; rest]}) } -> + elem exp :: get_list elem rest + | {pexp_desc = + Pexp_construct ({txt = Longident.Lident "[]"}, None)} -> + [] + | _ -> + raise_errorf + "Internal error: invalid [@@@ocaml.ppx.context { %s }] list syntax" + name + and get_pair f1 f2 = function + | {pexp_desc = Pexp_tuple [e1; e2]} -> + (f1 e1, f2 e2) + | _ -> + raise_errorf + "Internal error: invalid [@@@ocaml.ppx.context { %s }] pair syntax" + name + and get_option elem = function + | { pexp_desc = + Pexp_construct ({ txt = Longident.Lident "Some" }, Some exp) } -> + Some (elem exp) + | { pexp_desc = + Pexp_construct ({ txt = Longident.Lident "None" }, None) } -> + None + | _ -> + raise_errorf + "Internal error: invalid [@@@ocaml.ppx.context { %s }] option syntax" + name + in + match name with + | "tool_name" -> + tool_name_ref := get_string payload + | "include_dirs" -> + Clflags.include_dirs := get_list get_string payload + | "load_path" -> + Config.load_path := get_list get_string payload + | "open_modules" -> + Clflags.open_modules := get_list get_string payload + | "for_package" -> + Clflags.for_package := get_option get_string payload + | "debug" -> + Clflags.debug := get_bool payload + | "cookies" -> + let l = get_list (get_pair get_string (fun x -> x)) payload in + cookies := + List.fold_left + (fun s (k, v) -> StringMap.add k v s) StringMap.empty + l + | _ -> + () + in + List.iter (function ({txt=Lident name}, x) -> field name x | _ -> ()) fields + + let update_cookies fields = + let fields = + List.filter + (function ({txt=Lident "cookies"}, _) -> false | _ -> true) + fields + in + fields @ [get_cookies ()] +end +let ppx_context = PpxContext.make -let apply ~source ~target mapper = + +let apply_lazy ~source ~target mapper = let ic = open_in_bin source in - let magic = String.create (String.length Config.ast_impl_magic_number) in - really_input ic magic 0 (String.length magic); + let magic = + really_input_string ic (String.length Config.ast_impl_magic_number) + in if magic <> Config.ast_impl_magic_number && magic <> Config.ast_intf_magic_number then - failwith "Ast_mapper: unknown magic number"; + failwith "Ast_mapper: OCaml version mismatch or malformed input"; Location.input_name := input_value ic; let ast = input_value ic in close_in ic; + let implem ast = + try + let fields, ast = + match ast with + | {pstr_desc = Pstr_attribute ({txt = "ocaml.ppx.context"}, x)} :: l -> + PpxContext.get_fields x, l + | _ -> [], ast + in + PpxContext.restore fields; + let mapper = mapper () in + let ast = mapper.structure mapper ast in + let fields = PpxContext.update_cookies fields in + Str.attribute (PpxContext.mk fields) :: ast + with exn -> + match error_of_exn exn with + | Some error -> + [{pstr_desc = Pstr_extension (extension_of_error error, []); + pstr_loc = Location.none}] + | None -> raise exn + in + let iface ast = + try + let fields, ast = + match ast with + | {psig_desc = Psig_attribute ({txt = "ocaml.ppx.context"}, x)} :: l -> + PpxContext.get_fields x, l + | _ -> [], ast + in + PpxContext.restore fields; + let mapper = mapper () in + let ast = mapper.signature mapper ast in + let fields = PpxContext.update_cookies fields in + Sig.attribute (PpxContext.mk fields) :: ast + with exn -> + match error_of_exn exn with + | Some error -> + [{psig_desc = Psig_extension (extension_of_error error, []); + psig_loc = Location.none}] + | None -> raise exn + in let ast = if magic = Config.ast_impl_magic_number - then Obj.magic (mapper.structure mapper (Obj.magic ast)) - else Obj.magic (mapper.signature mapper (Obj.magic ast)) + then Obj.magic (implem (Obj.magic ast)) + else Obj.magic (iface (Obj.magic ast)) in let oc = open_out_bin target in output_string oc magic; @@ -571,24 +855,53 @@ let apply ~source ~target mapper = output_value oc ast; close_out oc +let drop_ppx_context_str ~restore = function + | {pstr_desc = Pstr_attribute({Location.txt = "ocaml.ppx.context"}, a)} + :: items -> + if restore then + PpxContext.restore (PpxContext.get_fields a); + items + | items -> items + +let drop_ppx_context_sig ~restore = function + | {psig_desc = Psig_attribute({Location.txt = "ocaml.ppx.context"}, a)} + :: items -> + if restore then + PpxContext.restore (PpxContext.get_fields a); + items + | items -> items + +let add_ppx_context_str ~tool_name ast = + Ast_helper.Str.attribute (ppx_context ~tool_name ()) :: ast + +let add_ppx_context_sig ~tool_name ast = + Ast_helper.Sig.attribute (ppx_context ~tool_name ()) :: ast + + +let apply ~source ~target mapper = + apply_lazy ~source ~target (fun () -> mapper) + let run_main mapper = try let a = Sys.argv in let n = Array.length a in if n > 2 then - apply ~source:a.(n - 2) ~target:a.(n - 1) - (mapper (Array.to_list (Array.sub a 1 (n - 3)))) + let mapper () = + try mapper (Array.to_list (Array.sub a 1 (n - 3))) + with exn -> + (* PR #6463 *) + let f _ _ = raise exn in + {default_mapper with structure = f; signature = f} + in + apply_lazy ~source:a.(n - 2) ~target:a.(n - 1) mapper else begin Printf.eprintf "Usage: %s [extra_args] <infile> <outfile>\n%!" Sys.executable_name; exit 2 end with exn -> - begin try Location.report_exception Format.err_formatter exn - with exn -> prerr_endline (Printexc.to_string exn) - end; + prerr_endline (Printexc.to_string exn); exit 2 let register_function = ref (fun _name f -> run_main f) let register name f = !register_function name f - diff --git a/parsing/ast_mapper.mli b/parsing/ast_mapper.mli index c71db50a7..d48971d58 100644 --- a/parsing/ast_mapper.mli +++ b/parsing/ast_mapper.mli @@ -10,7 +10,40 @@ (* *) (***********************************************************************) -(** Helpers to write Parsetree rewriters *) +(** The interface of a -ppx rewriter + + A -ppx rewriter is a program that accepts a serialized abstract syntax + tree and outputs another, possibly modified, abstract syntax tree. + This module encapsulates the interface between the compiler and + the -ppx rewriters, handling such details as the serialization format, + forwarding of command-line flags, and storing state. + + {!mapper} allows to implement AST rewriting using open recursion. + A typical mapper would be based on {!default_mapper}, a deep + identity mapper, and will fall back on it for handling the syntax it + does not modify. For example: + + {[ +open Asttypes +open Parsetree +open Ast_mapper + +let test_mapper argv = + { default_mapper with + expr = fun mapper expr -> + match expr with + | { pexp_desc = Pexp_extension ({ txt = "test" }, PStr [])} -> + Ast_helper.Exp.constant (Const_int 42) + | other -> default_mapper.expr mapper other; } + +let () = + register "ppx_test" test_mapper]} + + This -ppx rewriter, which replaces [[%test]] in expressions with + the constant [42], can be compiled using + [ocamlc -o ppx_test -I +compiler-libs ocamlcommon.cma ppx_test.ml]. + + *) open Parsetree @@ -28,18 +61,26 @@ type mapper = { class_signature: mapper -> class_signature -> class_signature; class_structure: mapper -> class_structure -> class_structure; class_type: mapper -> class_type -> class_type; - class_type_declaration: mapper -> class_type_declaration -> class_type_declaration; + class_type_declaration: mapper -> class_type_declaration + -> class_type_declaration; class_type_field: mapper -> class_type_field -> class_type_field; - constructor_declaration: mapper -> constructor_declaration -> constructor_declaration; + constructor_declaration: mapper -> constructor_declaration + -> constructor_declaration; expr: mapper -> expression -> expression; extension: mapper -> extension -> extension; + extension_constructor: mapper -> extension_constructor + -> extension_constructor; + include_declaration: mapper -> include_declaration -> include_declaration; + include_description: mapper -> include_description -> include_description; label_declaration: mapper -> label_declaration -> label_declaration; location: mapper -> Location.t -> Location.t; module_binding: mapper -> module_binding -> module_binding; module_declaration: mapper -> module_declaration -> module_declaration; module_expr: mapper -> module_expr -> module_expr; module_type: mapper -> module_type -> module_type; - module_type_declaration: mapper -> module_type_declaration -> module_type_declaration; + module_type_declaration: mapper -> module_type_declaration + -> module_type_declaration; + open_description: mapper -> open_description -> open_description; pat: mapper -> pattern -> pattern; payload: mapper -> payload -> payload; signature: mapper -> signature -> signature; @@ -48,6 +89,7 @@ type mapper = { structure_item: mapper -> structure_item -> structure_item; typ: mapper -> core_type -> core_type; type_declaration: mapper -> type_declaration -> type_declaration; + type_extension: mapper -> type_extension -> type_extension; type_kind: mapper -> type_kind -> type_kind; value_binding: mapper -> value_binding -> value_binding; value_description: mapper -> value_description -> value_description; @@ -63,6 +105,16 @@ val default_mapper: mapper (** {2 Apply mappers to compilation units} *) +val tool_name: unit -> string +(** Can be used within a ppx preprocessor to know which tool is + calling it ["ocamlc"], ["ocamlopt"], ["ocamldoc"], ["ocamldep"], + ["ocaml"], ... Some global variables that reflect command-line + options are automatically synchronized between the calling tool + and the ppx preprocessor: [Clflags.include_dirs], + [Config.load_path], [Clflags.open_modules], [Clflags.for_package], + [Clflags.debug]. *) + + val apply: source:string -> target:string -> mapper -> unit (** Apply a mapper (parametrized by the unit name) to a dumped parsetree found in the [source] file and put the result in the @@ -81,7 +133,6 @@ val run_main: (string list -> mapper) -> unit val register_function: (string -> (string list -> mapper) -> unit) ref val register: string -> (string list -> mapper) -> unit - (** Apply the [register_function]. The default behavior is to run the mapper immediately, taking arguments from the process command line. This is to support a scenario where a mapper is linked as a @@ -102,3 +153,41 @@ val register: string -> (string list -> mapper) -> unit (** {2 Convenience functions to write mappers} *) val map_opt: ('a -> 'b) -> 'a option -> 'b option + +val extension_of_error: Location.error -> extension +(** Encode an error into an 'ocaml.error' extension node which can be + inserted in a generated Parsetree. The compiler will be + responsible for reporting the error. *) + +val attribute_of_warning: Location.t -> string -> attribute +(** Encode a warning message into an 'ocaml.ppwarning' attribute which can be + inserted in a generated Parsetree. The compiler will be + responsible for reporting the warning. *) + +(** {2 Helper functions to call external mappers} *) + +val add_ppx_context_str: tool_name:string -> Parsetree.structure -> Parsetree.structure +(** Extract information from the current environment and encode it + into an attribute which is prepended to the list of structure + items in order to pass the information to an external + processor. *) + +val add_ppx_context_sig: tool_name:string -> Parsetree.signature -> Parsetree.signature +(** Same as [add_ppx_context_str], but for signatures. *) + +val drop_ppx_context_str: restore:bool -> Parsetree.structure -> Parsetree.structure +(** Drop the ocaml.ppx.context attribute from a structure. If + [restore] is true, also restore the associated data in the current + process. *) + +val drop_ppx_context_sig: restore:bool -> Parsetree.signature -> Parsetree.signature +(** Same as [drop_ppx_context_str], but for signatures. *) + +(** {2 Cookies} *) + +(** Cookies are used to pass information from a ppx processor to + a further invocation of itself, when called from the OCaml + toplevel (or other tools that support cookies). *) + +val set_cookie: string -> Parsetree.expression -> unit +val get_cookie: string -> Parsetree.expression option diff --git a/parsing/lexer.mli b/parsing/lexer.mli index b54f11104..9898e9719 100644 --- a/parsing/lexer.mli +++ b/parsing/lexer.mli @@ -40,3 +40,22 @@ val in_string : unit -> bool;; val print_warnings : bool ref val comments : unit -> (string * Location.t) list val token_with_comments : Lexing.lexbuf -> Parser.token + +(* + [set_preprocessor init preprocessor] registers [init] as the function +to call to initialize the preprocessor when the lexer is initialized, +and [preprocessor] a function that is called when a new token is needed +by the parser, as [preprocessor lexer lexbuf] where [lexer] is the +lexing function. + +When a preprocessor is configured by calling [set_preprocessor], the lexer +changes its behavior: +- It accepts backslash-newline as a token-separating blank. +- It emits an EOL token for every newline except those preceeded by backslash + and those in strings or comments. +*) + +val set_preprocessor : + (unit -> unit) -> + ((Lexing.lexbuf -> Parser.token) -> Lexing.lexbuf -> Parser.token) -> + unit diff --git a/parsing/lexer.mll b/parsing/lexer.mll index 910027c04..237b44764 100644 --- a/parsing/lexer.mll +++ b/parsing/lexer.mll @@ -94,7 +94,7 @@ let keyword_table = (* To buffer string literals *) -let initial_string_buffer = String.create 256 +let initial_string_buffer = Bytes.create 256 let string_buff = ref initial_string_buffer let string_index = ref 0 @@ -103,12 +103,12 @@ let reset_string_buffer () = string_index := 0 let store_string_char c = - if !string_index >= String.length (!string_buff) then begin - let new_buff = String.create (String.length (!string_buff) * 2) in - String.blit (!string_buff) 0 new_buff 0 (String.length (!string_buff)); - string_buff := new_buff + if !string_index >= Bytes.length !string_buff then begin + let new_buff = Bytes.create (Bytes.length (!string_buff) * 2) in + Bytes.blit !string_buff 0 new_buff 0 (Bytes.length !string_buff); + string_buff := new_buff end; - String.unsafe_set (!string_buff) (!string_index) c; + Bytes.unsafe_set !string_buff !string_index c; incr string_index let store_string s = @@ -120,7 +120,7 @@ let store_lexeme lexbuf = store_string (Lexing.lexeme lexbuf) let get_stored_string () = - let s = String.sub (!string_buff) 0 (!string_index) in + let s = Bytes.sub_string !string_buff 0 !string_index in string_buff := initial_string_buffer; s @@ -181,13 +181,14 @@ let cvt_nativeint_literal s = let remove_underscores s = let l = String.length s in + let b = Bytes.create l in let rec remove src dst = if src >= l then - if dst >= l then s else String.sub s 0 dst + if dst >= l then s else Bytes.sub_string b 0 dst else match s.[src] with '_' -> remove (src + 1) dst - | c -> s.[dst] <- c; remove (src + 1) (dst + 1) + | c -> Bytes.set b dst c; remove (src + 1) (dst + 1) in remove 0 0 (* recover the name from a LABEL or OPTLABEL token *) @@ -215,6 +216,8 @@ let update_loc lexbuf file line absolute chars = } ;; +let preprocessor = ref None + (* Warn about Latin-1 characters used in idents *) let warn_latin1 lexbuf = @@ -236,8 +239,9 @@ let report_error ppf = function | Unterminated_string -> fprintf ppf "String literal not terminated" | Unterminated_string_in_comment (_, loc) -> - fprintf ppf "This comment contains an unterminated string literal@.%aString literal begins here" - Location.print_error loc + fprintf ppf "This comment contains an unterminated string literal@.\ + %aString literal begins here" + Location.print_error loc | Keyword_as_label kwd -> fprintf ppf "`%s' is a keyword, it cannot be used as label name" kwd | Literal_overflow ty -> @@ -255,7 +259,7 @@ let () = } -let newline = ('\013'* '\010' ) +let newline = ('\013'* '\010') let blank = [' ' '\009' '\012'] let lowercase = ['a'-'z' '_'] let uppercase = ['A'-'Z'] @@ -282,9 +286,19 @@ let float_literal = (['e' 'E'] ['+' '-']? ['0'-'9'] ['0'-'9' '_']*)? rule token = parse + | "\\" newline { + match !preprocessor with + | None -> + raise (Error(Illegal_character (Lexing.lexeme_char lexbuf 0), + Location.curr lexbuf)) + | Some _ -> + update_loc lexbuf None 1 false 0; + token lexbuf } | newline { update_loc lexbuf None 1 false 0; - token lexbuf + match !preprocessor with + | None -> token lexbuf + | Some _ -> EOL } | blank + { token lexbuf } @@ -445,10 +459,12 @@ rule token = parse | "[%" { LBRACKETPERCENT } | "[%%" { LBRACKETPERCENTPERCENT } | "[@@" { LBRACKETATAT } + | "[@@@" { LBRACKETATATAT } | "!" { BANG } | "!=" { INFIXOP0 "!=" } | "+" { PLUS } | "+." { PLUSDOT } + | "+=" { PLUSEQ } | "-" { MINUS } | "-." { MINUSDOT } @@ -519,7 +535,8 @@ and comment = parse | loc :: _ -> let start = List.hd (List.rev !comment_start_loc) in comment_start_loc := []; - raise (Error (Unterminated_string_in_comment (start, str_start), loc)) + raise (Error (Unterminated_string_in_comment (start, str_start), + loc)) end; is_in_string := false; store_string_char '|'; @@ -631,7 +648,11 @@ and skip_sharp_bang = parse | "" { () } { - let token_with_comments = token + + let token_with_comments lexbuf = + match !preprocessor with + | None -> token lexbuf + | Some (_init, preprocess) -> preprocess token lexbuf let last_comments = ref [] let rec token lexbuf = @@ -641,9 +662,16 @@ and skip_sharp_bang = parse token lexbuf | tok -> tok let comments () = List.rev !last_comments + let init () = is_in_string := false; last_comments := []; - comment_start_loc := [] + comment_start_loc := []; + match !preprocessor with + | None -> () + | Some (init, _preprocess) -> init () + + let set_preprocessor init preprocess = + preprocessor := Some (init, preprocess) } diff --git a/parsing/location.ml b/parsing/location.ml index 132021f5b..c6d1704f1 100644 --- a/parsing/location.ml +++ b/parsing/location.ml @@ -83,7 +83,7 @@ let highlight_terminfo ppf num_lines lb locs = (* Count number of lines in phrase *) let lines = ref !num_loc_lines in for i = pos0 to lb.lex_buffer_len - 1 do - if lb.lex_buffer.[i] = '\n' then incr lines + if Bytes.get lb.lex_buffer i = '\n' then incr lines done; (* If too many lines, give up *) if !lines >= num_lines - 2 then raise Exit; @@ -98,7 +98,7 @@ let highlight_terminfo ppf num_lines lb locs = Terminfo.standout true; if List.exists (fun loc -> pos = loc.loc_end.pos_cnum) locs then Terminfo.standout false; - let c = lb.lex_buffer.[pos + pos0] in + let c = Bytes.get lb.lex_buffer (pos + pos0) in print_char c; bol := (c = '\n') done; @@ -119,7 +119,7 @@ let highlight_dumb ppf lb loc = (* Determine line numbers for the start and end points *) let line_start = ref 0 and line_end = ref 0 in for pos = 0 to end_pos do - if lb.lex_buffer.[pos + pos0] = '\n' then begin + if Bytes.get lb.lex_buffer (pos + pos0) = '\n' then begin if loc.loc_start.pos_cnum > pos then incr line_start; if loc.loc_end.pos_cnum > pos then incr line_end; end @@ -132,7 +132,7 @@ let highlight_dumb ppf lb loc = let line = ref 0 in let pos_at_bol = ref 0 in for pos = 0 to end_pos do - match lb.lex_buffer.[pos + pos0] with + match Bytes.get lb.lex_buffer (pos + pos0) with | '\n' -> if !line = !line_start && !line = !line_end then begin (* loc is on one line: underline location *) @@ -333,7 +333,8 @@ let rec report_error ppf ({loc; msg; sub; if_highlight} as err) = else begin print ppf loc; Format.pp_print_string ppf msg; - List.iter (fun err -> Format.fprintf ppf "@\n@[<2>%a@]" report_error err) sub + List.iter (fun err -> Format.fprintf ppf "@\n@[<2>%a@]" report_error err) + sub end let error_of_printer loc print x = @@ -366,3 +367,16 @@ let report_exception ppf exn = match error_of_exn exn with | Some err -> fprintf ppf "@[%a@]@." report_error err | None -> raise exn + + +exception Error of error + +let () = + register_error_of_exn + (function + | Error e -> Some e + | _ -> None + ) + +let raise_errorf ?(loc = none) ?(sub = []) ?(if_highlight = "") = + Printf.ksprintf (fun msg -> raise (Error ({loc; msg; sub; if_highlight}))) diff --git a/parsing/location.mli b/parsing/location.mli index e6df9d1f6..1a7feeb4d 100644 --- a/parsing/location.mli +++ b/parsing/location.mli @@ -69,6 +69,8 @@ val mkloc : 'a -> t -> 'a loc val print: formatter -> t -> unit val print_filename: formatter -> string -> unit +val absolute_path: string -> string + val show_filename: string -> string (** In -absname mode, return the absolute path for this filename. Otherwise, returns the filename unchanged. *) @@ -87,9 +89,15 @@ type error = if_highlight: string; (* alternative message if locations are highlighted *) } +exception Error of error + val error: ?loc:t -> ?sub:error list -> ?if_highlight:string -> string -> error -val errorf: ?loc:t -> ?sub:error list -> ?if_highlight:string -> ('a, unit, string, error) format4 -> 'a +val errorf: ?loc:t -> ?sub:error list -> ?if_highlight:string + -> ('a, unit, string, error) format4 -> 'a + +val raise_errorf: ?loc:t -> ?sub:error list -> ?if_highlight:string + -> ('a, unit, string, 'b) format4 -> 'a val error_of_printer: t -> (formatter -> 'a -> unit) -> 'a -> error diff --git a/parsing/parser.mly b/parsing/parser.mly index e6fbdde6d..26bbdc1e9 100644 --- a/parsing/parser.mly +++ b/parsing/parser.mly @@ -67,6 +67,7 @@ let ghexp d = Exp.mk ~loc:(symbol_gloc ()) d let ghpat d = Pat.mk ~loc:(symbol_gloc ()) d let ghtyp d = Typ.mk ~loc:(symbol_gloc ()) d let ghloc d = { txt = d; loc = symbol_gloc () } +let ghstr d = Str.mk ~loc:(symbol_gloc()) d let ghunit () = ghexp (Pexp_construct (mknoloc (Lident "()"), None)) @@ -236,7 +237,8 @@ let varify_constructors var_names t = | Ptyp_constr(longident, lst) -> Ptyp_constr(longident, List.map loop lst) | Ptyp_object (lst, o) -> - Ptyp_object (List.map (fun (s, t) -> (s, loop t)) lst, o) + Ptyp_object + (List.map (fun (s, attrs, t) -> (s, attrs, loop t)) lst, o) | Ptyp_class (longident, lst) -> Ptyp_class (longident, List.map loop lst) | Ptyp_alias(core_type, string) -> @@ -256,8 +258,8 @@ let varify_constructors var_names t = {t with ptyp_desc = desc} and loop_row_field = function - | Rtag(label,flag,lst) -> - Rtag(label,flag,List.map loop lst) + | Rtag(label,attrs,flag,lst) -> + Rtag(label,attrs,flag,List.map loop lst) | Rinherit t -> Rinherit (loop t) in @@ -281,6 +283,12 @@ let wrap_exp_attrs body (ext, attrs) = let mkexp_attrs d attrs = wrap_exp_attrs (mkexp d) attrs +let mkcf_attrs d attrs = + Cf.mk ~loc:(symbol_rloc()) ~attrs d + +let mkctf_attrs d attrs = + Ctf.mk ~loc:(symbol_rloc()) ~attrs d + %} /* Tokens */ @@ -354,6 +362,7 @@ let mkexp_attrs d attrs = %token LPAREN %token LBRACKETAT %token LBRACKETATAT +%token LBRACKETATATAT %token MATCH %token METHOD %token MINUS @@ -372,6 +381,7 @@ let mkexp_attrs d attrs = %token PERCENT %token PLUS %token PLUSDOT +%token PLUSEQ %token <string> PREFIXOP %token PRIVATE %token QUESTION @@ -402,6 +412,8 @@ let mkexp_attrs d attrs = %token WITH %token <string * Location.t> COMMENT +%token EOL + /* Precedences and associativities. Tokens and rules have precedences. A reduce/reduce conflict is resolved @@ -449,10 +461,8 @@ The precedences must be listed from low to high. %nonassoc below_LBRACKETAT %nonassoc LBRACKETAT %nonassoc LBRACKETATAT -%nonassoc LBRACKETPERCENT -%nonassoc LBRACKETPERCENTPERCENT %right COLONCOLON /* expr (e :: e :: e) */ -%left INFIXOP2 PLUS PLUSDOT MINUS MINUSDOT /* expr (e OP e OP e) */ +%left INFIXOP2 PLUS PLUSDOT MINUS MINUSDOT PLUSEQ /* expr (e OP e OP e) */ %left PERCENT INFIXOP3 STAR /* expr (e OP e OP e) */ %right INFIXOP4 /* expr (e OP e OP e) */ %nonassoc prec_unary_minus prec_unary_plus /* unary - */ @@ -466,6 +476,7 @@ The precedences must be listed from low to high. %nonassoc BACKQUOTE BANG BEGIN CHAR FALSE FLOAT INT INT32 INT64 LBRACE LBRACELESS LBRACKET LBRACKETBAR LIDENT LPAREN NEW NATIVEINT PREFIXOP STRING TRUE UIDENT + LBRACKETPERCENT LBRACKETPERCENTPERCENT /* Entry points */ @@ -500,8 +511,7 @@ toplevel_phrase: | EOF { raise End_of_file } ; top_structure: - str_attribute top_structure { $1 :: $2 } - | seq_expr post_item_attributes { [mkstrexp $1 $2] } + seq_expr post_item_attributes { [mkstrexp $1 $2] } | top_structure_tail { $1 } ; top_structure_tail: @@ -562,7 +572,8 @@ module_expr: | STRUCT structure error { unclosed "struct" 1 "end" 3 } | FUNCTOR functor_args MINUSGREATER module_expr - { List.fold_left (fun acc (n, t) -> mkmod(Pmod_functor(n, t, acc))) $4 $2 } + { List.fold_left (fun acc (n, t) -> mkmod(Pmod_functor(n, t, acc))) + $4 $2 } | module_expr LPAREN module_expr RPAREN { mkmod(Pmod_apply($1, $3)) } | module_expr LPAREN RPAREN @@ -602,8 +613,7 @@ module_expr: ; structure: - str_attribute structure { $1 :: $2 } - | seq_expr post_item_attributes structure_tail { mkstrexp $1 $2 :: $3 } + seq_expr post_item_attributes structure_tail { mkstrexp $1 $2 :: $3 } | structure_tail { $1 } ; structure_tail: @@ -611,9 +621,6 @@ structure_tail: | SEMISEMI structure { $2 } | structure_item structure_tail { $1 :: $2 } ; -str_attribute: - post_item_attribute { mkstr(Pstr_attribute $1) } -; structure_item: LET ext_attributes rec_flag let_bindings { @@ -623,11 +630,12 @@ structure_item: let exp = wrap_exp_attrs exp $2 in mkstr(Pstr_eval (exp, attrs)) | l -> - begin match $2 with - | None, [] -> mkstr(Pstr_value($3, List.rev l)) - | Some _, _ -> not_expecting 2 "extension" - | None, _ :: _ -> not_expecting 2 "attribute" - end + let str = mkstr(Pstr_value($3, List.rev l)) in + let (ext, attrs) = $2 in + if attrs <> [] then not_expecting 2 "attribute"; + match ext with + | None -> str + | Some id -> ghstr (Pstr_extension((id, PStr [str]), [])) } | EXTERNAL val_ident COLON core_type EQUAL primitive_declaration post_item_attributes @@ -636,10 +644,10 @@ structure_item: ~prim:$6 ~attrs:$7 ~loc:(symbol_rloc ()))) } | TYPE type_declarations { mkstr(Pstr_type (List.rev $2) ) } - | EXCEPTION exception_declaration + | TYPE str_type_extension + { mkstr(Pstr_typext $2) } + | EXCEPTION str_exception_declaration { mkstr(Pstr_exception $2) } - | EXCEPTION UIDENT EQUAL constr_longident post_item_attributes - { mkstr(Pstr_exn_rebind(mkrhs $2 2, mkloc $4 (rhs_loc 4), $5)) } | MODULE module_binding { mkstr(Pstr_module $2) } | MODULE REC module_bindings @@ -650,16 +658,17 @@ structure_item: | MODULE TYPE ident EQUAL module_type post_item_attributes { mkstr(Pstr_modtype (Mtd.mk (mkrhs $3 3) ~typ:$5 ~attrs:$6 ~loc:(symbol_rloc()))) } - | OPEN override_flag mod_longident post_item_attributes - { mkstr(Pstr_open ($2, mkrhs $3 3, $4)) } + | open_statement { mkstr(Pstr_open $1) } | CLASS class_declarations { mkstr(Pstr_class (List.rev $2)) } | CLASS TYPE class_type_declarations { mkstr(Pstr_class_type (List.rev $3)) } | INCLUDE module_expr post_item_attributes - { mkstr(Pstr_include ($2, $3)) } + { mkstr(Pstr_include (Incl.mk $2 ~attrs:$3 ~loc:(symbol_rloc()))) } | item_extension post_item_attributes { mkstr(Pstr_extension ($1, $2)) } + | floating_attribute + { mkstr(Pstr_attribute $1) } ; module_binding_body: EQUAL module_expr @@ -689,13 +698,14 @@ module_type: { unclosed "sig" 1 "end" 3 } | FUNCTOR functor_args MINUSGREATER module_type %prec below_WITH - { List.fold_left (fun acc (n, t) -> mkmty(Pmty_functor(n, t, acc))) $4 $2 } + { List.fold_left (fun acc (n, t) -> mkmty(Pmty_functor(n, t, acc))) + $4 $2 } | module_type WITH with_constraints { mkmty(Pmty_with($1, List.rev $3)) } | MODULE TYPE OF module_expr %prec below_LBRACKETAT { mkmty(Pmty_typeof $4) } - | LPAREN MODULE mod_longident RPAREN - { mkmty (Pmty_alias (mkrhs $3 3)) } +/* | LPAREN MODULE mod_longident RPAREN + { mkmty (Pmty_alias (mkrhs $3 3)) } */ | LPAREN module_type RPAREN { $2 } | LPAREN module_type error @@ -706,16 +716,9 @@ module_type: { Mty.attr $1 $2 } ; signature: - sig_attribute signature { $1 :: $2 } - | signature_tail { $1 } -; -signature_tail: /* empty */ { [] } | SEMISEMI signature { $2 } - | signature_item signature_tail { $1 :: $2 } -; -sig_attribute: - post_item_attribute { mksig(Psig_attribute $1) } + | signature_item signature { $1 :: $2 } ; signature_item: VAL val_ident COLON core_type post_item_attributes @@ -728,7 +731,9 @@ signature_item: ~loc:(symbol_rloc()))) } | TYPE type_declarations { mksig(Psig_type (List.rev $2)) } - | EXCEPTION exception_declaration + | TYPE sig_type_extension + { mksig(Psig_typext $2) } + | EXCEPTION sig_exception_declaration { mksig(Psig_exception $2) } | MODULE UIDENT module_declaration post_item_attributes { mksig(Psig_module (Md.mk (mkrhs $2 2) @@ -748,18 +753,23 @@ signature_item: { mksig(Psig_modtype (Mtd.mk (mkrhs $3 3) ~typ:$5 ~loc:(symbol_rloc()) ~attrs:$6)) } - | OPEN override_flag mod_longident post_item_attributes - { mksig(Psig_open ($2, mkrhs $3 3, $4)) } + | open_statement + { mksig(Psig_open $1) } | INCLUDE module_type post_item_attributes %prec below_WITH - { mksig(Psig_include ($2, $3)) } + { mksig(Psig_include (Incl.mk $2 ~attrs:$3 ~loc:(symbol_rloc()))) } | CLASS class_descriptions { mksig(Psig_class (List.rev $2)) } | CLASS TYPE class_type_declarations { mksig(Psig_class_type (List.rev $3)) } | item_extension post_item_attributes { mksig(Psig_extension ($1, $2)) } + | floating_attribute + { mksig(Psig_attribute $1) } +; +open_statement: + | OPEN override_flag mod_longident post_item_attributes + { Opn.mk (mkrhs $3 3) ~override:$2 ~attrs:$4 ~loc:(symbol_rloc()) } ; - module_declaration: COLON module_type { $2 } @@ -784,7 +794,8 @@ class_declarations: | class_declaration { [$1] } ; class_declaration: - virtual_flag class_type_parameters LIDENT class_fun_binding post_item_attributes + virtual_flag class_type_parameters LIDENT class_fun_binding + post_item_attributes { Ci.mk (mkrhs $3 3) $4 ~virt:$1 ~params:$2 @@ -816,7 +827,7 @@ class_expr: { $2 } | class_simple_expr simple_labeled_expr_list { mkclass(Pcl_apply($1, List.rev $2)) } - | LET rec_flag let_bindings IN class_expr + | LET rec_flag let_bindings_no_attrs IN class_expr { mkclass(Pcl_let ($2, List.rev $3, $5)) } | class_expr attribute { Cl.attr $1 $2 } @@ -860,19 +871,20 @@ class_fields: { $2 :: $1 } ; class_field: - | INHERIT override_flag class_expr parent_binder - { mkcf (Pcf_inherit ($2, $3, $4)) } - | VAL value - { mkcf (Pcf_val $2) } - | METHOD method_ - { mkcf (Pcf_method $2) } - | CONSTRAINT constrain_field - { mkcf (Pcf_constraint $2) } - | INITIALIZER seq_expr - { mkcf (Pcf_initializer $2) } - | class_field post_item_attribute - { Cf.attr $1 $2 } - | item_extension { mkcf(Pcf_extension $1) } + | INHERIT override_flag class_expr parent_binder post_item_attributes + { mkcf_attrs (Pcf_inherit ($2, $3, $4)) $5 } + | VAL value post_item_attributes + { mkcf_attrs (Pcf_val $2) $3 } + | METHOD method_ post_item_attributes + { mkcf_attrs (Pcf_method $2) $3 } + | CONSTRAINT constrain_field post_item_attributes + { mkcf_attrs (Pcf_constraint $2) $3 } + | INITIALIZER seq_expr post_item_attributes + { mkcf_attrs (Pcf_initializer $2) $3 } + | item_extension post_item_attributes + { mkcf_attrs (Pcf_extension $1) $2 } + | floating_attribute + { mkcf (Pcf_attribute $1) } ; parent_binder: AS LIDENT @@ -904,13 +916,16 @@ method_: { if $1 = Override then syntax_error (); mkloc $4 (rhs_loc 4), $3, Cfk_virtual $6 } | override_flag private_flag label strict_binding - { mkloc $3 (rhs_loc 3), $2, Cfk_concrete ($1, ghexp(Pexp_poly ($4, None))) } + { mkloc $3 (rhs_loc 3), $2, + Cfk_concrete ($1, ghexp(Pexp_poly ($4, None))) } | override_flag private_flag label COLON poly_type EQUAL seq_expr - { mkloc $3 (rhs_loc 3), $2, Cfk_concrete ($1, ghexp(Pexp_poly($7, Some $5))) } + { mkloc $3 (rhs_loc 3), $2, + Cfk_concrete ($1, ghexp(Pexp_poly($7, Some $5))) } | override_flag private_flag label COLON TYPE lident_list DOT core_type EQUAL seq_expr { let exp, poly = wrap_type_annotation $6 $8 $10 in - mkloc $3 (rhs_loc 3), $2, Cfk_concrete ($1, ghexp(Pexp_poly(exp, Some poly))) } + mkloc $3 (rhs_loc 3), $2, + Cfk_concrete ($1, ghexp(Pexp_poly(exp, Some poly))) } ; /* Class types */ @@ -918,7 +933,8 @@ method_: class_type: class_signature { $1 } - | QUESTION LIDENT COLON simple_core_type_or_tuple_no_attr MINUSGREATER class_type + | QUESTION LIDENT COLON simple_core_type_or_tuple_no_attr MINUSGREATER + class_type { mkcty(Pcty_arrow("?" ^ $2 , mkoption $4, $6)) } | OPTLABEL simple_core_type_or_tuple_no_attr MINUSGREATER class_type { mkcty(Pcty_arrow("?" ^ $1, mkoption $2, $4)) } @@ -926,11 +942,7 @@ class_type: { mkcty(Pcty_arrow($1, $3, $5)) } | simple_core_type_or_tuple_no_attr MINUSGREATER class_type { mkcty(Pcty_arrow("", $1, $3)) } - | class_type attribute - { Cty.attr $1 $2 } - | extension - { mkcty(Pcty_extension $1) } -; + ; class_signature: LBRACKET core_type_comma_list RBRACKET clty_longident { mkcty(Pcty_constr (mkloc $4 (rhs_loc 4), List.rev $2)) } @@ -940,6 +952,10 @@ class_signature: { mkcty(Pcty_signature $2) } | OBJECT class_sig_body error { unclosed "object" 1 "end" 3 } + | class_signature attribute + { Cty.attr $1 $2 } + | extension + { mkcty(Pcty_extension $1) } ; class_sig_body: class_self_type class_sig_fields @@ -956,16 +972,21 @@ class_sig_fields: | class_sig_fields class_sig_field { $2 :: $1 } ; class_sig_field: - INHERIT class_signature { mkctf (Pctf_inherit $2) } - | VAL value_type { mkctf (Pctf_val $2) } - | METHOD private_virtual_flags label COLON poly_type + INHERIT class_signature post_item_attributes + { mkctf_attrs (Pctf_inherit $2) $3 } + | VAL value_type post_item_attributes + { mkctf_attrs (Pctf_val $2) $3 } + | METHOD private_virtual_flags label COLON poly_type post_item_attributes { let (p, v) = $2 in - mkctf (Pctf_method ($3, p, v, $5)) + mkctf_attrs (Pctf_method ($3, p, v, $5)) $6 } - | CONSTRAINT constrain_field { mkctf (Pctf_constraint $2) } - | class_sig_field post_item_attribute { Ctf.attr $1 $2 } - | item_extension { mkctf(Pctf_extension $1) } + | CONSTRAINT constrain_field post_item_attributes + { mkctf_attrs (Pctf_constraint $2) $3 } + | item_extension post_item_attributes + { mkctf_attrs (Pctf_extension $1) $2 } + | floating_attribute + { mkctf(Pctf_attribute $1) } ; value_type: VIRTUAL mutable_flag label COLON core_type @@ -986,7 +1007,8 @@ class_descriptions: | class_description { [$1] } ; class_description: - virtual_flag class_type_parameters LIDENT COLON class_type post_item_attributes + virtual_flag class_type_parameters LIDENT COLON class_type + post_item_attributes { Ci.mk (mkrhs $3 3) $5 ~virt:$1 ~params:$2 @@ -998,7 +1020,8 @@ class_type_declarations: | class_type_declaration { [$1] } ; class_type_declaration: - virtual_flag class_type_parameters LIDENT EQUAL class_signature post_item_attributes + virtual_flag class_type_parameters LIDENT EQUAL class_signature + post_item_attributes { Ci.mk (mkrhs $3 3) $5 ~virt:$1 ~params:$2 @@ -1059,7 +1082,7 @@ expr: { $1 } | simple_expr simple_labeled_expr_list { mkexp(Pexp_apply($1, List.rev $2)) } - | LET ext_attributes rec_flag let_bindings IN seq_expr + | LET ext_attributes rec_flag let_bindings_no_attrs IN seq_expr { mkexp_attrs (Pexp_let($3, List.rev $4, $6)) $2 } | LET MODULE ext_attributes UIDENT module_binding_body IN seq_expr { mkexp_attrs (Pexp_letmodule(mkrhs $4 4, $5, $7)) $3 } @@ -1090,7 +1113,8 @@ expr: { mkexp_attrs (Pexp_ifthenelse($3, $5, None)) $2 } | WHILE ext_attributes seq_expr DO seq_expr DONE { mkexp_attrs (Pexp_while($3, $5)) $2 } - | FOR ext_attributes pattern EQUAL seq_expr direction_flag seq_expr DO seq_expr DONE + | FOR ext_attributes pattern EQUAL seq_expr direction_flag seq_expr DO + seq_expr DONE { mkexp_attrs(Pexp_for($3, $5, $7, $6, $9)) $2 } | expr COLONCOLON expr { mkexp_cons (rhs_loc 2) (ghexp(Pexp_tuple[$1;$3])) (symbol_rloc()) } @@ -1110,6 +1134,8 @@ expr: { mkinfix $1 "+" $3 } | expr PLUSDOT expr { mkinfix $1 "+." $3 } + | expr PLUSEQ expr + { mkinfix $1 "+=" $3 } | expr MINUS expr { mkinfix $1 "-" $3 } | expr MINUSDOT expr @@ -1157,7 +1183,7 @@ expr: | OBJECT ext_attributes class_structure END { mkexp_attrs (Pexp_object $3) $2 } | OBJECT ext_attributes class_structure error - { unclosed "object" 1 "end" 3 } + { unclosed "object" 1 "end" 4 } | expr attribute { Exp.attr $1 $2 } ; @@ -1245,7 +1271,7 @@ simple_expr: | LBRACELESS GREATERRBRACE { mkexp (Pexp_override [])} | mod_longident DOT LBRACELESS field_expr_list opt_semi GREATERRBRACE - { mkexp(Pexp_open(Fresh, mkrhs $1 1, mkexp (Pexp_override(List.rev $4)))) } + { mkexp(Pexp_open(Fresh, mkrhs $1 1, mkexp (Pexp_override(List.rev $4))))} | mod_longident DOT LBRACELESS field_expr_list opt_semi error { unclosed "{<" 3 ">}" 6 } | simple_expr SHARP label @@ -1295,13 +1321,26 @@ let_bindings: let_binding { [$1] } | let_bindings AND let_binding { $3 :: $1 } ; +let_bindings_no_attrs: + let_bindings { + let l = $1 in + List.iter + (fun vb -> + if vb.pvb_attributes <> [] then + raise Syntaxerr.(Error(Not_expecting(vb.pvb_loc,"item attribute"))) + ) + l; + l + } lident_list: LIDENT { [$1] } | LIDENT lident_list { $1 :: $2 } ; let_binding: - let_binding_ post_item_attributes { let (p, e) = $1 in Vb.mk ~attrs:$2 p e } + let_binding_ post_item_attributes { + let (p, e) = $1 in Vb.mk ~loc:(symbol_rloc()) ~attrs:$2 p e + } ; let_binding_: val_ident fun_binding @@ -1419,6 +1458,8 @@ pattern: { expecting 3 "pattern" } | LAZY simple_pattern { mkpat(Ppat_lazy $2) } + | EXCEPTION pattern %prec prec_constr_appl + { mkpat(Ppat_exception $2) } | pattern attribute { Pat.attr $1 $2 } ; @@ -1537,27 +1578,33 @@ type_kind: { (Ptype_variant(List.rev $3), Private, None) } | EQUAL private_flag BAR constructor_declarations { (Ptype_variant(List.rev $4), $2, None) } + | EQUAL DOTDOT + { (Ptype_open, Public, None) } | EQUAL private_flag LBRACE label_declarations opt_semi RBRACE { (Ptype_record(List.rev $4), $2, None) } | EQUAL core_type EQUAL private_flag opt_bar constructor_declarations { (Ptype_variant(List.rev $6), $4, Some $2) } + | EQUAL core_type EQUAL DOTDOT + { (Ptype_open, Public, Some $2) } | EQUAL core_type EQUAL private_flag LBRACE label_declarations opt_semi RBRACE { (Ptype_record(List.rev $6), $4, Some $2) } ; optional_type_parameters: /*empty*/ { [] } - | optional_type_parameter { [$1] } + | optional_type_parameter { [$1] } | LPAREN optional_type_parameter_list RPAREN { List.rev $2 } ; optional_type_parameter: - type_variance QUOTE ident { Some (mkrhs $3 3), $1 } - | type_variance UNDERSCORE { None, $1 } + type_variance optional_type_variable { $2, $1 } ; optional_type_parameter_list: optional_type_parameter { [$1] } | optional_type_parameter_list COMMA optional_type_parameter { $3 :: $1 } ; - +optional_type_variable: + QUOTE ident { mktyp(Ptyp_var $2) } + | UNDERSCORE { mktyp(Ptyp_any) } +; type_parameters: @@ -1566,13 +1613,16 @@ type_parameters: | LPAREN type_parameter_list RPAREN { List.rev $2 } ; type_parameter: - type_variance QUOTE ident { mkrhs $3 3, $1 } + type_variance type_variable { $2, $1 } ; type_variance: /* empty */ { Invariant } | PLUS { Covariant } | MINUS { Contravariant } ; +type_variable: + QUOTE ident { mktyp(Ptyp_var $2) } +; type_parameter_list: type_parameter { [$1] } | type_parameter_list COMMA type_parameter { $3 :: $1 } @@ -1588,11 +1638,23 @@ constructor_declaration: Type.constructor (mkrhs $1 1) ~args ?res ~loc:(symbol_rloc()) ~attrs:$2 } ; -exception_declaration: - | constructor_declaration post_item_attributes +str_exception_declaration: + | extension_constructor_declaration post_item_attributes + { + let ext = $1 in + {ext with pext_attributes = ext.pext_attributes @ $2} + } + | extension_constructor_rebind post_item_attributes + { + let ext = $1 in + {ext with pext_attributes = ext.pext_attributes @ $2} + } +; +sig_exception_declaration: + | extension_constructor_declaration post_item_attributes { - let cd = $1 in - {cd with pcd_attributes = cd.pcd_attributes @ $2} + let ext = $1 in + {ext with pext_attributes = ext.pext_attributes @ $2} } ; generalized_constructor_arguments: @@ -1619,6 +1681,43 @@ label_declaration: } ; +/* Type Extensions */ + +str_type_extension: + optional_type_parameters type_longident + PLUSEQ private_flag opt_bar str_extension_constructors post_item_attributes + { Te.mk (mkrhs $2 2) (List.rev $6) + ~params:$1 ~priv:$4 ~attrs:$7 } +; +sig_type_extension: + optional_type_parameters type_longident + PLUSEQ private_flag opt_bar sig_extension_constructors post_item_attributes + { Te.mk (mkrhs $2 2) (List.rev $6) + ~params:$1 ~priv:$4 ~attrs:$7 } +; +str_extension_constructors: + extension_constructor_declaration { [$1] } + | extension_constructor_rebind { [$1] } + | str_extension_constructors BAR extension_constructor_declaration + { $3 :: $1 } + | str_extension_constructors BAR extension_constructor_rebind + { $3 :: $1 } +; +sig_extension_constructors: + extension_constructor_declaration { [$1] } + | sig_extension_constructors BAR extension_constructor_declaration + { $3 :: $1 } +; +extension_constructor_declaration: + | constr_ident attributes generalized_constructor_arguments + { let args, res = $3 in + Te.decl (mkrhs $1 1) ~args ?res ~loc:(symbol_rloc()) ~attrs:$2 } +; +extension_constructor_rebind: + | constr_ident attributes EQUAL constr_longident + { Te.rebind (mkrhs $1 1) (mkrhs $4 4) ~loc:(symbol_rloc()) ~attrs:$2 } +; + /* "with" constraints (additional type equations over signature components) */ with_constraints: @@ -1626,11 +1725,11 @@ with_constraints: | with_constraints AND with_constraint { $3 :: $1 } ; with_constraint: - TYPE type_parameters /*label_longident*/ type_longident with_type_binder core_type constraints + TYPE type_parameters label_longident with_type_binder core_type constraints { Pwith_type (mkrhs $3 3, (Type.mk (mkrhs (Longident.last $3) 3) - ~params:(List.map (fun (x, v) -> Some x, v) $2) + ~params:$2 ~cstrs:(List.rev $6) ~manifest:$5 ~priv:$4 @@ -1640,7 +1739,7 @@ with_constraint: | TYPE type_parameters label COLONEQUAL core_type { Pwith_typesubst (Type.mk (mkrhs $3 3) - ~params:(List.map (fun (x, v) -> Some x, v) $2) + ~params:$2 ~manifest:$5 ~loc:(symbol_rloc())) } | MODULE mod_longident EQUAL mod_ext_longident @@ -1767,10 +1866,10 @@ row_field: | simple_core_type { Rinherit $1 } ; tag_field: - name_tag OF opt_ampersand amper_type_list - { Rtag ($1, $3, List.rev $4) } - | name_tag - { Rtag ($1, true, []) } + name_tag attributes OF opt_ampersand amper_type_list + { Rtag ($1, $2, $4, List.rev $5) } + | name_tag attributes + { Rtag ($1, $2, true, []) } ; opt_ampersand: AMPERSAND { true } @@ -1808,12 +1907,12 @@ core_type_list_no_attr: | core_type_list STAR simple_core_type_no_attr { $3 :: $1 } ; meth_list: - field SEMI meth_list { let (f, c) = $3 in ($1 :: f, c) } + field SEMI meth_list { let (f, c) = $3 in ($1 :: f, c) } | field opt_semi { [$1], Closed } | DOTDOT { [], Open } ; field: - label COLON poly_type /* ok */ { ($1, $3) } + label attributes COLON poly_type { ($1, $2, $4) } ; label: LIDENT { $1 } @@ -1822,13 +1921,13 @@ label: /* Constants */ constant: - INT { Const_int $1 } - | CHAR { Const_char $1 } - | STRING { let (s, d) = $1 in Const_string (s, d) } - | FLOAT { Const_float $1 } - | INT32 { Const_int32 $1 } - | INT64 { Const_int64 $1 } - | NATIVEINT { Const_nativeint $1 } + INT { Const_int $1 } + | CHAR { Const_char $1 } + | STRING { let (s, d) = $1 in Const_string (s, d) } + | FLOAT { Const_float $1 } + | INT32 { Const_int32 $1 } + | INT64 { Const_int64 $1 } + | NATIVEINT { Const_nativeint $1 } ; signed_constant: constant { $1 } @@ -1878,6 +1977,7 @@ operator: | AMPERSAND { "&" } | AMPERAMPER { "&&" } | COLONEQUAL { ":=" } + | PLUSEQ { "+=" } | PERCENT { "%" } ; constr_ident: @@ -1906,12 +2006,8 @@ label_longident: | mod_longident DOT LIDENT { Ldot($1, $3) } ; type_longident: - type_ident { Lident $1 } - | mod_ext_longident DOT type_ident { Ldot($1, $3) } -; -type_ident: - LIDENT { $1 } - | LIDENT DOT UIDENT { $1 ^ "." ^ $3 } + LIDENT { Lident $1 } + | mod_ext_longident DOT LIDENT { Ldot($1, $3) } ; mod_longident: UIDENT { Lident $1 } @@ -1942,6 +2038,7 @@ toplevel_directive: | SHARP ident STRING { Ptop_dir($2, Pdir_string (fst $3)) } | SHARP ident INT { Ptop_dir($2, Pdir_int $3) } | SHARP ident val_longident { Ptop_dir($2, Pdir_ident $3) } + | SHARP ident mod_longident { Ptop_dir($2, Pdir_ident $3) } | SHARP ident FALSE { Ptop_dir($2, Pdir_bool false) } | SHARP ident TRUE { Ptop_dir($2, Pdir_bool true) } ; @@ -2065,6 +2162,9 @@ attribute: post_item_attribute: LBRACKETATAT attr_id payload RBRACKET { ($2, $3) } ; +floating_attribute: + LBRACKETATATAT attr_id payload RBRACKET { ($2, $3) } +; post_item_attributes: /* empty */ { [] } | post_item_attribute post_item_attributes { $1 :: $2 } diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli index a76be627d..d287b9eee 100644 --- a/parsing/parsetree.mli +++ b/parsing/parsetree.mli @@ -17,14 +17,19 @@ open Asttypes (** {2 Extension points} *) type attribute = string loc * payload - (* [@id ARG] - [@@id ARG] + (* [@id ARG] + [@@id ARG] + + Metadata containers passed around within the AST. + The compiler ignores unknown attributes. *) and extension = string loc * payload (* [%id ARG] [%%id ARG] - *) + + Sub-language placeholder -- rejected by the typechecker. + *) and attributes = attribute list @@ -55,13 +60,16 @@ and core_type_desc = ?l:T1 -> T2 (label = "?l") *) | Ptyp_tuple of core_type list - (* T1 * ... * Tn (n >= 2) *) + (* T1 * ... * Tn + + Invariant: n >= 2 + *) | Ptyp_constr of Longident.t loc * core_type list (* tconstr T tconstr (T1, ..., Tn) tconstr *) - | Ptyp_object of (string * core_type) list * closed_flag + | Ptyp_object of (string * attributes * core_type) list * closed_flag (* < l1:T1; ...; ln:Tn > (flag = Closed) < l1:T1; ...; ln:Tn; .. > (flag = Open) *) @@ -110,12 +118,19 @@ and package_type = Longident.t loc * (Longident.t loc * core_type) list *) and row_field = - | Rtag of label * bool * core_type list + | Rtag of label * attributes * bool * core_type list (* [`A] ( true, [] ) [`A of T] ( false, [T] ) [`A of T1 & .. & Tn] ( false, [T1;...Tn] ) [`A of & T1 & .. & Tn] ( true, [T1;...Tn] ) - *) + + - The 2nd field is true if the tag contains a + constant (empty) constructor. + - '&' occurs when several types are used for the same constructor + (see 4.2 in the manual) + + - TODO: switch to a record representation, and keep location + *) | Rinherit of core_type (* [ T ] *) @@ -143,7 +158,10 @@ and pattern_desc = Other forms of interval are recognized by the parser but rejected by the type-checker. *) | Ppat_tuple of pattern list - (* (P1, ..., Pn) (n >= 2) *) + (* (P1, ..., Pn) + + Invariant: n >= 2 + *) | Ppat_construct of Longident.t loc * pattern option (* C None C P Some P @@ -156,6 +174,8 @@ and pattern_desc = | Ppat_record of (Longident.t loc * pattern) list * closed_flag (* { l1=P1; ...; ln=Pn } (flag = Closed) { l1=P1; ...; ln=Pn; _} (flag = Open) + + Invariant: n > 0 *) | Ppat_array of pattern list (* [| P1; ...; Pn |] *) @@ -169,8 +189,11 @@ and pattern_desc = (* lazy P *) | Ppat_unpack of string loc (* (module P) - Note: (module P : S) is represented as Ppat_constraint(Ppat_unpack, Ptyp_package) + Note: (module P : S) is represented as + Ppat_constraint(Ppat_unpack, Ptyp_package) *) + | Ppat_exception of pattern + (* exception P *) | Ppat_extension of extension (* [%id] *) @@ -211,13 +234,18 @@ and expression_desc = (* E0 ~l1:E1 ... ~ln:En li can be empty (non labeled argument) or start with '?' (optional argument). + + Invariant: n > 0 *) | Pexp_match of expression * case list (* match E0 with P1 -> E1 | ... | Pn -> En *) | Pexp_try of expression * case list (* try E0 with P1 -> E1 | ... | Pn -> En *) | Pexp_tuple of expression list - (* (E1, ..., En) (n >= 2) *) + (* (E1, ..., En) + + Invariant: n >= 2 + *) | Pexp_construct of Longident.t loc * expression option (* C None C E Some E @@ -230,6 +258,8 @@ and expression_desc = | Pexp_record of (Longident.t loc * expression) list * expression option (* { l1=P1; ...; ln=Pn } (None) { E0 with l1=P1; ...; ln=Pn } (Some E0) + + Invariant: n > 0 *) | Pexp_field of expression * Longident.t loc (* E.l *) @@ -266,7 +296,8 @@ and expression_desc = (* let module M = ME in E *) | Pexp_assert of expression (* assert E - Note: "assert false" is treated in a special way by the type-checker. *) + Note: "assert false" is treated in a special way by the + type-checker. *) | Pexp_lazy of expression (* lazy E *) | Pexp_poly of expression * core_type option @@ -284,7 +315,9 @@ and expression_desc = (module ME : S) is represented as Pexp_constraint(Pexp_pack, Ptyp_package S) *) | Pexp_open of override_flag * Longident.t loc * expression - (* let open M in E *) + (* let open M in E + let! open M in E + *) | Pexp_extension of extension (* [%id] *) @@ -318,7 +351,7 @@ and value_description = and type_declaration = { ptype_name: string loc; - ptype_params: (string loc option * variance) list; + ptype_params: (core_type * variance) list; (* ('a1,...'an) t; None represents _*) ptype_cstrs: (core_type * core_type * Location.t) list; (* ... constraint T1=T1' ... constraint Tn=Tn' *) @@ -336,12 +369,16 @@ and type_declaration = type t = T0 = C of T | ... (variant, manifest=T0) type t = {l: T; ...} (record, no manifest) type t = T0 = {l : T; ...} (record, manifest=T0) + type t = .. (open, no manifest) *) and type_kind = | Ptype_abstract | Ptype_variant of constructor_declaration list + (* Invariant: non-empty list *) | Ptype_record of label_declaration list + (* Invariant: non-empty list *) + | Ptype_open and label_declaration = { @@ -355,7 +392,7 @@ and label_declaration = (* { ...; l: T; ... } (mutable=Immutable) { ...; mutable l: T; ... } (mutable=Mutable) - Note: T can be a Pexp_poly. + Note: T can be a Ptyp_poly. *) and constructor_declaration = @@ -380,6 +417,38 @@ and constructor_arguments = | C of {...} as t (res = None, args = Pcstr_record) *) +and type_extension = + { + ptyext_path: Longident.t loc; + ptyext_params: (core_type * variance) list; + ptyext_constructors: extension_constructor list; + ptyext_private: private_flag; + ptyext_attributes: attributes; (* ... [@@id1] [@@id2] *) + } +(* + type t += ... +*) + +and extension_constructor = + { + pext_name: string loc; + pext_kind : extension_constructor_kind; + pext_loc : Location.t; + pext_attributes: attributes; (* C [@id1] [@id2] of ... *) + } + +and extension_constructor_kind = + Pext_decl of constructor_arguments * core_type option + (* + | C of T1 * ... * Tn ([T1; ...; Tn], None) + | C: T0 ([], Some T0) + | C: T1 * ... * Tn -> T0 ([T1; ...; Tn], Some T0) + *) + | Pext_rebind of Longident.t loc + (* + | C = D + *) + (** {2 Class language} *) (* Type expressions for the class language *) @@ -429,17 +498,19 @@ and class_type_field_desc = | Pctf_method of (string * private_flag * virtual_flag * core_type) (* method x: T - Note: T can be a Pexp_poly. + Note: T can be a Ptyp_poly. *) | Pctf_constraint of (core_type * core_type) (* constraint T1 = T2 *) + | Pctf_attribute of attribute + (* [@@@id] *) | Pctf_extension of extension (* [%%id] *) and 'a class_infos = { pci_virt: virtual_flag; - pci_params: (string loc * variance) list; + pci_params: (core_type * variance) list; pci_name: string loc; pci_expr: 'a; pci_loc: Location.t; @@ -481,6 +552,8 @@ and class_expr_desc = (* CE ~l1:E1 ... ~ln:En li can be empty (non labeled argument) or start with '?' (optional argument). + + Invariant: n > 0 *) | Pcl_let of rec_flag * value_binding list * class_expr (* let P1 = E1 and ... and Pn = EN in CE (flag = Nonrecursive) @@ -504,7 +577,7 @@ and class_field = { pcf_desc: class_field_desc; pcf_loc: Location.t; - pcf_attributes: attributes; (* ... [@id1] [@id2] *) + pcf_attributes: attributes; (* ... [@@id1] [@@id2] *) } and class_field_desc = @@ -526,8 +599,10 @@ and class_field_desc = (* constraint T1 = T2 *) | Pcf_initializer of expression (* initializer E *) + | Pcf_attribute of attribute + (* [@@@id] *) | Pcf_extension of extension - (* [%id] *) + (* [%%id] *) and class_field_kind = | Cfk_virtual of core_type @@ -578,7 +653,9 @@ and signature_item_desc = *) | Psig_type of type_declaration list (* type t1 = ... and ... and tn = ... *) - | Psig_exception of constructor_declaration + | Psig_typext of type_extension + (* type t1 += ... *) + | Psig_exception of extension_constructor (* exception C of T *) | Psig_module of module_declaration (* module X : MT *) @@ -587,18 +664,16 @@ and signature_item_desc = | Psig_modtype of module_type_declaration (* module type S = MT module type S *) - | Psig_open of override_flag * Longident.t loc * attributes + | Psig_open of open_description (* open X *) - | Psig_include of module_type * attributes + | Psig_include of include_description (* include MT *) | Psig_class of class_description list (* class c1 : ... and ... and cn : ... *) | Psig_class_type of class_type_declaration list (* class type ct1 = ... and ... and ctn = ... *) | Psig_attribute of attribute - (* [@@id] - (not attached to another item, i.e. after ";;" or at the beginning - of the signature) *) + (* [@@@id] *) | Psig_extension of extension * attributes (* [%%id] *) @@ -622,6 +697,31 @@ and module_type_declaration = S (abstract module type declaration, pmtd_type = None) *) +and open_description = + { + popen_lid: Longident.t loc; + popen_override: override_flag; + popen_loc: Location.t; + popen_attributes: attributes; + } +(* open! X - popen_override = Override (silences the 'used identifier + shadowing' warning) + open X - popen_override = Fresh + *) + +and 'a include_infos = + { + pincl_mod: 'a; + pincl_loc: Location.t; + pincl_attributes: attributes; + } + +and include_description = module_type include_infos +(* include MT *) + +and include_declaration = module_expr include_infos +(* include ME *) + and with_constraint = | Pwith_type of Longident.t loc * type_declaration (* with type X.t = ... @@ -679,28 +779,27 @@ and structure_item_desc = (* external x: T = "s1" ... "sn" *) | Pstr_type of type_declaration list (* type t1 = ... and ... and tn = ... *) - | Pstr_exception of constructor_declaration - (* exception C of T *) - | Pstr_exn_rebind of string loc * Longident.t loc * attributes - (* exception C = M.X *) + | Pstr_typext of type_extension + (* type t1 += ... *) + | Pstr_exception of extension_constructor + (* exception C of T + exception C = M.X *) | Pstr_module of module_binding (* module X = ME *) | Pstr_recmodule of module_binding list (* module rec X1 = ME1 and ... and Xn = MEn *) | Pstr_modtype of module_type_declaration (* module type S = MT *) - | Pstr_open of override_flag * Longident.t loc * attributes + | Pstr_open of open_description (* open X *) | Pstr_class of class_declaration list (* class c1 = ... and ... and cn = ... *) | Pstr_class_type of class_type_declaration list (* class type ct1 = ... and ... and ctn = ... *) - | Pstr_include of module_expr * attributes + | Pstr_include of include_declaration (* include ME *) | Pstr_attribute of attribute - (* [@@id] - (not attached to another item, i.e. after ";;" or at the beginning - of the structure) *) + (* [@@@id] *) | Pstr_extension of extension * attributes (* [%%id] *) @@ -709,6 +808,7 @@ and value_binding = pvb_pat: pattern; pvb_expr: expression; pvb_attributes: attributes; + pvb_loc: Location.t; } and module_binding = @@ -727,6 +827,7 @@ and module_binding = type toplevel_phrase = | Ptop_def of structure | Ptop_dir of string * directive_argument + (* #use, #load ... *) and directive_argument = | Pdir_none diff --git a/parsing/pprintast.ml b/parsing/pprintast.ml index ac7c6d2a3..5f59dacac 100644 --- a/parsing/pprintast.ml +++ b/parsing/pprintast.ml @@ -60,7 +60,8 @@ let needs_parens txt = is_infix (fixity_of_string txt) || List.mem txt.[0] prefix_symbols -(* some infixes need spaces around parens to avoid clashes with comment syntax *) +(* some infixes need spaces around parens to avoid clashes with comment + syntax *) let needs_spaces txt = txt.[0]='*' || txt.[String.length txt - 1] = '*' @@ -75,8 +76,8 @@ let protect_ident ppf txt = let protect_longident ppf print_longident longprefix txt = let format : (_, _, _) format = if not (needs_parens txt) then "%a.%s" - else if needs_spaces txt then "(@;%a.%s@;)" - else "(%a.%s)" in + else if needs_spaces txt then "%a.(@;%s@;)" + else "%a.(%s)" in fprintf ppf format print_longident longprefix txt type space_formatter = (unit, Format.formatter, unit) format @@ -125,19 +126,6 @@ let is_simple_construct :construct -> bool = function let pp = fprintf -let rec is_irrefut_patt x = - match x.ppat_desc with - | Ppat_any | Ppat_var _ | Ppat_unpack _ -> true - | Ppat_alias (p,_) -> is_irrefut_patt p - | Ppat_tuple (ps) -> List.for_all is_irrefut_patt ps - | Ppat_constraint (p,_) -> is_irrefut_patt p - | Ppat_or (l,r) -> is_irrefut_patt l || is_irrefut_patt r - | Ppat_record (ls,_) -> List.for_all (fun (_,x) -> is_irrefut_patt x) ls - | Ppat_lazy p -> is_irrefut_patt p - | Ppat_extension _ -> assert false - | Ppat_interval _ - | Ppat_constant _ | Ppat_construct _ | Ppat_variant _ | Ppat_array _ - | Ppat_type _-> false (*conservative*) class printer ()= object(self:'self) val pipe = false val semi = false @@ -162,9 +150,9 @@ class printer ()= object(self:'self) | xs -> let rec loop f = function | [x] -> fu f x - | x::xs -> pp f "%a%(%)%a" fu x sep loop xs + | x::xs -> fu f x; pp f sep; loop f xs; | _ -> assert false in begin - pp f "%(%)%a%(%)" first loop xs last; + pp f first; loop f xs; pp f last; end in aux f xs method option : 'a. ?first:space_formatter -> ?last:space_formatter -> @@ -174,11 +162,11 @@ class printer ()= object(self:'self) and last = match last with Some x -> x | None -> "" in match a with | None -> () - | Some x -> pp f "%(%)%a%(%)" first fu x last + | Some x -> pp f first; fu f x; pp f last; method paren: 'a . ?first:space_formatter -> ?last:space_formatter -> bool -> (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a -> unit = fun ?(first="") ?(last="") b fu f x -> - if b then pp f "(%(%)%a%(%))" first fu x last + if b then (pp f "("; pp f first; fu f x; pp f last; pp f ")") else fu f x @@ -222,18 +210,13 @@ class printer ()= object(self:'self) method constant_string f s = pp f "%S" s method tyvar f str = pp f "'%s" str method string_quot f x = pp f "`%s" x - method type_var_option f str = - match str with - | None -> pp f "_" (* wildcard*) - | Some {txt;_} -> self#tyvar f txt (* c ['a,'b] *) method class_params_def f = function | [] -> () | l -> pp f "[%a] " (* space *) - (self#list (fun f ({txt;_},s) -> - pp f "%s%a" (type_variance s) self#tyvar txt) ~sep:",") l + (self#list self#type_param ~sep:",") l method type_with_label f (label,({ptyp_desc;_}as c) ) = match label with @@ -285,7 +268,8 @@ class printer ()= object(self:'self) | Ptyp_variant (l, closed, low) -> let type_variant_helper f x = match x with - | Rtag (l, _, ctl) -> pp f "@[<2>%a%a@]" self#string_quot l + | Rtag (l, attrs, _, ctl) -> pp f "@[<2>%a%a%a@]" self#string_quot l + self#attributes attrs (fun f l -> match l with |[] -> () | _ -> pp f "@;of@;%a" @@ -311,8 +295,9 @@ class printer ()= object(self:'self) pp f ">@ %a" (self#list self#string_quot) xs) low | Ptyp_object (l, o) -> - let core_field_type f (s, ct) = - pp f "@[<hov2>%s@ :%a@ @]" s self#core_type ct + let core_field_type f (s, attrs, ct) = + pp f "@[<hov2>%s%a@ :%a@ @]" s + self#attributes attrs self#core_type ct in let field_var f = function | Asttypes.Closed -> () @@ -335,8 +320,7 @@ class printer ()= object(self:'self) |_ -> pp f "@[<hov2>(module@ %a@ with@ %a)@]" self#longident_loc lid (self#list aux ~sep:"@ and@ ") cstrs) - | Ptyp_extension (s, arg) -> - pp f "@[<2>(&%s@ %a)@]" s.txt self#payload arg + | Ptyp_extension e -> self#extension f e | _ -> self#paren true self#core_type f x (********************pattern********************) (* be cautious when use [pattern], [pattern1] is preferred *) @@ -353,7 +337,8 @@ class printer ()= object(self:'self) | Ppat_alias (p, s) -> pp f "@[<2>%a@;as@;%a@]" self#pattern p protect_ident s.txt (* RA*) | Ppat_or (p1, p2) -> (* *) - pp f "@[<hov0>%a@]" (self#list ~sep:"@,|" self#pattern) (list_of_pattern [] x) + pp f "@[<hov0>%a@]" (self#list ~sep:"@,|" self#pattern) + (list_of_pattern [] x) | _ -> self#pattern1 f x method pattern1 (f:Format.formatter) (x:pattern) :unit = let rec pattern_list_helper f = function @@ -410,6 +395,8 @@ class printer ()= object(self:'self) pp f "@[<2>(%a@;:@;%a)@]" self#pattern1 p self#core_type ct | Ppat_lazy p -> pp f "@[<2>(lazy@;%a)@]" self#pattern1 p + | Ppat_exception p -> + pp f "@[<2>exception@;%a@]" self#pattern1 p | _ -> self#paren true self#pattern f x method label_exp f (l,opt,p) = @@ -422,11 +409,13 @@ class printer ()= object(self:'self) match p.ppat_desc with | Ppat_var {txt;_} when txt = rest -> (match opt with - |Some o -> pp f "?(%s=@;%a)@;" rest self#expression o - | None -> pp f "?%s@ " rest) - | _ -> (match opt with - | Some o -> pp f "%s:(%a=@;%a)@;" l self#pattern1 p self#expression o - | None -> pp f "%s:%a@;" l self#simple_pattern p ) + | Some o -> pp f "?(%s=@;%a)@;" rest self#expression o + | None -> pp f "?%s@ " rest) + | _ -> + (match opt with + | Some o -> + pp f "%s:(%a=@;%a)@;" l self#pattern1 p self#expression o + | None -> pp f "%s:%a@;" l self#simple_pattern p) end else (match p.ppat_desc with @@ -466,54 +455,61 @@ class printer ()= object(self:'self) end | Pexp_apply ({pexp_desc=Pexp_ident - {txt= Ldot (Ldot (Lident "Bigarray", array), ("get"|"set" as gs)) ;_};_}, + {txt= Ldot (Ldot (Lident "Bigarray", array), + ("get"|"set" as gs)) ;_};_}, label_exprs) -> - begin match array,gs with - | "Genarray","get" -> - begin match label_exprs with - | [(_,a);(_,{pexp_desc=Pexp_array ls;_})] -> begin - pp f "@[%a.{%a}@]" self#simple_expr a - (self#list ~sep:"," self#simple_expr ) ls; - true - end - | _ -> false - end - | "Genarray","set" -> - begin match label_exprs with - | [(_,a);(_,{pexp_desc=Pexp_array ls;_});(_,c)] -> begin - pp f "@[%a.{%a}@ <-@ %a@]" self#simple_expr a - (self#list ~sep:"," self#simple_expr ) ls self#simple_expr c; - true - end - | _ -> false - end - | ("Array1"|"Array2"|"Array3"),"set" -> - begin - match label_exprs with - | (_,a)::rest -> - begin match List.rev rest with - | (_,v)::rest -> - let args = List.map snd (List.rev rest) in - pp f "@[%a.{%a}@ <-@ %a@]" - self#simple_expr a (self#list ~sep:"," self#simple_expr) - args self#simple_expr v; - true - | _ -> assert false - end - | _ -> assert false - end - | ("Array1"|"Array2"|"Array3"),"get" -> - begin match label_exprs with - |(_,a)::rest -> - pp f "@[%a.{%a}@]" - self#simple_expr a (self#list ~sep:"," self#simple_expr) - (List.map snd rest); - true - | _ -> assert false - end + begin match array, gs, label_exprs with + | "Genarray", "get", + [(_,a);(_,{pexp_desc=Pexp_array ls;_})] -> + pp f "@[%a.{%a}@]" self#simple_expr a + (self#list ~sep:"," self#simple_expr ) ls; + true + | "Genarray", "set", + [(_,a);(_,{pexp_desc=Pexp_array ls;_});(_,c)] -> + pp f "@[%a.{%a}@ <-@ %a@]" self#simple_expr a + (self#list ~sep:"," self#simple_expr ) ls self#simple_expr c; + true + | "Array1", "set", [(_,a);(_,i);(_,v)] -> + pp f "@[%a.{%a}@ <-@ %a@]" + self#simple_expr a + self#simple_expr i + self#simple_expr v; + true + | "Array2", "set", [(_,a);(_,i1);(_,i2);(_,v)] -> + pp f "@[%a.{%a,%a}@ <-@ %a@]" + self#simple_expr a + self#simple_expr i1 + self#simple_expr i2 + self#simple_expr v; + true + | "Array3", "set", [(_,a);(_,i1);(_,i2);(_,i3);(_,v)] -> + pp f "@[%a.{%a,%a,%a}@ <-@ %a@]" + self#simple_expr a + self#simple_expr i1 + self#simple_expr i2 + self#simple_expr i3 + self#simple_expr v; + true + | "Array1", "get", [(_,a);(_,i)] -> + pp f "@[%a.{%a}@]" + self#simple_expr a + self#simple_expr i; + true + | "Array2", "get", [(_,a);(_,i1);(_,i2)] -> + pp f "@[%a.{%a,%a}@]" + self#simple_expr a + self#simple_expr i1 + self#simple_expr i2; + true + | "Array3", "get", [(_,a);(_,i1);(_,i2);(_,i3)] -> + pp f "@[%a.{%a,%a,%a}@]" + self#simple_expr a + self#simple_expr i1 + self#simple_expr i2 + self#simple_expr i3; + true | _ -> false end - | _ -> false method expression f x = if x.pexp_attributes <> [] then begin @@ -612,15 +608,17 @@ class printer ()= object(self:'self) pp f "@[<hov2>assert@ %a@]" self#simple_expr e | Pexp_lazy (e) -> pp f "@[<hov2>lazy@ %a@]" self#simple_expr e - | Pexp_poly _ -> - assert false + (* Pexp_poly: impossible but we should print it anyway, rather than assert false *) + | Pexp_poly (e, None) -> + pp f "@[<hov2>!poly!@ %a@]" self#simple_expr e + | Pexp_poly (e, Some ct) -> + pp f "@[<hov2>(!poly!@ %a@ : %a)@]" self#simple_expr e self#core_type ct | Pexp_open (ovf, lid, e) -> pp f "@[<2>let open%s %a in@;%a@]" (override ovf) self#longident_loc lid self#expression e | Pexp_variant (l,Some eo) -> pp f "@[<2>`%s@;%a@]" l self#simple_expr eo - | Pexp_extension (s, arg) -> - pp f "@[<2>(&%s@ %a)@]" s.txt self#payload arg + | Pexp_extension e -> self#extension f e | _ -> self#expression1 f x method expression1 f x = if x.pexp_attributes <> [] then self#expression f x @@ -689,8 +687,17 @@ class printer ()= object(self:'self) method attributes f l = List.iter (self # attribute f) l + method item_attributes f l = + List.iter (self # item_attribute f) l + method attribute f (s, e) = - pp f "[@@%s %a]" s.txt self#payload e + pp f "@[<2>[@@%s@ %a]@]" s.txt self#payload e + + method item_attribute f (s, e) = + pp f "@[<2>[@@@@%s@ %a]@]" s.txt self#payload e + + method floating_attribute f (s, e) = + pp f "@[<2>[@@@@@@%s@ %a]@]" s.txt self#payload e method value_description f x = pp f "@[<hov2>%a%a@]" self#core_type x.pval_type @@ -701,124 +708,167 @@ class printer ()= object(self:'self) x.pval_prim ; end) x + method extension f (s, e) = + pp f "@[<2>[%%%s@ %a]@]" s.txt self#payload e + + method item_extension f (s, e) = + pp f "@[<2>[%%%%%s@ %a]@]" s.txt self#payload e - method exception_declaration f cd = - pp f "@[<hov2>exception@ %s%a@]" cd.pcd_name.txt - (fun f ed -> match ed with - | Pcstr_tuple [] -> () - | Pcstr_tuple l -> pp f "@ of@ %a" (self#list ~sep:"*" self#core_type) l - | Pcstr_record _ -> assert false (* TODO *) - ) cd.pcd_args + method exception_declaration f ext = + pp f "@[<hov2>exception@ %a@]" self#extension_constructor ext method class_signature f { pcsig_self = ct; pcsig_fields = l ;_} = let class_type_field f x = match x.pctf_desc with | Pctf_inherit (ct) -> - pp f "@[<2>inherit@ %a@]" self#class_type ct + pp f "@[<2>inherit@ %a@]%a" self#class_type ct + self#item_attributes x.pctf_attributes | Pctf_val (s, mf, vf, ct) -> - pp f "@[<2>val @ %a%a%s@ :@ %a@]" + pp f "@[<2>val @ %a%a%s@ :@ %a@]%a" self#mutable_flag mf self#virtual_flag vf s self#core_type ct + self#item_attributes x.pctf_attributes | Pctf_method (s, pf, vf, ct) -> - pp f "@[<2>method %a %a%s :@;%a@]" + pp f "@[<2>method %a %a%s :@;%a@]%a" self#private_flag pf self#virtual_flag vf s self#core_type ct + self#item_attributes x.pctf_attributes | Pctf_constraint (ct1, ct2) -> - pp f "@[<2>constraint@ %a@ =@ %a@]" + pp f "@[<2>constraint@ %a@ =@ %a@]%a" self#core_type ct1 self#core_type ct2 - | Pctf_extension _ -> assert false + self#item_attributes x.pctf_attributes + | Pctf_attribute a -> self#floating_attribute f a + | Pctf_extension e -> + self#item_extension f e; + self#item_attributes f x.pctf_attributes in - pp f "@[<hv0>@[<hv2>object @[<1>%a@]@ %a@]@ end@]" + pp f "@[<hv0>@[<hv2>object@[<1>%a@]@ %a@]@ end@]" (fun f ct -> match ct.ptyp_desc with | Ptyp_any -> () - | _ -> pp f "(%a)" self#core_type ct) ct + | _ -> pp f " (%a)" self#core_type ct) ct (self#list class_type_field ~sep:"@;") l ; (* call [class_signature] called by [class_signature] *) method class_type f x = match x.pcty_desc with - | Pcty_signature cs -> self#class_signature f cs; + | Pcty_signature cs -> + self#class_signature f cs; + self#attributes f x.pcty_attributes | Pcty_constr (li, l) -> - pp f "%a%a" + pp f "%a%a%a" (fun f l -> match l with | [] -> () | _ -> pp f "[%a]@ " (self#list self#core_type ~sep:"," ) l) l self#longident_loc li + self#attributes x.pcty_attributes | Pcty_arrow (l, co, cl) -> pp f "@[<2>%a@;->@;%a@]" (* FIXME remove parens later *) - self#type_with_label (l,co) self#class_type cl - | Pcty_extension _ -> assert false - + self#type_with_label (l,co) + self#class_type cl + | Pcty_extension e -> + self#extension f e; + self#attributes f x.pcty_attributes (* [class type a = object end] *) method class_type_declaration_list f l = - let class_type_declaration f ({pci_params=ls;pci_name={txt;_};_} as x) = - pp f "%a%a%s@ =@ %a" self#virtual_flag x.pci_virt + let class_type_declaration kwd f ({pci_params=ls;pci_name={txt;_};_} as x) = + pp f "@[<2>%s %a%a%s@ =@ %a@]%a" kwd + self#virtual_flag x.pci_virt self#class_params_def ls txt - self#class_type x.pci_expr in + self#class_type x.pci_expr + self#item_attributes x.pci_attributes + in match l with | [] -> () - | [h] -> pp f "@[<hv2>class type %a@]" class_type_declaration h - | _ -> - pp f "@[<2>class type %a@]" - (self#list class_type_declaration ~sep:"@]@;@[<2>and@;") l + | [x] -> class_type_declaration "class type" f x + | x :: xs -> + pp f "@[<v>%a@,%a@]" + (class_type_declaration "class type") x + (self#list ~sep:"@," (class_type_declaration "and")) xs method class_field f x = match x.pcf_desc with | Pcf_inherit (ovf, ce, so) -> - pp f "@[<2>inherit@ %s@ %a%a@]" (override ovf) self#class_expr ce + pp f "@[<2>inherit@ %s@ %a%a@]%a" (override ovf) + self#class_expr ce (fun f so -> match so with | None -> (); | Some (s) -> pp f "@ as %s" s ) so + self#item_attributes x.pcf_attributes | Pcf_val (s, mf, Cfk_concrete (ovf, e)) -> - pp f "@[<2>val%s %a%s =@;%a@]" (override ovf) self#mutable_flag mf - s.txt self#expression e + pp f "@[<2>val%s %a%s =@;%a@]%a" (override ovf) + self#mutable_flag mf s.txt + self#expression e + self#item_attributes x.pcf_attributes | Pcf_method (s, pf, Cfk_virtual ct) -> - pp f "@[<2>method virtual %a %s :@;%a@]" - self#private_flag pf s.txt self#core_type ct + pp f "@[<2>method virtual %a %s :@;%a@]%a" + self#private_flag pf s.txt + self#core_type ct + self#item_attributes x.pcf_attributes | Pcf_val (s, mf, Cfk_virtual ct) -> - pp f "@[<2>val virtual %a%s :@ %a@]" + pp f "@[<2>val virtual %a%s :@ %a@]%a" self#mutable_flag mf s.txt self#core_type ct + self#item_attributes x.pcf_attributes | Pcf_method (s, pf, Cfk_concrete (ovf, e)) -> - pp f "@[<2>method%s %a%a@]" + let bind e = + self#binding f + {pvb_pat= + {ppat_desc=Ppat_var s;ppat_loc=Location.none;ppat_attributes=[]}; + pvb_expr=e; + pvb_attributes=[]; + pvb_loc=Location.none; + } + in + pp f "@[<2>method%s %a%a@]%a" (override ovf) self#private_flag pf (fun f e -> match e.pexp_desc with | Pexp_poly (e, Some ct) -> pp f "%s :@;%a=@;%a" s.txt (self#core_type) ct self#expression e - | Pexp_poly (e,None) -> - self#binding f {pvb_pat={ppat_desc=Ppat_var s;ppat_loc=Location.none;ppat_attributes=[]}; - pvb_expr=e; - pvb_attributes=[]} - | _ -> - self#expression f e ) e + | Pexp_poly (e,None) -> bind e + | _ -> bind e) e + self#item_attributes x.pcf_attributes | Pcf_constraint (ct1, ct2) -> - pp f "@[<2>constraint %a =@;%a@]" self#core_type ct1 self#core_type ct2 + pp f "@[<2>constraint %a =@;%a@]%a" + self#core_type ct1 + self#core_type ct2 + self#item_attributes x.pcf_attributes | Pcf_initializer (e) -> - pp f "@[<2>initializer@ %a@]" self#expression e - | Pcf_extension _ -> assert false + pp f "@[<2>initializer@ %a@]%a" + self#expression e + self#item_attributes x.pcf_attributes + | Pcf_attribute a -> self#floating_attribute f a + | Pcf_extension e -> + self#item_extension f e; + self#item_attributes f x.pcf_attributes method class_structure f { pcstr_self = p; pcstr_fields = l } = - pp f "@[<hv0>@[<hv2>object %a@;%a@]@;end@]" + pp f "@[<hv0>@[<hv2>object%a@;%a@]@;end@]" (fun f p -> match p.ppat_desc with | Ppat_any -> () - | Ppat_constraint _ -> pp f "%a" self#pattern p - | _ -> pp f "(%a)" self#pattern p) p + | Ppat_constraint _ -> pp f " %a" self#pattern p + | _ -> pp f " (%a)" self#pattern p) p (self#list self#class_field ) l method class_expr f x = + if x.pcl_attributes <> [] then begin + pp f "((%a)%a)" self#class_expr {x with pcl_attributes=[]} + self#attributes x.pcl_attributes + end else match x.pcl_desc with - | Pcl_structure (cs) -> self#class_structure f cs ; + | Pcl_structure (cs) -> self#class_structure f cs | Pcl_fun (l, eo, p, e) -> - pp f "fun@ %a@ ->@ %a" self#label_exp (l,eo,p) self#class_expr e + pp f "fun@ %a@ ->@ %a" + self#label_exp (l,eo,p) + self#class_expr e | Pcl_let (rf, l, ce) -> - (* pp f "let@;%a%a@ in@ %a" *) - pp f "%a@ in@ %a" - (* self#rec_flag rf *) + pp f "%a@ in@ %a" self#bindings (rf,l) self#class_expr ce | Pcl_apply (ce, l) -> - pp f "(%a@ %a)" self#class_expr ce (self#list self#label_x_expression_param) l + pp f "(%a@ %a)" + self#class_expr ce + (self#list self#label_x_expression_param) l | Pcl_constr (li, l) -> pp f "%a%a" (fun f l-> if l <>[] then @@ -829,9 +879,13 @@ class printer ()= object(self:'self) pp f "(%a@ :@ %a)" self#class_expr ce self#class_type ct - | Pcl_extension _ -> assert false + | Pcl_extension e -> self#extension f e method module_type f x = + if x.pmty_attributes <> [] then begin + pp f "((%a)%a)" self#module_type {x with pmty_attributes=[]} + self#attributes x.pmty_attributes + end else match x.pmty_desc with | Pmty_ident li -> pp f "%a" self#longident_loc li; @@ -841,7 +895,7 @@ class printer ()= object(self:'self) pp f "@[<hv0>@[<hv2>sig@ %a@]@ end@]" (* "@[<hov>sig@ %a@ end@]" *) (self#list self#signature_item ) s (* FIXME wrong indentation*) | Pmty_functor (_, None, mt2) -> - pp f "@[<hov2>functor () ->@ %a@]" self#module_type mt2 + pp f "@[<hov2>functor () ->@ %a@]" self#module_type mt2 | Pmty_functor (s, Some mt1, mt2) -> pp f "@[<hov2>functor@ (%s@ :@ %a)@ ->@ %a@]" s.txt self#module_type mt1 self#module_type mt2 @@ -850,14 +904,14 @@ class printer ()= object(self:'self) | Pwith_type (li, ({ptype_params= ls ;_} as td)) -> let ls = List.map fst ls in pp f "type@ %a %a =@ %a" - (self#list self#type_var_option ~sep:"," ~first:"(" ~last:")") - ls self#longident_loc li self#type_declaration td + (self#list self#core_type ~sep:"," ~first:"(" ~last:")") + ls self#longident_loc li self#type_declaration td | Pwith_module (li, li2) -> pp f "module %a =@ %a" self#longident_loc li self#longident_loc li2; | Pwith_typesubst ({ptype_params=ls;_} as td) -> let ls = List.map fst ls in pp f "type@ %a %s :=@ %a" - (self#list self#type_var_option ~sep:"," ~first:"(" ~last:")") + (self#list self#core_type ~sep:"," ~first:"(" ~last:")") ls td.ptype_name.txt self#type_declaration td | Pwith_modsubst (s, li2) -> @@ -869,7 +923,7 @@ class printer ()= object(self:'self) | Pmty_typeof me -> pp f "@[<hov2>module@ type@ of@ %a@]" self#module_expr me - | Pmty_extension _ -> assert false + | Pmty_extension e -> self#extension f e method signature f x = self#list ~sep:"@\n" self#signature_item f x @@ -878,42 +932,51 @@ class printer ()= object(self:'self) | Psig_type l -> self#type_def_list f l | Psig_value vd -> - pp f "@[<2>%a@]" - (fun f vd -> - let intro = if vd.pval_prim = [] then "val" else "external" in - pp f "%s@ %a@ :@ " intro protect_ident vd.pval_name.txt; - self#value_description f vd;) vd + let intro = if vd.pval_prim = [] then "val" else "external" in + pp f "@[<2>%s@ %a@ :@ %a@]%a" intro + protect_ident vd.pval_name.txt + self#value_description vd + self#item_attributes vd.pval_attributes + | Psig_typext te -> + self#type_extension f te | Psig_exception ed -> self#exception_declaration f ed | Psig_class l -> - let class_description f ({pci_params=ls;pci_name={txt;_};_} as x) = - pp f "%a%a%s@;:@;%a" (* "@[<2>class %a%a%s@;:@;%a@]" *) + let class_description kwd f ({pci_params=ls;pci_name={txt;_};_} as x) = + pp f "@[<2>%s %a%a%s@;:@;%a@]%a" kwd self#virtual_flag x.pci_virt - self#class_params_def - ls - txt self#class_type x.pci_expr in - pp f "@[<0>%a@]" - (fun f l -> match l with - |[] ->() - |[x] -> pp f "@[<2>class %a@]" class_description x - |_ -> - self#list ~first:"@[<v0>class @[<2>" ~sep:"@]@;and @[" - ~last:"@]@]" class_description f l) - l - | Psig_module {pmd_name; pmd_type={pmty_desc=Pmty_alias alias}} -> - pp f "@[<hov>module@ %s@ =@ %a@]" - pmd_name.txt self#longident_loc alias + self#class_params_def ls txt + self#class_type x.pci_expr + self#item_attributes x.pci_attributes + in begin + match l with + | [] -> () + | [x] -> class_description "class" f x + | x :: xs -> + pp f "@[<v>%a@,%a@]" + (class_description "class") x + (self#list ~sep:"@," (class_description "and")) xs + end + | Psig_module ({pmd_type={pmty_desc=Pmty_alias alias};_} as pmd) -> + pp f "@[<hov>module@ %s@ =@ %a@]%a" pmd.pmd_name.txt + self#longident_loc alias + self#item_attributes pmd.pmd_attributes | Psig_module pmd -> - pp f "@[<hov>module@ %s@ :@ %a@]" + pp f "@[<hov>module@ %s@ :@ %a@]%a" pmd.pmd_name.txt - self#module_type pmd.pmd_type - | Psig_open (ovf, li, _attrs) -> - pp f "@[<hov2>open%s@ %a@]" (override ovf) self#longident_loc li - | Psig_include (mt, _attrs) -> - pp f "@[<hov2>include@ %a@]" - self#module_type mt - | Psig_modtype {pmtd_name=s; pmtd_type=md} -> - pp f "@[<hov2>module@ type@ %s%a@]" + self#module_type pmd.pmd_type + self#item_attributes pmd.pmd_attributes + | Psig_open od -> + pp f "@[<hov2>open%s@ %a@]%a" + (override od.popen_override) + self#longident_loc od.popen_lid + self#item_attributes od.popen_attributes + | Psig_include incl -> + pp f "@[<hov2>include@ %a@]%a" + self#module_type incl.pincl_mod + self#item_attributes incl.pincl_attributes + | Psig_modtype {pmtd_name=s; pmtd_type=md; pmtd_attributes=attrs} -> + pp f "@[<hov2>module@ type@ %s%a@]%a" s.txt (fun f md -> match md with | None -> () @@ -921,6 +984,7 @@ class printer ()= object(self:'self) pp_print_space f () ; pp f "@ =@ %a" self#module_type mt ) md + self#item_attributes attrs | Psig_class_type (l) -> self#class_type_declaration_list f l ; | Psig_recmodule decls -> @@ -929,17 +993,26 @@ class printer ()= object(self:'self) | [] -> () ; | pmd :: tl -> if not first then - pp f "@ @[<hov2>and@ %s:@ %a@]" - pmd.pmd_name.txt self#module_type pmd.pmd_type + pp f "@ @[<hov2>and@ %s:@ %a@]%a" pmd.pmd_name.txt + self#module_type pmd.pmd_type + self#item_attributes pmd.pmd_attributes else - pp f "@ @[<hov2>module@ rec@ %s:@ %a@]" - pmd.pmd_name.txt self#module_type pmd.pmd_type; - string_x_module_type_list f ~first:false tl in - string_x_module_type_list f decls - | Psig_attribute _ - | Psig_extension _ -> assert false + pp f "@[<hov2>module@ rec@ %s:@ %a@]%a" pmd.pmd_name.txt + self#module_type pmd.pmd_type + self#item_attributes pmd.pmd_attributes; + string_x_module_type_list f ~first:false tl + in + string_x_module_type_list f decls + | Psig_attribute a -> self#floating_attribute f a + | Psig_extension(e, a) -> + self#item_extension f e; + self#item_attributes f a end method module_expr f x = + if x.pmod_attributes <> [] then begin + pp f "((%a)%a)" self#module_expr {x with pmod_attributes=[]} + self#attributes x.pmod_attributes + end else match x.pmod_desc with | Pmod_structure (s) -> pp f "@[<hv2>struct@;@[<0>%a@]@;<1 -2>end@]" @@ -959,11 +1032,15 @@ class printer ()= object(self:'self) pp f "%a(%a)" self#module_expr me1 self#module_expr me2 | Pmod_unpack e -> pp f "(val@ %a)" self#expression e - | Pmod_extension _ -> assert false + | Pmod_extension e -> self#extension f e method structure f x = self#list ~sep:"@\n" self#structure_item f x method payload f = function + | PStr [{pstr_desc = Pstr_eval (e, attrs)}] -> + pp f "@[<2>%a@]%a" + self#expression e + self#item_attributes attrs | PStr x -> self#structure f x | PTyp x -> pp f ":"; self#core_type f x | PPat (x, None) -> pp f "?"; self#pattern f x @@ -972,7 +1049,7 @@ class printer ()= object(self:'self) pp f " when "; self#expression f e (* transform [f = fun g h -> ..] to [f g h = ... ] could be improved *) - method binding f {pvb_pat=p; pvb_expr=x; pvb_attributes=_} = (* TODO: print attributes *) + method binding f {pvb_pat=p; pvb_expr=x; _} = let rec pp_print_pexp_function f x = if x.pexp_attributes <> [] then pp f "=@;%a" self#expression x else match x.pexp_desc with @@ -990,74 +1067,75 @@ class printer ()= object(self:'self) | ( _ , Ppat_constraint( p ,ty)) -> (* special case for the first*) (match ty.ptyp_desc with | Ptyp_poly _ -> - pp f "%a@;:@;%a=@;%a" self#simple_pattern p self#core_type ty self#expression x + pp f "%a@;:@;%a=@;%a" self#simple_pattern p + self#core_type ty self#expression x | _ -> - pp f "(%a@;:%a)=@;%a" self#simple_pattern p self#core_type ty self#expression x) + pp f "(%a@;:%a)=@;%a" self#simple_pattern p + self#core_type ty self#expression x) | Pexp_constraint (e,t1),Ppat_var {txt;_} -> - pp f "%s:@ %a@;=@;%a" txt self#core_type t1 self#expression e + pp f "%s:@ %a@;=@;%a" txt self#core_type t1 self#expression e | (_, Ppat_var _) -> pp f "%a@ %a" self#simple_pattern p pp_print_pexp_function x | _ -> pp f "%a@;=@;%a" self#pattern p self#expression x (* [in] is not printed *) method bindings f (rf,l) = + let binding kwd rf f x = + pp f "@[<2>%s %a%a@]%a" kwd self#rec_flag rf + self#binding x self#item_attributes x.pvb_attributes + in begin match l with | [] -> () - | [x] -> pp f "@[<2>let %a%a@]" self#rec_flag rf self#binding x + | [x] -> binding "let" rf f x | x::xs -> - (* pp f "@[<hv0>let %a@[<2>%a%a@]" *) - (* FIXME the indentation is not good see [Insert].ml*) - pp f "@[<hv0>@[<2>let %a%a%a@]" - self#rec_flag rf self#binding x - (fun f l -> match l with - | [] -> assert false - | [x] -> - pp f - (* "@]@;and @[<2>%a@]" *) - "@]@;@[<2>and %a@]" - self#binding x - | xs -> - self#list self#binding - (* ~first:"@]@;and @[<2>" *) - ~first:"@]@;@[<2>and " - (* ~sep:"@]@;and @[<2>" *) - ~sep:"@]@;@[<2>and " - ~last:"@]" f xs ) xs + pp f "@[<v>%a@,%a@]" + (binding "let" rf) x + (self#list ~sep:"@," (binding "and" Nonrecursive)) xs end method structure_item f x = begin match x.pstr_desc with - | Pstr_eval (e, _attrs) -> - pp f "@[<hov2>let@ _ =@ %a@]" self#expression e + | Pstr_eval (e, attrs) -> + pp f "@[<hov2>let@ _ =@ %a@]%a" + self#expression e + self#item_attributes attrs | Pstr_type [] -> assert false | Pstr_type l -> self#type_def_list f l | Pstr_value (rf, l) -> (* pp f "@[<hov2>let %a%a@]" self#rec_flag rf self#bindings l *) pp f "@[<2>%a@]" self#bindings (rf,l) + | Pstr_typext te -> self#type_extension f te | Pstr_exception ed -> self#exception_declaration f ed | Pstr_module x -> - let rec module_helper me = match me.pmod_desc with - | Pmod_functor(s,mt,me) -> - if mt = None then pp f "()" - else Misc.may (pp f "(%s:%a)" s.txt self#module_type) mt; - module_helper me - | _ -> me in - pp f "@[<hov2>module %s%a@]" + let rec module_helper me = + match me.pmod_desc with + | Pmod_functor(s,mt,me') when me.pmod_attributes = [] -> + if mt = None then pp f "()" + else Misc.may (pp f "(%s:%a)" s.txt self#module_type) mt; + module_helper me' + | _ -> me + in + pp f "@[<hov2>module %s%a@]%a" x.pmb_name.txt (fun f me -> - let me = module_helper me in + let me = module_helper me in (match me.pmod_desc with | Pmod_constraint - (me, + (me', ({pmty_desc=(Pmty_ident (_) - | Pmty_signature (_));_} as mt)) -> - pp f " :@;%a@;=@;%a@;" self#module_type mt self#module_expr me + | Pmty_signature (_));_} as mt)) + when me.pmod_attributes = [] -> + pp f " :@;%a@;=@;%a@;" self#module_type mt self#module_expr me' | _ -> - pp f " =@ %a" self#module_expr me + pp f " =@ %a" self#module_expr me )) x.pmb_expr - | Pstr_open (ovf, li, _attrs) -> - pp f "@[<2>open%s@;%a@]" (override ovf) self#longident_loc li; - | Pstr_modtype {pmtd_name=s; pmtd_type=md} -> - pp f "@[<hov2>module@ type@ %s%a@]" + self#item_attributes x.pmb_attributes + | Pstr_open od -> + pp f "@[<2>open%s@;%a@]%a" + (override od.popen_override) + self#longident_loc od.popen_lid + self#item_attributes od.popen_attributes + | Pstr_modtype {pmtd_name=s; pmtd_type=md; pmtd_attributes=attrs} -> + pp f "@[<hov2>module@ type@ %s%a@]%a" s.txt (fun f md -> match md with | None -> () @@ -1065,135 +1143,204 @@ class printer ()= object(self:'self) pp_print_space f () ; pp f "@ =@ %a" self#module_type mt ) md + self#item_attributes attrs | Pstr_class l -> - let class_declaration f (* for the second will be changed to and FIXME*) - ({pci_params=ls; - pci_name={txt;_}; - pci_virt; - pci_expr={pcl_desc;_}; - _ } as x) = - let rec class_fun_helper f e = match e.pcl_desc with - | Pcl_fun (l, eo, p, e) -> - self#label_exp f (l,eo,p); - class_fun_helper f e - | _ -> e in - pp f "%a%a%s %a" self#virtual_flag pci_virt self#class_params_def ls txt - (fun f _ -> - let ce = - (match pcl_desc with - | Pcl_fun _ -> - class_fun_helper f x.pci_expr; - | _ -> x.pci_expr) in - let ce = - (match ce.pcl_desc with - | Pcl_constraint (ce, ct) -> - pp f ": @[%a@] " self#class_type ct ; - ce - | _ -> ce ) in - pp f "=@;%a" self#class_expr ce ) x in - (match l with - | [] -> () - | [x] -> pp f "@[<2>class %a@]" class_declaration x - | xs -> self#list - ~first:"@[<v0>class @[<2>" - ~sep:"@]@;and @[" - ~last:"@]@]" class_declaration f xs) + let extract_class_args cl = + let rec loop acc cl = + match cl.pcl_desc with + | Pcl_fun (l, eo, p, cl') when cl.pcl_attributes = [] -> + loop ((l,eo,p) :: acc) cl' + | _ -> List.rev acc, cl + in + let args, cl = loop [] cl in + let constr, cl = + match cl.pcl_desc with + | Pcl_constraint (cl', ct) when cl.pcl_attributes = [] -> + Some ct, cl' + | _ -> None, cl + in + args, constr, cl + in + let class_constraint f ct = pp f ": @[%a@] " self#class_type ct in + let class_declaration kwd f + ({pci_params=ls; pci_name={txt;_}; _} as x) = + let args, constr, cl = extract_class_args x.pci_expr in + pp f "@[<2>%s %a%a%s %a%a=@;%a@]%a" kwd + self#virtual_flag x.pci_virt + self#class_params_def ls txt + (self#list self#label_exp) args + (self#option class_constraint) constr + self#class_expr cl + self#item_attributes x.pci_attributes + in begin + match l with + | [] -> () + | [x] -> class_declaration "class" f x + | x :: xs -> + pp f "@[<v>%a@,%a@]" + (class_declaration "class") x + (self#list ~sep:"@," (class_declaration "and")) xs + end | Pstr_class_type (l) -> self#class_type_declaration_list f l ; | Pstr_primitive vd -> - pp f "@[<hov2>external@ %a@ :@ %a@]" protect_ident vd.pval_name.txt - self#value_description vd - | Pstr_include (me, _attrs) -> - pp f "@[<hov2>include@ %a@]" self#module_expr me - | Pstr_exn_rebind (s, li, _attrs) -> (* todo: check this *) - pp f "@[<hov2>exception@ %s@ =@ %a@]" s.txt self#longident_loc li + pp f "@[<hov2>external@ %a@ :@ %a@]%a" + protect_ident vd.pval_name.txt + self#value_description vd + self#item_attributes vd.pval_attributes + | Pstr_include incl -> + pp f "@[<hov2>include@ %a@]%a" + self#module_expr incl.pincl_mod + self#item_attributes incl.pincl_attributes | Pstr_recmodule decls -> (* 3.07 *) let aux f = function - | {pmb_name = s; pmb_expr={pmod_desc=Pmod_constraint (expr, typ)}} -> - pp f "@[<hov2>and@ %s:%a@ =@ %a@]" - s.txt self#module_type typ self#module_expr expr + | ({pmb_expr={pmod_desc=Pmod_constraint (expr, typ)}} as pmb) -> + pp f "@[<hov2>and@ %s:%a@ =@ %a@]%a" pmb.pmb_name.txt + self#module_type typ + self#module_expr expr + self#item_attributes pmb.pmb_attributes | _ -> assert false in begin match decls with - | {pmb_name = s; pmb_expr={pmod_desc=Pmod_constraint (expr, typ)}} :: l2 -> - pp f "@[<hv>@[<hov2>module@ rec@ %s:%a@ =@ %a@]@ %a@]" - s.txt + | ({pmb_expr={pmod_desc=Pmod_constraint (expr, typ)}} as pmb) :: l2 -> + pp f "@[<hv>@[<hov2>module@ rec@ %s:%a@ =@ %a@]%a@ %a@]" + pmb.pmb_name.txt self#module_type typ self#module_expr expr + self#item_attributes pmb.pmb_attributes (fun f l2 -> List.iter (aux f) l2) l2 | _ -> assert false end - | Pstr_attribute _ -> () - | Pstr_extension _ -> assert false + | Pstr_attribute a -> self#floating_attribute f a + | Pstr_extension(e, a) -> + self#item_extension f e; + self#item_attributes f a end - method type_param f (opt, a) = - pp f "%s%a" (type_variance a ) self#type_var_option opt - (* shared by [Pstr_type,Psig_type]*) - method type_def_list f l = - let aux f ({ptype_name = s; ptype_params;ptype_kind;ptype_manifest;_} as td) = - pp f "%a%s%a" - (fun f l -> match l with - |[] -> () - | _ -> pp f "%a@;" (self#list self#type_param ~first:"(" ~last:")" ~sep:",") l) - ptype_params s.txt - (fun f td ->begin match ptype_kind, ptype_manifest with - | Ptype_abstract, None -> () - | _ , _ -> pp f " =@;" end; - pp f "%a" self#type_declaration td ) td in + method type_param f (ct, a) = + pp f "%s%a" (type_variance a) self#core_type ct + method type_params f = function + [] -> () + | l -> pp f "%a " (self#list self#type_param ~first:"(" ~last:")" ~sep:",") l + method type_def_list f l = + let type_decl kwd f x = + let eq = + if (x.ptype_kind = Ptype_abstract) + && (x.ptype_manifest = None) then "" + else " =" + in + pp f "@[<2>%s %a%s%s%a@]%a" kwd + self#type_params x.ptype_params + x.ptype_name.txt eq + self#type_declaration x + self#item_attributes x.ptype_attributes + in match l with - | [] -> () ; - | [x] -> pp f "@[<2>type %a@]" aux x - | xs -> pp f "@[<v>@[<2>type %a" - (self#list aux ~sep:"@]@,@[<2>and " ~last:"@]@]") xs - (* called by type_def_list *) - method type_declaration f x = begin - let type_variant_leaf f {pcd_name; pcd_args; pcd_res; pcd_loc=_} = match pcd_res with - |None -> - pp f "@\n|@;%s%a" pcd_name.txt - (fun f l -> match l with - | Pcstr_tuple [] -> () - | Pcstr_tuple l -> pp f "@;of@;%a" (self#list self#core_type1 ~sep:"*@;") l - | Pcstr_record _ -> assert false (* TODO *) - ) pcd_args - |Some x -> - begin match pcd_args with - | Pcstr_tuple l -> - pp f "@\n|@;%s:@;%a" pcd_name.txt - (self#list self#core_type1 ~sep:"@;->@;") (l@[x]) - | Pcstr_record _ -> assert false (* TODO *) - end + | [] -> assert false + | [x] -> type_decl "type" f x + | x :: xs -> pp f "@[<v>%a@,%a@]" + (type_decl "type") x + (self#list ~sep:"@," (type_decl "and")) xs + + method record_declaration f lbls = + let type_record_field f pld = + pp f "@[<2>%a%s:@;%a@]" self#mutable_flag pld.pld_mutable pld.pld_name.txt self#core_type pld.pld_type in + pp f "{@\n%a}" + (self#list type_record_field ~sep:";@\n" ) lbls + + method type_declaration f x = + let priv f = + match x.ptype_private with + Public -> () + | Private -> pp f "@;private" in - pp f "%a%a@ %a" - (fun f x -> match (x.ptype_manifest,x.ptype_kind,x.ptype_private) with - | (None,_,Public) -> pp f "@;" - | (None,Ptype_abstract,Private) -> pp f "@;" (* private type without print*) - | (None,_,Private) -> pp f "private@;" - | (Some y, Ptype_abstract,Private) -> - pp f "private@;%a" self#core_type y; - | (Some y, _, Private) -> - pp f "%a = private@;" self#core_type y - | (Some y,Ptype_abstract, Public) -> self#core_type f y; - | (Some y, _,Public) -> begin - pp f "%a =@;" self#core_type y (* manifest types*) - end) x - (fun f x -> match x.ptype_kind with - (*here only normal variant types allowed here*) + let manifest f = + match x.ptype_manifest with + | None -> () + | Some y -> pp f "@;%a" self#core_type y + in + let constructor_declaration f pcd = + pp f "|@;"; + self#constructor_declaration f (pcd.pcd_name.txt, pcd.pcd_args, pcd.pcd_res, pcd.pcd_attributes) + in + let label_declaration f pld = + pp f "@[<2>%a%s%a:@;%a;@]" + self#mutable_flag pld.pld_mutable + pld.pld_name.txt + self#attributes pld.pld_attributes + self#core_type pld.pld_type + in + let repr f = + let intro f = + if x.ptype_manifest = None then () + else pp f "@;=" + in + match x.ptype_kind with | Ptype_variant xs -> - pp f "%a" - (self#list ~sep:"" type_variant_leaf) xs + pp f "%t@\n%a" intro + (self#list ~sep:"@\n" constructor_declaration) xs | Ptype_abstract -> () | Ptype_record l -> - let type_record_field f pld = - pp f "@[<2>%a%s:@;%a@]" self#mutable_flag pld.pld_mutable pld.pld_name.txt self#core_type pld.pld_type in - pp f "{@\n%a}" - (self#list type_record_field ~sep:";@\n" ) l ; - ) x - (self#list - (fun f (ct1,ct2,_) -> + pp f "%t@;{@\n%a}" intro + (self#list ~sep:"@\n" label_declaration) l ; + | Ptype_open -> pp f "%t@;.." intro + in + let constraints f = + self#list ~first:"@ " + (fun f (ct1,ct2,_) -> pp f "@[<hov2>constraint@ %a@ =@ %a@]" - self#core_type ct1 self#core_type ct2 )) x.ptype_cstrs ; - (* TODO: attributes *) - end + self#core_type ct1 self#core_type ct2) + f x.ptype_cstrs + in + pp f "%t%t%t%t" priv manifest repr constraints + + method type_extension f x = + let extension_constructor f x = + pp f "@\n|@;%a" self#extension_constructor x + in + pp f "@[<2>type %a%a +=%a@]%a" + (fun f -> function + | [] -> () + | l -> pp f "%a@;" (self#list self#type_param ~first:"(" ~last:")" ~sep:",") l) + x.ptyext_params + self#longident_loc x.ptyext_path + (self#list ~sep:"" extension_constructor) + x.ptyext_constructors + self#item_attributes x.ptyext_attributes + + method constructor_declaration f (name, args, res, attrs) = + match res with + | None -> + pp f "%s%a%a" name + self#attributes attrs + (fun f -> function + | Pcstr_tuple [] -> () + | Pcstr_tuple l -> + pp f "@;of@;%a" (self#list self#core_type1 ~sep:"*@;") l + | Pcstr_record l -> pp f "@;of@;%a" (self#record_declaration) l + ) args + | Some r -> + pp f "%s%a:@;%a" name + self#attributes attrs + (fun f -> function + | Pcstr_tuple [] -> self#core_type1 f r + | Pcstr_tuple l -> pp f "%a@;->@;%a" + (self#list self#core_type1 ~sep:"*@;") l + self#core_type1 r + | Pcstr_record l -> + pp f "%a@;->@;%a" (self#record_declaration) l self#core_type1 r + ) + args + + + method extension_constructor f x = + match x.pext_kind with + | Pext_decl(l, r) -> + self#constructor_declaration f (x.pext_name.txt, l, r, x.pext_attributes) + | Pext_rebind li -> + pp f "%s%a@;=@;%a" x.pext_name.txt + self#attributes x.pext_attributes + self#longident_loc li + method case_list f l : unit = let aux f {pc_lhs; pc_guard; pc_rhs} = pp f "@;| @[<2>%a%a@;->@;%a@]" diff --git a/parsing/pprintast.mli b/parsing/pprintast.mli index 86297cea8..42a340915 100644 --- a/parsing/pprintast.mli +++ b/parsing/pprintast.mli @@ -27,7 +27,7 @@ class printer : method class_expr : Format.formatter -> Parsetree.class_expr -> unit method class_field : Format.formatter -> Parsetree.class_field -> unit method class_params_def : - Format.formatter -> (string Asttypes.loc * Asttypes.variance) list -> unit + Format.formatter -> (Parsetree.core_type * Asttypes.variance) list -> unit method class_signature : Format.formatter -> Parsetree.class_signature -> unit method class_structure : @@ -37,6 +37,7 @@ class printer : Format.formatter -> Parsetree.class_type_declaration list -> unit method constant : Format.formatter -> Asttypes.constant -> unit method constant_string : Format.formatter -> string -> unit + method constructor_declaration : Format.formatter -> (string * Parsetree.constructor_arguments * Parsetree.core_type option * Parsetree.attributes) -> unit method core_type : Format.formatter -> Parsetree.core_type -> unit method core_type1 : Format.formatter -> Parsetree.core_type -> unit method direction_flag : @@ -44,10 +45,12 @@ class printer : method directive_argument : Format.formatter -> Parsetree.directive_argument -> unit method exception_declaration : - Format.formatter -> Parsetree.constructor_declaration -> unit + Format.formatter -> Parsetree.extension_constructor -> unit method expression : Format.formatter -> Parsetree.expression -> unit method expression1 : Format.formatter -> Parsetree.expression -> unit method expression2 : Format.formatter -> Parsetree.expression -> unit + method extension_constructor : + Format.formatter -> Parsetree.extension_constructor -> unit method label_exp : Format.formatter -> Asttypes.label * Parsetree.expression option * Parsetree.pattern -> @@ -78,6 +81,7 @@ class printer : method payload : Format.formatter -> Parsetree.payload -> unit method private_flag : Format.formatter -> Asttypes.private_flag -> unit method rec_flag : Format.formatter -> Asttypes.rec_flag -> unit + method record_declaration : Format.formatter -> Parsetree.label_declaration list -> unit method reset : 'b method reset_semi : 'b @@ -102,10 +106,12 @@ class printer : Format.formatter -> Parsetree.type_declaration -> unit method type_def_list : Format.formatter -> Parsetree.type_declaration list -> unit + method type_extension : + Format.formatter -> Parsetree.type_extension -> unit method type_param : - Format.formatter -> string Asttypes.loc option * Asttypes.variance -> unit - method type_var_option : - Format.formatter -> string Asttypes.loc option -> unit + Format.formatter -> Parsetree.core_type * Asttypes.variance -> unit + method type_params : + Format.formatter -> (Parsetree.core_type * Asttypes.variance) list -> unit method type_with_label : Format.formatter -> Asttypes.label * Parsetree.core_type -> unit method tyvar : Format.formatter -> string -> unit @@ -116,7 +122,12 @@ class printer : Format.formatter -> Parsetree.value_description -> unit method virtual_flag : Format.formatter -> Asttypes.virtual_flag -> unit method attribute : Format.formatter -> Parsetree.attribute -> unit + method item_attribute : Format.formatter -> Parsetree.attribute -> unit + method floating_attribute : Format.formatter -> Parsetree.attribute -> unit method attributes : Format.formatter -> Parsetree.attributes -> unit + method item_attributes : Format.formatter -> Parsetree.attributes -> unit + method extension : Format.formatter -> Parsetree.extension -> unit + method item_extension : Format.formatter -> Parsetree.extension -> unit end val default : printer val toplevel_phrase : Format.formatter -> Parsetree.toplevel_phrase -> unit diff --git a/parsing/printast.ml b/parsing/printast.ml index 7979e4128..2bf9d8f3e 100644 --- a/parsing/printast.ml +++ b/parsing/printast.ml @@ -157,8 +157,9 @@ let rec core_type i ppf x = line i ppf "Ptyp_object %a\n" fmt_closed_flag c; let i = i + 1 in List.iter - (fun (s, t) -> - line i ppf "method %s" s; + (fun (s, attrs, t) -> + line i ppf "method %s\n" s; + attributes i ppf attrs; core_type (i + 1) ppf t ) l @@ -194,7 +195,8 @@ and pattern i ppf x = line i ppf "Ppat_alias %a\n" fmt_string_loc s; pattern i ppf p; | Ppat_constant (c) -> line i ppf "Ppat_constant %a\n" fmt_constant c; - | Ppat_interval (c1, c2) -> line i ppf "Ppat_interval %a..%a\n" fmt_constant c1 fmt_constant c2; + | Ppat_interval (c1, c2) -> + line i ppf "Ppat_interval %a..%a\n" fmt_constant c1 fmt_constant c2; | Ppat_tuple (l) -> line i ppf "Ppat_tuple\n"; list i pattern ppf l; @@ -226,6 +228,9 @@ and pattern i ppf x = longident_loc i ppf li | Ppat_unpack s -> line i ppf "Ppat_unpack %a\n" fmt_string_loc s; + | Ppat_exception p -> + line i ppf "Ppat_exception\n"; + pattern i ppf p | Ppat_extension (s, arg) -> line i ppf "Ppat_extension \"%s\"\n" s.txt; payload i ppf arg @@ -356,20 +361,17 @@ and expression i ppf x = payload i ppf arg and value_description i ppf x = - line i ppf "value_description %a %a\n" fmt_string_loc x.pval_name fmt_location x.pval_loc; + line i ppf "value_description %a %a\n" fmt_string_loc + x.pval_name fmt_location x.pval_loc; attributes i ppf x.pval_attributes; core_type (i+1) ppf x.pval_type; list (i+1) string ppf x.pval_prim -and type_parameter i ppf (x, _variance) = - match x with - | Some x -> - string_loc i ppf x - | None -> - string i ppf "_" +and type_parameter i ppf (x, _variance) = core_type i ppf x and type_declaration i ppf x = - line i ppf "type_declaration %a %a\n" fmt_string_loc x.ptype_name fmt_location x.ptype_loc; + line i ppf "type_declaration %a %a\n" fmt_string_loc x.ptype_name + fmt_location x.ptype_loc; attributes i ppf x.ptype_attributes; let i = i+1 in line i ppf "ptype_params =\n"; @@ -411,6 +413,37 @@ and type_kind i ppf x = | Ptype_record l -> line i ppf "Ptype_record\n"; list (i+1) label_decl ppf l; + | Ptype_open -> + line i ppf "Ptype_open\n"; + +and type_extension i ppf x = + line i ppf "type_extension\n"; + attributes i ppf x.ptyext_attributes; + let i = i+1 in + line i ppf "ptyext_path = %a\n" fmt_longident_loc x.ptyext_path; + line i ppf "ptyext_params =\n"; + list (i+1) type_parameter ppf x.ptyext_params; + line i ppf "ptyext_constructors =\n"; + list (i+1) extension_constructor ppf x.ptyext_constructors; + line i ppf "ptyext_private = %a\n" fmt_private_flag x.ptyext_private; + +and extension_constructor i ppf x = + line i ppf "extension_constructor %a\n" fmt_location x.pext_loc; + attributes i ppf x.pext_attributes; + let i = i + 1 in + line i ppf "pext_name = \"%s\"\n" x.pext_name.txt; + line i ppf "pext_kind =\n"; + extension_constructor_kind (i + 1) ppf x.pext_kind; + +and extension_constructor_kind i ppf x = + match x with + Pext_decl(a, r) -> + line i ppf "Pext_decl\n"; + constructor_arguments (i+1) ppf a; + option (i+1) core_type ppf r; + | Pext_rebind li -> + line i ppf "Pext_rebind\n"; + line (i+1) ppf "%a\n" fmt_longident_loc li; and class_type i ppf x = line i ppf "class_type %a\n" fmt_location x.pcty_loc; @@ -449,12 +482,16 @@ and class_type_field i ppf x = fmt_virtual_flag vf; core_type (i+1) ppf ct; | Pctf_method (s, pf, vf, ct) -> - line i ppf "Pctf_method \"%s\" %a %a\n" s fmt_private_flag pf fmt_virtual_flag vf; + line i ppf "Pctf_method \"%s\" %a %a\n" s fmt_private_flag pf + fmt_virtual_flag vf; core_type (i+1) ppf ct; | Pctf_constraint (ct1, ct2) -> line i ppf "Pctf_constraint\n"; core_type (i+1) ppf ct1; core_type (i+1) ppf ct2; + | Pctf_attribute (s, arg) -> + line i ppf "Pctf_attribute \"%s\"\n" s.txt; + payload i ppf arg | Pctf_extension (s, arg) -> line i ppf "Pctf_extension \"%s\"\n" s.txt; payload i ppf arg @@ -465,7 +502,7 @@ and class_description i ppf x = let i = i+1 in line i ppf "pci_virt = %a\n" fmt_virtual_flag x.pci_virt; line i ppf "pci_params =\n"; - cl_type_parameters (i+1) ppf x.pci_params; + list (i+1) type_parameter ppf x.pci_params; line i ppf "pci_name = %a\n" fmt_string_loc x.pci_name; line i ppf "pci_expr =\n"; class_type (i+1) ppf x.pci_expr; @@ -476,7 +513,7 @@ and class_type_declaration i ppf x = let i = i+1 in line i ppf "pci_virt = %a\n" fmt_virtual_flag x.pci_virt; line i ppf "pci_params =\n"; - cl_type_parameters (i+1) ppf x.pci_params; + list (i+1) type_parameter ppf x.pci_params; line i ppf "pci_name = %a\n" fmt_string_loc x.pci_name; line i ppf "pci_expr =\n"; class_type (i+1) ppf x.pci_expr; @@ -543,6 +580,9 @@ and class_field i ppf x = | Pcf_initializer (e) -> line i ppf "Pcf_initializer\n"; expression (i+1) ppf e; + | Pcf_attribute (s, arg) -> + line i ppf "Pcf_attribute \"%s\"\n" s.txt; + payload i ppf arg | Pcf_extension (s, arg) -> line i ppf "Pcf_extension \"%s\"\n" s.txt; payload i ppf arg @@ -561,7 +601,7 @@ and class_declaration i ppf x = let i = i+1 in line i ppf "pci_virt = %a\n" fmt_virtual_flag x.pci_virt; line i ppf "pci_params =\n"; - cl_type_parameters (i+1) ppf x.pci_params; + list (i+1) type_parameter ppf x.pci_params; line i ppf "pci_name = %a\n" fmt_string_loc x.pci_name; line i ppf "pci_expr =\n"; class_expr (i+1) ppf x.pci_expr; @@ -603,9 +643,12 @@ and signature_item i ppf x = | Psig_type (l) -> line i ppf "Psig_type\n"; list i type_declaration ppf l; - | Psig_exception cd -> + | Psig_typext te -> + line i ppf "Psig_typext\n"; + type_extension i ppf te + | Psig_exception ext -> line i ppf "Psig_exception\n"; - constructor_decl i ppf cd; + extension_constructor i ppf ext; | Psig_module pmd -> line i ppf "Psig_module %a\n" fmt_string_loc pmd.pmd_name; attributes i ppf pmd.pmd_attributes; @@ -617,15 +660,15 @@ and signature_item i ppf x = line i ppf "Psig_modtype %a\n" fmt_string_loc x.pmtd_name; attributes i ppf x.pmtd_attributes; modtype_declaration i ppf x.pmtd_type - | Psig_open (ovf, li, attrs) -> + | Psig_open od -> line i ppf "Psig_open %a %a\n" - fmt_override_flag ovf - fmt_longident_loc li; - attributes i ppf attrs - | Psig_include (mt, attrs) -> + fmt_override_flag od.popen_override + fmt_longident_loc od.popen_lid; + attributes i ppf od.popen_attributes + | Psig_include incl -> line i ppf "Psig_include\n"; - module_type i ppf mt; - attributes i ppf attrs + module_type i ppf incl.pincl_mod; + attributes i ppf incl.pincl_attributes | Psig_class (l) -> line i ppf "Psig_class\n"; list i class_description ppf l; @@ -708,14 +751,12 @@ and structure_item i ppf x = | Pstr_type l -> line i ppf "Pstr_type\n"; list i type_declaration ppf l; - | Pstr_exception cd -> + | Pstr_typext te -> + line i ppf "Pstr_typext\n"; + type_extension i ppf te + | Pstr_exception ext -> line i ppf "Pstr_exception\n"; - constructor_decl i ppf cd; - | Pstr_exn_rebind (s, li, attrs) -> - line i ppf "Pstr_exn_rebind\n"; - attributes i ppf attrs; - line (i+1) ppf "%a\n" fmt_string_loc s; - line (i+1) ppf "%a\n" fmt_longident_loc li + extension_constructor i ppf ext; | Pstr_module x -> line i ppf "Pstr_module\n"; module_binding i ppf x @@ -726,21 +767,21 @@ and structure_item i ppf x = line i ppf "Pstr_modtype %a\n" fmt_string_loc x.pmtd_name; attributes i ppf x.pmtd_attributes; modtype_declaration i ppf x.pmtd_type - | Pstr_open (ovf, li, attrs) -> + | Pstr_open od -> line i ppf "Pstr_open %a %a\n" - fmt_override_flag ovf - fmt_longident_loc li; - attributes i ppf attrs + fmt_override_flag od.popen_override + fmt_longident_loc od.popen_lid; + attributes i ppf od.popen_attributes | Pstr_class (l) -> line i ppf "Pstr_class\n"; list i class_declaration ppf l; | Pstr_class_type (l) -> line i ppf "Pstr_class_type\n"; list i class_type_declaration ppf l; - | Pstr_include (me, attrs) -> + | Pstr_include incl -> line i ppf "Pstr_include"; - attributes i ppf attrs; - module_expr i ppf me + attributes i ppf incl.pincl_attributes; + module_expr i ppf incl.pincl_mod | Pstr_extension ((s, arg), attrs) -> line i ppf "Pstr_extension \"%s\"\n" s.txt; attributes i ppf attrs; @@ -764,30 +805,25 @@ and core_type_x_core_type_x_location i ppf (ct1, ct2, l) = core_type (i+1) ppf ct1; core_type (i+1) ppf ct2; -and constructor_decl i ppf {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} = +and constructor_decl i ppf + {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} = line i ppf "%a\n" fmt_location pcd_loc; - attributes i ppf pcd_attributes; line (i+1) ppf "%a\n" fmt_string_loc pcd_name; - begin match pcd_args with - | Pcstr_tuple l -> list (i+1) core_type ppf l; - | Pcstr_record l -> list (i+1) label_decl ppf l - end; + attributes i ppf pcd_attributes; + constructor_arguments (i+1) ppf pcd_args; option (i+1) core_type ppf pcd_res -and label_decl i ppf {pld_name; pld_mutable; pld_type; pld_loc; pld_attributes} = +and constructor_arguments i ppf = function + | Pcstr_tuple l -> list i core_type ppf l + | Pcstr_record l -> list i label_decl ppf l + +and label_decl i ppf {pld_name; pld_mutable; pld_type; pld_loc; pld_attributes}= line i ppf "%a\n" fmt_location pld_loc; attributes i ppf pld_attributes; line (i+1) ppf "%a\n" fmt_mutable_flag pld_mutable; line (i+1) ppf "%a" fmt_string_loc pld_name; core_type (i+1) ppf pld_type -and cl_type_parameters i ppf l = - line i ppf "<params>\n"; - list (i+1) cl_type_parameter ppf l; - -and cl_type_parameter i ppf (x, _variance) = - string_loc i ppf x - and longident_x_pattern i ppf (li, p) = line i ppf "%a\n" fmt_longident_loc li; pattern (i+1) ppf p; @@ -821,8 +857,9 @@ and label_x_expression i ppf (l,e) = and label_x_bool_x_core_type_list i ppf x = match x with - Rtag (l, b, ctl) -> + Rtag (l, attrs, b, ctl) -> line i ppf "Rtag \"%s\" %s\n" l (string_of_bool b); + attributes (i+1) ppf attrs; list (i+1) core_type ppf ctl | Rinherit (ct) -> line i ppf "Rinherit\n"; diff --git a/parsing/syntaxerr.ml b/parsing/syntaxerr.ml index e239d6fe2..8c2f37b35 100644 --- a/parsing/syntaxerr.ml +++ b/parsing/syntaxerr.ml @@ -19,6 +19,7 @@ type error = | Applicative_path of Location.t | Variable_in_scope of Location.t * string | Other of Location.t + | Ill_formed_ast of Location.t * string exception Error of error exception Escape_error @@ -51,6 +52,8 @@ let prepare_error = function var var | Other loc -> Location.error ~loc "Error: Syntax error" + | Ill_formed_ast (loc, s) -> + Location.errorf ~loc "Error: broken invariant in parsetree: %s" s let () = Location.register_error_of_exn @@ -69,4 +72,9 @@ let location_of_error = function | Variable_in_scope(l,_) | Other l | Not_expecting (l, _) + | Ill_formed_ast (l, _) | Expecting (l, _) -> l + + +let ill_formed_ast loc s = + raise (Error (Ill_formed_ast (loc, s))) diff --git a/parsing/syntaxerr.mli b/parsing/syntaxerr.mli index 1aec26ed5..8147213fa 100644 --- a/parsing/syntaxerr.mli +++ b/parsing/syntaxerr.mli @@ -21,6 +21,7 @@ type error = | Applicative_path of Location.t | Variable_in_scope of Location.t * string | Other of Location.t + | Ill_formed_ast of Location.t * string exception Error of error exception Escape_error @@ -29,3 +30,4 @@ val report_error: formatter -> error -> unit (* Deprecated. Use Location.{error_of_exn, report_error}. *) val location_of_error: error -> Location.t +val ill_formed_ast: Location.t -> string -> 'a diff --git a/stdlib/.depend b/stdlib/.depend index e5b65ad51..96f95082d 100644 --- a/stdlib/.depend +++ b/stdlib/.depend @@ -2,7 +2,11 @@ arg.cmi : array.cmi : arrayLabels.cmi : buffer.cmi : +bytes.cmi : +bytesLabels.cmi : callback.cmi : +camlinternalFormat.cmi : camlinternalFormatBasics.cmi buffer.cmi +camlinternalFormatBasics.cmi : camlinternalLazy.cmi : camlinternalMod.cmi : obj.cmi camlinternalOO.cmi : obj.cmi @@ -27,16 +31,17 @@ nativeint.cmi : obj.cmi : int32.cmi oo.cmi : camlinternalOO.cmi parsing.cmi : obj.cmi lexing.cmi -pervasives.cmi : +pervasives.cmi : camlinternalFormatBasics.cmi printexc.cmi : -printf.cmi : obj.cmi buffer.cmi +printf.cmi : buffer.cmi queue.cmi : random.cmi : nativeint.cmi int64.cmi int32.cmi scanf.cmi : pervasives.cmi set.cmi : sort.cmi : stack.cmi : -stdLabels.cmi : stringLabels.cmi listLabels.cmi arrayLabels.cmi +stdLabels.cmi : stringLabels.cmi listLabels.cmi bytesLabels.cmi \ + arrayLabels.cmi stream.cmi : string.cmi : stringLabels.cmi : @@ -50,10 +55,20 @@ array.cmo : array.cmi array.cmx : array.cmi arrayLabels.cmo : array.cmi arrayLabels.cmi arrayLabels.cmx : array.cmx arrayLabels.cmi -buffer.cmo : sys.cmi string.cmi buffer.cmi -buffer.cmx : sys.cmx string.cmx buffer.cmi +buffer.cmo : sys.cmi string.cmi bytes.cmi buffer.cmi +buffer.cmx : sys.cmx string.cmx bytes.cmx buffer.cmi +bytes.cmo : pervasives.cmi list.cmi char.cmi bytes.cmi +bytes.cmx : pervasives.cmx list.cmx char.cmx bytes.cmi +bytesLabels.cmo : bytes.cmi bytesLabels.cmi +bytesLabels.cmx : bytes.cmx bytesLabels.cmi callback.cmo : obj.cmi callback.cmi callback.cmx : obj.cmx callback.cmi +camlinternalFormat.cmo : sys.cmi string.cmi char.cmi \ + camlinternalFormatBasics.cmi bytes.cmi buffer.cmi camlinternalFormat.cmi +camlinternalFormat.cmx : sys.cmx string.cmx char.cmx \ + camlinternalFormatBasics.cmx bytes.cmx buffer.cmx camlinternalFormat.cmi +camlinternalFormatBasics.cmo : camlinternalFormatBasics.cmi +camlinternalFormatBasics.cmx : camlinternalFormatBasics.cmi camlinternalLazy.cmo : obj.cmi camlinternalLazy.cmi camlinternalLazy.cmx : obj.cmx camlinternalLazy.cmi camlinternalMod.cmo : obj.cmi camlinternalOO.cmi array.cmi \ @@ -68,20 +83,22 @@ char.cmo : char.cmi char.cmx : char.cmi complex.cmo : complex.cmi complex.cmx : complex.cmi -digest.cmo : string.cmi char.cmi digest.cmi -digest.cmx : string.cmx char.cmx digest.cmi +digest.cmo : string.cmi char.cmi bytes.cmi digest.cmi +digest.cmx : string.cmx char.cmx bytes.cmx digest.cmi filename.cmo : sys.cmi string.cmi random.cmi printf.cmi lazy.cmi buffer.cmi \ filename.cmi filename.cmx : sys.cmx string.cmx random.cmx printf.cmx lazy.cmx buffer.cmx \ filename.cmi -format.cmo : string.cmi printf.cmi pervasives.cmi obj.cmi list.cmi \ - buffer.cmi format.cmi -format.cmx : string.cmx printf.cmx pervasives.cmx obj.cmx list.cmx \ - buffer.cmx format.cmi +format.cmo : string.cmi pervasives.cmi camlinternalFormatBasics.cmi \ + camlinternalFormat.cmi buffer.cmi format.cmi +format.cmx : string.cmx pervasives.cmx camlinternalFormatBasics.cmx \ + camlinternalFormat.cmx buffer.cmx format.cmi gc.cmo : sys.cmi printf.cmi gc.cmi gc.cmx : sys.cmx printf.cmx gc.cmi -genlex.cmo : string.cmi stream.cmi list.cmi hashtbl.cmi char.cmi genlex.cmi -genlex.cmx : string.cmx stream.cmx list.cmx hashtbl.cmx char.cmx genlex.cmi +genlex.cmo : string.cmi stream.cmi list.cmi hashtbl.cmi char.cmi bytes.cmi \ + genlex.cmi +genlex.cmx : string.cmx stream.cmx list.cmx hashtbl.cmx char.cmx bytes.cmx \ + genlex.cmi hashtbl.cmo : sys.cmi string.cmi random.cmi obj.cmi lazy.cmi array.cmi \ hashtbl.cmi hashtbl.cmx : sys.cmx string.cmx random.cmx obj.cmx lazy.cmx array.cmx \ @@ -92,16 +109,16 @@ int64.cmo : pervasives.cmi int64.cmi int64.cmx : pervasives.cmx int64.cmi lazy.cmo : obj.cmi camlinternalLazy.cmi lazy.cmi lazy.cmx : obj.cmx camlinternalLazy.cmx lazy.cmi -lexing.cmo : sys.cmi string.cmi array.cmi lexing.cmi -lexing.cmx : sys.cmx string.cmx array.cmx lexing.cmi +lexing.cmo : sys.cmi string.cmi bytes.cmi array.cmi lexing.cmi +lexing.cmx : sys.cmx string.cmx bytes.cmx array.cmx lexing.cmi list.cmo : list.cmi list.cmx : list.cmi listLabels.cmo : list.cmi listLabels.cmi listLabels.cmx : list.cmx listLabels.cmi map.cmo : map.cmi map.cmx : map.cmi -marshal.cmo : string.cmi marshal.cmi -marshal.cmx : string.cmx marshal.cmi +marshal.cmo : bytes.cmi marshal.cmi +marshal.cmx : bytes.cmx marshal.cmi moreLabels.cmo : set.cmi map.cmi hashtbl.cmi moreLabels.cmi moreLabels.cmx : set.cmx map.cmx hashtbl.cmx moreLabels.cmi nativeint.cmo : sys.cmi pervasives.cmi nativeint.cmi @@ -112,13 +129,15 @@ oo.cmo : camlinternalOO.cmi oo.cmi oo.cmx : camlinternalOO.cmx oo.cmi parsing.cmo : obj.cmi lexing.cmi array.cmi parsing.cmi parsing.cmx : obj.cmx lexing.cmx array.cmx parsing.cmi -pervasives.cmo : pervasives.cmi -pervasives.cmx : pervasives.cmi -printexc.cmo : printf.cmi obj.cmi buffer.cmi array.cmi printexc.cmi -printexc.cmx : printf.cmx obj.cmx buffer.cmx array.cmx printexc.cmi -printf.cmo : string.cmi obj.cmi list.cmi char.cmi buffer.cmi array.cmi \ +pervasives.cmo : camlinternalFormatBasics.cmi pervasives.cmi +pervasives.cmx : camlinternalFormatBasics.cmx pervasives.cmi +printexc.cmo : printf.cmi pervasives.cmi obj.cmi buffer.cmi array.cmi \ + printexc.cmi +printexc.cmx : printf.cmx pervasives.cmx obj.cmx buffer.cmx array.cmx \ + printexc.cmi +printf.cmo : camlinternalFormatBasics.cmi camlinternalFormat.cmi buffer.cmi \ printf.cmi -printf.cmx : string.cmx obj.cmx list.cmx char.cmx buffer.cmx array.cmx \ +printf.cmx : camlinternalFormatBasics.cmx camlinternalFormat.cmx buffer.cmx \ printf.cmi queue.cmo : obj.cmi queue.cmi queue.cmx : obj.cmx queue.cmi @@ -126,26 +145,28 @@ random.cmo : string.cmi pervasives.cmi nativeint.cmi int64.cmi int32.cmi \ digest.cmi char.cmi array.cmi random.cmi random.cmx : string.cmx pervasives.cmx nativeint.cmx int64.cmx int32.cmx \ digest.cmx char.cmx array.cmx random.cmi -scanf.cmo : string.cmi printf.cmi pervasives.cmi obj.cmi list.cmi \ - hashtbl.cmi buffer.cmi array.cmi scanf.cmi -scanf.cmx : string.cmx printf.cmx pervasives.cmx obj.cmx list.cmx \ - hashtbl.cmx buffer.cmx array.cmx scanf.cmi +scanf.cmo : string.cmi printf.cmi pervasives.cmi list.cmi \ + camlinternalFormatBasics.cmi camlinternalFormat.cmi bytes.cmi buffer.cmi \ + scanf.cmi +scanf.cmx : string.cmx printf.cmx pervasives.cmx list.cmx \ + camlinternalFormatBasics.cmx camlinternalFormat.cmx bytes.cmx buffer.cmx \ + scanf.cmi set.cmo : list.cmi set.cmi set.cmx : list.cmx set.cmi sort.cmo : array.cmi sort.cmi sort.cmx : array.cmx sort.cmi stack.cmo : list.cmi stack.cmi stack.cmx : list.cmx stack.cmi -stdLabels.cmo : stringLabels.cmi listLabels.cmi arrayLabels.cmi \ - stdLabels.cmi -stdLabels.cmx : stringLabels.cmx listLabels.cmx arrayLabels.cmx \ - stdLabels.cmi +stdLabels.cmo : stringLabels.cmi listLabels.cmi bytesLabels.cmi \ + arrayLabels.cmi stdLabels.cmi +stdLabels.cmx : stringLabels.cmx listLabels.cmx bytesLabels.cmx \ + arrayLabels.cmx stdLabels.cmi std_exit.cmo : std_exit.cmx : -stream.cmo : string.cmi obj.cmi list.cmi lazy.cmi stream.cmi -stream.cmx : string.cmx obj.cmx list.cmx lazy.cmx stream.cmi -string.cmo : pervasives.cmi list.cmi char.cmi string.cmi -string.cmx : pervasives.cmx list.cmx char.cmx string.cmi +stream.cmo : string.cmi obj.cmi list.cmi lazy.cmi bytes.cmi stream.cmi +stream.cmx : string.cmx obj.cmx list.cmx lazy.cmx bytes.cmx stream.cmi +string.cmo : pervasives.cmi list.cmi bytes.cmi string.cmi +string.cmx : pervasives.cmx list.cmx bytes.cmx string.cmi stringLabels.cmo : string.cmi stringLabels.cmi stringLabels.cmx : string.cmx stringLabels.cmi sys.cmo : sys.cmi @@ -160,10 +181,20 @@ array.cmo : array.cmi array.p.cmx : array.cmi arrayLabels.cmo : array.cmi arrayLabels.cmi arrayLabels.p.cmx : array.p.cmx arrayLabels.cmi -buffer.cmo : sys.cmi string.cmi buffer.cmi -buffer.p.cmx : sys.p.cmx string.p.cmx buffer.cmi +buffer.cmo : sys.cmi string.cmi bytes.cmi buffer.cmi +buffer.p.cmx : sys.p.cmx string.p.cmx bytes.p.cmx buffer.cmi +bytes.cmo : pervasives.cmi list.cmi char.cmi bytes.cmi +bytes.p.cmx : pervasives.p.cmx list.p.cmx char.p.cmx bytes.cmi +bytesLabels.cmo : bytes.cmi bytesLabels.cmi +bytesLabels.p.cmx : bytes.p.cmx bytesLabels.cmi callback.cmo : obj.cmi callback.cmi callback.p.cmx : obj.p.cmx callback.cmi +camlinternalFormat.cmo : sys.cmi string.cmi char.cmi \ + camlinternalFormatBasics.cmi bytes.cmi buffer.cmi camlinternalFormat.cmi +camlinternalFormat.p.cmx : sys.p.cmx string.p.cmx char.p.cmx \ + camlinternalFormatBasics.p.cmx bytes.p.cmx buffer.p.cmx camlinternalFormat.cmi +camlinternalFormatBasics.cmo : camlinternalFormatBasics.cmi +camlinternalFormatBasics.p.cmx : camlinternalFormatBasics.cmi camlinternalLazy.cmo : obj.cmi camlinternalLazy.cmi camlinternalLazy.p.cmx : obj.p.cmx camlinternalLazy.cmi camlinternalMod.cmo : obj.cmi camlinternalOO.cmi array.cmi \ @@ -178,20 +209,22 @@ char.cmo : char.cmi char.p.cmx : char.cmi complex.cmo : complex.cmi complex.p.cmx : complex.cmi -digest.cmo : string.cmi char.cmi digest.cmi -digest.p.cmx : string.p.cmx char.p.cmx digest.cmi +digest.cmo : string.cmi char.cmi bytes.cmi digest.cmi +digest.p.cmx : string.p.cmx char.p.cmx bytes.p.cmx digest.cmi filename.cmo : sys.cmi string.cmi random.cmi printf.cmi lazy.cmi buffer.cmi \ filename.cmi filename.p.cmx : sys.p.cmx string.p.cmx random.p.cmx printf.p.cmx lazy.p.cmx buffer.p.cmx \ filename.cmi -format.cmo : string.cmi printf.cmi pervasives.cmi obj.cmi list.cmi \ - buffer.cmi format.cmi -format.p.cmx : string.p.cmx printf.p.cmx pervasives.p.cmx obj.p.cmx list.p.cmx \ - buffer.p.cmx format.cmi +format.cmo : string.cmi pervasives.cmi camlinternalFormatBasics.cmi \ + camlinternalFormat.cmi buffer.cmi format.cmi +format.p.cmx : string.p.cmx pervasives.p.cmx camlinternalFormatBasics.p.cmx \ + camlinternalFormat.p.cmx buffer.p.cmx format.cmi gc.cmo : sys.cmi printf.cmi gc.cmi gc.p.cmx : sys.p.cmx printf.p.cmx gc.cmi -genlex.cmo : string.cmi stream.cmi list.cmi hashtbl.cmi char.cmi genlex.cmi -genlex.p.cmx : string.p.cmx stream.p.cmx list.p.cmx hashtbl.p.cmx char.p.cmx genlex.cmi +genlex.cmo : string.cmi stream.cmi list.cmi hashtbl.cmi char.cmi bytes.cmi \ + genlex.cmi +genlex.p.cmx : string.p.cmx stream.p.cmx list.p.cmx hashtbl.p.cmx char.p.cmx bytes.p.cmx \ + genlex.cmi hashtbl.cmo : sys.cmi string.cmi random.cmi obj.cmi lazy.cmi array.cmi \ hashtbl.cmi hashtbl.p.cmx : sys.p.cmx string.p.cmx random.p.cmx obj.p.cmx lazy.p.cmx array.p.cmx \ @@ -202,16 +235,16 @@ int64.cmo : pervasives.cmi int64.cmi int64.p.cmx : pervasives.p.cmx int64.cmi lazy.cmo : obj.cmi camlinternalLazy.cmi lazy.cmi lazy.p.cmx : obj.p.cmx camlinternalLazy.p.cmx lazy.cmi -lexing.cmo : sys.cmi string.cmi array.cmi lexing.cmi -lexing.p.cmx : sys.p.cmx string.p.cmx array.p.cmx lexing.cmi +lexing.cmo : sys.cmi string.cmi bytes.cmi array.cmi lexing.cmi +lexing.p.cmx : sys.p.cmx string.p.cmx bytes.p.cmx array.p.cmx lexing.cmi list.cmo : list.cmi list.p.cmx : list.cmi listLabels.cmo : list.cmi listLabels.cmi listLabels.p.cmx : list.p.cmx listLabels.cmi map.cmo : map.cmi map.p.cmx : map.cmi -marshal.cmo : string.cmi marshal.cmi -marshal.p.cmx : string.p.cmx marshal.cmi +marshal.cmo : bytes.cmi marshal.cmi +marshal.p.cmx : bytes.p.cmx marshal.cmi moreLabels.cmo : set.cmi map.cmi hashtbl.cmi moreLabels.cmi moreLabels.p.cmx : set.p.cmx map.p.cmx hashtbl.p.cmx moreLabels.cmi nativeint.cmo : sys.cmi pervasives.cmi nativeint.cmi @@ -222,13 +255,15 @@ oo.cmo : camlinternalOO.cmi oo.cmi oo.p.cmx : camlinternalOO.p.cmx oo.cmi parsing.cmo : obj.cmi lexing.cmi array.cmi parsing.cmi parsing.p.cmx : obj.p.cmx lexing.p.cmx array.p.cmx parsing.cmi -pervasives.cmo : pervasives.cmi -pervasives.p.cmx : pervasives.cmi -printexc.cmo : printf.cmi obj.cmi buffer.cmi array.cmi printexc.cmi -printexc.p.cmx : printf.p.cmx obj.p.cmx buffer.p.cmx array.p.cmx printexc.cmi -printf.cmo : string.cmi obj.cmi list.cmi char.cmi buffer.cmi array.cmi \ +pervasives.cmo : camlinternalFormatBasics.cmi pervasives.cmi +pervasives.p.cmx : camlinternalFormatBasics.p.cmx pervasives.cmi +printexc.cmo : printf.cmi pervasives.cmi obj.cmi buffer.cmi array.cmi \ + printexc.cmi +printexc.p.cmx : printf.p.cmx pervasives.p.cmx obj.p.cmx buffer.p.cmx array.p.cmx \ + printexc.cmi +printf.cmo : camlinternalFormatBasics.cmi camlinternalFormat.cmi buffer.cmi \ printf.cmi -printf.p.cmx : string.p.cmx obj.p.cmx list.p.cmx char.p.cmx buffer.p.cmx array.p.cmx \ +printf.p.cmx : camlinternalFormatBasics.p.cmx camlinternalFormat.p.cmx buffer.p.cmx \ printf.cmi queue.cmo : obj.cmi queue.cmi queue.p.cmx : obj.p.cmx queue.cmi @@ -236,26 +271,28 @@ random.cmo : string.cmi pervasives.cmi nativeint.cmi int64.cmi int32.cmi \ digest.cmi char.cmi array.cmi random.cmi random.p.cmx : string.p.cmx pervasives.p.cmx nativeint.p.cmx int64.p.cmx int32.p.cmx \ digest.p.cmx char.p.cmx array.p.cmx random.cmi -scanf.cmo : string.cmi printf.cmi pervasives.cmi obj.cmi list.cmi \ - hashtbl.cmi buffer.cmi array.cmi scanf.cmi -scanf.p.cmx : string.p.cmx printf.p.cmx pervasives.p.cmx obj.p.cmx list.p.cmx \ - hashtbl.p.cmx buffer.p.cmx array.p.cmx scanf.cmi +scanf.cmo : string.cmi printf.cmi pervasives.cmi list.cmi \ + camlinternalFormatBasics.cmi camlinternalFormat.cmi bytes.cmi buffer.cmi \ + scanf.cmi +scanf.p.cmx : string.p.cmx printf.p.cmx pervasives.p.cmx list.p.cmx \ + camlinternalFormatBasics.p.cmx camlinternalFormat.p.cmx bytes.p.cmx buffer.p.cmx \ + scanf.cmi set.cmo : list.cmi set.cmi set.p.cmx : list.p.cmx set.cmi sort.cmo : array.cmi sort.cmi sort.p.cmx : array.p.cmx sort.cmi stack.cmo : list.cmi stack.cmi stack.p.cmx : list.p.cmx stack.cmi -stdLabels.cmo : stringLabels.cmi listLabels.cmi arrayLabels.cmi \ - stdLabels.cmi -stdLabels.p.cmx : stringLabels.p.cmx listLabels.p.cmx arrayLabels.p.cmx \ - stdLabels.cmi +stdLabels.cmo : stringLabels.cmi listLabels.cmi bytesLabels.cmi \ + arrayLabels.cmi stdLabels.cmi +stdLabels.p.cmx : stringLabels.p.cmx listLabels.p.cmx bytesLabels.p.cmx \ + arrayLabels.p.cmx stdLabels.cmi std_exit.cmo : std_exit.p.cmx : -stream.cmo : string.cmi obj.cmi list.cmi lazy.cmi stream.cmi -stream.p.cmx : string.p.cmx obj.p.cmx list.p.cmx lazy.p.cmx stream.cmi -string.cmo : pervasives.cmi list.cmi char.cmi string.cmi -string.p.cmx : pervasives.p.cmx list.p.cmx char.p.cmx string.cmi +stream.cmo : string.cmi obj.cmi list.cmi lazy.cmi bytes.cmi stream.cmi +stream.p.cmx : string.p.cmx obj.p.cmx list.p.cmx lazy.p.cmx bytes.p.cmx stream.cmi +string.cmo : pervasives.cmi list.cmi bytes.cmi string.cmi +string.p.cmx : pervasives.p.cmx list.p.cmx bytes.p.cmx string.cmi stringLabels.cmo : string.cmi stringLabels.cmi stringLabels.p.cmx : string.p.cmx stringLabels.cmi sys.cmo : sys.cmi diff --git a/stdlib/Compflags b/stdlib/Compflags index d0938af89..f393c4ec0 100755 --- a/stdlib/Compflags +++ b/stdlib/Compflags @@ -18,8 +18,11 @@ case $1 in camlinternalOO.cmx|camlinternalOO.p.cmx) echo ' -inline 0';; buffer.cmx|buffer.p.cmx) echo ' -inline 3';; # make sure add_char is inlined (PR#5872) - buffer.cm[io]|printf.cm[io]|format.cm[io]|scanf.cm[io]) echo ' -w A';; + buffer.cm[io]) echo ' -w A';; + camlinternalFormat.cm[io]) echo ' -w Ae';; + camlinternalFormatBasics*.cm[iox]) echo ' -nopervasives';; + printf.cm[io]|format.cm[io]|scanf.cm[io]) echo ' -w Ae';; scanf.cmx|scanf.p.cmx) echo ' -inline 9';; - *Labels.cm[ox]|*Labels.p.cmx) echo ' -nolabels -trans-mod';; + *Labels.cm[ox]|*Labels.p.cmx) echo ' -nolabels -no-alias-deps';; *) echo ' ';; esac diff --git a/stdlib/Makefile b/stdlib/Makefile index 80be16e0b..37f9a5f0b 100644 --- a/stdlib/Makefile +++ b/stdlib/Makefile @@ -25,19 +25,22 @@ allopt-prof: stdlib.p.cmxa std_exit.p.cmx installopt: installopt-default installopt-$(PROFILING) installopt-default: - cp stdlib.cmxa stdlib.a std_exit.o *.cmx $(LIBDIR) - cd $(LIBDIR); $(RANLIB) stdlib.a + cp stdlib.cmxa stdlib.a std_exit.o *.cmx $(INSTALL_LIBDIR) + cd $(INSTALL_LIBDIR); $(RANLIB) stdlib.a installopt-noprof: - rm -f $(LIBDIR)/stdlib.p.cmxa; ln -s stdlib.cmxa $(LIBDIR)/stdlib.p.cmxa - rm -f $(LIBDIR)/stdlib.p.a; ln -s stdlib.a $(LIBDIR)/stdlib.p.a - rm -f $(LIBDIR)/std_exit.p.cmx; \ - ln -s std_exit.cmx $(LIBDIR)/std_exit.p.cmx - rm -f $(LIBDIR)/std_exit.p.o; ln -s std_exit.o $(LIBDIR)/std_exit.p.o + rm -f $(INSTALL_LIBDIR)/stdlib.p.cmxa; \ + ln -s stdlib.cmxa $(INSTALL_LIBDIR)/stdlib.p.cmxa + rm -f $(INSTALL_LIBDIR)/stdlib.p.a; \ + ln -s stdlib.a $(INSTALL_LIBDIR)/stdlib.p.a + rm -f $(INSTALL_LIBDIR)/std_exit.p.cmx; \ + ln -s std_exit.cmx $(INSTALL_LIBDIR)/std_exit.p.cmx + rm -f $(INSTALL_LIBDIR)/std_exit.p.o; \ + ln -s std_exit.o $(INSTALL_LIBDIR)/std_exit.p.o installopt-prof: - cp stdlib.p.cmxa stdlib.p.a std_exit.p.cmx std_exit.p.o $(LIBDIR) - cd $(LIBDIR); $(RANLIB) stdlib.p.a + cp stdlib.p.cmxa stdlib.p.a std_exit.p.cmx std_exit.p.o $(INSTALL_LIBDIR) + cd $(INSTALL_LIBDIR); $(RANLIB) stdlib.p.a stdlib.p.cmxa: $(OBJS:.cmo=.p.cmx) $(CAMLOPT) -a -o stdlib.p.cmxa $(OBJS:.cmo=.p.cmx) diff --git a/stdlib/Makefile.nt b/stdlib/Makefile.nt index b85622b90..590701bf9 100644 --- a/stdlib/Makefile.nt +++ b/stdlib/Makefile.nt @@ -16,7 +16,7 @@ include Makefile.shared allopt: stdlib.cmxa std_exit.cmx installopt: - cp stdlib.cmxa stdlib.$(A) std_exit.$(O) *.cmx $(LIBDIR) + cp stdlib.cmxa stdlib.$(A) std_exit.$(O) *.cmx $(INSTALL_LIBDIR) camlheader camlheader_ur: headernt.c ../config/Makefile $(BYTECC) $(BYTECCCOMPOPTS) -c -I../byterun \ diff --git a/stdlib/Makefile.shared b/stdlib/Makefile.shared index 80c40d600..54de337cb 100755 --- a/stdlib/Makefile.shared +++ b/stdlib/Makefile.shared @@ -15,38 +15,41 @@ include ../config/Makefile RUNTIME=../boot/ocamlrun COMPILER=../ocamlc CAMLC=$(RUNTIME) $(COMPILER) -COMPFLAGS=-strict-sequence -w +33..39 -g -warn-error A -bin-annot -nostdlib +COMPFLAGS=-strict-sequence -w +33..39 -g -warn-error A -bin-annot -nostdlib \ + -safe-string OPTCOMPILER=../ocamlopt CAMLOPT=$(RUNTIME) $(OPTCOMPILER) -OPTCOMPFLAGS=-warn-error A -nostdlib -g -bin-annot CAMLDEP=../boot/ocamlrun ../tools/ocamldep -OBJS=pervasives.cmo $(OTHERS) -OTHERS=array.cmo list.cmo char.cmo string.cmo sys.cmo \ +OBJS=camlinternalFormatBasics.cmo pervasives.cmo $(OTHERS) +OTHERS=array.cmo list.cmo char.cmo bytes.cmo string.cmo sys.cmo \ sort.cmo marshal.cmo obj.cmo \ int32.cmo int64.cmo nativeint.cmo \ lexing.cmo parsing.cmo \ set.cmo map.cmo stack.cmo queue.cmo \ camlinternalLazy.cmo lazy.cmo stream.cmo \ - buffer.cmo printf.cmo \ + buffer.cmo camlinternalFormat.cmo printf.cmo \ arg.cmo printexc.cmo gc.cmo \ digest.cmo random.cmo hashtbl.cmo format.cmo scanf.cmo callback.cmo \ camlinternalOO.cmo oo.cmo camlinternalMod.cmo \ genlex.cmo weak.cmo \ filename.cmo complex.cmo \ - arrayLabels.cmo listLabels.cmo stringLabels.cmo moreLabels.cmo stdLabels.cmo + arrayLabels.cmo listLabels.cmo bytesLabels.cmo \ + stringLabels.cmo moreLabels.cmo stdLabels.cmo all: stdlib.cma std_exit.cmo camlheader camlheader_ur +INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR) + install: install-$(RUNTIMED) cp stdlib.cma std_exit.cmo *.cmi *.mli *.ml camlheader camlheader_ur \ - $(LIBDIR) + $(INSTALL_LIBDIR) install-noruntimed: .PHONY: install-noruntimed install-runtimed: camlheaderd - cp camlheaderd $(LIBDIR) + cp camlheaderd $(INSTALL_LIBDIR) .PHONY: install-runtimed stdlib.cma: $(OBJS) @@ -73,10 +76,10 @@ clean:: $(CAMLC) $(COMPFLAGS) `./Compflags $@` -c $< .ml.cmx: - $(CAMLOPT) $(OPTCOMPFLAGS) `./Compflags $@` -c $< + $(CAMLOPT) $(COMPFLAGS) `./Compflags $@` -c $< .ml.p.cmx: - $(CAMLOPT) $(OPTCOMPFLAGS) `./Compflags $@` -p -c -o $*.p.cmx $< + $(CAMLOPT) $(COMPFLAGS) `./Compflags $@` -p -c -o $*.p.cmx $< # Dependencies on the compiler $(OBJS) std_exit.cmo: $(COMPILER) @@ -85,7 +88,7 @@ $(OBJS:.cmo=.cmx) std_exit.cmx: $(OPTCOMPILER) $(OBJS:.cmo=.p.cmx) std_exit.p.cmx: $(OPTCOMPILER) # Dependencies on Pervasives (not tracked by ocamldep) -$(OBJS) std_exit.cmo: pervasives.cmi +$(OTHERS) std_exit.cmo: pervasives.cmi $(OTHERS:.cmo=.cmi) std_exit.cmi: pervasives.cmi $(OBJS:.cmo=.cmx) std_exit.cmx: pervasives.cmi $(OBJS:.cmo=.p.cmx) std_exit.p.cmx: pervasives.cmi diff --git a/stdlib/StdlibModules b/stdlib/StdlibModules index c5c8896ed..abdfcb362 100644 --- a/stdlib/StdlibModules +++ b/stdlib/StdlibModules @@ -21,7 +21,11 @@ STDLIB_MODULES=\ array \ arrayLabels \ buffer \ + bytes \ + bytesLabels \ callback \ + camlinternalFormat \ + camlinternalFormatBasics \ camlinternalLazy \ camlinternalMod \ camlinternalOO \ diff --git a/stdlib/arg.ml b/stdlib/arg.ml index 8b64236a7..0f6480b82 100644 --- a/stdlib/arg.ml +++ b/stdlib/arg.ml @@ -112,11 +112,11 @@ let parse_argv_dynamic ?(current=current) argv speclist anonfun errmsg = | Unknown "-help" -> () | Unknown "--help" -> () | Unknown s -> - bprintf b "%s: unknown option `%s'.\n" progname s + bprintf b "%s: unknown option '%s'.\n" progname s | Missing s -> - bprintf b "%s: option `%s' needs an argument.\n" progname s + bprintf b "%s: option '%s' needs an argument.\n" progname s | Wrong (opt, arg, expected) -> - bprintf b "%s: wrong argument `%s'; option `%s' expects %s.\n" + bprintf b "%s: wrong argument '%s'; option '%s' expects %s.\n" progname arg opt expected | Message s -> bprintf b "%s: %s.\n" progname s @@ -129,7 +129,7 @@ let parse_argv_dynamic ?(current=current) argv speclist anonfun errmsg = incr current; while !current < l do let s = argv.(!current) in - if String.length s >= 1 && String.get s 0 = '-' then begin + if String.length s >= 1 && s.[0] = '-' then begin let action = try assoc3 s !speclist with Not_found -> stop (Unknown s) diff --git a/stdlib/arg.mli b/stdlib/arg.mli index e6e07316d..22eda40b7 100644 --- a/stdlib/arg.mli +++ b/stdlib/arg.mli @@ -94,7 +94,7 @@ val parse : *) val parse_dynamic : - (key * spec * doc) list ref -> anon_fun -> string -> unit + (key * spec * doc) list ref -> anon_fun -> usage_msg -> unit (** Same as {!Arg.parse}, except that the [speclist] argument is a reference and may be updated during the parsing. A typical use for this feature is to parse command lines of the form: diff --git a/stdlib/array.mli b/stdlib/array.mli index 7c0049e28..e9a64528f 100644 --- a/stdlib/array.mli +++ b/stdlib/array.mli @@ -47,6 +47,7 @@ external make : int -> 'a -> 'a array = "caml_make_vect" size is only [Sys.max_array_length / 2].*) external create : int -> 'a -> 'a array = "caml_make_vect" + [@@ocaml.deprecated] (** @deprecated [Array.create] is an alias for {!Array.make}. *) val init : int -> (int -> 'a) -> 'a array @@ -73,6 +74,7 @@ val make_matrix : int -> int -> 'a -> 'a array array size is only [Sys.max_array_length / 2]. *) val create_matrix : int -> int -> 'a -> 'a array array + [@@ocaml.deprecated] (** @deprecated [Array.create_matrix] is an alias for {!Array.make_matrix}. *) val append : 'a array -> 'a array -> 'a array diff --git a/stdlib/arrayLabels.mli b/stdlib/arrayLabels.mli index 03b6224ae..cf8b650e5 100644 --- a/stdlib/arrayLabels.mli +++ b/stdlib/arrayLabels.mli @@ -47,7 +47,8 @@ external make : int -> 'a -> 'a array = "caml_make_vect" size is only [Sys.max_array_length / 2].*) external create : int -> 'a -> 'a array = "caml_make_vect" -(** @deprecated [Array.create] is an alias for {!ArrayLabels.make}. *) + [@@ocaml.deprecated] +(** @deprecated [ArrayLabels.create] is an alias for {!ArrayLabels.make}. *) val init : int -> f:(int -> 'a) -> 'a array (** [Array.init n f] returns a fresh array of length [n], @@ -73,7 +74,8 @@ val make_matrix : dimx:int -> dimy:int -> 'a -> 'a array array size is only [Sys.max_array_length / 2]. *) val create_matrix : dimx:int -> dimy:int -> 'a -> 'a array array -(** @deprecated [Array.create_matrix] is an alias for + [@@ocaml.deprecated] +(** @deprecated [ArrayLabels.create_matrix] is an alias for {!ArrayLabels.make_matrix}. *) val append : 'a array -> 'a array -> 'a array diff --git a/stdlib/buffer.ml b/stdlib/buffer.ml index 78a9e2611..986fe6f33 100644 --- a/stdlib/buffer.ml +++ b/stdlib/buffer.ml @@ -14,41 +14,38 @@ (* Extensible buffers *) type t = - {mutable buffer : string; + {mutable buffer : bytes; mutable position : int; mutable length : int; - initial_buffer : string} + initial_buffer : bytes} let create n = let n = if n < 1 then 1 else n in let n = if n > Sys.max_string_length then Sys.max_string_length else n in - let s = String.create n in + let s = Bytes.create n in {buffer = s; position = 0; length = n; initial_buffer = s} -let contents b = String.sub b.buffer 0 b.position +let contents b = Bytes.sub_string b.buffer 0 b.position +let to_bytes b = Bytes.sub b.buffer 0 b.position let sub b ofs len = if ofs < 0 || len < 0 || ofs > b.position - len then invalid_arg "Buffer.sub" - else begin - let r = String.create len in - String.unsafe_blit b.buffer ofs r 0 len; - r - end + else Bytes.sub_string b.buffer ofs len ;; let blit src srcoff dst dstoff len = if len < 0 || srcoff < 0 || srcoff > src.position - len - || dstoff < 0 || dstoff > (String.length dst) - len + || dstoff < 0 || dstoff > (Bytes.length dst) - len then invalid_arg "Buffer.blit" else - String.blit src.buffer srcoff dst dstoff len + Bytes.unsafe_blit src.buffer srcoff dst dstoff len ;; let nth b ofs = if ofs < 0 || ofs >= b.position then invalid_arg "Buffer.nth" - else String.unsafe_get b.buffer ofs + else Bytes.unsafe_get b.buffer ofs ;; let length b = b.position @@ -57,7 +54,7 @@ let clear b = b.position <- 0 let reset b = b.position <- 0; b.buffer <- b.initial_buffer; - b.length <- String.length b.buffer + b.length <- Bytes.length b.buffer let resize b more = let len = b.length in @@ -68,34 +65,41 @@ let resize b more = then new_len := Sys.max_string_length else failwith "Buffer.add: cannot grow buffer" end; - let new_buffer = String.create !new_len in - String.blit b.buffer 0 new_buffer 0 b.position; + let new_buffer = Bytes.create !new_len in + (* PR#6148: let's keep using [blit] rather than [unsafe_blit] in + this tricky function that is slow anyway. *) + Bytes.blit b.buffer 0 new_buffer 0 b.position; b.buffer <- new_buffer; b.length <- !new_len let add_char b c = let pos = b.position in if pos >= b.length then resize b 1; - String.unsafe_set b.buffer pos c; + Bytes.unsafe_set b.buffer pos c; b.position <- pos + 1 let add_substring b s offset len = - if offset < 0 || len < 0 || offset > String.length s - len - then invalid_arg "Buffer.add_substring"; + if offset < 0 || len < 0 || offset + len > String.length s + then invalid_arg "Buffer.add_substring/add_subbytes"; let new_position = b.position + len in if new_position > b.length then resize b len; - String.unsafe_blit s offset b.buffer b.position len; + Bytes.blit_string s offset b.buffer b.position len; b.position <- new_position +let add_subbytes b s offset len = + add_substring b (Bytes.unsafe_to_string s) offset len + let add_string b s = let len = String.length s in let new_position = b.position + len in if new_position > b.length then resize b len; - String.unsafe_blit s 0 b.buffer b.position len; + Bytes.blit_string s 0 b.buffer b.position len; b.position <- new_position +let add_bytes b s = add_string b (Bytes.unsafe_to_string s) + let add_buffer b bs = - add_substring b bs.buffer 0 bs.position + add_subbytes b bs.buffer 0 bs.position let add_channel b ic len = if len < 0 || len > Sys.max_string_length then (* PR#5004 *) diff --git a/stdlib/buffer.mli b/stdlib/buffer.mli index c50c98792..e7ce8b999 100644 --- a/stdlib/buffer.mli +++ b/stdlib/buffer.mli @@ -11,9 +11,9 @@ (* *) (***********************************************************************) -(** Extensible string buffers. +(** Extensible buffers. - This module implements string buffers that automatically expand + This module implements buffers that automatically expand as necessary. It provides accumulative concatenation of strings in quasi-linear time (instead of quadratic time when strings are concatenated pairwise). @@ -24,8 +24,8 @@ type t val create : int -> t (** [create n] returns a fresh buffer, initially empty. - The [n] parameter is the initial size of the internal string - that holds the buffer contents. That string is automatically + The [n] parameter is the initial size of the internal byte sequence + that holds the buffer contents. That byte sequence is automatically reallocated when more than [n] characters are stored in the buffer, but shrinks back to [n] characters when [reset] is called. For best performance, [n] should be of the same order of magnitude @@ -40,26 +40,30 @@ val contents : t -> string (** Return a copy of the current contents of the buffer. The buffer itself is unchanged. *) +val to_bytes : t -> bytes +(** Return a copy of the current contents of the buffer. + The buffer itself is unchanged. *) + val sub : t -> int -> int -> string -(** [Buffer.sub b off len] returns (a copy of) the substring of the -current contents of the buffer [b] starting at offset [off] of length -[len] bytes. May raise [Invalid_argument] if out of bounds request. The -buffer itself is unaffected. *) +(** [Buffer.sub b off len] returns (a copy of) the bytes from the + current contents of the buffer [b] starting at offset [off] of + length [len] bytes. May raise [Invalid_argument] if out of bounds + request. The buffer itself is unaffected. *) -val blit : t -> int -> string -> int -> int -> unit +val blit : t -> int -> bytes -> int -> int -> unit (** [Buffer.blit src srcoff dst dstoff len] copies [len] characters from the current contents of the buffer [src], starting at offset [srcoff] - to string [dst], starting at character [dstoff]. + to [dst], starting at character [dstoff]. Raise [Invalid_argument] if [srcoff] and [len] do not designate a valid - substring of [src], or if [dstoff] and [len] do not designate a valid - substring of [dst]. + range of [src], or if [dstoff] and [len] do not designate a valid + range of [dst]. @since 3.11.2 *) val nth : t -> int -> char (** get the n-th character of the buffer. Raise [Invalid_argument] if -index out of bounds *) + index out of bounds *) val length : t -> int (** Return the number of characters currently contained in the buffer. *) @@ -68,8 +72,8 @@ val clear : t -> unit (** Empty the buffer. *) val reset : t -> unit -(** Empty the buffer and deallocate the internal string holding the - buffer contents, replacing it with the initial internal string +(** Empty the buffer and deallocate the internal byte sequence holding the + buffer contents, replacing it with the initial internal byte sequence of length [n] that was allocated by {!Buffer.create} [n]. For long-lived buffers that may have grown a lot, [reset] allows faster reclamation of the space used by the buffer. *) @@ -80,10 +84,17 @@ val add_char : t -> char -> unit val add_string : t -> string -> unit (** [add_string b s] appends the string [s] at the end of the buffer [b]. *) +val add_bytes : t -> bytes -> unit +(** [add_string b s] appends the string [s] at the end of the buffer [b]. *) + val add_substring : t -> string -> int -> int -> unit (** [add_substring b s ofs len] takes [len] characters from offset [ofs] in string [s] and appends them at the end of the buffer [b]. *) +val add_subbytes : t -> bytes -> int -> int -> unit +(** [add_substring b s ofs len] takes [len] characters from offset + [ofs] in byte sequence [s] and appends them at the end of the buffer [b]. *) + val add_substitute : t -> (string -> string) -> string -> unit (** [add_substitute b f s] appends the string pattern [s] at the end of the buffer [b] with substitution. diff --git a/stdlib/bytes.ml b/stdlib/bytes.ml new file mode 100644 index 000000000..ece7c1ea5 --- /dev/null +++ b/stdlib/bytes.ml @@ -0,0 +1,253 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* Byte sequence operations *) + +external length : bytes -> int = "%string_length" +external string_length : string -> int = "%string_length" +external get : bytes -> int -> char = "%string_safe_get" +external set : bytes -> int -> char -> unit = "%string_safe_set" +external create : int -> bytes = "caml_create_string" +external unsafe_get : bytes -> int -> char = "%string_unsafe_get" +external unsafe_set : bytes -> int -> char -> unit = "%string_unsafe_set" +external unsafe_fill : bytes -> int -> int -> char -> unit + = "caml_fill_string" "noalloc" +external unsafe_to_string : bytes -> string = "%identity" +external unsafe_of_string : string -> bytes = "%identity" + +external unsafe_blit : bytes -> int -> bytes -> int -> int -> unit + = "caml_blit_string" "noalloc" +external unsafe_blit_string : string -> int -> bytes -> int -> int -> unit + = "caml_blit_string" "noalloc" + +let make n c = + let s = create n in + unsafe_fill s 0 n c; + s + +let init n f = + let s = create n in + for i = 0 to n - 1 do + unsafe_set s i (f i) + done; + s + +let empty = create 0;; + +let copy s = + let len = length s in + let r = create len in + unsafe_blit s 0 r 0 len; + r + +let to_string b = unsafe_to_string (copy b) +let of_string s = copy (unsafe_of_string s) + +let sub s ofs len = + if ofs < 0 || len < 0 || ofs > length s - len + then invalid_arg "Bytes.sub" + else begin + let r = create len in + unsafe_blit s ofs r 0 len; + r + end + +let sub_string b ofs len = unsafe_to_string (sub b ofs len) + +let extend s left right = + let len = length s + left + right in + let r = create len in + let (srcoff, dstoff) = if left < 0 then -left, 0 else 0, left in + let cpylen = min (length s - srcoff) (len - dstoff) in + if cpylen > 0 then unsafe_blit s srcoff r dstoff cpylen; + r + +let fill s ofs len c = + if ofs < 0 || len < 0 || ofs > length s - len + then invalid_arg "Bytes.fill" + else unsafe_fill s ofs len c + +let blit s1 ofs1 s2 ofs2 len = + if len < 0 || ofs1 < 0 || ofs1 > length s1 - len + || ofs2 < 0 || ofs2 > length s2 - len + then invalid_arg "Bytes.blit" + else unsafe_blit s1 ofs1 s2 ofs2 len + +let blit_string s1 ofs1 s2 ofs2 len = + if len < 0 || ofs1 < 0 || ofs1 > string_length s1 - len + || ofs2 < 0 || ofs2 > length s2 - len + then invalid_arg "Bytes.blit_string" + else unsafe_blit_string s1 ofs1 s2 ofs2 len + +let iter f a = + for i = 0 to length a - 1 do f(unsafe_get a i) done + +let iteri f a = + for i = 0 to length a - 1 do f i (unsafe_get a i) done + +let concat sep l = + match l with + [] -> empty + | hd :: tl -> + let num = ref 0 and len = ref 0 in + List.iter (fun s -> incr num; len := !len + length s) l; + let r = create (!len + length sep * (!num - 1)) in + unsafe_blit hd 0 r 0 (length hd); + let pos = ref(length hd) in + List.iter + (fun s -> + unsafe_blit sep 0 r !pos (length sep); + pos := !pos + length sep; + unsafe_blit s 0 r !pos (length s); + pos := !pos + length s) + tl; + r + +let cat s1 s2 = + let l1 = length s1 in + let l2 = length s2 in + let r = create (l1 + l2) in + unsafe_blit s1 0 r 0 l1; + unsafe_blit s2 0 r l1 l2; + r +;; + +external is_printable: char -> bool = "caml_is_printable" +external char_code: char -> int = "%identity" +external char_chr: int -> char = "%identity" + +let is_space = function + | ' ' | '\012' | '\n' | '\r' | '\t' -> true + | _ -> false + +let trim s = + let len = length s in + let i = ref 0 in + while !i < len && is_space (unsafe_get s !i) do + incr i + done; + let j = ref (len - 1) in + while !j >= !i && is_space (unsafe_get s !j) do + decr j + done; + if !j >= !i then + sub s !i (!j - !i + 1) + else + empty + +let escaped s = + let n = ref 0 in + for i = 0 to length s - 1 do + n := !n + + (match unsafe_get s i with + | '"' | '\\' | '\n' | '\t' | '\r' | '\b' -> 2 + | c -> if is_printable c then 1 else 4) + done; + if !n = length s then copy s else begin + let s' = create !n in + n := 0; + for i = 0 to length s - 1 do + begin match unsafe_get s i with + | ('"' | '\\') as c -> + unsafe_set s' !n '\\'; incr n; unsafe_set s' !n c + | '\n' -> + unsafe_set s' !n '\\'; incr n; unsafe_set s' !n 'n' + | '\t' -> + unsafe_set s' !n '\\'; incr n; unsafe_set s' !n 't' + | '\r' -> + unsafe_set s' !n '\\'; incr n; unsafe_set s' !n 'r' + | '\b' -> + unsafe_set s' !n '\\'; incr n; unsafe_set s' !n 'b' + | c -> + if is_printable c then + unsafe_set s' !n c + else begin + let a = char_code c in + unsafe_set s' !n '\\'; + incr n; + unsafe_set s' !n (char_chr (48 + a / 100)); + incr n; + unsafe_set s' !n (char_chr (48 + (a / 10) mod 10)); + incr n; + unsafe_set s' !n (char_chr (48 + a mod 10)) + end + end; + incr n + done; + s' + end + +let map f s = + let l = length s in + if l = 0 then s else begin + let r = create l in + for i = 0 to l - 1 do unsafe_set r i (f (unsafe_get s i)) done; + r + end + +let mapi f s = + let l = length s in + if l = 0 then s else begin + let r = create l in + for i = 0 to l - 1 do unsafe_set r i (f i (unsafe_get s i)) done; + r + end + +let uppercase s = map Char.uppercase s +let lowercase s = map Char.lowercase s + +let apply1 f s = + if length s = 0 then s else begin + let r = copy s in + unsafe_set r 0 (f(unsafe_get s 0)); + r + end + +let capitalize s = apply1 Char.uppercase s +let uncapitalize s = apply1 Char.lowercase s + +let rec index_rec s lim i c = + if i >= lim then raise Not_found else + if unsafe_get s i = c then i else index_rec s lim (i + 1) c;; + +let index s c = index_rec s (length s) 0 c;; + +let index_from s i c = + let l = length s in + if i < 0 || i > l then invalid_arg "Bytes.index_from" else + index_rec s l i c;; + +let rec rindex_rec s i c = + if i < 0 then raise Not_found else + if unsafe_get s i = c then i else rindex_rec s (i - 1) c;; + +let rindex s c = rindex_rec s (length s - 1) c;; + +let rindex_from s i c = + if i < -1 || i >= length s then invalid_arg "Bytes.rindex_from" else + rindex_rec s i c;; + +let contains_from s i c = + let l = length s in + if i < 0 || i > l then invalid_arg "Bytes.contains_from" else + try ignore (index_rec s l i c); true with Not_found -> false;; + +let contains s c = contains_from s 0 c;; + +let rcontains_from s i c = + if i < 0 || i >= length s then invalid_arg "Bytes.rcontains_from" else + try ignore (rindex_rec s i c); true with Not_found -> false;; + +type t = bytes + +let compare (x: t) (y: t) = Pervasives.compare x y diff --git a/stdlib/bytes.mli b/stdlib/bytes.mli new file mode 100644 index 000000000..82b28a28c --- /dev/null +++ b/stdlib/bytes.mli @@ -0,0 +1,398 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(** Byte sequence operations. + + A byte sequence is a mutable data structure that contains a + fixed-length sequence of bytes. Each byte can be indexed in + constant time for reading or writing. + + Given a byte sequence [s] of length [l], we can access each of the + [l] bytes of [s] via its index in the sequence. Indexes start at + [0], and we will call an index valid in [s] if it falls within the + range [[0...l-1]] (inclusive). A position is the point between two + bytes or at the beginning or end of the sequence. We call a + position valid in [s] if it falls within the range [[0...l]] + (inclusive). Note that the byte at index [n] is between positions + [n] and [n+1]. + + Two parameters [start] and [len] are said to designate a valid + range of [s] if [len >= 0] and [start] and [start+len] are valid + positions in [s]. + + Byte sequences can be modified in place, for instance via the [set] + and [blit] functions described below. See also strings (module + {!String}), which are almost the same data structure, but cannot be + modified in place. + + Bytes are represented by the OCaml type [char]. + + @since 4.02.0 + *) + +external length : bytes -> int = "%string_length" +(** Return the length (number of bytes) of the argument. *) + +external get : bytes -> int -> char = "%string_safe_get" +(** [get s n] returns the byte at index [n] in argument [s]. + + Raise [Invalid_argument] if [n] not a valid index in [s]. *) + +external set : bytes -> int -> char -> unit = "%string_safe_set" +(** [set s n c] modifies [s] in place, replacing the byte at index [n] + with [c]. + + Raise [Invalid_argument] if [n] is not a valid index in [s]. *) + +external create : int -> bytes = "caml_create_string" +(** [create n] returns a new byte sequence of length [n]. The + sequence is uninitialized and contains arbitrary bytes. + + Raise [Invalid_argument] if [n < 0] or [n > ]{!Sys.max_string_length}. *) + +val make : int -> char -> bytes +(** [make n c] returns a new byte sequence of length [n], filled with + the byte [c]. + + Raise [Invalid_argument] if [n < 0] or [n > ]{!Sys.max_string_length}. *) + +val init : int -> (int -> char) -> bytes +(** [Bytes.init n f] returns a fresh byte sequence of length [n], with + character [i] initialized to the result of [f i] (in increasing + index order). + + Raise [Invalid_argument] if [n < 0] or [n > ]{!Sys.max_string_length}. *) + +val empty : bytes +(** A byte sequence of size 0. *) + +val copy : bytes -> bytes +(** Return a new byte sequence that contains the same bytes as the + argument. *) + +val of_string : string -> bytes +(** Return a new byte sequence that contains the same bytes as the + given string. *) + +val to_string : bytes -> string +(** Return a new string that contains the same bytes as the given byte + sequence. *) + +val sub : bytes -> int -> int -> bytes +(** [sub s start len] returns a new byte sequence of length [len], + containing the subsequence of [s] that starts at position [start] + and has length [len]. + + Raise [Invalid_argument] if [start] and [len] do not designate a + valid range of [s]. *) + +val sub_string : bytes -> int -> int -> string +(** Same as [sub] but return a string instead of a byte sequence. *) + +val extend : bytes -> int -> int -> bytes +(** [extend s left right] returns a new byte sequence that contains + the bytes of [s], with [left] uninitialized bytes prepended and + [right] uninitialized bytes appended to it. If [left] or [right] + is negative, then bytes are removed (instead of appended) from + the corresponding side of [s]. + + Raise [Invalid_argument] if the result length is negative or + longer than {!Sys.max_string_length} bytes. *) + +val fill : bytes -> int -> int -> char -> unit +(** [fill s start len c] modifies [s] in place, replacing [len] + characters with [c], starting at [start]. + + Raise [Invalid_argument] if [start] and [len] do not designate a + valid range of [s]. *) + +val blit : bytes -> int -> bytes -> int -> int -> unit +(** [blit src srcoff dst dstoff len] copies [len] bytes from sequence + [src], starting at index [srcoff], to sequence [dst], starting at + index [dstoff]. It works correctly even if [src] and [dst] are the + same byte sequence, and the source and destination intervals + overlap. + + Raise [Invalid_argument] if [srcoff] and [len] do not + designate a valid range of [src], or if [dstoff] and [len] + do not designate a valid range of [dst]. *) + +val blit_string : string -> int -> bytes -> int -> int -> unit +(** [blit src srcoff dst dstoff len] copies [len] bytes from string + [src], starting at index [srcoff], to byte sequence [dst], + starting at index [dstoff]. + + Raise [Invalid_argument] if [srcoff] and [len] do not + designate a valid range of [src], or if [dstoff] and [len] + do not designate a valid range of [dst]. *) + +val concat : bytes -> bytes list -> bytes +(** [concat sep sl] concatenates the list of byte sequences [sl], + inserting the separator byte sequence [sep] between each, and + returns the result as a new byte sequence. + + Raise [Invalid_argument] if the result is longer than + {!Sys.max_string_length} bytes. *) + +val cat : bytes -> bytes -> bytes +(** [cat s1 s2] concatenates [s1] and [s2] and returns the result + as new byte sequence. + + Raise [Invalid_argument] if the result is longer than + {!Sys.max_string_length} bytes. *) + +val iter : (char -> unit) -> bytes -> unit +(** [iter f s] applies function [f] in turn to all the bytes of [s]. + It is equivalent to [f (get s 0); f (get s 1); ...; f (get s + (length s - 1)); ()]. *) + +val iteri : (int -> char -> unit) -> bytes -> unit +(** Same as {!Bytes.iter}, but the function is applied to the index of + the byte as first argument and the byte itself as second + argument. *) + +val map : (char -> char) -> bytes -> bytes +(** [map f s] applies function [f] in turn to all the bytes of [s] + (in increasing index order) and stores the resulting bytes in + a new sequence that is returned as the result. *) + +val mapi : (int -> char -> char) -> bytes -> bytes +(** [mapi f s] calls [f] with each character of [s] and its + index (in increasing index order) and stores the resulting bytes + in a new sequence that is returned as the result. *) + +val trim : bytes -> bytes +(** Return a copy of the argument, without leading and trailing + whitespace. The bytes regarded as whitespace are the ASCII + characters [' '], ['\012'], ['\n'], ['\r'], and ['\t']. *) + +val escaped : bytes -> bytes +(** Return a copy of the argument, with special characters represented + by escape sequences, following the lexical conventions of OCaml. + + Raise [Invalid_argument] if the result is longer than + {!Sys.max_string_length} bytes. *) + +val index : bytes -> char -> int +(** [index s c] returns the index of the first occurrence of byte [c] + in [s]. + + Raise [Not_found] if [c] does not occur in [s]. *) + +val rindex : bytes -> char -> int +(** [rindex s c] returns the index of the last occurrence of byte [c] + in [s]. + + Raise [Not_found] if [c] does not occur in [s]. *) + +val index_from : bytes -> int -> char -> int +(** [index_from s i c] returns the index of the first occurrence of + byte [c] in [s] after position [i]. [Bytes.index s c] is + equivalent to [Bytes.index_from s 0 c]. + + Raise [Invalid_argument] if [i] is not a valid position in [s]. + Raise [Not_found] if [c] does not occur in [s] after position [i]. *) + +val rindex_from : bytes -> int -> char -> int +(** [rindex_from s i c] returns the index of the last occurrence of + byte [c] in [s] before position [i+1]. [rindex s c] is equivalent + to [rindex_from s (Bytes.length s - 1) c]. + + Raise [Invalid_argument] if [i+1] is not a valid position in [s]. + Raise [Not_found] if [c] does not occur in [s] before position [i+1]. *) + +val contains : bytes -> char -> bool +(** [contains s c] tests if byte [c] appears in [s]. *) + +val contains_from : bytes -> int -> char -> bool +(** [contains_from s start c] tests if byte [c] appears in [s] after + position [start]. [contains s c] is equivalent to [contains_from + s 0 c]. + + Raise [Invalid_argument] if [start] is not a valid position in [s]. *) + +val rcontains_from : bytes -> int -> char -> bool +(** [rcontains_from s stop c] tests if byte [c] appears in [s] before + position [stop+1]. + + Raise [Invalid_argument] if [stop < 0] or [stop+1] is not a valid + position in [s]. *) + +val uppercase : bytes -> bytes +(** Return a copy of the argument, with all lowercase letters + translated to uppercase, including accented letters of the ISO + Latin-1 (8859-1) character set. *) + +val lowercase : bytes -> bytes +(** Return a copy of the argument, with all uppercase letters + translated to lowercase, including accented letters of the ISO + Latin-1 (8859-1) character set. *) + +val capitalize : bytes -> bytes +(** Return a copy of the argument, with the first byte set to + uppercase. *) + +val uncapitalize : bytes -> bytes +(** Return a copy of the argument, with the first byte set to + lowercase. *) + +type t = bytes +(** An alias for the type of byte sequences. *) + +val compare: t -> t -> int +(** The comparison function for byte sequences, with the same + specification as {!Pervasives.compare}. Along with the type [t], + this function [compare] allows the module [Bytes] to be passed as + argument to the functors {!Set.Make} and {!Map.Make}. *) + + +(** {4 Unsafe conversions (for advanced users)} + + This section describes unsafe, low-level conversion functions + between [bytes] and [string]. They do not copy the internal data; + used improperly, they can break the immutability invariant on + strings provided by the [-safe-string] option. They are available for + expert library authors, but for most purposes you should use the + always-correct {!Bytes.to_string} and {!Bytes.of_string} instead. +*) + +val unsafe_to_string : bytes -> string +(** Unsafely convert a byte sequence into a string. + + To reason about the use of [unsafe_to_string], it is convenient to + consider an "ownership" discipline. A piece of code that + manipulates some data "owns" it; there are several disjoint ownership + modes, including: + - Unique ownership: the data may be accessed and mutated + - Shared ownership: the data has several owners, that may only + access it, not mutate it. + + Unique ownership is linear: passing the data to another piece of + code means giving up ownership (we cannot write the + data again). A unique owner may decide to make the data shared + (giving up mutation rights on it), but shared data may not become + uniquely-owned again. + + [unsafe_to_string s] can only be used when the caller owns the byte + sequence [s] -- either uniquely or as shared immutable data. The + caller gives up ownership of [s], and gains ownership of the + returned string. + + There are two valid use-cases that respect this ownership + discipline: + + 1. Creating a string by initializing and mutating a byte sequence + that is never changed after initialization is performed. + + {[ +let string_init len f : string = + let s = Bytes.create len in + for i = 0 to len - 1 do Bytes.set s i (f i) done; + Bytes.unsafe_to_string s + ]} + + This function is safe because the byte sequence [s] will never be + accessed or mutated after [unsafe_to_string] is called. The + [string_init] code gives up ownership of [s], and returns the + ownership of the resulting string to its caller. + + Note that it would be unsafe if [s] was passed as an additional + parameter to the function [f] as it could escape this way and be + mutated in the future -- [string_init] would give up ownership of + [s] to pass it to [f], and could not call [unsafe_to_string] + safely. + + We have provided the {!String.init}, {!String.map} and + {!String.mapi} functions to cover most cases of building + new strings. You should prefer those over [to_string] or + [unsafe_to_string] whenever applicable. + + 2. Temporarily giving ownership of a byte sequence to a function + that expects a uniquely owned string and returns ownership back, so + that we can mutate the sequence again after the call ended. + + {[ +let bytes_length (s : bytes) = + String.length (Bytes.unsafe_to_string s) + ]} + + In this use-case, we do not promise that [s] will never be mutated + after the call to [bytes_length s]. The {!String.length} function + temporarily borrows unique ownership of the byte sequence + (and sees it as a [string]), but returns this ownership back to + the caller, which may assume that [s] is still a valid byte + sequence after the call. Note that this is only correct because we + know that {!String.length} does not capture its argument -- it could + escape by a side-channel such as a memoization combinator. + + The caller may not mutate [s] while the string is borrowed (it has + temporarily given up ownership). This affects concurrent programs, + but also higher-order functions: if [String.length] returned + a closure to be called later, [s] should not be mutated until this + closure is fully applied and returns ownership. +*) + +val unsafe_of_string : string -> bytes +(** Unsafely convert a shared string to a byte sequence that should + not be mutated. + + The same ownership discipline that makes [unsafe_to_string] + correct applies to [unsafe_of_string]: you may use it if you were + the owner of the [string] value, and you will own the return + [bytes] in the same mode. + + In practice, unique ownership of string values is extremely + difficult to reason about correctly. You should always assume + strings are shared, never uniquely owned. + + For example, string literals are implicitly shared by the + compiler, so you never uniquely own them. + + {[ +let incorrect = Bytes.unsafe_of_string "hello" +let s = Bytes.of_string "hello" + ]} + + The first declaration is incorrect, because the string literal + ["hello"] could be shared by the compiler with other parts of the + program, and mutating [incorrect] is a bug. You must always use + the second version, which performs a copy and is thus correct. + + Assuming unique ownership of strings that are not string + literals, but are (partly) built from string literals, is also + incorrect. For example, mutating [unsafe_of_string ("foo" ^ s)] + could mutate the shared string ["foo"] -- assuming a rope-like + representation of strings. More generally, functions operating on + strings will assume shared ownership, they do not preserve unique + ownership. It is thus incorrect to assume unique ownership of the + result of [unsafe_of_string]. + + The only case we have reasonable confidence is safe is if the + produced [bytes] is shared -- used as an immutable byte + sequence. This is possibly useful for incremental migration of + low-level programs that manipulate immutable sequences of bytes + (for example {!Marshal.from_bytes}) and previously used the + [string] type for this purpose. +*) + +(**/**) + +(* The following is for system use only. Do not call directly. *) + +external unsafe_get : bytes -> int -> char = "%string_unsafe_get" +external unsafe_set : bytes -> int -> char -> unit = "%string_unsafe_set" +external unsafe_blit : + bytes -> int -> bytes -> int -> int -> unit + = "caml_blit_string" "noalloc" +external unsafe_fill : + bytes -> int -> int -> char -> unit = "caml_fill_string" "noalloc" diff --git a/stdlib/bytesLabels.ml b/stdlib/bytesLabels.ml new file mode 100644 index 000000000..8ec8ec9e1 --- /dev/null +++ b/stdlib/bytesLabels.ml @@ -0,0 +1,16 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jacques Garrigue, Kyoto University RIMS *) +(* *) +(* Copyright 2001 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* Module [BytesLabels]: labelled Bytes module *) + +include Bytes diff --git a/stdlib/bytesLabels.mli b/stdlib/bytesLabels.mli new file mode 100644 index 000000000..d48d95f5c --- /dev/null +++ b/stdlib/bytesLabels.mli @@ -0,0 +1,213 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(** Byte sequence operations. *) + +external length : bytes -> int = "%string_length" +(** Return the length (number of bytes) of the argument. *) + +external get : bytes -> int -> char = "%string_safe_get" +(** [get s n] returns the byte at index [n] in argument [s]. + + Raise [Invalid_argument] if [n] not a valid index in [s]. *) + + +external set : bytes -> int -> char -> unit = "%string_safe_set" +(** [set s n c] modifies [s] in place, replacing the byte at index [n] + with [c]. + + Raise [Invalid_argument] if [n] is not a valid index in [s]. *) + +external create : int -> bytes = "caml_create_string" +(** [create n] returns a new byte sequence of length [n]. The + sequence is uninitialized and contains arbitrary bytes. + + Raise [Invalid_argument] if [n < 0] or [n > ]{!Sys.max_string_length}. *) + +val make : int -> char -> bytes +(** [make n c] returns a new byte sequence of length [n], filled with + the byte [c]. + + Raise [Invalid_argument] if [n < 0] or [n > ]{!Sys.max_string_length}. *) + +val init : int -> f:(int -> char) -> bytes +(** [init n f] returns a fresh byte sequence of length [n], + with character [i] initialized to the result of [f i]. + + Raise [Invalid_argument] if [n < 0] or [n > ]{!Sys.max_string_length}. *) + +val empty : bytes +(** A byte sequence of size 0. *) + +val copy : bytes -> bytes +(** Return a new byte sequence that contains the same bytes as the + argument. *) + +val of_string : string -> bytes +(** Return a new byte sequence that contains the same bytes as the + given string. *) + +val to_string : bytes -> string +(** Return a new string that contains the same bytes as the given byte + sequence. *) + +val sub : bytes -> pos:int -> len:int -> bytes +(** [sub s start len] returns a new byte sequence of length [len], + containing the subsequence of [s] that starts at position [start] + and has length [len]. + + Raise [Invalid_argument] if [start] and [len] do not designate a + valid range of [s]. *) + +val sub_string : bytes -> int -> int -> string +(** Same as [sub] but return a string instead of a byte sequence. *) + +val fill : bytes -> pos:int -> len:int -> char -> unit +(** [fill s start len c] modifies [s] in place, replacing [len] + characters with [c], starting at [start]. + + Raise [Invalid_argument] if [start] and [len] do not designate a + valid range of [s]. *) + +val blit : + src:bytes -> src_pos:int -> dst:bytes -> dst_pos:int -> len:int + -> unit +(** [blit src srcoff dst dstoff len] copies [len] bytes from sequence + [src], starting at index [srcoff], to sequence [dst], starting at + index [dstoff]. It works correctly even if [src] and [dst] are the + same byte sequence, and the source and destination intervals + overlap. + + Raise [Invalid_argument] if [srcoff] and [len] do not + designate a valid range of [src], or if [dstoff] and [len] + do not designate a valid range of [dst]. *) + +val concat : sep:bytes -> bytes list -> bytes +(** [concat sep sl] concatenates the list of byte sequences [sl], + inserting the separator byte sequence [sep] between each, and + returns the result as a new byte sequence. *) + +val iter : f:(char -> unit) -> bytes -> unit +(** [iter f s] applies function [f] in turn to all the bytes of [s]. + It is equivalent to [f (get s 0); f (get s 1); ...; f (get s + (length s - 1)); ()]. *) + +val iteri : f:(int -> char -> unit) -> bytes -> unit +(** Same as {!Bytes.iter}, but the function is applied to the index of + the byte as first argument and the byte itself as second + argument. *) + +val map : f:(char -> char) -> bytes -> bytes +(** [map f s] applies function [f] in turn to all the bytes of [s] and + stores the resulting bytes in a new sequence that is returned as + the result. *) + +val mapi : f:(int -> char -> char) -> bytes -> bytes +(** [mapi f s] calls [f] with each character of [s] and its + index (in increasing index order) and stores the resulting bytes + in a new sequence that is returned as the result. *) + +val trim : bytes -> bytes +(** Return a copy of the argument, without leading and trailing + whitespace. The bytes regarded as whitespace are the ASCII + characters [' '], ['\012'], ['\n'], ['\r'], and ['\t']. *) + +val escaped : bytes -> bytes +(** Return a copy of the argument, with special characters represented + by escape sequences, following the lexical conventions of OCaml. *) + +val index : bytes -> char -> int +(** [index s c] returns the index of the first occurrence of byte [c] + in [s]. + + Raise [Not_found] if [c] does not occur in [s]. *) + +val rindex : bytes -> char -> int +(** [rindex s c] returns the index of the last occurrence of byte [c] + in [s]. + + Raise [Not_found] if [c] does not occur in [s]. *) + +val index_from : bytes -> int -> char -> int +(** [index_from s i c] returns the index of the first occurrence of + byte [c] in [s] after position [i]. [Bytes.index s c] is + equivalent to [Bytes.index_from s 0 c]. + + Raise [Invalid_argument] if [i] is not a valid position in [s]. + Raise [Not_found] if [c] does not occur in [s] after position [i]. *) + +val rindex_from : bytes -> int -> char -> int +(** [rindex_from s i c] returns the index of the last occurrence of + byte [c] in [s] before position [i+1]. [rindex s c] is equivalent + to [rindex_from s (Bytes.length s - 1) c]. + + Raise [Invalid_argument] if [i+1] is not a valid position in [s]. + Raise [Not_found] if [c] does not occur in [s] before position [i+1]. *) + +val contains : bytes -> char -> bool +(** [contains s c] tests if byte [c] appears in [s]. *) + +val contains_from : bytes -> int -> char -> bool +(** [contains_from s start c] tests if byte [c] appears in [s] after + position [start]. [contains s c] is equivalent to [contains_from + s 0 c]. + + Raise [Invalid_argument] if [start] is not a valid position in [s]. *) + +val rcontains_from : bytes -> int -> char -> bool +(** [rcontains_from s stop c] tests if byte [c] appears in [s] before + position [stop+1]. + + Raise [Invalid_argument] if [stop < 0] or [stop+1] is not a valid + position in [s]. *) + +val uppercase : bytes -> bytes +(** Return a copy of the argument, with all lowercase letters + translated to uppercase, including accented letters of the ISO + Latin-1 (8859-1) character set. *) + +val lowercase : bytes -> bytes +(** Return a copy of the argument, with all uppercase letters + translated to lowercase, including accented letters of the ISO + Latin-1 (8859-1) character set. *) + +val capitalize : bytes -> bytes +(** Return a copy of the argument, with the first byte set to + uppercase. *) + +val uncapitalize : bytes -> bytes +(** Return a copy of the argument, with the first byte set to + lowercase. *) + +type t = bytes +(** An alias for the type of byte sequences. *) + +val compare: t -> t -> int +(** The comparison function for byte sequences, with the same + specification as {!Pervasives.compare}. Along with the type [t], + this function [compare] allows the module [Bytes] to be passed as + argument to the functors {!Set.Make} and {!Map.Make}. *) + +(**/**) + +(* The following is for system use only. Do not call directly. *) + +external unsafe_get : bytes -> int -> char = "%string_unsafe_get" +external unsafe_set : bytes -> int -> char -> unit = "%string_unsafe_set" +external unsafe_blit : + src:bytes -> src_pos:int -> dst:bytes -> dst_pos:int -> len:int -> + unit = "caml_blit_string" "noalloc" +external unsafe_fill : + bytes -> pos:int -> len:int -> char -> unit = "caml_fill_string" "noalloc" +val unsafe_to_string : bytes -> string +val unsafe_of_string : string -> bytes diff --git a/stdlib/camlinternalFormat.ml b/stdlib/camlinternalFormat.ml new file mode 100644 index 000000000..7fb82dbe2 --- /dev/null +++ b/stdlib/camlinternalFormat.ml @@ -0,0 +1,2644 @@ +open CamlinternalFormatBasics + +(******************************************************************************) + (* Tools to manipulate scanning set of chars (see %[...]) *) + +type mutable_char_set = bytes + +(* Create a fresh, empty, mutable char set. *) +let create_char_set () = Bytes.make 32 '\000' + +(* Add a char in a mutable char set. *) +let add_in_char_set char_set c = + let ind = int_of_char c in + let str_ind = ind lsr 3 and mask = 1 lsl (ind land 0b111) in + Bytes.set char_set str_ind + (char_of_int (int_of_char (Bytes.get char_set str_ind) lor mask)) + +let freeze_char_set char_set = + Bytes.to_string char_set + +(* Compute the complement of a char set. *) +let rev_char_set char_set = + let char_set' = create_char_set () in + for i = 0 to 31 do + Bytes.set char_set' i + (char_of_int (int_of_char (String.get char_set i) lxor 0xFF)); + done; + Bytes.unsafe_to_string char_set' + +(* Return true if a `c' is in `char_set'. *) +let is_in_char_set char_set c = + let ind = int_of_char c in + let str_ind = ind lsr 3 and mask = 1 lsl (ind land 0b111) in + (int_of_char (String.get char_set str_ind) land mask) <> 0 + + +(******************************************************************************) + (* Ignored param conversion *) + +(* GADT used to abstract an existential type parameter. *) +(* See param_format_of_ignored_format. *) +type ('a, 'b, 'c, 'd, 'e, 'f) param_format_ebb = Param_format_EBB : + ('x -> 'a, 'b, 'c, 'd, 'e, 'f) fmt -> + ('a, 'b, 'c, 'd, 'e, 'f) param_format_ebb + +(* Compute a padding associated to a pad_option (see "%_42d"). *) +let pad_of_pad_opt pad_opt = match pad_opt with + | None -> No_padding + | Some width -> Lit_padding (Right, width) + +(* Compute a precision associated to a prec_option (see "%_.42f"). *) +let prec_of_prec_opt prec_opt = match prec_opt with + | None -> No_precision + | Some ndec -> Lit_precision ndec + +(* Turn an ignored param into its equivalent not-ignored format node. *) +(* Used for format pretty-printing and Scanf. *) +let param_format_of_ignored_format : type a b c d e f x y . + (a, b, c, d, y, x) ignored -> (x, b, c, y, e, f) fmt -> + (a, b, c, d, e, f) param_format_ebb = +fun ign fmt -> match ign with + | Ignored_char -> + Param_format_EBB (Char fmt) + | Ignored_caml_char -> + Param_format_EBB (Caml_char fmt) + | Ignored_string pad_opt -> + Param_format_EBB (String (pad_of_pad_opt pad_opt, fmt)) + | Ignored_caml_string pad_opt -> + Param_format_EBB (Caml_string (pad_of_pad_opt pad_opt, fmt)) + | Ignored_int (iconv, pad_opt) -> + Param_format_EBB (Int (iconv, pad_of_pad_opt pad_opt, No_precision, fmt)) + | Ignored_int32 (iconv, pad_opt) -> + Param_format_EBB + (Int32 (iconv, pad_of_pad_opt pad_opt, No_precision, fmt)) + | Ignored_nativeint (iconv, pad_opt) -> + Param_format_EBB + (Nativeint (iconv, pad_of_pad_opt pad_opt, No_precision, fmt)) + | Ignored_int64 (iconv, pad_opt) -> + Param_format_EBB + (Int64 (iconv, pad_of_pad_opt pad_opt, No_precision, fmt)) + | Ignored_float (pad_opt, prec_opt) -> + Param_format_EBB + (Float (Float_f, pad_of_pad_opt pad_opt, prec_of_prec_opt prec_opt, fmt)) + | Ignored_bool -> + Param_format_EBB (Bool fmt) + | Ignored_format_arg (pad_opt, fmtty) -> + Param_format_EBB (Format_arg (pad_opt, fmtty, fmt)) + | Ignored_format_subst (pad_opt, fmtty) -> + Param_format_EBB + (Format_subst (pad_opt, fmtty, fmt)) + | Ignored_reader -> + Param_format_EBB (Reader fmt) + | Ignored_scan_char_set (width_opt, char_set) -> + Param_format_EBB (Scan_char_set (width_opt, char_set, fmt)) + | Ignored_scan_get_counter counter -> + Param_format_EBB (Scan_get_counter (counter, fmt)) + + +(******************************************************************************) + (* Types *) + +type ('b, 'c) acc_formatting_gen = + | Acc_open_tag of ('b, 'c) acc + | Acc_open_box of ('b, 'c) acc + +(* Reversed list of printing atoms. *) +(* Used to accumulate printf arguments. *) +and ('b, 'c) acc = + | Acc_formatting_lit of ('b, 'c) acc * formatting_lit (* Special fmtting (box) *) + | Acc_formatting_gen of ('b, 'c) acc * ('b, 'c) acc_formatting_gen (* Special fmtting (box) *) + | Acc_string_literal of ('b, 'c) acc * string (* Literal string *) + | Acc_char_literal of ('b, 'c) acc * char (* Literal char *) + | Acc_data_string of ('b, 'c) acc * string (* Generated string *) + | Acc_data_char of ('b, 'c) acc * char (* Generated char *) + | Acc_delay of ('b, 'c) acc * ('b -> 'c) (* Delayed printing (%a, %t) *) + | Acc_flush of ('b, 'c) acc (* Flush *) + | Acc_invalid_arg of ('b, 'c) acc * string (* Raise Invalid_argument msg *) + | End_of_acc + +(* List of heterogeneous values. *) +(* Used to accumulate scanf callback arguments. *) +type ('a, 'b) heter_list = + | Cons : 'c * ('a, 'b) heter_list -> ('c -> 'a, 'b) heter_list + | Nil : ('b, 'b) heter_list + +(* Existential Black Boxes. *) +(* Used to abstract some existential type parameters. *) + +(* GADT type associating a padding and an fmtty. *) +(* See the type_padding function. *) +type ('a, 'b, 'c, 'd, 'e, 'f) padding_fmtty_ebb = Padding_fmtty_EBB : + ('x, 'y) padding * ('y, 'b, 'c, 'd, 'e, 'f) fmtty -> + ('x, 'b, 'c, 'd, 'e, 'f) padding_fmtty_ebb + +(* GADT type associating a padding, a precision and an fmtty. *) +(* See the type_padprec function. *) +type ('a, 'b, 'c, 'd, 'e, 'f) padprec_fmtty_ebb = Padprec_fmtty_EBB : + ('x, 'y) padding * ('y, 'z) precision * ('z, 'b, 'c, 'd, 'e, 'f) fmtty -> + ('x, 'b, 'c, 'd, 'e, 'f) padprec_fmtty_ebb + +(* GADT type associating a padding and an fmt. *) +(* See make_padding_fmt_ebb and parse_format functions. *) +type ('a, 'b, 'c, 'e, 'f) padding_fmt_ebb = Padding_fmt_EBB : + (_, 'x -> 'a) padding * + ('a, 'b, 'c, 'd, 'e, 'f) fmt -> + ('x, 'b, 'c, 'e, 'f) padding_fmt_ebb + +(* GADT type associating a precision and an fmt. *) +(* See make_precision_fmt_ebb and parse_format functions. *) +type ('a, 'b, 'c, 'e, 'f) precision_fmt_ebb = Precision_fmt_EBB : + (_, 'x -> 'a) precision * + ('a, 'b, 'c, 'd, 'e, 'f) fmt -> + ('x, 'b, 'c, 'e, 'f) precision_fmt_ebb + +(* GADT type associating a padding, a precision and an fmt. *) +(* See make_padprec_fmt_ebb and parse_format functions. *) +type ('p, 'b, 'c, 'e, 'f) padprec_fmt_ebb = Padprec_fmt_EBB : + ('x, 'y) padding * ('y, 'p -> 'a) precision * + ('a, 'b, 'c, 'd, 'e, 'f) fmt -> + ('p, 'b, 'c, 'e, 'f) padprec_fmt_ebb + +(* Abstract the 'a and 'd parameters of an fmt. *) +(* Output type of the format parsing function. *) +type ('b, 'c, 'e, 'f) fmt_ebb = Fmt_EBB : + ('a, 'b, 'c, 'd, 'e, 'f) fmt -> + ('b, 'c, 'e, 'f) fmt_ebb + +(* GADT type associating an fmtty and an fmt. *) +(* See the type_format_gen function. *) +type ('a, 'b, 'c, 'd, 'e, 'f) fmt_fmtty_ebb = Fmt_fmtty_EBB : + ('a, 'b, 'c, 'd, 'y, 'x) fmt * + ('x, 'b, 'c, 'y, 'e, 'f) fmtty -> + ('a, 'b, 'c, 'd, 'e, 'f) fmt_fmtty_ebb + +(* GADT type associating an fmtty and an fmt. *) +(* See the type_ignored_format_substitution function. *) +type ('a, 'b, 'c, 'd, 'e, 'f) fmtty_fmt_ebb = Fmtty_fmt_EBB : + ('a, 'b, 'c, 'd, 'y, 'x) fmtty * + ('x, 'b, 'c, 'y, 'e, 'f) fmt_fmtty_ebb -> + ('a, 'b, 'c, 'd, 'e, 'f) fmtty_fmt_ebb + +(* Abstract all fmtty type parameters. *) +(* Used to compare format types. *) +type fmtty_ebb = Fmtty_EBB : ('a, 'b, 'c, 'd, 'e, 'f) fmtty -> fmtty_ebb + +(* Abstract all padding type parameters. *) +(* Used to compare paddings. *) +type padding_ebb = Padding_EBB : ('a, 'b) padding -> padding_ebb + +(* Abstract all precision type parameters. *) +(* Used to compare precisions. *) +type precision_ebb = Precision_EBB : ('a, 'b) precision -> precision_ebb + +(******************************************************************************) + (* Constants *) + +(* Default precision for float printing. *) +let default_float_precision = 6 + +(******************************************************************************) + (* Externals *) + +external format_float: string -> float -> string + = "caml_format_float" +external format_int: string -> int -> string + = "caml_format_int" +external format_int32: string -> int32 -> string + = "caml_int32_format" +external format_nativeint: string -> nativeint -> string + = "caml_nativeint_format" +external format_int64: string -> int64 -> string + = "caml_int64_format" + +(******************************************************************************) + (* Tools to pretty-print formats *) + +(* Type of extensible character buffers. *) +type buffer = { + mutable ind : int; + mutable bytes : bytes; +} + +(* Create a fresh buffer. *) +let buffer_create init_size = { ind = 0; bytes = Bytes.create init_size } + +(* Check size of the buffer and grow it if needed. *) +let buffer_check_size buf overhead = + let len = Bytes.length buf.bytes in + let min_len = buf.ind + overhead in + if min_len > len then ( + let new_len = max (len * 2) min_len in + let new_str = Bytes.create new_len in + Bytes.blit buf.bytes 0 new_str 0 len; + buf.bytes <- new_str; + ) + +(* Add the character `c' to the buffer `buf'. *) +let buffer_add_char buf c = + buffer_check_size buf 1; + Bytes.set buf.bytes buf.ind c; + buf.ind <- buf.ind + 1 + +(* Add the string `s' to the buffer `buf'. *) +let buffer_add_string buf s = + let str_len = String.length s in + buffer_check_size buf str_len; + String.blit s 0 buf.bytes buf.ind str_len; + buf.ind <- buf.ind + str_len + +(* Get the content of the buffer. *) +let buffer_contents buf = + Bytes.sub_string buf.bytes 0 buf.ind + +(***) + +(* Convert an integer conversion to char. *) +let char_of_iconv iconv = match iconv with + | Int_d | Int_pd | Int_sd -> 'd' | Int_i | Int_pi | Int_si -> 'i' + | Int_x | Int_Cx -> 'x' | Int_X | Int_CX -> 'X' | Int_o | Int_Co -> 'o' + | Int_u -> 'u' + +(* Convert a float conversion to char. *) +let char_of_fconv fconv = match fconv with + | Float_f | Float_pf | Float_sf -> 'f' | Float_e | Float_pe | Float_se -> 'e' + | Float_E | Float_pE | Float_sE -> 'E' | Float_g | Float_pg | Float_sg -> 'g' + | Float_G | Float_pG | Float_sG -> 'G' | Float_F -> 'F' + +(* Convert a scanning counter to char. *) +let char_of_counter counter = match counter with + | Line_counter -> 'l' + | Char_counter -> 'n' + | Token_counter -> 'N' + +(***) + +(* Print a char_set in a buffer with the OCaml format lexical convention. *) +let bprint_char_set buf char_set = + let rec print_start set = + let is_alone c = + let before, after = Char.(chr (code c - 1), chr (code c + 1)) in + is_in_char_set set c + && not (is_in_char_set set before && is_in_char_set set after) in + if is_alone ']' then buffer_add_char buf ']'; + print_out set 1; + if is_alone '-' then buffer_add_char buf '-'; + and print_out set i = + if i < 256 then + if is_in_char_set set (char_of_int i) then print_first set i + else print_out set (i + 1) + and print_first set i = + match char_of_int i with + | '\255' -> print_char buf 255; + | ']' | '-' -> print_out set (i + 1); + | _ -> print_second set (i + 1); + and print_second set i = + if is_in_char_set set (char_of_int i) then + match char_of_int i with + | '\255' -> + print_char buf 254; + print_char buf 255; + | ']' | '-' when not (is_in_char_set set (char_of_int (i + 1))) -> + print_char buf (i - 1); + print_out set (i + 1); + | _ when not (is_in_char_set set (char_of_int (i + 1))) -> + print_char buf (i - 1); + print_char buf i; + print_out set (i + 2); + | _ -> + print_in set (i - 1) (i + 2); + else ( + print_char buf (i - 1); + print_out set (i + 1); + ) + and print_in set i j = + if j = 256 || not (is_in_char_set set (char_of_int j)) then ( + print_char buf i; + print_char buf (int_of_char '-'); + print_char buf (j - 1); + if j < 256 then print_out set (j + 1); + ) else + print_in set i (j + 1); + and print_char buf i = match char_of_int i with + | '%' -> buffer_add_char buf '%'; buffer_add_char buf '%'; + | '@' -> buffer_add_char buf '%'; buffer_add_char buf '@'; + | c -> buffer_add_char buf c; + in + buffer_add_char buf '['; + print_start ( + if is_in_char_set char_set '\000' + then ( buffer_add_char buf '^'; rev_char_set char_set ) + else char_set + ); + buffer_add_char buf ']' + +(***) + +(* Print a padty in a buffer with the format-like syntax. *) +let bprint_padty buf padty = match padty with + | Left -> buffer_add_char buf '-' + | Right -> () + | Zeros -> buffer_add_char buf '0' + +(* Print the '_' of an ignored flag if needed. *) +let bprint_ignored_flag buf ign_flag = + if ign_flag then buffer_add_char buf '_' + +(***) + +let bprint_pad_opt buf pad_opt = match pad_opt with + | None -> () + | Some width -> buffer_add_string buf (string_of_int width) + +(***) + +(* Print padding in a buffer with the format-like syntax. *) +let bprint_padding : type a b . buffer -> (a, b) padding -> unit = +fun buf pad -> match pad with + | No_padding -> () + | Lit_padding (padty, n) -> + bprint_padty buf padty; + buffer_add_string buf (string_of_int n); + | Arg_padding padty -> + bprint_padty buf padty; + buffer_add_char buf '*' + +(* Print precision in a buffer with the format-like syntax. *) +let bprint_precision : type a b . buffer -> (a, b) precision -> unit = + fun buf prec -> match prec with + | No_precision -> () + | Lit_precision n -> + buffer_add_char buf '.'; + buffer_add_string buf (string_of_int n); + | Arg_precision -> + buffer_add_string buf ".*" + +(***) + +(* Print the optionnal '+', ' ' or '#' associated to an int conversion. *) +let bprint_iconv_flag buf iconv = match iconv with + | Int_pd | Int_pi -> buffer_add_char buf '+' + | Int_sd | Int_si -> buffer_add_char buf ' ' + | Int_Cx | Int_CX | Int_Co -> buffer_add_char buf '#' + | Int_d | Int_i | Int_x | Int_X | Int_o | Int_u -> () + +(* Print an complete int format in a buffer (ex: "%3.*d"). *) +let bprint_int_fmt buf ign_flag iconv pad prec = + buffer_add_char buf '%'; + bprint_ignored_flag buf ign_flag; + bprint_iconv_flag buf iconv; + bprint_padding buf pad; + bprint_precision buf prec; + buffer_add_char buf (char_of_iconv iconv) + +(* Print a complete int32, nativeint or int64 format in a buffer. *) +let bprint_altint_fmt buf ign_flag iconv pad prec c = + buffer_add_char buf '%'; + bprint_ignored_flag buf ign_flag; + bprint_iconv_flag buf iconv; + bprint_padding buf pad; + bprint_precision buf prec; + buffer_add_char buf c; + buffer_add_char buf (char_of_iconv iconv) + +(***) + +(* Print the optionnal '+' associated to a float conversion. *) +let bprint_fconv_flag buf fconv = match fconv with + | Float_pf | Float_pe | Float_pE | Float_pg | Float_pG -> + buffer_add_char buf '+' + | Float_sf | Float_se | Float_sE | Float_sg | Float_sG -> + buffer_add_char buf ' ' + | Float_f | Float_e | Float_E | Float_g | Float_G | Float_F -> + () + +(* Print a complete float format in a buffer (ex: "%+*.3f"). *) +let bprint_float_fmt buf ign_flag fconv pad prec = + buffer_add_char buf '%'; + bprint_ignored_flag buf ign_flag; + bprint_fconv_flag buf fconv; + bprint_padding buf pad; + bprint_precision buf prec; + buffer_add_char buf (char_of_fconv fconv) + +(* Compute the literal string representation of a formatting_lit. *) +(* Also used by Printf and Scanf where formatting is not interpreted. *) +let string_of_formatting_lit formatting_lit = match formatting_lit with + | Close_box -> "@]" + | Close_tag -> "@}" + | Break (str, _, _) -> str + | FFlush -> "@?" + | Force_newline -> "@\n" + | Flush_newline -> "@." + | Magic_size (str, _) -> str + | Escaped_at -> "@@" + | Escaped_percent -> "@%" + | Scan_indic c -> "@" ^ (String.make 1 c) + +(* Compute the literal string representation of a formatting. *) +(* Also used by Printf and Scanf where formatting is not interpreted. *) +let string_of_formatting_gen : type a b c d e f . + (a, b, c, d, e, f) formatting_gen -> string = + fun formatting_gen -> match formatting_gen with + | Open_tag (Format (_, str)) -> str + | Open_box (Format (_, str)) -> str + +(***) + +(* Print a literal char in a buffer, escape '%' by "%%". *) +let bprint_char_literal buf chr = match chr with + | '%' -> buffer_add_string buf "%%" + | _ -> buffer_add_char buf chr + +(* Print a literal string in a buffer, escape all '%' by "%%". *) +let bprint_string_literal buf str = + for i = 0 to String.length str - 1 do + bprint_char_literal buf str.[i] + done + +(******************************************************************************) + (* Format pretty-printing *) + +(* Print a complete format type (an fmtty) in a buffer. *) +let rec bprint_fmtty : type a b c d e f g h i j k l . + buffer -> (a, b, c, d, e, f, g, h, i, j, k, l) fmtty_rel -> unit = +fun buf fmtty -> match fmtty with + | Char_ty rest -> buffer_add_string buf "%c"; bprint_fmtty buf rest; + | String_ty rest -> buffer_add_string buf "%s"; bprint_fmtty buf rest; + | Int_ty rest -> buffer_add_string buf "%i"; bprint_fmtty buf rest; + | Int32_ty rest -> buffer_add_string buf "%li"; bprint_fmtty buf rest; + | Nativeint_ty rest -> buffer_add_string buf "%ni"; bprint_fmtty buf rest; + | Int64_ty rest -> buffer_add_string buf "%Li"; bprint_fmtty buf rest; + | Float_ty rest -> buffer_add_string buf "%f"; bprint_fmtty buf rest; + | Bool_ty rest -> buffer_add_string buf "%B"; bprint_fmtty buf rest; + | Alpha_ty rest -> buffer_add_string buf "%a"; bprint_fmtty buf rest; + | Theta_ty rest -> buffer_add_string buf "%t"; bprint_fmtty buf rest; + | Reader_ty rest -> buffer_add_string buf "%r"; bprint_fmtty buf rest; + + | Ignored_reader_ty rest -> + buffer_add_string buf "%_r"; + bprint_fmtty buf rest; + + | Format_arg_ty (sub_fmtty, rest) -> + buffer_add_string buf "%{"; bprint_fmtty buf sub_fmtty; + buffer_add_string buf "%}"; bprint_fmtty buf rest; + | Format_subst_ty (sub_fmtty, _, rest) -> + buffer_add_string buf "%("; bprint_fmtty buf sub_fmtty; + buffer_add_string buf "%)"; bprint_fmtty buf rest; + + | End_of_fmtty -> () + +(***) + +(* Print a complete format in a buffer. *) +let bprint_fmt buf fmt = + let rec fmtiter : type a b c d e f . + (a, b, c, d, e, f) fmt -> bool -> unit = + fun fmt ign_flag -> match fmt with + | String (pad, rest) -> + buffer_add_char buf '%'; bprint_ignored_flag buf ign_flag; + bprint_padding buf pad; buffer_add_char buf 's'; + fmtiter rest false; + | Caml_string (pad, rest) -> + buffer_add_char buf '%'; bprint_ignored_flag buf ign_flag; + bprint_padding buf pad; buffer_add_char buf 'S'; + fmtiter rest false; + + | Int (iconv, pad, prec, rest) -> + bprint_int_fmt buf ign_flag iconv pad prec; + fmtiter rest false; + | Int32 (iconv, pad, prec, rest) -> + bprint_altint_fmt buf ign_flag iconv pad prec 'l'; + fmtiter rest false; + | Nativeint (iconv, pad, prec, rest) -> + bprint_altint_fmt buf ign_flag iconv pad prec 'n'; + fmtiter rest false; + | Int64 (iconv, pad, prec, rest) -> + bprint_altint_fmt buf ign_flag iconv pad prec 'L'; + fmtiter rest false; + | Float (fconv, pad, prec, rest) -> + bprint_float_fmt buf ign_flag fconv pad prec; + fmtiter rest false; + + | Char rest -> + buffer_add_char buf '%'; bprint_ignored_flag buf ign_flag; + buffer_add_char buf 'c'; fmtiter rest false; + | Caml_char rest -> + buffer_add_char buf '%'; bprint_ignored_flag buf ign_flag; + buffer_add_char buf 'C'; fmtiter rest false; + | Bool rest -> + buffer_add_char buf '%'; bprint_ignored_flag buf ign_flag; + buffer_add_char buf 'B'; fmtiter rest false; + | Alpha rest -> + buffer_add_char buf '%'; bprint_ignored_flag buf ign_flag; + buffer_add_char buf 'a'; fmtiter rest false; + | Theta rest -> + buffer_add_char buf '%'; bprint_ignored_flag buf ign_flag; + buffer_add_char buf 't'; fmtiter rest false; + | Reader rest -> + buffer_add_char buf '%'; bprint_ignored_flag buf ign_flag; + buffer_add_char buf 'r'; fmtiter rest false; + | Flush rest -> + buffer_add_string buf "%!"; + fmtiter rest ign_flag; + + | String_literal (str, rest) -> + bprint_string_literal buf str; + fmtiter rest ign_flag; + | Char_literal (chr, rest) -> + bprint_char_literal buf chr; + fmtiter rest ign_flag; + + | Format_arg (pad_opt, fmtty, rest) -> + buffer_add_char buf '%'; bprint_ignored_flag buf ign_flag; + bprint_pad_opt buf pad_opt; buffer_add_char buf '{'; + bprint_fmtty buf fmtty; buffer_add_char buf '%'; buffer_add_char buf '}'; + fmtiter rest false; + | Format_subst (pad_opt, fmtty, rest) -> + buffer_add_char buf '%'; bprint_ignored_flag buf ign_flag; + bprint_pad_opt buf pad_opt; buffer_add_char buf '('; + bprint_fmtty buf fmtty; buffer_add_char buf '%'; buffer_add_char buf ')'; + fmtiter rest false; + + | Scan_char_set (width_opt, char_set, rest) -> + buffer_add_char buf '%'; bprint_ignored_flag buf ign_flag; + bprint_pad_opt buf width_opt; bprint_char_set buf char_set; + fmtiter rest false; + | Scan_get_counter (counter, rest) -> + buffer_add_char buf '%'; bprint_ignored_flag buf ign_flag; + buffer_add_char buf (char_of_counter counter); + fmtiter rest false; + | Ignored_param (ign, rest) -> + let Param_format_EBB fmt' = param_format_of_ignored_format ign rest in + fmtiter fmt' true; + + | Formatting_lit (fmting_lit, rest) -> + bprint_string_literal buf (string_of_formatting_lit fmting_lit); + fmtiter rest ign_flag; + | Formatting_gen (fmting_gen, rest) -> + bprint_string_literal buf "@{"; + bprint_string_literal buf (string_of_formatting_gen fmting_gen); + fmtiter rest ign_flag; + + | End_of_format -> () + + in fmtiter fmt false + +(***) + +(* Convert a format to string. *) +let string_of_fmt fmt = + let buf = buffer_create 16 in + bprint_fmt buf fmt; + buffer_contents buf + +(******************************************************************************) + (* Type extraction *) + +type (_, _) eq = Refl : ('a, 'a) eq + +(* Invariant: this function is the identity on values. + + In particular, if (ty1, ty2) have equal values, then + (trans (symm ty1) ty2) respects the 'trans' precondition. *) +let rec symm : type a1 b1 c1 d1 e1 f1 a2 b2 c2 d2 e2 f2 . + (a1, b1, c1, d1, e1, f1, + a2, b2, c2, d2, e2, f2) fmtty_rel +-> (a2, b2, c2, d2, e2, f2, + a1, b1, c1, d1, e1, f1) fmtty_rel += function + | Char_ty rest -> Char_ty (symm rest) + | Int_ty rest -> Int_ty (symm rest) + | Int32_ty rest -> Int32_ty (symm rest) + | Int64_ty rest -> Int64_ty (symm rest) + | Nativeint_ty rest -> Nativeint_ty (symm rest) + | Float_ty rest -> Float_ty (symm rest) + | Bool_ty rest -> Bool_ty (symm rest) + | String_ty rest -> String_ty (symm rest) + | Theta_ty rest -> Theta_ty (symm rest) + | Alpha_ty rest -> Alpha_ty (symm rest) + | Reader_ty rest -> Reader_ty (symm rest) + | Ignored_reader_ty rest -> Ignored_reader_ty (symm rest) + | Format_arg_ty (ty, rest) -> + Format_arg_ty (ty, symm rest) + | Format_subst_ty (ty1, ty2, rest) -> + Format_subst_ty (ty2, ty1, symm rest) + | End_of_fmtty -> End_of_fmtty + +let rec fmtty_rel_det : type a1 b c d1 e1 f1 a2 d2 e2 f2 . + (a1, b, c, d1, e1, f1, + a2, b, c, d2, e2, f2) fmtty_rel -> + ((f1, f2) eq -> (a1, a2) eq) + * ((a1, a2) eq -> (f1, f2) eq) + * ((e1, e2) eq -> (d1, d2) eq) + * ((d1, d2) eq -> (e1, e2) eq) += function + | End_of_fmtty -> + (fun Refl -> Refl), + (fun Refl -> Refl), + (fun Refl -> Refl), + (fun Refl -> Refl) + | Char_ty rest -> + let fa, af, ed, de = fmtty_rel_det rest in + (fun Refl -> let Refl = fa Refl in Refl), + (fun Refl -> let Refl = af Refl in Refl), + ed, de + | String_ty rest -> + let fa, af, ed, de = fmtty_rel_det rest in + (fun Refl -> let Refl = fa Refl in Refl), + (fun Refl -> let Refl = af Refl in Refl), + ed, de + | Int_ty rest -> + let fa, af, ed, de = fmtty_rel_det rest in + (fun Refl -> let Refl = fa Refl in Refl), + (fun Refl -> let Refl = af Refl in Refl), + ed, de + | Int32_ty rest -> + let fa, af, ed, de = fmtty_rel_det rest in + (fun Refl -> let Refl = fa Refl in Refl), + (fun Refl -> let Refl = af Refl in Refl), + ed, de + | Int64_ty rest -> + let fa, af, ed, de = fmtty_rel_det rest in + (fun Refl -> let Refl = fa Refl in Refl), + (fun Refl -> let Refl = af Refl in Refl), + ed, de + | Nativeint_ty rest -> + let fa, af, ed, de = fmtty_rel_det rest in + (fun Refl -> let Refl = fa Refl in Refl), + (fun Refl -> let Refl = af Refl in Refl), + ed, de + | Float_ty rest -> + let fa, af, ed, de = fmtty_rel_det rest in + (fun Refl -> let Refl = fa Refl in Refl), + (fun Refl -> let Refl = af Refl in Refl), + ed, de + | Bool_ty rest -> + let fa, af, ed, de = fmtty_rel_det rest in + (fun Refl -> let Refl = fa Refl in Refl), + (fun Refl -> let Refl = af Refl in Refl), + ed, de + + | Theta_ty rest -> + let fa, af, ed, de = fmtty_rel_det rest in + (fun Refl -> let Refl = fa Refl in Refl), + (fun Refl -> let Refl = af Refl in Refl), + ed, de + | Alpha_ty rest -> + let fa, af, ed, de = fmtty_rel_det rest in + (fun Refl -> let Refl = fa Refl in Refl), + (fun Refl -> let Refl = af Refl in Refl), + ed, de + | Reader_ty rest -> + let fa, af, ed, de = fmtty_rel_det rest in + (fun Refl -> let Refl = fa Refl in Refl), + (fun Refl -> let Refl = af Refl in Refl), + (fun Refl -> let Refl = ed Refl in Refl), + (fun Refl -> let Refl = de Refl in Refl) + | Ignored_reader_ty rest -> + let fa, af, ed, de = fmtty_rel_det rest in + (fun Refl -> let Refl = fa Refl in Refl), + (fun Refl -> let Refl = af Refl in Refl), + (fun Refl -> let Refl = ed Refl in Refl), + (fun Refl -> let Refl = de Refl in Refl) + | Format_arg_ty (_ty, rest) -> + let fa, af, ed, de = fmtty_rel_det rest in + (fun Refl -> let Refl = fa Refl in Refl), + (fun Refl -> let Refl = af Refl in Refl), + ed, de + | Format_subst_ty (ty1, ty2, rest) -> + let fa, af, ed, de = fmtty_rel_det rest in + let ty = trans (symm ty1) ty2 in + let ag, ga, dj, jd = fmtty_rel_det ty in + (fun Refl -> let Refl = fa Refl in let Refl = ag Refl in Refl), + (fun Refl -> let Refl = ga Refl in let Refl = af Refl in Refl), + (fun Refl -> let Refl = ed Refl in let Refl = dj Refl in Refl), + (fun Refl -> let Refl = jd Refl in let Refl = de Refl in Refl) + +(* Precondition: we assume that the two fmtty_rel arguments have equal + values (at possibly distinct types); this invariant comes from the way + fmtty_rel witnesses are produced by the type-checker + + The code below uses (assert false) when this assumption is broken. The + code pattern is the following: + + | Foo x, Foo y -> + (* case where indeed both values + start with constructor Foo *) + | Foo _, _ + | _, Foo _ -> + (* different head constructors: broken precondition *) + assert false +*) +and trans : type + a1 b1 c1 d1 e1 f1 + a2 b2 c2 d2 e2 f2 + a3 b3 c3 d3 e3 f3 +. + (a1, b1, c1, d1, e1, f1, + a2, b2, c2, d2, e2, f2) fmtty_rel +-> (a2, b2, c2, d2, e2, f2, + a3, b3, c3, d3, e3, f3) fmtty_rel +-> (a1, b1, c1, d1, e1, f1, + a3, b3, c3, d3, e3, f3) fmtty_rel += fun ty1 ty2 -> match ty1, ty2 with + | Char_ty rest1, Char_ty rest2 -> Char_ty (trans rest1 rest2) + | String_ty rest1, String_ty rest2 -> String_ty (trans rest1 rest2) + | Bool_ty rest1, Bool_ty rest2 -> Bool_ty (trans rest1 rest2) + | Int_ty rest1, Int_ty rest2 -> Int_ty (trans rest1 rest2) + | Int32_ty rest1, Int32_ty rest2 -> Int32_ty (trans rest1 rest2) + | Int64_ty rest1, Int64_ty rest2 -> Int64_ty (trans rest1 rest2) + | Nativeint_ty rest1, Nativeint_ty rest2 -> Nativeint_ty (trans rest1 rest2) + | Float_ty rest1, Float_ty rest2 -> Float_ty (trans rest1 rest2) + + | Alpha_ty rest1, Alpha_ty rest2 -> Alpha_ty (trans rest1 rest2) + | Alpha_ty _, _ -> assert false + | _, Alpha_ty _ -> assert false + + | Theta_ty rest1, Theta_ty rest2 -> Theta_ty (trans rest1 rest2) + | Theta_ty _, _ -> assert false + | _, Theta_ty _ -> assert false + + | Reader_ty rest1, Reader_ty rest2 -> Reader_ty (trans rest1 rest2) + | Reader_ty _, _ -> assert false + | _, Reader_ty _ -> assert false + + | Ignored_reader_ty rest1, Ignored_reader_ty rest2 -> + Ignored_reader_ty (trans rest1 rest2) + | Ignored_reader_ty _, _ -> assert false + | _, Ignored_reader_ty _ -> assert false + + | Format_arg_ty (ty1, rest1), Format_arg_ty (ty2, rest2) -> + Format_arg_ty (trans ty1 ty2, trans rest1 rest2) + | Format_arg_ty _, _ -> assert false + | _, Format_arg_ty _ -> assert false + + | Format_subst_ty (ty11, ty12, rest1), + Format_subst_ty (ty21, ty22, rest2) -> + let ty = trans (symm ty12) ty21 in + let _, f2, _, f4 = fmtty_rel_det ty in + let Refl = f2 Refl in + let Refl = f4 Refl in + Format_subst_ty (ty11, ty22, trans rest1 rest2) + | Format_subst_ty _, _ -> assert false + | _, Format_subst_ty _ -> assert false + + | End_of_fmtty, End_of_fmtty -> End_of_fmtty + | End_of_fmtty, _ -> assert false + | _, End_of_fmtty -> assert false + +let rec fmtty_of_formatting_gen : type a b c d e f . + (a, b, c, d, e, f) formatting_gen -> + (a, b, c, d, e, f) fmtty = +fun formatting_gen -> match formatting_gen with + | Open_tag (Format (fmt, _)) -> fmtty_of_fmt fmt + | Open_box (Format (fmt, _)) -> fmtty_of_fmt fmt + +(* Extract the type representation (an fmtty) of a format. *) +and fmtty_of_fmt : type a b c d e f . + (a, b, c, d, e, f) fmt -> (a, b, c, d, e, f) fmtty = +fun fmtty -> match fmtty with + | String (pad, rest) -> + fmtty_of_padding_fmtty pad (String_ty (fmtty_of_fmt rest)) + | Caml_string (pad, rest) -> + fmtty_of_padding_fmtty pad (String_ty (fmtty_of_fmt rest)) + + | Int (_, pad, prec, rest) -> + let ty_rest = fmtty_of_fmt rest in + let prec_ty = fmtty_of_precision_fmtty prec (Int_ty ty_rest) in + fmtty_of_padding_fmtty pad prec_ty + | Int32 (_, pad, prec, rest) -> + let ty_rest = fmtty_of_fmt rest in + let prec_ty = fmtty_of_precision_fmtty prec (Int32_ty ty_rest) in + fmtty_of_padding_fmtty pad prec_ty + | Nativeint (_, pad, prec, rest) -> + let ty_rest = fmtty_of_fmt rest in + let prec_ty = fmtty_of_precision_fmtty prec (Nativeint_ty ty_rest) in + fmtty_of_padding_fmtty pad prec_ty + | Int64 (_, pad, prec, rest) -> + let ty_rest = fmtty_of_fmt rest in + let prec_ty = fmtty_of_precision_fmtty prec (Int64_ty ty_rest) in + fmtty_of_padding_fmtty pad prec_ty + | Float (_, pad, prec, rest) -> + let ty_rest = fmtty_of_fmt rest in + let prec_ty = fmtty_of_precision_fmtty prec (Float_ty ty_rest) in + fmtty_of_padding_fmtty pad prec_ty + + | Char rest -> Char_ty (fmtty_of_fmt rest) + | Caml_char rest -> Char_ty (fmtty_of_fmt rest) + | Bool rest -> Bool_ty (fmtty_of_fmt rest) + | Alpha rest -> Alpha_ty (fmtty_of_fmt rest) + | Theta rest -> Theta_ty (fmtty_of_fmt rest) + | Reader rest -> Reader_ty (fmtty_of_fmt rest) + + | Format_arg (_, ty, rest) -> + Format_arg_ty (ty, fmtty_of_fmt rest) + | Format_subst (_, ty, rest) -> + Format_subst_ty (ty, ty, fmtty_of_fmt rest) + + | Flush rest -> fmtty_of_fmt rest + | String_literal (_, rest) -> fmtty_of_fmt rest + | Char_literal (_, rest) -> fmtty_of_fmt rest + + | Scan_char_set (_, _, rest) -> String_ty (fmtty_of_fmt rest) + | Scan_get_counter (_, rest) -> Int_ty (fmtty_of_fmt rest) + | Ignored_param (ign, rest) -> fmtty_of_ignored_format ign rest + | Formatting_lit (_, rest) -> fmtty_of_fmt rest + | Formatting_gen (fmting_gen, rest) -> + concat_fmtty (fmtty_of_formatting_gen fmting_gen) (fmtty_of_fmt rest) + + | End_of_format -> End_of_fmtty + +(* Extract the fmtty of an ignored parameter followed by the rest of + the format. *) +and fmtty_of_ignored_format : type x y a b c d e f . + (a, b, c, d, y, x) ignored -> + (x, b, c, y, e, f) fmt -> + (a, b, c, d, e, f) fmtty = +fun ign fmt -> match ign with + | Ignored_char -> fmtty_of_fmt fmt + | Ignored_caml_char -> fmtty_of_fmt fmt + | Ignored_string _ -> fmtty_of_fmt fmt + | Ignored_caml_string _ -> fmtty_of_fmt fmt + | Ignored_int (_, _) -> fmtty_of_fmt fmt + | Ignored_int32 (_, _) -> fmtty_of_fmt fmt + | Ignored_nativeint (_, _) -> fmtty_of_fmt fmt + | Ignored_int64 (_, _) -> fmtty_of_fmt fmt + | Ignored_float (_, _) -> fmtty_of_fmt fmt + | Ignored_bool -> fmtty_of_fmt fmt + | Ignored_format_arg _ -> fmtty_of_fmt fmt + | Ignored_format_subst (_, fmtty) -> concat_fmtty fmtty (fmtty_of_fmt fmt) + | Ignored_reader -> Ignored_reader_ty (fmtty_of_fmt fmt) + | Ignored_scan_char_set _ -> fmtty_of_fmt fmt + | Ignored_scan_get_counter _ -> fmtty_of_fmt fmt + +(* Add an Int_ty node if padding is taken as an extra argument (ex: "%*s"). *) +and fmtty_of_padding_fmtty : type x a b c d e f . + (x, a) padding -> (a, b, c, d, e, f) fmtty -> (x, b, c, d, e, f) fmtty = + fun pad fmtty -> match pad with + | No_padding -> fmtty + | Lit_padding _ -> fmtty + | Arg_padding _ -> Int_ty fmtty + +(* Add an Int_ty node if precision is taken as an extra argument (ex: "%.*f").*) +and fmtty_of_precision_fmtty : type x a b c d e f . + (x, a) precision -> (a, b, c, d, e, f) fmtty -> (x, b, c, d, e, f) fmtty = + fun prec fmtty -> match prec with + | No_precision -> fmtty + | Lit_precision _ -> fmtty + | Arg_precision -> Int_ty fmtty + +(******************************************************************************) + (* Format typing *) + +(* Exception raised when a format does not match a given format type. *) +exception Type_mismatch + +(* Type a padding. *) +(* Take an Int_ty from the fmtty if the integer should be kept as argument. *) +(* Raise Type_mismatch in case of type mismatch. *) +let type_padding : type a b c d e f x y . + (x, y) padding -> (a, b, c, d, e, f) fmtty -> + (a, b, c, d, e, f) padding_fmtty_ebb = +fun pad fmtty -> match pad, fmtty with + | No_padding, _ -> Padding_fmtty_EBB (No_padding, fmtty) + | Lit_padding (padty, w), _ -> Padding_fmtty_EBB (Lit_padding (padty,w),fmtty) + | Arg_padding padty, Int_ty rest -> Padding_fmtty_EBB (Arg_padding padty,rest) + | _ -> raise Type_mismatch + +(* Convert a (upadding, uprecision) to a (padding, precision). *) +(* Take one or two Int_ty from the fmtty if needed. *) +(* Raise Type_mismatch in case of type mismatch. *) +let type_padprec : type a b c d e f x y z . + (x, y) padding -> (y, z) precision -> (a, b, c, d, e, f) fmtty -> + (a, b, c, d, e, f) padprec_fmtty_ebb = +fun pad prec fmtty -> match prec, type_padding pad fmtty with + | No_precision, Padding_fmtty_EBB (pad, rest) -> + Padprec_fmtty_EBB (pad, No_precision, rest) + | Lit_precision p, Padding_fmtty_EBB (pad, rest) -> + Padprec_fmtty_EBB (pad, Lit_precision p, rest) + | Arg_precision, Padding_fmtty_EBB (pad, Int_ty rest) -> + Padprec_fmtty_EBB (pad, Arg_precision, rest) + | _, Padding_fmtty_EBB (_, _) -> raise Type_mismatch + +(* Type a format according to an fmtty. *) +(* If typing succeed, generate a copy of the format with the same + type parameters as the fmtty. *) +(* Raise a Failure with an error message in case of type mismatch. *) +let rec type_format : + type a1 b1 c1 d1 e1 f1 + a2 b2 c2 d2 e2 f2 . + (a1, b1, c1, d1, e1, f1) fmt + -> (a2, b2, c2, d2, e2, f2) fmtty + -> (a2, b2, c2, d2, e2, f2) fmt += fun fmt fmtty -> match type_format_gen fmt fmtty with + | Fmt_fmtty_EBB (fmt', End_of_fmtty) -> fmt' + | _ -> raise Type_mismatch + +and type_format_gen : + type a1 b1 c1 d1 e1 f1 + a2 b2 c2 d2 e2 f2 . + (a1, b1, c1, d1, e1, f1) fmt + -> (a2, b2, c2, d2, e2, f2) fmtty + -> (a2, b2, c2, d2, e2, f2) fmt_fmtty_ebb += fun fmt fmtty -> match fmt, fmtty with + | Char fmt_rest, Char_ty fmtty_rest -> + let Fmt_fmtty_EBB (fmt', fmtty') = type_format_gen fmt_rest fmtty_rest in + Fmt_fmtty_EBB (Char fmt', fmtty') + | Caml_char fmt_rest, Char_ty fmtty_rest -> + let Fmt_fmtty_EBB (fmt', fmtty') = type_format_gen fmt_rest fmtty_rest in + Fmt_fmtty_EBB (Caml_char fmt', fmtty') + | String (pad, fmt_rest), _ -> ( + match type_padding pad fmtty with + | Padding_fmtty_EBB (pad, String_ty fmtty_rest) -> + let Fmt_fmtty_EBB (fmt', fmtty') = type_format_gen fmt_rest fmtty_rest in + Fmt_fmtty_EBB (String (pad, fmt'), fmtty') + | Padding_fmtty_EBB (_, _) -> raise Type_mismatch + ) + | Caml_string (pad, fmt_rest), _ -> ( + match type_padding pad fmtty with + | Padding_fmtty_EBB (pad, String_ty fmtty_rest) -> + let Fmt_fmtty_EBB (fmt', fmtty') = type_format_gen fmt_rest fmtty_rest in + Fmt_fmtty_EBB (Caml_string (pad, fmt'), fmtty') + | Padding_fmtty_EBB (_, _) -> raise Type_mismatch + ) + | Int (iconv, pad, prec, fmt_rest), _ -> ( + match type_padprec pad prec fmtty with + | Padprec_fmtty_EBB (pad, prec, Int_ty fmtty_rest) -> + let Fmt_fmtty_EBB (fmt', fmtty') = type_format_gen fmt_rest fmtty_rest in + Fmt_fmtty_EBB (Int (iconv, pad, prec, fmt'), fmtty') + | Padprec_fmtty_EBB (_, _, _) -> raise Type_mismatch + ) + | Int32 (iconv, pad, prec, fmt_rest), _ -> ( + match type_padprec pad prec fmtty with + | Padprec_fmtty_EBB (pad, prec, Int32_ty fmtty_rest) -> + let Fmt_fmtty_EBB (fmt', fmtty') = type_format_gen fmt_rest fmtty_rest in + Fmt_fmtty_EBB (Int32 (iconv, pad, prec, fmt'), fmtty') + | Padprec_fmtty_EBB (_, _, _) -> raise Type_mismatch + ) + | Nativeint (iconv, pad, prec, fmt_rest), _ -> ( + match type_padprec pad prec fmtty with + | Padprec_fmtty_EBB (pad, prec, Nativeint_ty fmtty_rest) -> + let Fmt_fmtty_EBB (fmt', fmtty') = type_format_gen fmt_rest fmtty_rest in + Fmt_fmtty_EBB (Nativeint (iconv, pad, prec, fmt'), fmtty') + | Padprec_fmtty_EBB (_, _, _) -> raise Type_mismatch + ) + | Int64 (iconv, pad, prec, fmt_rest), _ -> ( + match type_padprec pad prec fmtty with + | Padprec_fmtty_EBB (pad, prec, Int64_ty fmtty_rest) -> + let Fmt_fmtty_EBB (fmt', fmtty') = type_format_gen fmt_rest fmtty_rest in + Fmt_fmtty_EBB (Int64 (iconv, pad, prec, fmt'), fmtty') + | Padprec_fmtty_EBB (_, _, _) -> raise Type_mismatch + ) + | Float (fconv, pad, prec, fmt_rest), _ -> ( + match type_padprec pad prec fmtty with + | Padprec_fmtty_EBB (pad, prec, Float_ty fmtty_rest) -> + let Fmt_fmtty_EBB (fmt', fmtty') = type_format_gen fmt_rest fmtty_rest in + Fmt_fmtty_EBB (Float (fconv, pad, prec, fmt'), fmtty') + | Padprec_fmtty_EBB (_, _, _) -> raise Type_mismatch + ) + | Bool fmt_rest, Bool_ty fmtty_rest -> + let Fmt_fmtty_EBB (fmt', fmtty') = type_format_gen fmt_rest fmtty_rest in + Fmt_fmtty_EBB (Bool fmt', fmtty') + | Flush fmt_rest, fmtty_rest -> + let Fmt_fmtty_EBB (fmt', fmtty') = type_format_gen fmt_rest fmtty_rest in + Fmt_fmtty_EBB (Flush fmt', fmtty') + + | String_literal (str, fmt_rest), fmtty_rest -> + let Fmt_fmtty_EBB (fmt', fmtty') = type_format_gen fmt_rest fmtty_rest in + Fmt_fmtty_EBB (String_literal (str, fmt'), fmtty') + | Char_literal (chr, fmt_rest), fmtty_rest -> + let Fmt_fmtty_EBB (fmt', fmtty') = type_format_gen fmt_rest fmtty_rest in + Fmt_fmtty_EBB (Char_literal (chr, fmt'), fmtty') + + | Format_arg (pad_opt, sub_fmtty, fmt_rest), + Format_arg_ty (sub_fmtty', fmtty_rest) -> + if Fmtty_EBB sub_fmtty <> Fmtty_EBB sub_fmtty' then raise Type_mismatch; + let Fmt_fmtty_EBB (fmt', fmtty') = type_format_gen fmt_rest fmtty_rest in + Fmt_fmtty_EBB (Format_arg (pad_opt, sub_fmtty', fmt'), fmtty') + | Format_subst (pad_opt, sub_fmtty, fmt_rest), + Format_subst_ty (sub_fmtty1, _sub_fmtty2, fmtty_rest) -> + if Fmtty_EBB (erase_rel sub_fmtty) <> Fmtty_EBB (erase_rel sub_fmtty1) then + raise Type_mismatch; + let Fmt_fmtty_EBB (fmt', fmtty') = type_format_gen fmt_rest (erase_rel fmtty_rest) in + Fmt_fmtty_EBB (Format_subst (pad_opt, sub_fmtty1, fmt'), fmtty') + (* Printf and Format specific constructors: *) + | Alpha fmt_rest, Alpha_ty fmtty_rest -> + let Fmt_fmtty_EBB (fmt', fmtty') = type_format_gen fmt_rest fmtty_rest in + Fmt_fmtty_EBB (Alpha fmt', fmtty') + | Theta fmt_rest, Theta_ty fmtty_rest -> + let Fmt_fmtty_EBB (fmt', fmtty') = type_format_gen fmt_rest fmtty_rest in + Fmt_fmtty_EBB (Theta fmt', fmtty') + + (* Format specific constructors: *) + | Formatting_lit (formatting_lit, fmt_rest), fmtty_rest -> + let Fmt_fmtty_EBB (fmt', fmtty') = type_format_gen fmt_rest fmtty_rest in + Fmt_fmtty_EBB (Formatting_lit (formatting_lit, fmt'), fmtty') + | Formatting_gen (formatting_gen, fmt_rest), fmtty_rest -> + type_formatting_gen formatting_gen fmt_rest fmtty_rest + + (* Scanf specific constructors: *) + | Reader fmt_rest, Reader_ty fmtty_rest -> + let Fmt_fmtty_EBB (fmt', fmtty') = type_format_gen fmt_rest fmtty_rest in + Fmt_fmtty_EBB (Reader fmt', fmtty') + | Scan_char_set (width_opt, char_set, fmt_rest), String_ty fmtty_rest -> + let Fmt_fmtty_EBB (fmt', fmtty') = type_format_gen fmt_rest fmtty_rest in + Fmt_fmtty_EBB (Scan_char_set (width_opt, char_set, fmt'), fmtty') + | Scan_get_counter (counter, fmt_rest), Int_ty fmtty_rest -> + let Fmt_fmtty_EBB (fmt', fmtty') = type_format_gen fmt_rest fmtty_rest in + Fmt_fmtty_EBB (Scan_get_counter (counter, fmt'), fmtty') + | Ignored_param (ign, rest), fmtty_rest -> + type_ignored_param ign rest fmtty_rest + + | End_of_format, fmtty_rest -> Fmt_fmtty_EBB (End_of_format, fmtty_rest) + + | _ -> raise Type_mismatch + +and type_formatting_gen : type a1 a3 b1 b3 c1 c3 d1 d3 e1 e2 e3 f1 f2 f3 . + (a1, b1, c1, d1, e1, f1) formatting_gen -> + (f1, b1, c1, e1, e2, f2) fmt -> + (a3, b3, c3, d3, e3, f3) fmtty -> + (a3, b3, c3, d3, e3, f3) fmt_fmtty_ebb = +fun formatting_gen fmt0 fmtty0 -> match formatting_gen with + | Open_tag (Format (fmt1, str)) -> + let Fmt_fmtty_EBB (fmt2, fmtty2) = type_format_gen fmt1 fmtty0 in + let Fmt_fmtty_EBB (fmt3, fmtty3) = type_format_gen fmt0 fmtty2 in + Fmt_fmtty_EBB (Formatting_gen (Open_tag (Format (fmt2, str)), fmt3), fmtty3) + | Open_box (Format (fmt1, str)) -> + let Fmt_fmtty_EBB (fmt2, fmtty2) = type_format_gen fmt1 fmtty0 in + let Fmt_fmtty_EBB (fmt3, fmtty3) = type_format_gen fmt0 fmtty2 in + Fmt_fmtty_EBB (Formatting_gen (Open_tag (Format (fmt2, str)), fmt3), fmtty3) + +(* Type an Ignored_param node according to an fmtty. *) +and type_ignored_param : type p q x y z t u v a b c d e f . + (x, y, z, t, q, p) ignored -> + (p, y, z, q, u, v) fmt -> + (a, b, c, d, e, f) fmtty -> + (a, b, c, d, e, f) fmt_fmtty_ebb = +fun ign fmt fmtty -> match ign with + | Ignored_char as ign' -> type_ignored_param_one ign' fmt fmtty + | Ignored_caml_char as ign' -> type_ignored_param_one ign' fmt fmtty + | Ignored_string _ as ign' -> type_ignored_param_one ign' fmt fmtty + | Ignored_caml_string _ as ign' -> type_ignored_param_one ign' fmt fmtty + | Ignored_int _ as ign' -> type_ignored_param_one ign' fmt fmtty + | Ignored_int32 _ as ign' -> type_ignored_param_one ign' fmt fmtty + | Ignored_nativeint _ as ign' -> type_ignored_param_one ign' fmt fmtty + | Ignored_int64 _ as ign' -> type_ignored_param_one ign' fmt fmtty + | Ignored_float _ as ign' -> type_ignored_param_one ign' fmt fmtty + | Ignored_bool as ign' -> type_ignored_param_one ign' fmt fmtty + | Ignored_scan_char_set _ as ign' -> type_ignored_param_one ign' fmt fmtty + | Ignored_scan_get_counter _ as ign' -> type_ignored_param_one ign' fmt fmtty + | Ignored_format_arg (pad_opt, sub_fmtty) -> + type_ignored_param_one (Ignored_format_arg (pad_opt, sub_fmtty)) fmt fmtty + | Ignored_format_subst (pad_opt, sub_fmtty) -> + let Fmtty_fmt_EBB (sub_fmtty', Fmt_fmtty_EBB (fmt', fmtty')) = + type_ignored_format_substitution sub_fmtty fmt fmtty in + Fmt_fmtty_EBB (Ignored_param (Ignored_format_subst (pad_opt, sub_fmtty'), fmt'), fmtty') + | Ignored_reader -> ( + match fmtty with + | Ignored_reader_ty fmtty_rest -> + let Fmt_fmtty_EBB (fmt', fmtty') = type_format_gen fmt fmtty_rest in + Fmt_fmtty_EBB (Ignored_param (Ignored_reader, fmt'), fmtty') + | _ -> raise Type_mismatch + ) + +and type_ignored_param_one : type a1 a2 b1 b2 c1 c2 d1 d2 e1 e2 f1 f2 . + (a2, b2, c2, d2, d2, a2) ignored -> + (a1, b1, c1, d1, e1, f1) fmt -> + (a2, b2, c2, d2, e2, f2) fmtty -> + (a2, b2, c2, d2, e2, f2) fmt_fmtty_ebb += fun ign fmt fmtty -> + let Fmt_fmtty_EBB (fmt', fmtty') = type_format_gen fmt fmtty in + Fmt_fmtty_EBB (Ignored_param (ign, fmt'), fmtty') + +(* Typing of the complex case: "%_(...%)". *) +and type_ignored_format_substitution : type w x y z p s t u a b c d e f . + (w, x, y, z, s, p) fmtty -> + (p, x, y, s, t, u) fmt -> + (a, b, c, d, e, f) fmtty -> (a, b, c, d, e, f) fmtty_fmt_ebb = +fun sub_fmtty fmt fmtty -> match sub_fmtty, fmtty with + | Char_ty sub_fmtty_rest, Char_ty fmtty_rest -> + let Fmtty_fmt_EBB (sub_fmtty_rest', fmt') = + type_ignored_format_substitution sub_fmtty_rest fmt fmtty_rest in + Fmtty_fmt_EBB (Char_ty sub_fmtty_rest', fmt') + | String_ty sub_fmtty_rest, String_ty fmtty_rest -> + let Fmtty_fmt_EBB (sub_fmtty_rest', fmt') = + type_ignored_format_substitution sub_fmtty_rest fmt fmtty_rest in + Fmtty_fmt_EBB (String_ty sub_fmtty_rest', fmt') + | Int_ty sub_fmtty_rest, Int_ty fmtty_rest -> + let Fmtty_fmt_EBB (sub_fmtty_rest', fmt') = + type_ignored_format_substitution sub_fmtty_rest fmt fmtty_rest in + Fmtty_fmt_EBB (Int_ty sub_fmtty_rest', fmt') + | Int32_ty sub_fmtty_rest, Int32_ty fmtty_rest -> + let Fmtty_fmt_EBB (sub_fmtty_rest', fmt') = + type_ignored_format_substitution sub_fmtty_rest fmt fmtty_rest in + Fmtty_fmt_EBB (Int32_ty sub_fmtty_rest', fmt') + | Nativeint_ty sub_fmtty_rest, Nativeint_ty fmtty_rest -> + let Fmtty_fmt_EBB (sub_fmtty_rest', fmt') = + type_ignored_format_substitution sub_fmtty_rest fmt fmtty_rest in + Fmtty_fmt_EBB (Nativeint_ty sub_fmtty_rest', fmt') + | Int64_ty sub_fmtty_rest, Int64_ty fmtty_rest -> + let Fmtty_fmt_EBB (sub_fmtty_rest', fmt') = + type_ignored_format_substitution sub_fmtty_rest fmt fmtty_rest in + Fmtty_fmt_EBB (Int64_ty sub_fmtty_rest', fmt') + | Float_ty sub_fmtty_rest, Float_ty fmtty_rest -> + let Fmtty_fmt_EBB (sub_fmtty_rest', fmt') = + type_ignored_format_substitution sub_fmtty_rest fmt fmtty_rest in + Fmtty_fmt_EBB (Float_ty sub_fmtty_rest', fmt') + | Bool_ty sub_fmtty_rest, Bool_ty fmtty_rest -> + let Fmtty_fmt_EBB (sub_fmtty_rest', fmt') = + type_ignored_format_substitution sub_fmtty_rest fmt fmtty_rest in + Fmtty_fmt_EBB (Bool_ty sub_fmtty_rest', fmt') + | Alpha_ty sub_fmtty_rest, Alpha_ty fmtty_rest -> + let Fmtty_fmt_EBB (sub_fmtty_rest', fmt') = + type_ignored_format_substitution sub_fmtty_rest fmt fmtty_rest in + Fmtty_fmt_EBB (Alpha_ty sub_fmtty_rest', fmt') + | Theta_ty sub_fmtty_rest, Theta_ty fmtty_rest -> + let Fmtty_fmt_EBB (sub_fmtty_rest', fmt') = + type_ignored_format_substitution sub_fmtty_rest fmt fmtty_rest in + Fmtty_fmt_EBB (Theta_ty sub_fmtty_rest', fmt') + | Reader_ty sub_fmtty_rest, Reader_ty fmtty_rest -> + let Fmtty_fmt_EBB (sub_fmtty_rest', fmt') = + type_ignored_format_substitution sub_fmtty_rest fmt fmtty_rest in + Fmtty_fmt_EBB (Reader_ty sub_fmtty_rest', fmt') + | Ignored_reader_ty sub_fmtty_rest, Ignored_reader_ty fmtty_rest -> + let Fmtty_fmt_EBB (sub_fmtty_rest', fmt') = + type_ignored_format_substitution sub_fmtty_rest fmt fmtty_rest in + Fmtty_fmt_EBB (Ignored_reader_ty sub_fmtty_rest', fmt') + + | Format_arg_ty (sub2_fmtty, sub_fmtty_rest), + Format_arg_ty (sub2_fmtty', fmtty_rest) -> + if Fmtty_EBB sub2_fmtty <> Fmtty_EBB sub2_fmtty' then raise Type_mismatch; + let Fmtty_fmt_EBB (sub_fmtty_rest', fmt') = + type_ignored_format_substitution sub_fmtty_rest fmt fmtty_rest in + Fmtty_fmt_EBB (Format_arg_ty (sub2_fmtty', sub_fmtty_rest'), fmt') + | Format_subst_ty (sub1_fmtty, sub2_fmtty, sub_fmtty_rest), + Format_subst_ty (sub1_fmtty', sub2_fmtty', fmtty_rest) -> + (* TODO define Fmtty_rel_EBB to remove those erase_rel *) + if Fmtty_EBB (erase_rel sub1_fmtty) <> Fmtty_EBB (erase_rel sub1_fmtty') then raise Type_mismatch; + if Fmtty_EBB (erase_rel sub2_fmtty) <> Fmtty_EBB (erase_rel sub2_fmtty') then raise Type_mismatch; + let sub_fmtty' = trans (symm sub1_fmtty') sub2_fmtty' in + let _, f2, _, f4 = fmtty_rel_det sub_fmtty' in + let Refl = f2 Refl in + let Refl = f4 Refl in + let Fmtty_fmt_EBB (sub_fmtty_rest', fmt') = + type_ignored_format_substitution (erase_rel sub_fmtty_rest) fmt fmtty_rest in + Fmtty_fmt_EBB (Format_subst_ty (sub1_fmtty', sub2_fmtty', symm sub_fmtty_rest'), fmt') + | End_of_fmtty, fmtty -> + Fmtty_fmt_EBB (End_of_fmtty, type_format_gen fmt fmtty) + | _ -> raise Type_mismatch + +(* This implementation of `recast` is a bit disappointing. The + invariant provided by the type are very strong: the input format's + type is in relation to the output type's as witnessed by the + fmtty_rel argument. One would at first expect this function to be + total, and implementable by exhaustive pattern matching. Instead, + we reuse the highly partial and much less well-defined function + `type_format` that has lost all knowledge of the correspondence + between the argument's types. + + Besides the fact that this function reuses a lot of the + `type_format` logic (eg.: seeing Int_ty in the fmtty parameter does + not let you match on Int only, as you may in fact have Float + (Arg_padding, ...) ("%.*d") beginning with an Int_ty), it is also + a partial function, because the typing information in a format is + not quite enough to reconstruct it unambiguously. For example, the + format types of "%d%_r" and "%_r%d" have the same format6 + parameters, but they are not at all exchangeable, and putting one + in place of the other must result in a dynamic failure. + + Given that: + - we'd have to duplicate a lot of non-trivial typing logic from type_format + - this wouldn't even eliminate (all) the dynamic failures + we decided to just reuse type_format directly for now. +*) +let recast : + type a1 b1 c1 d1 e1 f1 + a2 b2 c2 d2 e2 f2 + . + (a1, b1, c1, d1, e1, f1) fmt + -> (a1, b1, c1, d1, e1, f1, + a2, b2, c2, d2, e2, f2) fmtty_rel + -> (a2, b2, c2, d2, e2, f2) fmt += fun fmt fmtty -> + type_format fmt (erase_rel (symm fmtty)) + +(******************************************************************************) + (* Printing tools *) + +(* Add padding spaces arround a string. *) +let fix_padding padty width str = + let len = String.length str in + if width <= len then str else + let res = Bytes.make width (if padty = Zeros then '0' else ' ') in + begin match padty with + | Left -> String.blit str 0 res 0 len + | Right -> String.blit str 0 res (width - len) len + | Zeros when len > 0 && (str.[0] = '+' || str.[0] = '-' || str.[0] = ' ') -> + Bytes.set res 0 str.[0]; + String.blit str 1 res (width - len + 1) (len - 1) + | Zeros when len > 1 && str.[0] = '0' && (str.[1] = 'x' || str.[1] = 'X') -> + Bytes.set res 1 str.[1]; + String.blit str 2 res (width - len + 2) (len - 2) + | Zeros -> + String.blit str 0 res (width - len) len + end; + Bytes.unsafe_to_string res + +(* Add '0' padding to int, int32, nativeint or int64 string representation. *) +let fix_int_precision prec str = + let len = String.length str in + if prec <= len then str else + let res = Bytes.make prec '0' in + begin match str.[0] with + | ('+' | '-' | ' ') as c -> + Bytes.set res 0 c; + String.blit str 1 res (prec - len + 1) (len - 1); + | '0' when len > 1 && (str.[1] = 'x' || str.[1] = 'X') -> + Bytes.set res 1 str.[1]; + String.blit str 2 res (prec - len + 2) (len - 2); + | '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> + String.blit str 0 res (prec - len) len; + | _ -> + assert false + end; + Bytes.unsafe_to_string res + +(* Escape a string according to the OCaml lexing convention. *) +let string_to_caml_string str = + let str = String.escaped str in + let l = String.length str in + let res = Bytes.make (l + 2) '\"' in + String.unsafe_blit str 0 res 1 l; + Bytes.unsafe_to_string res + +(* Generate the format_int/int32/nativeint/int64 first argument + from an int_conv. *) +let format_of_iconv = function + | Int_d -> "%d" | Int_pd -> "%+d" | Int_sd -> "% d" + | Int_i -> "%i" | Int_pi -> "%+i" | Int_si -> "% i" + | Int_x -> "%x" | Int_Cx -> "%#x" + | Int_X -> "%X" | Int_CX -> "%#X" + | Int_o -> "%o" | Int_Co -> "%#o" + | Int_u -> "%u" + +let format_of_iconvL = function + | Int_d -> "%Ld" | Int_pd -> "%+Ld" | Int_sd -> "% Ld" + | Int_i -> "%Li" | Int_pi -> "%+Li" | Int_si -> "% Li" + | Int_x -> "%Lx" | Int_Cx -> "%#Lx" + | Int_X -> "%LX" | Int_CX -> "%#LX" + | Int_o -> "%Lo" | Int_Co -> "%#Lo" + | Int_u -> "%Lu" + +let format_of_iconvl = function + | Int_d -> "%ld" | Int_pd -> "%+ld" | Int_sd -> "% ld" + | Int_i -> "%li" | Int_pi -> "%+li" | Int_si -> "% li" + | Int_x -> "%lx" | Int_Cx -> "%#lx" + | Int_X -> "%lX" | Int_CX -> "%#lX" + | Int_o -> "%lo" | Int_Co -> "%#lo" + | Int_u -> "%lu" + +let format_of_iconvn = function + | Int_d -> "%nd" | Int_pd -> "%+nd" | Int_sd -> "% nd" + | Int_i -> "%ni" | Int_pi -> "%+ni" | Int_si -> "% ni" + | Int_x -> "%nx" | Int_Cx -> "%#nx" + | Int_X -> "%nX" | Int_CX -> "%#nX" + | Int_o -> "%no" | Int_Co -> "%#no" + | Int_u -> "%nu" + +(* Generate the format_float first argument form a float_conv. *) +let format_of_fconv fconv prec = + let symb = if fconv = Float_F then 'g' else char_of_fconv fconv in + let buf = buffer_create 16 in + buffer_add_char buf '%'; + bprint_fconv_flag buf fconv; + buffer_add_char buf '.'; + buffer_add_string buf (string_of_int prec); + buffer_add_char buf symb; + buffer_contents buf + +(* Convert an integer to a string according to a conversion. *) +let convert_int iconv n = format_int (format_of_iconv iconv) n +let convert_int32 iconv n = format_int32 (format_of_iconvl iconv) n +let convert_nativeint iconv n = format_nativeint (format_of_iconvn iconv) n +let convert_int64 iconv n = format_int64 (format_of_iconvL iconv) n + +(* Convert a float to string. *) +(* Fix special case of "OCaml float format". *) +let convert_float fconv prec x = + let str = format_float (format_of_fconv fconv prec) x in + if fconv <> Float_F then str else + let len = String.length str in + let rec is_valid i = + if i = len then false else + match str.[i] with + | '.' | 'e' | 'E' -> true + | _ -> is_valid (i + 1) + in + match classify_float x with + | FP_normal | FP_subnormal | FP_zero -> + if is_valid 0 then str else str ^ "." + | FP_infinite -> + if x < 0.0 then "neg_infinity" else "infinity" + | FP_nan -> "nan" + +(* Convert a char to a string according to the OCaml lexical convention. *) +let format_caml_char c = + let str = Char.escaped c in + let l = String.length str in + let res = Bytes.make (l + 2) '\'' in + String.unsafe_blit str 0 res 1 l; + Bytes.unsafe_to_string res + +(* Convert a format type to string *) +let string_of_fmtty fmtty = + let buf = buffer_create 16 in + bprint_fmtty buf fmtty; + buffer_contents buf + +(******************************************************************************) + (* Generic printing function *) + +(* Make a generic printing function. *) +(* Used to generate Printf and Format printing functions. *) +(* Parameters: + k: a continuation finally applied to the output stream and the accumulator. + o: the output stream (see k, %a and %t). + acc: rev list of printing entities (string, char, flush, formatting, ...). + fmt: the format. *) +let rec make_printf : type a b c d e f . + (b -> (b, c) acc -> f) -> b -> (b, c) acc -> + (a, b, c, d, e, f) fmt -> a = +fun k o acc fmt -> match fmt with + | Char rest -> + fun c -> + let new_acc = Acc_data_char (acc, c) in + make_printf k o new_acc rest + | Caml_char rest -> + fun c -> + let new_acc = Acc_data_string (acc, format_caml_char c) in + make_printf k o new_acc rest + | String (pad, rest) -> + make_string_padding k o acc rest pad (fun str -> str) + | Caml_string (pad, rest) -> + make_string_padding k o acc rest pad string_to_caml_string + | Int (iconv, pad, prec, rest) -> + make_int_padding_precision k o acc rest pad prec convert_int iconv + | Int32 (iconv, pad, prec, rest) -> + make_int_padding_precision k o acc rest pad prec convert_int32 iconv + | Nativeint (iconv, pad, prec, rest) -> + make_int_padding_precision k o acc rest pad prec convert_nativeint iconv + | Int64 (iconv, pad, prec, rest) -> + make_int_padding_precision k o acc rest pad prec convert_int64 iconv + | Float (fconv, pad, prec, rest) -> + make_float_padding_precision k o acc rest pad prec fconv + | Bool rest -> + fun b -> make_printf k o (Acc_data_string (acc, string_of_bool b)) rest + | Alpha rest -> + fun f x -> make_printf k o (Acc_delay (acc, fun o -> f o x)) rest + | Theta rest -> + fun f -> make_printf k o (Acc_delay (acc, f)) rest + | Reader _ -> + (* This case is impossible, by typing of formats. *) + (* Indeed, since printf and co. take a format4 as argument, the 'd and 'e + type parameters of fmt are obviously equals. The Reader is the + only constructor which touch 'd and 'e type parameters of the format + type, it adds an (->) to the 'd parameters. Consequently, a format4 + cannot contain a Reader node, except in the sub-format associated to + an %{...%}. It's not a problem because make_printf do not call + itself recursively on the sub-format associated to %{...%}. *) + assert false + | Flush rest -> + make_printf k o (Acc_flush acc) rest + + | String_literal (str, rest) -> + make_printf k o (Acc_string_literal (acc, str)) rest + | Char_literal (chr, rest) -> + make_printf k o (Acc_char_literal (acc, chr)) rest + + | Format_arg (_, sub_fmtty, rest) -> + let ty = string_of_fmtty sub_fmtty in + (fun str -> + ignore str; + make_printf k o (Acc_data_string (acc, ty)) rest) + | Format_subst (_, fmtty, rest) -> + fun (Format (fmt, _)) -> make_printf k o acc + (concat_fmt (recast fmt fmtty) rest) + + | Scan_char_set (_, _, rest) -> + let new_acc = Acc_invalid_arg (acc, "Printf: bad conversion %[") in + fun _ -> make_printf k o new_acc rest + | Scan_get_counter (_, rest) -> + (* This case should be refused for Printf. *) + (* Accepted for backward compatibility. *) + (* Interpret %l, %n and %L as %u. *) + fun n -> + let new_acc = Acc_data_string (acc, format_int "%u" n) in + make_printf k o new_acc rest + | Ignored_param (ign, rest) -> + make_ignored_param k o acc ign rest + + | Formatting_lit (fmting_lit, rest) -> + make_printf k o (Acc_formatting_lit (acc, fmting_lit)) rest + | Formatting_gen (Open_tag (Format (fmt', _)), rest) -> + let k' koc kacc = + make_printf k koc (Acc_formatting_gen (acc, Acc_open_tag kacc)) rest in + make_printf k' o End_of_acc fmt' + | Formatting_gen (Open_box (Format (fmt', _)), rest) -> + let k' koc kacc = + make_printf k koc (Acc_formatting_gen (acc, Acc_open_box kacc)) rest in + make_printf k' o End_of_acc fmt' + + | End_of_format -> + k o acc + +(* Delay the error (Invalid_argument "Printf: bad conversion %_"). *) +(* Generate functions to take remaining arguments (after the "%_"). *) +and make_ignored_param : type x y a b c d e f . + (b -> (b, c) acc -> f) -> b -> (b, c) acc -> + (a, b, c, d, y, x) ignored -> + (x, b, c, y, e, f) fmt -> a = +fun k o acc ign fmt -> match ign with + | Ignored_char -> make_invalid_arg k o acc fmt + | Ignored_caml_char -> make_invalid_arg k o acc fmt + | Ignored_string _ -> make_invalid_arg k o acc fmt + | Ignored_caml_string _ -> make_invalid_arg k o acc fmt + | Ignored_int (_, _) -> make_invalid_arg k o acc fmt + | Ignored_int32 (_, _) -> make_invalid_arg k o acc fmt + | Ignored_nativeint (_, _) -> make_invalid_arg k o acc fmt + | Ignored_int64 (_, _) -> make_invalid_arg k o acc fmt + | Ignored_float (_, _) -> make_invalid_arg k o acc fmt + | Ignored_bool -> make_invalid_arg k o acc fmt + | Ignored_format_arg _ -> make_invalid_arg k o acc fmt + | Ignored_format_subst (_, fmtty) -> make_from_fmtty k o acc fmtty fmt + | Ignored_reader -> assert false + | Ignored_scan_char_set _ -> make_invalid_arg k o acc fmt + | Ignored_scan_get_counter _ -> make_invalid_arg k o acc fmt + + +(* Special case of printf "%_(". *) +and make_from_fmtty : type x y a b c d e f . + (b -> (b, c) acc -> f) -> b -> (b, c) acc -> + (a, b, c, d, y, x) fmtty -> + (x, b, c, y, e, f) fmt -> a = +fun k o acc fmtty fmt -> match fmtty with + | Char_ty rest -> fun _ -> make_from_fmtty k o acc rest fmt + | String_ty rest -> fun _ -> make_from_fmtty k o acc rest fmt + | Int_ty rest -> fun _ -> make_from_fmtty k o acc rest fmt + | Int32_ty rest -> fun _ -> make_from_fmtty k o acc rest fmt + | Nativeint_ty rest -> fun _ -> make_from_fmtty k o acc rest fmt + | Int64_ty rest -> fun _ -> make_from_fmtty k o acc rest fmt + | Float_ty rest -> fun _ -> make_from_fmtty k o acc rest fmt + | Bool_ty rest -> fun _ -> make_from_fmtty k o acc rest fmt + | Alpha_ty rest -> fun _ _ -> make_from_fmtty k o acc rest fmt + | Theta_ty rest -> fun _ -> make_from_fmtty k o acc rest fmt + | Reader_ty _ -> assert false + | Ignored_reader_ty _ -> assert false + | Format_arg_ty (_, rest) -> fun _ -> make_from_fmtty k o acc rest fmt + | End_of_fmtty -> make_invalid_arg k o acc fmt + | Format_subst_ty (ty1, ty2, rest) -> + let ty = trans (symm ty1) ty2 in + fun _ -> make_from_fmtty k o acc (concat_fmtty ty rest) fmt + +(* Insert an Acc_invalid_arg in the accumulator and continue to generate + closures to get the remaining arguments. *) +and make_invalid_arg : type a b c d e f . + (b -> (b, c) acc -> f) -> b -> (b, c) acc -> + (a, b, c, d, e, f) fmt -> a = +fun k o acc fmt -> + make_printf k o (Acc_invalid_arg (acc, "Printf: bad conversion %_")) fmt + +(* Fix padding, take it as an extra integer argument if needed. *) +and make_string_padding : type x z a b c d e f . + (b -> (b, c) acc -> f) -> b -> (b, c) acc -> + (a, b, c, d, e, f) fmt -> + (x, z -> a) padding -> (z -> string) -> x = + fun k o acc fmt pad trans -> match pad with + | No_padding -> + fun x -> + let new_acc = Acc_data_string (acc, trans x) in + make_printf k o new_acc fmt + | Lit_padding (padty, width) -> + fun x -> + let new_acc = Acc_data_string (acc, fix_padding padty width (trans x)) in + make_printf k o new_acc fmt + | Arg_padding padty -> + fun w x -> + let new_acc = Acc_data_string (acc, fix_padding padty w (trans x)) in + make_printf k o new_acc fmt + +(* Fix padding and precision for int, int32, nativeint or int64. *) +(* Take one or two extra integer arguments if needed. *) +and make_int_padding_precision : type x y z a b c d e f . + (b -> (b, c) acc -> f) -> b -> (b, c) acc -> + (a, b, c, d, e, f) fmt -> + (x, y) padding -> (y, z -> a) precision -> (int_conv -> z -> string) -> + int_conv -> x = + fun k o acc fmt pad prec trans iconv -> match pad, prec with + | No_padding, No_precision -> + fun x -> + let str = trans iconv x in + make_printf k o (Acc_data_string (acc, str)) fmt + | No_padding, Lit_precision p -> + fun x -> + let str = fix_int_precision p (trans iconv x) in + make_printf k o (Acc_data_string (acc, str)) fmt + | No_padding, Arg_precision -> + fun p x -> + let str = fix_int_precision p (trans iconv x) in + make_printf k o (Acc_data_string (acc, str)) fmt + | Lit_padding (padty, w), No_precision -> + fun x -> + let str = fix_padding padty w (trans iconv x) in + make_printf k o (Acc_data_string (acc, str)) fmt + | Lit_padding (padty, w), Lit_precision p -> + fun x -> + let str = fix_padding padty w (fix_int_precision p (trans iconv x)) in + make_printf k o (Acc_data_string (acc, str)) fmt + | Lit_padding (padty, w), Arg_precision -> + fun p x -> + let str = fix_padding padty w (fix_int_precision p (trans iconv x)) in + make_printf k o (Acc_data_string (acc, str)) fmt + | Arg_padding padty, No_precision -> + fun w x -> + let str = fix_padding padty w (trans iconv x) in + make_printf k o (Acc_data_string (acc, str)) fmt + | Arg_padding padty, Lit_precision p -> + fun w x -> + let str = fix_padding padty w (fix_int_precision p (trans iconv x)) in + make_printf k o (Acc_data_string (acc, str)) fmt + | Arg_padding padty, Arg_precision -> + fun w p x -> + let str = fix_padding padty w (fix_int_precision p (trans iconv x)) in + make_printf k o (Acc_data_string (acc, str)) fmt + +(* Convert a float, fix padding and precision if needed. *) +(* Take the float argument and one or two extra integer arguments if needed. *) +and make_float_padding_precision : type x y a b c d e f . + (b -> (b, c) acc -> f) -> b -> (b, c) acc -> + (a, b, c, d, e, f) fmt -> + (x, y) padding -> (y, float -> a) precision -> float_conv -> x = + fun k o acc fmt pad prec fconv -> match pad, prec with + | No_padding, No_precision -> + fun x -> + let str = convert_float fconv default_float_precision x in + make_printf k o (Acc_data_string (acc, str)) fmt + | No_padding, Lit_precision p -> + fun x -> + let str = convert_float fconv p x in + make_printf k o (Acc_data_string (acc, str)) fmt + | No_padding, Arg_precision -> + fun p x -> + let str = convert_float fconv p x in + make_printf k o (Acc_data_string (acc, str)) fmt + | Lit_padding (padty, w), No_precision -> + fun x -> + let str = convert_float fconv default_float_precision x in + let str' = fix_padding padty w str in + make_printf k o (Acc_data_string (acc, str')) fmt + | Lit_padding (padty, w), Lit_precision p -> + fun x -> + let str = fix_padding padty w (convert_float fconv p x) in + make_printf k o (Acc_data_string (acc, str)) fmt + | Lit_padding (padty, w), Arg_precision -> + fun p x -> + let str = fix_padding padty w (convert_float fconv p x) in + make_printf k o (Acc_data_string (acc, str)) fmt + | Arg_padding padty, No_precision -> + fun w x -> + let str = convert_float fconv default_float_precision x in + let str' = fix_padding padty w str in + make_printf k o (Acc_data_string (acc, str')) fmt + | Arg_padding padty, Lit_precision p -> + fun w x -> + let str = fix_padding padty w (convert_float fconv p x) in + make_printf k o (Acc_data_string (acc, str)) fmt + | Arg_padding padty, Arg_precision -> + fun w p x -> + let str = fix_padding padty w (convert_float fconv p x) in + make_printf k o (Acc_data_string (acc, str)) fmt + +(******************************************************************************) + (* Continuations for make_printf *) + +(* Recursively output an "accumulator" containing a reversed list of + printing entities (string, char, flus, ...) in an output_stream. *) +(* Used as a continuation of make_printf. *) +let rec output_acc o acc = match acc with + | Acc_formatting_lit (p, fmting_lit) -> + let s = string_of_formatting_lit fmting_lit in + output_acc o p; output_string o s; + | Acc_formatting_gen (p, Acc_open_tag acc') -> + output_acc o p; output_string o "@{"; output_acc o acc'; + | Acc_formatting_gen (p, Acc_open_box acc') -> + output_acc o p; output_string o "@["; output_acc o acc'; + | Acc_string_literal (p, s) + | Acc_data_string (p, s) -> output_acc o p; output_string o s + | Acc_char_literal (p, c) + | Acc_data_char (p, c) -> output_acc o p; output_char o c + | Acc_delay (p, f) -> output_acc o p; f o + | Acc_flush p -> output_acc o p; flush o + | Acc_invalid_arg (p, msg) -> output_acc o p; invalid_arg msg; + | End_of_acc -> () + +(* Recursively output an "accumulator" containing a reversed list of + printing entities (string, char, flus, ...) in a buffer. *) +(* Used as a continuation of make_printf. *) +let rec bufput_acc b acc = match acc with + | Acc_formatting_lit (p, fmting_lit) -> + let s = string_of_formatting_lit fmting_lit in + bufput_acc b p; Buffer.add_string b s; + | Acc_formatting_gen (p, Acc_open_tag acc') -> + bufput_acc b p; Buffer.add_string b "@{"; bufput_acc b acc'; + | Acc_formatting_gen (p, Acc_open_box acc') -> + bufput_acc b p; Buffer.add_string b "@["; bufput_acc b acc'; + | Acc_string_literal (p, s) + | Acc_data_string (p, s) -> bufput_acc b p; Buffer.add_string b s + | Acc_char_literal (p, c) + | Acc_data_char (p, c) -> bufput_acc b p; Buffer.add_char b c + | Acc_delay (p, f) -> bufput_acc b p; f b + | Acc_flush p -> bufput_acc b p; + | Acc_invalid_arg (p, msg) -> bufput_acc b p; invalid_arg msg; + | End_of_acc -> () + +(* Recursively output an "accumulator" containing a reversed list of + printing entities (string, char, flus, ...) in a buffer. *) +(* Differ from bufput_acc by the interpretation of %a and %t. *) +(* Used as a continuation of make_printf. *) +let rec strput_acc b acc = match acc with + | Acc_formatting_lit (p, fmting_lit) -> + let s = string_of_formatting_lit fmting_lit in + strput_acc b p; Buffer.add_string b s; + | Acc_formatting_gen (p, Acc_open_tag acc') -> + strput_acc b p; Buffer.add_string b "@{"; strput_acc b acc'; + | Acc_formatting_gen (p, Acc_open_box acc') -> + strput_acc b p; Buffer.add_string b "@["; strput_acc b acc'; + | Acc_string_literal (p, s) + | Acc_data_string (p, s) -> strput_acc b p; Buffer.add_string b s + | Acc_char_literal (p, c) + | Acc_data_char (p, c) -> strput_acc b p; Buffer.add_char b c + | Acc_delay (p, f) -> strput_acc b p; Buffer.add_string b (f ()) + | Acc_flush p -> strput_acc b p; + | Acc_invalid_arg (p, msg) -> strput_acc b p; invalid_arg msg; + | End_of_acc -> () + +(******************************************************************************) + (* Error managment *) + +(* Raise a Failure with a pretty-printed error message. *) +let failwith_message (Format (fmt, _)) = + let buf = Buffer.create 256 in + let k () acc = strput_acc buf acc; failwith (Buffer.contents buf) in + make_printf k () End_of_acc fmt + +(******************************************************************************) + (* Formatting tools *) + +(* Convert a string to an open block description (indent, block_type) *) +let open_box_of_string str = + if str = "" then (0, Pp_box) else + let len = String.length str in + let invalid_box () = failwith_message "invalid box description %S" str in + let rec parse_spaces i = + if i = len then i else + match str.[i] with + | ' ' | '\t' -> parse_spaces (i + 1) + | _ -> i + and parse_lword i j = + if j = len then j else + match str.[j] with + | 'a' .. 'z' -> parse_lword i (j + 1) + | _ -> j + and parse_int i j = + if j = len then j else + match str.[j] with + | '0' .. '9' | '-' -> parse_int i (j + 1) + | _ -> j in + let wstart = parse_spaces 0 in + let wend = parse_lword wstart wstart in + let box_name = String.sub str wstart (wend - wstart) in + let nstart = parse_spaces wend in + let nend = parse_int nstart nstart in + let indent = + if nstart = nend then 0 else + try int_of_string (String.sub str nstart (nend - nstart)) + with Failure _ -> invalid_box () in + let exp_end = parse_spaces nend in + let () = if exp_end <> len then invalid_box () in + let box_type = match box_name with + | "" | "b" -> Pp_box + | "h" -> Pp_hbox + | "v" -> Pp_vbox + | "hv" -> Pp_hvbox + | "hov" -> Pp_hovbox + | _ -> invalid_box () in + (indent, box_type) + +(******************************************************************************) + (* Parsing tools *) + +(* Create a padding_fmt_ebb from a padding and a format. *) +(* Copy the padding to disjoin the type parameters of argument and result. *) +let make_padding_fmt_ebb : type x y . + (x, y) padding -> (_, _, _, _, _, _) fmt -> + (_, _, _, _, _) padding_fmt_ebb = +fun pad fmt -> match pad with + | No_padding -> Padding_fmt_EBB (No_padding, fmt) + | Lit_padding (s, w) -> Padding_fmt_EBB (Lit_padding (s, w), fmt) + | Arg_padding s -> Padding_fmt_EBB (Arg_padding s, fmt) + +(* Create a precision_fmt_ebb from a precision and a format. *) +(* Copy the precision to disjoin the type parameters of argument and result. *) +let make_precision_fmt_ebb : type x y . + (x, y) precision -> (_, _, _, _, _, _) fmt -> + (_, _, _, _, _) precision_fmt_ebb = +fun prec fmt -> match prec with + | No_precision -> Precision_fmt_EBB (No_precision, fmt) + | Lit_precision p -> Precision_fmt_EBB (Lit_precision p, fmt) + | Arg_precision -> Precision_fmt_EBB (Arg_precision, fmt) + +(* Create a padprec_fmt_ebb forma a padding, a precision and a format. *) +(* Copy the padding and the precision to disjoin type parameters of arguments + and result. *) +let make_padprec_fmt_ebb : type x y z t . + (x, y) padding -> (z, t) precision -> + (_, _, _, _, _, _) fmt -> + (_, _, _, _, _) padprec_fmt_ebb = +fun pad prec fmt -> + let Precision_fmt_EBB (prec, fmt') = make_precision_fmt_ebb prec fmt in + match pad with + | No_padding -> Padprec_fmt_EBB (No_padding, prec, fmt') + | Lit_padding (s, w) -> Padprec_fmt_EBB (Lit_padding (s, w), prec, fmt') + | Arg_padding s -> Padprec_fmt_EBB (Arg_padding s, prec, fmt') + +(******************************************************************************) + (* Format parsing *) + +(* Parse a string representing a format and create a fmt_ebb. *) +(* Raise an Failure exception in case of invalid format. *) +let fmt_ebb_of_string ?legacy_behavior str = + (* Parameters naming convention: *) + (* - lit_start: start of the literal sequence. *) + (* - str_ind: current index in the string. *) + (* - end_ind: end of the current (sub-)format. *) + (* - pct_ind: index of the '%' in the current micro-format. *) + (* - zero: is the '0' flag defined in the current micro-format. *) + (* - minus: is the '-' flag defined in the current micro-format. *) + (* - plus: is the '+' flag defined in the current micro-format. *) + (* - sharp: is the '#' flag defined in the current micro-format. *) + (* - space: is the ' ' flag defined in the current micro-format. *) + (* - ign: is the '_' flag defined in the current micro-format. *) + (* - pad: padding of the current micro-format. *) + (* - prec: precision of the current micro-format. *) + (* - symb: char representing the conversion ('c', 's', 'd', ...). *) + (* - char_set: set of characters as bitmap (see scanf %[...]). *) + + let legacy_behavior = match legacy_behavior with + | Some flag -> flag + | None -> true + (** When this flag is enabled, the format parser tries to behave as + the <4.02 implementations, in particular it ignores most benine + nonsensical format. When the flag is disabled, it will reject any + format that is not accepted by the specification. + + A typical example would be "%+ d": specifying both '+' (if the + number is positive, pad with a '+' to get the same width as + negative numbres) and ' ' (if the number is positive, pad with + a space) does not make sense, but the legacy (< 4.02) + implementation was happy to just ignore the space. + *) + in + + (* Raise a Failure with a friendly error message. *) + (* Used when the end of the format (or the current sub-format) was encoutered + unexpectedly. *) + let unexpected_end_of_format end_ind = + failwith_message + "invalid format %S: at character number %d, unexpected end of format" + str end_ind; + + (* Raise Failure with a friendly error message about an option dependencie + problem. *) + and invalid_format_without str_ind c s = + failwith_message + "invalid format %S: at character number %d, '%c' without %s" + str str_ind c s + + (* Raise Failure with a friendly error message about an unexpected + character. *) + and expected_character str_ind expected read = + failwith_message + "invalid format %S: at character number %d, %s expected, read %C" + str str_ind expected read in + + (* Parse the string from beg_ind (included) to end_ind (excluded). *) + let rec parse : type e f . int -> int -> (_, _, e, f) fmt_ebb = + fun beg_ind end_ind -> parse_literal beg_ind beg_ind end_ind + + (* Read literal characters up to '%' or '@' special characters. *) + and parse_literal : type e f . int -> int -> int -> (_, _, e, f) fmt_ebb = + fun lit_start str_ind end_ind -> + if str_ind = end_ind then add_literal lit_start str_ind End_of_format else + match str.[str_ind] with + | '%' -> + let Fmt_EBB fmt_rest = parse_format str_ind end_ind in + add_literal lit_start str_ind fmt_rest + | '@' -> + let Fmt_EBB fmt_rest = parse_after_at (str_ind + 1) end_ind in + add_literal lit_start str_ind fmt_rest + | _ -> + parse_literal lit_start (str_ind + 1) end_ind + + (* Parse a format after '%' *) + and parse_format : type e f . int -> int -> (_, _, e, f) fmt_ebb = + fun pct_ind end_ind -> parse_ign pct_ind (pct_ind + 1) end_ind + + and parse_ign : type e f . int -> int -> int -> (_, _, e, f) fmt_ebb = + fun pct_ind str_ind end_ind -> + if str_ind = end_ind then unexpected_end_of_format end_ind; + match str.[str_ind] with + | '_' -> parse_flags pct_ind (str_ind+1) end_ind true + | _ -> parse_flags pct_ind str_ind end_ind false + + and parse_flags : type e f . int -> int -> int -> bool -> (_, _, e, f) fmt_ebb = + fun pct_ind str_ind end_ind ign -> + let zero = ref false and minus = ref false + and plus = ref false and space = ref false + and sharp = ref false in + let set_flag str_ind flag = + (* in legacy mode, duplicate flags are accepted *) + if !flag && not legacy_behavior then + failwith_message + "invalid format %S: at character number %d, duplicate flag %C" + str str_ind str.[str_ind]; + flag := true; + in + let rec read_flags str_ind = + if str_ind = end_ind then unexpected_end_of_format end_ind; + begin match str.[str_ind] with + | '0' -> set_flag str_ind zero; read_flags (str_ind + 1) + | '-' -> set_flag str_ind minus; read_flags (str_ind + 1) + | '+' -> set_flag str_ind plus; read_flags (str_ind + 1) + | '#' -> set_flag str_ind sharp; read_flags (str_ind + 1) + | ' ' -> set_flag str_ind space; read_flags (str_ind + 1) + | _ -> + parse_padding pct_ind str_ind end_ind + !zero !minus !plus !sharp !space ign + end + in + read_flags str_ind + + (* Try to read a digital or a '*' padding. *) + and parse_padding : type e f . + int -> int -> int -> bool -> bool -> bool -> bool -> bool -> bool -> + (_, _, e, f) fmt_ebb = + fun pct_ind str_ind end_ind zero minus plus sharp space ign -> + if str_ind = end_ind then unexpected_end_of_format end_ind; + let padty = match zero, minus with + | false, false -> Right + | false, true -> Left + | true, false -> Zeros + | true, true -> + if legacy_behavior then Left + else incompatible_flag pct_ind str_ind '-' "0" in + match str.[str_ind] with + | '0' .. '9' -> + let new_ind, width = parse_positive str_ind end_ind 0 in + parse_after_padding pct_ind new_ind end_ind plus sharp space ign + (Lit_padding (padty, width)) + | '*' -> + parse_after_padding pct_ind (str_ind + 1) end_ind plus sharp space ign + (Arg_padding padty) + | _ -> + if legacy_behavior then + parse_after_padding pct_ind str_ind end_ind plus sharp space ign + No_padding + else begin match padty with + | Left -> + invalid_format_without (str_ind - 1) '-' "padding" + | Zeros -> + invalid_format_without (str_ind - 1) '0' "padding" + | Right -> + parse_after_padding pct_ind str_ind end_ind plus sharp space ign + No_padding + end + + (* Is precision defined? *) + and parse_after_padding : type x e f . + int -> int -> int -> bool -> bool -> bool -> bool -> (x, _) padding -> + (_, _, e, f) fmt_ebb = + fun pct_ind str_ind end_ind plus sharp space ign pad -> + if str_ind = end_ind then unexpected_end_of_format end_ind; + match str.[str_ind] with + | '.' -> + parse_precision pct_ind (str_ind + 1) end_ind plus sharp space ign pad + | symb -> + parse_conversion pct_ind (str_ind + 1) end_ind plus sharp space ign pad + No_precision symb + + (* Read the digital or '*' precision. *) + and parse_precision : type x e f . + int -> int -> int -> bool -> bool -> bool -> bool -> (x, _) padding -> + (_, _, e, f) fmt_ebb = + fun pct_ind str_ind end_ind plus sharp space ign pad -> + if str_ind = end_ind then unexpected_end_of_format end_ind; + let parse_literal str_ind = + let new_ind, prec = parse_positive str_ind end_ind 0 in + if new_ind = end_ind then unexpected_end_of_format end_ind; + parse_conversion pct_ind (new_ind + 1) end_ind plus sharp space ign pad + (Lit_precision prec) str.[new_ind] in + match str.[str_ind] with + | '0' .. '9' -> parse_literal str_ind + | ('+' | '-') when legacy_behavior -> + (* Legacy mode would accept and ignore '+' or '-' before the + integer describing the desired precision; not that this + cannot happen for padding width, as '+' and '-' already have + a semantics there. + + That said, the idea (supported by this tweak) that width and + precision literals are "integer literals" in the OCaml sense is + still blatantly wrong, as 123_456 or 0xFF are rejected. *) + parse_literal (str_ind + 1) + | '*' -> + parse_after_precision pct_ind (str_ind + 1) end_ind plus sharp space ign + pad Arg_precision + | _ -> + if legacy_behavior then + (* note that legacy implementation did not ignore '.' without + a number (as it does for padding indications), but + interprets it as '.0' *) + parse_after_precision pct_ind str_ind end_ind plus sharp space ign pad (Lit_precision 0) else + invalid_format_without (str_ind - 1) '.' "precision" + + (* Try to read the conversion. *) + and parse_after_precision : type x z e f . + int -> int -> int -> bool -> bool -> bool -> bool -> (x, _) padding -> + (z, _) precision -> (_, _, e, f) fmt_ebb = + fun pct_ind str_ind end_ind plus sharp space ign pad prec -> + if str_ind = end_ind then unexpected_end_of_format end_ind; + parse_conversion pct_ind (str_ind + 1) end_ind plus sharp space ign pad prec + str.[str_ind] + + (* Case analysis on conversion. *) + and parse_conversion : type x y z t e f . + int -> int -> int -> bool -> bool -> bool -> bool -> (x, y) padding -> + (z, t) precision -> char -> (_, _, e, f) fmt_ebb = + fun pct_ind str_ind end_ind plus sharp space ign pad prec symb -> + (* Flags used to check option usages/compatibilities. *) + let plus_used = ref false and sharp_used = ref false + and space_used = ref false and ign_used = ref false + and pad_used = ref false and prec_used = ref false in + + (* Access to options, update flags. *) + let get_plus () = plus_used := true; plus + and get_sharp () = sharp_used := true; sharp + and get_space () = space_used := true; space + and get_ign () = ign_used := true; ign + and get_pad () = pad_used := true; pad + and get_prec () = prec_used := true; prec in + + (* Check that padty <> Zeros. *) + let check_no_0 symb (type a) (type b) (pad : (a,b) padding) = + match pad with + | No_padding -> pad + | Lit_padding ((Left | Right), _) -> pad + | Arg_padding (Left | Right) -> pad + | Lit_padding (Zeros, width) -> + if legacy_behavior then Lit_padding (Right, width) + else incompatible_flag pct_ind str_ind symb "0" + | Arg_padding Zeros -> + if legacy_behavior then Arg_padding Right + else incompatible_flag pct_ind str_ind symb "0" + in + + (* Get padding as a pad_option (see "%_", "%{", "%(" and "%["). + (no need for legacy mode tweaking, those were rejected by the + legacy parser as well) *) + let get_pad_opt c = match get_pad () with + | No_padding -> None + | Lit_padding (Right, width) -> Some width + | Lit_padding (Zeros, width) -> + if legacy_behavior then Some width + else incompatible_flag pct_ind str_ind c "'0'" + | Lit_padding (Left, width) -> + if legacy_behavior then Some width + else incompatible_flag pct_ind str_ind c "'-'" + | Arg_padding _ -> incompatible_flag pct_ind str_ind c "'*'" + in + + (* Get precision as a prec_option (see "%_f"). + (no need for legacy mode tweaking, those were rejected by the + legacy parser as well) *) + let get_prec_opt () = match get_prec () with + | No_precision -> None + | Lit_precision ndec -> Some ndec + | Arg_precision -> incompatible_flag pct_ind str_ind '_' "'*'" + in + + let fmt_result = match symb with + | ',' -> + parse str_ind end_ind + | 'c' -> + let Fmt_EBB fmt_rest = parse str_ind end_ind in + if get_ign () then Fmt_EBB (Ignored_param (Ignored_char, fmt_rest)) + else Fmt_EBB (Char fmt_rest) + | 'C' -> + let Fmt_EBB fmt_rest = parse str_ind end_ind in + if get_ign () then Fmt_EBB (Ignored_param (Ignored_caml_char,fmt_rest)) + else Fmt_EBB (Caml_char fmt_rest) + | 's' -> + let pad = check_no_0 symb (get_pad ()) in + let Fmt_EBB fmt_rest = parse str_ind end_ind in + if get_ign () then + let ignored = Ignored_string (get_pad_opt '_') in + Fmt_EBB (Ignored_param (ignored, fmt_rest)) + else + let Padding_fmt_EBB (pad', fmt_rest') = + make_padding_fmt_ebb pad fmt_rest in + Fmt_EBB (String (pad', fmt_rest')) + | 'S' -> + let pad = check_no_0 symb (get_pad ()) in + let Fmt_EBB fmt_rest = parse str_ind end_ind in + if get_ign () then + let ignored = Ignored_caml_string (get_pad_opt '_') in + Fmt_EBB (Ignored_param (ignored, fmt_rest)) + else + let Padding_fmt_EBB (pad', fmt_rest') = + make_padding_fmt_ebb pad fmt_rest in + Fmt_EBB (Caml_string (pad', fmt_rest')) + | 'd' | 'i' | 'x' | 'X' | 'o' | 'u' -> + let iconv = compute_int_conv pct_ind str_ind (get_plus ()) (get_sharp ()) + (get_space ()) symb in + let Fmt_EBB fmt_rest = parse str_ind end_ind in + if get_ign () then + let ignored = Ignored_int (iconv, get_pad_opt '_') in + Fmt_EBB (Ignored_param (ignored, fmt_rest)) + else + let Padprec_fmt_EBB (pad', prec', fmt_rest') = + make_padprec_fmt_ebb (get_pad ()) (get_prec ()) fmt_rest in + Fmt_EBB (Int (iconv, pad', prec', fmt_rest')) + | 'N' -> + let Fmt_EBB fmt_rest = parse str_ind end_ind in + let counter = Token_counter in + if get_ign () then + let ignored = Ignored_scan_get_counter counter in + Fmt_EBB (Ignored_param (ignored, fmt_rest)) + else + Fmt_EBB (Scan_get_counter (counter, fmt_rest)) + | 'l' | 'n' | 'L' when str_ind=end_ind || not (is_int_base str.[str_ind]) -> + let Fmt_EBB fmt_rest = parse str_ind end_ind in + let counter = counter_of_char symb in + if get_ign () then + let ignored = Ignored_scan_get_counter counter in + Fmt_EBB (Ignored_param (ignored, fmt_rest)) + else + Fmt_EBB (Scan_get_counter (counter, fmt_rest)) + | 'l' -> + let iconv = + compute_int_conv pct_ind (str_ind + 1) (get_plus ()) (get_sharp ()) + (get_space ()) str.[str_ind] in + let Fmt_EBB fmt_rest = parse (str_ind + 1) end_ind in + if get_ign () then + let ignored = Ignored_int32 (iconv, get_pad_opt '_') in + Fmt_EBB (Ignored_param (ignored, fmt_rest)) + else + let Padprec_fmt_EBB (pad', prec', fmt_rest') = + make_padprec_fmt_ebb (get_pad ()) (get_prec ()) fmt_rest in + Fmt_EBB (Int32 (iconv, pad', prec', fmt_rest')) + | 'n' -> + let iconv = + compute_int_conv pct_ind (str_ind + 1) (get_plus ()) + (get_sharp ()) (get_space ()) str.[str_ind] in + let Fmt_EBB fmt_rest = parse (str_ind + 1) end_ind in + if get_ign () then + let ignored = Ignored_nativeint (iconv, get_pad_opt '_') in + Fmt_EBB (Ignored_param (ignored, fmt_rest)) + else + let Padprec_fmt_EBB (pad', prec', fmt_rest') = + make_padprec_fmt_ebb (get_pad ()) (get_prec ()) fmt_rest in + Fmt_EBB (Nativeint (iconv, pad', prec', fmt_rest')) + | 'L' -> + let iconv = + compute_int_conv pct_ind (str_ind + 1) (get_plus ()) (get_sharp ()) + (get_space ()) str.[str_ind] in + let Fmt_EBB fmt_rest = parse (str_ind + 1) end_ind in + if get_ign () then + let ignored = Ignored_int64 (iconv, get_pad_opt '_') in + Fmt_EBB (Ignored_param (ignored, fmt_rest)) + else + let Padprec_fmt_EBB (pad', prec', fmt_rest') = + make_padprec_fmt_ebb (get_pad ()) (get_prec ()) fmt_rest in + Fmt_EBB (Int64 (iconv, pad', prec', fmt_rest')) + | 'f' | 'e' | 'E' | 'g' | 'G' | 'F' -> + let fconv = compute_float_conv pct_ind str_ind (get_plus ()) + (get_space ()) symb in + let Fmt_EBB fmt_rest = parse str_ind end_ind in + if get_ign () then + let ignored = Ignored_float (get_pad_opt '_', get_prec_opt ()) in + Fmt_EBB (Ignored_param (ignored, fmt_rest)) + else + let Padprec_fmt_EBB (pad', prec', fmt_rest') = + make_padprec_fmt_ebb (get_pad ()) (get_prec ()) fmt_rest in + Fmt_EBB (Float (fconv, pad', prec', fmt_rest')) + | 'b' | 'B' -> + let Fmt_EBB fmt_rest = parse str_ind end_ind in + if get_ign () then Fmt_EBB (Ignored_param (Ignored_bool, fmt_rest)) + else Fmt_EBB (Bool fmt_rest) + | 'a' -> + let Fmt_EBB fmt_rest = parse str_ind end_ind in + Fmt_EBB (Alpha fmt_rest) + | 't' -> + let Fmt_EBB fmt_rest = parse str_ind end_ind in + Fmt_EBB (Theta fmt_rest) + | 'r' -> + let Fmt_EBB fmt_rest = parse str_ind end_ind in + if get_ign () then Fmt_EBB (Ignored_param (Ignored_reader, fmt_rest)) + else Fmt_EBB (Reader fmt_rest) + | '!' -> + let Fmt_EBB fmt_rest = parse str_ind end_ind in + Fmt_EBB (Flush fmt_rest) + | ('%' | '@') as c -> + let Fmt_EBB fmt_rest = parse str_ind end_ind in + Fmt_EBB (Char_literal (c, fmt_rest)) + | '{' -> + let sub_end = search_subformat_end str_ind end_ind '}' in + let Fmt_EBB sub_fmt = parse str_ind sub_end in + let Fmt_EBB fmt_rest = parse (sub_end + 2) end_ind in + let sub_fmtty = fmtty_of_fmt sub_fmt in + if get_ign () then + let ignored = Ignored_format_arg (get_pad_opt '_', sub_fmtty) in + Fmt_EBB (Ignored_param (ignored, fmt_rest)) + else + Fmt_EBB (Format_arg (get_pad_opt '{', sub_fmtty, fmt_rest)) + | '(' -> + let sub_end = search_subformat_end str_ind end_ind ')' in + let Fmt_EBB fmt_rest = parse (sub_end + 2) end_ind in + let Fmt_EBB sub_fmt = parse str_ind sub_end in + let sub_fmtty = fmtty_of_fmt sub_fmt in + if get_ign () then + let ignored = Ignored_format_subst (get_pad_opt '_', sub_fmtty) in + Fmt_EBB (Ignored_param (ignored, fmt_rest)) + else + Fmt_EBB (Format_subst (get_pad_opt '(', sub_fmtty, fmt_rest)) + | '[' -> + let next_ind, char_set = parse_char_set str_ind end_ind in + let Fmt_EBB fmt_rest = parse next_ind end_ind in + if get_ign () then + let ignored = Ignored_scan_char_set (get_pad_opt '_', char_set) in + Fmt_EBB (Ignored_param (ignored, fmt_rest)) + else + Fmt_EBB (Scan_char_set (get_pad_opt '[', char_set, fmt_rest)) + | '-' | '+' | '#' | ' ' | '_' -> + failwith_message + "invalid format %S: at character number %d, \ + flag %C is only allowed after the '%%', before padding and precision" + str pct_ind symb + | _ -> + failwith_message + "invalid format %S: at character number %d, \ + invalid conversion \"%%%c\"" str (str_ind - 1) symb + in + (* Check for unused options, and reject them as incompatible. + + Such checks need to be disabled in legacy mode, as the legacy + parser silently ignored incompatible flags. *) + if not legacy_behavior then begin + if not !plus_used && plus then + incompatible_flag pct_ind str_ind symb "'+'"; + if not !sharp_used && sharp then + incompatible_flag pct_ind str_ind symb "'#'"; + if not !space_used && space then + incompatible_flag pct_ind str_ind symb "' '"; + if not !pad_used && Padding_EBB pad <> Padding_EBB No_padding then + incompatible_flag pct_ind str_ind symb "`padding'"; + if not !prec_used && Precision_EBB prec <> Precision_EBB No_precision then + incompatible_flag pct_ind str_ind (if ign then '_' else symb) + "`precision'"; + if ign && plus then incompatible_flag pct_ind str_ind '_' "'+'"; + end; + (* this last test must not be disabled in legacy mode, + as ignoring it would typically result in a different typing + than what the legacy parser used *) + if not !ign_used && ign then + begin match symb with + (* argument-less formats can safely be ignored in legacy mode *) + | ('@' | '%' | '!' | ',') when legacy_behavior -> () + | _ -> + incompatible_flag pct_ind str_ind symb "'_'" + end; + fmt_result + + (* Parse formatting informations (after '@'). *) + and parse_after_at : type e f . int -> int -> (_, _, e, f) fmt_ebb = + fun str_ind end_ind -> + if str_ind = end_ind then Fmt_EBB (Char_literal ('@', End_of_format)) + else + match str.[str_ind] with + | '[' -> + parse_tag false (str_ind + 1) end_ind + | ']' -> + let Fmt_EBB fmt_rest = parse (str_ind + 1) end_ind in + Fmt_EBB (Formatting_lit (Close_box, fmt_rest)) + | '{' -> + parse_tag true (str_ind + 1) end_ind + | '}' -> + let Fmt_EBB fmt_rest = parse (str_ind + 1) end_ind in + Fmt_EBB (Formatting_lit (Close_tag, fmt_rest)) + | ',' -> + let Fmt_EBB fmt_rest = parse (str_ind + 1) end_ind in + Fmt_EBB (Formatting_lit (Break ("@,", 0, 0), fmt_rest)) + | ' ' -> + let Fmt_EBB fmt_rest = parse (str_ind + 1) end_ind in + Fmt_EBB (Formatting_lit (Break ("@ ", 1, 0), fmt_rest)) + | ';' -> + parse_good_break (str_ind + 1) end_ind + | '?' -> + let Fmt_EBB fmt_rest = parse (str_ind + 1) end_ind in + Fmt_EBB (Formatting_lit (FFlush, fmt_rest)) + | '\n' -> + let Fmt_EBB fmt_rest = parse (str_ind + 1) end_ind in + Fmt_EBB (Formatting_lit (Force_newline, fmt_rest)) + | '.' -> + let Fmt_EBB fmt_rest = parse (str_ind + 1) end_ind in + Fmt_EBB (Formatting_lit (Flush_newline, fmt_rest)) + | '<' -> + parse_magic_size (str_ind + 1) end_ind + | '@' -> + let Fmt_EBB fmt_rest = parse (str_ind + 1) end_ind in + Fmt_EBB (Formatting_lit (Escaped_at, fmt_rest)) + | '%' when str_ind + 1 < end_ind && str.[str_ind + 1] = '%' -> + let Fmt_EBB fmt_rest = parse (str_ind + 2) end_ind in + Fmt_EBB (Formatting_lit (Escaped_percent, fmt_rest)) + | '%' -> + let Fmt_EBB fmt_rest = parse str_ind end_ind in + Fmt_EBB (Char_literal ('@', fmt_rest)) + | c -> + let Fmt_EBB fmt_rest = parse (str_ind + 1) end_ind in + Fmt_EBB (Formatting_lit (Scan_indic c, fmt_rest)) + + and check_open_box : type a b c d e f . (a, b, c, d, e, f) fmt -> unit = + fun fmt -> match fmt with + | String_literal (str, End_of_format) -> ( + try ignore (open_box_of_string str) with Failure _ -> + ((* Emit warning: invalid open box *)) + ) + | _ -> () + + (* Try to read the optionnal <name> after "@{" or "@[". *) + and parse_tag : type e f . bool -> int -> int -> (_, _, e, f) fmt_ebb = + fun is_open_tag str_ind end_ind -> + try + if str_ind = end_ind then raise Not_found; + match str.[str_ind] with + | '<' -> + let ind = String.index_from str (str_ind + 1) '>' in + if ind >= end_ind then raise Not_found; + let sub_str = String.sub str str_ind (ind - str_ind + 1) in + let Fmt_EBB fmt_rest = parse (ind + 1) end_ind in + let Fmt_EBB sub_fmt = parse str_ind (ind + 1) in + let sub_format = Format (sub_fmt, sub_str) in + let formatting = if is_open_tag then Open_tag sub_format else ( + check_open_box sub_fmt; + Open_box sub_format) in + Fmt_EBB (Formatting_gen (formatting, fmt_rest)) + | _ -> + raise Not_found + with Not_found -> + let Fmt_EBB fmt_rest = parse str_ind end_ind in + let sub_format = Format (End_of_format, "") in + let formatting = + if is_open_tag then Open_tag sub_format else Open_box sub_format in + Fmt_EBB (Formatting_gen (formatting, fmt_rest)) + + (* Try to read the optionnal <width offset> after "@;". *) + and parse_good_break : type e f . int -> int -> (_, _, e, f) fmt_ebb = + fun str_ind end_ind -> + let next_ind, formatting_lit = + try + if str_ind = end_ind || str.[str_ind] <> '<' then raise Not_found; + let str_ind_1 = parse_spaces (str_ind + 1) end_ind in + match str.[str_ind_1] with + | '0' .. '9' | '-' -> ( + let str_ind_2, width = parse_integer str_ind_1 end_ind in + let str_ind_3 = parse_spaces str_ind_2 end_ind in + match str.[str_ind_3] with + | '>' -> + let s = String.sub str (str_ind-2) (str_ind_3-str_ind+3) in + str_ind_3 + 1, Break (s, width, 0) + | '0' .. '9' | '-' -> + let str_ind_4, offset = parse_integer str_ind_3 end_ind in + let str_ind_5 = parse_spaces str_ind_4 end_ind in + if str.[str_ind_5] <> '>' then raise Not_found; + let s = String.sub str (str_ind-2) (str_ind_5-str_ind+3) in + str_ind_5 + 1, Break (s, width, offset) + | _ -> raise Not_found + ) + | _ -> raise Not_found + with Not_found | Failure _ -> + str_ind, Break ("@;", 1, 0) + in + let Fmt_EBB fmt_rest = parse next_ind end_ind in + Fmt_EBB (Formatting_lit (formatting_lit, fmt_rest)) + + (* Parse the size in a <n>. *) + and parse_magic_size : type e f . int -> int -> (_, _, e, f) fmt_ebb = + fun str_ind end_ind -> + match + try + let str_ind_1 = parse_spaces str_ind end_ind in + match str.[str_ind_1] with + | '0' .. '9' | '-' -> + let str_ind_2, size = parse_integer str_ind_1 end_ind in + let str_ind_3 = parse_spaces str_ind_2 end_ind in + if str.[str_ind_3] <> '>' then raise Not_found; + let s = String.sub str (str_ind - 2) (str_ind_3 - str_ind + 3) in + Some (str_ind_3 + 1, Magic_size (s, size)) + | _ -> None + with Not_found | Failure _ -> + None + with + | Some (next_ind, formatting_lit) -> + let Fmt_EBB fmt_rest = parse next_ind end_ind in + Fmt_EBB (Formatting_lit (formatting_lit, fmt_rest)) + | None -> + let Fmt_EBB fmt_rest = parse str_ind end_ind in + Fmt_EBB (Formatting_lit (Scan_indic '<', fmt_rest)) + + (* Parse and construct a char set. *) + and parse_char_set str_ind end_ind = + if str_ind = end_ind then unexpected_end_of_format end_ind; + + let char_set = create_char_set () in + let add_char c = + add_in_char_set char_set c; + in + let add_range c c' = + for i = int_of_char c to int_of_char c' do + add_in_char_set char_set (char_of_int i); + done; + in + + let fail_single_percent str_ind = + failwith_message + "invalid format %S: '%%' alone is not accepted in character sets, \ + use %%%% instead at position %d." str str_ind; + in + + (* Parse the first character of a char set. *) + let rec parse_char_set_start str_ind end_ind = + if str_ind = end_ind then unexpected_end_of_format end_ind; + let c = str.[str_ind] in + parse_char_set_after_char (str_ind + 1) end_ind c; + + (* Parse the content of a char set until the first ']'. *) + and parse_char_set_content str_ind end_ind = + if str_ind = end_ind then unexpected_end_of_format end_ind; + match str.[str_ind] with + | ']' -> + str_ind + 1 + | '-' -> + add_char '-'; + parse_char_set_content (str_ind + 1) end_ind; + | c -> + parse_char_set_after_char (str_ind + 1) end_ind c; + + (* Test for range in char set. *) + and parse_char_set_after_char str_ind end_ind c = + if str_ind = end_ind then unexpected_end_of_format end_ind; + match str.[str_ind] with + | ']' -> + add_char c; + str_ind + 1 + | '-' -> + parse_char_set_after_minus (str_ind + 1) end_ind c + | ('%' | '@') as c' when c = '%' -> + add_char c'; + parse_char_set_content (str_ind + 1) end_ind + | c' -> + if c = '%' then fail_single_percent str_ind; + (* note that '@' alone is accepted, as done by the legacy implementation; + the documentation specifically requires %@ so we could warn on that *) + add_char c; + parse_char_set_after_char (str_ind + 1) end_ind c' + + (* Manage range in char set (except if the '-' the last char before ']') *) + and parse_char_set_after_minus str_ind end_ind c = + if str_ind = end_ind then unexpected_end_of_format end_ind; + match str.[str_ind] with + | ']' -> + add_char c; + add_char '-'; + str_ind + 1 + | '%' -> + if str_ind + 1 = end_ind then unexpected_end_of_format end_ind; + begin match str.[str_ind + 1] with + | ('%' | '@') as c' -> + add_range c c'; + parse_char_set_content (str_ind + 2) end_ind + | _ -> fail_single_percent str_ind + end + | c' -> + add_range c c'; + parse_char_set_content (str_ind + 1) end_ind + in + let str_ind, reverse = + if str_ind = end_ind then unexpected_end_of_format end_ind; + match str.[str_ind] with + | '^' -> str_ind + 1, true + | _ -> str_ind, false in + let next_ind = parse_char_set_start str_ind end_ind in + let char_set = freeze_char_set char_set in + next_ind, (if reverse then rev_char_set char_set else char_set) + + (* Consume all next spaces, raise an Failure if end_ind is reached. *) + and parse_spaces str_ind end_ind = + if str_ind = end_ind then unexpected_end_of_format end_ind; + if str.[str_ind] = ' ' then parse_spaces (str_ind + 1) end_ind else str_ind + + (* Read a positive integer from the string, raise a Failure if end_ind is + reached. *) + and parse_positive str_ind end_ind acc = + if str_ind = end_ind then unexpected_end_of_format end_ind; + match str.[str_ind] with + | '0' .. '9' as c -> + let new_acc = acc * 10 + (int_of_char c - int_of_char '0') in + if new_acc > Sys.max_string_length then + failwith_message + "invalid format %S: integer %d is greater than the limit %d" + str new_acc Sys.max_string_length + else + parse_positive (str_ind + 1) end_ind new_acc + | _ -> str_ind, acc + + (* Read a positive or negative integer from the string, raise a Failure + if end_ind is reached. *) + and parse_integer str_ind end_ind = + if str_ind = end_ind then unexpected_end_of_format end_ind; + match str.[str_ind] with + | '0' .. '9' -> parse_positive str_ind end_ind 0 + | '-' -> ( + if str_ind + 1 = end_ind then unexpected_end_of_format end_ind; + match str.[str_ind + 1] with + | '0' .. '9' -> + let next_ind, n = parse_positive (str_ind + 1) end_ind 0 in + next_ind, -n + | c -> + expected_character (str_ind + 1) "digit" c + ) + | _ -> assert false + + (* Add a literal to a format from a literal character sub-sequence. *) + and add_literal : type a d e f . + int -> int -> (a, _, _, d, e, f) fmt -> + (_, _, e, f) fmt_ebb = + fun lit_start str_ind fmt -> match str_ind - lit_start with + | 0 -> Fmt_EBB fmt + | 1 -> Fmt_EBB (Char_literal (str.[lit_start], fmt)) + | size -> Fmt_EBB (String_literal (String.sub str lit_start size, fmt)) + + (* Search the end of the current sub-format + (i.e. the corresponding "%}" or "%)") *) + and search_subformat_end str_ind end_ind c = + if str_ind = end_ind then + failwith_message + "invalid format %S: unclosed sub-format, \ + expected \"%%%c\" at character number %d" str c end_ind; + match str.[str_ind] with + | '%' -> + if str_ind + 1 = end_ind then unexpected_end_of_format end_ind; + if str.[str_ind + 1] = c then (* End of format found *) str_ind else + begin match str.[str_ind + 1] with + | '_' -> + (* Search for "%_(" or "%_{". *) + if str_ind + 2 = end_ind then unexpected_end_of_format end_ind; + begin match str.[str_ind + 2] with + | '{' -> + let sub_end = search_subformat_end (str_ind + 3) end_ind '}' in + search_subformat_end (sub_end + 2) end_ind c + | '(' -> + let sub_end = search_subformat_end (str_ind + 3) end_ind ')' in + search_subformat_end (sub_end + 2) end_ind c + | _ -> search_subformat_end (str_ind + 3) end_ind c + end + | '{' -> + (* %{...%} sub-format found. *) + let sub_end = search_subformat_end (str_ind + 2) end_ind '}' in + search_subformat_end (sub_end + 2) end_ind c + | '(' -> + (* %(...%) sub-format found. *) + let sub_end = search_subformat_end (str_ind + 2) end_ind ')' in + search_subformat_end (sub_end + 2) end_ind c + | '}' -> + (* Error: %(...%}. *) + expected_character (str_ind + 1) "character ')'" '}'; + | ')' -> + (* Error: %{...%). *) + expected_character (str_ind + 1) "character '}'" ')'; + | _ -> + search_subformat_end (str_ind + 2) end_ind c + end + | _ -> search_subformat_end (str_ind + 1) end_ind c + + (* Check if symb is a valid int conversion after "%l", "%n" or "%L" *) + and is_int_base symb = match symb with + | 'd' | 'i' | 'x' | 'X' | 'o' | 'u' -> true + | _ -> false + + (* Convert a char (l, n or L) to its associated counter. *) + and counter_of_char symb = match symb with + | 'l' -> Line_counter | 'n' -> Char_counter + | 'L' -> Token_counter | _ -> assert false + + (* Convert (plus, symb) to its associated int_conv. *) + and compute_int_conv pct_ind str_ind plus sharp space symb = + match plus, sharp, space, symb with + | false, false, false, 'd' -> Int_d | false, false, false, 'i' -> Int_i + | false, false, true, 'd' -> Int_sd | false, false, true, 'i' -> Int_si + | true, false, false, 'd' -> Int_pd | true, false, false, 'i' -> Int_pi + | false, false, false, 'x' -> Int_x | false, false, false, 'X' -> Int_X + | false, true, false, 'x' -> Int_Cx | false, true, false, 'X' -> Int_CX + | false, false, false, 'o' -> Int_o + | false, true, false, 'o' -> Int_Co + | false, false, false, 'u' -> Int_u + | _, true, _, 'x' when legacy_behavior -> Int_Cx + | _, true, _, 'X' when legacy_behavior -> Int_CX + | _, true, _, 'o' when legacy_behavior -> Int_Co + | _, true, _, _ -> + if legacy_behavior then (* ignore *) + compute_int_conv pct_ind str_ind plus false space symb + else incompatible_flag pct_ind str_ind symb "'#'" + | true, false, true, _ -> + if legacy_behavior then + (* plus and space: legacy implementation prefers plus *) + compute_int_conv pct_ind str_ind plus sharp false symb + else incompatible_flag pct_ind str_ind ' ' "'+'" + | false, false, true, _ -> + if legacy_behavior then (* ignore *) + compute_int_conv pct_ind str_ind plus sharp false symb + else incompatible_flag pct_ind str_ind symb "' '" + | true, false, false, _ -> + if legacy_behavior then (* ignore *) + compute_int_conv pct_ind str_ind false sharp space symb + else incompatible_flag pct_ind str_ind symb "'+'" + | false, false, false, _ -> assert false + + (* Convert (plus, symb) to its associated float_conv. *) + and compute_float_conv pct_ind str_ind plus space symb = + match plus, space, symb with + | false, false, 'f' -> Float_f | false, false, 'e' -> Float_e + | false, true, 'f' -> Float_sf | false, true, 'e' -> Float_se + | true, false, 'f' -> Float_pf | true, false, 'e' -> Float_pe + | false, false, 'E' -> Float_E | false, false, 'g' -> Float_g + | false, true, 'E' -> Float_sE | false, true, 'g' -> Float_sg + | true, false, 'E' -> Float_pE | true, false, 'g' -> Float_pg + | false, false, 'G' -> Float_G + | false, true, 'G' -> Float_sG + | true, false, 'G' -> Float_pG + | false, false, 'F' -> Float_F + | true, true, _ -> + if legacy_behavior then + (* plus and space: legacy implementation prefers plus *) + compute_float_conv pct_ind str_ind plus false symb + else incompatible_flag pct_ind str_ind ' ' "'+'" + | false, true, _ -> + if legacy_behavior then (* ignore *) + compute_float_conv pct_ind str_ind plus false symb + else incompatible_flag pct_ind str_ind symb "' '" + | true, false, _ -> + if legacy_behavior then (* ignore *) + compute_float_conv pct_ind str_ind false space symb + else incompatible_flag pct_ind str_ind symb "'+'" + | false, false, _ -> assert false + + (* Raise a Failure with a friendly error message about incompatible options.*) + and incompatible_flag : type a . int -> int -> char -> string -> a = + fun pct_ind str_ind symb option -> + let subfmt = String.sub str pct_ind (str_ind - pct_ind) in + failwith_message + "invalid format %S: at character number %d, \ + %s is incompatible with '%c' in sub-format %S" + str pct_ind option symb subfmt; + + in parse 0 (String.length str) + +(******************************************************************************) + (* Guarded string to format conversions *) + +(* Convert a string to a format according to an fmtty. *) +(* Raise a Failure with an error message in case of type mismatch. *) +let format_of_string_fmtty str fmtty = + let Fmt_EBB fmt = fmt_ebb_of_string str in + try Format (type_format fmt fmtty, str) + with Type_mismatch -> + failwith_message + "bad input: format type mismatch between %S and %S" + str (string_of_fmtty fmtty) + +(* Convert a string to a format compatible with an other format. *) +(* Raise a Failure with an error message in case of type mismatch. *) +let format_of_string_format str (Format (fmt', str')) = + let Fmt_EBB fmt = fmt_ebb_of_string str in + try Format (type_format fmt (fmtty_of_fmt fmt'), str) + with Type_mismatch -> + failwith_message + "bad input: format type mismatch between %S and %S" str str' diff --git a/stdlib/camlinternalFormat.mli b/stdlib/camlinternalFormat.mli new file mode 100644 index 000000000..dd8da62d2 --- /dev/null +++ b/stdlib/camlinternalFormat.mli @@ -0,0 +1,104 @@ +(* No comments, OCaml stdlib internal use only. *) + +open CamlinternalFormatBasics + +val is_in_char_set : char_set -> char -> bool +val rev_char_set : char_set -> char_set + +type mutable_char_set = bytes +val create_char_set : unit -> mutable_char_set +val add_in_char_set : mutable_char_set -> char -> unit +val freeze_char_set : mutable_char_set -> char_set + +type ('a, 'b, 'c, 'd, 'e, 'f) param_format_ebb = Param_format_EBB : + ('x -> 'a, 'b, 'c, 'd, 'e, 'f) fmt -> + ('a, 'b, 'c, 'd, 'e, 'f) param_format_ebb + +val param_format_of_ignored_format : + ('a, 'b, 'c, 'd, 'y, 'x) ignored -> ('x, 'b, 'c, 'y, 'e, 'f) fmt -> + ('a, 'b, 'c, 'd, 'e, 'f) param_format_ebb + +type ('b, 'c) acc_formatting_gen = + | Acc_open_tag of ('b, 'c) acc + | Acc_open_box of ('b, 'c) acc + +and ('b, 'c) acc = + | Acc_formatting_lit of ('b, 'c) acc * formatting_lit + | Acc_formatting_gen of ('b, 'c) acc * ('b, 'c) acc_formatting_gen + | Acc_string_literal of ('b, 'c) acc * string + | Acc_char_literal of ('b, 'c) acc * char + | Acc_data_string of ('b, 'c) acc * string + | Acc_data_char of ('b, 'c) acc * char + | Acc_delay of ('b, 'c) acc * ('b -> 'c) + | Acc_flush of ('b, 'c) acc + | Acc_invalid_arg of ('b, 'c) acc * string + | End_of_acc + +type ('a, 'b) heter_list = + | Cons : 'c * ('a, 'b) heter_list -> ('c -> 'a, 'b) heter_list + | Nil : ('b, 'b) heter_list + +type ('b, 'c, 'e, 'f) fmt_ebb = Fmt_EBB : + ('a, 'b, 'c, 'd, 'e, 'f) CamlinternalFormatBasics.fmt -> + ('b, 'c, 'e, 'f) fmt_ebb + +val make_printf : + ('b -> ('b, 'c) acc -> 'd) -> 'b -> ('b, 'c) acc -> + ('a, 'b, 'c, 'c, 'c, 'd) CamlinternalFormatBasics.fmt -> 'a + +val output_acc : out_channel -> (out_channel, unit) acc -> unit +val bufput_acc : Buffer.t -> (Buffer.t, unit) acc -> unit +val strput_acc : Buffer.t -> (unit, string) acc -> unit + +val type_format : + ('x, 'b, 'c, 't, 'u, 'v) CamlinternalFormatBasics.fmt -> + ('a, 'b, 'c, 'd, 'e, 'f) CamlinternalFormatBasics.fmtty -> + ('a, 'b, 'c, 'd, 'e, 'f) CamlinternalFormatBasics.fmt + +val fmt_ebb_of_string : ?legacy_behavior:bool -> string -> ('b, 'c, 'e, 'f) fmt_ebb +(* warning: the optional flag legacy_behavior is EXPERIMENTAL and will + be removed in the next version. You must not set it explicitly. It + is only used by the type-checker implementation. +*) + +val format_of_string_fmtty : + string -> + ('a, 'b, 'c, 'd, 'e, 'f) CamlinternalFormatBasics.fmtty -> + ('a, 'b, 'c, 'd, 'e, 'f) CamlinternalFormatBasics.format6 + +val format_of_string_format : + string -> + ('a, 'b, 'c, 'd, 'e, 'f) CamlinternalFormatBasics.format6 -> + ('a, 'b, 'c, 'd, 'e, 'f) CamlinternalFormatBasics.format6 + +val char_of_iconv : CamlinternalFormatBasics.int_conv -> char +val string_of_formatting_lit : CamlinternalFormatBasics.formatting_lit -> string +val string_of_formatting_gen : + ('a, 'b, 'c, 'd, 'e, 'f) CamlinternalFormatBasics.formatting_gen -> string + +val string_of_fmtty : + ('a, 'b, 'c, 'd, 'e, 'f) CamlinternalFormatBasics.fmtty -> string +val string_of_fmt : + ('a, 'b, 'c, 'd, 'e, 'f) CamlinternalFormatBasics.fmt -> string + +val open_box_of_string : string -> int * block_type + +val symm : + ('a1, 'b1, 'c1, 'd1, 'e1, 'f1, + 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel +-> ('a2, 'b2, 'c2, 'd2, 'e2, 'f2, + 'a1, 'b1, 'c1, 'd1, 'e1, 'f1) fmtty_rel + +val trans : + ('a1, 'b1, 'c1, 'd1, 'e1, 'f1, + 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel +-> ('a2, 'b2, 'c2, 'd2, 'e2, 'f2, + 'a3, 'b3, 'c3, 'd3, 'e3, 'f3) fmtty_rel +-> ('a1, 'b1, 'c1, 'd1, 'e1, 'f1, + 'a3, 'b3, 'c3, 'd3, 'e3, 'f3) fmtty_rel + +val recast : + ('a1, 'b1, 'c1, 'd1, 'e1, 'f1) fmt +-> ('a1, 'b1, 'c1, 'd1, 'e1, 'f1, + 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel +-> ('a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmt diff --git a/stdlib/camlinternalFormatBasics.ml b/stdlib/camlinternalFormatBasics.ml new file mode 100644 index 000000000..e51e4e2ce --- /dev/null +++ b/stdlib/camlinternalFormatBasics.ml @@ -0,0 +1,614 @@ +(* Padding position. *) +type padty = + | Left (* Text is left justified ('-' option). *) + | Right (* Text is right justified (no '-' option). *) + | Zeros (* Text is right justified by zeros (see '0' option). *) + +(***) + +(* Integer conversion. *) +type int_conv = + | Int_d | Int_pd | Int_sd (* %d | %+d | % d *) + | Int_i | Int_pi | Int_si (* %i | %+i | % i *) + | Int_x | Int_Cx (* %x | %#x *) + | Int_X | Int_CX (* %X | %#X *) + | Int_o | Int_Co (* %o | %#o *) + | Int_u (* %u *) + +(* Float conversion. *) +type float_conv = + | Float_f | Float_pf | Float_sf (* %f | %+f | % f *) + | Float_e | Float_pe | Float_se (* %e | %+e | % e *) + | Float_E | Float_pE | Float_sE (* %E | %+E | % E *) + | Float_g | Float_pg | Float_sg (* %g | %+g | % g *) + | Float_G | Float_pG | Float_sG (* %G | %+G | % G *) + | Float_F (* %F *) + +(***) + +(* Char sets (see %[...]) are bitmaps implemented as 32-char strings. *) +type char_set = string + +(***) + +(* Counter used in Scanf. *) +type counter = + | Line_counter (* %l *) + | Char_counter (* %n *) + | Token_counter (* %N, %L *) + +(***) + +(* Padding of strings and numbers. *) +type ('a, 'b) padding = + (* No padding (ex: "%d") *) + | No_padding : ('a, 'a) padding + (* Literal padding (ex: "%8d") *) + | Lit_padding : padty * int -> ('a, 'a) padding + (* Padding as extra argument (ex: "%*d") *) + | Arg_padding : padty -> (int -> 'a, 'a) padding + +(* Some formats, such as %_d, + only accept an optional number as padding option (no extra argument) *) +type pad_option = int option + +(* Precision of floats and '0'-padding of integers. *) +type ('a, 'b) precision = + (* No precision (ex: "%f") *) + | No_precision : ('a, 'a) precision + (* Literal precision (ex: "%.3f") *) + | Lit_precision : int -> ('a, 'a) precision + (* Precision as extra argument (ex: "%.*f") *) + | Arg_precision : (int -> 'a, 'a) precision + +(* Some formats, such as %_f, + only accept an optional number as precision option (no extra argument) *) +type prec_option = int option + +(***) + +(* Relational format types + +In the first format+gadts implementation, the type for %(..%) in the +fmt GADT was as follows: + +| Format_subst : (* %(...%) *) + pad_option * ('d1, 'q1, 'd2, 'q2) reader_nb_unifier * + ('x, 'b, 'c, 'd1, 'q1, 'u) fmtty * + ('u, 'b, 'c, 'q1, 'e1, 'f) fmt -> + (('x, 'b, 'c, 'd2, 'q2, 'u) format6 -> 'x, 'b, 'c, 'd1, 'e1, 'f) fmt + +Notice that the 'u parameter in 'f position in the format argument +(('x, .., 'u) format6 -> ..) is equal to the 'u parameter in 'a +position in the format tail (('u, .., 'f) fmt). This means that the +type of the expected format parameter depends of where the %(...%) +are in the format string: + + # Printf.printf "%(%)";; + - : (unit, out_channel, unit, '_a, '_a, unit) + CamlinternalFormatBasics.format6 -> unit + = <fun> + # Printf.printf "%(%)%d";; + - : (int -> unit, out_channel, unit, '_a, '_a, int -> unit) + CamlinternalFormatBasics.format6 -> int -> unit + = <fun> + +On the contrary, the legacy typer gives a clever type that does not +depend on the position of %(..%) in the format string. For example, +%(%) will have the polymorphic type ('a, 'b, 'c, 'd, 'd, 'a): it can +be concatenated to any format type, and only enforces the constraint +that its 'a and 'f parameters are equal (no format arguments) and 'd +and 'e are equal (no reader argument). + +The weakening of this parameter type in the GADT version broke user +code (in fact it essentially made %(...%) unusable except at the last +position of a format). In particular, the following would not work +anymore: + + fun sep -> + Format.printf "foo%(%)bar%(%)baz" sep sep + +As the type-checker would require two *incompatible* types for the %(%) +in different positions. + +The solution to regain a general type for %(..%) is to generalize this +technique, not only on the 'd, 'e parameters, but on all six +parameters of a format: we introduce a "relational" type + ('a1, 'b1, 'c1, 'd1, 'e1, 'f1, + 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel +whose values are proofs that ('a1, .., 'f1) and ('a2, .., 'f2) morally +correspond to the same format type: 'a1 is obtained from 'f1,'b1,'c1 +in the exact same way that 'a2 is obtained from 'f2,'b2,'c2, etc. + +For example, the relation between two format types beginning with a Char +parameter is as follows: + +| Char_ty : (* %c *) + ('a1, 'b1, 'c1, 'd1, 'e1, 'f1, + 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel -> + (char -> 'a1, 'b1, 'c1, 'd1, 'e1, 'f1, + char -> 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel + +In the general case, the term structure of fmtty_rel is (almost¹) +isomorphic to the fmtty of the previous implementation: every +constructor is re-read with a binary, relational type, instead of the +previous unary typing. fmtty can then be re-defined as the diagonal of +fmtty_rel: + + type ('a, 'b, 'c, 'd, 'e, 'f) fmtty = + ('a, 'b, 'c, 'd, 'e, 'f, + 'a, 'b, 'c, 'd, 'e, 'f) fmtty_rel + +Once we have this fmtty_rel type in place, we can give the more +general type to %(...%): + +| Format_subst : (* %(...%) *) + pad_option * + ('g, 'h, 'i, 'j, 'k, 'l, + 'g2, 'b, 'c, 'j2, 'd, 'a) fmtty_rel * + ('a, 'b, 'c, 'd, 'e, 'f) fmt -> + (('g, 'h, 'i, 'j, 'k, 'l) format6 -> 'g2, 'b, 'c, 'j2, 'e, 'f) fmt + +We accept any format (('g, 'h, 'i, 'j, 'k, 'l) format6) (this is +completely unrelated to the type of the current format), but also +require a proof that this format is in relation to another format that +is concatenable to the format tail. When executing a %(...%) format +(in camlinternalFormat.ml:make_printf or scanf.ml:make_scanf), we +transtype the format along this relation using the 'recast' function +to transpose between related format types. + + val recast : + ('a1, 'b1, 'c1, 'd1, 'e1, 'f1) fmt + -> ('a1, 'b1, 'c1, 'd1, 'e1, 'f1, + 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel + -> ('a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmt + +NOTE ¹: the typing of Format_subst_ty requires not one format type, but +two, one to establish the link between the format argument and the +first six parameters, and the other for the link between the format +argumant and the last six parameters. + +| Format_subst_ty : (* %(...%) *) + ('g, 'h, 'i, 'j, 'k, 'l, + 'g1, 'b1, 'c1, 'j1, 'd1, 'a1) fmtty_rel * + ('g, 'h, 'i, 'j, 'k, 'l, + 'g2, 'b2, 'c2, 'j2, 'd2, 'a2) fmtty_rel * + ('a1, 'b1, 'c1, 'd1, 'e1, 'f1, + 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel -> + (('g, 'h, 'i, 'j, 'k, 'l) format6 -> 'g1, 'b1, 'c1, 'j1, 'e1, 'f1, + ('g, 'h, 'i, 'j, 'k, 'l) format6 -> 'g2, 'b2, 'c2, 'j2, 'e2, 'f2) fmtty_rel + +When we generate a format AST, we generate exactly the same witness +for both relations, and the witness-conversion functions in +camlinternalFormat do rely on this invariant. For example, the +function that proves that the relation is transitive + + val trans : + ('a1, 'b1, 'c1, 'd1, 'e1, 'f1, + 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel + -> ('a2, 'b2, 'c2, 'd2, 'e2, 'f2, + 'a3, 'b3, 'c3, 'd3, 'e3, 'f3) fmtty_rel + -> ('a1, 'b1, 'c1, 'd1, 'e1, 'f1, + 'a3, 'b3, 'c3, 'd3, 'e3, 'f3) fmtty_rel + +does assume that the two input have exactly the same term structure +(and is only every used for argument witnesses of the +Format_subst_ty constructor). +*) + +(* Type of a block used by the Format pretty-printer. *) +type block_type = + | Pp_hbox (* Horizontal block no line breaking *) + | Pp_vbox (* Vertical block each break leads to a new line *) + | Pp_hvbox (* Horizontal-vertical block: same as vbox, except if this block + is small enough to fit on a single line *) + | Pp_hovbox (* Horizontal or Vertical block: breaks lead to new line + only when necessary to print the content of the block *) + | Pp_box (* Horizontal or Indent block: breaks lead to new line + only when necessary to print the content of the block, or + when it leads to a new indentation of the current line *) + | Pp_fits (* Internal usage: when a block fits on a single line *) + +(* Formatting element used by the Format pretty-printter. *) +type formatting_lit = + | Close_box (* @] *) + | Close_tag (* @} *) + | Break of string * int * int (* @, | @ | @; | @;<> *) + | FFlush (* @? *) + | Force_newline (* @\n *) + | Flush_newline (* @. *) + | Magic_size of string * int (* @<n> *) + | Escaped_at (* @@ *) + | Escaped_percent (* @%% *) + | Scan_indic of char (* @X *) + +(* Formatting element used by the Format pretty-printter. *) +type ('a, 'b, 'c, 'd, 'e, 'f) formatting_gen = + | Open_tag : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> (* @{ *) + ('a, 'b, 'c, 'd, 'e, 'f) formatting_gen + | Open_box : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> (* @[ *) + ('a, 'b, 'c, 'd, 'e, 'f) formatting_gen + +(***) + +(* List of format type elements. *) +(* In particular used to represent %(...%) and %{...%} contents. *) +and ('a, 'b, 'c, 'd, 'e, 'f) fmtty = + ('a, 'b, 'c, 'd, 'e, 'f, + 'a, 'b, 'c, 'd, 'e, 'f) fmtty_rel +and ('a1, 'b1, 'c1, 'd1, 'e1, 'f1, + 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel = + | Char_ty : (* %c *) + ('a1, 'b1, 'c1, 'd1, 'e1, 'f1, + 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel -> + (char -> 'a1, 'b1, 'c1, 'd1, 'e1, 'f1, + char -> 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel + | String_ty : (* %s *) + ('a1, 'b1, 'c1, 'd1, 'e1, 'f1, + 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel -> + (string -> 'a1, 'b1, 'c1, 'd1, 'e1, 'f1, + string -> 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel + | Int_ty : (* %d *) + ('a1, 'b1, 'c1, 'd1, 'e1, 'f1, + 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel -> + (int -> 'a1, 'b1, 'c1, 'd1, 'e1, 'f1, + int -> 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel + | Int32_ty : (* %ld *) + ('a1, 'b1, 'c1, 'd1, 'e1, 'f1, + 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel -> + (int32 -> 'a1, 'b1, 'c1, 'd1, 'e1, 'f1, + int32 -> 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel + | Nativeint_ty : (* %nd *) + ('a1, 'b1, 'c1, 'd1, 'e1, 'f1, + 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel -> + (nativeint -> 'a1, 'b1, 'c1, 'd1, 'e1, 'f1, + nativeint -> 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel + | Int64_ty : (* %Ld *) + ('a1, 'b1, 'c1, 'd1, 'e1, 'f1, + 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel -> + (int64 -> 'a1, 'b1, 'c1, 'd1, 'e1, 'f1, + int64 -> 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel + | Float_ty : (* %f *) + ('a1, 'b1, 'c1, 'd1, 'e1, 'f1, + 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel -> + (float -> 'a1, 'b1, 'c1, 'd1, 'e1, 'f1, + float -> 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel + | Bool_ty : (* %B *) + ('a1, 'b1, 'c1, 'd1, 'e1, 'f1, + 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel -> + (bool -> 'a1, 'b1, 'c1, 'd1, 'e1, 'f1, + bool -> 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel + + | Format_arg_ty : (* %{...%} *) + ('g, 'h, 'i, 'j, 'k, 'l) fmtty * + ('a1, 'b1, 'c1, 'd1, 'e1, 'f1, + 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel -> + (('g, 'h, 'i, 'j, 'k, 'l) format6 -> 'a1, 'b1, 'c1, 'd1, 'e1, 'f1, + ('g, 'h, 'i, 'j, 'k, 'l) format6 -> 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel + | Format_subst_ty : (* %(...%) *) + ('g, 'h, 'i, 'j, 'k, 'l, + 'g1, 'b1, 'c1, 'j1, 'd1, 'a1) fmtty_rel * + ('g, 'h, 'i, 'j, 'k, 'l, + 'g2, 'b2, 'c2, 'j2, 'd2, 'a2) fmtty_rel * + ('a1, 'b1, 'c1, 'd1, 'e1, 'f1, + 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel -> + (('g, 'h, 'i, 'j, 'k, 'l) format6 -> 'g1, 'b1, 'c1, 'j1, 'e1, 'f1, + ('g, 'h, 'i, 'j, 'k, 'l) format6 -> 'g2, 'b2, 'c2, 'j2, 'e2, 'f2) fmtty_rel + + (* Printf and Format specific constructors. *) + | Alpha_ty : (* %a *) + ('a1, 'b1, 'c1, 'd1, 'e1, 'f1, + 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel -> + (('b1 -> 'x -> 'c1) -> 'x -> 'a1, 'b1, 'c1, 'd1, 'e1, 'f1, + ('b2 -> 'x -> 'c2) -> 'x -> 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel + | Theta_ty : (* %t *) + ('a1, 'b1, 'c1, 'd1, 'e1, 'f1, + 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel -> + (('b1 -> 'c1) -> 'a1, 'b1, 'c1, 'd1, 'e1, 'f1, + ('b2 -> 'c2) -> 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel + + (* Scanf specific constructor. *) + | Reader_ty : (* %r *) + ('a1, 'b1, 'c1, 'd1, 'e1, 'f1, + 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel -> + ('x -> 'a1, 'b1, 'c1, ('b1 -> 'x) -> 'd1, 'e1, 'f1, + 'x -> 'a2, 'b2, 'c2, ('b2 -> 'x) -> 'd2, 'e2, 'f2) fmtty_rel + | Ignored_reader_ty : (* %_r *) + ('a1, 'b1, 'c1, 'd1, 'e1, 'f1, + 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel -> + ('a1, 'b1, 'c1, ('b1 -> 'x) -> 'd1, 'e1, 'f1, + 'a2, 'b2, 'c2, ('b2 -> 'x) -> 'd2, 'e2, 'f2) fmtty_rel + + | End_of_fmtty : + ('f1, 'b1, 'c1, 'd1, 'd1, 'f1, + 'f2, 'b2, 'c2, 'd2, 'd2, 'f2) fmtty_rel + +(***) + +(* List of format elements. *) +and ('a, 'b, 'c, 'd, 'e, 'f) fmt = + | Char : (* %c *) + ('a, 'b, 'c, 'd, 'e, 'f) fmt -> + (char -> 'a, 'b, 'c, 'd, 'e, 'f) fmt + | Caml_char : (* %C *) + ('a, 'b, 'c, 'd, 'e, 'f) fmt -> + (char -> 'a, 'b, 'c, 'd, 'e, 'f) fmt + | String : (* %s *) + ('x, string -> 'a) padding * ('a, 'b, 'c, 'd, 'e, 'f) fmt -> + ('x, 'b, 'c, 'd, 'e, 'f) fmt + | Caml_string : (* %S *) + ('x, string -> 'a) padding * ('a, 'b, 'c, 'd, 'e, 'f) fmt -> + ('x, 'b, 'c, 'd, 'e, 'f) fmt + | Int : (* %[dixXuo] *) + int_conv * ('x, 'y) padding * ('y, int -> 'a) precision * + ('a, 'b, 'c, 'd, 'e, 'f) fmt -> + ('x, 'b, 'c, 'd, 'e, 'f) fmt + | Int32 : (* %l[dixXuo] *) + int_conv * ('x, 'y) padding * ('y, int32 -> 'a) precision * + ('a, 'b, 'c, 'd, 'e, 'f) fmt -> + ('x, 'b, 'c, 'd, 'e, 'f) fmt + | Nativeint : (* %n[dixXuo] *) + int_conv * ('x, 'y) padding * ('y, nativeint -> 'a) precision * + ('a, 'b, 'c, 'd, 'e, 'f) fmt -> + ('x, 'b, 'c, 'd, 'e, 'f) fmt + | Int64 : (* %L[dixXuo] *) + int_conv * ('x, 'y) padding * ('y, int64 -> 'a) precision * + ('a, 'b, 'c, 'd, 'e, 'f) fmt -> + ('x, 'b, 'c, 'd, 'e, 'f) fmt + | Float : (* %[feEgGF] *) + float_conv * ('x, 'y) padding * ('y, float -> 'a) precision * + ('a, 'b, 'c, 'd, 'e, 'f) fmt -> + ('x, 'b, 'c, 'd, 'e, 'f) fmt + | Bool : (* %[bB] *) + ('a, 'b, 'c, 'd, 'e, 'f) fmt -> + (bool -> 'a, 'b, 'c, 'd, 'e, 'f) fmt + | Flush : (* %! *) + ('a, 'b, 'c, 'd, 'e, 'f) fmt -> + ('a, 'b, 'c, 'd, 'e, 'f) fmt + + | String_literal : (* abc *) + string * ('a, 'b, 'c, 'd, 'e, 'f) fmt -> + ('a, 'b, 'c, 'd, 'e, 'f) fmt + | Char_literal : (* x *) + char * ('a, 'b, 'c, 'd, 'e, 'f) fmt -> + ('a, 'b, 'c, 'd, 'e, 'f) fmt + + | Format_arg : (* %{...%} *) + pad_option * ('g, 'h, 'i, 'j, 'k, 'l) fmtty * + ('a, 'b, 'c, 'd, 'e, 'f) fmt -> + (('g, 'h, 'i, 'j, 'k, 'l) format6 -> 'a, 'b, 'c, 'd, 'e, 'f) fmt + | Format_subst : (* %(...%) *) + pad_option * + ('g, 'h, 'i, 'j, 'k, 'l, + 'g2, 'b, 'c, 'j2, 'd, 'a) fmtty_rel * + ('a, 'b, 'c, 'd, 'e, 'f) fmt -> + (('g, 'h, 'i, 'j, 'k, 'l) format6 -> 'g2, 'b, 'c, 'j2, 'e, 'f) fmt + + (* Printf and Format specific constructor. *) + | Alpha : (* %a *) + ('a, 'b, 'c, 'd, 'e, 'f) fmt -> + (('b -> 'x -> 'c) -> 'x -> 'a, 'b, 'c, 'd, 'e, 'f) fmt + | Theta : (* %t *) + ('a, 'b, 'c, 'd, 'e, 'f) fmt -> + (('b -> 'c) -> 'a, 'b, 'c, 'd, 'e, 'f) fmt + + (* Format specific constructor: *) + | Formatting_lit : (* @_ *) + formatting_lit * ('a, 'b, 'c, 'd, 'e, 'f) fmt -> + ('a, 'b, 'c, 'd, 'e, 'f) fmt + | Formatting_gen : (* @_ *) + ('a1, 'b, 'c, 'd1, 'e1, 'f1) formatting_gen * + ('f1, 'b, 'c, 'e1, 'e2, 'f2) fmt -> ('a1, 'b, 'c, 'd1, 'e2, 'f2) fmt + + (* Scanf specific constructors: *) + | Reader : (* %r *) + ('a, 'b, 'c, 'd, 'e, 'f) fmt -> + ('x -> 'a, 'b, 'c, ('b -> 'x) -> 'd, 'e, 'f) fmt + | Scan_char_set : (* %[...] *) + pad_option * char_set * ('a, 'b, 'c, 'd, 'e, 'f) fmt -> + (string -> 'a, 'b, 'c, 'd, 'e, 'f) fmt + | Scan_get_counter : (* %[nlNL] *) + counter * ('a, 'b, 'c, 'd, 'e, 'f) fmt -> + (int -> 'a, 'b, 'c, 'd, 'e, 'f) fmt + | Ignored_param : (* %_ *) + ('a, 'b, 'c, 'd, 'y, 'x) ignored * ('x, 'b, 'c, 'y, 'e, 'f) fmt -> + ('a, 'b, 'c, 'd, 'e, 'f) fmt + + | End_of_format : + ('f, 'b, 'c, 'e, 'e, 'f) fmt + +(***) + +(* Type for ignored parameters (see "%_"). *) +and ('a, 'b, 'c, 'd, 'e, 'f) ignored = + | Ignored_char : (* %_c *) + ('a, 'b, 'c, 'd, 'd, 'a) ignored + | Ignored_caml_char : (* %_C *) + ('a, 'b, 'c, 'd, 'd, 'a) ignored + | Ignored_string : (* %_s *) + pad_option -> ('a, 'b, 'c, 'd, 'd, 'a) ignored + | Ignored_caml_string : (* %_S *) + pad_option -> ('a, 'b, 'c, 'd, 'd, 'a) ignored + | Ignored_int : (* %_d *) + int_conv * pad_option -> ('a, 'b, 'c, 'd, 'd, 'a) ignored + | Ignored_int32 : (* %_ld *) + int_conv * pad_option -> ('a, 'b, 'c, 'd, 'd, 'a) ignored + | Ignored_nativeint : (* %_nd *) + int_conv * pad_option -> ('a, 'b, 'c, 'd, 'd, 'a) ignored + | Ignored_int64 : (* %_Ld *) + int_conv * pad_option -> ('a, 'b, 'c, 'd, 'd, 'a) ignored + | Ignored_float : (* %_f *) + pad_option * prec_option -> ('a, 'b, 'c, 'd, 'd, 'a) ignored + | Ignored_bool : (* %_B *) + ('a, 'b, 'c, 'd, 'd, 'a) ignored + | Ignored_format_arg : (* %_{...%} *) + pad_option * ('g, 'h, 'i, 'j, 'k, 'l) fmtty -> + ('a, 'b, 'c, 'd, 'd, 'a) ignored + | Ignored_format_subst : (* %_(...%) *) + pad_option * ('a, 'b, 'c, 'd, 'e, 'f) fmtty -> + ('a, 'b, 'c, 'd, 'e, 'f) ignored + | Ignored_reader : (* %_r *) + ('a, 'b, 'c, ('b -> 'x) -> 'd, 'd, 'a) ignored + | Ignored_scan_char_set : (* %_[...] *) + pad_option * char_set -> ('a, 'b, 'c, 'd, 'd, 'a) ignored + | Ignored_scan_get_counter : (* %_[nlNL] *) + counter -> ('a, 'b, 'c, 'd, 'd, 'a) ignored + +and ('a, 'b, 'c, 'd, 'e, 'f) format6 = + Format of ('a, 'b, 'c, 'd, 'e, 'f) fmt * string + +let rec erase_rel : type a b c d e f g h i j k l . + (a, b, c, d, e, f, + g, h, i, j, k, l) fmtty_rel -> (a, b, c, d, e, f) fmtty += function + | Char_ty rest -> + Char_ty (erase_rel rest) + | String_ty rest -> + String_ty (erase_rel rest) + | Int_ty rest -> + Int_ty (erase_rel rest) + | Int32_ty rest -> + Int32_ty (erase_rel rest) + | Int64_ty rest -> + Int64_ty (erase_rel rest) + | Nativeint_ty rest -> + Nativeint_ty (erase_rel rest) + | Float_ty rest -> + Float_ty (erase_rel rest) + | Bool_ty rest -> + Bool_ty (erase_rel rest) + | Format_arg_ty (ty, rest) -> + Format_arg_ty (ty, erase_rel rest) + | Format_subst_ty (ty1, ty2, rest) -> + Format_subst_ty (ty1, ty1, erase_rel rest) + | Alpha_ty rest -> + Alpha_ty (erase_rel rest) + | Theta_ty rest -> + Theta_ty (erase_rel rest) + | Reader_ty rest -> + Reader_ty (erase_rel rest) + | Ignored_reader_ty rest -> + Ignored_reader_ty (erase_rel rest) + | End_of_fmtty -> End_of_fmtty + +(******************************************************************************) + (* Format type concatenation *) + +(* Concatenate two format types. *) +(* Used by: + * reader_nb_unifier_of_fmtty to count readers in an fmtty, + * Scanf.take_fmtty_format_readers to extract readers inside %(...%), + * CamlinternalFormat.fmtty_of_ignored_format to extract format type. *) + +(* +let rec concat_fmtty : type a b c d e f g h . + (a, b, c, d, e, f) fmtty -> + (f, b, c, e, g, h) fmtty -> + (a, b, c, d, g, h) fmtty = +*) +let rec concat_fmtty : + type a1 b1 c1 d1 e1 f1 + a2 b2 c2 d2 e2 f2 + g1 j1 g2 j2 + . + (g1, b1, c1, j1, d1, a1, + g2, b2, c2, j2, d2, a2) fmtty_rel -> + (a1, b1, c1, d1, e1, f1, + a2, b2, c2, d2, e2, f2) fmtty_rel -> + (g1, b1, c1, j1, e1, f1, + g2, b2, c2, j2, e2, f2) fmtty_rel = +fun fmtty1 fmtty2 -> match fmtty1 with + | Char_ty rest -> + Char_ty (concat_fmtty rest fmtty2) + | String_ty rest -> + String_ty (concat_fmtty rest fmtty2) + | Int_ty rest -> + Int_ty (concat_fmtty rest fmtty2) + | Int32_ty rest -> + Int32_ty (concat_fmtty rest fmtty2) + | Nativeint_ty rest -> + Nativeint_ty (concat_fmtty rest fmtty2) + | Int64_ty rest -> + Int64_ty (concat_fmtty rest fmtty2) + | Float_ty rest -> + Float_ty (concat_fmtty rest fmtty2) + | Bool_ty rest -> + Bool_ty (concat_fmtty rest fmtty2) + | Alpha_ty rest -> + Alpha_ty (concat_fmtty rest fmtty2) + | Theta_ty rest -> + Theta_ty (concat_fmtty rest fmtty2) + | Reader_ty rest -> + Reader_ty (concat_fmtty rest fmtty2) + | Ignored_reader_ty rest -> + Ignored_reader_ty (concat_fmtty rest fmtty2) + | Format_arg_ty (ty, rest) -> + Format_arg_ty (ty, concat_fmtty rest fmtty2) + | Format_subst_ty (ty1, ty2, rest) -> + Format_subst_ty (ty1, ty2, concat_fmtty rest fmtty2) + | End_of_fmtty -> fmtty2 + +(******************************************************************************) + (* Format concatenation *) + +(* Concatenate two formats. *) +let rec concat_fmt : type a b c d e f g h . + (a, b, c, d, e, f) fmt -> + (f, b, c, e, g, h) fmt -> + (a, b, c, d, g, h) fmt = +fun fmt1 fmt2 -> match fmt1 with + | String (pad, rest) -> + String (pad, concat_fmt rest fmt2) + | Caml_string (pad, rest) -> + Caml_string (pad, concat_fmt rest fmt2) + + | Int (iconv, pad, prec, rest) -> + Int (iconv, pad, prec, concat_fmt rest fmt2) + | Int32 (iconv, pad, prec, rest) -> + Int32 (iconv, pad, prec, concat_fmt rest fmt2) + | Nativeint (iconv, pad, prec, rest) -> + Nativeint (iconv, pad, prec, concat_fmt rest fmt2) + | Int64 (iconv, pad, prec, rest) -> + Int64 (iconv, pad, prec, concat_fmt rest fmt2) + | Float (fconv, pad, prec, rest) -> + Float (fconv, pad, prec, concat_fmt rest fmt2) + + | Char (rest) -> + Char (concat_fmt rest fmt2) + | Caml_char rest -> + Caml_char (concat_fmt rest fmt2) + | Bool rest -> + Bool (concat_fmt rest fmt2) + | Alpha rest -> + Alpha (concat_fmt rest fmt2) + | Theta rest -> + Theta (concat_fmt rest fmt2) + | Reader rest -> + Reader (concat_fmt rest fmt2) + | Flush rest -> + Flush (concat_fmt rest fmt2) + + | String_literal (str, rest) -> + String_literal (str, concat_fmt rest fmt2) + | Char_literal (chr, rest) -> + Char_literal (chr, concat_fmt rest fmt2) + + | Format_arg (pad, fmtty, rest) -> + Format_arg (pad, fmtty, concat_fmt rest fmt2) + | Format_subst (pad, fmtty, rest) -> + Format_subst (pad, fmtty, concat_fmt rest fmt2) + + | Scan_char_set (width_opt, char_set, rest) -> + Scan_char_set (width_opt, char_set, concat_fmt rest fmt2) + | Scan_get_counter (counter, rest) -> + Scan_get_counter (counter, concat_fmt rest fmt2) + | Ignored_param (ign, rest) -> + Ignored_param (ign, concat_fmt rest fmt2) + + | Formatting_lit (fmting_lit, rest) -> + Formatting_lit (fmting_lit, concat_fmt rest fmt2) + | Formatting_gen (fmting_gen, rest) -> + Formatting_gen (fmting_gen, concat_fmt rest fmt2) + + | End_of_format -> + fmt2 diff --git a/stdlib/camlinternalFormatBasics.mli b/stdlib/camlinternalFormatBasics.mli new file mode 100644 index 000000000..52f428ad8 --- /dev/null +++ b/stdlib/camlinternalFormatBasics.mli @@ -0,0 +1,287 @@ +(* No comments, OCaml stdlib internal use only. *) + +type padty = Left | Right | Zeros + +type int_conv = + | Int_d | Int_pd | Int_sd | Int_i | Int_pi | Int_si + | Int_x | Int_Cx | Int_X | Int_CX | Int_o | Int_Co | Int_u + +type float_conv = + | Float_f | Float_pf | Float_sf | Float_e | Float_pe | Float_se + | Float_E | Float_pE | Float_sE | Float_g | Float_pg | Float_sg + | Float_G | Float_pG | Float_sG | Float_F + +type char_set = string + +type counter = Line_counter | Char_counter | Token_counter + +type ('a, 'b) padding = + | No_padding : ('a, 'a) padding + | Lit_padding : padty * int -> ('a, 'a) padding + | Arg_padding : padty -> (int -> 'a, 'a) padding + +type pad_option = int option + +type ('a, 'b) precision = + | No_precision : ('a, 'a) precision + | Lit_precision : int -> ('a, 'a) precision + | Arg_precision : (int -> 'a, 'a) precision + +type prec_option = int option + +type block_type = Pp_hbox | Pp_vbox | Pp_hvbox | Pp_hovbox | Pp_box | Pp_fits + +type formatting_lit = + | Close_box + | Close_tag + | Break of string * int * int + | FFlush + | Force_newline + | Flush_newline + | Magic_size of string * int + | Escaped_at + | Escaped_percent + | Scan_indic of char + +type ('a, 'b, 'c, 'd, 'e, 'f) formatting_gen = + | Open_tag : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> + ('a, 'b, 'c, 'd, 'e, 'f) formatting_gen + | Open_box : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> + ('a, 'b, 'c, 'd, 'e, 'f) formatting_gen + +and ('a, 'b, 'c, 'd, 'e, 'f) fmtty = + ('a, 'b, 'c, 'd, 'e, 'f, + 'a, 'b, 'c, 'd, 'e, 'f) fmtty_rel +and ('a1, 'b1, 'c1, 'd1, 'e1, 'f1, + 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel = +| Char_ty : (* %c *) + ('a1, 'b1, 'c1, 'd1, 'e1, 'f1, + 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel -> + (char -> 'a1, 'b1, 'c1, 'd1, 'e1, 'f1, + char -> 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel +| String_ty : (* %s *) + ('a1, 'b1, 'c1, 'd1, 'e1, 'f1, + 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel -> + (string -> 'a1, 'b1, 'c1, 'd1, 'e1, 'f1, + string -> 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel +| Int_ty : (* %d *) + ('a1, 'b1, 'c1, 'd1, 'e1, 'f1, + 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel -> + (int -> 'a1, 'b1, 'c1, 'd1, 'e1, 'f1, + int -> 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel +| Int32_ty : (* %ld *) + ('a1, 'b1, 'c1, 'd1, 'e1, 'f1, + 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel -> + (int32 -> 'a1, 'b1, 'c1, 'd1, 'e1, 'f1, + int32 -> 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel +| Nativeint_ty : (* %nd *) + ('a1, 'b1, 'c1, 'd1, 'e1, 'f1, + 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel -> + (nativeint -> 'a1, 'b1, 'c1, 'd1, 'e1, 'f1, + nativeint -> 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel +| Int64_ty : (* %Ld *) + ('a1, 'b1, 'c1, 'd1, 'e1, 'f1, + 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel -> + (int64 -> 'a1, 'b1, 'c1, 'd1, 'e1, 'f1, + int64 -> 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel +| Float_ty : (* %f *) + ('a1, 'b1, 'c1, 'd1, 'e1, 'f1, + 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel -> + (float -> 'a1, 'b1, 'c1, 'd1, 'e1, 'f1, + float -> 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel +| Bool_ty : (* %B *) + ('a1, 'b1, 'c1, 'd1, 'e1, 'f1, + 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel -> + (bool -> 'a1, 'b1, 'c1, 'd1, 'e1, 'f1, + bool -> 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel +| Format_arg_ty : (* %{...%} *) + ('g, 'h, 'i, 'j, 'k, 'l) fmtty * + ('a1, 'b1, 'c1, 'd1, 'e1, 'f1, + 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel -> + (('g, 'h, 'i, 'j, 'k, 'l) format6 -> 'a1, 'b1, 'c1, 'd1, 'e1, 'f1, + ('g, 'h, 'i, 'j, 'k, 'l) format6 -> 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel +| Format_subst_ty : (* %(...%) *) + ('g, 'h, 'i, 'j, 'k, 'l, + 'g1, 'b1, 'c1, 'j1, 'd1, 'a1) fmtty_rel * + ('g, 'h, 'i, 'j, 'k, 'l, + 'g2, 'b2, 'c2, 'j2, 'd2, 'a2) fmtty_rel * + ('a1, 'b1, 'c1, 'd1, 'e1, 'f1, + 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel -> + (('g, 'h, 'i, 'j, 'k, 'l) format6 -> 'g1, 'b1, 'c1, 'j1, 'e1, 'f1, + ('g, 'h, 'i, 'j, 'k, 'l) format6 -> 'g2, 'b2, 'c2, 'j2, 'e2, 'f2) fmtty_rel + +(* Printf and Format specific constructors. *) +| Alpha_ty : (* %a *) + ('a1, 'b1, 'c1, 'd1, 'e1, 'f1, + 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel -> + (('b1 -> 'x -> 'c1) -> 'x -> 'a1, 'b1, 'c1, 'd1, 'e1, 'f1, + ('b2 -> 'x -> 'c2) -> 'x -> 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel +| Theta_ty : (* %t *) + ('a1, 'b1, 'c1, 'd1, 'e1, 'f1, + 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel -> + (('b1 -> 'c1) -> 'a1, 'b1, 'c1, 'd1, 'e1, 'f1, + ('b2 -> 'c2) -> 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel + +(* Scanf specific constructor. *) +| Reader_ty : (* %r *) + ('a1, 'b1, 'c1, 'd1, 'e1, 'f1, + 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel -> + ('x -> 'a1, 'b1, 'c1, ('b1 -> 'x) -> 'd1, 'e1, 'f1, + 'x -> 'a2, 'b2, 'c2, ('b2 -> 'x) -> 'd2, 'e2, 'f2) fmtty_rel +| Ignored_reader_ty : (* %_r *) + ('a1, 'b1, 'c1, 'd1, 'e1, 'f1, + 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel -> + ('a1, 'b1, 'c1, ('b1 -> 'x) -> 'd1, 'e1, 'f1, + 'a2, 'b2, 'c2, ('b2 -> 'x) -> 'd2, 'e2, 'f2) fmtty_rel + +| End_of_fmtty : + ('f1, 'b1, 'c1, 'd1, 'd1, 'f1, + 'f2, 'b2, 'c2, 'd2, 'd2, 'f2) fmtty_rel + +(**) + +(** List of format elements. *) +and ('a, 'b, 'c, 'd, 'e, 'f) fmt = +| Char : (* %c *) + ('a, 'b, 'c, 'd, 'e, 'f) fmt -> + (char -> 'a, 'b, 'c, 'd, 'e, 'f) fmt +| Caml_char : (* %C *) + ('a, 'b, 'c, 'd, 'e, 'f) fmt -> + (char -> 'a, 'b, 'c, 'd, 'e, 'f) fmt +| String : (* %s *) + ('x, string -> 'a) padding * ('a, 'b, 'c, 'd, 'e, 'f) fmt -> + ('x, 'b, 'c, 'd, 'e, 'f) fmt +| Caml_string : (* %S *) + ('x, string -> 'a) padding * ('a, 'b, 'c, 'd, 'e, 'f) fmt -> + ('x, 'b, 'c, 'd, 'e, 'f) fmt +| Int : (* %[dixXuo] *) + int_conv * ('x, 'y) padding * ('y, int -> 'a) precision * + ('a, 'b, 'c, 'd, 'e, 'f) fmt -> + ('x, 'b, 'c, 'd, 'e, 'f) fmt +| Int32 : (* %l[dixXuo] *) + int_conv * ('x, 'y) padding * ('y, int32 -> 'a) precision * + ('a, 'b, 'c, 'd, 'e, 'f) fmt -> + ('x, 'b, 'c, 'd, 'e, 'f) fmt +| Nativeint : (* %n[dixXuo] *) + int_conv * ('x, 'y) padding * ('y, nativeint -> 'a) precision * + ('a, 'b, 'c, 'd, 'e, 'f) fmt -> + ('x, 'b, 'c, 'd, 'e, 'f) fmt +| Int64 : (* %L[dixXuo] *) + int_conv * ('x, 'y) padding * ('y, int64 -> 'a) precision * + ('a, 'b, 'c, 'd, 'e, 'f) fmt -> + ('x, 'b, 'c, 'd, 'e, 'f) fmt +| Float : (* %[feEgGF] *) + float_conv * ('x, 'y) padding * ('y, float -> 'a) precision * + ('a, 'b, 'c, 'd, 'e, 'f) fmt -> + ('x, 'b, 'c, 'd, 'e, 'f) fmt +| Bool : (* %[bB] *) + ('a, 'b, 'c, 'd, 'e, 'f) fmt -> + (bool -> 'a, 'b, 'c, 'd, 'e, 'f) fmt +| Flush : (* %! *) + ('a, 'b, 'c, 'd, 'e, 'f) fmt -> + ('a, 'b, 'c, 'd, 'e, 'f) fmt + +| String_literal : (* abc *) + string * ('a, 'b, 'c, 'd, 'e, 'f) fmt -> + ('a, 'b, 'c, 'd, 'e, 'f) fmt +| Char_literal : (* x *) + char * ('a, 'b, 'c, 'd, 'e, 'f) fmt -> + ('a, 'b, 'c, 'd, 'e, 'f) fmt + +| Format_arg : (* %{...%} *) + pad_option * ('g, 'h, 'i, 'j, 'k, 'l) fmtty * + ('a, 'b, 'c, 'd, 'e, 'f) fmt -> + (('g, 'h, 'i, 'j, 'k, 'l) format6 -> 'a, 'b, 'c, 'd, 'e, 'f) fmt +| Format_subst : (* %(...%) *) + pad_option * + ('g, 'h, 'i, 'j, 'k, 'l, + 'g2, 'b, 'c, 'j2, 'd, 'a) fmtty_rel * + ('a, 'b, 'c, 'd, 'e, 'f) fmt -> + (('g, 'h, 'i, 'j, 'k, 'l) format6 -> 'g2, 'b, 'c, 'j2, 'e, 'f) fmt + +(* Printf and Format specific constructor. *) +| Alpha : (* %a *) + ('a, 'b, 'c, 'd, 'e, 'f) fmt -> + (('b -> 'x -> 'c) -> 'x -> 'a, 'b, 'c, 'd, 'e, 'f) fmt +| Theta : (* %t *) + ('a, 'b, 'c, 'd, 'e, 'f) fmt -> + (('b -> 'c) -> 'a, 'b, 'c, 'd, 'e, 'f) fmt + +(* Format specific constructor: *) +| Formatting_lit : (* @_ *) + formatting_lit * ('a, 'b, 'c, 'd, 'e, 'f) fmt -> + ('a, 'b, 'c, 'd, 'e, 'f) fmt +| Formatting_gen : (* @_ *) + ('a1, 'b, 'c, 'd1, 'e1, 'f1) formatting_gen * + ('f1, 'b, 'c, 'e1, 'e2, 'f2) fmt -> ('a1, 'b, 'c, 'd1, 'e2, 'f2) fmt + +(* Scanf specific constructors: *) +| Reader : (* %r *) + ('a, 'b, 'c, 'd, 'e, 'f) fmt -> + ('x -> 'a, 'b, 'c, ('b -> 'x) -> 'd, 'e, 'f) fmt +| Scan_char_set : (* %[...] *) + pad_option * char_set * ('a, 'b, 'c, 'd, 'e, 'f) fmt -> + (string -> 'a, 'b, 'c, 'd, 'e, 'f) fmt +| Scan_get_counter : (* %[nlNL] *) + counter * ('a, 'b, 'c, 'd, 'e, 'f) fmt -> + (int -> 'a, 'b, 'c, 'd, 'e, 'f) fmt +| Ignored_param : (* %_ *) + ('a, 'b, 'c, 'd, 'y, 'x) ignored * ('x, 'b, 'c, 'y, 'e, 'f) fmt -> + ('a, 'b, 'c, 'd, 'e, 'f) fmt + +| End_of_format : + ('f, 'b, 'c, 'e, 'e, 'f) fmt + +and ('a, 'b, 'c, 'd, 'e, 'f) ignored = + | Ignored_char : + ('a, 'b, 'c, 'd, 'd, 'a) ignored + | Ignored_caml_char : + ('a, 'b, 'c, 'd, 'd, 'a) ignored + | Ignored_string : + pad_option -> ('a, 'b, 'c, 'd, 'd, 'a) ignored + | Ignored_caml_string : + pad_option -> ('a, 'b, 'c, 'd, 'd, 'a) ignored + | Ignored_int : + int_conv * pad_option -> ('a, 'b, 'c, 'd, 'd, 'a) ignored + | Ignored_int32 : + int_conv * pad_option -> ('a, 'b, 'c, 'd, 'd, 'a) ignored + | Ignored_nativeint : + int_conv * pad_option -> ('a, 'b, 'c, 'd, 'd, 'a) ignored + | Ignored_int64 : + int_conv * pad_option -> ('a, 'b, 'c, 'd, 'd, 'a) ignored + | Ignored_float : + pad_option * prec_option -> ('a, 'b, 'c, 'd, 'd, 'a) ignored + | Ignored_bool : + ('a, 'b, 'c, 'd, 'd, 'a) ignored + | Ignored_format_arg : + pad_option * ('g, 'h, 'i, 'j, 'k, 'l) fmtty -> + ('a, 'b, 'c, 'd, 'd, 'a) ignored + | Ignored_format_subst : + pad_option * ('a, 'b, 'c, 'd, 'e, 'f) fmtty -> + ('a, 'b, 'c, 'd, 'e, 'f) ignored + | Ignored_reader : + ('a, 'b, 'c, ('b -> 'x) -> 'd, 'd, 'a) ignored + | Ignored_scan_char_set : + pad_option * char_set -> ('a, 'b, 'c, 'd, 'd, 'a) ignored + | Ignored_scan_get_counter : + counter -> ('a, 'b, 'c, 'd, 'd, 'a) ignored + +and ('a, 'b, 'c, 'd, 'e, 'f) format6 = + Format of ('a, 'b, 'c, 'd, 'e, 'f) fmt * string + +val concat_fmtty : + ('g1, 'b1, 'c1, 'j1, 'd1, 'a1, + 'g2, 'b2, 'c2, 'j2, 'd2, 'a2) fmtty_rel -> + ('a1, 'b1, 'c1, 'd1, 'e1, 'f1, + 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel -> + ('g1, 'b1, 'c1, 'j1, 'e1, 'f1, + 'g2, 'b2, 'c2, 'j2, 'e2, 'f2) fmtty_rel + +val erase_rel : + ('a, 'b, 'c, 'd, 'e, 'f, + 'g, 'h, 'i, 'j, 'k, 'l) fmtty_rel -> ('a, 'b, 'c, 'd, 'e, 'f) fmtty + +val concat_fmt : + ('a, 'b, 'c, 'd, 'e, 'f) fmt -> + ('f, 'b, 'c, 'e, 'g, 'h) fmt -> + ('a, 'b, 'c, 'd, 'g, 'h) fmt diff --git a/stdlib/camlinternalOO.ml b/stdlib/camlinternalOO.ml index 872a56065..3c39c0b67 100644 --- a/stdlib/camlinternalOO.ml +++ b/stdlib/camlinternalOO.ml @@ -128,7 +128,7 @@ let rec fit_size n = let new_table pub_labels = incr table_count; let len = Array.length pub_labels in - let methods = Array.create (len*2+2) dummy_met in + let methods = Array.make (len*2+2) dummy_met in methods.(0) <- magic len; methods.(1) <- magic (fit_size len * Sys.word_size / 8 - 1); for i = 0 to len - 1 do methods.(i*2+3) <- magic pub_labels.(i) done; @@ -144,7 +144,7 @@ let new_table pub_labels = let resize array new_size = let old_size = Array.length array.methods in if new_size > old_size then begin - let new_buck = Array.create new_size dummy_met in + let new_buck = Array.make new_size dummy_met in Array.blit array.methods 0 new_buck 0 old_size; array.methods <- new_buck end @@ -267,7 +267,7 @@ let to_array arr = let new_methods_variables table meths vals = let meths = to_array meths in let nmeths = Array.length meths and nvals = Array.length vals in - let res = Array.create (nmeths + nvals) 0 in + let res = Array.make (nmeths + nvals) 0 in for i = 0 to nmeths - 1 do res.(i) <- get_method_label table meths.(i) done; diff --git a/stdlib/digest.ml b/stdlib/digest.ml index 2baf3dbfa..14cb4ebd9 100644 --- a/stdlib/digest.ml +++ b/stdlib/digest.ml @@ -23,11 +23,15 @@ external channel: in_channel -> int -> t = "caml_md5_chan" let string str = unsafe_string str 0 (String.length str) +let bytes b = string (Bytes.unsafe_to_string b) + let substring str ofs len = if ofs < 0 || len < 0 || ofs > String.length str - len then invalid_arg "Digest.substring" else unsafe_string str ofs len +let subbytes b ofs len = substring (Bytes.unsafe_to_string b) ofs len + let file filename = let ic = open_in_bin filename in let d = channel ic (-1) in @@ -35,23 +39,21 @@ let file filename = d let output chan digest = - output chan digest 0 16 + output_string chan digest -let input chan = - let digest = String.create 16 in - really_input chan digest 0 16; - digest +let input chan = really_input_string chan 16 -let char_hex n = Char.unsafe_chr (n + if n < 10 then Char.code '0' else (Char.code 'a' - 10)) +let char_hex n = + Char.unsafe_chr (n + if n < 10 then Char.code '0' else (Char.code 'a' - 10)) let to_hex d = - let result = String.create 32 in + let result = Bytes.create 32 in for i = 0 to 15 do let x = Char.code d.[i] in - String.unsafe_set result (i*2) (char_hex (x lsr 4)); - String.unsafe_set result (i*2+1) (char_hex (x land 0x0f)); + Bytes.unsafe_set result (i*2) (char_hex (x lsr 4)); + Bytes.unsafe_set result (i*2+1) (char_hex (x land 0x0f)); done; - result + Bytes.unsafe_to_string result let from_hex s = if String.length s <> 32 then raise (Invalid_argument "Digest.from_hex"); @@ -63,8 +65,8 @@ let from_hex s = | _ -> raise (Invalid_argument "Digest.from_hex") in let byte i = digit s.[i] lsl 4 + digit s.[i+1] in - let result = String.create 16 in + let result = Bytes.create 16 in for i = 0 to 15 do - result.[i] <- Char.chr (byte (2 * i)); + Bytes.set result i (Char.chr (byte (2 * i))); done; - result + Bytes.unsafe_to_string result diff --git a/stdlib/digest.mli b/stdlib/digest.mli index 7fa1f15d6..583d2a46b 100644 --- a/stdlib/digest.mli +++ b/stdlib/digest.mli @@ -36,10 +36,16 @@ val compare : t -> t -> int val string : string -> t (** Return the digest of the given string. *) +val bytes : bytes -> t +(** Return the digest of the given byte sequence. *) + val substring : string -> int -> int -> t (** [Digest.substring s ofs len] returns the digest of the substring - of [s] starting at character number [ofs] and containing [len] - characters. *) + of [s] starting at index [ofs] and containing [len] characters. *) + +val subbytes : bytes -> int -> int -> t +(** [Digest.subbytes s ofs len] returns the digest of the subsequence + of [s] starting at index [ofs] and containing [len] bytes. *) external channel : in_channel -> int -> t = "caml_md5_chan" (** If [len] is nonnegative, [Digest.channel ic len] reads [len] diff --git a/stdlib/filename.mli b/stdlib/filename.mli index c44c6d954..a4ea3aaab 100644 --- a/stdlib/filename.mli +++ b/stdlib/filename.mli @@ -117,14 +117,13 @@ val set_temp_dir_name : string -> unit @since 4.00.0 *) -val temp_dir_name : string -(** @deprecated The name of the initial temporary directory: +val temp_dir_name : string [@@ocaml.deprecated] +(** The name of the initial temporary directory: Under Unix, the value of the [TMPDIR] environment variable, or "/tmp" if the variable is not set. Under Windows, the value of the [TEMP] environment variable, or "." if the variable is not set. - This function is deprecated; {!Filename.get_temp_dir_name} should be - used instead. + @deprecated You should use {!Filename.get_temp_dir_name} instead. @since 3.09.1 *) diff --git a/stdlib/format.ml b/stdlib/format.ml index 02222932e..5e206e11f 100644 --- a/stdlib/format.ml +++ b/stdlib/format.ml @@ -29,6 +29,10 @@ external int_of_size : size -> int = "%identity" (* Tokens are one of the following : *) +type block_type + = CamlinternalFormatBasics.block_type + = Pp_hbox | Pp_vbox | Pp_hvbox | Pp_hovbox | Pp_box | Pp_fits + type pp_token = | Pp_text of string (* normal text *) | Pp_break of int * int (* complete break *) @@ -46,21 +50,7 @@ type pp_token = and tag = string -and block_type = -| Pp_hbox (* Horizontal block no line breaking *) -| Pp_vbox (* Vertical block each break leads to a new line *) -| Pp_hvbox (* Horizontal-vertical block: same as vbox, except if this block - is small enough to fit on a single line *) -| Pp_hovbox (* Horizontal or Vertical block: breaks lead to new line - only when necessary to print the content of the block *) -| Pp_box (* Horizontal or Indent block: breaks lead to new line - only when necessary to print the content of the block, or - when it leads to a new indentation of the current line *) -| Pp_fits (* Internal usage: when a block fits on a single line *) - -and tblock = - | Pp_tbox of int list ref (* Tabulation box *) -;; +and tblock = Pp_tbox of int list ref (* Tabulation box *) (* The Queue: contains all formatting elements. @@ -241,7 +231,6 @@ let pp_infinity = 1000000010;; let pp_output_string state s = state.pp_out_string s 0 (String.length s) and pp_output_newline state = state.pp_out_newline () and pp_output_spaces state n = state.pp_out_spaces n -;; (* To format a break, indenting a new line. *) let break_new_line state offset width = @@ -657,9 +646,7 @@ let pp_print_bool state b = pp_print_string state (string_of_bool b);; (* To format a char. *) let pp_print_char state c = - let s = String.create 1 in - s.[0] <- c; - pp_print_as state 1 s + pp_print_as state 1 (String.make 1 c) ;; (* Opening boxes. *) @@ -901,7 +888,7 @@ let rec display_blanks state n = ;; let pp_set_formatter_out_channel state os = - state.pp_out_string <- output os; + state.pp_out_string <- output_substring os; state.pp_out_flush <- (fun () -> flush os); state.pp_out_newline <- display_newline state; state.pp_out_spaces <- display_blanks state; @@ -967,7 +954,7 @@ let make_formatter output flush = ;; let formatter_of_out_channel oc = - make_formatter (output oc) (fun () -> flush oc) + make_formatter (output_substring oc) (fun () -> flush oc) ;; let formatter_of_buffer b = @@ -1071,309 +1058,106 @@ and set_tags = pp_set_tags std_formatter ;; - -(************************************************************** - - Printf implementation. - - **************************************************************) - -module Sformat = Printf.CamlinternalPr.Sformat;; -module Tformat = Printf.CamlinternalPr.Tformat;; - -(* Error messages when processing formats. *) - -(* Trailer: giving up at character number ... *) -let giving_up mess fmt i = - Printf.sprintf - "Format.fprintf: %s \'%s\', giving up at character number %d%s" - mess (Sformat.to_string fmt) i - (if i < Sformat.length fmt - then Printf.sprintf " (%c)." (Sformat.get fmt i) - else Printf.sprintf "%c" '.') -;; - -(* When an invalid format deserves a special error explanation. *) -let format_invalid_arg mess fmt i = invalid_arg (giving_up mess fmt i);; - -(* Standard invalid format. *) -let invalid_format fmt i = format_invalid_arg "bad format" fmt i;; - -(* Cannot find a valid integer into that format. *) -let invalid_integer fmt i = - invalid_arg (giving_up "bad integer specification" fmt i);; - -(* Finding an integer size out of a sub-string of the format. *) -let format_int_of_string fmt i s = - let sz = - try int_of_string s with - | Failure _ -> invalid_integer fmt i in - size_of_int sz -;; - -(* Getting strings out of buffers. *) -let get_buffer_out b = - let s = Buffer.contents b in - Buffer.reset b; - s -;; - -(* [ppf] is supposed to be a pretty-printer that outputs to buffer [b]: - to extract the contents of [ppf] as a string we flush [ppf] and get the - string out of [b]. *) -let string_out b ppf = - pp_flush_queue ppf false; - get_buffer_out b -;; - -(* Applies [printer] to a formatter that outputs on a fresh buffer, - then returns the resulting material. *) -let exstring printer arg = - let b = Buffer.create 512 in - let ppf = formatter_of_buffer b in - printer ppf arg; - string_out b ppf -;; - -(* To turn out a character accumulator into the proper string result. *) -let implode_rev s0 = function - | [] -> s0 - | l -> String.concat "" (List.rev (s0 :: l)) -;; - -(* [mkprintf] is the printf-like function generator: given the - - [to_s] flag that tells if we are printing into a string, - - the [get_out] function that has to be called to get a [ppf] function to - output onto, - it generates a [kprintf] function that takes as arguments a [k] - continuation function to be called at the end of formatting, - and a printing format string to print the rest of the arguments - according to the format string. - Regular [fprintf]-like functions of this module are obtained via partial - applications of [mkprintf]. *) -let mkprintf to_s get_out k fmt = - - (* [out] is global to this definition of [pr], and must be shared by all its - recursive calls (if any). *) - let out = get_out fmt in - let print_as = ref None in - let outc c = - match !print_as with - | None -> pp_print_char out c - | Some size -> - pp_print_as_size out size (String.make 1 c); - print_as := None - and outs s = - match !print_as with - | None -> pp_print_string out s - | Some size -> - pp_print_as_size out size s; - print_as := None - and flush out = pp_print_flush out () in - - let rec pr k n fmt v = - - let len = Sformat.length fmt in - - let rec doprn n i = - if i >= len then Obj.magic (k out) else - match Sformat.get fmt i with - | '%' -> - Tformat.scan_format fmt v n i cont_s cont_a cont_t cont_f cont_m - | '@' -> - let i = succ i in - if i >= len then invalid_format fmt i else - begin match Sformat.get fmt i with - | '[' -> - do_pp_open_box out n (succ i) - | ']' -> - pp_close_box out (); - doprn n (succ i) - | '{' -> - do_pp_open_tag out n (succ i) - | '}' -> - pp_close_tag out (); - doprn n (succ i) - | ' ' -> - pp_print_space out (); - doprn n (succ i) - | ',' -> - pp_print_cut out (); - doprn n (succ i) - | '?' -> - pp_print_flush out (); - doprn n (succ i) - | '.' -> - pp_print_newline out (); - doprn n (succ i) - | '\n' -> - pp_force_newline out (); - doprn n (succ i) - | ';' -> - do_pp_break out n (succ i) - | '<' -> - let got_size size n i = - print_as := Some size; - doprn n (skip_gt i) in - get_int n (succ i) got_size - | '@' -> - outc '@'; - doprn n (succ i) - | _ -> invalid_format fmt i - end - | c -> outc c; doprn n (succ i) - - and cont_s n s i = - outs s; doprn n i - and cont_a n printer arg i = - if to_s then - outs ((Obj.magic printer : unit -> _ -> string) () arg) - else - printer out arg; - doprn n i - and cont_t n printer i = - if to_s then - outs ((Obj.magic printer : unit -> string) ()) - else - printer out; - doprn n i - and cont_f n i = - flush out; doprn n i - and cont_m n xf i = - let m = - Sformat.add_int_index - (Tformat.count_printing_arguments_of_format xf) n in - pr (Obj.magic (fun _ -> doprn m i)) n xf v - - and get_int n i c = - if i >= len then invalid_integer fmt i else - match Sformat.get fmt i with - | ' ' -> get_int n (succ i) c - | '%' -> - let cont_s n s i = c (format_int_of_string fmt i s) n i - and cont_a _n _printer _arg i = invalid_integer fmt i - and cont_t _n _printer i = invalid_integer fmt i - and cont_f _n i = invalid_integer fmt i - and cont_m _n _sfmt i = invalid_integer fmt i in - Tformat.scan_format fmt v n i cont_s cont_a cont_t cont_f cont_m - | _ -> - let rec get j = - if j >= len then invalid_integer fmt j else - match Sformat.get fmt j with - | '0' .. '9' | '-' -> get (succ j) - | _ -> - let size = - if j = i then size_of_int 0 else - let s = Sformat.sub fmt (Sformat.index_of_int i) (j - i) in - format_int_of_string fmt j s in - c size n j in - get i - - and skip_gt i = - if i >= len then invalid_format fmt i else - match Sformat.get fmt i with - | ' ' -> skip_gt (succ i) - | '>' -> succ i - | _ -> invalid_format fmt i - - and get_box_kind i = - if i >= len then Pp_box, i else - match Sformat.get fmt i with - | 'h' -> - let i = succ i in - if i >= len then Pp_hbox, i else - begin match Sformat.get fmt i with - | 'o' -> - let i = succ i in - if i >= len then format_invalid_arg "bad box format" fmt i else - begin match Sformat.get fmt i with - | 'v' -> Pp_hovbox, succ i - | c -> - format_invalid_arg - ("bad box name ho" ^ String.make 1 c) fmt i - end - | 'v' -> Pp_hvbox, succ i - | _ -> Pp_hbox, i - end - | 'b' -> Pp_box, succ i - | 'v' -> Pp_vbox, succ i - | _ -> Pp_box, i - - and get_tag_name n i c = - let rec get accu n i j = - if j >= len then - c (implode_rev - (Sformat.sub fmt (Sformat.index_of_int i) (j - i)) - accu) - n j else - match Sformat.get fmt j with - | '>' -> - c (implode_rev - (Sformat.sub fmt (Sformat.index_of_int i) (j - i)) - accu) - n j - | '%' -> - let s0 = Sformat.sub fmt (Sformat.index_of_int i) (j - i) in - let cont_s n s i = get (s :: s0 :: accu) n i i - and cont_a n printer arg i = - let s = - if to_s - then (Obj.magic printer : unit -> _ -> string) () arg - else exstring printer arg in - get (s :: s0 :: accu) n i i - and cont_t n printer i = - let s = - if to_s - then (Obj.magic printer : unit -> string) () - else exstring (fun ppf () -> printer ppf) () in - get (s :: s0 :: accu) n i i - and cont_f _n i = - format_invalid_arg "bad tag name specification" fmt i - and cont_m _n _sfmt i = - format_invalid_arg "bad tag name specification" fmt i in - Tformat.scan_format fmt v n j cont_s cont_a cont_t cont_f cont_m - | _ -> get accu n i (succ j) in - get [] n i i - - and do_pp_break ppf n i = - if i >= len then begin pp_print_space ppf (); doprn n i end else - match Sformat.get fmt i with - | '<' -> - let rec got_nspaces nspaces n i = - get_int n i (got_offset nspaces) - and got_offset nspaces offset n i = - pp_print_break ppf (int_of_size nspaces) (int_of_size offset); - doprn n (skip_gt i) in - get_int n (succ i) got_nspaces - | _c -> pp_print_space ppf (); doprn n i - - and do_pp_open_box ppf n i = - if i >= len then begin pp_open_box_gen ppf 0 Pp_box; doprn n i end else - match Sformat.get fmt i with - | '<' -> - let kind, i = get_box_kind (succ i) in - let got_size size n i = - pp_open_box_gen ppf (int_of_size size) kind; - doprn n (skip_gt i) in - get_int n i got_size - | _c -> pp_open_box_gen ppf 0 Pp_box; doprn n i - - and do_pp_open_tag ppf n i = - if i >= len then begin pp_open_tag ppf ""; doprn n i end else - match Sformat.get fmt i with - | '<' -> - let got_name tag_name n i = - pp_open_tag ppf tag_name; - doprn n (skip_gt i) in - get_tag_name n (succ i) got_name - | _c -> pp_open_tag ppf ""; doprn n i in - - doprn n 0 in - - let kpr = pr k (Sformat.index_of_int 0) in - - Tformat.kapr kpr fmt -;; + (**************************************************************) + +let compute_tag output tag_acc = + let buf = Buffer.create 16 in + let ppf = formatter_of_buffer buf in + let () = output ppf tag_acc in + let () = pp_print_flush ppf () in + let len = Buffer.length buf in + if len < 2 then Buffer.contents buf + else Buffer.sub buf 1 (len - 2) + + (************************************************************** + + Defining continuations to be passed as arguments of + CamlinternalFormat.make_printf. + + **************************************************************) + +open CamlinternalFormatBasics +open CamlinternalFormat + +(* Interpret a formatting entity on a formatter. *) +let output_formatting_lit ppf fmting_lit = match fmting_lit with + | Close_box -> pp_close_box ppf () + | Close_tag -> pp_close_tag ppf () + | Break (_, width, offset) -> pp_print_break ppf width offset + | FFlush -> pp_print_flush ppf () + | Force_newline -> pp_force_newline ppf () + | Flush_newline -> pp_print_newline ppf () + | Magic_size (_, _) -> () + | Escaped_at -> pp_print_char ppf '@' + | Escaped_percent -> pp_print_char ppf '%' + | Scan_indic c -> pp_print_char ppf '@'; pp_print_char ppf c + +(* Recursively output an "accumulator" containing a reversed list of + printing entities (string, char, flus, ...) in an output_stream. *) +(* Differ from Printf.output_acc by the interpretation of formatting. *) +(* Used as a continuation of CamlinternalFormat.make_printf. *) +let rec output_acc ppf acc = match acc with + | Acc_string_literal (Acc_formatting_lit (p, Magic_size (_, size)), s) + | Acc_data_string (Acc_formatting_lit (p, Magic_size (_, size)), s) -> + output_acc ppf p; + pp_print_as_size ppf (size_of_int size) s; + | Acc_char_literal (Acc_formatting_lit (p, Magic_size (_, size)), c) + | Acc_data_char (Acc_formatting_lit (p, Magic_size (_, size)), c) -> + output_acc ppf p; + pp_print_as_size ppf (size_of_int size) (String.make 1 c); + | Acc_formatting_lit (p, f) -> + output_acc ppf p; + output_formatting_lit ppf f; + | Acc_formatting_gen (p, Acc_open_tag acc') -> + output_acc ppf p; + pp_open_tag ppf (compute_tag output_acc acc') + | Acc_formatting_gen (p, Acc_open_box acc') -> + let () = output_acc ppf p in + let (indent, bty) = open_box_of_string (compute_tag output_acc acc') in + pp_open_box_gen ppf indent bty + | Acc_string_literal (p, s) + | Acc_data_string (p, s) -> output_acc ppf p; pp_print_string ppf s; + | Acc_char_literal (p, c) + | Acc_data_char (p, c) -> output_acc ppf p; pp_print_char ppf c; + | Acc_delay (p, f) -> output_acc ppf p; f ppf; + | Acc_flush p -> output_acc ppf p; pp_print_flush ppf (); + | Acc_invalid_arg (p, msg) -> output_acc ppf p; invalid_arg msg; + | End_of_acc -> () + +(* Recursively output an "accumulator" containing a reversed list of + printing entities (string, char, flus, ...) in a buffer. *) +(* Differ from Printf.bufput_acc by the interpretation of formatting. *) +(* Used as a continuation of CamlinternalFormat.make_printf. *) +let rec strput_acc ppf acc = match acc with + | Acc_string_literal (Acc_formatting_lit (p, Magic_size (_, size)), s) + | Acc_data_string (Acc_formatting_lit (p, Magic_size (_, size)), s) -> + strput_acc ppf p; + pp_print_as_size ppf (size_of_int size) s; + | Acc_char_literal (Acc_formatting_lit (p, Magic_size (_, size)), c) + | Acc_data_char (Acc_formatting_lit (p, Magic_size (_, size)), c) -> + strput_acc ppf p; + pp_print_as_size ppf (size_of_int size) (String.make 1 c); + | Acc_delay (Acc_formatting_lit (p, Magic_size (_, size)), f) -> + strput_acc ppf p; + pp_print_as_size ppf (size_of_int size) (f ()); + | Acc_formatting_lit (p, f) -> + strput_acc ppf p; + output_formatting_lit ppf f; + | Acc_formatting_gen (p, Acc_open_tag acc') -> + strput_acc ppf p; + pp_open_tag ppf (compute_tag strput_acc acc') + | Acc_formatting_gen (p, Acc_open_box acc') -> + let () = strput_acc ppf p in + let (indent, bty) = open_box_of_string (compute_tag strput_acc acc') in + pp_open_box_gen ppf indent bty + | Acc_string_literal (p, s) + | Acc_data_string (p, s) -> strput_acc ppf p; pp_print_string ppf s; + | Acc_char_literal (p, c) + | Acc_data_char (p, c) -> strput_acc ppf p; pp_print_char ppf c; + | Acc_delay (p, f) -> strput_acc ppf p; pp_print_string ppf (f ()); + | Acc_flush p -> strput_acc ppf p; pp_print_flush ppf (); + | Acc_invalid_arg (p, msg) -> strput_acc ppf p; invalid_arg msg; + | End_of_acc -> () (************************************************************** @@ -1381,30 +1165,37 @@ let mkprintf to_s get_out k fmt = **************************************************************) -let kfprintf k ppf = mkprintf false (fun _ -> ppf) k;; -let ikfprintf k ppf = Tformat.kapr (fun _ _ -> Obj.magic (k ppf));; - -let fprintf ppf = kfprintf ignore ppf;; -let ifprintf ppf = ikfprintf ignore ppf;; -let printf fmt = fprintf std_formatter fmt;; -let eprintf fmt = fprintf err_formatter fmt;; - -let ksprintf k = +let kfprintf k o (Format (fmt, _)) = + make_printf (fun o acc -> output_acc o acc; k o) o End_of_acc fmt +let ikfprintf k x (Format (fmt, _)) = + make_printf (fun _ _ -> k x) x End_of_acc fmt + +let fprintf ppf fmt = kfprintf ignore ppf fmt +let ifprintf ppf fmt = ikfprintf ignore ppf fmt +let printf fmt = fprintf std_formatter fmt +let eprintf fmt = fprintf err_formatter fmt + +let ksprintf k (Format (fmt, _)) = + let k' () acc = + let b = Buffer.create 512 in + let ppf = formatter_of_buffer b in + strput_acc ppf acc; + pp_flush_queue ppf false; + k (Buffer.contents b) in + make_printf k' () End_of_acc fmt + +let sprintf fmt = + ksprintf (fun s -> s) fmt + +let asprintf (Format (fmt, _)) = let b = Buffer.create 512 in - let k ppf = k (string_out b ppf) in let ppf = formatter_of_buffer b in - let get_out _ = ppf in - mkprintf true get_out k -;; - -let sprintf fmt = ksprintf (fun s -> s) fmt;; - -let asprintf fmt = - let b = Buffer.create 512 in - let k ppf = string_out b ppf in - let ppf = formatter_of_buffer b in - let get_out _ = ppf in - mkprintf false get_out k fmt;; + let k' : (formatter -> (formatter, unit) acc -> string) + = fun ppf acc -> + output_acc ppf acc; + pp_flush_queue ppf false; + Buffer.contents b in + make_printf k' ppf End_of_acc fmt (************************************************************** @@ -1412,15 +1203,10 @@ let asprintf fmt = **************************************************************) -let kbprintf k b = - mkprintf false (fun _ -> formatter_of_buffer b) k -;; - (* Deprecated error prone function bprintf. *) -let bprintf b = - let k ppf = pp_flush_queue ppf false in - kbprintf k b -;; +let bprintf b (Format (fmt, _) : ('a, formatter, unit) format) = + let k ppf acc = output_acc ppf acc; pp_flush_queue ppf false in + make_printf k (formatter_of_buffer b) End_of_acc fmt (* Deprecated alias for ksprintf. *) let kprintf = ksprintf;; diff --git a/stdlib/format.mli b/stdlib/format.mli index e7cbe506e..b44fc0a94 100644 --- a/stdlib/format.mli +++ b/stdlib/format.mli @@ -714,14 +714,18 @@ val ksprintf : (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b;; (** {6 Deprecated} *) -val bprintf : Buffer.t -> ('a, formatter, unit) format -> 'a;; +val bprintf : Buffer.t -> ('a, formatter, unit) format -> 'a + [@@ocaml.deprecated] +;; (** @deprecated This function is error prone. Do not use it. If you need to print to some buffer [b], you must first define a formatter writing to [b], using [let to_b = formatter_of_buffer b]; then use regular calls to [Format.fprintf] on formatter [to_b]. *) -val kprintf : (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b;; +val kprintf : (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b + [@@ocaml.deprecated] +;; (** @deprecated An alias for [ksprintf]. *) val set_all_formatter_output_functions : @@ -730,6 +734,7 @@ val set_all_formatter_output_functions : newline:(unit -> unit) -> spaces:(int -> unit) -> unit +[@@ocaml.deprecated] ;; (** @deprecated Subsumed by [set_formatter_out_functions]. *) @@ -740,12 +745,14 @@ val get_all_formatter_output_functions : (unit -> unit) * (unit -> unit) * (int -> unit) +[@@ocaml.deprecated] ;; (** @deprecated Subsumed by [get_formatter_out_functions]. *) val pp_set_all_formatter_output_functions : formatter -> out:(string -> int -> int -> unit) -> flush:(unit -> unit) -> newline:(unit -> unit) -> spaces:(int -> unit) -> unit +[@@ocaml.deprecated] ;; (** @deprecated Subsumed by [pp_set_formatter_out_functions]. *) @@ -754,6 +761,7 @@ val pp_get_all_formatter_output_functions : formatter -> unit -> (string -> int -> int -> unit) * (unit -> unit) * (unit -> unit) * (int -> unit) +[@@ocaml.deprecated] ;; (** @deprecated Subsumed by [pp_get_formatter_out_functions]. *) diff --git a/stdlib/gc.mli b/stdlib/gc.mli index d2f2d9761..f86a1e687 100644 --- a/stdlib/gc.mli +++ b/stdlib/gc.mli @@ -83,7 +83,7 @@ type stat = type control = { mutable minor_heap_size : int; (** The size (in words) of the minor heap. Changing - this parameter will trigger a minor collection. Default: 32k. *) + this parameter will trigger a minor collection. Default: 256k. *) mutable major_heap_increment : int; (** How much to add to the major heap when increasing it. If this @@ -131,7 +131,7 @@ type control = mutable stack_limit : int; (** The maximum size of the stack (in words). This is only relevant to the byte-code runtime, as the native code runtime - uses the operating system's stack. Default: 256k. *) + uses the operating system's stack. Default: 1024k. *) mutable allocation_policy : int; (** The policy used for allocating in the heap. Possible @@ -215,6 +215,9 @@ val finalise : ('a -> unit) -> 'a -> unit before the values it depends upon. Of course, this becomes false if additional dependencies are introduced by assignments. + In the presence of multiple OCaml threads it should be assumed that + any particular finaliser may be executed in any of the threads. + Anything reachable from the closure of finalisation functions is considered reachable, so the following code will not work as expected: @@ -249,7 +252,7 @@ val finalise : ('a -> unit) -> 'a -> unit another copy is still in use by the program. - The results of calling {!String.make}, {!String.create}, + The results of calling {!String.make}, {!Bytes.make}, {!Bytes.create}, {!Array.make}, and {!Pervasives.ref} are guaranteed to be heap-allocated and non-constant except when the length argument is [0]. *) diff --git a/stdlib/genlex.ml b/stdlib/genlex.ml index dc80727df..4f52b1865 100644 --- a/stdlib/genlex.ml +++ b/stdlib/genlex.ml @@ -21,7 +21,7 @@ type token = (* The string buffering machinery *) -let initial_buffer = String.create 32 +let initial_buffer = Bytes.create 32 let buffer = ref initial_buffer let bufpos = ref 0 @@ -29,16 +29,16 @@ let bufpos = ref 0 let reset_buffer () = buffer := initial_buffer; bufpos := 0 let store c = - if !bufpos >= String.length !buffer then - begin - let newbuffer = String.create (2 * !bufpos) in - String.blit !buffer 0 newbuffer 0 !bufpos; buffer := newbuffer - end; - String.set !buffer !bufpos c; + if !bufpos >= Bytes.length !buffer then begin + let newbuffer = Bytes.create (2 * !bufpos) in + Bytes.blit !buffer 0 newbuffer 0 !bufpos; + buffer := newbuffer + end; + Bytes.set !buffer !bufpos c; incr bufpos let get_string () = - let s = String.sub !buffer 0 !bufpos in buffer := initial_buffer; s + let s = Bytes.sub_string !buffer 0 !bufpos in buffer := initial_buffer; s (* The lexer *) diff --git a/stdlib/hashtbl.mli b/stdlib/hashtbl.mli index 5424df40d..0c3e4999f 100644 --- a/stdlib/hashtbl.mli +++ b/stdlib/hashtbl.mli @@ -187,6 +187,34 @@ val stats : ('a, 'b) t -> statistics (** {6 Functorial interface} *) +(** The functorial interface allows the use of specific comparison + and hash functions, either for performance/security concerns, + or because keys are not hashable/comparable with the polymorphic builtins. + + For instance, one might want to specialize a table for integer keys: + {[ + module IntHash = + struct + type t = int + let equal i j = i=j + let hash i = i land max_int + end + + module IntHashtbl = Hashtbl.Make(IntHash) + + let h = IntHashtbl.create 17 in + IntHashtbl.add h 12 "hello";; + ]} + + This creates a new module [IntHashtbl], with a new type ['a + IntHashtbl.t] of tables from [int] to ['a]. In this example, [h] + contains [string] values so its type is [string IntHashtbl.t]. + + Note that the new type ['a IntHashtbl.t] is not compatible with + the type [('a,'b) Hashtbl.t] of the generic interface. For + example, [Hashtbl.length h] would not type-check, you must use + [IntHashtbl.length]. +*) module type HashedType = sig diff --git a/stdlib/header.c b/stdlib/header.c index cb3d9953a..93cdfeb2d 100644 --- a/stdlib/header.c +++ b/stdlib/header.c @@ -133,7 +133,7 @@ static char * read_runtime_path(int fd) char buffer[TRAILER_SIZE]; static char runtime_path[MAXPATHLEN]; int num_sections, i; - uint32 path_size; + uint32_t path_size; long ofs; lseek(fd, (long) -TRAILER_SIZE, SEEK_END); diff --git a/stdlib/lazy.mli b/stdlib/lazy.mli index 6108a715c..6ade2e3d4 100644 --- a/stdlib/lazy.mli +++ b/stdlib/lazy.mli @@ -75,11 +75,11 @@ val is_val : 'a t -> bool;; did not raise an exception. @since 4.00.0 *) -val lazy_from_fun : (unit -> 'a) -> 'a t;; +val lazy_from_fun : (unit -> 'a) -> 'a t [@@ocaml.deprecated];; (** @deprecated synonym for [from_fun]. *) -val lazy_from_val : 'a -> 'a t;; +val lazy_from_val : 'a -> 'a t [@@ocaml.deprecated];; (** @deprecated synonym for [from_val]. *) -val lazy_is_val : 'a t -> bool;; +val lazy_is_val : 'a t -> bool [@@ocaml.deprecated];; (** @deprecated synonym for [is_val]. *) diff --git a/stdlib/lexing.ml b/stdlib/lexing.ml index 53748ad86..d2231fbe9 100644 --- a/stdlib/lexing.ml +++ b/stdlib/lexing.ml @@ -29,7 +29,7 @@ let dummy_pos = { type lexbuf = { refill_buff : lexbuf -> unit; - mutable lex_buffer : string; + mutable lex_buffer : bytes; mutable lex_buffer_len : int; mutable lex_abs_pos : int; mutable lex_start_pos : int; @@ -81,7 +81,7 @@ let new_engine tbl state buf = let lex_refill read_fun aux_buffer lexbuf = let read = - read_fun aux_buffer (String.length aux_buffer) in + read_fun aux_buffer (Bytes.length aux_buffer) in let n = if read > 0 then read @@ -90,16 +90,16 @@ let lex_refill read_fun aux_buffer lexbuf = <-------|---------------------|-----------> | junk | valid data | junk | ^ ^ ^ ^ - 0 start_pos buffer_end String.length buffer + 0 start_pos buffer_end Bytes.length buffer *) - if lexbuf.lex_buffer_len + n > String.length lexbuf.lex_buffer then begin + if lexbuf.lex_buffer_len + n > Bytes.length lexbuf.lex_buffer then begin (* There is not enough space at the end of the buffer *) if lexbuf.lex_buffer_len - lexbuf.lex_start_pos + n - <= String.length lexbuf.lex_buffer + <= Bytes.length lexbuf.lex_buffer then begin (* But there is enough space if we reclaim the junk at the beginning of the buffer *) - String.blit lexbuf.lex_buffer lexbuf.lex_start_pos + Bytes.blit lexbuf.lex_buffer lexbuf.lex_start_pos lexbuf.lex_buffer 0 (lexbuf.lex_buffer_len - lexbuf.lex_start_pos) end else begin @@ -107,12 +107,12 @@ let lex_refill read_fun aux_buffer lexbuf = space since n <= String.length aux_buffer <= String.length buffer. Watch out for string length overflow, though. *) let newlen = - min (2 * String.length lexbuf.lex_buffer) Sys.max_string_length in + min (2 * Bytes.length lexbuf.lex_buffer) Sys.max_string_length in if lexbuf.lex_buffer_len - lexbuf.lex_start_pos + n > newlen then failwith "Lexing.lex_refill: cannot grow buffer"; - let newbuf = String.create newlen in + let newbuf = Bytes.create newlen in (* Copy the valid data to the beginning of the new buffer *) - String.blit lexbuf.lex_buffer lexbuf.lex_start_pos + Bytes.blit lexbuf.lex_buffer lexbuf.lex_start_pos newbuf 0 (lexbuf.lex_buffer_len - lexbuf.lex_start_pos); lexbuf.lex_buffer <- newbuf @@ -133,9 +133,7 @@ let lex_refill read_fun aux_buffer lexbuf = done end; (* There is now enough space at the end of the buffer *) - String.blit aux_buffer 0 - lexbuf.lex_buffer lexbuf.lex_buffer_len - n; + Bytes.blit aux_buffer 0 lexbuf.lex_buffer lexbuf.lex_buffer_len n; lexbuf.lex_buffer_len <- lexbuf.lex_buffer_len + n let zero_pos = { @@ -146,8 +144,8 @@ let zero_pos = { };; let from_function f = - { refill_buff = lex_refill f (String.create 512); - lex_buffer = String.create 1024; + { refill_buff = lex_refill f (Bytes.create 512); + lex_buffer = Bytes.create 1024; lex_buffer_len = 0; lex_abs_pos = 0; lex_start_pos = 0; @@ -165,7 +163,8 @@ let from_channel ic = let from_string s = { refill_buff = (fun lexbuf -> lexbuf.lex_eof_reached <- true); - lex_buffer = s ^ ""; + lex_buffer = Bytes.of_string s; (* have to make a copy for compatibility + with unsafe-string mode *) lex_buffer_len = String.length s; lex_abs_pos = 0; lex_start_pos = 0; @@ -180,37 +179,31 @@ let from_string s = let lexeme lexbuf = let len = lexbuf.lex_curr_pos - lexbuf.lex_start_pos in - let s = String.create len in - String.unsafe_blit lexbuf.lex_buffer lexbuf.lex_start_pos s 0 len; - s + Bytes.sub_string lexbuf.lex_buffer lexbuf.lex_start_pos len let sub_lexeme lexbuf i1 i2 = let len = i2-i1 in - let s = String.create len in - String.unsafe_blit lexbuf.lex_buffer i1 s 0 len; - s + Bytes.sub_string lexbuf.lex_buffer i1 len let sub_lexeme_opt lexbuf i1 i2 = if i1 >= 0 then begin let len = i2-i1 in - let s = String.create len in - String.unsafe_blit lexbuf.lex_buffer i1 s 0 len; - Some s + Some (Bytes.sub_string lexbuf.lex_buffer i1 len) end else begin None end -let sub_lexeme_char lexbuf i = lexbuf.lex_buffer.[i] +let sub_lexeme_char lexbuf i = Bytes.get lexbuf.lex_buffer i let sub_lexeme_char_opt lexbuf i = if i >= 0 then - Some lexbuf.lex_buffer.[i] + Some (Bytes.get lexbuf.lex_buffer i) else None let lexeme_char lexbuf i = - String.get lexbuf.lex_buffer (lexbuf.lex_start_pos + i) + Bytes.get lexbuf.lex_buffer (lexbuf.lex_start_pos + i) let lexeme_start lexbuf = lexbuf.lex_start_p.pos_cnum;; let lexeme_end lexbuf = lexbuf.lex_curr_p.pos_cnum;; diff --git a/stdlib/lexing.mli b/stdlib/lexing.mli index 6d5406d69..30898670b 100644 --- a/stdlib/lexing.mli +++ b/stdlib/lexing.mli @@ -46,7 +46,7 @@ val dummy_pos : position;; type lexbuf = { refill_buff : lexbuf -> unit; - mutable lex_buffer : string; + mutable lex_buffer : bytes; mutable lex_buffer_len : int; mutable lex_abs_pos : int; mutable lex_start_pos : int; @@ -84,12 +84,12 @@ val from_string : string -> lexbuf the string. An end-of-input condition is generated when the end of the string is reached. *) -val from_function : (string -> int -> int) -> lexbuf +val from_function : (bytes -> int -> int) -> lexbuf (** Create a lexer buffer with the given function as its reading method. When the scanner needs more characters, it will call the given - function, giving it a character string [s] and a character - count [n]. The function should put [n] characters or less in [s], - starting at character number 0, and return the number of characters + function, giving it a byte sequence [s] and a byte + count [n]. The function should put [n] bytes or fewer in [s], + starting at index 0, and return the number of bytes provided. A return value of 0 means end of input. *) diff --git a/stdlib/list.mli b/stdlib/list.mli index 5b88f229d..b53a63c64 100644 --- a/stdlib/list.mli +++ b/stdlib/list.mli @@ -112,14 +112,14 @@ val fold_right : ('a -> 'b -> 'b) -> 'a list -> 'b -> 'b val iter2 : ('a -> 'b -> unit) -> 'a list -> 'b list -> unit (** [List.iter2 f [a1; ...; an] [b1; ...; bn]] calls in turn [f a1 b1; ...; f an bn]. - Raise [Invalid_argument] if the two lists have - different lengths. *) + Raise [Invalid_argument] if the two lists are determined + to have different lengths. *) val map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list (** [List.map2 f [a1; ...; an] [b1; ...; bn]] is [[f a1 b1; ...; f an bn]]. - Raise [Invalid_argument] if the two lists have - different lengths. Not tail-recursive. *) + Raise [Invalid_argument] if the two lists are determined + to have different lengths. Not tail-recursive. *) val rev_map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list (** [List.rev_map2 f l1 l2] gives the same result as @@ -129,14 +129,14 @@ val rev_map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list val fold_left2 : ('a -> 'b -> 'c -> 'a) -> 'a -> 'b list -> 'c list -> 'a (** [List.fold_left2 f a [b1; ...; bn] [c1; ...; cn]] is [f (... (f (f a b1 c1) b2 c2) ...) bn cn]. - Raise [Invalid_argument] if the two lists have - different lengths. *) + Raise [Invalid_argument] if the two lists are determined + to have different lengths. *) val fold_right2 : ('a -> 'b -> 'c -> 'c) -> 'a list -> 'b list -> 'c -> 'c (** [List.fold_right2 f [a1; ...; an] [b1; ...; bn] c] is [f a1 b1 (f a2 b2 (... (f an bn c) ...))]. - Raise [Invalid_argument] if the two lists have - different lengths. Not tail-recursive. *) + Raise [Invalid_argument] if the two lists are determined + to have different lengths. Not tail-recursive. *) (** {6 List scanning} *) @@ -154,13 +154,13 @@ val exists : ('a -> bool) -> 'a list -> bool val for_all2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool (** Same as {!List.for_all}, but for a two-argument predicate. - Raise [Invalid_argument] if the two lists have - different lengths. *) + Raise [Invalid_argument] if the two lists are determined + to have different lengths. *) val exists2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool (** Same as {!List.exists}, but for a two-argument predicate. - Raise [Invalid_argument] if the two lists have - different lengths. *) + Raise [Invalid_argument] if the two lists are determined + to have different lengths. *) val mem : 'a -> 'a list -> bool (** [mem a l] is true if and only if [a] is equal diff --git a/stdlib/listLabels.mli b/stdlib/listLabels.mli index 8cf651471..45e3c41ea 100644 --- a/stdlib/listLabels.mli +++ b/stdlib/listLabels.mli @@ -112,14 +112,14 @@ val fold_right : f:('a -> 'b -> 'b) -> 'a list -> init:'b -> 'b val iter2 : f:('a -> 'b -> unit) -> 'a list -> 'b list -> unit (** [List.iter2 f [a1; ...; an] [b1; ...; bn]] calls in turn [f a1 b1; ...; f an bn]. - Raise [Invalid_argument] if the two lists have - different lengths. *) + Raise [Invalid_argument] if the two lists are determined + to have different lengths. *) val map2 : f:('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list (** [List.map2 f [a1; ...; an] [b1; ...; bn]] is [[f a1 b1; ...; f an bn]]. - Raise [Invalid_argument] if the two lists have - different lengths. Not tail-recursive. *) + Raise [Invalid_argument] if the two lists are determined + to have different lengths. Not tail-recursive. *) val rev_map2 : f:('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list (** [List.rev_map2 f l1 l2] gives the same result as @@ -130,15 +130,15 @@ val fold_left2 : f:('a -> 'b -> 'c -> 'a) -> init:'a -> 'b list -> 'c list -> 'a (** [List.fold_left2 f a [b1; ...; bn] [c1; ...; cn]] is [f (... (f (f a b1 c1) b2 c2) ...) bn cn]. - Raise [Invalid_argument] if the two lists have - different lengths. *) + Raise [Invalid_argument] if the two lists are determined + to have different lengths. *) val fold_right2 : f:('a -> 'b -> 'c -> 'c) -> 'a list -> 'b list -> init:'c -> 'c (** [List.fold_right2 f [a1; ...; an] [b1; ...; bn] c] is [f a1 b1 (f a2 b2 (... (f an bn c) ...))]. - Raise [Invalid_argument] if the two lists have - different lengths. Not tail-recursive. *) + Raise [Invalid_argument] if the two lists are determined + to have different lengths. Not tail-recursive. *) (** {6 List scanning} *) @@ -156,13 +156,13 @@ val exists : f:('a -> bool) -> 'a list -> bool val for_all2 : f:('a -> 'b -> bool) -> 'a list -> 'b list -> bool (** Same as {!ListLabels.for_all}, but for a two-argument predicate. - Raise [Invalid_argument] if the two lists have - different lengths. *) + Raise [Invalid_argument] if the two lists are determined + to have different lengths. *) val exists2 : f:('a -> 'b -> bool) -> 'a list -> 'b list -> bool (** Same as {!ListLabels.exists}, but for a two-argument predicate. - Raise [Invalid_argument] if the two lists have - different lengths. *) + Raise [Invalid_argument] if the two lists are determined + to have different lengths. *) val mem : 'a -> set:'a list -> bool (** [mem a l] is true if and only if [a] is equal diff --git a/stdlib/map.mli b/stdlib/map.mli index 6dd371b52..abf453161 100644 --- a/stdlib/map.mli +++ b/stdlib/map.mli @@ -19,6 +19,26 @@ All operations over maps are purely applicative (no side-effects). The implementation uses balanced binary trees, and therefore searching and insertion take time logarithmic in the size of the map. + + For instance: + {[ + module IntPairs = + struct + type t = int * int + let compare (x0,y0) (x1,y1) = + match Pervasives.compare x0 x1 with + 0 -> Pervasives.compare y0 y1 + | c -> c + end + + module PairsMap = Map.Make(IntPairs) + + let m = PairsMap.(empty |> add (0,1) "hello" |> add (1,0) "world") + ]} + + This creates a new module [PairsMap], with a new type ['a PairsMap.t] + of maps from [int * int] to ['a]. In this example, [m] contains [string] + values so its type is [string PairsMap.t]. *) module type OrderedType = diff --git a/stdlib/marshal.ml b/stdlib/marshal.ml index 7a65a16a3..415559571 100644 --- a/stdlib/marshal.ml +++ b/stdlib/marshal.ml @@ -19,35 +19,48 @@ type extern_flags = external to_channel: out_channel -> 'a -> extern_flags list -> unit = "caml_output_value" +external to_bytes: 'a -> extern_flags list -> bytes + = "caml_output_value_to_string" external to_string: 'a -> extern_flags list -> string = "caml_output_value_to_string" external to_buffer_unsafe: - string -> int -> int -> 'a -> extern_flags list -> int + bytes -> int -> int -> 'a -> extern_flags list -> int = "caml_output_value_to_buffer" let to_buffer buff ofs len v flags = - if ofs < 0 || len < 0 || ofs > String.length buff - len + if ofs < 0 || len < 0 || ofs > Bytes.length buff - len then invalid_arg "Marshal.to_buffer: substring out of bounds" else to_buffer_unsafe buff ofs len v flags +(* The functions below use byte sequences as input, never using any + mutation. It makes sense to use non-mutated [bytes] rather than + [string], because we really work with sequences of bytes, not + a text representation. +*) + external from_channel: in_channel -> 'a = "caml_input_value" -external from_string_unsafe: string -> int -> 'a +external from_bytes_unsafe: bytes -> int -> 'a = "caml_input_value_from_string" -external data_size_unsafe: string -> int -> int = "caml_marshal_data_size" +external data_size_unsafe: bytes -> int -> int = "caml_marshal_data_size" let header_size = 20 let data_size buff ofs = - if ofs < 0 || ofs > String.length buff - header_size + if ofs < 0 || ofs > Bytes.length buff - header_size then invalid_arg "Marshal.data_size" else data_size_unsafe buff ofs let total_size buff ofs = header_size + data_size buff ofs -let from_string buff ofs = - if ofs < 0 || ofs > String.length buff - header_size - then invalid_arg "Marshal.from_size" +let from_bytes buff ofs = + if ofs < 0 || ofs > Bytes.length buff - header_size + then invalid_arg "Marshal.from_bytes" else begin let len = data_size_unsafe buff ofs in - if ofs > String.length buff - (header_size + len) - then invalid_arg "Marshal.from_string" - else from_string_unsafe buff ofs + if ofs > Bytes.length buff - (header_size + len) + then invalid_arg "Marshal.from_bytes" + else from_bytes_unsafe buff ofs end + +let from_string buff ofs = + (* Bytes.unsafe_of_string is safe here, as the produced byte + sequence is never mutated *) + from_bytes (Bytes.unsafe_of_string buff) ofs diff --git a/stdlib/marshal.mli b/stdlib/marshal.mli index f12af9fd9..9dfdd1624 100644 --- a/stdlib/marshal.mli +++ b/stdlib/marshal.mli @@ -33,12 +33,13 @@ Anything can happen at run-time if the object in the file does not belong to the given type. - OCaml exception values (of type [exn]) returned by the unmarhsaller - should not be pattern-matched over through [match ... with] or [try - ... with], because unmarshalling does not preserve the information - required for matching their exception constructor. Structural - equalities with other exception values, or most other uses such as - Printexc.to_string, will still work as expected. + Values of extensible variant types, for example exceptions (of + extensible type [exn]), returned by the unmarhsaller should not be + pattern-matched over through [match ... with] or [try ... with], + because unmarshalling does not preserve the information required for + matching their constructors. Structural equalities with other + extensible variant values does not work either. Most other uses such + as Printexc.to_string, will still work as expected. The representation of marshaled values is not human-readable, and uses bytes that are not printable characters. Therefore, @@ -47,7 +48,7 @@ [open_out_bin] or [open_in_bin]; channels opened in text mode will cause unmarshaling errors on platforms where text channels behave differently than binary channels, e.g. Windows. -*) + *) type extern_flags = No_sharing (** Don't preserve sharing *) @@ -74,17 +75,26 @@ val to_channel : out_channel -> 'a -> extern_flags list -> unit byte representations if [v] actually contains sharing, or even non-termination if [v] contains cycles. - If [flags] does not contain [Marshal.Closures], - marshaling fails when it encounters a functional value - inside [v]: only 'pure' data structures, containing neither - functions nor objects, can safely be transmitted between - different programs. If [flags] contains [Marshal.Closures], - functional values will be marshaled as a position in the code - of the program. In this case, the output of marshaling can - only be read back in processes that run exactly the same program, - with exactly the same compiled code. (This is checked - at un-marshaling time, using an MD5 digest of the code - transmitted along with the code position.) + If [flags] does not contain [Marshal.Closures], marshaling fails + when it encounters a functional value inside [v]: only 'pure' data + structures, containing neither functions nor objects, can safely be + transmitted between different programs. If [flags] contains + [Marshal.Closures], functional values will be marshaled as a the + position in the code of the program together with the values + corresponding to the free variables captured in the closure. In + this case, the output of marshaling can only be read back in + processes that run exactly the same program, with exactly the same + compiled code. (This is checked at un-marshaling time, using an MD5 + digest of the code transmitted along with the code position.) + + The exact definition of which free variables are captured in a + closure is not specified and can very between bytecode and native + code (and according to optimization flags). In particular, a + function value accessing a global reference may or may not include + the reference in its closure. If it does, unmarshaling the + corresponding closure will create a new reference, different from + the global one. + If [flags] contains [Marshal.Compat_32], marshaling fails when it encounters an integer value outside the range [[-2{^30}, 2{^30}-1]] @@ -99,19 +109,24 @@ val to_channel : out_channel -> 'a -> extern_flags list -> unit it has no effect if marshaling is performed on a 32-bit platform. *) -external to_string : - 'a -> extern_flags list -> string = "caml_output_value_to_string" -(** [Marshal.to_string v flags] returns a string containing - the representation of [v] as a sequence of bytes. +external to_bytes : + 'a -> extern_flags list -> bytes = "caml_output_value_to_string" +(** [Marshal.to_bytes v flags] returns a byte sequence containing + the representation of [v]. The [flags] argument has the same meaning as for {!Marshal.to_channel}. *) -val to_buffer : string -> int -> int -> 'a -> extern_flags list -> int +external to_string : + 'a -> extern_flags list -> string = "caml_output_value_to_string" +(** Same as [to_bytes] but return the result as a string instead of + a byte sequence. *) + +val to_buffer : bytes -> int -> int -> 'a -> extern_flags list -> int (** [Marshal.to_buffer buff ofs len v flags] marshals the value [v], - storing its byte representation in the string [buff], - starting at character number [ofs], and writing at most - [len] characters. It returns the number of characters - actually written to the string. If the byte representation + storing its byte representation in the sequence [buff], + starting at index [ofs], and writing at most + [len] bytes. It returns the number of bytes + actually written to the sequence. If the byte representation of [v] does not fit in [len] characters, the exception [Failure] is raised. *) @@ -121,36 +136,41 @@ val from_channel : in_channel -> 'a one of the [Marshal.to_*] functions, and reconstructs and returns the corresponding value.*) -val from_string : string -> int -> 'a -(** [Marshal.from_string buff ofs] unmarshals a structured value +val from_bytes : bytes -> int -> 'a +(** [Marshal.from_bytes buff ofs] unmarshals a structured value like {!Marshal.from_channel} does, except that the byte representation is not read from a channel, but taken from - the string [buff], starting at position [ofs]. *) + the byte sequence [buff], starting at position [ofs]. + The byte sequence is not mutated. *) + +val from_string : string -> int -> 'a +(** Same as [from_bytes] but take a string as argument instead of a + byte sequence. *) val header_size : int (** The bytes representing a marshaled value are composed of a fixed-size header and a variable-sized data part, whose size can be determined from the header. - {!Marshal.header_size} is the size, in characters, of the header. - {!Marshal.data_size}[ buff ofs] is the size, in characters, + {!Marshal.header_size} is the size, in bytes, of the header. + {!Marshal.data_size}[ buff ofs] is the size, in bytes, of the data part, assuming a valid header is stored in [buff] starting at position [ofs]. Finally, {!Marshal.total_size} [buff ofs] is the total size, - in characters, of the marshaled value. + in bytes, of the marshaled value. Both {!Marshal.data_size} and {!Marshal.total_size} raise [Failure] if [buff], [ofs] does not contain a valid header. To read the byte representation of a marshaled value into - a string buffer, the program needs to read first - {!Marshal.header_size} characters into the buffer, + a byte sequence, the program needs to read first + {!Marshal.header_size} bytes into the sequence, then determine the length of the remainder of the representation using {!Marshal.data_size}, - make sure the buffer is large enough to hold the remaining - data, then read it, and finally call {!Marshal.from_string} + make sure the sequence is large enough to hold the remaining + data, then read it, and finally call {!Marshal.from_bytes} to unmarshal the value. *) -val data_size : string -> int -> int +val data_size : bytes -> int -> int (** See {!Marshal.header_size}.*) -val total_size : string -> int -> int +val total_size : bytes -> int -> int (** See {!Marshal.header_size}.*) diff --git a/stdlib/nativeint.mli b/stdlib/nativeint.mli index eb2dde2cf..3dce1b6c4 100644 --- a/stdlib/nativeint.mli +++ b/stdlib/nativeint.mli @@ -16,8 +16,8 @@ This module provides operations on the type [nativeint] of signed 32-bit integers (on 32-bit platforms) or signed 64-bit integers (on 64-bit platforms). - This integer type has exactly the same width as that of a [long] - integer type in the C compiler. All arithmetic operations over + This integer type has exactly the same width as that of a + pointer type in the C compiler. All arithmetic operations over [nativeint] are taken modulo 2{^32} or 2{^64} depending on the word size of the architecture. diff --git a/stdlib/obj.ml b/stdlib/obj.ml index a6f11586e..ac9695cdb 100644 --- a/stdlib/obj.ml +++ b/stdlib/obj.ml @@ -33,9 +33,9 @@ external truncate : t -> int -> unit = "caml_obj_truncate" external add_offset : t -> Int32.t -> t = "caml_obj_add_offset" let marshal (obj : t) = - Marshal.to_string obj [] + Marshal.to_bytes obj [] let unmarshal str pos = - (Marshal.from_string str pos, pos + Marshal.total_size str pos) + (Marshal.from_bytes str pos, pos + Marshal.total_size str pos) let lazy_tag = 246 let closure_tag = 247 @@ -56,3 +56,33 @@ let final_tag = custom_tag let int_tag = 1000 let out_of_heap_tag = 1001 let unaligned_tag = 1002 + +let extension_slot x = + let x = repr x in + let slot = + if (is_block x) && (tag x) <> object_tag && (size x) >= 1 then field x 0 + else x + in + let name = + if (is_block slot) && (tag slot) = object_tag then field slot 0 + else raise Not_found + in + if (tag name) = string_tag then slot + else raise Not_found + +let extension_name x = + try + let slot = extension_slot x in + (obj (field slot 0) : string) + with Not_found -> invalid_arg "Obj.extension_name" + +let extension_id x = + try + let slot = extension_slot x in + (obj (field slot 1) : int) + with Not_found -> invalid_arg "Obj.extension_id" + +let extension_slot x = + try + extension_slot x + with Not_found -> invalid_arg "Obj.extension_slot" diff --git a/stdlib/obj.mli b/stdlib/obj.mli index 9a5bd721d..08b8a4f64 100644 --- a/stdlib/obj.mli +++ b/stdlib/obj.mli @@ -43,18 +43,22 @@ val infix_tag : int val forward_tag : int val no_scan_tag : int val abstract_tag : int -val string_tag : int +val string_tag : int (* both [string] and [bytes] *) val double_tag : int val double_array_tag : int val custom_tag : int -val final_tag : int (* DEPRECATED *) +val final_tag : int [@@ocaml.deprecated] val int_tag : int val out_of_heap_tag : int val unaligned_tag : int (* should never happen @since 3.11.0 *) +val extension_name : 'a -> string +val extension_id : 'a -> int +val extension_slot : 'a -> t + (** The following two functions are deprecated. Use module {!Marshal} instead. *) -val marshal : t -> string -val unmarshal : string -> int -> t * int +val marshal : t -> bytes [@@ocaml.deprecated] +val unmarshal : bytes -> int -> t * int [@@ocaml.deprecated] diff --git a/stdlib/parsing.ml b/stdlib/parsing.ml index 762128244..47e151e1b 100644 --- a/stdlib/parsing.ml +++ b/stdlib/parsing.ml @@ -84,10 +84,10 @@ external set_trace: bool -> bool = "caml_set_parser_trace" let env = - { s_stack = Array.create 100 0; - v_stack = Array.create 100 (Obj.repr ()); - symb_start_stack = Array.create 100 dummy_pos; - symb_end_stack = Array.create 100 dummy_pos; + { s_stack = Array.make 100 0; + v_stack = Array.make 100 (Obj.repr ()); + symb_start_stack = Array.make 100 dummy_pos; + symb_end_stack = Array.make 100 dummy_pos; stacksize = 100; stackbase = 0; curr_char = 0; @@ -104,10 +104,10 @@ let env = let grow_stacks() = let oldsize = env.stacksize in let newsize = oldsize * 2 in - let new_s = Array.create newsize 0 - and new_v = Array.create newsize (Obj.repr ()) - and new_start = Array.create newsize dummy_pos - and new_end = Array.create newsize dummy_pos in + let new_s = Array.make newsize 0 + and new_v = Array.make newsize (Obj.repr ()) + and new_start = Array.make newsize dummy_pos + and new_end = Array.make newsize dummy_pos in Array.blit env.s_stack 0 new_s 0 oldsize; env.s_stack <- new_s; Array.blit env.v_stack 0 new_v 0 oldsize; diff --git a/stdlib/pervasives.ml b/stdlib/pervasives.ml index e4a07c3de..6b7165206 100644 --- a/stdlib/pervasives.ml +++ b/stdlib/pervasives.ml @@ -37,6 +37,18 @@ exception Exit external ( |> ) : 'a -> ('a -> 'b) -> 'b = "%revapply" external ( @@ ) : ('a -> 'b) -> 'a -> 'b = "%apply" +(* Debugging *) + +external __LOC__ : string = "%loc_LOC" +external __FILE__ : string = "%loc_FILE" +external __LINE__ : int = "%loc_LINE" +external __MODULE__ : string = "%loc_MODULE" +external __POS__ : string * int * int * int = "%loc_POS" + +external __LOC_OF__ : 'a -> string * 'a = "%loc_LOC" +external __LINE_OF__ : 'a -> int * 'a = "%loc_LINE" +external __POS_OF__ : 'a -> (string * int * int * int) * 'a = "%loc_POS" + (* Comparisons *) external ( = ) : 'a -> 'a -> bool = "%equal" @@ -69,7 +81,7 @@ external succ : int -> int = "%succint" external pred : int -> int = "%predint" external ( + ) : int -> int -> int = "%addint" external ( - ) : int -> int -> int = "%subint" -external ( * ) : int -> int -> int = "%mulint" +external ( * ) : int -> int -> int = "%mulint" external ( / ) : int -> int -> int = "%divint" external ( mod ) : int -> int -> int = "%modint" @@ -150,19 +162,24 @@ type fpclass = | FP_nan external classify_float : float -> fpclass = "caml_classify_float" -(* String operations -- more in module String *) +(* String and byte sequence operations -- more in modules String and Bytes *) external string_length : string -> int = "%string_length" -external string_create : int -> string = "caml_create_string" -external string_blit : string -> int -> string -> int -> int -> unit +external bytes_length : bytes -> int = "%string_length" +external bytes_create : int -> bytes = "caml_create_string" +external string_blit : string -> int -> bytes -> int -> int -> unit = "caml_blit_string" "noalloc" +external bytes_blit : bytes -> int -> bytes -> int -> int -> unit + = "caml_blit_string" "noalloc" +external bytes_unsafe_to_string : bytes -> string = "%identity" +external bytes_unsafe_of_string : string -> bytes = "%identity" let ( ^ ) s1 s2 = let l1 = string_length s1 and l2 = string_length s2 in - let s = string_create (l1 + l2) in + let s = bytes_create (l1 + l2) in string_blit s1 0 s 0 l1; string_blit s2 0 s l1 l2; - s + bytes_unsafe_to_string s (* Character operations -- more in module Char *) @@ -180,6 +197,15 @@ external ignore : 'a -> unit = "%ignore" external fst : 'a * 'b -> 'a = "%field0" external snd : 'a * 'b -> 'b = "%field1" +(* References *) + +type 'a ref = { mutable contents : 'a } +external ref : 'a -> 'a ref = "%makemutable" +external ( ! ) : 'a ref -> 'a = "%field0" +external ( := ) : 'a ref -> 'a -> unit = "%setfield0" +external incr : int ref -> unit = "%incr" +external decr : int ref -> unit = "%decr" + (* String conversion functions *) external format_int : string -> int -> string = "caml_format_int" @@ -196,16 +222,13 @@ let string_of_int n = format_int "%d" n external int_of_string : string -> int = "caml_int_of_string" - -module String = struct - external get : string -> int -> char = "%string_safe_get" -end +external string_get : string -> int -> char = "%string_safe_get" let valid_float_lexem s = let l = string_length s in let rec loop i = if i >= l then s ^ "." else - match s.[i] with + match string_get s i with | '0' .. '9' | '-' -> loop (i + 1) | _ -> s in @@ -265,19 +288,29 @@ let flush_all () = | a :: l -> (try flush a with _ -> ()); iter l in iter (out_channels_list ()) -external unsafe_output : out_channel -> string -> int -> int -> unit +external unsafe_output : out_channel -> bytes -> int -> int -> unit = "caml_ml_output" +external unsafe_output_string : out_channel -> string -> int -> int -> unit + = "caml_ml_output" external output_char : out_channel -> char -> unit = "caml_ml_output_char" +let output_bytes oc s = + unsafe_output oc s 0 (bytes_length s) + let output_string oc s = - unsafe_output oc s 0 (string_length s) + unsafe_output_string oc s 0 (string_length s) let output oc s ofs len = - if ofs < 0 || len < 0 || ofs > string_length s - len + if ofs < 0 || len < 0 || ofs > bytes_length s - len then invalid_arg "output" else unsafe_output oc s ofs len +let output_substring oc s ofs len = + if ofs < 0 || len < 0 || ofs > string_length s - len + then invalid_arg "output_substring" + else unsafe_output_string oc s ofs len + external output_byte : out_channel -> int -> unit = "caml_ml_output_char" external output_binary_int : out_channel -> int -> unit = "caml_ml_output_int" @@ -309,11 +342,11 @@ let open_in_bin name = external input_char : in_channel -> char = "caml_ml_input_char" -external unsafe_input : in_channel -> string -> int -> int -> int +external unsafe_input : in_channel -> bytes -> int -> int -> int = "caml_ml_input" let input ic s ofs len = - if ofs < 0 || len < 0 || ofs > string_length s - len + if ofs < 0 || len < 0 || ofs > bytes_length s - len then invalid_arg "input" else unsafe_input ic s ofs len @@ -326,39 +359,44 @@ let rec unsafe_really_input ic s ofs len = end let really_input ic s ofs len = - if ofs < 0 || len < 0 || ofs > string_length s - len + if ofs < 0 || len < 0 || ofs > bytes_length s - len then invalid_arg "really_input" else unsafe_really_input ic s ofs len +let really_input_string ic len = + let s = bytes_create len in + really_input ic s 0 len; + bytes_unsafe_to_string s + external input_scan_line : in_channel -> int = "caml_ml_input_scan_line" let input_line chan = let rec build_result buf pos = function [] -> buf | hd :: tl -> - let len = string_length hd in - string_blit hd 0 buf (pos - len) len; + let len = bytes_length hd in + bytes_blit hd 0 buf (pos - len) len; build_result buf (pos - len) tl in let rec scan accu len = let n = input_scan_line chan in if n = 0 then begin (* n = 0: we are at EOF *) match accu with [] -> raise End_of_file - | _ -> build_result (string_create len) len accu + | _ -> build_result (bytes_create len) len accu end else if n > 0 then begin (* n > 0: newline found in buffer *) - let res = string_create (n - 1) in + let res = bytes_create (n - 1) in ignore (unsafe_input chan res 0 (n - 1)); ignore (input_char chan); (* skip the newline *) match accu with [] -> res | _ -> let len = len + n - 1 in - build_result (string_create len) len (res :: accu) + build_result (bytes_create len) len (res :: accu) end else begin (* n < 0: newline not found *) - let beg = string_create (-n) in + let beg = bytes_create (-n) in ignore(unsafe_input chan beg 0 (-n)); scan (beg :: accu) (len - n) end - in scan [] 0 + in bytes_unsafe_to_string (scan [] 0) external input_byte : in_channel -> int = "caml_ml_input_char" external input_binary_int : in_channel -> int = "caml_ml_input_int" @@ -375,6 +413,7 @@ external set_binary_mode_in : in_channel -> bool -> unit let print_char c = output_char stdout c let print_string s = output_string stdout s +let print_bytes s = output_bytes stdout s let print_int i = output_string stdout (string_of_int i) let print_float f = output_string stdout (string_of_float f) let print_endline s = @@ -385,6 +424,7 @@ let print_newline () = output_char stdout '\n'; flush stdout let prerr_char c = output_char stderr c let prerr_string s = output_string stderr s +let prerr_bytes s = output_bytes stderr s let prerr_int i = output_string stderr (string_of_int i) let prerr_float f = output_string stderr (string_of_float f) let prerr_endline s = @@ -410,43 +450,26 @@ module LargeFile = external in_channel_length : in_channel -> int64 = "caml_ml_channel_size_64" end -(* References *) +(* Formats *) -type 'a ref = { mutable contents : 'a } -external ref : 'a -> 'a ref = "%makemutable" -external ( ! ) : 'a ref -> 'a = "%field0" -external ( := ) : 'a ref -> 'a -> unit = "%setfield0" -external incr : int ref -> unit = "%incr" -external decr : int ref -> unit = "%decr" +type ('a, 'b, 'c, 'd, 'e, 'f) format6 + = ('a, 'b, 'c, 'd, 'e, 'f) CamlinternalFormatBasics.format6 + = Format of ('a, 'b, 'c, 'd, 'e, 'f) CamlinternalFormatBasics.fmt + * string -(* Formats *) type ('a, 'b, 'c, 'd) format4 = ('a, 'b, 'c, 'c, 'c, 'd) format6 type ('a, 'b, 'c) format = ('a, 'b, 'c, 'c) format4 +let string_of_format (Format (fmt, str)) = str + external format_of_string : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> ('a, 'b, 'c, 'd, 'e, 'f) format6 = "%identity" -external format_to_string : - ('a, 'b, 'c, 'd, 'e, 'f) format6 -> string = "%identity" -external string_to_format : - string -> ('a, 'b, 'c, 'd, 'e, 'f) format6 = "%identity" - -let (( ^^ ) : - ('a, 'b, 'c, 'd, 'e, 'f) format6 -> - ('f, 'b, 'c, 'e, 'g, 'h) format6 -> - ('a, 'b, 'c, 'd, 'g, 'h) format6) = - fun fmt1 fmt2 -> - string_to_format (format_to_string fmt1 ^ "%," ^ format_to_string fmt2) -;; - -let string_of_format fmt = - let s = format_to_string fmt in - let l = string_length s in - let r = string_create l in - string_blit s 0 r 0 l; - r +let (^^) (Format (fmt1, str1)) (Format (fmt2, str2)) = + Format (CamlinternalFormatBasics.concat_fmt fmt1 fmt2, + str1 ^ "%," ^ str2) (* Miscellaneous *) diff --git a/stdlib/pervasives.mli b/stdlib/pervasives.mli index 0a2e4af6a..d471a4ebb 100644 --- a/stdlib/pervasives.mli +++ b/stdlib/pervasives.mli @@ -14,8 +14,8 @@ (** The initially opened module. This module provides the basic operations over the built-in types - (numbers, booleans, strings, exceptions, references, lists, arrays, - input-output channels, ...). + (numbers, booleans, byte sequences, strings, exceptions, references, + lists, arrays, input-output channels, ...). This module is automatically opened at the beginning of each compilation. All components of this module can therefore be referred by their short @@ -68,7 +68,7 @@ external ( <= ) : 'a -> 'a -> bool = "%lessequal" external ( >= ) : 'a -> 'a -> bool = "%greaterequal" (** Structural ordering functions. These functions coincide with - the usual orderings over integers, characters, strings + the usual orderings over integers, characters, strings, byte sequences and floating-point numbers, and extend them to a total ordering over all types. The ordering is compatible with [( = )]. As in the case @@ -107,7 +107,7 @@ val max : 'a -> 'a -> 'a external ( == ) : 'a -> 'a -> bool = "%eq" (** [e1 == e2] tests for physical equality of [e1] and [e2]. - On mutable types such as references, arrays, strings, records with + On mutable types such as references, arrays, byte sequences, records with mutable fields and objects with mutable instance variables, [e1 == e2] is true if and only if physical modification of [e1] also affects [e2]. @@ -130,6 +130,7 @@ external ( && ) : bool -> bool -> bool = "%sequand" [e2] is not evaluated at all. *) external ( & ) : bool -> bool -> bool = "%sequand" + [@@ocaml.deprecated] (** @deprecated {!Pervasives.( && )} should be used instead. *) external ( || ) : bool -> bool -> bool = "%sequor" @@ -138,8 +139,47 @@ external ( || ) : bool -> bool -> bool = "%sequor" [e2] is not evaluated at all. *) external ( or ) : bool -> bool -> bool = "%sequor" + [@@ocaml.deprecated] (** @deprecated {!Pervasives.( || )} should be used instead.*) +(** {6 Debugging} *) + +external __LOC__ : string = "%loc_LOC" +(** [__LOC__] returns the location at which this expression appears in + the file currently being parsed by the compiler, with the standard + error format of OCaml: "File %S, line %d, characters %d-%d" *) +external __FILE__ : string = "%loc_FILE" +(** [__FILE__] returns the name of the file currently being + parsed by the compiler. *) +external __LINE__ : int = "%loc_LINE" +(** [__LINE__] returns the line number at which this expression + appears in the file currently being parsed by the compiler. *) +external __MODULE__ : string = "%loc_MODULE" +(** [__MODULE__] returns the module name of the file being + parsed by the compiler. *) +external __POS__ : string * int * int * int = "%loc_POS" +(** [__POS__] returns a tuple [(file,lnum,cnum,enum)], corresponding + to the location at which this expression appears in the file + currently being parsed by the compiler. [file] is the current + filename, [lnum] the line number, [cnum] the character position in + the line and [enum] the last character position in the line. *) + +external __LOC_OF__ : 'a -> string * 'a = "%loc_LOC" +(** [__LOC_OF__ expr] returns a pair [(loc, expr)] where [loc] is the + location of [expr] in the file currently being parsed by the + compiler, with the standard error format of OCaml: "File %S, line + %d, characters %d-%d" *) +external __LINE_OF__ : 'a -> int * 'a = "%loc_LINE" +(** [__LINE__ expr] returns a pair [(line, expr)], where [line] is the + line number at which the expression [expr] appears in the file + currently being parsed by the compiler. *) +external __POS_OF__ : 'a -> (string * int * int * int) * 'a = "%loc_POS" +(** [__POS_OF__ expr] returns a pair [(expr,loc)], where [loc] is a + tuple [(file,lnum,cnum,enum)] corresponding to the location at + which the expression [expr] appears in the file currently being + parsed by the compiler. [file] is the current filename, [lnum] the + line number, [cnum] the character position in the line and [enum] + the last character position in the line. *) (** {6 Composition operators} *) @@ -553,6 +593,9 @@ val print_char : char -> unit val print_string : string -> unit (** Print a string on standard output. *) +val print_bytes : bytes -> unit +(** Print a byte sequence on standard output. *) + val print_int : int -> unit (** Print an integer, in decimal, on standard output. *) @@ -577,6 +620,9 @@ val prerr_char : char -> unit val prerr_string : string -> unit (** Print a string on standard error. *) +val prerr_bytes : bytes -> unit +(** Print a byte sequence on standard error. *) + val prerr_int : int -> unit (** Print an integer, in decimal, on standard error. *) @@ -584,8 +630,8 @@ val prerr_float : float -> unit (** Print a floating-point number, in decimal, on standard error. *) val prerr_endline : string -> unit -(** Print a string, followed by a newline character on standard error - and flush standard error. *) +(** Print a string, followed by a newline character on standard + error and flush standard error. *) val prerr_newline : unit -> unit (** Print a newline character on standard error, and flush @@ -661,11 +707,18 @@ val output_char : out_channel -> char -> unit val output_string : out_channel -> string -> unit (** Write the string on the given output channel. *) -val output : out_channel -> string -> int -> int -> unit -(** [output oc buf pos len] writes [len] characters from string [buf], +val output_bytes : out_channel -> bytes -> unit +(** Write the byte sequence on the given output channel. *) + +val output : out_channel -> bytes -> int -> int -> unit +(** [output oc buf pos len] writes [len] characters from byte sequence [buf], starting at offset [pos], to the given output channel [oc]. Raise [Invalid_argument "output"] if [pos] and [len] do not - designate a valid substring of [buf]. *) + designate a valid range of [buf]. *) + +val output_substring : out_channel -> string -> int -> int -> unit +(** Same as [output] but take a string as argument instead of + a byte sequence. *) val output_byte : out_channel -> int -> unit (** Write one 8-bit integer (as the single character with that code) @@ -756,9 +809,9 @@ val input_line : in_channel -> string Raise [End_of_file] if the end of the file is reached at the beginning of line. *) -val input : in_channel -> string -> int -> int -> int +val input : in_channel -> bytes -> int -> int -> int (** [input ic buf pos len] reads up to [len] characters from - the given channel [ic], storing them in string [buf], starting at + the given channel [ic], storing them in byte sequence [buf], starting at character number [pos]. It returns the actual number of characters read, between 0 and [len] (inclusive). @@ -771,15 +824,21 @@ val input : in_channel -> string -> int -> int -> int if desired. (See also {!Pervasives.really_input} for reading exactly [len] characters.) Exception [Invalid_argument "input"] is raised if [pos] and [len] - do not designate a valid substring of [buf]. *) + do not designate a valid range of [buf]. *) -val really_input : in_channel -> string -> int -> int -> unit +val really_input : in_channel -> bytes -> int -> int -> unit (** [really_input ic buf pos len] reads [len] characters from channel [ic], - storing them in string [buf], starting at character number [pos]. + storing them in byte sequence [buf], starting at character number [pos]. Raise [End_of_file] if the end of file is reached before [len] characters have been read. Raise [Invalid_argument "really_input"] if - [pos] and [len] do not designate a valid substring of [buf]. *) + [pos] and [len] do not designate a valid range of [buf]. *) + +val really_input_string : in_channel -> int -> string +(** [really_input_string ic len] reads [len] characters from channel [ic] + and returns them in a new string. + Raise [End_of_file] if the end of file is reached before [len] + characters have been read. *) val input_byte : in_channel -> int (** Same as {!Pervasives.input_char}, but return the 8-bit integer representing @@ -910,7 +969,7 @@ external decr : int ref -> unit = "%decr" *) (** Format strings have a general and highly polymorphic type - [('a, 'b, 'c, 'd, 'e, 'f) format6]. Type [format6] is built in. + [('a, 'b, 'c, 'd, 'e, 'f) format6]. The two simplified types, [format] and [format4] below are included for backward compatibility with earlier releases of OCaml. @@ -949,6 +1008,10 @@ external decr : int ref -> unit = "%decr" for the [scanf]-style functions, it is typically the result type of the receiver function. *) + +type ('a, 'b, 'c, 'd, 'e, 'f) format6 = + ('a, 'b, 'c, 'd, 'e, 'f) CamlinternalFormatBasics.format6 + type ('a, 'b, 'c, 'd) format4 = ('a, 'b, 'c, 'c, 'c, 'd) format6 type ('a, 'b, 'c) format = ('a, 'b, 'c, 'c) format4 @@ -1003,6 +1066,6 @@ val at_exit : (unit -> unit) -> unit val valid_float_lexem : string -> string -val unsafe_really_input : in_channel -> string -> int -> int -> unit +val unsafe_really_input : in_channel -> bytes -> int -> int -> unit val do_at_exit : unit -> unit diff --git a/stdlib/printexc.ml b/stdlib/printexc.ml index 9f20c7b46..4ebb84cea 100644 --- a/stdlib/printexc.ml +++ b/stdlib/printexc.ml @@ -82,12 +82,13 @@ let catch fct arg = eprintf "Uncaught exception: %s\n" (to_string x); exit 2 -type raw_backtrace +type raw_backtrace_slot +type raw_backtrace = raw_backtrace_slot array external get_raw_backtrace: unit -> raw_backtrace = "caml_get_exception_raw_backtrace" -type loc_info = +type backtrace_slot = | Known_location of bool (* is_raise *) * string (* filename *) * int (* line number *) @@ -98,29 +99,27 @@ type loc_info = (* to avoid warning *) let _ = [Known_location (false, "", 0, 0, 0); Unknown_location false] -type backtrace = loc_info array +external convert_raw_backtrace_slot: + raw_backtrace_slot -> backtrace_slot = "caml_convert_raw_backtrace_slot" -external convert_raw_backtrace: - raw_backtrace -> backtrace option = "caml_convert_raw_backtrace" +let convert_raw_backtrace rbckt = + try Some (Array.map convert_raw_backtrace_slot rbckt) + with Failure _ -> None -let format_loc_info pos li = - let is_raise = - match li with - | Known_location(is_raise, _, _, _, _) -> is_raise - | Unknown_location(is_raise) -> is_raise in - let info = +let format_backtrace_slot pos slot = + let info is_raise = if is_raise then if pos = 0 then "Raised at" else "Re-raised at" else if pos = 0 then "Raised by primitive operation at" else "Called from" in - match li with + match slot with + | Unknown_location true -> (* compiler-inserted re-raise, skipped *) None + | Unknown_location false -> + Some (sprintf "%s unknown location" (info false)) | Known_location(is_raise, filename, lineno, startchar, endchar) -> - sprintf "%s file \"%s\", line %d, characters %d-%d" - info filename lineno startchar endchar - | Unknown_location(is_raise) -> - sprintf "%s unknown location" - info + Some (sprintf "%s file \"%s\", line %d, characters %d-%d" + (info is_raise) filename lineno startchar endchar) let print_exception_backtrace outchan backtrace = match backtrace with @@ -129,8 +128,9 @@ let print_exception_backtrace outchan backtrace = "(Program not linked with -g, cannot print stack backtrace)\n" | Some a -> for i = 0 to Array.length a - 1 do - if a.(i) <> Unknown_location true then - fprintf outchan "%s\n" (format_loc_info i a.(i)) + match format_backtrace_slot i a.(i) with + | None -> () + | Some str -> fprintf outchan "%s\n" str done let print_raw_backtrace outchan raw_backtrace = @@ -147,20 +147,70 @@ let backtrace_to_string backtrace = | Some a -> let b = Buffer.create 1024 in for i = 0 to Array.length a - 1 do - if a.(i) <> Unknown_location true then - bprintf b "%s\n" (format_loc_info i a.(i)) + match format_backtrace_slot i a.(i) with + | None -> () + | Some str -> bprintf b "%s\n" str done; Buffer.contents b let raw_backtrace_to_string raw_backtrace = backtrace_to_string (convert_raw_backtrace raw_backtrace) +let backtrace_slot_is_raise = function + | Known_location(is_raise, _, _, _, _) -> is_raise + | Unknown_location(is_raise) -> is_raise + +type location = { + filename : string; + line_number : int; + start_char : int; + end_char : int; +} + +let backtrace_slot_location = function + | Unknown_location _ -> None + | Known_location(_is_raise, filename, line_number, + start_char, end_char) -> + Some { + filename; + line_number; + start_char; + end_char; + } + +let backtrace_slots raw_backtrace = + (* The documentation of this function guarantees that Some is + returned only if a part of the trace is usable. This gives us + a bit more work than just convert_raw_backtrace, but it makes the + API more user-friendly -- otherwise most users would have to + reimplement the "Program not linked with -g, sorry" logic + themselves. *) + match convert_raw_backtrace raw_backtrace with + | None -> None + | Some backtrace -> + let usable_slot = function + | Unknown_location _ -> false + | Known_location _ -> true in + let rec exists_usable = function + | (-1) -> false + | i -> usable_slot backtrace.(i) || exists_usable (i - 1) in + if exists_usable (Array.length backtrace - 1) + then Some backtrace + else None + +module Slot = struct + type t = backtrace_slot + let format = format_backtrace_slot + let is_raise = backtrace_slot_is_raise + let location = backtrace_slot_location +end + +let raw_backtrace_length bckt = Array.length bckt +let get_raw_backtrace_slot bckt i = Array.get bckt i + (* confusingly named: returns the *string* corresponding to the global current backtrace *) let get_backtrace () = - (* we could use the caml_get_exception_backtrace primitive here, but - we hope to deprecate it so it's better to just compose the - raw stuff *) backtrace_to_string (convert_raw_backtrace (get_raw_backtrace ())) external record_backtrace: bool -> unit = "caml_record_backtrace" @@ -169,10 +219,8 @@ external backtrace_status: unit -> bool = "caml_backtrace_status" let register_printer fn = printers := fn :: !printers - external get_callstack: int -> raw_backtrace = "caml_get_current_callstack" - let exn_slot x = let x = Obj.repr x in if Obj.tag x = 0 then Obj.field x 0 else x @@ -184,3 +232,64 @@ let exn_slot_id x = let exn_slot_name x = let slot = exn_slot x in (Obj.obj (Obj.field slot 0) : string) + + +let uncaught_exception_handler = ref None + +let set_uncaught_exception_handler fn = uncaught_exception_handler := Some fn + +let empty_backtrace : raw_backtrace = Obj.obj (Obj.new_block Obj.abstract_tag 0) + +let try_get_raw_backtrace () = + try + get_raw_backtrace () + with _ (* Out_of_memory? *) -> + empty_backtrace + +let handle_uncaught_exception' exn debugger_in_use = + try + (* Get the backtrace now, in case one of the [at_exit] function + destroys it. *) + let raw_backtrace = + if debugger_in_use (* Same test as in [byterun/printexc.c] *) then + empty_backtrace + else + try_get_raw_backtrace () + in + (try Pervasives.do_at_exit () with _ -> ()); + match !uncaught_exception_handler with + | None -> + eprintf "Fatal error: exception %s\n" (to_string exn); + print_raw_backtrace stderr raw_backtrace; + flush stderr + | Some handler -> + try + handler exn raw_backtrace + with exn' -> + let raw_backtrace' = try_get_raw_backtrace () in + eprintf "Fatal error: exception %s\n" (to_string exn); + print_raw_backtrace stderr raw_backtrace; + eprintf "Fatal error in uncaught exception handler: exception %s\n" + (to_string exn'); + print_raw_backtrace stderr raw_backtrace'; + flush stderr + with + | Out_of_memory -> + prerr_endline + "Fatal error: out of memory in uncaught exception handler" + +(* This function is called by [caml_fatal_uncaught_exception] in + [byterun/printexc.c] which expects no exception is raised. *) +let handle_uncaught_exception exn debugger_in_use = + try + handle_uncaught_exception' exn debugger_in_use + with _ -> + (* There is not much we can do at this point *) + () + +external register_named_value : string -> 'a -> unit + = "caml_register_named_value" + +let () = + register_named_value "Printexc.handle_uncaught_exception" + handle_uncaught_exception diff --git a/stdlib/printexc.mli b/stdlib/printexc.mli index c378d9cb3..6bffe174c 100644 --- a/stdlib/printexc.mli +++ b/stdlib/printexc.mli @@ -86,25 +86,46 @@ val register_printer: (exn -> string option) -> unit (** {6 Raw backtraces} *) type raw_backtrace - -(** The abstract type [backtrace] stores exception backtraces in +(** The abstract type [raw_backtrace] stores a backtrace in a low-level format, instead of directly exposing them as string as the [get_backtrace()] function does. This allows delaying the formatting of backtraces to when they are - actually printed, which might be useful if you record more + actually printed, which may be useful if you record more backtraces than you print. + + Raw backtraces cannot be marshalled. If you need marshalling, you + should use the array returned by the [backtrace_slots] function of + the next section. + + @since 4.01.0 *) val get_raw_backtrace: unit -> raw_backtrace +(** [Printexc.get_raw_backtrace ()] returns the same exception + backtrace that [Printexc.print_backtrace] would print, but in + a raw format. + + @since 4.01.0 +*) + val print_raw_backtrace: out_channel -> raw_backtrace -> unit +(** Print a raw backtrace in the same format + [Printexc.print_backtrace] uses. + + @since 4.01.0 +*) + val raw_backtrace_to_string: raw_backtrace -> string +(** Return a string from a raw backtrace, in the same format + [Printexc.get_backtrace] uses. + @since 4.01.0 +*) (** {6 Current call stack} *) val get_callstack: int -> raw_backtrace - (** [Printexc.get_callstack n] returns a description of the top of the call stack on the current program point (for the current thread), with at most [n] entries. (Note: this function is not related to @@ -113,6 +134,138 @@ val get_callstack: int -> raw_backtrace @since 4.01.0 *) +(** {6 Uncaught exceptions} *) + +val set_uncaught_exception_handler: (exn -> raw_backtrace -> unit) -> unit +(** [Printexc.set_uncaught_exception_handler fn] registers [fn] as the handler + for uncaught exceptions. The default handler prints the exception and + backtrace on standard error output. + + Note that when [fn] is called all the functions registered with + {!Pervasives.at_exit} have already been called. Because of this you must + make sure any output channel [fn] writes on is flushed. + + If [fn] raises an exception, it is ignored. + + @since 4.02.0 +*) + + +(** {6 Manipulation of backtrace information} + + Those function allow to traverse the slots of a raw backtrace, + extract information from them in a programmer-friendly format. +*) + +type backtrace_slot +(** The abstract type [backtrace_slot] represents a single slot of + a backtrace. + + @since 4.02 +*) + +val backtrace_slots : raw_backtrace -> backtrace_slot array option +(** Returns the slots of a raw backtrace, or [None] if none of them + contain useful information. + + In the return array, the slot at index [0] corresponds to the most + recent function call, raise, or primitive [get_backtrace] call in + the trace. + + Some possible reasons for returning [None] are as follow: + - none of the slots in the trace come from modules compiled with + debug information ([-g]) + - the program is a bytecode program that has not been linked with + debug information enabled ([ocamlc -g]) +*) + +type location = { + filename : string; + line_number : int; + start_char : int; + end_char : int; +} +(** The type of location information found in backtraces. [start_char] + and [end_char] are positions relative to the beginning of the + line. + + @since 4.02 +*) + +module Slot : sig + type t = backtrace_slot + + val is_raise : t -> bool + (** [is_raise slot] is [true] when [slot] refers to a raising + point in the code, and [false] when it comes from a simple + function call. + + @since 4.02 + *) + + val location : t -> location option + (** [location slot] returns the location information of the slot, + if available, and [None] otherwise. + + Some possible reasons for failing to return a location are as follow: + - the slot corresponds to a compiler-inserted raise + - the slot corresponds to a part of the program that has not been + compiled with debug information ([-g]) + + @since 4.02 + *) + + val format : int -> t -> string option + (** [format pos slot] returns the string representation of [slot] as + [raw_backtrace_to_string] would format it, assuming it is the + [pos]-th element of the backtrace: the [0]-th element is + pretty-printed differently than the others. + + Whole-backtrace printing functions also skip some uninformative + slots; in that case, [format pos slot] returns [None]. + + @since 4.02 + *) +end + + +(** {6 Raw backtrace slots} *) + +type raw_backtrace_slot +(** This type allows direct access to raw backtrace slots, without any + conversion in an OCaml-usable data-structure. Being + process-specific, they must absolutely not be marshalled, and are + unsafe to use for this reason (marshalling them may not fail, but + un-marshalling and using the result will result in + undefined behavior). + + Elements of this type can still be compared and hashed: when two + elements are equal, then they represent the same source location + (the converse is not necessarily true in presence of inlining, + for example). +*) + +val raw_backtrace_length : raw_backtrace -> int +(** [raw_backtrace_length bckt] returns the number of slots in the + backtrace [bckt]. + + @since 4.02 +*) + +val get_raw_backtrace_slot : raw_backtrace -> int -> raw_backtrace_slot +(** [get_slot bckt pos] returns the slot in position [pos] in the + backtrace [bckt]. + + @since 4.02 +*) + +val convert_raw_backtrace_slot : raw_backtrace_slot -> backtrace_slot +(** Extracts the user-friendly [backtrace_slot] from a low-level + [raw_backtrace_slot]. + + @since 4.02 +*) + (** {6 Exception slots} *) @@ -130,5 +283,3 @@ val exn_slot_name: exn -> string @since 4.02.0 *) - - diff --git a/stdlib/printf.ml b/stdlib/printf.ml index 380169204..1152429f9 100644 --- a/stdlib/printf.ml +++ b/stdlib/printf.ml @@ -11,728 +11,29 @@ (* *) (***********************************************************************) -external format_float: string -> float -> string - = "caml_format_float" -external format_int: string -> int -> string - = "caml_format_int" -external format_int32: string -> int32 -> string - = "caml_int32_format" -external format_nativeint: string -> nativeint -> string - = "caml_nativeint_format" -external format_int64: string -> int64 -> string - = "caml_int64_format" - -module Sformat = struct - - type index;; - - external unsafe_index_of_int : int -> index = "%identity" - ;; - let index_of_int i = - if i >= 0 then unsafe_index_of_int i - else failwith ("Sformat.index_of_int: negative argument " ^ string_of_int i) - ;; - external int_of_index : index -> int = "%identity" - ;; - - let add_int_index i idx = index_of_int (i + int_of_index idx);; - let succ_index = add_int_index 1;; - (* Literal position are one-based (hence pred p instead of p). *) - let index_of_literal_position p = index_of_int (pred p);; - - external length : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> int - = "%string_length" - ;; - external get : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> int -> char - = "%string_safe_get" - ;; - external unsafe_get : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> int -> char - = "%string_unsafe_get" - ;; - external unsafe_to_string : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> string - = "%identity" - ;; - let sub fmt idx len = - String.sub (unsafe_to_string fmt) (int_of_index idx) len - ;; - let to_string fmt = sub fmt (unsafe_index_of_int 0) (length fmt) - ;; - -end -;; - -let bad_conversion sfmt i c = - invalid_arg - ("Printf: bad conversion %" ^ String.make 1 c ^ ", at char number " ^ - string_of_int i ^ " in format string \'" ^ sfmt ^ "\'") -;; - -let bad_conversion_format fmt i c = - bad_conversion (Sformat.to_string fmt) i c -;; - -let incomplete_format fmt = - invalid_arg - ("Printf: premature end of format string \'" ^ - Sformat.to_string fmt ^ "\'") -;; - -(* Parses a string conversion to return the specified length and the - padding direction. *) -let parse_string_conversion sfmt = - let rec parse neg i = - if i >= String.length sfmt then (0, neg) else - match String.unsafe_get sfmt i with - | '1'..'9' -> - (int_of_string - (String.sub sfmt i (String.length sfmt - i - 1)), - neg) - | '-' -> - parse true (succ i) - | _ -> - parse neg (succ i) in - try parse false 1 with - | Failure _ -> bad_conversion sfmt 0 's' -;; - -(* Pad a (sub) string into a blank string of length [p], - on the right if [neg] is true, on the left otherwise. *) -let pad_string pad_char p neg s i len = - if p = len && i = 0 then s else - if p <= len then String.sub s i len else - let res = String.make p pad_char in - if neg - then String.blit s i res 0 len - else String.blit s i res (p - len) len; - res -;; - -(* Format a string given a %s format, e.g. %40s or %-20s. - To do ?: ignore other flags (#, +, etc). *) -let format_string sfmt s = - let (p, neg) = parse_string_conversion sfmt in - pad_string ' ' p neg s 0 (String.length s) -;; - -(* Extract a format string out of [fmt] between [start] and [stop] inclusive. - ['*'] in the format are replaced by integers taken from the [widths] list. - [extract_format] returns a string which is the string representation of - the resulting format string. *) -let extract_format fmt start stop widths = - let skip_positional_spec start = - match Sformat.unsafe_get fmt start with - | '0'..'9' -> - let rec skip_int_literal i = - match Sformat.unsafe_get fmt i with - | '0'..'9' -> skip_int_literal (succ i) - | '$' -> succ i - | _ -> start in - skip_int_literal (succ start) - | _ -> start in - let start = skip_positional_spec (succ start) in - let b = Buffer.create (stop - start + 10) in - Buffer.add_char b '%'; - let rec fill_format i widths = - if i <= stop then - match (Sformat.unsafe_get fmt i, widths) with - | ('*', h :: t) -> - Buffer.add_string b (string_of_int h); - let i = skip_positional_spec (succ i) in - fill_format i t - | ('*', []) -> - assert false (* Should not happen since this is ill-typed. *) - | (c, _) -> - Buffer.add_char b c; - fill_format (succ i) widths in - fill_format start (List.rev widths); - Buffer.contents b -;; - -let extract_format_int conv fmt start stop widths = - let sfmt = extract_format fmt start stop widths in - match conv with - | 'n' | 'N' -> - sfmt.[String.length sfmt - 1] <- 'u'; - sfmt - | _ -> sfmt -;; - -let extract_format_float conv fmt start stop widths = - let sfmt = extract_format fmt start stop widths in - match conv with - | 'F' -> - sfmt.[String.length sfmt - 1] <- 'g'; - sfmt - | _ -> sfmt -;; - -(* Returns the position of the next character following the meta format - string, starting from position [i], inside a given format [fmt]. - According to the character [conv], the meta format string is - enclosed by the delimiters %{ and %} (when [conv = '{']) or %( and - %) (when [conv = '(']). Hence, [sub_format] returns the index of - the character following the [')'] or ['}'] that ends the meta format, - according to the character [conv]. *) -let sub_format incomplete_format bad_conversion_format conv fmt i = - let len = Sformat.length fmt in - let rec sub_fmt c i = - let close = if c = '(' then ')' else (* '{' *) '}' in - let rec sub j = - if j >= len then incomplete_format fmt else - match Sformat.get fmt j with - | '%' -> sub_sub (succ j) - | _ -> sub (succ j) - and sub_sub j = - if j >= len then incomplete_format fmt else - match Sformat.get fmt j with - | '(' | '{' as c -> - let j = sub_fmt c (succ j) in - sub (succ j) - | '}' | ')' as c -> - if c = close then succ j else bad_conversion_format fmt i c - | _ -> sub (succ j) in - sub i in - sub_fmt conv i -;; - -let sub_format_for_printf conv = - sub_format incomplete_format bad_conversion_format conv -;; - -let iter_on_format_args fmt add_conv add_char = - - let lim = Sformat.length fmt - 1 in - - let rec scan_flags skip i = - if i > lim then incomplete_format fmt else - match Sformat.unsafe_get fmt i with - | '*' -> scan_flags skip (add_conv skip i 'i') - (* | '$' -> scan_flags skip (succ i) *** PR#4321 *) - | '#' | '-' | ' ' | '+' -> scan_flags skip (succ i) - | '_' -> scan_flags true (succ i) - | '0'..'9' - | '.' -> scan_flags skip (succ i) - | _ -> scan_conv skip i - and scan_conv skip i = - if i > lim then incomplete_format fmt else - match Sformat.unsafe_get fmt i with - | '%' | '@' | '!' | ',' -> succ i - | 's' | 'S' | '[' -> add_conv skip i 's' - | 'c' | 'C' -> add_conv skip i 'c' - | 'd' | 'i' |'o' | 'u' | 'x' | 'X' | 'N' -> add_conv skip i 'i' - | 'f' | 'e' | 'E' | 'g' | 'G' | 'F' -> add_conv skip i 'f' - | 'B' | 'b' -> add_conv skip i 'B' - | 'a' | 'r' | 't' as conv -> add_conv skip i conv - | 'l' | 'n' | 'L' as conv -> - let j = succ i in - if j > lim then add_conv skip i 'i' else begin - match Sformat.get fmt j with - | 'd' | 'i' | 'o' | 'u' | 'x' | 'X' -> - add_char (add_conv skip i conv) 'i' - | _ -> add_conv skip i 'i' end - | '{' as conv -> - (* Just get a regular argument, skipping the specification. *) - let i = add_conv skip i conv in - (* To go on, find the index of the next char after the meta format. *) - let j = sub_format_for_printf conv fmt i in - (* Add the meta specification to the summary anyway. *) - let rec loop i = - if i < j - 2 then loop (add_char i (Sformat.get fmt i)) in - loop i; - (* Go on, starting at the closing brace to properly close the meta - specification in the summary. *) - scan_conv skip (j - 1) - | '(' as conv -> - (* Use the static format argument specification instead of - the runtime format argument value: they must have the same type - anyway. *) - scan_fmt (add_conv skip i conv) - | '}' | ')' as conv -> add_conv skip i conv - | conv -> bad_conversion_format fmt i conv - - and scan_fmt i = - if i < lim then - if Sformat.get fmt i = '%' - then scan_fmt (scan_flags false (succ i)) - else scan_fmt (succ i) - else i in - - ignore (scan_fmt 0) -;; - -(* Returns a string that summarizes the typing information that a given - format string contains. - For instance, [summarize_format_type "A number %d\n"] is "%i". - It also checks the well-formedness of the format string. *) -let summarize_format_type fmt = - let len = Sformat.length fmt in - let b = Buffer.create len in - let add_char i c = Buffer.add_char b c; succ i in - let add_conv skip i c = - if skip then Buffer.add_string b "%_" else Buffer.add_char b '%'; - add_char i c in - iter_on_format_args fmt add_conv add_char; - Buffer.contents b -;; - -module Ac = struct - type ac = { - mutable ac_rglr : int; - mutable ac_skip : int; - mutable ac_rdrs : int; - } -end -;; - -open Ac;; - -(* Computes the number of arguments of a format (including the flag - arguments if any). *) -let ac_of_format fmt = - let ac = { ac_rglr = 0; ac_skip = 0; ac_rdrs = 0; } in - let incr_ac skip c = - let inc = if c = 'a' then 2 else 1 in - if c = 'r' then ac.ac_rdrs <- ac.ac_rdrs + 1; - if skip - then ac.ac_skip <- ac.ac_skip + inc - else ac.ac_rglr <- ac.ac_rglr + inc in - let add_conv skip i c = - (* Just finishing a meta format: no additional argument to record. *) - if c <> ')' && c <> '}' then incr_ac skip c; - succ i - and add_char i _ = succ i in - - iter_on_format_args fmt add_conv add_char; - ac -;; - -let count_printing_arguments_of_format fmt = - let ac = ac_of_format fmt in - (* For printing, only the regular arguments have to be counted. *) - ac.ac_rglr -;; - -let list_iter_i f l = - let rec loop i = function - | [] -> () - | [x] -> f i x (* Tail calling [f] *) - | x :: xs -> f i x; loop (succ i) xs in - loop 0 l -;; - -(* 'Abstracting' version of kprintf: returns a (curried) function that - will print when totally applied. - Note: in the following, we are careful not to be badly caught - by the compiler optimizations for the representation of arrays. *) -let kapr kpr fmt = - match count_printing_arguments_of_format fmt with - | 0 -> kpr fmt [||] - | 1 -> Obj.magic (fun x -> - let a = Array.make 1 (Obj.repr 0) in - a.(0) <- x; - kpr fmt a) - | 2 -> Obj.magic (fun x y -> - let a = Array.make 2 (Obj.repr 0) in - a.(0) <- x; a.(1) <- y; - kpr fmt a) - | 3 -> Obj.magic (fun x y z -> - let a = Array.make 3 (Obj.repr 0) in - a.(0) <- x; a.(1) <- y; a.(2) <- z; - kpr fmt a) - | 4 -> Obj.magic (fun x y z t -> - let a = Array.make 4 (Obj.repr 0) in - a.(0) <- x; a.(1) <- y; a.(2) <- z; - a.(3) <- t; - kpr fmt a) - | 5 -> Obj.magic (fun x y z t u -> - let a = Array.make 5 (Obj.repr 0) in - a.(0) <- x; a.(1) <- y; a.(2) <- z; - a.(3) <- t; a.(4) <- u; - kpr fmt a) - | 6 -> Obj.magic (fun x y z t u v -> - let a = Array.make 6 (Obj.repr 0) in - a.(0) <- x; a.(1) <- y; a.(2) <- z; - a.(3) <- t; a.(4) <- u; a.(5) <- v; - kpr fmt a) - | nargs -> - let rec loop i args = - if i >= nargs then - let a = Array.make nargs (Obj.repr 0) in - list_iter_i (fun i arg -> a.(nargs - i - 1) <- arg) args; - kpr fmt a - else Obj.magic (fun x -> loop (succ i) (x :: args)) in - loop 0 [] -;; - -type positional_specification = - | Spec_none | Spec_index of Sformat.index -;; - -(* To scan an optional positional parameter specification, - i.e. an integer followed by a [$]. - - Calling [got_spec] with appropriate arguments, we 'return' a positional - specification and an index to go on scanning the [fmt] format at hand. - - Note that this is optimized for the regular case, i.e. no positional - parameter, since in this case we juste 'return' the constant - [Spec_none]; in case we have a positional parameter, we 'return' a - [Spec_index] [positional_specification] which is a bit more costly. - - Note also that we do not support [*$] specifications, since this would - lead to type checking problems: a [*$] positional specification means - 'take the next argument to [printf] (which must be an integer value)', - name this integer value $n$; [*$] now designates parameter $n$. - - Unfortunately, the type of a parameter specified via a [*$] positional - specification should be the type of the corresponding argument to - [printf], hence this should be the type of the $n$-th argument to [printf] - with $n$ being the {\em value} of the integer argument defining [*]; we - clearly cannot statically guess the value of this parameter in the general - case. Put it another way: this means type dependency, which is completely - out of scope of the OCaml type algebra. *) - -let scan_positional_spec fmt got_spec i = - match Sformat.unsafe_get fmt i with - | '0'..'9' as d -> - let rec get_int_literal accu j = - match Sformat.unsafe_get fmt j with - | '0'..'9' as d -> - get_int_literal (10 * accu + (int_of_char d - 48)) (succ j) - | '$' -> - if accu = 0 then - failwith "printf: bad positional specification (0)." else - got_spec (Spec_index (Sformat.index_of_literal_position accu)) (succ j) - (* Not a positional specification: tell so the caller, and go back to - scanning the format from the original [i] position we were called at - first. *) - | _ -> got_spec Spec_none i in - get_int_literal (int_of_char d - 48) (succ i) - (* No positional specification: tell so the caller, and go back to scanning - the format from the original [i] position. *) - | _ -> got_spec Spec_none i -;; - -(* Get the index of the next argument to printf, according to the given - positional specification. *) -let next_index spec n = - match spec with - | Spec_none -> Sformat.succ_index n - | Spec_index _ -> n -;; - -(* Get the index of the actual argument to printf, according to its - optional positional specification. *) -let get_index spec n = - match spec with - | Spec_none -> n - | Spec_index p -> p -;; - -(* Format a float argument as a valid OCaml lexeme. *) -let format_float_lexeme = - - (* To be revised: this procedure should be a unique loop that performs the - validity check and the string lexeme modification at the same time. - Otherwise, it is too difficult to handle the strange padding facilities - given by printf. Let alone handling the correct widths indication, - knowing that we have sometime to add a '.' at the end of the result! - *) - - let make_valid_float_lexeme s = - (* Check if s is already a valid lexeme: - in this case do nothing, - otherwise turn s into a valid OCaml lexeme. *) - let l = String.length s in - let rec valid_float_loop i = - if i >= l then s ^ "." else - match s.[i] with - (* Sure, this is already a valid float lexeme. *) - | '.' | 'e' | 'E' -> s - | _ -> valid_float_loop (i + 1) in - - valid_float_loop 0 in - - (fun sfmt x -> - match classify_float x with - | FP_normal | FP_subnormal | FP_zero -> - make_valid_float_lexeme (format_float sfmt x) - | FP_infinite -> - if x < 0.0 then "neg_infinity" else "infinity" - | FP_nan -> - "nan") -;; - -(* Decode a format string and act on it. - [fmt] is the [printf] format string, and [pos] points to a [%] character in - the format string. - After consuming the appropriate number of arguments and formatting - them, one of the following five continuations described below is called: - - - [cont_s] for outputting a string - (arguments: arg num, string, next pos) - - [cont_a] for performing a %a action - (arguments: arg num, fn, arg, next pos) - - [cont_t] for performing a %t action - (arguments: arg num, fn, next pos) - - [cont_f] for performing a flush action - (arguments: arg num, next pos) - - [cont_m] for performing a %( action - (arguments: arg num, sfmt, next pos) - - "arg num" is the index in array [args] of the next argument to [printf]. - "next pos" is the position in [fmt] of the first character following - the %conversion specification in [fmt]. *) - -(* Note: here, rather than test explicitly against [Sformat.length fmt] - to detect the end of the format, we use [Sformat.unsafe_get] and - rely on the fact that we'll get a "null" character if we access - one past the end of the string. These "null" characters are then - caught by the [_ -> bad_conversion] clauses below. - Don't do this at home, kids. *) -let scan_format fmt args n pos cont_s cont_a cont_t cont_f cont_m = - - let get_arg spec n = - Obj.magic (args.(Sformat.int_of_index (get_index spec n))) in - - let rec scan_positional n widths i = - let got_spec spec i = scan_flags spec n widths i in - scan_positional_spec fmt got_spec i - - and scan_flags spec n widths i = - match Sformat.unsafe_get fmt i with - | '*' -> - let got_spec wspec i = - let (width : int) = get_arg wspec n in - scan_flags spec (next_index wspec n) (width :: widths) i in - scan_positional_spec fmt got_spec (succ i) - | '0'..'9' - | '.' | '#' | '-' | ' ' | '+' -> scan_flags spec n widths (succ i) - | _ -> scan_conv spec n widths i - - and scan_conv spec n widths i = - match Sformat.unsafe_get fmt i with - | '%' | '@' as c -> - cont_s n (String.make 1 c) (succ i) - | '!' -> cont_f n (succ i) - | ',' -> cont_s n "" (succ i) - | 's' | 'S' as conv -> - let (x : string) = get_arg spec n in - let x = if conv = 's' then x else "\"" ^ String.escaped x ^ "\"" in - let s = - (* Optimize for common case %s *) - if i = succ pos then x else - format_string (extract_format fmt pos i widths) x in - cont_s (next_index spec n) s (succ i) - | '[' as conv -> - bad_conversion_format fmt i conv - | 'c' | 'C' as conv -> - let (x : char) = get_arg spec n in - let s = - if conv = 'c' then String.make 1 x else "'" ^ Char.escaped x ^ "'" in - cont_s (next_index spec n) s (succ i) - | 'd' | 'i' | 'o' | 'u' | 'x' | 'X' | 'N' as conv -> - let (x : int) = get_arg spec n in - let s = - format_int (extract_format_int conv fmt pos i widths) x in - cont_s (next_index spec n) s (succ i) - | 'f' | 'e' | 'E' | 'g' | 'G' -> - let (x : float) = get_arg spec n in - let s = format_float (extract_format fmt pos i widths) x in - cont_s (next_index spec n) s (succ i) - | 'F' as conv -> - let (x : float) = get_arg spec n in - let s = - format_float_lexeme - (if widths = [] - then "%.12g" - else extract_format_float conv fmt pos i widths) - x in - cont_s (next_index spec n) s (succ i) - | 'B' | 'b' -> - let (x : bool) = get_arg spec n in - cont_s (next_index spec n) (string_of_bool x) (succ i) - | 'a' -> - let printer = get_arg spec n in - (* If the printer spec is Spec_none, go on as usual. - If the printer spec is Spec_index p, - printer's argument spec is Spec_index (succ_index p). *) - let n = Sformat.succ_index (get_index spec n) in - let arg = get_arg Spec_none n in - cont_a (next_index spec n) printer arg (succ i) - | 'r' as conv -> - bad_conversion_format fmt i conv - | 't' -> - let printer = get_arg spec n in - cont_t (next_index spec n) printer (succ i) - | 'l' | 'n' | 'L' as conv -> - begin match Sformat.unsafe_get fmt (succ i) with - | 'd' | 'i' | 'o' | 'u' | 'x' | 'X' -> - let i = succ i in - let s = - match conv with - | 'l' -> - let (x : int32) = get_arg spec n in - format_int32 (extract_format fmt pos i widths) x - | 'n' -> - let (x : nativeint) = get_arg spec n in - format_nativeint (extract_format fmt pos i widths) x - | _ -> - let (x : int64) = get_arg spec n in - format_int64 (extract_format fmt pos i widths) x in - cont_s (next_index spec n) s (succ i) - | _ -> - let (x : int) = get_arg spec n in - let s = format_int (extract_format_int 'n' fmt pos i widths) x in - cont_s (next_index spec n) s (succ i) - end - | '{' | '(' as conv (* ')' '}' *) -> - let (xf : ('a, 'b, 'c, 'd, 'e, 'f) format6) = get_arg spec n in - let i = succ i in - let i = sub_format_for_printf conv fmt i in - if conv = '{' (* '}' *) then - (* Just print the format argument as a specification. *) - cont_s - (next_index spec n) - (summarize_format_type xf) - i else - (* Use the format argument instead of the format specification. *) - cont_m (next_index spec n) xf i - | (* '(' *) ')' -> - cont_s n "" (succ i) - | conv -> - bad_conversion_format fmt i conv in - - scan_positional n [] (succ pos) -;; - -let mkprintf to_s get_out outc outs flush k fmt = - - (* [out] is global to this definition of [pr], and must be shared by all its - recursive calls (if any). *) - let out = get_out fmt in - let outc c = outc out c in - let outs s = outs out s in - - let rec pr k n fmt v = - - let len = Sformat.length fmt in - - let rec doprn n i = - if i >= len then Obj.magic (k out) else - match Sformat.unsafe_get fmt i with - | '%' -> scan_format fmt v n i cont_s cont_a cont_t cont_f cont_m - | c -> outc c; doprn n (succ i) - - and cont_s n s i = - outs s; doprn n i - and cont_a n printer arg i = - if to_s then - outs ((Obj.magic printer : unit -> _ -> string) () arg) - else - printer out arg; - doprn n i - and cont_t n printer i = - if to_s then - outs ((Obj.magic printer : unit -> string) ()) - else - printer out; - doprn n i - and cont_f n i = - flush out; doprn n i - and cont_m n xf i = - let m = - Sformat.add_int_index - (count_printing_arguments_of_format xf) n in - pr (Obj.magic (fun _ -> doprn m i)) n xf v in - - doprn n 0 in - - let kpr = pr k (Sformat.index_of_int 0) in - - kapr kpr fmt -;; - -(************************************************************** - - Defining [fprintf] and various flavors of [fprintf]. - - **************************************************************) - -let kfprintf k oc = - mkprintf false (fun _ -> oc) output_char output_string flush k -;; -let ikfprintf k oc = kapr (fun _ _ -> Obj.magic (k oc));; - -let fprintf oc = kfprintf ignore oc;; -let ifprintf oc = ikfprintf ignore oc;; -let printf fmt = fprintf stdout fmt;; -let eprintf fmt = fprintf stderr fmt;; - -let kbprintf k b = - mkprintf false (fun _ -> b) Buffer.add_char Buffer.add_string ignore k -;; -let bprintf b = kbprintf ignore b;; - -let get_buff fmt = - let len = 2 * Sformat.length fmt in - Buffer.create len -;; - -let get_contents b = - let s = Buffer.contents b in - Buffer.clear b; - s -;; - -let get_cont k b = k (get_contents b);; - -let ksprintf k = - mkprintf true get_buff Buffer.add_char Buffer.add_string ignore (get_cont k) -;; - -let sprintf fmt = ksprintf (fun s -> s) fmt;; - -(************************************************************** - - Deprecated stuff. - - **************************************************************) - -let kprintf = ksprintf;; - -(* For OCaml system internal use only: needed to implement modules [Format] - and [Scanf]. *) - -module CamlinternalPr = struct - - module Sformat = Sformat;; - - module Tformat = struct - - type ac = - Ac.ac = { - mutable ac_rglr : int; - mutable ac_skip : int; - mutable ac_rdrs : int; - } - ;; - - let ac_of_format = ac_of_format;; - - let count_printing_arguments_of_format = - count_printing_arguments_of_format;; - - let sub_format = sub_format;; - - let summarize_format_type = summarize_format_type;; - - let scan_format = scan_format;; - - let kapr = kapr;; - - end - ;; - -end -;; +open CamlinternalFormatBasics +open CamlinternalFormat + +let kfprintf k o (Format (fmt, _)) = + make_printf (fun o acc -> output_acc o acc; k o) o End_of_acc fmt +let kbprintf k b (Format (fmt, _)) = + make_printf (fun b acc -> bufput_acc b acc; k b) b End_of_acc fmt +let ikfprintf k oc (Format (fmt, _)) = + make_printf (fun oc _ -> k oc) oc End_of_acc fmt + +let fprintf oc fmt = kfprintf ignore oc fmt +let bprintf b fmt = kbprintf ignore b fmt +let ifprintf oc fmt = ikfprintf ignore oc fmt +let printf fmt = fprintf stdout fmt +let eprintf fmt = fprintf stderr fmt + +let ksprintf k (Format (fmt, _)) = + let k' () acc = + let buf = Buffer.create 64 in + strput_acc buf acc; + k (Buffer.contents buf) in + make_printf k' () End_of_acc fmt + +let sprintf fmt = ksprintf (fun s -> s) fmt + +let kprintf = ksprintf diff --git a/stdlib/printf.mli b/stdlib/printf.mli index a75a64181..21e28159a 100644 --- a/stdlib/printf.mli +++ b/stdlib/printf.mli @@ -163,76 +163,5 @@ val kbprintf : (Buffer.t -> 'a) -> Buffer.t -> (** Deprecated *) -val kprintf : (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b;; +val kprintf : (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b (** A deprecated synonym for [ksprintf]. *) - -(**/**) - -(* The following is for system use only. Do not call directly. *) - -module CamlinternalPr : sig - - module Sformat : sig - type index;; - - val index_of_int : int -> index;; - external int_of_index : index -> int = "%identity";; - external unsafe_index_of_int : int -> index = "%identity";; - - val succ_index : index -> index;; - val add_int_index : int -> index -> index;; - - val sub : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> index -> int -> string;; - val to_string : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> string;; - external length : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> int - = "%string_length";; - external get : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> int -> char - = "%string_safe_get";; - external unsafe_to_string : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> string - = "%identity";; - external unsafe_get : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> int -> char - = "%string_unsafe_get";; - - end;; - - module Tformat : sig - - type ac = { - mutable ac_rglr : int; - mutable ac_skip : int; - mutable ac_rdrs : int; - };; - - val ac_of_format : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> ac;; - val count_printing_arguments_of_format : - ('a, 'b, 'c, 'd, 'e, 'f) format6 -> int;; - - val sub_format : - (('a, 'b, 'c, 'd, 'e, 'f) format6 -> int) -> - (('a, 'b, 'c, 'd, 'e, 'f) format6 -> int -> char -> int) -> - char -> - ('a, 'b, 'c, 'd, 'e, 'f) format6 -> - int -> - int - - val summarize_format_type : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> string - - val scan_format : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> - 'g array -> - Sformat.index -> - int -> - (Sformat.index -> string -> int -> 'h) -> - (Sformat.index -> 'i -> 'j -> int -> 'h) -> - (Sformat.index -> 'k -> int -> 'h) -> - (Sformat.index -> int -> 'h) -> - (Sformat.index -> ('l, 'm, 'n, 'o, 'p, 'q) format6 -> int -> 'h) -> - 'h - - val kapr : - (('a, 'b, 'c, 'd, 'e, 'f) format6 -> Obj.t array -> 'g) -> - ('a, 'b, 'c, 'd, 'e, 'f) format6 -> - 'g - - end;; - -end;; diff --git a/stdlib/queue.mli b/stdlib/queue.mli index 55e898832..5cd1136e4 100644 --- a/stdlib/queue.mli +++ b/stdlib/queue.mli @@ -16,7 +16,7 @@ This module implements queues (FIFOs), with in-place modification. {b Warning} This module is not thread-safe: each {!Queue.t} value - must be protected from concurrent access (e.g. with a {!Mutex.t}). + must be protected from concurrent access (e.g. with a [Mutex.t]). Failure to do so can lead to a crash. *) diff --git a/stdlib/scanf.ml b/stdlib/scanf.ml index 8f694fd3a..2a63ced9a 100644 --- a/stdlib/scanf.ml +++ b/stdlib/scanf.ml @@ -11,6 +11,19 @@ (* *) (***********************************************************************) +open CamlinternalFormatBasics +open CamlinternalFormat + +(* alias to avoid warning for ambiguity between + Pervasives.format6 + and CamlinternalFormatBasics.format6 + + (the former is in fact an alias for the latter, + but the ambiguity warning doesn't care) +*) +type ('a, 'b, 'c, 'd, 'e, 'f) format6 = + ('a, 'b, 'c, 'd, 'e, 'f) Pervasives.format6 + (* The run-time library for scanners. *) (* Scanning buffers. *) @@ -318,17 +331,17 @@ module Scanning : SCANNING = struct let from_ic scan_close_ic iname ic = let len = !file_buffer_size in - let buf = String.create len in + let buf = Bytes.create len in let i = ref 0 in let lim = ref 0 in let eof = ref false in let next () = - if !i < !lim then begin let c = buf.[!i] in incr i; c end else + if !i < !lim then begin let c = Bytes.get buf !i in incr i; c end else if !eof then raise End_of_file else begin lim := input ic buf 0 len; if !lim = 0 then begin eof := true; scan_close_ic ic end else begin i := 1; - buf.[0] + Bytes.get buf 0 end end in create iname next @@ -402,11 +415,6 @@ end type ('a, 'b, 'c, 'd) scanner = ('a, Scanning.in_channel, 'b, 'c, 'a -> 'd, 'd) format6 -> 'c -;; - -external string_to_format : - string -> ('a, 'b, 'c, 'd, 'e, 'f) format6 = "%identity" -;; (* Reporting errors. *) exception Scan_failure of string;; @@ -429,33 +437,6 @@ let bad_end_of_input message = (Printf.sprintf "scanning of %s failed: \ premature end of file occurred before end of token" message) -;; - -let int_of_width_opt = function - | None -> max_int - | Some width -> width -;; - -let int_of_prec_opt = function - | None -> max_int - | Some prec -> prec -;; - -module Sformat = Printf.CamlinternalPr.Sformat;; -module Tformat = Printf.CamlinternalPr.Tformat;; - -let bad_conversion fmt i c = - invalid_arg - (Printf.sprintf - "scanf: bad conversion %%%C, at char number %i \ - in format string \'%s\'" c i (Sformat.to_string fmt)) -;; - -let incomplete_format fmt = - invalid_arg - (Printf.sprintf "scanf: premature end of format string \'%s\'" - (Sformat.to_string fmt)) -;; let bad_float () = bad_input "no dot or exponent part found in float token" @@ -467,19 +448,15 @@ let character_mismatch_err c ci = let character_mismatch c ci = bad_input (character_mismatch_err c ci) -;; - -let format_mismatch_err fmt1 fmt2 = - Printf.sprintf - "format read \'%s\' does not match specification \'%s\'" fmt1 fmt2 -;; - -let format_mismatch fmt1 fmt2 = bad_input (format_mismatch_err fmt1 fmt2);; -(* Checking that 2 format strings are type compatible. *) -let compatible_format_type fmt1 fmt2 = - Tformat.summarize_format_type (string_to_format fmt1) = - Tformat.summarize_format_type (string_to_format fmt2);; +let rec skip_whites ib = + let c = Scanning.peek_char ib in + if not (Scanning.eof ib) then begin + match c with + | ' ' | '\t' | '\n' | '\r' -> + Scanning.invalidate_current_char ib; skip_whites ib + | _ -> () + end (* Checking that [c] is indeed in the input, then skips it. In this case, the character [c] has been explicitly specified in the @@ -496,28 +473,13 @@ let compatible_format_type fmt1 fmt2 = We are also careful to treat "\r\n" in the input as an end of line marker: it always matches a '\n' specification in the input format string. *) let rec check_char ib c = - let ci = Scanning.checked_peek_char ib in - if ci = c then Scanning.invalidate_current_char ib else begin - match ci with - | '\r' when c = '\n' -> - Scanning.invalidate_current_char ib; check_char ib '\n' - | _ -> character_mismatch c ci - end -;; - -(* Checks that the current char is indeed one of the stopper characters, - then skips it. - Be careful that if ib has no more character this procedure should - just do nothing (since %s@c defaults to the entire rest of the - buffer, when no character c can be found in the input). *) -let ignore_stoppers stps ib = - if stps <> [] && not (Scanning.eof ib) then - let ci = Scanning.peek_char ib in - if List.memq ci stps then Scanning.invalidate_current_char ib else - let sr = String.concat "" (List.map (String.make 1) stps) in - bad_input - (Printf.sprintf "looking for one of range %S, found %C" sr ci) -;; + if c = ' ' then skip_whites ib else + let ci = Scanning.checked_peek_char ib in + if ci = c then Scanning.invalidate_current_char ib else + match ci with + | '\r' when c = '\n' -> + Scanning.invalidate_current_char ib; check_char ib '\n' + | _ -> character_mismatch c ci (* Extracting tokens from the output token buffer. *) @@ -701,7 +663,7 @@ let scan_optionally_signed_int width ib = scan_unsigned_int width ib ;; -let scan_int_conv conv width _prec ib = +let scan_int_conv conv width ib = match conv with | 'b' -> scan_binary_int width ib | 'd' -> scan_optionally_signed_decimal_int width ib @@ -791,7 +753,7 @@ let scan_float width precision ib = scan_exp_part width ib, precision ;; -let scan_Float width precision ib = +let scan_caml_float width precision ib = let width = scan_optionally_signed_decimal_int width ib in if width = 0 then bad_float () else let c = Scanning.peek_char ib in @@ -805,12 +767,11 @@ let scan_Float width precision ib = | 'e' | 'E' -> scan_exp_part width ib | _ -> bad_float () -;; (* Scan a regular string: stops when encountering a space, if no scanning indication has been given; - otherwise, stops when encountering one of the characters in the scanning - indication list [stp]. + otherwise, stops when encountering the characters in the scanning + indication [stp]. It also stops at end of file or when the maximum number of characters has been read.*) let scan_string stp width ib = @@ -818,12 +779,14 @@ let scan_string stp width ib = if width = 0 then width else let c = Scanning.peek_char ib in if Scanning.eof ib then width else - if stp = [] then - match c with - | ' ' | '\t' | '\n' | '\r' -> width - | c -> loop (Scanning.store_char width ib c) else - if List.memq c stp then Scanning.skip_char width ib else - loop (Scanning.store_char width ib c) in + match stp with + | Some c' when c = c' -> Scanning.skip_char width ib + | Some _ -> loop (Scanning.store_char width ib c) + | None -> + match c with + | ' ' | '\t' | '\n' | '\r' -> width + | _ -> loop (Scanning.store_char width ib c) + in loop width ;; @@ -925,7 +888,7 @@ let scan_backslash_char width ib = ;; (* Scan a character (an OCaml token). *) -let scan_Char width ib = +let scan_caml_char width ib = let rec find_start width = match Scanning.checked_peek_char ib with @@ -948,7 +911,7 @@ let scan_Char width ib = ;; (* Scan a delimited string (an OCaml token). *) -let scan_String width ib = +let scan_caml_string width ib = let rec find_start width = match Scanning.checked_peek_char ib with @@ -981,8 +944,7 @@ let scan_String width ib = ;; (* Scan a boolean (an OCaml token). *) -let scan_bool width ib = - if width < 4 then bad_token_length "a boolean" else +let scan_bool ib = let c = Scanning.checked_peek_char ib in let m = match c with @@ -991,560 +953,384 @@ let scan_bool width ib = | c -> bad_input (Printf.sprintf "the character %C cannot start a boolean" c) in - scan_string [] (min width m) ib -;; - -(* Reading char sets in %[...] conversions. *) -type char_set = - | Pos_set of string (* Positive (regular) set. *) - | Neg_set of string (* Negative (complementary) set. *) -;; - - -(* Char sets are read as sub-strings in the format string. *) -let scan_range fmt j = - - let len = Sformat.length fmt in - - let buffer = Buffer.create len in - - let rec scan_closing j = - if j >= len then incomplete_format fmt else - match Sformat.get fmt j with - | ']' -> j, Buffer.contents buffer - | '%' -> - let j = j + 1 in - if j >= len then incomplete_format fmt else - begin match Sformat.get fmt j with - | '%' | '@' as c -> - Buffer.add_char buffer c; - scan_closing (j + 1) - | c -> bad_conversion fmt j c - end - | c -> - Buffer.add_char buffer c; - scan_closing (j + 1) in - - let scan_first_pos j = - if j >= len then incomplete_format fmt else - match Sformat.get fmt j with - | ']' as c -> - Buffer.add_char buffer c; - scan_closing (j + 1) - | _ -> scan_closing j in - - let scan_first_neg j = - if j >= len then incomplete_format fmt else - match Sformat.get fmt j with - | '^' -> - let j = j + 1 in - let k, char_set = scan_first_pos j in - k, Neg_set char_set - | _ -> - let k, char_set = scan_first_pos j in - k, Pos_set char_set in - - scan_first_neg j -;; - -(* Char sets are now represented as bit vectors that are represented as - byte strings. *) - -(* Bit manipulations into bytes. *) -let set_bit_of_byte byte idx b = - (b lsl idx) lor (byte land (* mask idx *) (lnot (1 lsl idx))) -;; - -let get_bit_of_byte byte idx = (byte lsr idx) land 1;; - -(* Bit manipulations in vectors of bytes represented as strings. *) -let set_bit_of_range r c b = - let idx = c land 0x7 in - let ydx = c lsr 3 in - let byte = r.[ydx] in - r.[ydx] <- char_of_int (set_bit_of_byte (int_of_char byte) idx b) -;; - -let get_bit_of_range r c = - let idx = c land 0x7 in - let ydx = c lsr 3 in - let byte = r.[ydx] in - get_bit_of_byte (int_of_char byte) idx -;; - -(* Char sets represented as bit vectors represented as fixed length byte - strings. *) -(* Create a full or empty set of chars. *) -let make_range bit = - let c = char_of_int (if bit = 0 then 0 else 0xFF) in - String.make 32 c -;; - -(* Test if a char belongs to a set of chars. *) -let get_char_in_range r c = get_bit_of_range r (int_of_char c);; - -let bit_not b = (lnot b) land 1;; - -(* Build the bit vector corresponding to the set of characters - that belongs to the string argument [set]. - (In the [Scanf] module [set] is always a sub-string of the format.) *) -let make_char_bit_vect bit set = - let r = make_range (bit_not bit) in - let lim = String.length set - 1 in - let rec loop bit rp i = - if i <= lim then - match set.[i] with - | '-' when rp -> - (* if i = 0 then rp is false (since the initial call is - loop bit false 0). Hence i >= 1 and the following is safe. *) - let c1 = set.[i - 1] in - let i = succ i in - if i > lim then loop bit false (i - 1) else - let c2 = set.[i] in - for j = int_of_char c1 to int_of_char c2 do - set_bit_of_range r j bit done; - loop bit false (succ i) - | _ -> - set_bit_of_range r (int_of_char set.[i]) bit; - loop bit true (succ i) in - loop bit false 0; - r -;; - -(* Compute the predicate on chars corresponding to a char set. *) -let make_predicate bit set stp = - let r = make_char_bit_vect bit set in - List.iter - (fun c -> set_bit_of_range r (int_of_char c) (bit_not bit)) stp; - (fun c -> get_char_in_range r c) -;; - -let make_setp stp char_set = - match char_set with - | Pos_set set -> - begin match String.length set with - | 0 -> (fun _ -> 0) - | 1 -> - let p = set.[0] in - (fun c -> if c == p then 1 else 0) - | 2 -> - let p1 = set.[0] and p2 = set.[1] in - (fun c -> if c == p1 || c == p2 then 1 else 0) - | 3 -> - let p1 = set.[0] and p2 = set.[1] and p3 = set.[2] in - if p2 = '-' then make_predicate 1 set stp else - (fun c -> if c == p1 || c == p2 || c == p3 then 1 else 0) - | _ -> make_predicate 1 set stp - end - | Neg_set set -> - begin match String.length set with - | 0 -> (fun _ -> 1) - | 1 -> - let p = set.[0] in - (fun c -> if c != p then 1 else 0) - | 2 -> - let p1 = set.[0] and p2 = set.[1] in - (fun c -> if c != p1 && c != p2 then 1 else 0) - | 3 -> - let p1 = set.[0] and p2 = set.[1] and p3 = set.[2] in - if p2 = '-' then make_predicate 0 set stp else - (fun c -> if c != p1 && c != p2 && c != p3 then 1 else 0) - | _ -> make_predicate 0 set stp - end -;; - -let setp_table = Hashtbl.create 7;; - -let add_setp stp char_set setp = - let char_set_tbl = - try Hashtbl.find setp_table char_set with - | Not_found -> - let char_set_tbl = Hashtbl.create 3 in - Hashtbl.add setp_table char_set char_set_tbl; - char_set_tbl in - Hashtbl.add char_set_tbl stp setp -;; + scan_string None m ib -let find_setp stp char_set = - try Hashtbl.find (Hashtbl.find setp_table char_set) stp with - | Not_found -> - let setp = make_setp stp char_set in - add_setp stp char_set setp; - setp -;; - -let scan_chars_in_char_set stp char_set width ib = - let rec loop_pos1 cp1 width = - if width = 0 then width else - let c = Scanning.peek_char ib in - if Scanning.eof ib then width else - if c == cp1 - then loop_pos1 cp1 (Scanning.store_char width ib c) - else width - and loop_pos2 cp1 cp2 width = - if width = 0 then width else - let c = Scanning.peek_char ib in - if Scanning.eof ib then width else - if c == cp1 || c == cp2 - then loop_pos2 cp1 cp2 (Scanning.store_char width ib c) - else width - and loop_pos3 cp1 cp2 cp3 width = - if width = 0 then width else - let c = Scanning.peek_char ib in - if Scanning.eof ib then width else - if c == cp1 || c == cp2 || c == cp3 - then loop_pos3 cp1 cp2 cp3 (Scanning.store_char width ib c) - else width - and loop_neg1 cp1 width = - if width = 0 then width else +(* Scan a string containing elements in char_set and terminated by scan_indic + if provided. *) +let scan_chars_in_char_set char_set scan_indic width ib = + let rec scan_chars i stp = let c = Scanning.peek_char ib in - if Scanning.eof ib then width else - if c != cp1 - then loop_neg1 cp1 (Scanning.store_char width ib c) - else width - and loop_neg2 cp1 cp2 width = - if width = 0 then width else - let c = Scanning.peek_char ib in - if Scanning.eof ib then width else - if c != cp1 && c != cp2 - then loop_neg2 cp1 cp2 (Scanning.store_char width ib c) - else width - and loop_neg3 cp1 cp2 cp3 width = - if width = 0 then width else - let c = Scanning.peek_char ib in - if Scanning.eof ib then width else - if c != cp1 && c != cp2 && c != cp3 - then loop_neg3 cp1 cp2 cp3 (Scanning.store_char width ib c) - else width - and loop setp width = - if width = 0 then width else - let c = Scanning.peek_char ib in - if Scanning.eof ib then width else - if setp c == 1 - then loop setp (Scanning.store_char width ib c) - else width in - - let width = - match char_set with - | Pos_set set -> - begin match String.length set with - | 0 -> loop (fun _ -> 0) width - | 1 -> loop_pos1 set.[0] width - | 2 -> loop_pos2 set.[0] set.[1] width - | 3 when set.[1] != '-' -> loop_pos3 set.[0] set.[1] set.[2] width - | _ -> loop (find_setp stp char_set) width end - | Neg_set set -> - begin match String.length set with - | 0 -> loop (fun _ -> 1) width - | 1 -> loop_neg1 set.[0] width - | 2 -> loop_neg2 set.[0] set.[1] width - | 3 when set.[1] != '-' -> loop_neg3 set.[0] set.[1] set.[2] width - | _ -> loop (find_setp stp char_set) width end in - ignore_stoppers stp ib; - width -;; - -let get_count t ib = - match t with - | 'l' -> Scanning.line_count ib - | 'n' -> Scanning.char_count ib - | _ -> Scanning.token_count ib -;; - -let rec skip_whites ib = - let c = Scanning.peek_char ib in - if not (Scanning.eof ib) then begin - match c with - | ' ' | '\t' | '\n' | '\r' -> - Scanning.invalidate_current_char ib; skip_whites ib - | _ -> () - end -;; + if i > 0 && not (Scanning.eof ib) && is_in_char_set char_set c && + int_of_char c <> stp then + let _ = Scanning.store_char max_int ib c in + scan_chars (i - 1) stp; + in + match scan_indic with + | None -> scan_chars width (-1); + | Some c -> + scan_chars width (int_of_char c); + if not (Scanning.eof ib) then + let ci = Scanning.peek_char ib in + if c = ci then Scanning.invalidate_current_char ib + else character_mismatch c ci (* The global error report function for [Scanf]. *) let scanf_bad_input ib = function | Scan_failure s | Failure s -> let i = Scanning.char_count ib in - bad_input (Printf.sprintf "scanf: bad input at char number %i: \'%s\'" i s) + bad_input (Printf.sprintf "scanf: bad input at char number %i: %S" i s) | x -> raise x -;; -let list_iter_i f l = - let rec loop i = function - | [] -> () - | [x] -> f i x (* Tail calling [f] *) - | x :: xs -> f i x; loop (succ i) xs in - loop 0 l -;; +(* Get the content of a counter from an input buffer. *) +let get_counter ib counter = match counter with + | Line_counter -> Scanning.line_count ib + | Char_counter -> Scanning.char_count ib + | Token_counter -> Scanning.token_count ib -let ascanf sc fmt = - let ac = Tformat.ac_of_format fmt in - match ac.Tformat.ac_rdrs with - | 0 -> - Obj.magic (fun f -> sc fmt [||] f) - | 1 -> - Obj.magic (fun x f -> sc fmt [| Obj.repr x |] f) - | 2 -> - Obj.magic (fun x y f -> sc fmt [| Obj.repr x; Obj.repr y; |] f) - | 3 -> - Obj.magic - (fun x y z f -> sc fmt [| Obj.repr x; Obj.repr y; Obj.repr z; |] f) - | nargs -> - let rec loop i args = - if i >= nargs then - let a = Array.make nargs (Obj.repr 0) in - list_iter_i (fun i arg -> a.(nargs - i - 1) <- arg) args; - Obj.magic (fun f -> sc fmt a f) - else Obj.magic (fun x -> loop (succ i) (x :: args)) in - loop 0 [] -;; - -(* The [scan_format] main scanning function. - It takes as arguments: - - an input buffer [ib] from which to read characters, - - an error handling function [ef], - - a format [fmt] that specifies what to read in the input, - - a vector of user's defined readers [rv], - - and a function [f] to pass the tokens read to. - - Then [scan_format] scans the format and the input buffer in parallel to - find out tokens as specified by the format; when it finds one token, it - converts it as specified, remembers the converted value as a future - argument to the function [f], and continues scanning. - - If the entire scanning succeeds (i.e. the format string has been - exhausted and the buffer has provided tokens according to the - format string), [f] is applied to the tokens read. - - If the scanning or some conversion fails, the main scanning function - aborts and applies the scanning buffer and a string that explains - the error to the error handling function [ef] (the error continuation). *) - -let scan_format ib ef fmt rv f = - - let limr = Array.length rv - 1 in - - let return v = Obj.magic v () in - let delay f x () = f x in - let stack f = delay (return f) in - let no_stack f _x = f in - - let rec scan fmt = - - let lim = Sformat.length fmt - 1 in - - let rec scan_fmt ir f i = - if i > lim then ir, f else - match Sformat.unsafe_get fmt i with - | '%' -> scan_skip ir f (succ i) - | ' ' -> skip_whites ib; scan_fmt ir f (succ i) - | c -> check_char ib c; scan_fmt ir f (succ i) - - and scan_skip ir f i = - if i > lim then ir, f else - match Sformat.get fmt i with - | '_' -> scan_limits true ir f (succ i) - | _ -> scan_limits false ir f i - - and scan_limits skip ir f i = - - let rec scan_width i = - if i > lim then incomplete_format fmt else - match Sformat.get fmt i with - | '0' .. '9' as conv -> - let width, i = - read_int_literal (decimal_value_of_char conv) (succ i) in - Some width, i - | _ -> None, i - - and scan_precision i = - begin - match Sformat.get fmt i with - | '.' -> - let precision, i = read_int_literal 0 (succ i) in - (Some precision, i) - | _ -> None, i - end +(* Compute the width of a padding option (see "%42{" and "%123("). *) +let width_of_pad_opt pad_opt = match pad_opt with + | None -> max_int + | Some width -> width - and read_int_literal accu i = - if i > lim then accu, i else - match Sformat.unsafe_get fmt i with - | '0' .. '9' as c -> - let accu = 10 * accu + decimal_value_of_char c in - read_int_literal accu (succ i) - | _ -> accu, i in - - if i > lim then ir, f else - let width_opt, i = scan_width i in - let prec_opt, i = scan_precision i in - scan_conversion skip width_opt prec_opt ir f i - - and scan_conversion skip width_opt prec_opt ir f i = - let stack = if skip then no_stack else stack in - let width = int_of_width_opt width_opt in - let prec = int_of_prec_opt prec_opt in - match Sformat.get fmt i with - | '%' | '@' as c -> - check_char ib c; - scan_fmt ir f (succ i) - | '!' -> - if not (Scanning.end_of_input ib) - then bad_input "end of input not found" else - scan_fmt ir f (succ i) - | ',' -> - scan_fmt ir f (succ i) - | 's' -> - let i, stp = scan_indication (succ i) in - let _x = scan_string stp width ib in - scan_fmt ir (stack f (token_string ib)) (succ i) - | 'S' -> - let _x = scan_String width ib in - scan_fmt ir (stack f (token_string ib)) (succ i) - | '[' (* ']' *) -> - let i, char_set = scan_range fmt (succ i) in - let i, stp = scan_indication (succ i) in - let _x = scan_chars_in_char_set stp char_set width ib in - scan_fmt ir (stack f (token_string ib)) (succ i) - | ('c' | 'C') when width = 0 -> - let c = Scanning.checked_peek_char ib in - scan_fmt ir (stack f c) (succ i) - | 'c' -> - let _x = scan_char width ib in - scan_fmt ir (stack f (token_char ib)) (succ i) - | 'C' -> - let _x = scan_Char width ib in - scan_fmt ir (stack f (token_char ib)) (succ i) - | 'd' | 'i' | 'o' | 'u' | 'x' | 'X' as conv -> - let _x = scan_int_conv conv width prec ib in - scan_fmt ir (stack f (token_int conv ib)) (succ i) - | 'N' as conv -> - scan_fmt ir (stack f (get_count conv ib)) (succ i) - | 'f' | 'e' | 'E' | 'g' | 'G' -> - let _x = scan_float width prec ib in - scan_fmt ir (stack f (token_float ib)) (succ i) - | 'F' -> - let _x = scan_Float width prec ib in - scan_fmt ir (stack f (token_float ib)) (succ i) -(* | 'B' | 'b' when width = Some 0 -> - let _x = scan_bool width ib in - scan_fmt ir (stack f (token_int ib)) (succ i) *) - | 'B' | 'b' -> - let _x = scan_bool width ib in - scan_fmt ir (stack f (token_bool ib)) (succ i) - | 'r' -> - if ir > limr then assert false else - let token = Obj.magic rv.(ir) ib in - scan_fmt (succ ir) (stack f token) (succ i) - | 'l' | 'n' | 'L' as conv0 -> - let i = succ i in - if i > lim then scan_fmt ir (stack f (get_count conv0 ib)) i else begin - match Sformat.get fmt i with - (* This is in fact an integer conversion (e.g. %ld, %ni, or %Lo). *) - | 'd' | 'i' | 'o' | 'u' | 'x' | 'X' as conv1 -> - let _x = scan_int_conv conv1 width prec ib in - (* Look back to the character that triggered the integer conversion - (this character is either 'l', 'n' or 'L') to find the - conversion to apply to the integer token read. *) - begin match conv0 with - | 'l' -> scan_fmt ir (stack f (token_int32 conv1 ib)) (succ i) - | 'n' -> scan_fmt ir (stack f (token_nativeint conv1 ib)) (succ i) - | _ -> scan_fmt ir (stack f (token_int64 conv1 ib)) (succ i) end - (* This is not an integer conversion, but a regular %l, %n or %L. *) - | _ -> scan_fmt ir (stack f (get_count conv0 ib)) i end - | '(' | '{' as conv (* ')' '}' *) -> - let i = succ i in - (* Find [mf], the static specification for the format to read. *) - let j = - Tformat.sub_format - incomplete_format bad_conversion conv fmt i in - let mf = Sformat.sub fmt (Sformat.index_of_int i) (j - 2 - i) in - (* Read [rf], the specified format string in the input buffer, - and check its correctness w.r.t. [mf]. *) - let _x = scan_String width ib in - let rf = token_string ib in - if not (compatible_format_type rf mf) then format_mismatch rf mf else - (* Proceed according to the kind of metaformat found: - - %{ mf %} simply returns [rf] as the token read, - - %( mf %) returns [rf] as the first token read, then - returns a second token obtained by scanning the input with - format string [rf]. - Behaviour for %( mf %) is mandatory for sake of format string - typechecking specification. To get pure format string - substitution behaviour, you should use %_( mf %) that skips the - first (format string) token and hence properly substitutes [mf] by - [rf] in the format string argument. +let stopper_of_formatting_lit fmting = + if fmting = Escaped_percent then '%', "" else + let str = string_of_formatting_lit fmting in + let stp = str.[1] in + let sub_str = String.sub str 2 (String.length str - 2) in + stp, sub_str + +(******************************************************************************) + (* Readers managment *) + +(* A call to take_format_readers on a format is evaluated into functions + taking readers as arguments and aggregate them into an heterogeneous list *) +(* When all readers are taken, finally pass the list of the readers to the + continuation k. *) +let rec take_format_readers : type a c d e f . + ((d, e) heter_list -> e) -> (a, Scanning.in_channel, c, d, e, f) fmt -> + d = +fun k fmt -> match fmt with + | Reader fmt_rest -> + fun reader -> + let new_k readers_rest = k (Cons (reader, readers_rest)) in + take_format_readers new_k fmt_rest + | Char rest -> take_format_readers k rest + | Caml_char rest -> take_format_readers k rest + | String (_, rest) -> take_format_readers k rest + | Caml_string (_, rest) -> take_format_readers k rest + | Int (_, _, _, rest) -> take_format_readers k rest + | Int32 (_, _, _, rest) -> take_format_readers k rest + | Nativeint (_, _, _, rest) -> take_format_readers k rest + | Int64 (_, _, _, rest) -> take_format_readers k rest + | Float (_, _, _, rest) -> take_format_readers k rest + | Bool rest -> take_format_readers k rest + | Alpha rest -> take_format_readers k rest + | Theta rest -> take_format_readers k rest + | Flush rest -> take_format_readers k rest + | String_literal (_, rest) -> take_format_readers k rest + | Char_literal (_, rest) -> take_format_readers k rest + + | Scan_char_set (_, _, rest) -> take_format_readers k rest + | Scan_get_counter (_, rest) -> take_format_readers k rest + + | Formatting_lit (_, rest) -> take_format_readers k rest + | Formatting_gen (Open_tag (Format (fmt, _)), rest) -> take_format_readers k (concat_fmt fmt rest) + | Formatting_gen (Open_box (Format (fmt, _)), rest) -> take_format_readers k (concat_fmt fmt rest) + + | Format_arg (_, _, rest) -> take_format_readers k rest + | Format_subst (_, fmtty, rest) -> + take_fmtty_format_readers k (erase_rel (symm fmtty)) rest + | Ignored_param (ign, rest) -> take_ignored_format_readers k ign rest + + | End_of_format -> k Nil + +(* Take readers associated to an fmtty coming from a Format_subst "%(...%)". *) +and take_fmtty_format_readers : type x y a c d e f . + ((d, e) heter_list -> e) -> (a, Scanning.in_channel, c, d, x, y) fmtty -> + (y, Scanning.in_channel, c, x, e, f) fmt -> d = +fun k fmtty fmt -> match fmtty with + | Reader_ty fmt_rest -> + fun reader -> + let new_k readers_rest = k (Cons (reader, readers_rest)) in + take_fmtty_format_readers new_k fmt_rest fmt + | Ignored_reader_ty fmt_rest -> + fun reader -> + let new_k readers_rest = k (Cons (reader, readers_rest)) in + take_fmtty_format_readers new_k fmt_rest fmt + | Char_ty rest -> take_fmtty_format_readers k rest fmt + | String_ty rest -> take_fmtty_format_readers k rest fmt + | Int_ty rest -> take_fmtty_format_readers k rest fmt + | Int32_ty rest -> take_fmtty_format_readers k rest fmt + | Nativeint_ty rest -> take_fmtty_format_readers k rest fmt + | Int64_ty rest -> take_fmtty_format_readers k rest fmt + | Float_ty rest -> take_fmtty_format_readers k rest fmt + | Bool_ty rest -> take_fmtty_format_readers k rest fmt + | Alpha_ty rest -> take_fmtty_format_readers k rest fmt + | Theta_ty rest -> take_fmtty_format_readers k rest fmt + | Format_arg_ty (_, rest) -> take_fmtty_format_readers k rest fmt + | End_of_fmtty -> take_format_readers k fmt + | Format_subst_ty (ty1, ty2, rest) -> + let ty = trans (symm ty1) ty2 in + take_fmtty_format_readers k (concat_fmtty ty rest) fmt + +(* Take readers associated to an ignored parameter. *) +and take_ignored_format_readers : type x y a c d e f . + ((d, e) heter_list -> e) -> (a, Scanning.in_channel, c, d, x, y) ignored -> + (y, Scanning.in_channel, c, x, e, f) fmt -> d = +fun k ign fmt -> match ign with + | Ignored_reader -> + fun reader -> + let new_k readers_rest = k (Cons (reader, readers_rest)) in + take_format_readers new_k fmt + | Ignored_char -> take_format_readers k fmt + | Ignored_caml_char -> take_format_readers k fmt + | Ignored_string _ -> take_format_readers k fmt + | Ignored_caml_string _ -> take_format_readers k fmt + | Ignored_int (_, _) -> take_format_readers k fmt + | Ignored_int32 (_, _) -> take_format_readers k fmt + | Ignored_nativeint (_, _) -> take_format_readers k fmt + | Ignored_int64 (_, _) -> take_format_readers k fmt + | Ignored_float (_, _) -> take_format_readers k fmt + | Ignored_bool -> take_format_readers k fmt + | Ignored_format_arg _ -> take_format_readers k fmt + | Ignored_format_subst (_, fmtty) -> take_fmtty_format_readers k fmtty fmt + | Ignored_scan_char_set _ -> take_format_readers k fmt + | Ignored_scan_get_counter _ -> take_format_readers k fmt + +(******************************************************************************) + (* Generic scanning *) + +(* Make a generic scanning function. *) +(* Scan a stream according to a format and readers obtained by + take_format_readers, and aggegate scanned values into an + heterogeneous list. *) +(* Return the heterogeneous list of scanned values. *) +let rec make_scanf : type a c d e f . + Scanning.in_channel -> (a, Scanning.in_channel, c, d, e, f) fmt -> + (d, _) heter_list -> (a, f) heter_list = +fun ib fmt readers -> match fmt with + | Char rest -> + let _ = scan_char 0 ib in + let c = token_char ib in + Cons (c, make_scanf ib rest readers) + | Caml_char rest -> + let _ = scan_caml_char 0 ib in + let c = token_char ib in + Cons (c, make_scanf ib rest readers) + + | String (pad, Formatting_lit (fmting_lit, rest)) -> + let stp, str = stopper_of_formatting_lit fmting_lit in + let scan width _ ib = scan_string (Some stp) width ib in + let str_rest = String_literal (str, rest) in + pad_prec_scanf ib str_rest readers pad No_precision scan token_string + | String (pad, rest) -> + let scan width _ ib = scan_string None width ib in + pad_prec_scanf ib rest readers pad No_precision scan token_string + + | Caml_string (pad, rest) -> + let scan width _ ib = scan_caml_string width ib in + pad_prec_scanf ib rest readers pad No_precision scan token_string + | Int (iconv, pad, prec, rest) -> + let c = char_of_iconv iconv in + let scan width _ ib = scan_int_conv c width ib in + pad_prec_scanf ib rest readers pad prec scan (token_int c) + | Int32 (iconv, pad, prec, rest) -> + let c = char_of_iconv iconv in + let scan width _ ib = scan_int_conv c width ib in + pad_prec_scanf ib rest readers pad prec scan (token_int32 c) + | Nativeint (iconv, pad, prec, rest) -> + let c = char_of_iconv iconv in + let scan width _ ib = scan_int_conv c width ib in + pad_prec_scanf ib rest readers pad prec scan (token_nativeint c) + | Int64 (iconv, pad, prec, rest) -> + let c = char_of_iconv iconv in + let scan width _ ib = scan_int_conv c width ib in + pad_prec_scanf ib rest readers pad prec scan (token_int64 c) + | Float (Float_F, pad, prec, rest) -> + pad_prec_scanf ib rest readers pad prec scan_caml_float token_float + | Float ((Float_f | Float_pf | Float_sf | Float_e | Float_pe | Float_se + | Float_E | Float_pE | Float_sE | Float_g | Float_pg | Float_sg + | Float_G | Float_pG | Float_sG), pad, prec, rest) -> + pad_prec_scanf ib rest readers pad prec scan_float token_float + + | Bool rest -> + let _ = scan_bool ib in + let b = token_bool ib in + Cons (b, make_scanf ib rest readers) + | Alpha _ -> + invalid_arg "scanf: bad conversion \"%a\"" + | Theta _ -> + invalid_arg "scanf: bad conversion \"%t\"" + | Reader fmt_rest -> + let Cons (reader, readers_rest) = readers in + let x = reader ib in + Cons (x, make_scanf ib fmt_rest readers_rest) + | Flush rest -> + if Scanning.end_of_input ib then make_scanf ib rest readers + else bad_input "end of input not found" + + | String_literal (str, rest) -> + String.iter (check_char ib) str; + make_scanf ib rest readers + | Char_literal (chr, rest) -> + check_char ib chr; + make_scanf ib rest readers + + | Format_arg (pad_opt, fmtty, rest) -> + let _ = scan_caml_string (width_of_pad_opt pad_opt) ib in + let s = token_string ib in + let fmt = + try format_of_string_fmtty s fmtty + with Failure msg -> bad_input msg + in + Cons (fmt, make_scanf ib rest readers) + | Format_subst (pad_opt, fmtty, rest) -> + let _ = scan_caml_string (width_of_pad_opt pad_opt) ib in + let s = token_string ib in + let fmt, fmt' = + try + let Fmt_EBB fmt = fmt_ebb_of_string s in + let Fmt_EBB fmt' = fmt_ebb_of_string s in + (* TODO: find a way to avoid reparsing twice *) + + (* TODO: these type-checks below *can* fail because of type + ambiguity in presence of ignored-readers: "%_r%d" and "%d%_r" + are typed in the same way. + + # Scanf.sscanf "\"%_r%d\"3" "%(%d%_r%)" ignore + (fun fmt n -> string_of_format fmt, n);; + Exception: CamlinternalFormat.Type_mismatch. + + We should properly catch this exception. *) - (* For conversion %{%}, just return this format string as the token - read and go on with the rest of the format string argument. *) - if conv = '{' (* '}' *) then scan_fmt ir (stack f rf) j else - (* Or else, return this format string as the first token read; - then continue scanning using this format string to get - the following token read; - finally go on with the rest of the format string argument. *) - let ir, nf = scan (string_to_format rf) ir (stack f rf) 0 in - (* Return the format string read and the value just read, - then go on with the rest of the format. *) - scan_fmt ir nf j - - | c -> bad_conversion fmt i c - - and scan_indication j = - if j > lim then j - 1, [] else - match Sformat.get fmt j with - | '@' -> - let k = j + 1 in - if k > lim then j - 1, [] else - begin match Sformat.get fmt k with - | '%' -> - let k = k + 1 in - if k > lim then j - 1, [] else - begin match Sformat.get fmt k with - | '%' | '@' as c -> k, [ c ] - | _c -> j - 1, [] - end - | c -> k, [ c ] - end - | _c -> j - 1, [] in - - scan_fmt in - - - Scanning.reset_token ib; - - let v = - try snd (scan fmt 0 (fun () -> f) 0) with - | (Scan_failure _ | Failure _ | End_of_file) as exc -> - stack (delay ef ib) exc in - return v -;; - -let mkscanf ib ef fmt = - let sc = scan_format ib ef in - ascanf sc fmt -;; - -let kscanf ib ef fmt = mkscanf ib ef fmt;; - -let bscanf ib = kscanf ib scanf_bad_input;; - -let fscanf ic = bscanf (Scanning.from_channel ic);; - -let sscanf : string -> ('a, 'b, 'c, 'd) scanner - = fun s -> bscanf (Scanning.from_string s);; - -let scanf fmt = bscanf Scanning.stdib fmt;; - -let bscanf_format ib fmt f = - let fmt = Sformat.unsafe_to_string fmt in - let fmt1 = - ignore (scan_String max_int ib); - token_string ib in - if not (compatible_format_type fmt1 fmt) then - format_mismatch fmt1 fmt else - f (string_to_format fmt1) -;; + type_format fmt (erase_rel fmtty), + type_format fmt' (erase_rel (symm fmtty)) + with Failure msg -> bad_input msg + in + Cons (Format (fmt, s), + make_scanf ib (concat_fmt fmt' rest) readers) + + | Scan_char_set (width_opt, char_set, Formatting_lit (fmting_lit, rest)) -> + let stp, str = stopper_of_formatting_lit fmting_lit in + let width = width_of_pad_opt width_opt in + let _ = scan_chars_in_char_set char_set (Some stp) width ib in + let s = token_string ib in + let str_rest = String_literal (str, rest) in + Cons (s, make_scanf ib str_rest readers) + | Scan_char_set (width_opt, char_set, rest) -> + let width = width_of_pad_opt width_opt in + let _ = scan_chars_in_char_set char_set None width ib in + let s = token_string ib in + Cons (s, make_scanf ib rest readers) + | Scan_get_counter (counter, rest) -> + let count = get_counter ib counter in + Cons (count, make_scanf ib rest readers) + + | Formatting_lit (formatting_lit, rest) -> + String.iter (check_char ib) (string_of_formatting_lit formatting_lit); + make_scanf ib rest readers + | Formatting_gen (Open_tag (Format (fmt', _)), rest) -> + check_char ib '@'; check_char ib '{'; + make_scanf ib (concat_fmt fmt' rest) readers + | Formatting_gen (Open_box (Format (fmt', _)), rest) -> + check_char ib '@'; check_char ib '['; + make_scanf ib (concat_fmt fmt' rest) readers + + | Ignored_param (ign, rest) -> + let Param_format_EBB fmt' = param_format_of_ignored_format ign rest in + begin match make_scanf ib fmt' readers with + | Cons (_, arg_rest) -> arg_rest + | Nil -> assert false + end -let sscanf_format s fmt = bscanf_format (Scanning.from_string s) fmt;; + | End_of_format -> + Nil + +(* Case analysis on padding and precision. *) +(* Reject formats containing "%*" or "%.*". *) +(* Pass padding and precision to the generic scanner `scan'. *) +and pad_prec_scanf : type a c d e f x y z t . + Scanning.in_channel -> (a, Scanning.in_channel, c, d, e, f) fmt -> + (d, _) heter_list -> (x, y) padding -> (y, z -> a) precision -> + (int -> int -> Scanning.in_channel -> t) -> + (Scanning.in_channel -> z) -> + (x, f) heter_list = +fun ib fmt readers pad prec scan token -> match pad, prec with + | No_padding, No_precision -> + let _ = scan max_int max_int ib in + let x = token ib in + Cons (x, make_scanf ib fmt readers) + | No_padding, Lit_precision p -> + let _ = scan max_int p ib in + let x = token ib in + Cons (x, make_scanf ib fmt readers) + | Lit_padding ((Right | Zeros), w), No_precision -> + let _ = scan w max_int ib in + let x = token ib in + Cons (x, make_scanf ib fmt readers) + | Lit_padding ((Right | Zeros), w), Lit_precision p -> + let _ = scan w p ib in + let x = token ib in + Cons (x, make_scanf ib fmt readers) + | Lit_padding (Left, _), _ -> + invalid_arg "scanf: bad conversion \"%-\"" + | Lit_padding ((Right | Zeros), _), Arg_precision -> + invalid_arg "scanf: bad conversion \"%*\"" + | Arg_padding _, _ -> + invalid_arg "scanf: bad conversion \"%*\"" + | No_padding, Arg_precision -> + invalid_arg "scanf: bad conversion \"%*\"" + +(******************************************************************************) + (* Defining [scanf] and various flavors of [scanf] *) + +type 'a kscanf_result = Args of 'a | Exc of exn + +let kscanf ib ef (Format (fmt, str)) = + let rec apply : type a b . a -> (a, b) heter_list -> b = + fun f args -> match args with + | Cons (x, r) -> apply (f x) r + | Nil -> f + in + let k readers f = + Scanning.reset_token ib; + match try Args (make_scanf ib fmt readers) with + | (Scan_failure _ | Failure _ | End_of_file) as exc -> Exc exc + | Invalid_argument msg -> + invalid_arg (msg ^ " in format \"" ^ String.escaped str ^ "\"") + with + | Args args -> apply f args + | Exc exc -> ef ib exc + in + take_format_readers k fmt + +let kbscanf = kscanf + +(***) + +let ksscanf s ef fmt = kbscanf (Scanning.from_string s) ef fmt +let kfscanf ic ef fmt = kbscanf (Scanning.from_channel ic) ef fmt +let bscanf ib fmt = kscanf ib scanf_bad_input fmt +let fscanf ic fmt = kscanf (Scanning.from_channel ic) scanf_bad_input fmt +let sscanf s fmt = kscanf (Scanning.from_string s) scanf_bad_input fmt +let scanf fmt = kscanf Scanning.stdib scanf_bad_input fmt + +(***) + +let bscanf_format : Scanning.in_channel -> ('a, 'b, 'c, 'd, 'e, 'f) format6 -> + (('a, 'b, 'c, 'd, 'e, 'f) format6 -> 'g) -> 'g = + fun ib format f -> + let _ = scan_caml_string max_int ib in + let str = token_string ib in + let fmt' = + try format_of_string_format str format + with Failure msg -> bad_input msg + in + f fmt' + +let sscanf_format : string -> ('a, 'b, 'c, 'd, 'e, 'f) format6 -> + (('a, 'b, 'c, 'd, 'e, 'f) format6 -> 'g) -> 'g = + fun s format f -> bscanf_format (Scanning.from_string s) format f let string_to_String s = let l = String.length s in @@ -1566,9 +1352,3 @@ let format_from_string s fmt = let unescaped s = sscanf ("\"" ^ s ^ "\"") "%S%!" (fun x -> x) ;; - -(* - Local Variables: - compile-command: "cd ..; make world" - End: -*) diff --git a/stdlib/scanf.mli b/stdlib/scanf.mli index a1b3d1acb..297d6f2d5 100644 --- a/stdlib/scanf.mli +++ b/stdlib/scanf.mli @@ -485,6 +485,16 @@ val kscanf : exception that aborted the scanning process as arguments. *) +val ksscanf : + string -> (Scanning.in_channel -> exn -> 'd) -> + ('a, 'b, 'c, 'd) scanner +(** Same as {!Scanf.kscanf} but reads from the given string. *) + +val kfscanf : + Pervasives.in_channel -> (Scanning.in_channel -> exn -> 'd) -> + ('a, 'b, 'c, 'd) scanner +(** Same as {!Scanf.kscanf}, but reads from the given regular input channel. *) + (** {6 Reading format strings from input} *) val bscanf_format : diff --git a/stdlib/set.ml b/stdlib/set.ml index 1d049b139..5c6212d88 100644 --- a/stdlib/set.ml +++ b/stdlib/set.ml @@ -363,7 +363,8 @@ module Make(Ord: OrderedType) = | 0, l -> Empty, l | 1, x0 :: l -> Node (Empty, x0, Empty, 1), l | 2, x0 :: x1 :: l -> Node (Node(Empty, x0, Empty, 1), x1, Empty, 2), l - | 3, x0 :: x1 :: x2 :: l -> Node (Node(Empty, x0, Empty, 1), x1, Node(Empty, x2, Empty, 1), 2), l + | 3, x0 :: x1 :: x2 :: l -> + Node (Node(Empty, x0, Empty, 1), x1, Node(Empty, x2, Empty, 1), 2),l | n, l -> let nl = n / 2 in let left, l = sub nl l in diff --git a/stdlib/set.mli b/stdlib/set.mli index 556ee9388..1b67398ee 100644 --- a/stdlib/set.mli +++ b/stdlib/set.mli @@ -19,6 +19,27 @@ The implementation uses balanced binary trees, and is therefore reasonably efficient: insertion and membership take time logarithmic in the size of the set, for instance. + + The [Make] functor constructs implementations for any type, given a + [compare] function. + For instance: + {[ + module IntPairs = + struct + type t = int * int + let compare (x0,y0) (x1,y1) = + match Pervasives.compare x0 x1 with + 0 -> Pervasives.compare y0 y1 + | c -> c + end + + module PairsSet = Set.Make(IntPairs) + + let m = PairsSet.(empty |> add (2,3) |> add (5,7) |> add (11,13)) + ]} + + This creates a new module [PairsSet], with a new type [PairsSet.t] + of sets of [int * int]. *) module type OrderedType = diff --git a/stdlib/sort.mli b/stdlib/sort.mli index d5abb79fa..a9be27e13 100644 --- a/stdlib/sort.mli +++ b/stdlib/sort.mli @@ -20,11 +20,13 @@ *) val list : ('a -> 'a -> bool) -> 'a list -> 'a list + [@@ocaml.deprecated] (** Sort a list in increasing order according to an ordering predicate. The predicate should return [true] if its first argument is less than or equal to its second argument. *) val array : ('a -> 'a -> bool) -> 'a array -> unit + [@@ocaml.deprecated] (** Sort an array in increasing order according to an ordering predicate. The predicate should return [true] if its first argument is @@ -32,6 +34,7 @@ val array : ('a -> 'a -> bool) -> 'a array -> unit The array is sorted in place. *) val merge : ('a -> 'a -> bool) -> 'a list -> 'a list -> 'a list + [@@ocaml.deprecated] (** Merge two lists according to the given predicate. Assuming the two argument lists are sorted according to the predicate, [merge] returns a sorted list containing the elements diff --git a/stdlib/stdLabels.ml b/stdlib/stdLabels.ml index 35b25e0b7..60713ca0c 100644 --- a/stdlib/stdLabels.ml +++ b/stdlib/stdLabels.ml @@ -18,3 +18,5 @@ module Array = ArrayLabels module List = ListLabels module String = StringLabels + +module Bytes = BytesLabels diff --git a/stdlib/stdLabels.mli b/stdlib/stdLabels.mli index 144936f17..c607a9987 100644 --- a/stdlib/stdLabels.mli +++ b/stdlib/stdLabels.mli @@ -14,12 +14,14 @@ (** Standard labeled libraries. This meta-module provides labelized version of the {!Array}, - {!List} and {!String} modules. + {!Bytes}, {!List} and {!String} modules. They only differ by their labels. Detailed interfaces can be found - in [arrayLabels.mli], [listLabels.mli] and [stringLabels.mli]. + in [arrayLabels.mli], [bytesLabels.mli], [listLabels.mli] + and [stringLabels.mli]. *) module Array = ArrayLabels +module Bytes = BytesLabels module List = ListLabels module String = StringLabels diff --git a/stdlib/stream.ml b/stdlib/stream.ml index 753bce005..751c741a8 100644 --- a/stdlib/stream.ml +++ b/stdlib/stream.ml @@ -25,7 +25,7 @@ and 'a data = | Sbuffio of buffio and 'a gen = { mutable curr : 'a option option; func : int -> 'a option } and buffio = - { ic : in_channel; buff : string; mutable len : int; mutable ind : int } + { ic : in_channel; buff : bytes; mutable len : int; mutable ind : int } ;; exception Failure;; exception Error of string;; @@ -37,7 +37,7 @@ let set_data (s : 'a t) (d : 'a data) = ;; let fill_buff b = - b.len <- input b.ic b.buff 0 (String.length b.buff); b.ind <- 0 + b.len <- input b.ic b.buff 0 (Bytes.length b.buff); b.ind <- 0 ;; let rec get_data count d = match d with @@ -64,7 +64,7 @@ let rec get_data count d = match d with | Sbuffio b -> if b.ind >= b.len then fill_buff b; if b.len == 0 then Sempty else - let r = Obj.magic (String.unsafe_get b.buff b.ind) in + let r = Obj.magic (Bytes.unsafe_get b.buff b.ind) in (* Warning: anyone using g thinks that an item has been read *) b.ind <- succ b.ind; Scons(r, d) | Slazy f -> get_data count (Lazy.force f) @@ -87,7 +87,7 @@ let rec peek s = | Sbuffio b -> if b.ind >= b.len then fill_buff b; if b.len == 0 then begin set_data s Sempty; None end - else Some (Obj.magic (String.unsafe_get b.buff b.ind)) + else Some (Obj.magic (Bytes.unsafe_get b.buff b.ind)) ;; let rec junk s = @@ -159,9 +159,18 @@ let of_string s = else None) ;; +let of_bytes s = + let count = ref 0 in + from (fun _ -> + let c = !count in + if c < Bytes.length s + then (incr count; Some (Bytes.get s c)) + else None) +;; + let of_channel ic = {count = 0; - data = Sbuffio {ic = ic; buff = String.create 4096; len = 0; ind = 0}} + data = Sbuffio {ic = ic; buff = Bytes.create 4096; len = 0; ind = 0}} ;; (* Stream expressions builders *) diff --git a/stdlib/stream.mli b/stdlib/stream.mli index aeb0da1e8..85a846102 100644 --- a/stdlib/stream.mli +++ b/stdlib/stream.mli @@ -46,6 +46,9 @@ val of_list : 'a list -> 'a t val of_string : string -> char t (** Return the stream of the characters of the string parameter. *) +val of_bytes : bytes -> char t +(** Return the stream of the characters of the bytes parameter. *) + val of_channel : in_channel -> char t (** Return the stream of the characters read from the input channel. *) diff --git a/stdlib/string.ml b/stdlib/string.ml index fda40b527..93880af26 100644 --- a/stdlib/string.ml +++ b/stdlib/string.ml @@ -2,72 +2,53 @@ (* *) (* OCaml *) (* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* Damien Doligez, projet Gallium, INRIA Rocquencourt *) (* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* Copyright 2014 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) -(* String operations *) +(* String operations, based on byte sequence operations *) external length : string -> int = "%string_length" external get : string -> int -> char = "%string_safe_get" -external set : string -> int -> char -> unit = "%string_safe_set" -external create : int -> string = "caml_create_string" +external set : bytes -> int -> char -> unit = "%string_safe_set" +external create : int -> bytes = "caml_create_string" external unsafe_get : string -> int -> char = "%string_unsafe_get" -external unsafe_set : string -> int -> char -> unit = "%string_unsafe_set" -external unsafe_blit : string -> int -> string -> int -> int -> unit +external unsafe_set : bytes -> int -> char -> unit = "%string_unsafe_set" +external unsafe_blit : string -> int -> bytes -> int -> int -> unit = "caml_blit_string" "noalloc" -external unsafe_fill : string -> int -> int -> char -> unit +external unsafe_fill : bytes -> int -> int -> char -> unit = "caml_fill_string" "noalloc" -let make n c = - let s = create n in - unsafe_fill s 0 n c; - s +module B = Bytes -let copy s = - let len = length s in - let r = create len in - unsafe_blit s 0 r 0 len; - r +let bts = B.unsafe_to_string +let bos = B.unsafe_of_string +let make n c = + B.make n c |> bts +let init n f = + B.init n f |> bts +let copy s = + B.copy (bos s) |> bts let sub s ofs len = - if ofs < 0 || len < 0 || ofs > length s - len - then invalid_arg "String.sub" - else begin - let r = create len in - unsafe_blit s ofs r 0 len; - r - end - -let fill s ofs len c = - if ofs < 0 || len < 0 || ofs > length s - len - then invalid_arg "String.fill" - else unsafe_fill s ofs len c - -let blit s1 ofs1 s2 ofs2 len = - if len < 0 || ofs1 < 0 || ofs1 > length s1 - len - || ofs2 < 0 || ofs2 > length s2 - len - then invalid_arg "String.blit" - else unsafe_blit s1 ofs1 s2 ofs2 len - -let iter f a = - for i = 0 to length a - 1 do f(unsafe_get a i) done - -let iteri f a = - for i = 0 to length a - 1 do f i (unsafe_get a i) done + B.sub (bos s) ofs len |> bts +let fill = + B.fill +let blit = + B.blit_string let concat sep l = match l with - [] -> "" + | [] -> "" | hd :: tl -> let num = ref 0 and len = ref 0 in List.iter (fun s -> incr num; len := !len + length s) l; - let r = create (!len + length sep * (!num - 1)) in + let r = B.create (!len + length sep * (!num - 1)) in unsafe_blit hd 0 r 0 (length hd); let pos = ref(length hd) in List.iter @@ -77,128 +58,68 @@ let concat sep l = unsafe_blit s 0 r !pos (length s); pos := !pos + length s) tl; - r + Bytes.unsafe_to_string r + +let iter f s = + B.iter f (bos s) +let iteri f s = + B.iteri f (bos s) +let map f s = + B.map f (bos s) |> bts +let mapi f s = + B.mapi f (bos s) |> bts + +(* Beware: we cannot use B.trim or B.escape because they always make a + copy, but String.mli spells out some cases where we are not allowed + to make a copy. *) external is_printable: char -> bool = "caml_is_printable" -external char_code: char -> int = "%identity" -external char_chr: int -> char = "%identity" let is_space = function | ' ' | '\012' | '\n' | '\r' | '\t' -> true | _ -> false let trim s = - let len = length s in - let i = ref 0 in - while !i < len && is_space (unsafe_get s !i) do - incr i - done; - let j = ref (len - 1) in - while !j >= !i && is_space (unsafe_get s !j) do - decr j - done; - if !i = 0 && !j = len - 1 then - s - else if !j >= !i then - sub s !i (!j - !i + 1) - else - "" + if s = "" then s + else if is_space (unsafe_get s 0) || is_space (unsafe_get s (length s - 1)) + then bts (B.trim (bos s)) + else s let escaped s = - let n = ref 0 in - for i = 0 to length s - 1 do - n := !n + - (match unsafe_get s i with - | '"' | '\\' | '\n' | '\t' | '\r' | '\b' -> 2 - | c -> if is_printable c then 1 else 4) - done; - if !n = length s then s else begin - let s' = create !n in - n := 0; - for i = 0 to length s - 1 do - begin - match unsafe_get s i with - | ('"' | '\\') as c -> - unsafe_set s' !n '\\'; incr n; unsafe_set s' !n c - | '\n' -> - unsafe_set s' !n '\\'; incr n; unsafe_set s' !n 'n' - | '\t' -> - unsafe_set s' !n '\\'; incr n; unsafe_set s' !n 't' - | '\r' -> - unsafe_set s' !n '\\'; incr n; unsafe_set s' !n 'r' - | '\b' -> - unsafe_set s' !n '\\'; incr n; unsafe_set s' !n 'b' - | c -> - if is_printable c then - unsafe_set s' !n c - else begin - let a = char_code c in - unsafe_set s' !n '\\'; - incr n; - unsafe_set s' !n (char_chr (48 + a / 100)); - incr n; - unsafe_set s' !n (char_chr (48 + (a / 10) mod 10)); - incr n; - unsafe_set s' !n (char_chr (48 + a mod 10)) - end - end; - incr n - done; - s' - end - -let map f s = - let l = length s in - if l = 0 then s else begin - let r = create l in - for i = 0 to l - 1 do unsafe_set r i (f(unsafe_get s i)) done; - r - end - -let uppercase s = map Char.uppercase s -let lowercase s = map Char.lowercase s - -let apply1 f s = - if length s = 0 then s else begin - let r = copy s in - unsafe_set r 0 (f(unsafe_get s 0)); - r - end - -let capitalize s = apply1 Char.uppercase s -let uncapitalize s = apply1 Char.lowercase s - -let rec index_rec s lim i c = - if i >= lim then raise Not_found else - if unsafe_get s i = c then i else index_rec s lim (i + 1) c;; - -let index s c = index_rec s (length s) 0 c;; - -let index_from s i c = - let l = length s in - if i < 0 || i > l then invalid_arg "String.index_from" else - index_rec s l i c;; - -let rec rindex_rec s i c = - if i < 0 then raise Not_found else - if unsafe_get s i = c then i else rindex_rec s (i - 1) c;; - -let rindex s c = rindex_rec s (length s - 1) c;; + let rec needs_escape i = + if i >= length s then false else + match unsafe_get s i with + | '"' | '\\' | '\n' | '\t' | '\r' | '\b' -> true + | c when is_printable c -> needs_escape (i+1) + | _ -> true + in + if needs_escape 0 then + bts (B.escaped (bos s)) + else + s +let index s c = + B.index (bos s) c +let rindex s c = + B.rindex (bos s) c +let index_from s i c= + B.index_from (bos s) i c let rindex_from s i c = - if i < -1 || i >= length s then invalid_arg "String.rindex_from" else - rindex_rec s i c;; - + B.rindex_from (bos s) i c +let contains s c = + B.contains (bos s) c let contains_from s i c = - let l = length s in - if i < 0 || i > l then invalid_arg "String.contains_from" else - try ignore (index_rec s l i c); true with Not_found -> false;; - -let contains s c = contains_from s 0 c;; - + B.contains_from (bos s) i c let rcontains_from s i c = - if i < 0 || i >= length s then invalid_arg "String.rcontains_from" else - try ignore (rindex_rec s i c); true with Not_found -> false;; + B.rcontains_from (bos s) i c +let uppercase s = + B.uppercase (bos s) |> bts +let lowercase s = + B.lowercase (bos s) |> bts +let capitalize s = + B.capitalize (bos s) |> bts +let uncapitalize s = + B.uncapitalize (bos s) |> bts type t = string diff --git a/stdlib/string.mli b/stdlib/string.mli index 14f2c82db..8f1e178b5 100644 --- a/stdlib/string.mli +++ b/stdlib/string.mli @@ -13,41 +13,36 @@ (** String operations. - Given a string [s] of length [l], we call character number in [s] - the index of a character in [s]. Indexes start at [0], and we will - call a character number valid in [s] if it falls within the range - [[0...l-1]]. A position is the point between two characters or at - the beginning or end of the string. We call a position valid - in [s] if it falls within the range [[0...l]]. Note that character - number [n] is between positions [n] and [n+1]. + A string is an immutable data structure that contains a + fixed-length sequence of (single-byte) characters. Each character + can be accessed in constant time through its index. + + Given a string [s] of length [l], we can access each of the [l] + characters of [s] via its index in the sequence. Indexes start at + [0], and we will call an index valid in [s] if it falls within the + range [[0...l-1]] (inclusive). A position is the point between two + characters or at the beginning or end of the string. We call a + position valid in [s] if it falls within the range [[0...l]] + (inclusive). Note that the character at index [n] is between + positions [n] and [n+1]. Two parameters [start] and [len] are said to designate a valid substring of [s] if [len >= 0] and [start] and [start+len] are valid positions in [s]. - OCaml strings can be modified in place, for instance via the - {!String.set} and {!String.blit} functions described below. This - possibility should be used rarely and with much care, however, since - both the OCaml compiler and most OCaml libraries share strings as if - they were immutable, rather than copying them. In particular, - string literals are shared: a single copy of the string is created - at program loading time and returned by all evaluations of the - string literal. Consider for example: - - {[ - # let f () = "foo";; - val f : unit -> string = <fun> - # (f ()).[0] <- 'b';; - - : unit = () - # f ();; - - : string = "boo" - ]} - - Likewise, many functions from the standard library can return string - literals or one of their string arguments. Therefore, the returned strings - must not be modified directly. If mutation is absolutely necessary, - it should be performed on a fresh copy of the string, as produced by - {!String.copy}. + OCaml strings used to be modifiable in place, for instance via the + {!String.set} and {!String.blit} functions described below. This + usage is deprecated and only possible when the compiler is put in + "unsafe-string" mode by giving the [-unsafe-string] command-line + option (which is currently the default for reasons of backward + compatibility). This is done by making the types [string] and + [bytes] (see module {!Bytes}) interchangeable so that functions + expecting byte sequences can also accept strings as arguments and + modify them. + + All new code should avoid this feature and be compiled with the + [-safe-string] command-line option to enforce the separation between + the types [string] and [bytes]. *) @@ -55,33 +50,51 @@ external length : string -> int = "%string_length" (** Return the length (number of characters) of the given string. *) external get : string -> int -> char = "%string_safe_get" -(** [String.get s n] returns character number [n] in string [s]. +(** [String.get s n] returns the character at index [n] in string [s]. You can also write [s.[n]] instead of [String.get s n]. - Raise [Invalid_argument] if [n] not a valid character number in [s]. *) + Raise [Invalid_argument] if [n] not a valid index in [s]. *) -external set : string -> int -> char -> unit = "%string_safe_set" -(** [String.set s n c] modifies string [s] in place, - replacing the character number [n] by [c]. +external set : bytes -> int -> char -> unit = "%string_safe_set" + [@@ocaml.deprecated] +(** [String.set s n c] modifies byte sequence [s] in place, + replacing the byte at index [n] with [c]. You can also write [s.[n] <- c] instead of [String.set s n c]. - Raise [Invalid_argument] if [n] is not a valid character number in [s]. *) + Raise [Invalid_argument] if [n] is not a valid index in [s]. -external create : int -> string = "caml_create_string" -(** [String.create n] returns a fresh string of length [n]. - The string initially contains arbitrary characters. + @deprecated This is a deprecated alias of {!Bytes.set}.[ ] *) - Raise [Invalid_argument] if [n < 0] or [n > ]{!Sys.max_string_length}. *) +external create : int -> bytes = "caml_create_string" [@@ocaml.deprecated] +(** [String.create n] returns a fresh byte sequence of length [n]. + The sequence is uninitialized and contains arbitrary bytes. + + Raise [Invalid_argument] if [n < 0] or [n > ]{!Sys.max_string_length}. + + @deprecated This is a deprecated alias of {!Bytes.create}.[ ] *) val make : int -> char -> string (** [String.make n c] returns a fresh string of length [n], filled with the character [c]. - Raise [Invalid_argument] if [n < 0] or [n > ]{!Sys.max_string_length}.*) + Raise [Invalid_argument] if [n < 0] or [n > ]{!Sys.max_string_length}. *) + +val init : int -> (int -> char) -> string +(** [String.init n f] returns a string of length [n], with character + [i] initialized to the result of [f i] (called in increasing + index order). + + Raise [Invalid_argument] if [n < 0] or [n > ]{!Sys.max_string_length}. + + @since 4.02.0 +*) -val copy : string -> string -(** Return a copy of the given string. *) +val copy : string -> string [@@ocaml.deprecated] +(** Return a copy of the given string. + + @deprecated Because strings are immutable, it doesn't make much + sense to make identical copies of them. *) val sub : string -> int -> int -> string (** [String.sub s start len] returns a fresh string of length [len], @@ -91,27 +104,24 @@ val sub : string -> int -> int -> string Raise [Invalid_argument] if [start] and [len] do not designate a valid substring of [s]. *) -val fill : string -> int -> int -> char -> unit -(** [String.fill s start len c] modifies string [s] in place, - replacing [len] characters by [c], starting at [start]. +val fill : bytes -> int -> int -> char -> unit [@@ocaml.deprecated] +(** [String.fill s start len c] modifies byte sequence [s] in place, + replacing [len] bytes with [c], starting at [start]. Raise [Invalid_argument] if [start] and [len] do not - designate a valid substring of [s]. *) + designate a valid range of [s]. -val blit : string -> int -> string -> int -> int -> unit -(** [String.blit src srcoff dst dstoff len] copies [len] characters - from string [src], starting at character number [srcoff], to - string [dst], starting at character number [dstoff]. It works - correctly even if [src] and [dst] are the same string, - and the source and destination intervals overlap. + @deprecated This is a deprecated alias of {!Bytes.fill}.[ ] *) - Raise [Invalid_argument] if [srcoff] and [len] do not - designate a valid substring of [src], or if [dstoff] and [len] - do not designate a valid substring of [dst]. *) +val blit : string -> int -> bytes -> int -> int -> unit +(** Same as {!Bytes.blit_string}. *) val concat : string -> string list -> string (** [String.concat sep sl] concatenates the list of strings [sl], - inserting the separator string [sep] between each. *) + inserting the separator string [sep] between each. + + Raise [Invalid_argument] if the result is longer than + {!Sys.max_string_length} bytes. *) val iter : (char -> unit) -> string -> unit (** [String.iter f s] applies function [f] in turn to all @@ -122,19 +132,24 @@ val iteri : (int -> char -> unit) -> string -> unit (** Same as {!String.iter}, but the function is applied to the index of the element as first argument (counting from 0), and the character itself as second argument. - @since 4.00.0 -*) + @since 4.00.0 *) val map : (char -> char) -> string -> string -(** [String.map f s] applies function [f] in turn to all - the characters of [s] and stores the results in a new string that - is returned. - @since 4.00.0 *) +(** [String.map f s] applies function [f] in turn to all the + characters of [s] (in increasing index order) and stores the + results in a new string that is returned. + @since 4.00.0 *) + +val mapi : (int -> char -> char) -> string -> string +(** [String.mapi f s] calls [f] with each character of [s] and its + index (in increasing index order) and stores the results in a new + string that is returned. + @since 4.02.0 *) val trim : string -> string (** Return a copy of the argument, without leading and trailing whitespace. The characters regarded as whitespace are: [' '], - ['\012'], ['\n'], ['\r'], and ['\t']. If there is no leading nor + ['\012'], ['\n'], ['\r'], and ['\t']. If there is neither leading nor trailing whitespace character in the argument, return the original string itself, not a copy. @since 4.00.0 *) @@ -144,22 +159,25 @@ val escaped : string -> string represented by escape sequences, following the lexical conventions of OCaml. If there is no special character in the argument, return the original string itself, - not a copy. Its inverse function is Scanf.unescaped. *) + not a copy. Its inverse function is Scanf.unescaped. + + Raise [Invalid_argument] if the result is longer than + {!Sys.max_string_length} bytes. *) val index : string -> char -> int -(** [String.index s c] returns the character number of the first +(** [String.index s c] returns the index of the first occurrence of character [c] in string [s]. Raise [Not_found] if [c] does not occur in [s]. *) val rindex : string -> char -> int -(** [String.rindex s c] returns the character number of the last +(** [String.rindex s c] returns the index of the last occurrence of character [c] in string [s]. Raise [Not_found] if [c] does not occur in [s]. *) val index_from : string -> int -> char -> int -(** [String.index_from s i c] returns the character number of the +(** [String.index_from s i c] returns the index of the first occurrence of character [c] in string [s] after position [i]. [String.index s c] is equivalent to [String.index_from s 0 c]. @@ -167,7 +185,7 @@ val index_from : string -> int -> char -> int Raise [Not_found] if [c] does not occur in [s] after position [i]. *) val rindex_from : string -> int -> char -> int -(** [String.rindex_from s i c] returns the character number of the +(** [String.rindex_from s i c] returns the index of the last occurrence of character [c] in string [s] before position [i+1]. [String.rindex s c] is equivalent to [String.rindex_from s (String.length s - 1) c]. @@ -224,8 +242,11 @@ val compare: t -> t -> int (* The following is for system use only. Do not call directly. *) external unsafe_get : string -> int -> char = "%string_unsafe_get" -external unsafe_set : string -> int -> char -> unit = "%string_unsafe_set" +external unsafe_set : bytes -> int -> char -> unit = "%string_unsafe_set" + [@@ocaml.deprecated] external unsafe_blit : - string -> int -> string -> int -> int -> unit = "caml_blit_string" "noalloc" + string -> int -> bytes -> int -> int -> unit + = "caml_blit_string" "noalloc" external unsafe_fill : - string -> int -> int -> char -> unit = "caml_fill_string" "noalloc" + bytes -> int -> int -> char -> unit = "caml_fill_string" "noalloc" + [@@ocaml.deprecated] diff --git a/stdlib/stringLabels.mli b/stdlib/stringLabels.mli index 8e2e6d379..1cf5d51ed 100644 --- a/stdlib/stringLabels.mli +++ b/stdlib/stringLabels.mli @@ -17,61 +17,71 @@ external length : string -> int = "%string_length" (** Return the length (number of characters) of the given string. *) external get : string -> int -> char = "%string_safe_get" -(** [String.get s n] returns character number [n] in string [s]. - The first character is character number 0. - The last character is character number [String.length s - 1]. +(** [String.get s n] returns the character at index [n] in string [s]. You can also write [s.[n]] instead of [String.get s n]. - Raise [Invalid_argument "index out of bounds"] - if [n] is outside the range 0 to [(String.length s - 1)]. *) + Raise [Invalid_argument] if [n] not a valid index in [s]. *) - -external set : string -> int -> char -> unit = "%string_safe_set" -(** [String.set s n c] modifies string [s] in place, - replacing the character number [n] by [c]. +external set : bytes -> int -> char -> unit = "%string_safe_set" + [@@ocaml.deprecated] +(** [String.set s n c] modifies byte sequence [s] in place, + replacing the byte at index [n] with [c]. You can also write [s.[n] <- c] instead of [String.set s n c]. - Raise [Invalid_argument "index out of bounds"] - if [n] is outside the range 0 to [(String.length s - 1)]. *) -external create : int -> string = "caml_create_string" -(** [String.create n] returns a fresh string of length [n]. - The string initially contains arbitrary characters. - Raise [Invalid_argument] if [n < 0] or [n > Sys.max_string_length]. -*) + Raise [Invalid_argument] if [n] is not a valid index in [s]. + + @deprecated This is a deprecated alias of {!Bytes.set}. *) + +external create : int -> bytes = "caml_create_string" [@@ocaml.deprecated] +(** [String.create n] returns a fresh byte sequence of length [n]. + The sequence is uninitialized and contains arbitrary bytes. + + Raise [Invalid_argument] if [n < 0] or [n > ]{!Sys.max_string_length}. + + @deprecated This is a deprecated alias of {!Bytes.create}. *) val make : int -> char -> string (** [String.make n c] returns a fresh string of length [n], filled with the character [c]. - Raise [Invalid_argument] if [n < 0] or [n > ]{!Sys.max_string_length}.*) + + Raise [Invalid_argument] if [n < 0] or [n > ]{!Sys.max_string_length}. *) + +val init : int -> f:(int -> char) -> string +(** [init n f] returns a string of length [n], + with character [i] initialized to the result of [f i]. + + Raise [Invalid_argument] if [n < 0] or [n > ]{!Sys.max_string_length}. *) val copy : string -> string (** Return a copy of the given string. *) val sub : string -> pos:int -> len:int -> string (** [String.sub s start len] returns a fresh string of length [len], - containing the characters number [start] to [start + len - 1] - of string [s]. - Raise [Invalid_argument] if [start] and [len] do not - designate a valid substring of [s]; that is, if [start < 0], - or [len < 0], or [start + len > ]{!StringLabels.length}[ s]. *) + containing the substring of [s] that starts at position [start] and + has length [len]. -val fill : string -> pos:int -> len:int -> char -> unit -(** [String.fill s start len c] modifies string [s] in place, - replacing the characters number [start] to [start + len - 1] - by [c]. Raise [Invalid_argument] if [start] and [len] do not designate a valid substring of [s]. *) +val fill : bytes -> pos:int -> len:int -> char -> unit [@@ocaml.deprecated] +(** [String.fill s start len c] modifies byte sequence [s] in place, + replacing [len] bytes by [c], starting at [start]. + + Raise [Invalid_argument] if [start] and [len] do not + designate a valid substring of [s]. + + @deprecated This is a deprecated alias of {!Bytes.fill}. *) + val blit : - src:string -> src_pos:int -> dst:string -> dst_pos:int -> len:int -> unit -(** [String.blit src srcoff dst dstoff len] copies [len] characters - from string [src], starting at character number [srcoff], to - string [dst], starting at character number [dstoff]. It works - correctly even if [src] and [dst] are the same string, - and the source and destination chunks overlap. + src:string -> src_pos:int -> dst:bytes -> dst_pos:int -> len:int + -> unit +(** [String.blit src srcoff dst dstoff len] copies [len] bytes + from the string [src], starting at index [srcoff], + to byte sequence [dst], starting at character number [dstoff]. + Raise [Invalid_argument] if [srcoff] and [len] do not - designate a valid substring of [src], or if [dstoff] and [len] - do not designate a valid substring of [dst]. *) + designate a valid range of [src], or if [dstoff] and [len] + do not designate a valid range of [dst]. *) val concat : sep:string -> string list -> string (** [String.concat sep sl] concatenates the list of strings [sl], @@ -86,8 +96,7 @@ val iteri : f:(int -> char -> unit) -> string -> unit (** Same as {!String.iter}, but the function is applied to the index of the element as first argument (counting from 0), and the character itself as second argument. - @since 4.00.0 -*) + @since 4.00.0 *) val map : f:(char -> char) -> string -> string (** [String.map f s] applies function [f] in turn to all @@ -95,11 +104,18 @@ val map : f:(char -> char) -> string -> string is returned. @since 4.00.0 *) +val mapi : f:(int -> char -> char) -> string -> string +(** [String.mapi f s] calls [f] with each character of [s] and its + index (in increasing index order) and stores the results in a new + string that is returned. + @since 4.02.0 *) + val trim : string -> string -(** Return a copy of the argument, without leading and trailing whitespace. - The characters regarded as whitespace are: [' '], ['\012'], ['\n'], - ['\r'], and ['\t']. If there is no whitespace character in the argument, - return the original string itself, not a copy. +(** Return a copy of the argument, without leading and trailing + whitespace. The characters regarded as whitespace are: [' '], + ['\012'], ['\n'], ['\r'], and ['\t']. If there is no leading nor + trailing whitespace character in the argument, return the original + string itself, not a copy. @since 4.00.0 *) val escaped : string -> string @@ -107,28 +123,36 @@ val escaped : string -> string represented by escape sequences, following the lexical conventions of OCaml. If there is no special character in the argument, return the original string itself, - not a copy. *) + not a copy. Its inverse function is Scanf.unescaped. *) val index : string -> char -> int -(** [String.index s c] returns the position of the leftmost +(** [String.index s c] returns the index of the first occurrence of character [c] in string [s]. + Raise [Not_found] if [c] does not occur in [s]. *) val rindex : string -> char -> int -(** [String.rindex s c] returns the position of the rightmost +(** [String.rindex s c] returns the index of the last occurrence of character [c] in string [s]. + Raise [Not_found] if [c] does not occur in [s]. *) val index_from : string -> int -> char -> int -(** Same as {!StringLabels.index}, but start - searching at the character position given as second argument. - [String.index s c] is equivalent to [String.index_from s 0 c].*) +(** [String.index_from s i c] returns the index of the + first occurrence of character [c] in string [s] after position [i]. + [String.index s c] is equivalent to [String.index_from s 0 c]. + + Raise [Invalid_argument] if [i] is not a valid position in [s]. + Raise [Not_found] if [c] does not occur in [s] after position [i]. *) val rindex_from : string -> int -> char -> int -(** Same as {!StringLabels.rindex}, but start - searching at the character position given as second argument. +(** [String.rindex_from s i c] returns the index of the + last occurrence of character [c] in string [s] before position [i+1]. [String.rindex s c] is equivalent to - [String.rindex_from s (String.length s - 1) c]. *) + [String.rindex_from s (String.length s - 1) c]. + + Raise [Invalid_argument] if [i+1] is not a valid position in [s]. + Raise [Not_found] if [c] does not occur in [s] before position [i+1]. *) val contains : string -> char -> bool (** [String.contains s c] tests if character [c] @@ -136,15 +160,18 @@ val contains : string -> char -> bool val contains_from : string -> int -> char -> bool (** [String.contains_from s start c] tests if character [c] - appears in the substring of [s] starting from [start] to the end - of [s]. - Raise [Invalid_argument] if [start] is not a valid index of [s]. *) + appears in [s] after position [start]. + [String.contains s c] is equivalent to + [String.contains_from s 0 c]. + + Raise [Invalid_argument] if [start] is not a valid position in [s]. *) val rcontains_from : string -> int -> char -> bool (** [String.rcontains_from s stop c] tests if character [c] - appears in the substring of [s] starting from the beginning - of [s] to index [stop]. - Raise [Invalid_argument] if [stop] is not a valid index of [s]. *) + appears in [s] before position [stop+1]. + + Raise [Invalid_argument] if [stop < 0] or [stop+1] is not a valid + position in [s]. *) val uppercase : string -> string (** Return a copy of the argument, with all lowercase letters @@ -176,9 +203,11 @@ val compare: t -> t -> int (* The following is for system use only. Do not call directly. *) external unsafe_get : string -> int -> char = "%string_unsafe_get" -external unsafe_set : string -> int -> char -> unit = "%string_unsafe_set" +external unsafe_set : bytes -> int -> char -> unit = "%string_unsafe_set" + [@@ocaml.deprecated] external unsafe_blit : - src:string -> src_pos:int -> dst:string -> dst_pos:int -> len:int -> + src:string -> src_pos:int -> dst:bytes -> dst_pos:int -> len:int -> unit = "caml_blit_string" "noalloc" external unsafe_fill : - string -> pos:int -> len:int -> char -> unit = "caml_fill_string" "noalloc" + bytes -> pos:int -> len:int -> char -> unit = "caml_fill_string" "noalloc" + [@@ocaml.deprecated] diff --git a/stdlib/sys.mli b/stdlib/sys.mli index 944b1090f..ae175c2e8 100644 --- a/stdlib/sys.mli +++ b/stdlib/sys.mli @@ -11,7 +11,12 @@ (* *) (***********************************************************************) -(** System interface. *) +(** System interface. + + Every function in this module raises [Sys_error] with an + informative message when the underlying system call signal + an error. +*) val argv : string array (** The command line arguments given to the process. @@ -99,7 +104,7 @@ val big_endian : bool @since 4.00.0 *) val max_string_length : int -(** Maximum length of a string. *) +(** Maximum length of strings and byte sequences. *) val max_array_length : int (** Maximum length of a normal array. The maximum length of a float diff --git a/stdlib/weak.ml b/stdlib/weak.ml index 536a42e04..8166142b6 100644 --- a/stdlib/weak.ml +++ b/stdlib/weak.ml @@ -80,8 +80,8 @@ module Make (H : Hashtbl.HashedType) : (S with type data = H.t) = struct let sz = if sz < 7 then 7 else sz in let sz = if sz > Sys.max_array_length then Sys.max_array_length else sz in { - table = Array.create sz emptybucket; - hashes = Array.create sz [| |]; + table = Array.make sz emptybucket; + hashes = Array.make sz [| |]; limit = limit; oversize = 0; rover = 0; diff --git a/testsuite/Makefile b/testsuite/Makefile index 813f4dabb..668f0833a 100644 --- a/testsuite/Makefile +++ b/testsuite/Makefile @@ -11,7 +11,8 @@ ######################################################################### BASEDIR := $(shell pwd) -NO_PRINT=`$(MAKE) empty --no-print-directory >/dev/null 2>&1 && echo '--no-print-directory'` +NO_PRINT=`$(MAKE) empty --no-print-directory >/dev/null 2>&1 \ + && echo --no-print-directory` FIND=find include ../config/Makefile @@ -20,12 +21,12 @@ include ../config/Makefile default: @echo "Available targets:" @echo " all launch all tests" - @echo " list FILE=f launch the tests referenced in file f (one path per line)" + @echo " list FILE=f launch the tests listed in f (one per line)" @echo " one DIR=p launch the tests located in path p" - @echo " promote DIR=p promote the reference files for the tests located in path p" + @echo " promote DIR=p promote the reference files for the tests in p" @echo " lib build library modules" @echo " clean delete generated files" - @echo " report print the report for the last execution, if any" + @echo " report print the report for the last execution" .PHONY: all all: lib diff --git a/testsuite/external/.ignore b/testsuite/external/.ignore index 8d1415349..39e14de91 100644 --- a/testsuite/external/.ignore +++ b/testsuite/external/.ignore @@ -26,7 +26,7 @@ camlpdf-0.5 camlp4 camlp4-trunk camlp5 -camlp5-6.10 +camlp5-git camlzip camlzip-1.04 camomile @@ -47,6 +47,8 @@ corekernel core_kernel-109.37.00 cryptokit cryptokit-1.6 +csv +csv-1.3.1 customprintf custom_printf-109.27.00 dbm @@ -60,7 +62,7 @@ fieldslib-109.15.00 fileutils ocaml-fileutils-0.4.4 findlib -findlib-1.3.3 +findlib-1.4.1 framac frama-c-Oxygen-20120901 geneweb @@ -140,7 +142,7 @@ variantslib-109.15.00 vsyml vsyml-2010-04-06 xmllight -xml-light-2.2 +xml-light.2.3 xmlm xmlm-1.1.0 zarith diff --git a/testsuite/external/Makefile b/testsuite/external/Makefile index c91e98084..566aaf392 100644 --- a/testsuite/external/Makefile +++ b/testsuite/external/Makefile @@ -42,12 +42,12 @@ all-cygwin: findlib ounit res pcre react ocamltext ocamlssl camlzip cryptokit \ camomile zen vsyml extlib fileutils ocamlify ocamlmod \ calendar dbm ocamlscript coq compcert -all-macos: findlib lablgtk ocamlgraph ounit res pcre core react ocamltext \ - ocamlssl lwt camlzip cryptokit sqlite menhir hevea \ - unison ocgi xmllight configfile xmlm lablgtkextras sks omake \ - altergo boomerang camomile zen vsyml ocamlnet extlib fileutils \ - odn ocamlify expect ocamlmod oasis calendar camlimages advi \ - dbm ocsigen ocamlscript coq compcert framac +all-macos: findlib res pcre react ocamltext \ + ocamlssl camlzip cryptokit sqlite menhir hevea \ + xmllight xmlm omake zen \ + altergo boomerang vsyml extlib \ + ocamlify calendar \ + dbm geneweb framac coq compcert platform: case `uname -s` in \ @@ -61,7 +61,7 @@ CAMLP4=camlp4-trunk ${CAMLP4}.zip: ${WGET} https://github.com/ocaml/camlp4/archive/trunk.zip mv trunk.zip ${CAMLP4}.zip -camlp4: ${CAMLP4}.zip +xxcamlp4: ${CAMLP4}.zip printf "%s " "$@" >/dev/tty test -d ${PREFIX} rm -rf ${CAMLP4} @@ -81,10 +81,10 @@ distclean:: all: camlp4 # http://projects.camlcity.org/projects/findlib.html -FINDLIB=findlib-1.3.3 +FINDLIB=findlib-1.4.1 ${FINDLIB}.tar.gz: ${WGET} http://download.camlcity.org/download/$@ -findlib: ${FINDLIB}.tar.gz camlp4 +findlib: ${FINDLIB}.tar.gz printf "%s " "$@" >/dev/tty test -d ${PREFIX} rm -rf ${FINDLIB} @@ -107,7 +107,7 @@ all: findlib LABLGTK=lablgtk-2.18.0 ${LABLGTK}.tar.gz: ${WGET} https://forge.ocamlcore.org/frs/download.php/1261/$@ -lablgtk: ${LABLGTK}.tar.gz findlib # TODO: add lablgl +xxlablgtk: ${LABLGTK}.tar.gz findlib camlp4 # TODO: add lablgl printf "%s " "$@" >/dev/tty test -d ${PREFIX} rm -rf ${LABLGTK} @@ -133,7 +133,7 @@ all: lablgtk OCAMLGRAPH=ocamlgraph-1.8.2 ${OCAMLGRAPH}.tar.gz: ${WGET} http://ocamlgraph.lri.fr/download/$@ -ocamlgraph: ${OCAMLGRAPH}.tar.gz findlib lablgtk +ocamlgraph: ${OCAMLGRAPH}.tar.gz findlib printf "%s " "$@" >/dev/tty test -d ${PREFIX} rm -rf ${OCAMLGRAPH} @@ -159,7 +159,7 @@ all: ocamlgraph OUNIT=ounit-1.1.2 ${OUNIT}.tar.gz: ${WGET} http://forge.ocamlcore.org/frs/download.php/886/$@ -ounit: ${OUNIT}.tar.gz findlib +xxounit: ${OUNIT}.tar.gz findlib camlp4 printf "%s " "$@" >/dev/tty test -d ${PREFIX} rm -rf ${OUNIT} @@ -229,7 +229,7 @@ all: pcre TYPECONV=type_conv-109.28.00 ${TYPECONV}.tar.gz: ${WGET} https://ocaml.janestreet.com/ocaml-core/109.28.00/individual/$@ -typeconv: ${TYPECONV}.tar.gz findlib +xxtypeconv: ${TYPECONV}.tar.gz findlib camlp4 printf "%s " "$@" >/dev/tty test -d ${PREFIX} rm -rf ${TYPECONV} @@ -252,7 +252,7 @@ all: typeconv VARIANTSLIB=variantslib-109.15.00 ${VARIANTSLIB}.tar.gz: ${WGET} https://ocaml.janestreet.com/ocaml-core/109.15.00/individual/$@ -variantslib: ${VARIANTSLIB}.tar.gz findlib typeconv +xxvariantslib: ${VARIANTSLIB}.tar.gz findlib typeconv printf "%s " "$@" >/dev/tty test -d ${PREFIX} rm -rf ${VARIANTSLIB} @@ -460,7 +460,7 @@ all: core CORE=core-109.37.00 ${CORE}.tar.gz: ${WGET} https://ocaml.janestreet.com/ocaml-core/109.37.00/individual/$@ -core: ${CORE}.tar.gz findlib variantslib sexplib fieldslib binprot comparelib \ +xxcore: ${CORE}.tar.gz findlib variantslib sexplib fieldslib binprot comparelib \ paounit pipebang res ounit corekernel printf "%s " "$@" >/dev/tty test -d ${PREFIX} @@ -626,7 +626,7 @@ all: ocamlssl LWT=lwt-2.4.0 ${LWT}.tar.gz: ${WGET} http://ocsigen.org/download/$@ -lwt: ${LWT}.tar.gz findlib react ocamltext ocamlssl lablgtk +xxlwt: ${LWT}.tar.gz findlib react ocamltext ocamlssl camlp4 lablgtk printf "%s " "$@" >/dev/tty test -d ${PREFIX} rm -rf ${LWT} @@ -836,7 +836,7 @@ all: mysql OCGI=ocgi-0.5 ${OCGI}.tar.gz: ${WGET} http://pauillac.inria.fr/~guesdon/Tools/Tars/$@ -ocgi: ${OCGI}.tar.gz +ocgi: ${OCGI}.tar.gz camlp4 printf "%s " "$@" >/dev/tty test -d ${PREFIX} rm -rf ${OCGI} @@ -856,20 +856,20 @@ distclean:: all: ocgi # http://tech.motion-twin.com/xmllight -XMLLIGHT=xml-light-2.2 -${XMLLIGHT}.zip: - ${WGET} http://tech.motion-twin.com/zip/$@ -xmllight: ${XMLLIGHT}.zip +XMLLIGHT=xml-light.2.3 +${XMLLIGHT}.tar.gz: + ${WGET} https://github.com/bguil/ocamllibs/releases/download/xml-light.2.3/$@ +xmllight: ${XMLLIGHT}.tar.gz printf "%s " "$@" >/dev/tty test -d ${PREFIX} rm -rf xml-light ${XMLLIGHT} - unzip ${XMLLIGHT}.zip && mv xml-light ${XMLLIGHT} + tar zxf ${XMLLIGHT}.tar.gz ./Patcher.sh ${XMLLIGHT} ( cd ${XMLLIGHT} && \ export PATH=${PREFIX}/bin:$$PATH && \ ${MAKE} xml_parser.ml && \ ${MAKE} all opt && \ - ${MAKE} install ) + ${MAKE} install_ocamlfind ) echo ${VERSION} >$@ clean:: rm -rf ${XMLLIGHT} xml-light xmllight @@ -881,7 +881,7 @@ all: xmllight CONFIGFILE=config-file-1.1 ${CONFIGFILE}.tar.gz: ${WGET} https://forge.ocamlcore.org/frs/download.php/845/$@ -configfile: ${CONFIGFILE}.tar.gz +configfile: ${CONFIGFILE}.tar.gz camlp4 printf "%s " "$@" >/dev/tty test -d ${PREFIX} rm -rf ${CONFIGFILE} @@ -950,7 +950,7 @@ all: lablgtkextras SKS=sks-1.1.3 ${SKS}.tgz: ${WGET} https://bitbucket.org/skskeyserver/sks-keyserver/downloads/$@ -sks: ${SKS}.tgz +sks: ${SKS}.tgz camlp4 printf "%s " "$@" >/dev/tty test -d ${PREFIX} rm -rf ${SKS} @@ -1060,7 +1060,7 @@ all: boomerang CAMOMILE=camomile-0.8.4 ${CAMOMILE}.tar.bz2: ${WGET} https://github.com/downloads/yoriyuki/Camomile/$@ -camomile: ${CAMOMILE}.tar.bz2 +camomile: ${CAMOMILE}.tar.bz2 camlp4 printf "%s " "$@" >/dev/tty test -d ${PREFIX} rm -rf ${CAMOMILE} @@ -1083,7 +1083,7 @@ all: camomile ZEN=zen_2.3.2 ${ZEN}.tar.gz: ${WGET} http://sanskrit.inria.fr/ZEN/$@ -zen: ${ZEN}.tar.gz +zen: ${ZEN}.tar.gz camlp4 printf "%s " "$@" >/dev/tty test -d ${PREFIX} rm -rf ${ZEN} @@ -1125,7 +1125,7 @@ all: vsyml OCAMLNET=ocamlnet-3.5.1 ${OCAMLNET}.tar.gz: ${WGET} http://download.camlcity.org/download/$@ -ocamlnet: ${OCAMLNET}.tar.gz findlib pcre lablgtk ocamlssl camlzip cryptokit +ocamlnet: ${OCAMLNET}.tar.gz findlib pcre camlp4 ocamlssl camlzip cryptokit printf "%s " "$@" >/dev/tty test -d ${PREFIX} rm -rf ${OCAMLNET} @@ -1208,7 +1208,7 @@ all: extlib FILEUTILS=ocaml-fileutils-0.4.4 ${FILEUTILS}.tar.gz: ${WGET} http://forge.ocamlcore.org/frs/download.php/892/$@ -fileutils: ${FILEUTILS}.tar.gz findlib ounit +xxfileutils: ${FILEUTILS}.tar.gz findlib ounit printf "%s " "$@" >/dev/tty test -d ${PREFIX} rm -rf ${FILEUTILS} @@ -1370,7 +1370,7 @@ CAMLIMAGES=camlimages-4.0.1 ${CAMLIMAGES}.tar.gz: ${WGET} https://bitbucket.org/camlspotter/camlimages/get/v4.0.1.tar.gz mv v4.0.1.tar.gz $@ -camlimages: ${CAMLIMAGES}.tar.gz findlib omake lablgtk +xxcamlimages: ${CAMLIMAGES}.tar.gz findlib omake lablgtk printf "%s " "$@" >/dev/tty test -d ${PREFIX} rm -rf ${CAMLIMAGES} @@ -1488,7 +1488,7 @@ all: mldonkey OCAMLSCRIPT=ocamlscript-2.0.3 ${OCAMLSCRIPT}.tar.gz: ${WGET} http://mjambon.com/releases/ocamlscript/$@ -ocamlscript: ${OCAMLSCRIPT}.tar.gz findlib +ocamlscript: ${OCAMLSCRIPT}.tar.gz findlib camlp4 printf "%s " "$@" >/dev/tty test -d ${PREFIX} rm -rf ${OCAMLSCRIPT} @@ -1529,7 +1529,7 @@ distclean:: rm -f ${KAPUTT}.tar.gz all: kaputt -#http://www.coherentpdf.com/ocaml-libraries.html +# http://www.coherentpdf.com/ocaml-libraries.html CAMLPDF=camlpdf-0.5 ${CAMLPDF}.tar.bz2: ${WGET} http://www.coherentpdf.com/$@ @@ -1550,56 +1550,76 @@ distclean:: rm -f ${CAMLPDF}.tar.gz all: camlpdf -# disabled: need to be updated for new AST stuff -# # http://pauillac.inria.fr/~ddr/camlp5/ -# CAMLP5=camlp5-6.10 -# ${CAMLP5}.tgz: -# ${WGET} http://pauillac.inria.fr/~ddr/camlp5/distrib/src/$@ -# camlp5: ${CAMLP5}.tgz -# printf "%s " "$@" >/dev/tty -# test -d ${PREFIX} -# rm -rf ${CAMLP5} -# tar zxf ${CAMLP5}.tgz -# ./Patcher.sh ${CAMLP5} -# ( cd ${CAMLP5} && \ -# export PATH=${PREFIX}/bin:$$PATH && \ -# ./configure --transitional && \ -# ${MAKE} world.opt && \ -# ${MAKE} install ) -# echo ${VERSION} >$@ -# clean:: -# rm -rf ${CAMLP5} camlp5 -# distclean:: -# rm -f ${CAMLP5}.tgz -# all: camlp5 - -# disabled: depends on camlp5 -# # http://opensource.geneanet.org/projects/geneweb -# GENEWEB=gw-6.05-src -# ${GENEWEB}.tgz: -# ${WGET} http://opensource.geneanet.org/attachments/download/190/$@ -# geneweb: ${GENEWEB}.tgz camlp5 -# printf "%s " "$@" >/dev/tty -# test -d ${PREFIX} -# rm -rf ${GENEWEB} -# tar zxf ${GENEWEB}.tgz -# ./Patcher.sh ${GENEWEB} -# ( cd ${GENEWEB} && \ -# export PATH=${PREFIX}/bin:$$PATH && \ -# sh ./configure && \ -# ${MAKE} ) -# echo ${VERSION} >$@ -# clean:: -# rm -rf ${GENEWEB} geneweb -# distclean:: -# rm -f ${GENEWEB}.tgz -# all: geneweb +# https://forge.ocamlcore.org/projects/csv +CSV=csv-1.3.1 +${CSV}.tar.gz: + ${WGET} https://forge.ocamlcore.org/frs/download.php/1235/$@ +csv: ${CSV}.tar.gz findlib + printf "%s " "$@" >/dev/tty + test -d ${PREFIX} + rm -rf ${CSV} + tar zxf ${CSV}.tar.gz + ./Patcher.sh ${CSV} + ( cd ${CSV} && \ + export PATH=${PREFIX}/bin:$$PATH && \ + ocaml setup.ml -configure --enable-tests --prefix ${PREFIX} && \ + ocaml setup.ml -build && \ + ocamlfind remove csv && \ + ocaml setup.ml -install ) + echo ${VERSION} >$@ +clean:: + rm -rf ${CSV} csv +distclean:: + rm -f ${CSV}.tar.gz +all: csv + +# http://pauillac.inria.fr/~ddr/camlp5/ +CAMLP5=camlp5-git +camlp5: + printf "%s " "$@" >/dev/tty + test -d ${PREFIX} + rm -rf ${CAMLP5} + git clone git://scm.gforge.inria.fr/camlp5/camlp5.git ${CAMLP5} + ./Patcher.sh ${CAMLP5} + ( cd ${CAMLP5} && \ + export PATH=${PREFIX}/bin:$$PATH && \ + ./configure --transitional && \ + ${MAKE} world.opt && \ + ${MAKE} install ) + echo ${VERSION} >$@ +clean:: + rm -rf ${CAMLP5} camlp5 +distclean:: + rm -f ${CAMLP5}-git +all: camlp5 + +disabled: depends on camlp5 +# http://opensource.geneanet.org/projects/geneweb +GENEWEB=gw-6.05-src +${GENEWEB}.tgz: + ${WGET} http://opensource.geneanet.org/attachments/download/190/$@ +geneweb: ${GENEWEB}.tgz camlp5 + printf "%s " "$@" >/dev/tty + test -d ${PREFIX} + rm -rf ${GENEWEB} + tar zxf ${GENEWEB}.tgz + ./Patcher.sh ${GENEWEB} + ( cd ${GENEWEB} && \ + export PATH=${PREFIX}/bin:$$PATH && \ + sh ./configure && \ + ${MAKE} ) + echo ${VERSION} >$@ +clean:: + rm -rf ${GENEWEB} geneweb +distclean:: + rm -f ${GENEWEB}.tgz +all: geneweb # http://coq.inria.fr/download COQ=coq-8.4pl2 ${COQ}.tar.gz: ${WGET} http://coq.inria.fr/distrib/V8.4pl2/files/$@ -coq: ${COQ}.tar.gz +coq: ${COQ}.tar.gz camlp5 printf "%s " "$@" >/dev/tty test -d ${PREFIX} rm -rf ${COQ} @@ -1669,7 +1689,7 @@ all: compcert FRAMAC=frama-c-Oxygen-20120901 ${FRAMAC}.tar.gz: ${WGET} http://frama-c.com/download/$@ -framac: ${FRAMAC}.tar.gz lablgtk ocamlgraph altergo coq +framac: ${FRAMAC}.tar.gz printf "%s " "$@" >/dev/tty test -d ${PREFIX} rm -rf ${FRAMAC} diff --git a/testsuite/external/camlp5-git.patch b/testsuite/external/camlp5-git.patch new file mode 100644 index 000000000..8ea012cc5 --- /dev/null +++ b/testsuite/external/camlp5-git.patch @@ -0,0 +1,12 @@ +diff --git a/Makefile b/Makefile +index 13622f7..b33a042 100644 +--- camlp5-git/Makefile.orig ++++ camlp5-git/Makefile +@@ -54,6 +54,7 @@ depend: + cd ocaml_stuff; $(MAKE) depend; cd .. + for i in $(DIRS) compile; do (cd $$i; $(MAKE) depend; cd ..); done + ++.PHONY: install + install: + rm -rf "$(DESTDIR)$(LIBDIR)/$(CAMLP5N)" + for i in $(DIRS) compile; do \ diff --git a/testsuite/interactive/lib-gc/alloc.ml b/testsuite/interactive/lib-gc/alloc.ml index 2db803469..aadecab28 100644 --- a/testsuite/interactive/lib-gc/alloc.ml +++ b/testsuite/interactive/lib-gc/alloc.ml @@ -21,7 +21,7 @@ let l = 32768;; let m = 1000;; -let ar = Array.create l "";; +let ar = Array.make l "";; Random.init 1234;; diff --git a/testsuite/interactive/lib-graph-3/sorts.ml b/testsuite/interactive/lib-graph-3/sorts.ml index 126463d2c..6e00d2566 100644 --- a/testsuite/interactive/lib-graph-3/sorts.ml +++ b/testsuite/interactive/lib-graph-3/sorts.ml @@ -75,7 +75,7 @@ let initialize name array maxval x y w h = (* Main animation function *) let display functs nelts maxval = - let a = Array.create nelts 0 in + let a = Array.make nelts 0 in for i = 0 to nelts - 1 do a.(i) <- Random.int maxval done; diff --git a/testsuite/makefiles/Makefile.common b/testsuite/makefiles/Makefile.common index ae6aceaa2..5fdf5a184 100644 --- a/testsuite/makefiles/Makefile.common +++ b/testsuite/makefiles/Makefile.common @@ -110,7 +110,7 @@ defaultclean: .cmxa.so: @$(OCAMLOPT) -o $@ -shared -linkall $(ADD_COMPFLAGS) $< -.mly.ml: +%.ml %.mli: %.mly @$(OCAMLYACC) -q $< 2> /dev/null .mll.ml: diff --git a/testsuite/tests/asmcomp/Makefile b/testsuite/tests/asmcomp/Makefile index aa37bf9e4..501d0594d 100644 --- a/testsuite/tests/asmcomp/Makefile +++ b/testsuite/tests/asmcomp/Makefile @@ -23,7 +23,7 @@ INCLUDES=\ OTHEROBJS=\ $(OTOPDIR)/compilerlibs/ocamlcommon.cma \ - $(OTOPDIR)/compilerlibs/ocamloptcomp.cma + $(OTOPDIR)/compilerlibs/ocamloptcomp.cma OBJS=parsecmmaux.cmo parsecmm.cmo lexcmm.cmo diff --git a/testsuite/tests/asmcomp/arm64.S b/testsuite/tests/asmcomp/arm64.S index 3bb411061..7b839c44a 100644 --- a/testsuite/tests/asmcomp/arm64.S +++ b/testsuite/tests/asmcomp/arm64.S @@ -12,21 +12,21 @@ .globl call_gen_code .align 2 -call_gen_code: +call_gen_code: /* Set up stack frame and save callee-save registers */ - stp x29, x30, [sp, -160]! - add x29, sp, #0 + stp x29, x30, [sp, -160]! + add x29, sp, #0 stp x19, x20, [sp, 16] stp x21, x22, [sp, 32] stp x23, x24, [sp, 48] stp x25, x26, [sp, 64] stp x27, x28, [sp, 80] - stp d8, d9, [sp, 96] + stp d8, d9, [sp, 96] stp d10, d11, [sp, 112] stp d12, d13, [sp, 128] stp d14, d15, [sp, 144] /* Shuffle arguments */ - mov x8, x0 + mov x8, x0 mov x0, x1 mov x1, x2 mov x2, x3 @@ -39,14 +39,14 @@ call_gen_code: ldp x23, x24, [sp, 48] ldp x25, x26, [sp, 64] ldp x27, x28, [sp, 80] - ldp d8, d9, [sp, 96] + ldp d8, d9, [sp, 96] ldp d10, d11, [sp, 112] ldp d12, d13, [sp, 128] ldp d14, d15, [sp, 144] - ldp x29, x30, [sp], 160 + ldp x29, x30, [sp], 160 ret .globl caml_c_call .align 2 caml_c_call: - br x15 + br x15 diff --git a/testsuite/tests/asmcomp/lexcmm.mll b/testsuite/tests/asmcomp/lexcmm.mll index e9efdb60f..4c262b112 100644 --- a/testsuite/tests/asmcomp/lexcmm.mll +++ b/testsuite/tests/asmcomp/lexcmm.mll @@ -81,7 +81,7 @@ let keyword_table = (* To buffer string literals *) -let initial_string_buffer = String.create 256 +let initial_string_buffer = Bytes.create 256 let string_buff = ref initial_string_buffer let string_index = ref 0 @@ -90,16 +90,16 @@ let reset_string_buffer () = string_index := 0 let store_string_char c = - if !string_index >= String.length (!string_buff) then begin - let new_buff = String.create (String.length (!string_buff) * 2) in - String.blit (!string_buff) 0 new_buff 0 (String.length (!string_buff)); - string_buff := new_buff + if !string_index >= Bytes.length (!string_buff) then begin + let new_buff = Bytes.create (Bytes.length (!string_buff) * 2) in + Bytes.blit (!string_buff) 0 new_buff 0 (Bytes.length (!string_buff)); + string_buff := new_buff end; - String.unsafe_set (!string_buff) (!string_index) c; + Bytes.unsafe_set (!string_buff) (!string_index) c; incr string_index let get_stored_string () = - let s = String.sub (!string_buff) 0 (!string_index) in + let s = Bytes.sub_string (!string_buff) 0 (!string_index) in string_buff := initial_string_buffer; s diff --git a/testsuite/tests/asmcomp/mainarith.c b/testsuite/tests/asmcomp/mainarith.c index f935391b5..d102c16dc 100644 --- a/testsuite/tests/asmcomp/mainarith.c +++ b/testsuite/tests/asmcomp/mainarith.c @@ -33,25 +33,29 @@ double F, G; #define INTTEST(arg,res) \ { intnat result = (res); \ if (arg != result) \ - printf("Failed test \"%s == %s\" for X=%"FMT"d and Y=%"FMT"d: result %"FMT"d, expected %"FMT"d\n", \ + printf("Failed test \"%s == %s\" for X=%"FMT"d and Y=%"FMT"d: " \ + "result %"FMT"d, expected %"FMT"d\n", \ #arg, #res, X, Y, arg, result); \ } #define INTFLOATTEST(arg,res) \ { intnat result = (res); \ if (arg != result) \ - printf("Failed test \"%s == %s\" for F=%.15g and G=%.15g: result %"FMT"d, expected %"FMT"d\n", \ + printf("Failed test \"%s == %s\" for F=%.15g and G=%.15g: "\ + "result %"FMT"d, expected %"FMT"d\n", \ #arg, #res, F, G, arg, result); \ } #define FLOATTEST(arg,res) \ { double result = (res); \ if (arg < result || arg > result) \ - printf("Failed test \"%s == %s\" for F=%.15g and G=%.15g: result %.15g, expected %.15g\n", \ + printf("Failed test \"%s == %s\" for F=%.15g and G=%.15g: "\ + "result %.15g, expected %.15g\n", \ #arg, #res, F, G, arg, result); \ } #define FLOATINTTEST(arg,res) \ { double result = (res); \ if (arg < result || arg > result) \ - printf("Failed test \"%s == %s\" for X=%"FMT"d and Y=%"FMT"d: result %.15g, expected %.15g\n", \ + printf("Failed test \"%s == %s\" for X=%"FMT"d and Y=%"FMT"d: "\ + "result %.15g, expected %.15g\n", \ #arg, #res, X, Y, arg, result); \ } diff --git a/testsuite/tests/asmcomp/optargs.ml b/testsuite/tests/asmcomp/optargs.ml index d50867239..92705bd25 100644 --- a/testsuite/tests/asmcomp/optargs.ml +++ b/testsuite/tests/asmcomp/optargs.ml @@ -1,3 +1,15 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Alain Frisch, LexiFi *) +(* *) +(* Copyright 2014 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + (* Check the effectiveness of inlining the wrapper which fills in default values for optional arguments. @@ -18,6 +30,4 @@ let () = done; let x2 = Gc.allocated_bytes () in assert(x1 -. x0 = x2 -. x1) - (* check that we did not allocated anything between x1 and x2 *) - - + (* check that we have not allocated anything between x1 and x2 *) diff --git a/testsuite/tests/asmcomp/parsecmm.mly b/testsuite/tests/asmcomp/parsecmm.mly index ad697b6f4..e936c2587 100644 --- a/testsuite/tests/asmcomp/parsecmm.mly +++ b/testsuite/tests/asmcomp/parsecmm.mly @@ -24,9 +24,9 @@ let rec make_letdef def body = Clet(id, def, make_letdef rem body) let make_switch n selector caselist = - let index = Array.create n 0 in + let index = Array.make n 0 in let casev = Array.of_list caselist in - let actv = Array.create (Array.length casev) (Cexit(0,[])) in + let actv = Array.make (Array.length casev) (Cexit(0,[])) in for i = 0 to Array.length casev - 1 do let (posl, e) = casev.(i) in List.iter (fun pos -> index.(pos) <- i) posl; @@ -172,7 +172,7 @@ componentlist: ; expr: INTCONST { Cconst_int $1 } - | FLOATCONST { Cconst_float $1 } + | FLOATCONST { Cconst_float (float_of_string $1) } | STRING { Cconst_symbol $1 } | POINTER { Cconst_pointer $1 } | IDENT { Cvar(find_ident $1) } @@ -316,7 +316,7 @@ dataitem: | BYTE INTCONST { Cint8 $2 } | HALF INTCONST { Cint16 $2 } | INT INTCONST { Cint(Nativeint.of_int $2) } - | FLOAT FLOATCONST { Cdouble $2 } + | FLOAT FLOATCONST { Cdouble (float_of_string $2) } | ADDR STRING { Csymbol_address $2 } | ADDR INTCONST { Clabel_address $2 } | KSTRING STRING { Cstring $2 } diff --git a/testsuite/tests/asmcomp/sparc.S b/testsuite/tests/asmcomp/sparc.S index 53c5fc902..ea029573a 100644 --- a/testsuite/tests/asmcomp/sparc.S +++ b/testsuite/tests/asmcomp/sparc.S @@ -11,11 +11,11 @@ /***********************************************************************/ #if defined(SYS_solaris) || defined(SYS_elf) -#define Call_gen_code _call_gen_code -#define Caml_c_call _caml_c_call -#else #define Call_gen_code call_gen_code #define Caml_c_call caml_c_call +#else +#define Call_gen_code _call_gen_code +#define Caml_c_call _caml_c_call #endif .global Call_gen_code diff --git a/testsuite/tests/asmcomp/staticalloc.ml b/testsuite/tests/asmcomp/staticalloc.ml index e21fdee63..3186686c7 100644 --- a/testsuite/tests/asmcomp/staticalloc.ml +++ b/testsuite/tests/asmcomp/staticalloc.ml @@ -1,3 +1,15 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Alain Frisch, LexiFi *) +(* *) +(* Copyright 2014 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + (* Check the effectiveness of structured constant propagation and static allocation. diff --git a/testsuite/tests/backtrace/Makefile b/testsuite/tests/backtrace/Makefile index 32533fd60..33ca1ed8b 100644 --- a/testsuite/tests/backtrace/Makefile +++ b/testsuite/tests/backtrace/Makefile @@ -14,7 +14,9 @@ BASEDIR=../.. EXECNAME=program$(EXE) ABCDFILES=backtrace.ml -OTHERFILES=backtrace2.ml raw_backtrace.ml +OTHERFILES=backtrace2.ml raw_backtrace.ml \ + backtrace_deprecated.ml backtrace_slots.ml +OTHERFILESNOINLINING=backtraces_and_finalizers.ml default: $(MAKE) byte @@ -68,6 +70,16 @@ native: >$$F.native.result 2>&1; \ $(DIFF) $$F.reference $$F.native.result >/dev/null \ && echo " => passed" || echo " => failed"; \ + done; + @for file in $(OTHERFILESNOINLINING); do \ + rm -f program program.exe; \ + $(OCAMLOPT) -inline 0 -g -o $(EXECNAME) $$file; \ + printf " ... testing '$$file' with ocamlopt:"; \ + F="`basename $$file .ml`"; \ + (OCAMLRUNPARAM=b=1 ./$(EXECNAME) $$arg || true) \ + >$$F.native.result 2>&1; \ + $(DIFF) $$F.reference $$F.native.result >/dev/null \ + && echo " => passed" || echo " => failed"; \ done .PHONY: promote diff --git a/testsuite/tests/backtrace/backtrace_deprecated.ml b/testsuite/tests/backtrace/backtrace_deprecated.ml new file mode 100644 index 000000000..7ec5152d0 --- /dev/null +++ b/testsuite/tests/backtrace/backtrace_deprecated.ml @@ -0,0 +1,50 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2008 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* A test for stack backtraces *) + +external get_backtrace : unit -> Printexc.backtrace_slot array option + = "caml_get_exception_backtrace" + +exception Error of string + +let rec f msg n = + if n = 0 then raise(Error msg) else 1 + f msg (n-1) + +let g msg = + try + f msg 5 + with Error "a" -> print_string "a"; print_newline(); 0 + | Error "b" as exn -> print_string "b"; print_newline(); raise exn + | Error "c" -> raise (Error "c") + +let run args = + try + ignore (g args.(0)); print_string "No exception\n" + with exn -> + Printf.printf "Uncaught exception %s\n" (Printexc.to_string exn); + get_backtrace () |> function + | None -> () + | Some trace -> + Array.iteri + (fun i slot -> match Printexc.Slot.format i slot with + | None -> () + | Some line -> print_endline line) + trace + +let _ = + Printexc.record_backtrace true; + run [| "a" |]; + run [| "b" |]; + run [| "c" |]; + run [| "d" |]; + run [| |] diff --git a/testsuite/tests/backtrace/backtrace_deprecated.reference b/testsuite/tests/backtrace/backtrace_deprecated.reference new file mode 100644 index 000000000..e9fea9ffe --- /dev/null +++ b/testsuite/tests/backtrace/backtrace_deprecated.reference @@ -0,0 +1,27 @@ +a +No exception +b +Uncaught exception Backtrace_deprecated.Error("b") +Raised at file "backtrace_deprecated.ml", line 21, characters 21-32 +Called from file "backtrace_deprecated.ml", line 21, characters 42-53 +Called from file "backtrace_deprecated.ml", line 21, characters 42-53 +Called from file "backtrace_deprecated.ml", line 21, characters 42-53 +Called from file "backtrace_deprecated.ml", line 21, characters 42-53 +Called from file "backtrace_deprecated.ml", line 21, characters 42-53 +Called from file "backtrace_deprecated.ml", line 25, characters 4-11 +Re-raised at file "backtrace_deprecated.ml", line 27, characters 68-71 +Called from file "backtrace_deprecated.ml", line 32, characters 11-23 +Uncaught exception Backtrace_deprecated.Error("c") +Raised at file "backtrace_deprecated.ml", line 28, characters 26-37 +Called from file "backtrace_deprecated.ml", line 32, characters 11-23 +Uncaught exception Backtrace_deprecated.Error("d") +Raised at file "backtrace_deprecated.ml", line 21, characters 21-32 +Called from file "backtrace_deprecated.ml", line 21, characters 42-53 +Called from file "backtrace_deprecated.ml", line 21, characters 42-53 +Called from file "backtrace_deprecated.ml", line 21, characters 42-53 +Called from file "backtrace_deprecated.ml", line 21, characters 42-53 +Called from file "backtrace_deprecated.ml", line 21, characters 42-53 +Called from file "backtrace_deprecated.ml", line 25, characters 4-11 +Called from file "backtrace_deprecated.ml", line 32, characters 11-23 +Uncaught exception Invalid_argument("index out of bounds") +Raised by primitive operation at file "backtrace_deprecated.ml", line 32, characters 14-22 diff --git a/testsuite/tests/backtrace/backtrace_slots.ml b/testsuite/tests/backtrace/backtrace_slots.ml new file mode 100644 index 000000000..8419c6190 --- /dev/null +++ b/testsuite/tests/backtrace/backtrace_slots.ml @@ -0,0 +1,72 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2008 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* A test for stack backtraces *) + +let get_backtrace () = + let raw_backtrace = Printexc.get_raw_backtrace () in + let raw_slots = + Array.init (Printexc.raw_backtrace_length raw_backtrace) + (Printexc.get_raw_backtrace_slot raw_backtrace) in + let convert = Printexc.convert_raw_backtrace_slot in + let backtrace = Array.map convert raw_slots in + (* we'll play with raw slots a bit to check that hashing and comparison work: + - create a hashtable that maps slots to their index in the raw backtrace + - create a balanced set of all slots + *) + let table = Hashtbl.create 100 in + Array.iteri (fun i slot -> Hashtbl.add table slot i) raw_slots; + let module S = Set.Make(struct + type t = Printexc.raw_backtrace_slot + let compare = Pervasives.compare + end) in + let slots = Array.fold_right S.add raw_slots S.empty in + Array.iteri (fun i slot -> + assert (S.mem slot slots); + assert (Hashtbl.mem table slot); + let j = + (* position in the table of the last slot equal to [slot] *) + Hashtbl.find table slot in + assert (slot = raw_slots.(j)); + assert (backtrace.(i) = backtrace.(j)); + ) raw_slots; + backtrace + +exception Error of string + +let rec f msg n = + if n = 0 then raise(Error msg) else 1 + f msg (n-1) + +let g msg = + try + f msg 5 + with Error "a" -> print_string "a"; print_newline(); 0 + | Error "b" as exn -> print_string "b"; print_newline(); raise exn + | Error "c" -> raise (Error "c") + +let run args = + try + ignore (g args.(0)); print_string "No exception\n" + with exn -> + Printf.printf "Uncaught exception %s\n" (Printexc.to_string exn); + get_backtrace () |> Array.iteri + (fun i slot -> match Printexc.Slot.format i slot with + | None -> () + | Some line -> print_endline line) + +let _ = + Printexc.record_backtrace true; + run [| "a" |]; + run [| "b" |]; + run [| "c" |]; + run [| "d" |]; + run [| |] diff --git a/testsuite/tests/backtrace/backtrace_slots.reference b/testsuite/tests/backtrace/backtrace_slots.reference new file mode 100644 index 000000000..2336cd5ac --- /dev/null +++ b/testsuite/tests/backtrace/backtrace_slots.reference @@ -0,0 +1,27 @@ +a +No exception +b +Uncaught exception Backtrace_slots.Error("b") +Raised at file "backtrace_slots.ml", line 47, characters 21-32 +Called from file "backtrace_slots.ml", line 47, characters 42-53 +Called from file "backtrace_slots.ml", line 47, characters 42-53 +Called from file "backtrace_slots.ml", line 47, characters 42-53 +Called from file "backtrace_slots.ml", line 47, characters 42-53 +Called from file "backtrace_slots.ml", line 47, characters 42-53 +Called from file "backtrace_slots.ml", line 51, characters 4-11 +Re-raised at file "backtrace_slots.ml", line 53, characters 68-71 +Called from file "backtrace_slots.ml", line 58, characters 11-23 +Uncaught exception Backtrace_slots.Error("c") +Raised at file "backtrace_slots.ml", line 54, characters 26-37 +Called from file "backtrace_slots.ml", line 58, characters 11-23 +Uncaught exception Backtrace_slots.Error("d") +Raised at file "backtrace_slots.ml", line 47, characters 21-32 +Called from file "backtrace_slots.ml", line 47, characters 42-53 +Called from file "backtrace_slots.ml", line 47, characters 42-53 +Called from file "backtrace_slots.ml", line 47, characters 42-53 +Called from file "backtrace_slots.ml", line 47, characters 42-53 +Called from file "backtrace_slots.ml", line 47, characters 42-53 +Called from file "backtrace_slots.ml", line 51, characters 4-11 +Called from file "backtrace_slots.ml", line 58, characters 11-23 +Uncaught exception Invalid_argument("index out of bounds") +Raised by primitive operation at file "backtrace_slots.ml", line 58, characters 14-22 diff --git a/testsuite/tests/backtrace/backtraces_and_finalizers.ml b/testsuite/tests/backtrace/backtraces_and_finalizers.ml new file mode 100644 index 000000000..22acf1af8 --- /dev/null +++ b/testsuite/tests/backtrace/backtraces_and_finalizers.ml @@ -0,0 +1,25 @@ +let () = Printexc.record_backtrace true + +let finaliser _ = try raise Exit with _ -> () + +let create () = + let x = ref () in + Gc.finalise finaliser x; + x + +let f () = raise Exit + +let () = + let minor_size = (Gc.get ()).Gc.minor_heap_size in + for i = 1 to 100 do + Gc.minor (); + try + ignore (create () : unit ref); + f () + with _ -> + for i = 1 to minor_size / 2 - 1 do + ignore (ref ()) + done; + ignore (Printexc.get_backtrace () : string) + done; + Printf.printf "ok\n" diff --git a/testsuite/tests/backtrace/backtraces_and_finalizers.reference b/testsuite/tests/backtrace/backtraces_and_finalizers.reference new file mode 100644 index 000000000..9766475a4 --- /dev/null +++ b/testsuite/tests/backtrace/backtraces_and_finalizers.reference @@ -0,0 +1 @@ +ok diff --git a/testsuite/tests/basic-io-2/io.ml b/testsuite/tests/basic-io-2/io.ml index 14e458cdd..8c71206a8 100644 --- a/testsuite/tests/basic-io-2/io.ml +++ b/testsuite/tests/basic-io-2/io.ml @@ -25,7 +25,7 @@ let test msg funct f1 f2 = let copy_file sz infile ofile = let ic = open_in_bin infile in let oc = open_out_bin ofile in - let buffer = String.create sz in + let buffer = Bytes.create sz in let rec copy () = let n = input ic buffer 0 sz in if n = 0 then () else begin @@ -41,7 +41,7 @@ let copy_file sz infile ofile = let copy_random sz infile ofile = let ic = open_in_bin infile in let oc = open_out_bin ofile in - let buffer = String.create sz in + let buffer = Bytes.create sz in let rec copy () = let s = 1 + Random.int sz in let n = input ic buffer 0 s in @@ -72,7 +72,7 @@ let copy_seek chunksize infile ofile = let ic = open_in_bin infile in let oc = open_out_bin ofile in let size = in_channel_length ic in - let buffer = String.create chunksize in + let buffer = Bytes.create chunksize in for i = (size - 1) / chunksize downto 0 do seek_in ic (i * chunksize); seek_out oc (i * chunksize); diff --git a/testsuite/tests/basic-modules/Makefile b/testsuite/tests/basic-modules/Makefile new file mode 100644 index 000000000..62dbc2a69 --- /dev/null +++ b/testsuite/tests/basic-modules/Makefile @@ -0,0 +1,19 @@ +######################################################################### +# # +# OCaml # +# # +# Xavier Clerc, SED, INRIA Rocquencourt # +# # +# Copyright 2010 Institut National de Recherche en Informatique et # +# en Automatique. All rights reserved. This file is distributed # +# under the terms of the Q Public License version 1.0. # +# # +######################################################################### + +BASEDIR=../.. + +MODULES=offset +MAIN_MODULE=main + +include $(BASEDIR)/makefiles/Makefile.one +include $(BASEDIR)/makefiles/Makefile.common diff --git a/testsuite/tests/basic-modules/main.ml b/testsuite/tests/basic-modules/main.ml new file mode 100644 index 000000000..54f8cbd61 --- /dev/null +++ b/testsuite/tests/basic-modules/main.ml @@ -0,0 +1,13 @@ +(* PR#6435 *) + +module F (M : sig + type t + module Set : Set.S with type elt = t + end) = +struct + let test set = Printf.printf "%d\n" (M.Set.cardinal set) +end + +module M = F (Offset) + +let () = M.test (Offset.M.Set.singleton "42") diff --git a/testsuite/tests/basic-modules/main.reference b/testsuite/tests/basic-modules/main.reference new file mode 100644 index 000000000..d00491fd7 --- /dev/null +++ b/testsuite/tests/basic-modules/main.reference @@ -0,0 +1 @@ +1 diff --git a/testsuite/tests/basic-modules/offset.ml b/testsuite/tests/basic-modules/offset.ml new file mode 100644 index 000000000..457947dcd --- /dev/null +++ b/testsuite/tests/basic-modules/offset.ml @@ -0,0 +1,10 @@ +module M = struct + type t = string + + let x = 0 + let x = 1 + + module Set = Set.Make(String) +end + +include M diff --git a/testsuite/tests/basic-more/pr2719.ml b/testsuite/tests/basic-more/pr2719.ml new file mode 100644 index 000000000..f0a9d6a4f --- /dev/null +++ b/testsuite/tests/basic-more/pr2719.ml @@ -0,0 +1,17 @@ +open Printf + +let bug () = + let mat = [| [|false|] |] + and test = ref false in + printf "Value of test at the beginning : %b\n" !test; flush stdout; + (try let _ = mat.(0).(-1) in + (test := true; + printf "Am I going through this block of instructions ?\n"; + flush stdout) + with Invalid_argument _ -> printf "Value of test now : %b\n" !test + ); + (try if mat.(0).(-1) then () + with Invalid_argument _ -> () + ) + +let () = bug () diff --git a/testsuite/tests/basic-more/pr2719.reference b/testsuite/tests/basic-more/pr2719.reference new file mode 100644 index 000000000..073d0916d --- /dev/null +++ b/testsuite/tests/basic-more/pr2719.reference @@ -0,0 +1,4 @@ +Value of test at the beginning : false +Value of test now : false + +All tests succeeded. diff --git a/testsuite/tests/basic-more/tprintf.ml b/testsuite/tests/basic-more/tprintf.ml index 9ea9366f5..5777739fe 100644 --- a/testsuite/tests/basic-more/tprintf.ml +++ b/testsuite/tests/basic-more/tprintf.ml @@ -20,7 +20,8 @@ let test0 () = sprintf "%.0f" 1.0 = "1" && sprintf "%.0f." 1.7 = "2." && sprintf "%.1f." 1.0 = "1.0." && - sprintf "%0.1f." 12.0 = "12.0." && + (*sprintf "%0.1f." 12.0 = "12.0." &&*) + (* >> '0' w/o padding *) sprintf "%3.1f." 12.0 = "12.0." && sprintf "%5.1f." 12.0 = " 12.0." && sprintf "%10.1f." 12.0 = " 12.0." && @@ -33,7 +34,8 @@ let test0 () = sprintf "%010.0f." 12.0 = "0000000012." && sprintf "% 10.0f." 12.0 = " 12." && - sprintf "%0.1f." 12.0 = "12.0." && + (*sprintf "%0.1f." 12.0 = "12.0." &&*) + (* >> '0' w/o padding *) sprintf "%10.1f." 1.001 = " 1.0." && sprintf "%05.1f." 1.001 = "001.0." ;; @@ -59,8 +61,9 @@ test (test2 ());; (* Testing meta format string printing. *) let test3 () = -sprintf "%{toto %s titi.\n%}" "Bonjour %s." = "%s" && -sprintf "%{%d%s%}" "kk%dkk%s\n" = "%i%s";; + sprintf "%{toto %S titi.\n%}" "Bonjour %S." = "%s" && + sprintf "%{Bonjour %S.%}" "toto %S titi.\n" = "%s" +;; test (test3 ());; (* Testing meta format string arguments. *) diff --git a/testsuite/tests/basic/arrays.ml b/testsuite/tests/basic/arrays.ml index e123edff6..b56893f5e 100644 --- a/testsuite/tests/basic/arrays.ml +++ b/testsuite/tests/basic/arrays.ml @@ -79,7 +79,7 @@ let test3 () = and t2 = AbstractFloat.from_float 2.0 and t3 = AbstractFloat.from_float 3.0 in let v = [|t1;t2;t3|] in - let w = Array.create 2 t1 in + let w = Array.make 2 t1 in let u = Array.copy v in if not (AbstractFloat.to_float v.(0) = 1.0 && AbstractFloat.to_float v.(1) = 2.0 && diff --git a/testsuite/tests/basic/constprop.ml b/testsuite/tests/basic/constprop.ml new file mode 100644 index 000000000..666129131 --- /dev/null +++ b/testsuite/tests/basic/constprop.ml @@ -0,0 +1,72 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2014 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* Test constant propagation through inlining *) + +(* constprop.ml is generated from constprop.mlp using + cpp constprop.mlp > constprop.ml +*) +let do_test msg res1 res2 = + Printf.printf "%s: %s\n" msg (if res1 = res2 then "passed" else "FAILED") +(* Hide a constant from the optimizer, preventing constant propagation *) +let hide x = List.nth [x] 0 +let _ = + begin + let x = true and y = false in + let xh = hide x and yh = hide y in + do_test "booleans" ((x && y, x || y, not x)) ((xh && yh, xh || yh, not xh)) + end; + begin + let x = 89809344 and y = 457455773 and s = 7 in + let xh = hide x and yh = hide y and sh = hide s in + do_test "integers" ((-x, x + y, x - y, x * y, x / y, x mod y, x land y, x lor y, x lxor y, x lsl s, x lsr s, x asr s, x = y, x <> y, x < y, x <= y, x > y, x >= y, succ x, pred y)) ((-xh, xh + yh, xh - yh, xh * yh, xh / yh, xh mod yh, xh land yh, xh lor yh, xh lxor yh, xh lsl sh, xh lsr sh, xh asr sh, xh = yh, xh <> yh, xh < yh, xh <= yh, xh > yh, xh >= yh, succ xh, pred yh)) + end; + begin + let x = 3.141592654 and y = 0.341638588598232096 in + let xh = hide x and yh = hide y in + do_test "floats" ((int_of_float x, x +. y, x -. y, x *. y, x /. y, x = y, x <> y, x < y, x <= y, x > y, x >= y)) ((int_of_float xh, xh +. yh, xh -. yh, xh *. yh, xh /. yh, xh = yh, xh <> yh, xh < yh, xh <= yh, xh > yh, xh >= yh)) + end; + begin + let x = 781944104l and y = 308219921l and s = 3 in + let xh = hide x and yh = hide y and sh = hide s in + do_test "32-bit integers" (Int32.(neg x, add x y, sub x y, mul x y, div x y, rem x y, logand x y, logor x y, logxor x y, shift_left x s, shift_right x s, shift_right_logical x s, x = y, x <> y, x < y, x <= y, x > y, x >= y)) (Int32.(neg xh, add xh yh, sub xh yh, mul xh yh, div xh yh, rem xh yh, logand xh yh, logor xh yh, logxor xh yh, shift_left xh sh, shift_right xh sh, shift_right_logical xh sh, xh = yh, xh <> yh, xh < yh, xh <= yh, xh > yh, xh >= yh)) + end; + begin + let x = 1828697041n and y = -521695949n and s = 8 in + let xh = hide x and yh = hide y and sh = hide s in + do_test "native integers" (Nativeint.(neg x, add x y, sub x y, mul x y, div x y, rem x y, logand x y, logor x y, logxor x y, shift_left x s, shift_right x s, shift_right_logical x s, x = y, x <> y, x < y, x <= y, x > y, x >= y)) (Nativeint.(neg xh, add xh yh, sub xh yh, mul xh yh, div xh yh, rem xh yh, logand xh yh, logor xh yh, logxor xh yh, shift_left xh sh, shift_right xh sh, shift_right_logical xh sh, xh = yh, xh <> yh, xh < yh, xh <= yh, xh > yh, xh >= yh)) + end; + begin + let x = 1511491586921138079L and y = 6677538715441746158L and s = 17 in + let xh = hide x and yh = hide y and sh = hide s in + do_test "64-bit integers" (Int64.(neg x, add x y, sub x y, mul x y, div x y, rem x y, logand x y, logor x y, logxor x y, shift_left x s, shift_right x s, shift_right_logical x s, x = y, x <> y, x < y, x <= y, x > y, x >= y)) (Int64.(neg xh, add xh yh, sub xh yh, mul xh yh, div xh yh, rem xh yh, logand xh yh, logor xh yh, logxor xh yh, shift_left xh sh, shift_right xh sh, shift_right_logical xh sh, xh = yh, xh <> yh, xh < yh, xh <= yh, xh > yh, xh >= yh)) + end; + begin + let x = 1000807289 in + let xh = hide x in + do_test "integer conversions" ((float_of_int x, Int32.of_int x, Nativeint.of_int x, Int64.of_int x)) ((float_of_int xh, Int32.of_int xh, Nativeint.of_int xh, Int64.of_int xh)) + end; + begin + let x = 10486393l in + let xh = hide x in + do_test "32-bit integer conversions" ((Int32.to_int x, Nativeint.of_int32 x, Int64.of_int32 x)) ((Int32.to_int xh, Nativeint.of_int32 xh, Int64.of_int32 xh)) + end; + begin + let x = -131134014n in + let xh = hide x in + do_test "native integer conversions" ((Nativeint.to_int x, Nativeint.to_int32 x, Int64.of_nativeint x)) ((Nativeint.to_int xh, Nativeint.to_int32 xh, Int64.of_nativeint xh)) + end; + begin + let x = 531871273453404175L in + let xh = hide x in + do_test "64-bit integer conversions" ((Int64.to_int x, Int64.to_int32 x, Int64.to_nativeint x)) ((Int64.to_int xh, Int64.to_int32 xh, Int64.to_nativeint xh)) + end diff --git a/testsuite/tests/basic/constprop.mlp b/testsuite/tests/basic/constprop.mlp new file mode 100644 index 000000000..305a98dd9 --- /dev/null +++ b/testsuite/tests/basic/constprop.mlp @@ -0,0 +1,130 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2014 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* Test constant propagation through inlining *) + +(* constprop.ml is generated from constprop.mlp using + cpp constprop.mlp > constprop.ml +*) + +#define tbool(x,y) \ + (x && y, x || y, not x) + +#define tint(x,y,s) \ + (-x, x + y, x - y, x * y, x / y, x mod y, \ + x land y, x lor y, x lxor y, \ + x lsl s, x lsr s, x asr s, \ + x = y, x <> y, x < y, x <= y, x > y, x >= y, \ + succ x, pred y) + +#define tfloat(x,y) \ + (int_of_float x, \ + x +. y, x -. y, x *. y, x /. y, \ + x = y, x <> y, x < y, x <= y, x > y, x >= y) + +#define tconvint(i) \ + (float_of_int i, \ + Int32.of_int i, \ + Nativeint.of_int i, \ + Int64.of_int i) + +#define tconvint32(i) \ + (Int32.to_int i, \ + Nativeint.of_int32 i, \ + Int64.of_int32 i) + +#define tconvnativeint(i) \ + (Nativeint.to_int i, \ + Nativeint.to_int32 i, \ + Int64.of_nativeint i) + +#define tconvint64(i) \ + (Int64.to_int i, \ + Int64.to_int32 i, \ + Int64.to_nativeint i) \ + +#define tint32(x,y,s) \ + Int32.(neg x, add x y, sub x y, mul x y, div x y, rem x y, \ + logand x y, logor x y, logxor x y, \ + shift_left x s, shift_right x s, shift_right_logical x s, \ + x = y, x <> y, x < y, x <= y, x > y, x >= y) + +#define tnativeint(x,y,s) \ + Nativeint.(neg x, add x y, sub x y, mul x y, div x y, rem x y, \ + logand x y, logor x y, logxor x y, \ + shift_left x s, shift_right x s, shift_right_logical x s, \ + x = y, x <> y, x < y, x <= y, x > y, x >= y) + +#define tint64(x,y,s) \ + Int64.(neg x, add x y, sub x y, mul x y, div x y, rem x y, \ + logand x y, logor x y, logxor x y, \ + shift_left x s, shift_right x s, shift_right_logical x s, \ + x = y, x <> y, x < y, x <= y, x > y, x >= y) + +let do_test msg res1 res2 = + Printf.printf "%s: %s\n" msg (if res1 = res2 then "passed" else "FAILED") + +(* Hide a constant from the optimizer, preventing constant propagation *) +let hide x = List.nth [x] 0 + +let _ = + begin + let x = true and y = false in + let xh = hide x and yh = hide y in + do_test "booleans" (tbool(x, y)) (tbool(xh,yh)) + end; + begin + let x = 89809344 and y = 457455773 and s = 7 in + let xh = hide x and yh = hide y and sh = hide s in + do_test "integers" (tint(x, y, s)) (tint(xh,yh,sh)) + end; + begin + let x = 3.141592654 and y = 0.341638588598232096 in + let xh = hide x and yh = hide y in + do_test "floats" (tfloat(x, y)) (tfloat(xh, yh)) + end; + begin + let x = 781944104l and y = 308219921l and s = 3 in + let xh = hide x and yh = hide y and sh = hide s in + do_test "32-bit integers" (tint32(x, y, s)) (tint32(xh, yh, sh)) + end; + begin + let x = 1828697041n and y = -521695949n and s = 8 in + let xh = hide x and yh = hide y and sh = hide s in + do_test "native integers" (tnativeint(x, y, s)) (tnativeint(xh, yh, sh)) + end; + begin + let x = 1511491586921138079L and y = 6677538715441746158L and s = 17 in + let xh = hide x and yh = hide y and sh = hide s in + do_test "64-bit integers" (tint64(x, y, s)) (tint64(xh, yh, sh)) + end; + begin + let x = 1000807289 in + let xh = hide x in + do_test "integer conversions" (tconvint(x)) (tconvint(xh)) + end; + begin + let x = 10486393l in + let xh = hide x in + do_test "32-bit integer conversions" (tconvint32(x)) (tconvint32(xh)) + end; + begin + let x = -131134014n in + let xh = hide x in + do_test "native integer conversions" (tconvnativeint(x)) (tconvnativeint(xh)) + end; + begin + let x = 531871273453404175L in + let xh = hide x in + do_test "64-bit integer conversions" (tconvint64(x)) (tconvint64(xh)) + end + diff --git a/testsuite/tests/basic/constprop.reference b/testsuite/tests/basic/constprop.reference new file mode 100644 index 000000000..59590530a --- /dev/null +++ b/testsuite/tests/basic/constprop.reference @@ -0,0 +1,10 @@ +booleans: passed +integers: passed +floats: passed +32-bit integers: passed +native integers: passed +64-bit integers: passed +integer conversions: passed +32-bit integer conversions: passed +native integer conversions: passed +64-bit integer conversions: passed diff --git a/testsuite/tests/basic/divint.ml b/testsuite/tests/basic/divint.ml index 6dd4be3fc..52d14b9c8 100644 --- a/testsuite/tests/basic/divint.ml +++ b/testsuite/tests/basic/divint.ml @@ -32,7 +32,7 @@ let test_one (df: int -> int) (mf: int -> int) x = let do_test divisor (df: int -> int) (mf: int -> int) = d := divisor; List.iter (test_one df mf) - [0; 1; 2; 3; 4; 5; 6; 7; 8; 9; 10; + [0; 1; 2; 3; 4; 5; 6; 7; 8; 9; 10; 100; 1000; 10000; 100000; 1000000; max_int - 1; max_int; -1; -2; -3; -4; -5; -6; -7; -8; -9; -10; -100; -1000; -10000; -100000; -1000000; min_int + 1; min_int]; @@ -59,7 +59,7 @@ let test_one (df: nativeint -> nativeint) (mf: nativeint -> nativeint) x = let do_test divisor (df: nativeint -> nativeint) (mf: nativeint -> nativeint) = d := Nativeint.of_int divisor; List.iter (test_one df mf) - [0n; 1n; 2n; 3n; 4n; 5n; 6n; 7n; 8n; 9n; 10n; + [0n; 1n; 2n; 3n; 4n; 5n; 6n; 7n; 8n; 9n; 10n; 100n; 1000n; 10000n; 100000n; 1000000n; Nativeint.(pred max_int); Nativeint.max_int; -1n; -2n; -3n; -4n; -5n; -6n; -7n; -8n; -9n; -10n; diff --git a/testsuite/tests/basic/maps.ml b/testsuite/tests/basic/maps.ml index 199f6fe4d..38b0d2b0c 100644 --- a/testsuite/tests/basic/maps.ml +++ b/testsuite/tests/basic/maps.ml @@ -19,7 +19,18 @@ let show m = IntMap.iter (fun k v -> Printf.printf "%d %s\n" k v) m let () = print_endline "Union+concat"; - show (IntMap.merge (fun _ l r -> match l, r with Some x, None | None, Some x -> Some x | Some x, Some y -> Some (x ^ x) | _ -> assert false) m1 m2); + let f1 _ l r = + match l, r with + | Some x, None | None, Some x -> Some x + | Some x, Some y -> Some (x ^ x) + | _ -> assert false + in + show (IntMap.merge f1 m1 m2); print_endline "Inter"; - show (IntMap.merge (fun _ l r -> match l, r with Some x, Some y when x = y -> Some x | _ -> None) m1 m2); + let f2 _ l r = + match l, r with + | Some x, Some y when x = y -> Some x + | _ -> None + in + show (IntMap.merge f2 m1 m2); () diff --git a/testsuite/tests/basic/tailcalls.ml b/testsuite/tests/basic/tailcalls.ml index 666acb45f..4b33206ee 100644 --- a/testsuite/tests/basic/tailcalls.ml +++ b/testsuite/tests/basic/tailcalls.ml @@ -32,9 +32,22 @@ let indtailcall8 fn a b c d e f g h = let indtailcall16 fn a b c d e f g h i j k l m n o p = fn a b c d e f g h i j k l m n o p +(* regression test for PR#6441: *) +let rec tailcall16_value_closures a b c d e f g h i j k l m n o p = + if a < 0 + then b + else tailcall16_value_closures + (a-1) (b+1) (c+2) (d+3) (e+4) (f+5) (g+6) (h+7) + (i+8) (j+9) (k+10) (l+11) (m+12) (n+13) (o+14) (p+15) +and fs = [tailcall16_value_closures] + let _ = print_int (tailcall4 10000000 0 0 0); print_newline(); print_int (tailcall8 10000000 0 0 0 0 0 0 0); print_newline(); - print_int (tailcall16 10000000 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0); print_newline(); + print_int (tailcall16 10000000 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0); + print_newline(); print_int (indtailcall8 tailcall8 10 0 0 0 0 0 0 0); print_newline(); - print_int (indtailcall16 tailcall16 10 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0); print_newline() + print_int (indtailcall16 tailcall16 10 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0); + print_newline(); + print_int (tailcall16_value_closures 10000000 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0); + print_newline() diff --git a/testsuite/tests/basic/tailcalls.reference b/testsuite/tests/basic/tailcalls.reference index 0943aba55..c7117bc95 100644 --- a/testsuite/tests/basic/tailcalls.reference +++ b/testsuite/tests/basic/tailcalls.reference @@ -3,3 +3,4 @@ 10000001 11 11 +10000001 diff --git a/testsuite/tests/embedded/cmcaml.ml b/testsuite/tests/embedded/cmcaml.ml index 121cec36f..b3e9b7e29 100644 --- a/testsuite/tests/embedded/cmcaml.ml +++ b/testsuite/tests/embedded/cmcaml.ml @@ -18,7 +18,7 @@ let rec fib n = let format_result n = let r = "Result = " ^ string_of_int n in (* Allocate gratuitously to test GC *) - for i = 1 to 1500 do ignore (String.create 256) done; + for i = 1 to 1500 do ignore (Bytes.create 256) done; r (* Registration *) diff --git a/testsuite/tests/formats-transition/Makefile b/testsuite/tests/formats-transition/Makefile new file mode 100644 index 000000000..9625a3fbc --- /dev/null +++ b/testsuite/tests/formats-transition/Makefile @@ -0,0 +1,3 @@ +BASEDIR=../.. +include $(BASEDIR)/makefiles/Makefile.toplevel +include $(BASEDIR)/makefiles/Makefile.common diff --git a/testsuite/tests/formats-transition/deprecated_unsigned_printers.ml b/testsuite/tests/formats-transition/deprecated_unsigned_printers.ml new file mode 100644 index 000000000..3127d773a --- /dev/null +++ b/testsuite/tests/formats-transition/deprecated_unsigned_printers.ml @@ -0,0 +1,22 @@ +(* %n, %l, %N and %L have a scanf-specific semantics, but are supposed + to be interpreted by Printf and Format as %u, despite this + interpretation being mildly deprecated *) + +let test format = (Printf.sprintf format (-3) : string) +;; + +let () = Printf.printf "%%n: %B\n" + (test "%n" = test "%u") +;; + +let () = Printf.printf "%%l: %B\n" + (test "%l" = test "%u") +;; + +let () = Printf.printf "%%N: %B\n" + (test "%N" = test "%u") +;; + +let () = Printf.printf "%%L: %B\n" + (test "%L" = test "%u") +;; diff --git a/testsuite/tests/formats-transition/deprecated_unsigned_printers.ml.reference b/testsuite/tests/formats-transition/deprecated_unsigned_printers.ml.reference new file mode 100644 index 000000000..0afeaa2be --- /dev/null +++ b/testsuite/tests/formats-transition/deprecated_unsigned_printers.ml.reference @@ -0,0 +1,7 @@ + +# * * val test : (int -> string, unit, string) format -> string = <fun> +# %n: true +# %l: true +# %N: true +# %L: true +# diff --git a/testsuite/tests/formats-transition/ignored_scan_counters.ml b/testsuite/tests/formats-transition/ignored_scan_counters.ml new file mode 100644 index 000000000..706a1af6f --- /dev/null +++ b/testsuite/tests/formats-transition/ignored_scan_counters.ml @@ -0,0 +1,30 @@ +(* Benoît's patch did not support %_[nlNL]; test their behavior *) + +(* not supported by Printf or Format: fails at runtime *) +let () = Printf.printf "%_n" +;; +let () = Printf.printf "%_N" +;; +let () = Printf.printf "%_l" +;; +let () = Printf.printf "%_L" +;; + +let () = Format.printf "%_n" +;; +let () = Format.printf "%_N" +;; +let () = Format.printf "%_l" +;; +let () = Format.printf "%_L" +;; + +(* identity for Scanf *) +let () = print_endline (Scanf.sscanf "" "%_n" "Hello World!") +;; +let () = print_endline (Scanf.sscanf "" "%_N" "Hello World!") +;; +let () = print_endline (Scanf.sscanf "" "%_l" "Hello World!") +;; +let () = print_endline (Scanf.sscanf "" "%_L" "Hello World!") +;; diff --git a/testsuite/tests/formats-transition/ignored_scan_counters.ml.reference b/testsuite/tests/formats-transition/ignored_scan_counters.ml.reference new file mode 100644 index 000000000..6d8d098b5 --- /dev/null +++ b/testsuite/tests/formats-transition/ignored_scan_counters.ml.reference @@ -0,0 +1,14 @@ + +# Exception: Invalid_argument "Printf: bad conversion %_". +# Exception: Invalid_argument "Printf: bad conversion %_". +# Exception: Invalid_argument "Printf: bad conversion %_". +# Exception: Invalid_argument "Printf: bad conversion %_". +# Exception: Invalid_argument "Printf: bad conversion %_". +# Exception: Invalid_argument "Printf: bad conversion %_". +# Exception: Invalid_argument "Printf: bad conversion %_". +# Exception: Invalid_argument "Printf: bad conversion %_". +# Hello World! +# Hello World! +# Hello World! +# Hello World! +# diff --git a/testsuite/tests/formats-transition/invalid_formats.ml b/testsuite/tests/formats-transition/invalid_formats.ml new file mode 100644 index 000000000..71f796b04 --- /dev/null +++ b/testsuite/tests/formats-transition/invalid_formats.ml @@ -0,0 +1,4 @@ +(* Empty file added to create a conflict with branch 4.02 because + the test only makes sense on 4.02.x and will not work on 4.03+ + When merging, don't forget to remove also the .ml.reference file. + *) diff --git a/testsuite/tests/formats-transition/legacy_incompatible_flags.ml b/testsuite/tests/formats-transition/legacy_incompatible_flags.ml new file mode 100644 index 000000000..53cf5c26c --- /dev/null +++ b/testsuite/tests/formats-transition/legacy_incompatible_flags.ml @@ -0,0 +1,20 @@ +(* the legacy parser ignores flags on formatters on which they make no + sense *) + +let () = Printf.printf "%+s\n" "toto" +;; +let () = Printf.printf "%#s\n" "toto" +;; +let () = Printf.printf "% s\n" "toto" +;; +let () = Printf.printf "%03s\n" "toto" +;; +let () = Printf.printf "%03S\n" "toto" +;; +let () = Printf.printf "%.3s\n" "toto" +;; + +(* it still fails on flags used with ignored formats (%_d, etc.), + but it's unclear how to test that in a backward-compatible way, + if we accept that the error message may have changed +*) diff --git a/testsuite/tests/formats-transition/legacy_unfinished_modifiers.ml b/testsuite/tests/formats-transition/legacy_unfinished_modifiers.ml new file mode 100644 index 000000000..16eca40c1 --- /dev/null +++ b/testsuite/tests/formats-transition/legacy_unfinished_modifiers.ml @@ -0,0 +1,18 @@ +(* test whether padding modifiers are accepted without any padding + size + + the precision modifier is accepted without precision setting, but it + defaults to 0, which is not the same thing as not having precision: + %.0f 3.5 => 3 + %.f 3.5 => 3 + %f 3.5 => 3.5 +*) + +let () = Printf.printf "%0d\n" 3 +;; +let () = Printf.printf "%-d\n" 3 +;; +let () = Printf.printf "%.d\n" 3 +;; +let () = Printf.printf "%.f\n" 3. +;; diff --git a/testsuite/tests/formats-transition/legacy_unfinished_modifiers.ml.reference b/testsuite/tests/formats-transition/legacy_unfinished_modifiers.ml.reference new file mode 100644 index 000000000..81c05c0dd --- /dev/null +++ b/testsuite/tests/formats-transition/legacy_unfinished_modifiers.ml.reference @@ -0,0 +1,6 @@ + +# * * * * * * * * 3 +# 3 +# 3 +# 3 +# diff --git a/testsuite/tests/gc-roots/globrootsprim.c b/testsuite/tests/gc-roots/globrootsprim.c index 9a1cc843a..f7bb32cea 100644 --- a/testsuite/tests/gc-roots/globrootsprim.c +++ b/testsuite/tests/gc-roots/globrootsprim.c @@ -16,10 +16,12 @@ #include "mlvalues.h" #include "memory.h" #include "alloc.h" +#include "gc.h" -struct block { value v; }; +struct block { value header; value v; }; -#define Block_val(v) ((struct block *) (v)) +#define Block_val(v) ((struct block*) &((value*) v)[-1]) +#define Val_block(b) ((value) &((b)->v)) value gb_get(value vblock) { @@ -29,9 +31,10 @@ value gb_get(value vblock) value gb_classic_register(value v) { struct block * b = caml_stat_alloc(sizeof(struct block)); + b->header = Make_header(1, 0, Caml_black); b->v = v; caml_register_global_root(&(b->v)); - return (value) b; + return Val_block(b); } value gb_classic_set(value vblock, value newval) @@ -49,9 +52,10 @@ value gb_classic_remove(value vblock) value gb_generational_register(value v) { struct block * b = caml_stat_alloc(sizeof(struct block)); + b->header = Make_header(1, 0, Caml_black); b->v = v; caml_register_generational_global_root(&(b->v)); - return (value) b; + return Val_block(b); } value gb_generational_set(value vblock, value newval) diff --git a/testsuite/tests/lib-bigarray-2/bigarrfml.ml b/testsuite/tests/lib-bigarray-2/bigarrfml.ml index c259061eb..906826fae 100644 --- a/testsuite/tests/lib-bigarray-2/bigarrfml.ml +++ b/testsuite/tests/lib-bigarray-2/bigarrfml.ml @@ -38,10 +38,14 @@ let test test_number answer correct_answer = (* External C and Fortran functions *) -external c_filltab : unit -> (float, float64_elt, c_layout) Array2.t = "c_filltab" -external c_printtab : (float, float64_elt, c_layout) Array2.t -> unit = "c_printtab" -external fortran_filltab : unit -> (float, float32_elt, fortran_layout) Array2.t = "fortran_filltab" -external fortran_printtab : (float, float32_elt, fortran_layout) Array2.t -> unit = "fortran_printtab" +external c_filltab : + unit -> (float, float64_elt, c_layout) Array2.t = "c_filltaab" +external c_printtab : + (float, float64_elt, c_layout) Array2.t -> unit = "c_printtab" +external fortran_filltab : + unit -> (float, float32_elt, fortran_layout) Array2.t = "fortran_filltab" +external fortran_printtab : + (float, float32_elt, fortran_layout) Array2.t -> unit = "fortran_printtab" let _ = diff --git a/testsuite/tests/lib-bigarray/bigarrays.ml b/testsuite/tests/lib-bigarray/bigarrays.ml index 333c17547..5ac8e7f74 100644 --- a/testsuite/tests/lib-bigarray/bigarrays.ml +++ b/testsuite/tests/lib-bigarray/bigarrays.ml @@ -433,7 +433,8 @@ let _ = (check_array2 (make_array2 float64 c_layout 0 10 20 float) 0 10 20 float); test 6 true - (check_array2 (make_array2 int16_signed fortran_layout 1 10 20 id) 1 10 20 id); + (check_array2 (make_array2 int16_signed fortran_layout 1 10 20 id) + 1 10 20 id); test 7 true (check_array2 (make_array2 int fortran_layout 1 10 20 id) 1 10 20 id); test 8 true @@ -494,10 +495,14 @@ let _ = test 1 true !ok; let b = Array2.create float32 fortran_layout 3 3 in - for i = 1 to 3 do for j = 1 to 3 do Array2.unsafe_set b i j (float(i-j)) done done; + for i = 1 to 3 do + for j = 1 to 3 do Array2.unsafe_set b i j (float(i-j)) done + done; let ok = ref true in for i = 1 to 3 do - for j = 1 to 3 do if Array2.unsafe_get b i j <> float(i-j) then ok := false done + for j = 1 to 3 do + if Array2.unsafe_get b i j <> float(i-j) then ok := false + done done; test 2 true !ok; @@ -541,9 +546,12 @@ let _ = test 4 (Array2.slice_left a 3) (from_list int [3000;3001;3002]); test 5 (Array2.slice_left a 4) (from_list int [4000;4001;4002]); let a = make_array2 int fortran_layout 1 5 3 id in - test 6 (Array2.slice_right a 1) (from_list_fortran int [1001;2001;3001;4001;5001]); - test 7 (Array2.slice_right a 2) (from_list_fortran int [1002;2002;3002;4002;5002]); - test 8 (Array2.slice_right a 3) (from_list_fortran int [1003;2003;3003;4003;5003]); + test 6 (Array2.slice_right a 1) + (from_list_fortran int [1001;2001;3001;4001;5001]); + test 7 (Array2.slice_right a 2) + (from_list_fortran int [1002;2002;3002;4002;5002]); + test 8 (Array2.slice_right a 3) + (from_list_fortran int [1003;2003;3003;4003;5003]); (* Tri-dimensional arrays *) @@ -587,7 +595,8 @@ let _ = (check_array3 (make_array3 float64 c_layout 0 4 5 6 float) 0 4 5 6 float); test 6 true - (check_array3 (make_array3 int16_signed fortran_layout 1 4 5 6 id) 1 4 5 6 id); + (check_array3 (make_array3 int16_signed fortran_layout 1 4 5 6 id) + 1 4 5 6 id); test 7 true (check_array3 (make_array3 int fortran_layout 1 4 5 6 id) 1 4 5 6 id); test 8 true @@ -641,7 +650,8 @@ let _ = done done done; let ok = ref true in for i = 0 to 1 do for j = 0 to 2 do for k = 0 to 3 do - if Int32.to_int (Array3.unsafe_get a i j k) <> (i lsl 4) + (j lsl 2) + k then ok := false + if Int32.to_int (Array3.unsafe_get a i j k) <> (i lsl 4) + (j lsl 2) + k + then ok := false done done done; test 1 true !ok; @@ -675,7 +685,8 @@ let _ = let c = reshape_1 (genarray_of_array2 a) 12 in test 1 c (from_list int [0;1;2;3;1000;1001;1002;1003;2000;2001;2002;2003]); let d = reshape_1 (genarray_of_array2 b) 12 in - test 2 d (from_list_fortran int [1001;2001;3001;1002;2002;3002;1003;2003;3003;1004;2004;3004]); + test 2 d (from_list_fortran int + [1001;2001;3001;1002;2002;3002;1003;2003;3003;1004;2004;3004]); testing_function "reshape_2"; let c = reshape_2 (genarray_of_array2 a) 4 3 in test 1 (Array2.slice_left c 0) (from_list int [0;1;2]); @@ -718,7 +729,8 @@ let _ = test_structured_io 11 (make_array3 int32 c_layout 0 20 30 40 Int32.of_int); test_structured_io 12 (make_array3 float32 fortran_layout 1 10 50 100 float); test_structured_io 13 (make_array2 complex32 c_layout 0 100 100 makecomplex); - test_structured_io 14 (make_array3 complex64 fortran_layout 1 10 20 30 makecomplex); + test_structured_io 14 (make_array3 complex64 fortran_layout 1 10 20 30 + makecomplex); testing_function "map_file"; let mapped_file = Filename.temp_file "bigarray" ".data" in diff --git a/testsuite/tests/lib-digest/md5.ml b/testsuite/tests/lib-digest/md5.ml index 66cd46750..f9bcf9289 100644 --- a/testsuite/tests/lib-digest/md5.ml +++ b/testsuite/tests/lib-digest/md5.ml @@ -201,7 +201,9 @@ let test hex s = let res = finish ctx in let exp = Digest.string s in let ok = res = exp && Digest.to_hex exp = hex in - if not ok then Printf.printf "Failure for %S : %S %S %S %S\n" s res exp (Digest.to_hex exp) hex; + if not ok then + Printf.printf "Failure for %S : %S %S %S %S\n" s res exp + (Digest.to_hex exp) hex; ok let time msg iter fn = @@ -215,12 +217,16 @@ let _ = if test "d41d8cd98f00b204e9800998ecf8427e" "" && test "0cc175b9c0f1b6a831c399e269772661" "a" && test "900150983cd24fb0d6963f7d28e17f72" "abc" - && test "8215ef0796a20bcaaae116d3876c664a" "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" + && test "8215ef0796a20bcaaae116d3876c664a" + "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" && test "7707d6ae4e027c70eea2a935c2296f21" (String.make 1_000_000 'a') && test "f96b697d7cb7938d525a2f31aaf161d0" "message digest" - && test "d174ab98d277d9f5a5611c2c9f419d9f" "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" - && test "9e107d9d372bb6826bd81d3542a419d6" "The quick brown fox jumps over the lazy dog" - && test "e4d909c290d0fb1ca068ffaddf22cbd0" "The quick brown fox jumps over the lazy dog." + && test "d174ab98d277d9f5a5611c2c9f419d9f" + "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" + && test "9e107d9d372bb6826bd81d3542a419d6" + "The quick brown fox jumps over the lazy dog" + && test "e4d909c290d0fb1ca068ffaddf22cbd0" + "The quick brown fox jumps over the lazy dog." then printf "Test vectors passed.\n"; flush stdout; (* Benchmark *) diff --git a/testsuite/tests/lib-dynlink-bytecode/stub1.c b/testsuite/tests/lib-dynlink-bytecode/stub1.c index f97c66f3e..60c8ab35a 100644 --- a/testsuite/tests/lib-dynlink-bytecode/stub1.c +++ b/testsuite/tests/lib-dynlink-bytecode/stub1.c @@ -16,8 +16,9 @@ #include <stdio.h> value stub1() { + CAMLparam0(); CAMLlocal1(x); printf("This is stub1!\n"); fflush(stdout); x = caml_copy_string("ABCDEF"); - return x; + CAMLreturn(x); } diff --git a/testsuite/tests/lib-dynlink-csharp/entry.c b/testsuite/tests/lib-dynlink-csharp/entry.c index a82eb46f6..b5d11636e 100755 --- a/testsuite/tests/lib-dynlink-csharp/entry.c +++ b/testsuite/tests/lib-dynlink-csharp/entry.c @@ -22,8 +22,8 @@ # define _DLLAPI __declspec(dllexport) # else # define _DLLAPI extern -# endif -# if defined(__MINGW32__) || defined(UNDER_CE) +# endif +# if defined(__MINGW32__) || defined(UNDER_CE) # define _CALLPROC # else # define _CALLPROC __stdcall diff --git a/testsuite/tests/lib-format/Makefile b/testsuite/tests/lib-format/Makefile index 0b385ca4b..7a6297b6f 100644 --- a/testsuite/tests/lib-format/Makefile +++ b/testsuite/tests/lib-format/Makefile @@ -14,5 +14,7 @@ MAIN_MODULE=tformat ADD_COMPFLAGS=-I $(OTOPDIR)/testsuite/lib ADD_MODULES=testing -include ../../makefiles/Makefile.one -include ../../makefiles/Makefile.common +BASEDIR=../.. + +include $(BASEDIR)/makefiles/Makefile.one +include $(BASEDIR)/makefiles/Makefile.common diff --git a/testsuite/tests/lib-hashtbl/hfun.ml b/testsuite/tests/lib-hashtbl/hfun.ml index 0ff127579..8a3c1cfc0 100644 --- a/testsuite/tests/lib-hashtbl/hfun.ml +++ b/testsuite/tests/lib-hashtbl/hfun.ml @@ -35,7 +35,8 @@ let _ = printf "+infty\t\t%08x\n" (Hashtbl.hash infinity); printf "-infty\t\t%08x\n" (Hashtbl.hash neg_infinity); printf "NaN\t\t%08x\n" (Hashtbl.hash nan); - printf "NaN#2\t\t%08x\n" (Hashtbl.hash (Int64.float_of_bits 0xFF_F0_00_12_34_56_78_9AL)); + printf "NaN#2\t\t%08x\n" + (Hashtbl.hash (Int64.float_of_bits 0xFF_F0_00_12_34_56_78_9AL)); printf "NaN#3\t\t%08x\n" (Hashtbl.hash (0.0 /. 0.0)); printf "-- Native integers:\n"; diff --git a/testsuite/tests/lib-marshal/intext.ml b/testsuite/tests/lib-marshal/intext.ml index 41f24bb65..27ffd64d2 100644 --- a/testsuite/tests/lib-marshal/intext.ml +++ b/testsuite/tests/lib-marshal/intext.ml @@ -230,7 +230,8 @@ let test_string () = t1 == t2 && t3 == t5 && t4 == t1 | _ -> false); let s = Marshal.to_string [|1;2;3;4;5;6;7;8;9;10;11;12;13;14;15;16|] [] in - test 122 (Marshal.from_string s 0 = [|1;2;3;4;5;6;7;8;9;10;11;12;13;14;15;16|]); + test 122 + (Marshal.from_string s 0 = [|1;2;3;4;5;6;7;8;9;10;11;12;13;14;15;16|]); let rec big n = if n <= 0 then A else H(n, big(n-1)) in let s = Marshal.to_string (big 1000) [] in let rec check_big n t = @@ -248,76 +249,77 @@ let marshal_to_buffer s start len v flags = ;; let test_buffer () = - let s = String.create 512 in + let s = Bytes.create 512 in marshal_to_buffer s 0 512 1 []; - test 201 (Marshal.from_string s 0 = 1); + test 201 (Marshal.from_bytes s 0 = 1); marshal_to_buffer s 0 512 (-1) []; - test 202 (Marshal.from_string s 0 = (-1)); + test 202 (Marshal.from_bytes s 0 = (-1)); marshal_to_buffer s 0 512 258 []; - test 203 (Marshal.from_string s 0 = 258); + test 203 (Marshal.from_bytes s 0 = 258); marshal_to_buffer s 0 512 20000 []; - test 204 (Marshal.from_string s 0 = 20000); + test 204 (Marshal.from_bytes s 0 = 20000); marshal_to_buffer s 0 512 0x12345678 []; - test 205 (Marshal.from_string s 0 = 0x12345678); + test 205 (Marshal.from_bytes s 0 = 0x12345678); marshal_to_buffer s 0 512 bigint []; - test 206 (Marshal.from_string s 0 = bigint); + test 206 (Marshal.from_bytes s 0 = bigint); marshal_to_buffer s 0 512 "foobargeebuz" []; - test 207 (Marshal.from_string s 0 = "foobargeebuz"); + test 207 (Marshal.from_bytes s 0 = "foobargeebuz"); marshal_to_buffer s 0 512 longstring []; - test 208 (Marshal.from_string s 0 = longstring); + test 208 (Marshal.from_bytes s 0 = longstring); test 209 (try marshal_to_buffer s 0 512 verylongstring []; false with Failure "Marshal.to_buffer: buffer overflow" -> true); marshal_to_buffer s 0 512 3.141592654 []; - test 210 (Marshal.from_string s 0 = 3.141592654); + test 210 (Marshal.from_bytes s 0 = 3.141592654); marshal_to_buffer s 0 512 () []; - test 211 (Marshal.from_string s 0 = ()); + test 211 (Marshal.from_bytes s 0 = ()); marshal_to_buffer s 0 512 A []; - test 212 (match Marshal.from_string s 0 with + test 212 (match Marshal.from_bytes s 0 with A -> true | _ -> false); marshal_to_buffer s 0 512 (B 1) []; - test 213 (match Marshal.from_string s 0 with + test 213 (match Marshal.from_bytes s 0 with (B 1) -> true | _ -> false); marshal_to_buffer s 0 512 (C 2.718) []; - test 214 (match Marshal.from_string s 0 with + test 214 (match Marshal.from_bytes s 0 with (C f) -> f = 2.718 | _ -> false); marshal_to_buffer s 0 512 (D "hello, world!") []; - test 215 (match Marshal.from_string s 0 with + test 215 (match Marshal.from_bytes s 0 with (D "hello, world!") -> true | _ -> false); marshal_to_buffer s 0 512 (E 'l') []; - test 216 (match Marshal.from_string s 0 with + test 216 (match Marshal.from_bytes s 0 with (E 'l') -> true | _ -> false); marshal_to_buffer s 0 512 (F(B 1)) []; - test 217 (match Marshal.from_string s 0 with + test 217 (match Marshal.from_bytes s 0 with (F(B 1)) -> true | _ -> false); marshal_to_buffer s 0 512 (G(A, G(B 2, G(C 3.14, G(D "glop", E 'e'))))) []; - test 218 (match Marshal.from_string s 0 with + test 218 (match Marshal.from_bytes s 0 with (G(A, G(B 2, G(C 3.14, G(D "glop", E 'e'))))) -> true | _ -> false); marshal_to_buffer s 0 512 (H(1, A)) []; - test 219 (match Marshal.from_string s 0 with + test 219 (match Marshal.from_bytes s 0 with (H(1, A)) -> true | _ -> false); marshal_to_buffer s 0 512 (I(B 2, 1e-6)) []; - test 220 (match Marshal.from_string s 0 with + test 220 (match Marshal.from_bytes s 0 with (I(B 2, 1e-6)) -> true | _ -> false); let x = D "sharing" in let y = G(x, x) in let z = G(y, G(x, y)) in marshal_to_buffer s 0 512 z []; - test 221 (match Marshal.from_string s 0 with + test 221 (match Marshal.from_bytes s 0 with G((G((D "sharing" as t1), t2) as t3), G(t4, t5)) -> t1 == t2 && t3 == t5 && t4 == t1 | _ -> false); marshal_to_buffer s 0 512 [|1;2;3;4;5;6;7;8;9;10;11;12;13;14;15;16|] []; - test 222 (Marshal.from_string s 0 = [|1;2;3;4;5;6;7;8;9;10;11;12;13;14;15;16|]); + test 222 + (Marshal.from_bytes s 0 = [|1;2;3;4;5;6;7;8;9;10;11;12;13;14;15;16|]); let rec big n = if n <= 0 then A else H(n, big(n-1)) in test 223 (try marshal_to_buffer s 0 512 (big 1000) []; false diff --git a/testsuite/tests/lib-num/test_nats.ml b/testsuite/tests/lib-num/test_nats.ml index 7fc15b517..541dd4c69 100644 --- a/testsuite/tests/lib-num/test_nats.ml +++ b/testsuite/tests/lib-num/test_nats.ml @@ -117,7 +117,10 @@ let set_mult_digit_nat n1 d1 l1 n2 d2 l2 n3 d3 = ignore (mult_digit_nat n1 d1 l1 n2 d2 l2 n3 d3) ;; -let s = "3333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333" in +let s = + "33333333333333333333333333333333333333333333333333333333333333333333\ + 33333333333333333333333333333333333333333333333333333333333333333333" +in test 21 equal_nat ( nat_of_string s, (let nat = make_nat 15 in diff --git a/testsuite/tests/lib-printf/Makefile b/testsuite/tests/lib-printf/Makefile index a8a294718..dc31633e1 100644 --- a/testsuite/tests/lib-printf/Makefile +++ b/testsuite/tests/lib-printf/Makefile @@ -15,5 +15,6 @@ MAIN_MODULE=tprintf ADD_COMPFLAGS=-I $(OTOPDIR)/testsuite/lib ADD_MODULES=testing -include ../../makefiles/Makefile.one -include ../../makefiles/Makefile.common +BASEDIR=../.. +include $(BASEDIR)/makefiles/Makefile.one +include $(BASEDIR)/makefiles/Makefile.common diff --git a/testsuite/tests/lib-printf/tprintf.ml b/testsuite/tests/lib-printf/tprintf.ml index 47313b325..2922f8e32 100644 --- a/testsuite/tests/lib-printf/tprintf.ml +++ b/testsuite/tests/lib-printf/tprintf.ml @@ -27,10 +27,12 @@ try test (sprintf "%04d/%05i" 42 43 = "0042/00043"); test (sprintf "%+d/%+i" 42 43 = "+42/+43"); test (sprintf "% d/% i" 42 43 = " 42/ 43"); - test (sprintf "%#d/%#i" 42 43 = "42/43"); + (*test (sprintf "%#d/%#i" 42 43 = "42/43");*) + (* >> '#' is incompatible with 'd' *) test (sprintf "%4d/%5i" 42 43 = " 42/ 43"); test (sprintf "%*d/%*i" 4 42 5 43 = " 42/ 43"); - test (sprintf "%-0+#4d/%-0 #5i" 42 43 = "+42 / 43 "); + (*test (sprintf "%-0+#4d/%-0 #5i" 42 43 = "+42 / 43 ");*) + (* >> '#' is incompatible with 'd' *) printf "\nd/i negative\n%!"; test (sprintf "%d/%i" (-42) (-43) = "-42/-43"); @@ -38,21 +40,27 @@ try test (sprintf "%04d/%05i" (-42) (-43) = "-042/-0043"); test (sprintf "%+d/%+i" (-42) (-43) = "-42/-43"); test (sprintf "% d/% i" (-42) (-43) = "-42/-43"); - test (sprintf "%#d/%#i" (-42) (-43) = "-42/-43"); + (*test (sprintf "%#d/%#i" (-42) (-43) = "-42/-43");*) + (* >> '#' is incompatible with 'd' *) test (sprintf "%4d/%5i" (-42) (-43) = " -42/ -43"); test (sprintf "%*d/%*i" 4 (-42) 5 (-43) = " -42/ -43"); - test (sprintf "%-0+ #4d/%-0+ #5i" (-42) (-43) = "-42 /-43 "); + (*test (sprintf "%-0+ #4d/%-0+ #5i" (-42) (-43) = "-42 /-43 ");*) + (* >> '0' is incompatible with '-', '#' is incompatible with 'd' *) printf "\nu positive\n%!"; test (sprintf "%u" 42 = "42"); test (sprintf "%-4u" 42 = "42 "); test (sprintf "%04u" 42 = "0042"); - test (sprintf "%+u" 42 = "42"); - test (sprintf "% u" 42 = "42"); - test (sprintf "%#u" 42 = "42"); + (*test (sprintf "%+u" 42 = "42");*) + (* >> '+' is incompatible with 'u' *) + (*test (sprintf "% u" 42 = "42");*) + (* >> ' ' is incompatible with 'u' *) + (*test (sprintf "%#u" 42 = "42");*) + (* >> '#' is incompatible with 'u' *) test (sprintf "%4u" 42 = " 42"); test (sprintf "%*u" 4 42 = " 42"); - test (sprintf "%-0+ #6d" 42 = "+42 "); + (*test (sprintf "%-0+ #6d" 42 = "+42 ");*) + (* >> '-' is incompatible with '0', '#' is incompatible with 'd' *) printf "\nu negative\n%!"; begin match Sys.word_size with @@ -67,12 +75,15 @@ try test (sprintf "%x" 42 = "2a"); test (sprintf "%-4x" 42 = "2a "); test (sprintf "%04x" 42 = "002a"); - test (sprintf "%+x" 42 = "2a"); - test (sprintf "% x" 42 = "2a"); + (*test (sprintf "%+x" 42 = "2a");*) + (* >> '+' is incompatible with 'x' *) + (*test (sprintf "% x" 42 = "2a");*) + (* >> ' ' is incompatible with 'x' *) test (sprintf "%#x" 42 = "0x2a"); test (sprintf "%4x" 42 = " 2a"); test (sprintf "%*x" 5 42 = " 2a"); - test (sprintf "%-0+ #*x" 5 42 = "0x2a "); + (*test (sprintf "%-0+ #*x" 5 42 = "0x2a ");*) + (* >> '-' is incompatible with '0' *) printf "\nx negative\n%!"; begin match Sys.word_size with @@ -87,12 +98,15 @@ try test (sprintf "%X" 42 = "2A"); test (sprintf "%-4X" 42 = "2A "); test (sprintf "%04X" 42 = "002A"); - test (sprintf "%+X" 42 = "2A"); - test (sprintf "% X" 42 = "2A"); + (*test (sprintf "%+X" 42 = "2A");*) + (* >> '+' is incompatible with 'X' *) + (*test (sprintf "% X" 42 = "2A");*) + (* >> ' ' is incompatible with 'X' *) test (sprintf "%#X" 42 = "0X2A"); test (sprintf "%4X" 42 = " 2A"); test (sprintf "%*X" 5 42 = " 2A"); - test (sprintf "%-0+ #*X" 5 42 = "0X2A "); + (*test (sprintf "%-0+ #*X" 5 42 = "0X2A ");*) + (* >> '-' is incompatible with '0' *) printf "\nx negative\n%!"; begin match Sys.word_size with @@ -107,12 +121,15 @@ try test (sprintf "%o" 42 = "52"); test (sprintf "%-4o" 42 = "52 "); test (sprintf "%04o" 42 = "0052"); - test (sprintf "%+o" 42 = "52"); - test (sprintf "% o" 42 = "52"); + (*test (sprintf "%+o" 42 = "52");*) + (* >> '+' is incompatible with 'o' *) + (*test (sprintf "% o" 42 = "52");*) + (* >> '+' is incompatible with 'o' *) test (sprintf "%#o" 42 = "052"); test (sprintf "%4o" 42 = " 52"); test (sprintf "%*o" 5 42 = " 52"); - test (sprintf "%-0+ #*o" 5 42 = "052 "); + (*test (sprintf "%-0+ #*o" 5 42 = "052 ");*) + (* >> '-' is incompatible with 'o' *) printf "\no negative\n%!"; begin match Sys.word_size with @@ -126,15 +143,20 @@ try printf "\ns\n%!"; test (sprintf "%s" "foo" = "foo"); test (sprintf "%-5s" "foo" = "foo "); - test (sprintf "%05s" "foo" = " foo"); - test (sprintf "%+s" "foo" = "foo"); - test (sprintf "% s" "foo" = "foo"); - test (sprintf "%#s" "foo" = "foo"); + (*test (sprintf "%05s" "foo" = " foo");*) + (* >> '0' is incompatible with 's' *) + (*test (sprintf "%+s" "foo" = "foo");*) + (* >> '+' is incompatible with 's' *) + (*test (sprintf "% s" "foo" = "foo");*) + (* >> ' ' is incompatible with 's' *) + (*test (sprintf "%#s" "foo" = "foo");*) + (* >> '#' is incompatible with 's' *) test (sprintf "%5s" "foo" = " foo"); test (sprintf "%1s" "foo" = "foo"); test (sprintf "%*s" 6 "foo" = " foo"); test (sprintf "%*s" 2 "foo" = "foo"); - test (sprintf "%-0+ #5s" "foo" = "foo "); + (*test (sprintf "%-0+ #5s" "foo" = "foo ");*) + (* >> '-' is incompatible with '0', '#' is incompatible with 's' *) test (sprintf "%s@" "foo" = "foo@"); test (sprintf "%s@inria.fr" "foo" = "foo@inria.fr"); test (sprintf "%s@%s" "foo" "inria.fr" = "foo@inria.fr"); @@ -143,9 +165,12 @@ try test (sprintf "%S" "fo\"o" = "\"fo\\\"o\""); (* test (sprintf "%-5S" "foo" = "\"foo\" "); padding not done *) (* test (sprintf "%05S" "foo" = " \"foo\""); padding not done *) - test (sprintf "%+S" "foo" = "\"foo\""); - test (sprintf "% S" "foo" = "\"foo\""); - test (sprintf "%#S" "foo" = "\"foo\""); + (*test (sprintf "%+S" "foo" = "\"foo\"");*) + (* >> '#' is incompatible with 'S' *) + (*test (sprintf "% S" "foo" = "\"foo\"");*) + (* >> '#' is incompatible with 'S' *) + (*test (sprintf "%#S" "foo" = "\"foo\"");*) + (* >> '#' is incompatible with 'S' *) (* test (sprintf "%5S" "foo" = " \"foo\""); padding not done *) test (sprintf "%1S" "foo" = "\"foo\""); (* test (sprintf "%*S" 6 "foo" = " \"foo\""); padding not done *) @@ -159,9 +184,12 @@ try test (sprintf "%c" 'c' = "c"); (* test (sprintf "%-4c" 'c' = "c "); padding not done *) (* test (sprintf "%04c" 'c' = " c"); padding not done *) - test (sprintf "%+c" 'c' = "c"); - test (sprintf "% c" 'c' = "c"); - test (sprintf "%#c" 'c' = "c"); + (*test (sprintf "%+c" 'c' = "c");*) + (* >> '#' is incompatible with 'c' *) + (*test (sprintf "% c" 'c' = "c");*) + (* >> '#' is incompatible with 'c' *) + (*test (sprintf "%#c" 'c' = "c");*) + (* >> '#' is incompatible with 'c' *) (* test (sprintf "%4c" 'c' = " c"); padding not done *) (* test (sprintf "%*c" 2 'c' = " c"); padding not done *) (* test (sprintf "%-0+ #4c" 'c' = "c "); padding not done *) @@ -171,12 +199,15 @@ try test (sprintf "%C" '\'' = "'\\''"); (* test (sprintf "%-4C" 'c' = "c "); padding not done *) (* test (sprintf "%04C" 'c' = " c"); padding not done *) - test (sprintf "%+C" 'c' = "'c'"); - test (sprintf "% C" 'c' = "'c'"); - test (sprintf "%#C" 'c' = "'c'"); -(* test (sprintf "%4C" 'c' = " 'c'"); padding not done *) -(* test (sprintf "%*C" 2 'c' = "'c'"); padding not done *) -(* test (sprintf "%-0+ #4C" 'c' = "'c' "); padding not done *) + (*test (sprintf "%+C" 'c' = "'c'");*) + (* >> '+' is incompatible with 'C' *) + (*test (sprintf "% C" 'c' = "'c'");*) + (* >> ' ' is incompatible with 'C' *) + (*test (sprintf "%#C" 'c' = "'c'");*) + (* >> '#' is incompatible with 'C' *) +(* test (sprintf "%4C" 'c' = " c"); padding not done *) +(* test (sprintf "%*C" 2 'c' = " c"); padding not done *) +(* test (sprintf "%-0+ #4C" 'c' = "c "); padding not done *) printf "\nf\n%!"; test (sprintf "%f" (-42.42) = "-42.420000"); @@ -184,19 +215,23 @@ try test (sprintf "%013f" (-42.42) = "-00042.420000"); test (sprintf "%+f" 42.42 = "+42.420000"); test (sprintf "% f" 42.42 = " 42.420000"); - test (sprintf "%#f" 42.42 = "42.420000"); + (*test (sprintf "%#f" 42.42 = "42.420000");*) + (* >> '#' is incompatible with 'f' *) test (sprintf "%13f" 42.42 = " 42.420000"); test (sprintf "%*f" 12 42.42 = " 42.420000"); - test (sprintf "%-0+ #12f" 42.42 = "+42.420000 "); + (*test (sprintf "%-0+ #12f" 42.42 = "+42.420000 ");*) + (* >> '-' is incompatible with '0', '#' is incompatible with 'f' *) test (sprintf "%.3f" (-42.42) = "-42.420"); test (sprintf "%-13.3f" (-42.42) = "-42.420 "); test (sprintf "%013.3f" (-42.42) = "-00000042.420"); test (sprintf "%+.3f" 42.42 = "+42.420"); test (sprintf "% .3f" 42.42 = " 42.420"); - test (sprintf "%#.3f" 42.42 = "42.420"); + (*test (sprintf "%#.3f" 42.42 = "42.420");*) + (* >> '#' is incompatible with 'f' *) test (sprintf "%13.3f" 42.42 = " 42.420"); test (sprintf "%*.*f" 12 3 42.42 = " 42.420"); - test (sprintf "%-0+ #12.3f" 42.42 = "+42.420 "); + (*test (sprintf "%-0+ #12.3f" 42.42 = "+42.420 ");*) + (* >> '-' is incompatible with '0', '#' is incompatible with 'f' *) (* Under Windows (mingw and maybe also MSVC), the stdlib uses three digits for the exponent instead of the two used by Linux and BSD. @@ -240,19 +275,23 @@ try test (sprintf "%015e" (-42.42) =* "-004.242000e+01"); test (sprintf "%+e" 42.42 =* "+4.242000e+01"); test (sprintf "% e" 42.42 =* " 4.242000e+01"); - test (sprintf "%#e" 42.42 =* "4.242000e+01"); + (*test (sprintf "%#e" 42.42 =* "4.242000e+01");*) + (* >> '#' is incompatible with 'e' *) test (sprintf "%15e" 42.42 =* " 4.242000e+01"); test (sprintf "%*e" 14 42.42 =* " 4.242000e+01"); - test (sprintf "%-0+ #14e" 42.42 =* "+4.242000e+01 "); + (*test (sprintf "%-0+ #14e" 42.42 =* "+4.242000e+01 ");*) + (* >> '-' is incompatible with '0', '#' is incompatible with 'e' *) test (sprintf "%.3e" (-42.42) =* "-4.242e+01"); test (sprintf "%-15.3e" (-42.42) =* "-4.242e+01 "); test (sprintf "%015.3e" (-42.42) =* "-000004.242e+01"); test (sprintf "%+.3e" 42.42 =* "+4.242e+01"); test (sprintf "% .3e" 42.42 =* " 4.242e+01"); - test (sprintf "%#.3e" 42.42 =* "4.242e+01"); + (*test (sprintf "%#.3e" 42.42 =* "4.242e+01");*) + (* >> '#' is incompatible with 'e' *) test (sprintf "%15.3e" 42.42 =* " 4.242e+01"); test (sprintf "%*.*e" 11 3 42.42 =* " 4.242e+01"); - test (sprintf "%-0+ #14.3e" 42.42 =* "+4.242e+01 "); + (*test (sprintf "%-0+ #14.3e" 42.42 =* "+4.242e+01 ");*) + (* >> '-' is incompatible with '0', '#' is incompatible with 'e' *) printf "\nE\n%!"; test (sprintf "%E" (-42.42) =* "-4.242000E+01"); @@ -260,19 +299,23 @@ try test (sprintf "%015E" (-42.42) =* "-004.242000E+01"); test (sprintf "%+E" 42.42 =* "+4.242000E+01"); test (sprintf "% E" 42.42 =* " 4.242000E+01"); - test (sprintf "%#E" 42.42 =* "4.242000E+01"); + (*test (sprintf "%#E" 42.42 =* "4.242000E+01");*) + (* >> '#' is incompatible with 'E' *) test (sprintf "%15E" 42.42 =* " 4.242000E+01"); test (sprintf "%*E" 14 42.42 =* " 4.242000E+01"); - test (sprintf "%-0+ #14E" 42.42 =* "+4.242000E+01 "); + (*test (sprintf "%-0+ #14E" 42.42 =* "+4.242000E+01 ");*) + (* >> '#' is incompatible with 'E' *) test (sprintf "%.3E" (-42.42) =* "-4.242E+01"); test (sprintf "%-15.3E" (-42.42) =* "-4.242E+01 "); test (sprintf "%015.3E" (-42.42) =* "-000004.242E+01"); test (sprintf "%+.3E" 42.42 =* "+4.242E+01"); test (sprintf "% .3E" 42.42 =* " 4.242E+01"); - test (sprintf "%#.3E" 42.42 =* "4.242E+01"); + (*test (sprintf "%#.3E" 42.42 =* "4.242E+01");*) + (* >> '#' is incompatible with 'E' *) test (sprintf "%15.3E" 42.42 =* " 4.242E+01"); test (sprintf "%*.*E" 11 3 42.42 =* " 4.242E+01"); - test (sprintf "%-0+ #14.3E" 42.42 =* "+4.242E+01 "); + (*test (sprintf "%-0+ #14.3E" 42.42 =* "+4.242E+01 ");*) + (* >> '-' is incompatible with '0', '#' is incompatible with 'E' *) (* %g gives strange results that correspond to neither %f nor %e printf "\ng\n%!"; @@ -302,10 +345,12 @@ try test (sprintf "%04ld/%05li" 42l 43l = "0042/00043"); test (sprintf "%+ld/%+li" 42l 43l = "+42/+43"); test (sprintf "% ld/% li" 42l 43l = " 42/ 43"); - test (sprintf "%#ld/%#li" 42l 43l = "42/43"); + (*test (sprintf "%#ld/%#li" 42l 43l = "42/43");*) + (* >> '#' is incompatible with 'ld' *) test (sprintf "%4ld/%5li" 42l 43l = " 42/ 43"); test (sprintf "%*ld/%*li" 4 42l 5 43l = " 42/ 43"); - test (sprintf "%-0+#4ld/%-0 #5li" 42l 43l = "+42 / 43 "); + (*test (sprintf "%-0+#4ld/%-0 #5li" 42l 43l = "+42 / 43 ");*) + (* >> '-' is incompatible with '0', '#' is incompatible with 'ld' *) printf "\nld/li negative\n%!"; test (sprintf "%ld/%li" (-42l) (-43l) = "-42/-43"); @@ -313,21 +358,27 @@ try test (sprintf "%04ld/%05li" (-42l) (-43l) = "-042/-0043"); test (sprintf "%+ld/%+li" (-42l) (-43l) = "-42/-43"); test (sprintf "% ld/% li" (-42l) (-43l) = "-42/-43"); - test (sprintf "%#ld/%#li" (-42l) (-43l) = "-42/-43"); + (*test (sprintf "%#ld/%#li" (-42l) (-43l) = "-42/-43");*) + (* >> '#' is incompatible with 'ld' *) test (sprintf "%4ld/%5li" (-42l) (-43l) = " -42/ -43"); test (sprintf "%*ld/%*li" 4 (-42l) 5 (-43l) = " -42/ -43"); - test (sprintf "%-0+ #4ld/%-0+ #5li" (-42l) (-43l) = "-42 /-43 "); + (*test (sprintf "%-0+ #4ld/%-0+ #5li" (-42l) (-43l) = "-42 /-43 ");*) + (* >> '-' is incompatible with '0', '#' is incompatible with 'ld' *) printf "\nlu positive\n%!"; test (sprintf "%lu" 42l = "42"); test (sprintf "%-4lu" 42l = "42 "); test (sprintf "%04lu" 42l = "0042"); - test (sprintf "%+lu" 42l = "42"); - test (sprintf "% lu" 42l = "42"); - test (sprintf "%#lu" 42l = "42"); + (*test (sprintf "%+lu" 42l = "42");*) + (* >> '+' is incompatible with 'lu' *) + (*test (sprintf "% lu" 42l = "42");*) + (* >> ' ' is incompatible with 'lu' *) + (*test (sprintf "%#lu" 42l = "42");*) + (* >> '#' is incompatible with 'lu' *) test (sprintf "%4lu" 42l = " 42"); test (sprintf "%*lu" 4 42l = " 42"); - test (sprintf "%-0+ #6ld" 42l = "+42 "); + (*test (sprintf "%-0+ #6ld" 42l = "+42 ");*) + (* >> '-' is incompatible with '0', '#' is incompatible with 'ld' *) printf "\nlu negative\n%!"; test (sprintf "%lu" (-1l) = "4294967295"); @@ -336,12 +387,15 @@ try test (sprintf "%lx" 42l = "2a"); test (sprintf "%-4lx" 42l = "2a "); test (sprintf "%04lx" 42l = "002a"); - test (sprintf "%+lx" 42l = "2a"); - test (sprintf "% lx" 42l = "2a"); + (*test (sprintf "%+lx" 42l = "2a");*) + (* >> '+' is incompatible with 'lx' *) + (*test (sprintf "% lx" 42l = "2a");*) + (* >> ' ' is incompatible with 'lx' *) test (sprintf "%#lx" 42l = "0x2a"); test (sprintf "%4lx" 42l = " 2a"); test (sprintf "%*lx" 5 42l = " 2a"); - test (sprintf "%-0+ #*lx" 5 42l = "0x2a "); + (*test (sprintf "%-0+ #*lx" 5 42l = "0x2a ");*) + (* >> '-' is incompatible with '0' *) printf "\nlx negative\n%!"; test (sprintf "%lx" (-42l) = "ffffffd6"); @@ -350,12 +404,15 @@ try test (sprintf "%lX" 42l = "2A"); test (sprintf "%-4lX" 42l = "2A "); test (sprintf "%04lX" 42l = "002A"); - test (sprintf "%+lX" 42l = "2A"); - test (sprintf "% lX" 42l = "2A"); + (*test (sprintf "%+lX" 42l = "2A");*) + (* >> '+' is incompatible with 'lX' *) + (*test (sprintf "% lX" 42l = "2A");*) + (* >> ' ' is incompatible with 'lX' *) test (sprintf "%#lX" 42l = "0X2A"); test (sprintf "%4lX" 42l = " 2A"); test (sprintf "%*lX" 5 42l = " 2A"); - test (sprintf "%-0+ #*lX" 5 42l = "0X2A "); + (*test (sprintf "%-0+ #*lX" 5 42l = "0X2A ");*) + (* >> '-' is incompatible with '0' *) printf "\nlx negative\n%!"; test (sprintf "%lX" (-42l) = "FFFFFFD6"); @@ -364,12 +421,15 @@ try test (sprintf "%lo" 42l = "52"); test (sprintf "%-4lo" 42l = "52 "); test (sprintf "%04lo" 42l = "0052"); - test (sprintf "%+lo" 42l = "52"); - test (sprintf "% lo" 42l = "52"); + (*test (sprintf "%+lo" 42l = "52");*) + (* >> '+' is incompatible with 'lo' *) + (*test (sprintf "% lo" 42l = "52");*) + (* >> ' ' is incompatible with 'lo' *) test (sprintf "%#lo" 42l = "052"); test (sprintf "%4lo" 42l = " 52"); test (sprintf "%*lo" 5 42l = " 52"); - test (sprintf "%-0+ #*lo" 5 42l = "052 "); + (*test (sprintf "%-0+ #*lo" 5 42l = "052 ");*) + (* >> '-' is incompatible with '0' *) printf "\nlo negative\n%!"; test (sprintf "%lo" (-42l) = "37777777726"); @@ -381,34 +441,46 @@ try test (sprintf "%Ld/%Li" 42L 43L = "42/43"); test (sprintf "%-4Ld/%-5Li" 42L 43L = "42 /43 "); test (sprintf "%04Ld/%05Li" 42L 43L = "0042/00043"); - test (sprintf "%+Ld/%+Li" 42L 43L = "+42/+43"); - test (sprintf "% Ld/% Li" 42L 43L = " 42/ 43"); - test (sprintf "%#Ld/%#Li" 42L 43L = "42/43"); + (*test (sprintf "%+Ld/%+Li" 42L 43L = "+42/+43");*) + (* >> '+' is incompatible with 'Ld' *) + (*test (sprintf "% Ld/% Li" 42L 43L = " 42/ 43");*) + (* >> ' ' is incompatible with 'Ld' *) + (*test (sprintf "%#Ld/%#Li" 42L 43L = "42/43");*) + (* >> '#' is incompatible with 'Ld' *) test (sprintf "%4Ld/%5Li" 42L 43L = " 42/ 43"); test (sprintf "%*Ld/%*Li" 4 42L 5 43L = " 42/ 43"); - test (sprintf "%-0+#4Ld/%-0 #5Li" 42L 43L = "+42 / 43 "); + (*test (sprintf "%-0+#4Ld/%-0 #5Li" 42L 43L = "+42 / 43 ");*) + (* >> '-' is incompatible with '0' *) printf "\nLd/Li negative\n%!"; test (sprintf "%Ld/%Li" (-42L) (-43L) = "-42/-43"); test (sprintf "%-4Ld/%-5Li" (-42L) (-43L) = "-42 /-43 "); test (sprintf "%04Ld/%05Li" (-42L) (-43L) = "-042/-0043"); - test (sprintf "%+Ld/%+Li" (-42L) (-43L) = "-42/-43"); - test (sprintf "% Ld/% Li" (-42L) (-43L) = "-42/-43"); - test (sprintf "%#Ld/%#Li" (-42L) (-43L) = "-42/-43"); + (*test (sprintf "%+Ld/%+Li" (-42L) (-43L) = "-42/-43");*) + (* >> '+' is incompatible with 'Ld' *) + (*test (sprintf "% Ld/% Li" (-42L) (-43L) = "-42/-43");*) + (* >> ' ' is incompatible with 'Ld' *) + (*test (sprintf "%#Ld/%#Li" (-42L) (-43L) = "-42/-43");*) + (* >> '#' is incompatible with 'Ld' *) test (sprintf "%4Ld/%5Li" (-42L) (-43L) = " -42/ -43"); test (sprintf "%*Ld/%*Li" 4 (-42L) 5 (-43L) = " -42/ -43"); - test (sprintf "%-0+ #4Ld/%-0+ #5Li" (-42L) (-43L) = "-42 /-43 "); + (*test (sprintf "%-0+ #4Ld/%-0+ #5Li" (-42L) (-43L) = "-42 /-43 ");*) + (* >> '-' is incompatible with '0' *) printf "\nLu positive\n%!"; test (sprintf "%Lu" 42L = "42"); test (sprintf "%-4Lu" 42L = "42 "); test (sprintf "%04Lu" 42L = "0042"); - test (sprintf "%+Lu" 42L = "42"); - test (sprintf "% Lu" 42L = "42"); - test (sprintf "%#Lu" 42L = "42"); + (*test (sprintf "%+Lu" 42L = "42");*) + (* >> '+' is incompatible with 'Lu' *) + (*test (sprintf "% Lu" 42L = "42");*) + (* >> ' ' is incompatible with 'Lu' *) + (*test (sprintf "%#Lu" 42L = "42");*) + (* >> '#' is incompatible with 'Lu' *) test (sprintf "%4Lu" 42L = " 42"); test (sprintf "%*Lu" 4 42L = " 42"); - test (sprintf "%-0+ #6Ld" 42L = "+42 "); + (*test (sprintf "%-0+ #6Ld" 42L = "+42 ");*) + (* >> '-' is incompatible with '0' *) printf "\nLu negative\n%!"; test (sprintf "%Lu" (-1L) = "18446744073709551615"); @@ -417,12 +489,15 @@ try test (sprintf "%Lx" 42L = "2a"); test (sprintf "%-4Lx" 42L = "2a "); test (sprintf "%04Lx" 42L = "002a"); - test (sprintf "%+Lx" 42L = "2a"); - test (sprintf "% Lx" 42L = "2a"); + (*test (sprintf "%+Lx" 42L = "2a");*) + (* >> '+' is incompatible with 'Lx' *) + (*test (sprintf "% Lx" 42L = "2a");*) + (* >> ' ' is incompatible with 'Lx' *) test (sprintf "%#Lx" 42L = "0x2a"); test (sprintf "%4Lx" 42L = " 2a"); test (sprintf "%*Lx" 5 42L = " 2a"); - test (sprintf "%-0+ #*Lx" 5 42L = "0x2a "); + (*test (sprintf "%-0+ #*Lx" 5 42L = "0x2a ");*) + (* >> '-' is incompatible with '0' *) printf "\nLx negative\n%!"; test (sprintf "%Lx" (-42L) = "ffffffffffffffd6"); @@ -431,12 +506,15 @@ try test (sprintf "%LX" 42L = "2A"); test (sprintf "%-4LX" 42L = "2A "); test (sprintf "%04LX" 42L = "002A"); - test (sprintf "%+LX" 42L = "2A"); - test (sprintf "% LX" 42L = "2A"); + (*test (sprintf "%+LX" 42L = "2A");*) + (* >> '+' is incompatible with 'LX' *) + (*test (sprintf "% LX" 42L = "2A");*) + (* >> ' ' is incompatible with 'LX' *) test (sprintf "%#LX" 42L = "0X2A"); test (sprintf "%4LX" 42L = " 2A"); test (sprintf "%*LX" 5 42L = " 2A"); - test (sprintf "%-0+ #*LX" 5 42L = "0X2A "); + (*test (sprintf "%-0+ #*LX" 5 42L = "0X2A ");*) + (* >> '-' is incompatible with '0' *) printf "\nLx negative\n%!"; test (sprintf "%LX" (-42L) = "FFFFFFFFFFFFFFD6"); @@ -445,12 +523,15 @@ try test (sprintf "%Lo" 42L = "52"); test (sprintf "%-4Lo" 42L = "52 "); test (sprintf "%04Lo" 42L = "0052"); - test (sprintf "%+Lo" 42L = "52"); - test (sprintf "% Lo" 42L = "52"); + (*test (sprintf "%+Lo" 42L = "52");*) + (* >> '+' is incompatible with 'Lo' *) + (*test (sprintf "% Lo" 42L = "52");*) + (* >> ' ' is incompatible with 'Lo' *) test (sprintf "%#Lo" 42L = "052"); test (sprintf "%4Lo" 42L = " 52"); test (sprintf "%*Lo" 5 42L = " 52"); - test (sprintf "%-0+ #*Lo" 5 42L = "052 "); + (*test (sprintf "%-0+ #*Lo" 5 42L = "052 ");*) + (* >> '-' is incompatible with '0' *) printf "\nLo negative\n%!"; test (sprintf "%Lo" (-42L) = "1777777777777777777726"); @@ -471,7 +552,7 @@ try printf "\n{...%%}\n%!"; let f = format_of_string "%4g/%s" in - test (sprintf "%{%#0F%S%}" f = "%f%s"); + test (sprintf "%{%.4F%5S%}" f = "%f%s"); printf "\n(...%%)\n%!"; let f = format_of_string "%d/foo/%s" in diff --git a/testsuite/tests/lib-printf/tprintf.reference b/testsuite/tests/lib-printf/tprintf.reference index 387dfb853..11ee3a74f 100644 --- a/testsuite/tests/lib-printf/tprintf.reference +++ b/testsuite/tests/lib-printf/tprintf.reference @@ -1,91 +1,91 @@ d/i positive - 0 1 2 3 4 5 6 7 8 + 0 1 2 3 4 5 6 d/i negative - 9 10 11 12 13 14 15 16 17 + 7 8 9 10 11 12 13 u positive - 18 19 20 21 22 23 24 25 26 + 14 15 16 17 18 u negative - 27 + 19 x positive - 28 29 30 31 32 33 34 35 36 + 20 21 22 23 24 25 x negative - 37 + 26 X positive - 38 39 40 41 42 43 44 45 46 + 27 28 29 30 31 32 x negative - 47 + 33 o positive - 48 49 50 51 52 53 54 55 56 + 34 35 36 37 38 39 o negative - 57 + 40 s - 58 59 60 61 62 63 64 65 66 67 68 69 70 71 + 41 42 43 44 45 46 47 48 49 S - 72 73 74 75 76 77 78 79 80 + 50 51 52 53 54 55 c - 81 82 83 84 + 56 C - 85 86 87 88 89 + 57 58 f - 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 + 59 60 61 62 63 64 65 66 67 68 69 70 71 72 F - 108 109 110 111 + 73 74 75 76 e - 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 + 77 78 79 80 81 82 83 84 85 86 87 88 89 90 E - 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 + 91 92 93 94 95 96 97 98 99 100 101 102 103 104 B - 148 149 + 105 106 ld/li positive - 150 151 152 153 154 155 156 157 158 + 107 108 109 110 111 112 113 ld/li negative - 159 160 161 162 163 164 165 166 167 + 114 115 116 117 118 119 120 lu positive - 168 169 170 171 172 173 174 175 176 + 121 122 123 124 125 lu negative - 177 + 126 lx positive - 178 179 180 181 182 183 184 185 186 + 127 128 129 130 131 132 lx negative - 187 + 133 lX positive - 188 189 190 191 192 193 194 195 196 + 134 135 136 137 138 139 lx negative - 197 + 140 lo positive - 198 199 200 201 202 203 204 205 206 + 141 142 143 144 145 146 lo negative - 207 + 147 Ld/Li positive - 208 209 210 211 212 213 214 215 216 + 148 149 150 151 152 Ld/Li negative - 217 218 219 220 221 222 223 224 225 + 153 154 155 156 157 Lu positive - 226 227 228 229 230 231 232 233 234 + 158 159 160 161 162 Lu negative - 235 + 163 Lx positive - 236 237 238 239 240 241 242 243 244 + 164 165 166 167 168 169 Lx negative - 245 + 170 LX positive - 246 247 248 249 250 251 252 253 254 + 171 172 173 174 175 176 Lx negative - 255 + 177 Lo positive - 256 257 258 259 260 261 262 263 264 + 178 179 180 181 182 183 Lo negative - 265 + 184 a - 266 + 185 t - 267 + 186 {...%} - 268 + 187 (...%) - 269 + 188 ! % @ , and constants - 270 271 272 273 274 275 276 + 189 190 191 192 193 194 195 end of tests All tests succeeded. diff --git a/testsuite/tests/lib-scanf/tscanf.ml b/testsuite/tests/lib-scanf/tscanf.ml index 53c92ffc8..8e6a252b8 100644 --- a/testsuite/tests/lib-scanf/tscanf.ml +++ b/testsuite/tests/lib-scanf/tscanf.ml @@ -1090,13 +1090,13 @@ let test46, test47 = Printf.sprintf "%i %(%s%)." 1 "spells one, %s" "in english"), (fun () -> - Printf.sprintf "%i ,%{%s%}, %s." + Printf.sprintf "%i %{%s%}, %s." 1 "spells one %s" "in english") ;; test (test46 () = "1 spells one, in english.") ;; -test (test47 () = "1 ,%s, in english.") +test (test47 () = "1 %s, in english.") ;; (* Testing scanning of meta formats. *) diff --git a/testsuite/tests/lib-set/testset.ml b/testsuite/tests/lib-set/testset.ml index 4f6626c11..3e55942a4 100644 --- a/testsuite/tests/lib-set/testset.ml +++ b/testsuite/tests/lib-set/testset.ml @@ -58,7 +58,8 @@ let test x s1 s2 = (S.elements s1 = List.filter (fun i -> S.mem i s1) testvals); checkbool "compare" - (normalize_cmp (S.compare s1 s2) = normalize_cmp (compare (S.elements s1) (S.elements s2))); + (normalize_cmp (S.compare s1 s2) + = normalize_cmp (compare (S.elements s1) (S.elements s2))); checkbool "equal" (S.equal s1 s2 = (S.elements s1 = S.elements s2)); diff --git a/testsuite/tests/lib-systhreads/testfork.precheck b/testsuite/tests/lib-systhreads/testfork.precheck index af81e807f..f93abf1a6 100644 --- a/testsuite/tests/lib-systhreads/testfork.precheck +++ b/testsuite/tests/lib-systhreads/testfork.precheck @@ -14,4 +14,3 @@ case `sed -n -e '/OTHERLIBRARIES=/s// /p' ../../../config/Makefile` in *' unix '*) exit 0;; *) exit 3;; esac - diff --git a/testsuite/tests/lib-threads/test1.ml b/testsuite/tests/lib-threads/test1.ml index 8961b6f85..c551fbc5d 100644 --- a/testsuite/tests/lib-threads/test1.ml +++ b/testsuite/tests/lib-threads/test1.ml @@ -21,7 +21,7 @@ type 'a prodcons = notfull: Condition.t } let create size init = - { buffer = Array.create size init; + { buffer = Array.make size init; lock = Mutex.create(); readpos = 0; writepos = 0; diff --git a/testsuite/tests/lib-threads/test7.checker b/testsuite/tests/lib-threads/test7.checker index 55396e138..4c4b2b4d6 100644 --- a/testsuite/tests/lib-threads/test7.checker +++ b/testsuite/tests/lib-threads/test7.checker @@ -10,4 +10,5 @@ # # ######################################################################### -test `grep -E '^-?[0123456789]+$' test7.result | wc -l` = `cat test7.result | wc -l` +test `grep -E '^-?[0123456789]+$' test7.result | wc -l` \ + = `cat test7.result | wc -l` diff --git a/testsuite/tests/lib-threads/testA.ml b/testsuite/tests/lib-threads/testA.ml index bdd33c345..30efd6d39 100644 --- a/testsuite/tests/lib-threads/testA.ml +++ b/testsuite/tests/lib-threads/testA.ml @@ -26,8 +26,8 @@ let process id data = set_private_data data; Mutex.lock output_lock; print_int id; print_string " --> "; print_string(get_private_data()); - Mutex.unlock output_lock; - print_newline() + print_newline(); + Mutex.unlock output_lock let _ = let t1 = Thread.create (process 1) "un" in diff --git a/testsuite/tests/lib-threads/testsocket.ml b/testsuite/tests/lib-threads/testsocket.ml index ec16c058c..6b2b0b049 100644 --- a/testsuite/tests/lib-threads/testsocket.ml +++ b/testsuite/tests/lib-threads/testsocket.ml @@ -20,7 +20,9 @@ let engine verbose number address = try while true do let s = input_line ic in - if verbose then (print_int number; print_string ">"; print_string s; print_newline()) + if verbose then begin + print_int number; print_string ">"; print_string s; print_newline() + end done; with End_of_file -> close_out oc; @@ -31,11 +33,11 @@ let main() = match Sys.argv with | [| _ |] -> false, [| Sys.argv.(0); "caml.inria.fr" |] | _ -> true, Sys.argv in - let addresses = Array.create (Array.length argv - 1) inet_addr_any in + let addresses = Array.make (Array.length argv - 1) inet_addr_any in for i = 1 to Array.length argv - 1 do addresses.(i - 1) <- (gethostbyname argv.(i)).h_addr_list.(0) done; - let processes = Array.create (Array.length addresses) (Thread.self()) in + let processes = Array.make (Array.length addresses) (Thread.self()) in for i = 0 to Array.length addresses - 1 do processes.(i) <- Thread.create (engine verbose i) addresses.(i) done; diff --git a/testsuite/tests/lib-threads/testsocket.precheck b/testsuite/tests/lib-threads/testsocket.precheck index 15ae35c52..6d41158ef 100644 --- a/testsuite/tests/lib-threads/testsocket.precheck +++ b/testsuite/tests/lib-threads/testsocket.precheck @@ -20,4 +20,4 @@ # disable this test on Windows non-cygwin ports until we decide # how to fix PR#5325 and PR#5578 -$CANKILL
\ No newline at end of file +$CANKILL diff --git a/testsuite/tests/lib-threads/token1.ml b/testsuite/tests/lib-threads/token1.ml index d6e7a1b7a..d0a7528b0 100644 --- a/testsuite/tests/lib-threads/token1.ml +++ b/testsuite/tests/lib-threads/token1.ml @@ -39,7 +39,7 @@ let process (n, conds, nprocs) = let main() = let nprocs = try int_of_string Sys.argv.(1) with _ -> 100 in let iter = try int_of_string Sys.argv.(2) with _ -> 1000 in - let conds = Array.create nprocs (Condition.create()) in + let conds = Array.make nprocs (Condition.create()) in for i = 1 to nprocs - 1 do conds.(i) <- Condition.create() done; niter := iter; for i = 0 to nprocs - 1 do Thread.create process (i, conds, nprocs) done; diff --git a/testsuite/tests/lib-threads/token2.ml b/testsuite/tests/lib-threads/token2.ml index 9ef05806e..c3548fb0f 100644 --- a/testsuite/tests/lib-threads/token2.ml +++ b/testsuite/tests/lib-threads/token2.ml @@ -35,9 +35,9 @@ let process (n, ins, outs, nprocs) = let main() = let nprocs = try int_of_string Sys.argv.(1) with _ -> 100 in let iter = try int_of_string Sys.argv.(2) with _ -> 1000 in - let ins = Array.create nprocs Unix.stdin in - let outs = Array.create nprocs Unix.stdout in - let threads = Array.create nprocs (Thread.self ()) in + let ins = Array.make nprocs Unix.stdin in + let outs = Array.make nprocs Unix.stdout in + let threads = Array.make nprocs (Thread.self ()) in for n = 0 to nprocs - 1 do let (i, o) = Unix.pipe() in ins.(n) <- i; outs.(n) <- o done; diff --git a/testsuite/tests/match-exception-warnings/Makefile b/testsuite/tests/match-exception-warnings/Makefile new file mode 100644 index 000000000..c9433b2ec --- /dev/null +++ b/testsuite/tests/match-exception-warnings/Makefile @@ -0,0 +1,15 @@ +######################################################################### +# # +# OCaml # +# # +# Xavier Clerc, SED, INRIA Rocquencourt # +# # +# Copyright 2010 Institut National de Recherche en Informatique et # +# en Automatique. All rights reserved. This file is distributed # +# under the terms of the Q Public License version 1.0. # +# # +######################################################################### + +BASEDIR=../.. +include $(BASEDIR)/makefiles/Makefile.toplevel +include $(BASEDIR)/makefiles/Makefile.common diff --git a/testsuite/tests/match-exception-warnings/exhaustiveness_warnings.ml b/testsuite/tests/match-exception-warnings/exhaustiveness_warnings.ml new file mode 100644 index 000000000..742038db4 --- /dev/null +++ b/testsuite/tests/match-exception-warnings/exhaustiveness_warnings.ml @@ -0,0 +1,12 @@ +(** Test exhaustiveness. + + match clauses should continue to give warnings about inexhaustive + value-matching clauses when there is an exception-matching clause + *) + +let test_match_exhaustiveness () = + match None with + | exception e -> () + | Some false -> () + | None -> () +;; diff --git a/testsuite/tests/match-exception-warnings/exhaustiveness_warnings.ml.reference b/testsuite/tests/match-exception-warnings/exhaustiveness_warnings.ml.reference new file mode 100644 index 000000000..f1e30bc56 --- /dev/null +++ b/testsuite/tests/match-exception-warnings/exhaustiveness_warnings.ml.reference @@ -0,0 +1,11 @@ + +# * * * * Characters 210-289: + ....match None with + | exception e -> () + | Some false -> () + | None -> () +Warning 8: this pattern-matching is not exhaustive. +Here is an example of a value that is not matched: +Some true +val test_match_exhaustiveness : unit -> unit = <fun> +# diff --git a/testsuite/tests/match-exception/Makefile b/testsuite/tests/match-exception/Makefile new file mode 100644 index 000000000..299656b24 --- /dev/null +++ b/testsuite/tests/match-exception/Makefile @@ -0,0 +1,15 @@ +######################################################################### +# # +# OCaml # +# # +# Xavier Clerc, SED, INRIA Rocquencourt # +# # +# Copyright 2010 Institut National de Recherche en Informatique et # +# en Automatique. All rights reserved. This file is distributed # +# under the terms of the Q Public License version 1.0. # +# # +######################################################################### + +BASEDIR=../.. +include $(BASEDIR)/makefiles/Makefile.several +include $(BASEDIR)/makefiles/Makefile.common diff --git a/testsuite/tests/match-exception/allocation.ml b/testsuite/tests/match-exception/allocation.ml new file mode 100644 index 000000000..fa943ffa3 --- /dev/null +++ b/testsuite/tests/match-exception/allocation.ml @@ -0,0 +1,24 @@ +(** Test that matching multiple values doesn't allocate a block. *) + +let f x y = + match x, y with + | Some x, None + | None, Some x -> x + 1 + | None, None -> 0 + | Some x, Some y -> x + y + | exception _ -> -1 + +let test_multiple_match_does_not_allocate = + let allocated_bytes = Gc.allocated_bytes () in + let allocated_bytes' = Gc.allocated_bytes () in + let a = Some 3 and b = None in + let allocated_bytes'' = Gc.allocated_bytes () in + let _ = f a b in + let allocated_bytes''' = Gc.allocated_bytes () in + if allocated_bytes' -. allocated_bytes = allocated_bytes''' -. allocated_bytes'' + then + Printf.printf "no allocations for multiple-value match\n" + else + Printf.printf "multiple-value match allocated %f bytes\n" + ((allocated_bytes''' -. allocated_bytes'') -. + (allocated_bytes' -. allocated_bytes)) diff --git a/testsuite/tests/match-exception/allocation.reference b/testsuite/tests/match-exception/allocation.reference new file mode 100644 index 000000000..98056ce6e --- /dev/null +++ b/testsuite/tests/match-exception/allocation.reference @@ -0,0 +1 @@ +no allocations for multiple-value match diff --git a/testsuite/tests/match-exception/exception_propagation.ml b/testsuite/tests/match-exception/exception_propagation.ml new file mode 100644 index 000000000..38d2cfd68 --- /dev/null +++ b/testsuite/tests/match-exception/exception_propagation.ml @@ -0,0 +1,17 @@ +(** + Test that match allows exceptions to propagate. +*) +let () = + try + match + (let _ = raise Not_found in + assert false) + with + | _ -> assert false + | exception Invalid_argument _ -> assert false + with + Not_found -> + print_endline "caught expected exception (Not_found)" + | _ -> + assert false +;; diff --git a/testsuite/tests/match-exception/exception_propagation.reference b/testsuite/tests/match-exception/exception_propagation.reference new file mode 100644 index 000000000..a119b6813 --- /dev/null +++ b/testsuite/tests/match-exception/exception_propagation.reference @@ -0,0 +1 @@ +caught expected exception (Not_found) diff --git a/testsuite/tests/match-exception/match_failure.ml b/testsuite/tests/match-exception/match_failure.ml new file mode 100644 index 000000000..c6149bf3b --- /dev/null +++ b/testsuite/tests/match-exception/match_failure.ml @@ -0,0 +1,19 @@ +(** + Test that value match failure in a match block raises Match_failure. +*) +let return_some_3 () = Some (1 + 2) +;; + +let test_match_partial_match = + try + let _ = (match return_some_3 () with + | Some x when x < 3 -> "Some x" + | exception Failure _ -> "failure" + | exception Invalid_argument _ -> "invalid argument" + | None -> "None" + ) in + assert false + with + Match_failure _ -> + print_endline "match failure, as expected" +;; diff --git a/testsuite/tests/match-exception/match_failure.reference b/testsuite/tests/match-exception/match_failure.reference new file mode 100644 index 000000000..6e17840fe --- /dev/null +++ b/testsuite/tests/match-exception/match_failure.reference @@ -0,0 +1 @@ +match failure, as expected diff --git a/testsuite/tests/match-exception/nested_handlers.ml b/testsuite/tests/match-exception/nested_handlers.ml new file mode 100644 index 000000000..0314cb103 --- /dev/null +++ b/testsuite/tests/match-exception/nested_handlers.ml @@ -0,0 +1,45 @@ +(* + Test that multiple handlers coexist happily. +*) + +let test_multiple_handlers = + let trace = ref [] in + let collect v = trace := v :: !trace in + let _ = + match + begin + match + begin + collect "one"; + failwith "two" + end + with + () -> collect "failure one" + | exception (Failure x) -> + collect x; + failwith "three" + end + with + () -> + collect "failure two"; + | exception (Failure x) -> + collect x; + match + begin + collect "four"; + failwith "five" + end + with + () -> collect "failure three" + | exception (Failure x) -> + collect x + in + print_endline (String.concat " " !trace); + assert (!trace = [ + "five"; + "four"; + "three"; + "two"; + "one"; + ]) +;; diff --git a/testsuite/tests/match-exception/nested_handlers.reference b/testsuite/tests/match-exception/nested_handlers.reference new file mode 100644 index 000000000..e30528669 --- /dev/null +++ b/testsuite/tests/match-exception/nested_handlers.reference @@ -0,0 +1 @@ +five four three two one diff --git a/testsuite/tests/match-exception/raise_from_success_continuation.ml b/testsuite/tests/match-exception/raise_from_success_continuation.ml new file mode 100644 index 000000000..34fb64714 --- /dev/null +++ b/testsuite/tests/match-exception/raise_from_success_continuation.ml @@ -0,0 +1,15 @@ +(** + Test raising exceptions from a value-matching branch. +*) +let test_raise_from_val_handler = + let () = print_endline "test raise from val handler" in + let g () = List.find ((=)2) [1;2;4] in + let h () = + match + g () + with exception _ -> 10 + | _ -> raise Not_found + in + assert ((try h () with Not_found -> 20) = 20); + print_endline "raise from val handler succeeded" +;; diff --git a/testsuite/tests/match-exception/raise_from_success_continuation.reference b/testsuite/tests/match-exception/raise_from_success_continuation.reference new file mode 100644 index 000000000..4cfe21608 --- /dev/null +++ b/testsuite/tests/match-exception/raise_from_success_continuation.reference @@ -0,0 +1,2 @@ +test raise from val handler +raise from val handler succeeded diff --git a/testsuite/tests/match-exception/streams.ml b/testsuite/tests/match-exception/streams.ml new file mode 100644 index 000000000..42e9a5f1d --- /dev/null +++ b/testsuite/tests/match-exception/streams.ml @@ -0,0 +1,37 @@ +(** + Test the stream example . +*) +type stream = Stream of (int * stream Lazy.t) +;; + +exception End_of_stream +;; + +let make_stream_up_to n = + let rec loop i = + if i = n then Stream (i, lazy (raise End_of_stream)) + else Stream (i, lazy (loop (i + 1))) + in loop 0 +;; + +let stream_get (Stream (x, s)) = (x, Lazy.force s) +;; + +let rec iter_stream_match f s = + match stream_get s + with exception End_of_stream -> () + | (x, s') -> + begin + f x; + iter_stream_match f s' + end +;; + +let test_iter_stream = + let limit = 10000000 in + try + iter_stream_match ignore (make_stream_up_to limit); + print_endline "iter_stream with handler case (match) is tail recursive" + with Stack_overflow -> + assert false +;; diff --git a/testsuite/tests/match-exception/streams.reference b/testsuite/tests/match-exception/streams.reference new file mode 100644 index 000000000..13df46408 --- /dev/null +++ b/testsuite/tests/match-exception/streams.reference @@ -0,0 +1 @@ +iter_stream with handler case (match) is tail recursive diff --git a/testsuite/tests/match-exception/tail_calls.ml b/testsuite/tests/match-exception/tail_calls.ml new file mode 100644 index 000000000..61cf02664 --- /dev/null +++ b/testsuite/tests/match-exception/tail_calls.ml @@ -0,0 +1,21 @@ +(** + The success continuation expression is in tail position. +*) + +let count_to_tr_match n = + let rec loop i = + match + i < n + with exception Not_found -> () + | false -> () + | true -> loop (i + 1) + in loop 0 +;; + +let test_tail_recursion = + try + count_to_tr_match 10000000; + print_endline "handler-case (match) is tail recursive" + with _ -> + assert false +;; diff --git a/testsuite/tests/match-exception/tail_calls.reference b/testsuite/tests/match-exception/tail_calls.reference new file mode 100644 index 000000000..342bf24a2 --- /dev/null +++ b/testsuite/tests/match-exception/tail_calls.reference @@ -0,0 +1 @@ +handler-case (match) is tail recursive diff --git a/testsuite/tests/misc-kb/kb.mli b/testsuite/tests/misc-kb/kb.mli index c0578e56f..246bc8198 100644 --- a/testsuite/tests/misc-kb/kb.mli +++ b/testsuite/tests/misc-kb/kb.mli @@ -23,5 +23,7 @@ val deletion_message: rule -> unit val non_orientable: term * term -> unit val partition: ('a -> bool) -> 'a list -> 'a list * 'a list val get_rule: int -> rule list -> rule -val kb_completion: (term * term -> bool) -> int -> rule list -> (term * term) list -> int * int -> (term * term) list -> rule list +val kb_completion: + (term * term -> bool) -> int -> rule list -> (term * term) list + -> int * int -> (term * term) list -> rule list val kb_complete: (term * term -> bool) -> rule list -> rule list -> unit diff --git a/testsuite/tests/misc-unsafe/fft.ml b/testsuite/tests/misc-unsafe/fft.ml index 2c1cf38b0..7e2442b0b 100644 --- a/testsuite/tests/misc-unsafe/fft.ml +++ b/testsuite/tests/misc-unsafe/fft.ml @@ -135,8 +135,8 @@ let test np = print_int np; print_string "... "; flush stdout; let enp = float np in let npm = np / 2 - 1 in - let pxr = Array.create (np+2) 0.0 - and pxi = Array.create (np+2) 0.0 in + let pxr = Array.make (np+2) 0.0 + and pxi = Array.make (np+2) 0.0 in let t = pi /. enp in pxr.(1) <- (enp -. 1.0) *. 0.5; pxi.(1) <- 0.0; diff --git a/testsuite/tests/misc-unsafe/quicksort.ml b/testsuite/tests/misc-unsafe/quicksort.ml index 4f872fd24..8879d9529 100644 --- a/testsuite/tests/misc-unsafe/quicksort.ml +++ b/testsuite/tests/misc-unsafe/quicksort.ml @@ -63,8 +63,8 @@ let random() = exception Failed let test_sort sort_fun size = - let a = Array.create size 0 in - let check = Array.create 4096 0 in + let a = Array.make size 0 in + let check = Array.make 4096 0 in for i = 0 to size-1 do let n = random() in a.(i) <- n; check.(n) <- check.(n)+1 done; diff --git a/testsuite/tests/misc/bdd.ml b/testsuite/tests/misc/bdd.ml index 954edc164..297eb68e4 100644 --- a/testsuite/tests/misc/bdd.ml +++ b/testsuite/tests/misc/bdd.ml @@ -31,14 +31,14 @@ let getId bdd = let initSize_1 = 8*1024 - 1 let nodeC = ref 1 let sz_1 = ref initSize_1 -let htab = ref(Array.create (!sz_1+1) []) +let htab = ref(Array.make (!sz_1+1) []) let n_items = ref 0 let hashVal x y v = x lsl 1 + y + v lsl 2 let resize newSize = let arr = !htab in let newSz_1 = newSize-1 in - let newArr = Array.create newSize [] in + let newArr = Array.make newSize [] in let rec copyBucket bucket = match bucket with [] -> () @@ -71,7 +71,7 @@ let rec insert idl idh v ind bucket newNode = let resetUnique () = ( sz_1 := initSize_1; - htab := Array.create (!sz_1+1) []; + htab := Array.make (!sz_1+1) []; n_items := 0; nodeC := 1 ) @@ -111,14 +111,14 @@ let mkVar x = mkNode zero x one let cacheSize = 1999 -let andslot1 = Array.create cacheSize 0 -let andslot2 = Array.create cacheSize 0 -let andslot3 = Array.create cacheSize zero -let xorslot1 = Array.create cacheSize 0 -let xorslot2 = Array.create cacheSize 0 -let xorslot3 = Array.create cacheSize zero -let notslot1 = Array.create cacheSize 0 -let notslot2 = Array.create cacheSize one +let andslot1 = Array.make cacheSize 0 +let andslot2 = Array.make cacheSize 0 +let andslot3 = Array.make cacheSize zero +let xorslot1 = Array.make cacheSize 0 +let xorslot2 = Array.make cacheSize 0 +let xorslot3 = Array.make cacheSize zero +let notslot1 = Array.make cacheSize 0 +let notslot2 = Array.make cacheSize one let hash x y = ((x lsl 1)+y) mod cacheSize let rec not n = @@ -196,7 +196,7 @@ let random() = seed := !seed * 25173 + 17431; !seed land 1 > 0 let random_vars n = - let vars = Array.create n false in + let vars = Array.make n false in for i = 0 to n - 1 do vars.(i) <- random() done; vars diff --git a/testsuite/tests/prim-bigstring/Makefile b/testsuite/tests/prim-bigstring/Makefile new file mode 100644 index 000000000..379dba99c --- /dev/null +++ b/testsuite/tests/prim-bigstring/Makefile @@ -0,0 +1,8 @@ +BASEDIR=../.. +LIBRARIES=unix bigarray +ADD_COMPFLAGS=-I $(OTOPDIR)/otherlibs/$(UNIXLIBVAR)unix \ + -I $(OTOPDIR)/otherlibs/bigarray +LD_PATH=$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix:$(TOPDIR)/otherlibs/bigarray + +include $(BASEDIR)/makefiles/Makefile.several +include $(BASEDIR)/makefiles/Makefile.common diff --git a/testsuite/tests/prim-bigstring/bigstring_access.ml b/testsuite/tests/prim-bigstring/bigstring_access.ml new file mode 100644 index 000000000..8fad87b15 --- /dev/null +++ b/testsuite/tests/prim-bigstring/bigstring_access.ml @@ -0,0 +1,102 @@ + +open Bigarray +type bigstring = (char, int8_unsigned_elt, c_layout) Array1.t + +external caml_bigstring_get_16 : + bigstring -> int -> int = "%caml_bigstring_get16" +external caml_bigstring_get_32 : + bigstring -> int -> int32 = "%caml_bigstring_get32" +external caml_bigstring_get_64 : + bigstring -> int -> int64 = "%caml_bigstring_get64" + +external caml_bigstring_set_16 : + bigstring -> int -> int -> unit = "%caml_bigstring_set16" +external caml_bigstring_set_32 : + bigstring -> int -> int32 -> unit = "%caml_bigstring_set32" +external caml_bigstring_set_64 : + bigstring -> int -> int64 -> unit = "%caml_bigstring_set64" + +let bigstring_of_string s = + let a = Array1.create char c_layout (String.length s) in + for i = 0 to String.length s - 1 do + a.{i} <- s.[i] + done; + a + +let s = bigstring_of_string (String.make 10 '\x00') +let empty_s = bigstring_of_string "" + +let assert_bound_check2 f v1 v2 = + try + ignore(f v1 v2); + assert false + with + | Invalid_argument("index out of bounds") -> () + +let assert_bound_check3 f v1 v2 v3 = + try + ignore(f v1 v2 v3); + assert false + with + | Invalid_argument("index out of bounds") -> () + +let () = + assert_bound_check2 caml_bigstring_get_16 s (-1); + assert_bound_check2 caml_bigstring_get_16 s 9; + assert_bound_check2 caml_bigstring_get_32 s (-1); + assert_bound_check2 caml_bigstring_get_32 s 7; + assert_bound_check2 caml_bigstring_get_64 s (-1); + assert_bound_check2 caml_bigstring_get_64 s 3; + + assert_bound_check3 caml_bigstring_set_16 s (-1) 0; + assert_bound_check3 caml_bigstring_set_16 s 9 0; + assert_bound_check3 caml_bigstring_set_32 s (-1) 0l; + assert_bound_check3 caml_bigstring_set_32 s 7 0l; + assert_bound_check3 caml_bigstring_set_64 s (-1) 0L; + assert_bound_check3 caml_bigstring_set_64 s 3 0L; + + assert_bound_check2 caml_bigstring_get_16 empty_s 0; + assert_bound_check2 caml_bigstring_get_32 empty_s 0; + assert_bound_check2 caml_bigstring_get_64 empty_s 0; + + assert_bound_check3 caml_bigstring_set_16 empty_s 0 0; + assert_bound_check3 caml_bigstring_set_32 empty_s 0 0l; + assert_bound_check3 caml_bigstring_set_64 empty_s 0 0L + + + +let () = + caml_bigstring_set_16 s 0 0x1234; + Printf.printf "%x %x %x\n%!" + (caml_bigstring_get_16 s 0) + (caml_bigstring_get_16 s 1) + (caml_bigstring_get_16 s 2); + caml_bigstring_set_16 s 0 0xFEDC; + Printf.printf "%x %x %x\n%!" + (caml_bigstring_get_16 s 0) + (caml_bigstring_get_16 s 1) + (caml_bigstring_get_16 s 2) + +let () = + caml_bigstring_set_32 s 0 0x12345678l; + Printf.printf "%lx %lx %lx\n%!" + (caml_bigstring_get_32 s 0) + (caml_bigstring_get_32 s 1) + (caml_bigstring_get_32 s 2); + caml_bigstring_set_32 s 0 0xFEDCBA09l; + Printf.printf "%lx %lx %lx\n%!" + (caml_bigstring_get_32 s 0) + (caml_bigstring_get_32 s 1) + (caml_bigstring_get_32 s 2) + +let () = + caml_bigstring_set_64 s 0 0x1234567890ABCDEFL; + Printf.printf "%Lx %Lx %Lx\n%!" + (caml_bigstring_get_64 s 0) + (caml_bigstring_get_64 s 1) + (caml_bigstring_get_64 s 2); + caml_bigstring_set_64 s 0 0xFEDCBA0987654321L; + Printf.printf "%Lx %Lx %Lx\n%!" + (caml_bigstring_get_64 s 0) + (caml_bigstring_get_64 s 1) + (caml_bigstring_get_64 s 2) diff --git a/testsuite/tests/prim-bigstring/bigstring_access.reference b/testsuite/tests/prim-bigstring/bigstring_access.reference new file mode 100644 index 000000000..22b25addf --- /dev/null +++ b/testsuite/tests/prim-bigstring/bigstring_access.reference @@ -0,0 +1,6 @@ +1234 12 0 +fedc fe 0 +12345678 123456 1234 +fedcba09 fedcba fedc +1234567890abcdef 1234567890abcd 1234567890ab +fedcba0987654321 fedcba09876543 fedcba098765 diff --git a/testsuite/tests/prim-bigstring/string_access.ml b/testsuite/tests/prim-bigstring/string_access.ml new file mode 100644 index 000000000..3afcc6c55 --- /dev/null +++ b/testsuite/tests/prim-bigstring/string_access.ml @@ -0,0 +1,89 @@ + +external caml_string_get_16 : string -> int -> int = "%caml_string_get16" +external caml_string_get_32 : string -> int -> int32 = "%caml_string_get32" +external caml_string_get_64 : string -> int -> int64 = "%caml_string_get64" + +external caml_string_set_16 : string -> int -> int -> unit = + "%caml_string_set16" +external caml_string_set_32 : string -> int -> int32 -> unit = + "%caml_string_set32" +external caml_string_set_64 : string -> int -> int64 -> unit = + "%caml_string_set64" + +let s = String.make 10 '\x00' +let empty_s = "" + +let assert_bound_check2 f v1 v2 = + try + ignore(f v1 v2); + assert false + with + | Invalid_argument("index out of bounds") -> () + +let assert_bound_check3 f v1 v2 v3 = + try + ignore(f v1 v2 v3); + assert false + with + | Invalid_argument("index out of bounds") -> () + +let () = + assert_bound_check2 caml_string_get_16 s (-1); + assert_bound_check2 caml_string_get_16 s 9; + assert_bound_check2 caml_string_get_32 s (-1); + assert_bound_check2 caml_string_get_32 s 7; + assert_bound_check2 caml_string_get_64 s (-1); + assert_bound_check2 caml_string_get_64 s 3; + + assert_bound_check3 caml_string_set_16 s (-1) 0; + assert_bound_check3 caml_string_set_16 s 9 0; + assert_bound_check3 caml_string_set_32 s (-1) 0l; + assert_bound_check3 caml_string_set_32 s 7 0l; + assert_bound_check3 caml_string_set_64 s (-1) 0L; + assert_bound_check3 caml_string_set_64 s 3 0L; + + assert_bound_check2 caml_string_get_16 empty_s 0; + assert_bound_check2 caml_string_get_32 empty_s 0; + assert_bound_check2 caml_string_get_64 empty_s 0; + + assert_bound_check3 caml_string_set_16 empty_s 0 0; + assert_bound_check3 caml_string_set_32 empty_s 0 0l; + assert_bound_check3 caml_string_set_64 empty_s 0 0L + + + +let () = + caml_string_set_16 s 0 0x1234; + Printf.printf "%x %x %x\n%!" + (caml_string_get_16 s 0) + (caml_string_get_16 s 1) + (caml_string_get_16 s 2); + caml_string_set_16 s 0 0xFEDC; + Printf.printf "%x %x %x\n%!" + (caml_string_get_16 s 0) + (caml_string_get_16 s 1) + (caml_string_get_16 s 2) + +let () = + caml_string_set_32 s 0 0x12345678l; + Printf.printf "%lx %lx %lx\n%!" + (caml_string_get_32 s 0) + (caml_string_get_32 s 1) + (caml_string_get_32 s 2); + caml_string_set_32 s 0 0xFEDCBA09l; + Printf.printf "%lx %lx %lx\n%!" + (caml_string_get_32 s 0) + (caml_string_get_32 s 1) + (caml_string_get_32 s 2) + +let () = + caml_string_set_64 s 0 0x1234567890ABCDEFL; + Printf.printf "%Lx %Lx %Lx\n%!" + (caml_string_get_64 s 0) + (caml_string_get_64 s 1) + (caml_string_get_64 s 2); + caml_string_set_64 s 0 0xFEDCBA0987654321L; + Printf.printf "%Lx %Lx %Lx\n%!" + (caml_string_get_64 s 0) + (caml_string_get_64 s 1) + (caml_string_get_64 s 2) diff --git a/testsuite/tests/prim-bigstring/string_access.reference b/testsuite/tests/prim-bigstring/string_access.reference new file mode 100644 index 000000000..22b25addf --- /dev/null +++ b/testsuite/tests/prim-bigstring/string_access.reference @@ -0,0 +1,6 @@ +1234 12 0 +fedc fe 0 +12345678 123456 1234 +fedcba09 fedcba fedc +1234567890abcdef 1234567890abcd 1234567890ab +fedcba0987654321 fedcba09876543 fedcba098765 diff --git a/testsuite/tests/regression/pr5757/pr5757.ml b/testsuite/tests/regression/pr5757/pr5757.ml index 5395840c3..3a40bb51f 100644 --- a/testsuite/tests/regression/pr5757/pr5757.ml +++ b/testsuite/tests/regression/pr5757/pr5757.ml @@ -12,6 +12,6 @@ Random.init 3;; for i = 0 to 100_000 do - ignore (String.create (Random.int 1_000_000)) + ignore (Bytes.create (Random.int 1_000_000)) done;; Printf.printf "hello world\n";; diff --git a/testsuite/tests/regression/pr6024/Makefile b/testsuite/tests/regression/pr6024/Makefile index 964eefced..3426801f5 100644 --- a/testsuite/tests/regression/pr6024/Makefile +++ b/testsuite/tests/regression/pr6024/Makefile @@ -12,5 +12,6 @@ MAIN_MODULE=pr6024 -include ../../../makefiles/Makefile.one -include ../../../makefiles/Makefile.common +BASEDIR=../../.. +include $(BASEDIR)/makefiles/Makefile.one +include $(BASEDIR)/makefiles/Makefile.common diff --git a/testsuite/tests/runtime-errors/stackoverflow.bytecode.checker b/testsuite/tests/runtime-errors/stackoverflow.bytecode.checker index 893d1efd9..b4f86ac69 100644 --- a/testsuite/tests/runtime-errors/stackoverflow.bytecode.checker +++ b/testsuite/tests/runtime-errors/stackoverflow.bytecode.checker @@ -11,4 +11,3 @@ ######################################################################### $DIFF stackoverflow.bytecode.reference stackoverflow.bytecode.result - diff --git a/testsuite/tests/runtime-errors/stackoverflow.native.checker b/testsuite/tests/runtime-errors/stackoverflow.native.checker index ac12dd3f8..26c2ccf14 100644 --- a/testsuite/tests/runtime-errors/stackoverflow.native.checker +++ b/testsuite/tests/runtime-errors/stackoverflow.native.checker @@ -11,4 +11,3 @@ ######################################################################### $DIFF stackoverflow.native.reference stackoverflow.native.result - diff --git a/testsuite/tests/runtime-errors/syserror.bytecode.checker b/testsuite/tests/runtime-errors/syserror.bytecode.checker index ed2d20950..a1cb88a52 100644 --- a/testsuite/tests/runtime-errors/syserror.bytecode.checker +++ b/testsuite/tests/runtime-errors/syserror.bytecode.checker @@ -11,6 +11,3 @@ ######################################################################### grep 'Fatal error: exception Sys_error' syserror.bytecode.result >/dev/null - - - diff --git a/testsuite/tests/tool-debugger/.ignore b/testsuite/tests/tool-debugger/basic/.ignore index e09cf9eb6..e09cf9eb6 100644 --- a/testsuite/tests/tool-debugger/.ignore +++ b/testsuite/tests/tool-debugger/basic/.ignore diff --git a/testsuite/tests/tool-debugger/Makefile b/testsuite/tests/tool-debugger/basic/Makefile index f95b4803b..f95b4803b 100644 --- a/testsuite/tests/tool-debugger/Makefile +++ b/testsuite/tests/tool-debugger/basic/Makefile diff --git a/testsuite/tests/tool-debugger/debuggee.ml b/testsuite/tests/tool-debugger/basic/debuggee.ml index 341d0b369..341d0b369 100644 --- a/testsuite/tests/tool-debugger/debuggee.ml +++ b/testsuite/tests/tool-debugger/basic/debuggee.ml diff --git a/testsuite/tests/tool-debugger/debuggee.reference b/testsuite/tests/tool-debugger/basic/debuggee.reference index e998926c3..e998926c3 100644 --- a/testsuite/tests/tool-debugger/debuggee.reference +++ b/testsuite/tests/tool-debugger/basic/debuggee.reference diff --git a/testsuite/tests/tool-debugger/input_script b/testsuite/tests/tool-debugger/basic/input_script index 2caf06dd4..2caf06dd4 100755 --- a/testsuite/tests/tool-debugger/input_script +++ b/testsuite/tests/tool-debugger/basic/input_script diff --git a/testsuite/tests/tool-debugger/find-artifacts/.ignore b/testsuite/tests/tool-debugger/find-artifacts/.ignore new file mode 100644 index 000000000..0a2c0c40c --- /dev/null +++ b/testsuite/tests/tool-debugger/find-artifacts/.ignore @@ -0,0 +1,2 @@ +compiler-libs +out diff --git a/testsuite/tests/tool-debugger/find-artifacts/Makefile b/testsuite/tests/tool-debugger/find-artifacts/Makefile new file mode 100644 index 000000000..f313d8642 --- /dev/null +++ b/testsuite/tests/tool-debugger/find-artifacts/Makefile @@ -0,0 +1,67 @@ +######################################################################### +# # +# OCaml # +# # +# Damien Doligez, EPI Gallium, INRIA Rocquencourt # +# # +# Copyright 2013 Institut National de Recherche en Informatique et # +# en Automatique. All rights reserved. This file is distributed # +# under the terms of the Q Public License version 1.0. # +# # +######################################################################### + +BASEDIR=../../.. +MAIN_MODULE=debuggee +ADD_COMPFLAGS=-g -custom +LD_PATH=$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix + +.PHONY: default +default: + @if ! $(SUPPORTS_SHARED_LIBRARIES); then \ + echo 'skipped (shared libraries not available)'; \ + else \ + $(MAKE) compile; \ + $(SET_LD_PATH) OCAMLLIB=. $(MAKE) run; \ + fi + +.PHONY: compile +compile: $(ML_FILES) $(CMO_FILES) + @rm -rf out + @rm -f program.byte program.byte.exe + @mkdir out + @$(OCAMLC) $(ADD_COMPFLAGS) $(ADD_CFLAGS) -o out/blah.cmo -c \ + $(O_FILES) $(CMA_FILES) $(CMO_FILES) $(ADD_CMO_FILES) \ + in/blah.ml + @$(OCAMLC) $(ADD_COMPFLAGS) $(ADD_CFLAGS) -o out/foo.cmo -c \ + $(O_FILES) $(CMA_FILES) $(CMO_FILES) $(ADD_CMO_FILES) \ + -I out in/foo.ml + @$(OCAMLC) $(ADD_COMPFLAGS) $(ADD_CFLAGS) -o program.byte$(EXE) \ + $(O_FILES) $(CMA_FILES) $(CMO_FILES) $(ADD_CMO_FILES) \ + out/blah.cmo out/foo.cmo + @mkdir -p compiler-libs + @cp $(TOPDIR)/toplevel/topdirs.cmi compiler-libs/ + +.PHONY: run +run: + @printf " ... testing with ocamlc" + @rm -f $(MAIN_MODULE).result + @echo 'source input_script' | \ + $(OCAMLRUN) `$(CYGPATH) $(TOPDIR)/debugger/ocamldebug$(EXE)` \ + program.byte$(EXE) >$(MAIN_MODULE).raw.result 2>&1 \ + && sed -e '/Debugger version/d' -e '/^Time:/d' \ + -e '/Breakpoint [0-9]* at [0-9]*:/d' -e '$$d' \ + $(MAIN_MODULE).raw.result >$(MAIN_MODULE).result \ + && $(DIFF) $(MAIN_MODULE).reference $(MAIN_MODULE).result >/dev/null \ + && echo " => passed" || echo " => failed" + +.PHONY: promote +promote: defaultpromote + +.PHONY: clean +clean: defaultclean + @rm -f *.result program.byte program.byte.exe \ + program.native program.native.exe \ + $(GENERATED_SOURCES) $(O_FILES) $(TEST_TEMP_FILES) + @rm -rf compiler-libs out + +include $(BASEDIR)/makefiles/Makefile.common diff --git a/testsuite/tests/tool-debugger/find-artifacts/debuggee.reference b/testsuite/tests/tool-debugger/find-artifacts/debuggee.reference new file mode 100644 index 000000000..06564f90b --- /dev/null +++ b/testsuite/tests/tool-debugger/find-artifacts/debuggee.reference @@ -0,0 +1,6 @@ + +(ocd) Loading program... done. +Breakpoint: 1 +10 <|b|>print x; +x: Blah.blah = Foo +y: Blah.blah = Bar "hi" diff --git a/testsuite/tests/tool-debugger/find-artifacts/in/blah.ml b/testsuite/tests/tool-debugger/find-artifacts/in/blah.ml new file mode 100644 index 000000000..462c07b2e --- /dev/null +++ b/testsuite/tests/tool-debugger/find-artifacts/in/blah.ml @@ -0,0 +1,3 @@ +type blah = + | Foo + | Bar of string diff --git a/testsuite/tests/tool-debugger/find-artifacts/in/foo.ml b/testsuite/tests/tool-debugger/find-artifacts/in/foo.ml new file mode 100644 index 000000000..8d992673b --- /dev/null +++ b/testsuite/tests/tool-debugger/find-artifacts/in/foo.ml @@ -0,0 +1,13 @@ +open Blah + +let print = function + | Foo -> print_endline "Foo"; + | Bar s -> print_endline ("Bar(" ^ s ^ ")") + +let main () = + let x = Foo in + let y = Bar "hi" in + print x; + print y + +let _ = main () diff --git a/testsuite/tests/tool-debugger/find-artifacts/input_script b/testsuite/tests/tool-debugger/find-artifacts/input_script new file mode 100644 index 000000000..4b907c5ae --- /dev/null +++ b/testsuite/tests/tool-debugger/find-artifacts/input_script @@ -0,0 +1,5 @@ +break @ Foo 10 +run +print x +print y +quit diff --git a/testsuite/tests/tool-lexyacc/lexgen.ml b/testsuite/tests/tool-lexyacc/lexgen.ml index 1a5995728..005ea68d9 100644 --- a/testsuite/tests/tool-lexyacc/lexgen.ml +++ b/testsuite/tests/tool-lexyacc/lexgen.ml @@ -55,7 +55,9 @@ let rec print_regexp = function | Chars n -> prerr_string "Chars "; prerr_int n | Action n -> prerr_string "Action "; prerr_int n | Seq(r1,r2) -> print_regexp r1; prerr_string "; "; print_regexp r2 - | Alt(r1,r2) -> prerr_string "("; print_regexp r1; prerr_string " | "; print_regexp r2; prerr_string ")" + | Alt(r1,r2) -> + prerr_string "("; print_regexp r1; prerr_string " | "; print_regexp r2; + prerr_string ")" | Star r -> prerr_string "("; print_regexp r; prerr_string ")*" ***) @@ -164,7 +166,7 @@ let rec lastpos = function let followpos size name_regexp_list = - let v = Array.create size [] in + let v = Array.make size [] in let fill_pos first = function OnChars pos -> v.(pos) <- merge_trans first v.(pos); () | ToAction _ -> () in @@ -221,8 +223,8 @@ let goto_state = function let transition_from chars follow pos_set = - let tr = Array.create 256 [] - and shift = Array.create 256 Backtrack in + let tr = Array.make 256 [] + and shift = Array.make 256 Backtrack in List.iter (fun pos -> List.iter @@ -248,7 +250,10 @@ let make_dfa lexdef = let (chars, name_regexp_list, actions) = encode_lexdef lexdef in (** - List.iter (fun (name, regexp) -> prerr_string name; prerr_string " = "; print_regexp regexp; prerr_newline()) name_regexp_list; + List.iter (fun (name, regexp) -> + prerr_string name; prerr_string " = "; print_regexp regexp; + prerr_newline()) + name_regexp_list; **) let follow = followpos (Array.length chars) name_regexp_list in @@ -258,6 +263,6 @@ let make_dfa lexdef = let states = map_on_states (translate_state chars follow) in let v = - Array.create (number_of_states()) (Perform 0) in + Array.make (number_of_states()) (Perform 0) in List.iter (fun (auto, i) -> v.(i) <- auto) states; (initial_states, v, actions) diff --git a/testsuite/tests/tool-ocamldoc/odoc_test.ml b/testsuite/tests/tool-ocamldoc/odoc_test.ml index 918cadc40..9e34bb2a1 100644 --- a/testsuite/tests/tool-ocamldoc/odoc_test.ml +++ b/testsuite/tests/tool-ocamldoc/odoc_test.ml @@ -53,7 +53,19 @@ class string_gen = p fmt "# manifest (Odoc_info.string_of_type_expr):\n<[%s]>\n" (match t.ty_manifest with None -> "None" - | Some e -> Odoc_info.string_of_type_expr e + | Some (Other e) -> Odoc_info.string_of_type_expr e + | Some (Object_type fields) -> + let b = Buffer.create 256 in + Buffer.add_string b "<"; + List.iter + (fun fd -> + Printf.bprintf b " %s: %s ;" + fd.of_name + (Odoc_info.string_of_type_expr fd.of_type) + ) + fields; + Buffer.add_string b " >"; + Buffer.contents b ); ); diff --git a/testsuite/tests/tool-ocamldoc/t01.ml b/testsuite/tests/tool-ocamldoc/t01.ml index d253be43d..ee291b900 100644 --- a/testsuite/tests/tool-ocamldoc/t01.ml +++ b/testsuite/tests/tool-ocamldoc/t01.ml @@ -16,4 +16,7 @@ module type MT = sig (string * string * string) -> (string * string * string) -> unit val y : int + + type obj_type = + < foo : int ; bar : float -> string ; gee : int -> (int * string) > end diff --git a/testsuite/tests/tool-ocamldoc/t01.reference b/testsuite/tests/tool-ocamldoc/t01.reference index 72345ffec..d5159bdfc 100644 --- a/testsuite/tests/tool-ocamldoc/t01.reference +++ b/testsuite/tests/tool-ocamldoc/t01.reference @@ -23,6 +23,8 @@ string * string * string -> string * string * string -> string * string * string -> unit val y : int + type obj_type = + < bar : float -> string; foo : int; gee : int -> int * string > end]> # type T01.MT.t: # manifest (Odoc_info.string_of_type_expr): @@ -31,3 +33,6 @@ end]> string -> string * string * string -> string * string * string -> string * string * string -> unit]> +# type T01.MT.obj_type: +# manifest (Odoc_info.string_of_type_expr): +<[< bar: float -> string ; foo: int ; gee: int -> int * string ; >]> diff --git a/testsuite/tests/tool-toplevel/Makefile b/testsuite/tests/tool-toplevel/Makefile new file mode 100644 index 000000000..c9433b2ec --- /dev/null +++ b/testsuite/tests/tool-toplevel/Makefile @@ -0,0 +1,15 @@ +######################################################################### +# # +# OCaml # +# # +# Xavier Clerc, SED, INRIA Rocquencourt # +# # +# Copyright 2010 Institut National de Recherche en Informatique et # +# en Automatique. All rights reserved. This file is distributed # +# under the terms of the Q Public License version 1.0. # +# # +######################################################################### + +BASEDIR=../.. +include $(BASEDIR)/makefiles/Makefile.toplevel +include $(BASEDIR)/makefiles/Makefile.common diff --git a/testsuite/tests/tool-toplevel/tracing.ml b/testsuite/tests/tool-toplevel/tracing.ml new file mode 100644 index 000000000..5acaff238 --- /dev/null +++ b/testsuite/tests/tool-toplevel/tracing.ml @@ -0,0 +1,4 @@ +List.fold_left;; +#trace List.fold_left;; +0;; +List.fold_left (+) 0 [1;2;3];; diff --git a/testsuite/tests/tool-toplevel/tracing.ml.reference b/testsuite/tests/tool-toplevel/tracing.ml.reference new file mode 100644 index 000000000..e6eda8d7f --- /dev/null +++ b/testsuite/tests/tool-toplevel/tracing.ml.reference @@ -0,0 +1,30 @@ + +# - : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a = <fun> +# List.fold_left is now traced. +# - : int = 0 +# List.fold_left <-- <fun> +List.fold_left --> <fun> +List.fold_left* <-- <poly> +List.fold_left* --> <fun> +List.fold_left** <-- [<poly>; <poly>; <poly>] +List.fold_left <-- <fun> +List.fold_left --> <fun> +List.fold_left* <-- <poly> +List.fold_left* --> <fun> +List.fold_left** <-- [<poly>; <poly>] +List.fold_left <-- <fun> +List.fold_left --> <fun> +List.fold_left* <-- <poly> +List.fold_left* --> <fun> +List.fold_left** <-- [<poly>] +List.fold_left <-- <fun> +List.fold_left --> <fun> +List.fold_left* <-- <poly> +List.fold_left* --> <fun> +List.fold_left** <-- [] +List.fold_left** --> <poly> +List.fold_left** --> <poly> +List.fold_left** --> <poly> +List.fold_left** --> <poly> +- : int = 6 +# diff --git a/testsuite/tests/typing-extensions/Makefile b/testsuite/tests/typing-extensions/Makefile new file mode 100644 index 000000000..5f42b7057 --- /dev/null +++ b/testsuite/tests/typing-extensions/Makefile @@ -0,0 +1,4 @@ +BASEDIR=../.. +include $(BASEDIR)/makefiles/Makefile.toplevel +include $(BASEDIR)/makefiles/Makefile.common + diff --git a/testsuite/tests/typing-extensions/cast.ml b/testsuite/tests/typing-extensions/cast.ml new file mode 100644 index 000000000..afcc2080d --- /dev/null +++ b/testsuite/tests/typing-extensions/cast.ml @@ -0,0 +1,96 @@ + +(* By using two types we can have a recursive constraint *) +type 'a class_name = .. constraint 'a = < cast: 'a. 'a name -> 'a; ..> +and 'a name = Class : 'a class_name -> (< cast: 'a. 'a name -> 'a; ..> as 'a) name +;; + +exception Bad_cast +;; + +class type castable = +object + method cast: 'a.'a name -> 'a +end +;; + +(* Lets create a castable class with a name*) + +class type foo_t = +object + inherit castable + method foo: string +end +;; + +type 'a class_name += Foo: foo_t class_name +;; + +class foo: foo_t = +object(self) + method cast: type a. a name -> a = + function + Class Foo -> (self :> foo_t) + | _ -> ((raise Bad_cast) : a) + method foo = "foo" +end +;; + +(* Now we can create a subclass of foo *) + +class type bar_t = +object + inherit foo + method bar: string +end +;; + +type 'a class_name += Bar: bar_t class_name +;; + +class bar: bar_t = +object(self) + inherit foo as super + method cast: type a. a name -> a = + function + Class Bar -> (self :> bar_t) + | other -> super#cast other + method bar = "bar" +end +;; + +(* Now lets create a mutable list of castable objects *) + +let clist :castable list ref = ref [] +;; + +let push_castable (c: #castable) = + clist := (c :> castable) :: !clist +;; + +let pop_castable () = + match !clist with + c :: rest -> + clist := rest; + c + | [] -> raise Not_found +;; + +(* We can add foos and bars to this list, and retrive them *) + +push_castable (new foo);; +push_castable (new bar);; +push_castable (new foo);; + +let c1: castable = pop_castable ();; +let c2: castable = pop_castable ();; +let c3: castable = pop_castable ();; + +(* We can also downcast these values to foos and bars *) + +let f1: foo = c1#cast (Class Foo);; (* Ok *) +let f2: foo = c2#cast (Class Foo);; (* Ok *) +let f3: foo = c3#cast (Class Foo);; (* Ok *) + +let b1: bar = c1#cast (Class Bar);; (* Exception Bad_cast *) +let b2: bar = c2#cast (Class Bar);; (* Ok *) +let b3: bar = c3#cast (Class Bar);; (* Exception Bad_cast *) diff --git a/testsuite/tests/typing-extensions/cast.ml.reference b/testsuite/tests/typing-extensions/cast.ml.reference new file mode 100644 index 000000000..c22974163 --- /dev/null +++ b/testsuite/tests/typing-extensions/cast.ml.reference @@ -0,0 +1,33 @@ + +# type 'b class_name = .. constraint 'b = < cast : 'a. 'a name -> 'a; .. > +and 'a name = + Class : 'a class_name -> (< cast : 'a0. 'a0 name -> 'a0; .. > as 'a) name +# exception Bad_cast +# class type castable = object method cast : 'a name -> 'a end +# class type foo_t = object method cast : 'a name -> 'a method foo : string end +# type 'b class_name += Foo : foo_t class_name +# class foo : foo_t +# class type bar_t = + object + method bar : string + method cast : 'a name -> 'a + method foo : string + end +# type 'b class_name += Bar : bar_t class_name +# class bar : bar_t +# val clist : castable list ref = {contents = []} +# val push_castable : #castable -> unit = <fun> +# val pop_castable : unit -> castable = <fun> +# - : unit = () +# - : unit = () +# - : unit = () +# val c1 : castable = <obj> +# val c2 : castable = <obj> +# val c3 : castable = <obj> +# val f1 : foo = <obj> +# val f2 : foo = <obj> +# val f3 : foo = <obj> +# Exception: Bad_cast. +# val b2 : bar = <obj> +# Exception: Bad_cast. +# diff --git a/testsuite/tests/typing-extensions/extensions.ml b/testsuite/tests/typing-extensions/extensions.ml new file mode 100644 index 000000000..59a23db9d --- /dev/null +++ b/testsuite/tests/typing-extensions/extensions.ml @@ -0,0 +1,321 @@ + +type foo = .. +;; + +type foo += + A + | B of int +;; + +let is_a x = + match x with + A -> true + | _ -> false +;; + +(* The type must be open to create extension *) + +type foo +;; + +type foo += A of int (* Error type is not open *) +;; + +(* The type parameters must match *) + +type 'a foo = .. +;; + +type ('a, 'b) foo += A of int (* Error: type parameter mismatch *) +;; + +(* In a signature the type does not have to be open *) + +module type S = +sig + type foo + type foo += A of float +end +;; + +(* But it must still be extensible *) + +module type S = +sig + type foo = A of int + type foo += B of float (* Error foo does not have an extensible type *) +end +;; + +(* Signatures can change the grouping of extensions *) + +type foo = .. +;; + +module M = struct + type foo += + A of int + | B of string + + type foo += + C of int + | D of float +end +;; + +module type S = sig + type foo += + B of string + | C of int + + type foo += D of float + + type foo += A of int +end +;; + +module M_S = (M : S) +;; + +(* Extensions can be GADTs *) + +type 'a foo = .. +;; + +type _ foo += + A : int -> int foo + | B : int foo +;; + +let get_num : type a. a foo -> a -> a option = fun f i1 -> + match f with + A i2 -> Some (i1 + i2) + | _ -> None +;; + +(* Extensions must obey constraints *) + +type 'a foo = .. constraint 'a = [> `Var ] +;; + +type 'a foo += A of 'a +;; + +let a = A 9 (* ERROR: Constraints not met *) +;; + +type 'a foo += B : int foo (* ERROR: Constraints not met *) +;; + +(* Signatures can make an extension private *) + +type foo = .. +;; + +module M = struct type foo += A of int end +;; + +let a1 = M.A 10 +;; + +module type S = sig type foo += private A of int end +;; + +module M_S = (M : S) +;; + +let is_s x = + match x with + M_S.A _ -> true + | _ -> false +;; + +let a2 = M_S.A 20 (* ERROR: Cannot create a value using a private constructor *) +;; + +(* Extensions can be rebound *) + +type foo = .. +;; + +module M = struct type foo += A1 of int end +;; + +type foo += A2 = M.A1 +;; + +type bar = .. +;; + +type bar += A3 = M.A1 (* Error: rebind wrong type *) +;; + +module M = struct type foo += private B1 of int end +;; + +type foo += private B2 = M.B1 +;; + +type foo += B3 = M.B1 (* Error: rebind private extension *) +;; + +type foo += C = Unknown (* Error: unbound extension *) +;; + +(* Extensions can be rebound even if type is closed *) + +module M : sig type foo type foo += A1 of int end + = struct type foo = .. type foo += A1 of int end + +type M.foo += A2 = M.A1 + +(* Rebinding handles abbreviations *) + +type 'a foo = .. +;; + +type 'a foo1 = 'a foo = .. +;; + +type 'a foo2 = 'a foo = .. +;; + +type 'a foo1 += + A of int + | B of 'a + | C : int foo1 +;; + +type 'a foo2 += + D = A + | E = B + | F = C +;; + +(* Extensions must obey variances *) + +type +'a foo = .. +;; + +type 'a foo += A of (int -> 'a) +;; + +type 'a foo += B of ('a -> int) (* ERROR: Parameter variances are not satisfied *) +;; + +type _ foo += C : ('a -> int) -> 'a foo (* ERROR: Parameter variances are not satisfied *) +;; + +type 'a bar = .. +;; + +type +'a bar += D of (int -> 'a) (* ERROR: type variances do not match *) +;; + +(* Exceptions are compatible with extensions *) + +module M : sig + type exn += + Foo of int * float + | Bar : 'a list -> exn +end = struct + exception Bar : 'a list -> exn + exception Foo of int * float +end +;; + +module M : sig + exception Bar : 'a list -> exn + exception Foo of int * float +end = struct + type exn += + Foo of int * float + | Bar : 'a list -> exn +end +;; + +exception Foo of int * float +;; + +exception Bar : 'a list -> exn +;; + +module M : sig + type exn += + Foo of int * float + | Bar : 'a list -> exn +end = struct + exception Bar = Bar + exception Foo = Foo +end +;; + +(* Test toplevel printing *) + +type foo = .. +;; + +type foo += + Foo of int * int option + | Bar of int option +;; + +let x = Foo(3, Some 4), Bar(Some 5) (* Prints Foo and Bar successfully *) +;; + +type foo += Foo of string +;; + +let y = x (* Prints Bar but not Foo (which has been shadowed) *) +;; + +exception Foo of int * int option +;; + +exception Bar of int option +;; + +let x = Foo(3, Some 4), Bar(Some 5) (* Prints Foo and Bar successfully *) +;; + +type foo += Foo of string +;; + +let y = x (* Prints Bar and part of Foo (which has been shadowed) *) +;; + +(* Test Obj functions *) + +type foo = .. +;; + +type foo += + Foo + | Bar of int +;; + +let n1 = Obj.extension_name Foo +;; + +let n2 = Obj.extension_name (Bar 1) +;; + +let t = (Obj.extension_id (Bar 2)) = (Obj.extension_id (Bar 3)) (* true *) +;; + +let f = (Obj.extension_id (Bar 2)) = (Obj.extension_id Foo) (* false *) +;; + +let is_foo x = (Obj.extension_id Foo) = (Obj.extension_id x) + +type foo += Foo +;; + +let f = is_foo Foo +;; + +let _ = Obj.extension_name 7 (* Invald_arg *) +;; + +let _ = Obj.extension_id (object method m = 3 end) (* Invald_arg *) +;; diff --git a/testsuite/tests/typing-extensions/extensions.ml.reference b/testsuite/tests/typing-extensions/extensions.ml.reference new file mode 100644 index 000000000..25af292de --- /dev/null +++ b/testsuite/tests/typing-extensions/extensions.ml.reference @@ -0,0 +1,131 @@ + +# type foo = .. +# type foo += A | B of int +# val is_a : foo -> bool = <fun> +# type foo +# Characters 13-21: + type foo += A of int (* Error type is not open *) + ^^^^^^^^ +Error: Cannot extend type definition foo +# type 'a foo = .. +# Characters 1-30: + type ('a, 'b) foo += A of int (* Error: type parameter mismatch *) + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This extension does not match the definition of type foo + They have different arities. +# module type S = sig type foo type foo += A of float end +# Characters 84-106: + type foo += B of float (* Error foo does not have an extensible type *) + ^^^^^^^^^^^^^^^^^^^^^^ +Error: Type foo is not extensible +# type foo = .. +# module M : + sig + type foo += A of int | B of string + type foo += C of int | D of float + + end +# module type S = + sig + type foo += B of string | C of int + type foo += D of float + type foo += A of int + end +# module M_S : S +# type 'a foo = .. +# type _ foo += A : int -> int foo | B : int foo +# val get_num : 'a foo -> 'a -> 'a option = <fun> +# type 'a foo = .. constraint 'a = [> `Var ] +# type 'a foo += A of 'a +# Characters 11-12: + let a = A 9 (* ERROR: Constraints not met *) + ^ +Error: This expression has type int but an expression was expected of type + [> `Var ] +# Characters 20-23: + type 'a foo += B : int foo (* ERROR: Constraints not met *) + ^^^ +Error: This type int should be an instance of type [> `Var ] +# type foo = .. +# module M : sig type foo += A of int end +# val a1 : foo = M.A 10 +# module type S = sig type foo += private A of int end +# module M_S : S +# val is_s : foo -> bool = <fun> +# Characters 10-18: + let a2 = M_S.A 20 (* ERROR: Cannot create a value using a private constructor *) + ^^^^^^^^ +Error: Cannot create values of the private type foo +# type foo = .. +# module M : sig type foo += A1 of int end +# type foo += A2 of int +# type bar = .. +# Characters 18-22: + type bar += A3 = M.A1 (* Error: rebind wrong type *) + ^^^^ +Error: The constructor M.A1 has type foo but was expected to be of type bar +# module M : sig type foo += private B1 of int end +# type foo += private B2 of int +# Characters 18-22: + type foo += B3 = M.B1 (* Error: rebind private extension *) + ^^^^ +Error: The constructor M.B1 is private +# Characters 13-24: + type foo += C = Unknown (* Error: unbound extension *) + ^^^^^^^^^^^ +Error: Unbound constructor Unknown +# module M : sig type foo type foo += A1 of int end +type M.foo += A2 of int +type 'a foo = .. +# type 'a foo1 = 'a foo = .. +# type 'a foo2 = 'a foo = .. +# type 'a foo1 += A of int | B of 'a | C : int foo1 +# type 'a foo2 += D of int | E of 'a | F : int foo2 +# type +'a foo = .. +# type 'a foo += A of (int -> 'a) +# Characters 1-32: + type 'a foo += B of ('a -> int) (* ERROR: Parameter variances are not satisfied *) + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: In this definition, expected parameter variances are not satisfied. + The 1st type parameter was expected to be covariant, + but it is injective contravariant. +# Characters 1-40: + type _ foo += C : ('a -> int) -> 'a foo (* ERROR: Parameter variances are not satisfied *) + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: In this definition, expected parameter variances are not satisfied. + The 1st type parameter was expected to be covariant, + but it is injective contravariant. +# type 'a bar = .. +# Characters 1-33: + type +'a bar += D of (int -> 'a) (* ERROR: type variances do not match *) + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This extension does not match the definition of type bar + Their variances do not agree. +# module M : sig type exn += Foo of int * float | Bar : 'a list -> exn end +# module M : + sig exception Bar : 'a list -> exn exception Foo of int * float end +# exception Foo of int * float +# exception Bar : 'a list -> exn +# module M : sig type exn += Foo of int * float | Bar : 'a list -> exn end +# type foo = .. +# type foo += Foo of int * int option | Bar of int option +# val x : foo * foo = (Foo (3, Some 4), Bar (Some 5)) +# type foo += Foo of string +# val y : foo * foo = (<extension>, Bar (Some 5)) +# exception Foo of int * int option +# exception Bar of int option +# val x : exn * exn = (Foo (3, Some 4), Bar (Some 5)) +# type foo += Foo of string +# val y : exn * exn = (Foo (3, _), Bar (Some 5)) +# type foo = .. +# type foo += Foo | Bar of int +# val n1 : string = "Foo" +# val n2 : string = "Bar" +# val t : bool = true +# val f : bool = false +# val is_foo : 'a -> bool = <fun> +type foo += Foo +# val f : bool = false +# Exception: Invalid_argument "Obj.extension_name". +# Exception: Invalid_argument "Obj.extension_id". +# diff --git a/testsuite/tests/typing-extensions/msg.ml b/testsuite/tests/typing-extensions/msg.ml new file mode 100644 index 000000000..ef1c12fb4 --- /dev/null +++ b/testsuite/tests/typing-extensions/msg.ml @@ -0,0 +1,131 @@ +(* Typed names *) + +module Msg : sig + + type 'a tag + + type result = Result : 'a tag * 'a -> result + + val write : 'a tag -> 'a -> unit + + val read : unit -> result + + type 'a tag += Int : int tag + + module type Desc = sig + type t + val label : string + val write : t -> string + val read : string -> t + end + + module Define (D : Desc) : sig + type 'a tag += C : D.t tag + end + +end = struct + + type 'a tag = .. + + type ktag = T : 'a tag -> ktag + + type 'a kind = + { tag : 'a tag; + label : string; + write : 'a -> string; + read : string -> 'a; } + + type rkind = K : 'a kind -> rkind + + type wkind = { f : 'a . 'a tag -> 'a kind } + + let readTbl : (string, rkind) Hashtbl.t = Hashtbl.create 13 + + let writeTbl : (ktag, wkind) Hashtbl.t = Hashtbl.create 13 + + let read_raw () : string * string = raise (Failure "Not implemented") + + type result = Result : 'a tag * 'a -> result + + let read () = + let label, content = read_raw () in + let K k = Hashtbl.find readTbl label in + let body = k.read content in + Result(k.tag, body) + + let write_raw (label : string) (content : string) = + raise (Failure "Not implemented") + + let write (tag : 'a tag) (body : 'a) = + let {f} = Hashtbl.find writeTbl (T tag) in + let k = f tag in + let content = k.write body in + write_raw k.label content + + (* Add int kind *) + + type 'a tag += Int : int tag + + let ik = + { tag = Int; + label = "int"; + write = string_of_int; + read = int_of_string } + + let () = Hashtbl.add readTbl "int" (K ik) + + let () = + let f (type t) (i : t tag) : t kind = + match i with + Int -> ik + | _ -> assert false + in + Hashtbl.add writeTbl (T Int) {f} + + (* Support user defined kinds *) + + module type Desc = sig + type t + val label : string + val write : t -> string + val read : string -> t + end + + module Define (D : Desc) = struct + type 'a tag += C : D.t tag + let k = + { tag = C; + label = D.label; + write = D.write; + read = D.read } + let () = Hashtbl.add readTbl D.label (K k) + let () = + let f (type t) (c : t tag) : t kind = + match c with + C -> k + | _ -> assert false + in + Hashtbl.add writeTbl (T C) {f} + end + +end;; + +let write_int i = Msg.write Msg.Int i;; + +module StrM = Msg.Define(struct + type t = string + let label = "string" + let read s = s + let write s = s +end);; + +type 'a Msg.tag += String = StrM.C;; + +let write_string s = Msg.write String s;; + +let read_one () = + let Msg.Result(tag, body) = Msg.read () in + match tag with + Msg.Int -> print_int body + | String -> print_string body + | _ -> print_string "Unknown";; diff --git a/testsuite/tests/typing-extensions/msg.ml.reference b/testsuite/tests/typing-extensions/msg.ml.reference new file mode 100644 index 000000000..e7f1a8f24 --- /dev/null +++ b/testsuite/tests/typing-extensions/msg.ml.reference @@ -0,0 +1,23 @@ + +# module Msg : + sig + type 'a tag + type result = Result : 'a tag * 'a -> result + val write : 'a tag -> 'a -> unit + val read : unit -> result + type 'a tag += Int : int tag + module type Desc = + sig + type t + val label : string + val write : t -> string + val read : string -> t + end + module Define : functor (D : Desc) -> sig type 'a tag += C : D.t tag end + end +# val write_int : int -> unit = <fun> +# module StrM : sig type 'a Msg.tag += C : string Msg.tag end +# type 'a Msg.tag += String : string Msg.tag +# val write_string : string -> unit = <fun> +# val read_one : unit -> unit = <fun> +# diff --git a/testsuite/tests/typing-extensions/open_types.ml b/testsuite/tests/typing-extensions/open_types.ml new file mode 100644 index 000000000..e7632cac2 --- /dev/null +++ b/testsuite/tests/typing-extensions/open_types.ml @@ -0,0 +1,109 @@ +type foo = .. +;; + +(* Check that abbreviations work *) + +type bar = foo = .. +;; + +type baz = foo = .. +;; + +type bar += Bar1 of int +;; + +type baz += Bar2 of int +;; + +module M = struct type bar += Foo of float end +;; + +module type S = sig type baz += Foo of float end +;; + +module M_S = (M : S) +;; + +(* Abbreviations need to be made open *) + +type foo = .. +;; + +type bar = foo +;; + +type bar += Bar of int (* Error: type is not open *) +;; + +type baz = bar = .. (* Error: type kinds don't match *) +;; + +(* Abbreviations need to match parameters *) + +type 'a foo = .. +;; + +type ('a, 'b) bar = 'a foo = .. (* Error: arrities do not match *) +;; + +type ('a, 'b) foo = .. +;; + +type ('a, 'b) bar = ('a, 'a) foo = .. (* Error: constraints do not match *) +;; + +(* Private abstract types cannot be open *) + +type foo = .. +;; + +type bar = private foo = .. (* ERROR: Private abstract types cannot be open *) +;; + +(* Check that signatures can hide open-ness *) + +module M = struct type foo = .. end +;; + +module type S = sig type foo end +;; + +module M_S = (M : S) +;; + +type M_S.foo += Foo (* ERROR: Cannot extend a type that isn't "open" *) +;; + +(* Check that signatures cannot add open-ness *) + +module M = struct type foo end +;; + +module type S = sig type foo = .. end +;; + +module M_S = (M : S) (* ERROR: Signatures are not compatible *) +;; + +(* Check that signatures maintain variances *) + +module M = struct type +'a foo = .. type 'a bar = 'a foo = .. end +;; + +module type S = sig type 'a foo = .. type 'a bar = 'a foo = .. end +;; + +module M_S = (M : S) (* ERROR: Signatures are not compatible *) +;; + +(* Exn is an open type *) + +type exn2 = exn = .. +;; + +(* Exhaustiveness *) + +type foo = .. +type foo += Foo +let f = function Foo -> () +;; (* warn *) diff --git a/testsuite/tests/typing-extensions/open_types.ml.reference b/testsuite/tests/typing-extensions/open_types.ml.reference new file mode 100644 index 000000000..5fb9684d4 --- /dev/null +++ b/testsuite/tests/typing-extensions/open_types.ml.reference @@ -0,0 +1,83 @@ + +# type foo = .. +# type bar = foo = .. +# type baz = foo = .. +# type bar += Bar1 of int +# type baz += Bar2 of int +# module M : sig type bar += Foo of float end +# module type S = sig type baz += Foo of float end +# module M_S : S +# type foo = .. +# type bar = foo +# Characters 13-23: + type bar += Bar of int (* Error: type is not open *) + ^^^^^^^^^^ +Error: Cannot extend type definition bar +# Characters 6-20: + type baz = bar = .. (* Error: type kinds don't match *) + ^^^^^^^^^^^^^^ +Error: This variant or record definition does not match that of type bar + Their kinds differ. +# type 'a foo = .. +# Characters 6-32: + type ('a, 'b) bar = 'a foo = .. (* Error: arrities do not match *) + ^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This variant or record definition does not match that of type 'a foo + They have different arities. +# type ('a, 'b) foo = .. +# Characters 6-38: + type ('a, 'b) bar = ('a, 'a) foo = .. (* Error: constraints do not match *) + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This variant or record definition does not match that of type + ('a, 'a) foo + Their constraints differ. +# type foo = .. +# Characters 24-25: + type bar = private foo = .. (* ERROR: Private abstract types cannot be open *) + ^ +Error: Syntax error +# module M : sig type foo = .. end +# module type S = sig type foo end +# module M_S : S +# Characters 17-20: + type M_S.foo += Foo (* ERROR: Cannot extend a type that isn't "open" *) + ^^^ +Error: Cannot extend type definition M_S.foo +# module M : sig type foo end +# module type S = sig type foo = .. end +# Characters 15-16: + module M_S = (M : S) (* ERROR: Signatures are not compatible *) + ^ +Error: Signature mismatch: + Modules do not match: sig type foo = M.foo end is not included in S + Type declarations do not match: + type foo = M.foo + is not included in + type foo = .. + Their kinds differ. +# module M : sig type +'a foo = .. type 'a bar = 'a foo = .. end +# module type S = sig type 'a foo = .. type 'a bar = 'a foo = .. end +# Characters 15-16: + module M_S = (M : S) (* ERROR: Signatures are not compatible *) + ^ +Error: Signature mismatch: + Modules do not match: + sig type 'a foo = 'a M.foo = .. type 'a bar = 'a foo = .. end + is not included in + S + Type declarations do not match: + type 'a foo = 'a M.foo = .. + is not included in + type 'a foo = .. + Their variances do not agree. +# type exn2 = exn = .. +# Characters 61-79: + let f = function Foo -> () + ^^^^^^^^^^^^^^^^^^ +Warning 8: this pattern-matching is not exhaustive. +Here is an example of a value that is not matched: +*extension* +type foo = .. +type foo += Foo +val f : foo -> unit = <fun> +# diff --git a/testsuite/tests/typing-fstclassmod/Makefile b/testsuite/tests/typing-fstclassmod/Makefile index e854696f4..e77918367 100644 --- a/testsuite/tests/typing-fstclassmod/Makefile +++ b/testsuite/tests/typing-fstclassmod/Makefile @@ -13,7 +13,7 @@ BASEDIR=../.. #MODULES= MAIN_MODULE=fstclassmod -ADD_COMPFLAGS=-w a +ADD_COMPFLAGS=-w A -warn-error A include $(BASEDIR)/makefiles/Makefile.one include $(BASEDIR)/makefiles/Makefile.common diff --git a/testsuite/tests/typing-fstclassmod/fstclassmod.ml b/testsuite/tests/typing-fstclassmod/fstclassmod.ml index 82af377be..bc8d66e51 100644 --- a/testsuite/tests/typing-fstclassmod/fstclassmod.ml +++ b/testsuite/tests/typing-fstclassmod/fstclassmod.ml @@ -146,11 +146,20 @@ let () = module type S1 = sig end module type S2 = S1 -let f (x : (module S1)) : (module S2) = x +let _f (x : (module S1)) : (module S2) = x module X = struct module type S end module Y = struct include X end -let f (x : (module X.S)) : (module Y.S) = x +let _f (x : (module X.S)) : (module Y.S) = x + +(* PR#6194, main example *) +module type S3 = sig val x : bool end;; +let f = function + | Some (module M : S3) when M.x ->1 + | Some _ -> 2 + | None -> 3 +;; +print_endline (string_of_int (f (Some (module struct let x = false end))));; diff --git a/testsuite/tests/typing-fstclassmod/fstclassmod.reference b/testsuite/tests/typing-fstclassmod/fstclassmod.reference index 59c7aa116..ec517d789 100644 --- a/testsuite/tests/typing-fstclassmod/fstclassmod.reference +++ b/testsuite/tests/typing-fstclassmod/fstclassmod.reference @@ -4,3 +4,4 @@ abc/def/xyz xyz/def/abc XXXXXXXX 10 (123,("A",456)) +2 diff --git a/testsuite/tests/typing-gadts/didier.ml b/testsuite/tests/typing-gadts/didier.ml new file mode 100644 index 000000000..8091375c0 --- /dev/null +++ b/testsuite/tests/typing-gadts/didier.ml @@ -0,0 +1,48 @@ +type 'a ty = + | Int : int ty + | Bool : bool ty + +let fbool (type t) (x : t) (tag : t ty) = + match tag with + | Bool -> x +;; +(* val fbool : 'a -> 'a ty -> 'a = <fun> *) +(** OK: the return value is x of type t **) + +let fint (type t) (x : t) (tag : t ty) = + match tag with + | Int -> x > 0 +;; +(* val fint : 'a -> 'a ty -> bool = <fun> *) +(** OK: the return value is x > 0 of type bool; +This has used the equation t = bool, not visible in the return type **) + +let f (type t) (x : t) (tag : t ty) = + match tag with + | Int -> x > 0 + | Bool -> x +(* val f : 'a -> 'a ty -> bool = <fun> *) + + +let g (type t) (x : t) (tag : t ty) = + match tag with + | Bool -> x + | Int -> x > 0 +(* Error: This expression has type bool but an expression was expected of type +t = int *) + +let id x = x;; +let idb1 = (fun id -> let _ = id true in id) id;; +let idb2 : bool -> bool = id;; +let idb3 ( _ : bool ) = false;; + +let g (type t) (x : t) (tag : t ty) = + match tag with + | Bool -> idb3 x + | Int -> x > 0 + +let g (type t) (x : t) (tag : t ty) = + match tag with + | Bool -> idb2 x + | Int -> x > 0 + diff --git a/testsuite/tests/typing-gadts/pr5948.ml b/testsuite/tests/typing-gadts/pr5948.ml index 8ba45d2df..0acc90868 100644 --- a/testsuite/tests/typing-gadts/pr5948.ml +++ b/testsuite/tests/typing-gadts/pr5948.ml @@ -1,6 +1,6 @@ type tag = [`TagA | `TagB | `TagC];; -type 'a poly = +type 'a poly = AandBTags : [< `TagA of int | `TagB ] poly | ATag : [< `TagA of int] poly (* constraint 'a = [< `TagA of int | `TagB] *) @@ -10,17 +10,17 @@ let intA = function `TagA i -> i let intB = function `TagB -> 4 ;; -let intAorB = function +let intAorB = function `TagA i -> i | `TagB -> 4 ;; -type _ wrapPoly = +type _ wrapPoly = WrapPoly : 'a poly -> ([< `TagA of int | `TagB] as 'a) wrapPoly ;; let example6 : type a. a wrapPoly -> (a -> int) = - fun w -> + fun w -> match w with | WrapPoly ATag -> intA | WrapPoly _ -> intA (* This should not be allowed *) diff --git a/testsuite/tests/typing-gadts/pr5985.ml b/testsuite/tests/typing-gadts/pr5985.ml index 6d0bbcee7..23902add3 100644 --- a/testsuite/tests/typing-gadts/pr5985.ml +++ b/testsuite/tests/typing-gadts/pr5985.ml @@ -29,7 +29,7 @@ end;; (* fail *) (* Another (more direct) instance using polymorphic variants *) (* PR#6275 *) type 'x t = A of 'a constraint 'x = [< `X of 'a ] ;; (* fail *) -let magic (x : int) : bool = +let magic (x : int) : bool = let A x = A x in x;; (* fail *) type 'a t = A : 'a -> [< `X of 'a ] t;; (* fail *) diff --git a/testsuite/tests/typing-gadts/pr6163.ml b/testsuite/tests/typing-gadts/pr6163.ml index e9646196e..ad5e8eda7 100644 --- a/testsuite/tests/typing-gadts/pr6163.ml +++ b/testsuite/tests/typing-gadts/pr6163.ml @@ -1,4 +1,4 @@ -type _ nat = +type _ nat = Zero : [`Zero] nat | Succ : 'a nat -> [`Succ of 'a] nat;; type 'a pre_nat = [`Zero | `Succ of 'a];; diff --git a/testsuite/tests/typing-gadts/pr6174.ml.principal.reference b/testsuite/tests/typing-gadts/pr6174.ml.principal.reference index 647015c36..8f2be5252 100644 --- a/testsuite/tests/typing-gadts/pr6174.ml.principal.reference +++ b/testsuite/tests/typing-gadts/pr6174.ml.principal.reference @@ -1,8 +1,7 @@ -# Characters 118-119: +# Characters 137-138: fun C k -> k (fun x -> x);; - ^ -Error: Recursive local constraint when unifying - (((ex#0 -> ex#1) -> ex#1) -> (ex#2 -> ex#1) -> ex#1) t - with ((a -> o) -> o) t + ^ +Error: This expression has type ex#0 but an expression was expected of type + ex#1 = (ex#2 -> ex#1) -> ex#1 # diff --git a/testsuite/tests/typing-gadts/pr6174.ml.reference b/testsuite/tests/typing-gadts/pr6174.ml.reference index 647015c36..8f2be5252 100644 --- a/testsuite/tests/typing-gadts/pr6174.ml.reference +++ b/testsuite/tests/typing-gadts/pr6174.ml.reference @@ -1,8 +1,7 @@ -# Characters 118-119: +# Characters 137-138: fun C k -> k (fun x -> x);; - ^ -Error: Recursive local constraint when unifying - (((ex#0 -> ex#1) -> ex#1) -> (ex#2 -> ex#1) -> ex#1) t - with ((a -> o) -> o) t + ^ +Error: This expression has type ex#0 but an expression was expected of type + ex#1 = (ex#2 -> ex#1) -> ex#1 # diff --git a/testsuite/tests/typing-gadts/test.ml b/testsuite/tests/typing-gadts/test.ml index a8215290a..2f0bb9196 100644 --- a/testsuite/tests/typing-gadts/test.ml +++ b/testsuite/tests/typing-gadts/test.ml @@ -102,12 +102,8 @@ module Existential_escape = module Rectype = struct type (_,_) t = C : ('a,'a) t - let _ = - fun (type s) -> - let a : (s, s * s) t = failwith "foo" in - match a with - C -> - () + let f : type s. (s, s*s) t -> unit = + fun C -> () (* here s = s*s! *) end ;; diff --git a/testsuite/tests/typing-gadts/test.ml.principal.reference b/testsuite/tests/typing-gadts/test.ml.principal.reference index 0d40f674a..fd9fb3501 100644 --- a/testsuite/tests/typing-gadts/test.ml.principal.reference +++ b/testsuite/tests/typing-gadts/test.ml.principal.reference @@ -53,10 +53,8 @@ module Nonexhaustive : Error: This expression has type a#2 t but an expression was expected of type a#2 t The type constructor a#2 would escape its scope -# Characters 174-175: - C -> - ^ -Error: Recursive local constraint when unifying (s, s) t with (s, s * s) t +# module Rectype : + sig type (_, _) t = C : ('a, 'a) t val f : ('s, 's * 's) t -> unit end # Characters 178-186: | (IntLit _ | BoolLit _) -> () ^^^^^^^^ diff --git a/testsuite/tests/typing-gadts/test.ml.reference b/testsuite/tests/typing-gadts/test.ml.reference index e6aa47b41..a5faa02c0 100644 --- a/testsuite/tests/typing-gadts/test.ml.reference +++ b/testsuite/tests/typing-gadts/test.ml.reference @@ -53,10 +53,8 @@ module Nonexhaustive : Error: This expression has type a#2 t but an expression was expected of type a#2 t The type constructor a#2 would escape its scope -# Characters 174-175: - C -> - ^ -Error: Recursive local constraint when unifying (s, s) t with (s, s * s) t +# module Rectype : + sig type (_, _) t = C : ('a, 'a) t val f : ('s, 's * 's) t -> unit end # Characters 178-186: | (IntLit _ | BoolLit _) -> () ^^^^^^^^ diff --git a/testsuite/tests/typing-labels/mixin2.ml b/testsuite/tests/typing-labels/mixin2.ml index 8a5498fa3..fd2b28979 100644 --- a/testsuite/tests/typing-labels/mixin2.ml +++ b/testsuite/tests/typing-labels/mixin2.ml @@ -182,7 +182,9 @@ let rec print = function let () = let e1 = lambda#eval (`App(`Abs("x",`Var"x"), `Var"y")) in let e2 = expr#eval (`Add(`Mult(`Num 3,`Neg(`Num 2)), `Var"x")) in - let e3 = lexpr#eval (`Add(`App(`Abs("x",`Mult(`Var"x",`Var"x")),`Num 2), `Num 5)) in + let e3 = + lexpr#eval (`Add(`App(`Abs("x",`Mult(`Var"x",`Var"x")),`Num 2), `Num 5)) + in print e1; print_newline (); print e2; print_newline (); print e3; print_newline () diff --git a/testsuite/tests/typing-labels/mixin3.ml b/testsuite/tests/typing-labels/mixin3.ml index 0b9db2428..5b987e819 100644 --- a/testsuite/tests/typing-labels/mixin3.ml +++ b/testsuite/tests/typing-labels/mixin3.ml @@ -176,7 +176,9 @@ let rec print = function let () = let e1 = lambda#eval (`App(`Abs("x",`Var"x"), `Var"y")) in let e2 = expr#eval (`Add(`Mult(`Num 3,`Neg(`Num 2)), `Var"x")) in - let e3 = lexpr#eval (`Add(`App(`Abs("x",`Mult(`Var"x",`Var"x")),`Num 2), `Num 5)) in + let e3 = + lexpr#eval (`Add(`App(`Abs("x",`Mult(`Var"x",`Var"x")),`Num 2), `Num 5)) + in print e1; print_newline (); print e2; print_newline (); print e3; print_newline () diff --git a/testsuite/tests/typing-misc/constraints.ml b/testsuite/tests/typing-misc/constraints.ml index 5408ca2c1..a00636325 100644 --- a/testsuite/tests/typing-misc/constraints.ml +++ b/testsuite/tests/typing-misc/constraints.ml @@ -14,3 +14,11 @@ type 'a t = 'a;; let f (x : 'a t as 'a) = ();; (* fails *) let f (x : 'a t) (y : 'a) = x = y;; + +(* PR#6505 *) +module type PR6505 = sig + type 'o is_an_object = < .. > as 'o + and 'o abs constraint 'o = 'o is_an_object + val abs : 'o is_an_object -> 'o abs + val unabs : 'o abs -> 'o +end;; (* fails *) diff --git a/testsuite/tests/typing-misc/constraints.ml.reference b/testsuite/tests/typing-misc/constraints.ml.reference index fe5204400..83a3dc1f9 100644 --- a/testsuite/tests/typing-misc/constraints.ml.reference +++ b/testsuite/tests/typing-misc/constraints.ml.reference @@ -26,4 +26,9 @@ Error: This alias is bound to type 'a t = 'a but is used as an instance of type 'a The type variable 'a occurs inside 'a # val f : 'a t -> 'a -> bool = <fun> +# Characters 83-122: + and 'o abs constraint 'o = 'o is_an_object + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The definition of abs contains a cycle: + 'a is_an_object as 'a # diff --git a/testsuite/tests/typing-misc/labels.ml b/testsuite/tests/typing-misc/labels.ml index b0f0229a6..2d4b9d19d 100644 --- a/testsuite/tests/typing-misc/labels.ml +++ b/testsuite/tests/typing-misc/labels.ml @@ -1,4 +1,11 @@ (* PR#5835 *) - let f ~x = x + 1;; f ?x:0;; + +(* PR#6352 *) +let foo (f : unit -> unit) = ();; +let g ?x () = ();; +foo ((); g);; + +(* PR#5748 *) +foo (fun ?opt () -> ()) ;; (* fails *) diff --git a/testsuite/tests/typing-misc/labels.ml.principal.reference b/testsuite/tests/typing-misc/labels.ml.principal.reference index b76dcddc5..f8be126bb 100644 --- a/testsuite/tests/typing-misc/labels.ml.principal.reference +++ b/testsuite/tests/typing-misc/labels.ml.principal.reference @@ -1,8 +1,16 @@ -# val f : x:int -> int = <fun> +# val f : x:int -> int = <fun> # Characters 5-6: f ?x:0;; ^ Warning 43: the label x is not optional. - : int = 1 +# val foo : (unit -> unit) -> unit = <fun> +# val g : ?x:'a -> unit -> unit = <fun> +# - : unit = () +# Characters 19-38: + foo (fun ?opt () -> ()) ;; (* fails *) + ^^^^^^^^^^^^^^^^^^^ +Error: This function should have type unit -> unit + but its first argument is labelled ?opt # diff --git a/testsuite/tests/typing-misc/labels.ml.reference b/testsuite/tests/typing-misc/labels.ml.reference index b76dcddc5..f8be126bb 100644 --- a/testsuite/tests/typing-misc/labels.ml.reference +++ b/testsuite/tests/typing-misc/labels.ml.reference @@ -1,8 +1,16 @@ -# val f : x:int -> int = <fun> +# val f : x:int -> int = <fun> # Characters 5-6: f ?x:0;; ^ Warning 43: the label x is not optional. - : int = 1 +# val foo : (unit -> unit) -> unit = <fun> +# val g : ?x:'a -> unit -> unit = <fun> +# - : unit = () +# Characters 19-38: + foo (fun ?opt () -> ()) ;; (* fails *) + ^^^^^^^^^^^^^^^^^^^ +Error: This function should have type unit -> unit + but its first argument is labelled ?opt # diff --git a/testsuite/tests/typing-misc/variant.ml b/testsuite/tests/typing-misc/variant.ml new file mode 100644 index 000000000..b0bd52227 --- /dev/null +++ b/testsuite/tests/typing-misc/variant.ml @@ -0,0 +1,8 @@ +(* PR#6394 *) + +module rec X : sig + type t = int * bool +end = struct + type t = A | B + let f = function A | B -> 0 +end;; diff --git a/testsuite/tests/typing-misc/variant.ml.reference b/testsuite/tests/typing-misc/variant.ml.reference new file mode 100644 index 000000000..4de6b611e --- /dev/null +++ b/testsuite/tests/typing-misc/variant.ml.reference @@ -0,0 +1,16 @@ + +# Characters 61-116: + ......struct + type t = A | B + let f = function A | B -> 0 + end.. +Error: Signature mismatch: + Modules do not match: + sig type t = X.t = A | B val f : t -> int end + is not included in + sig type t = int * bool end + Type declarations do not match: + type t = X.t = A | B + is not included in + type t = int * bool +# diff --git a/testsuite/tests/typing-modules-bugs/pr6427_bad.ml b/testsuite/tests/typing-modules-bugs/pr6427_bad.ml new file mode 100644 index 000000000..286dafb88 --- /dev/null +++ b/testsuite/tests/typing-modules-bugs/pr6427_bad.ml @@ -0,0 +1,20 @@ +let flag = ref false +module F(S : sig module type T end) (A : S.T) (B : S.T) = +struct + module X = (val if !flag then (module A) else (module B) : S.T) +end + +(* If the above were accepted, one could break soundness *) +module type S = sig type t val x : t end +module Float = struct type t = float let x = 0.0 end +module Int = struct type t = int let x = 0 end + +module M = F(struct module type T = S end) + +let () = flag := false +module M1 = M(Float)(Int) + +let () = flag := true +module M2 = M(Float)(Int) + +let _ = [| M2.X.x; M1.X.x |] diff --git a/testsuite/tests/typing-modules-bugs/pr6513_ok.ml b/testsuite/tests/typing-modules-bugs/pr6513_ok.ml new file mode 100644 index 000000000..f23fc599a --- /dev/null +++ b/testsuite/tests/typing-modules-bugs/pr6513_ok.ml @@ -0,0 +1,25 @@ +module type PR6513 = sig +module type S = sig type u end + +module type T = sig + type 'a wrap + type uri +end + +module Make: functor (Html5 : T with type 'a wrap = 'a) -> + S with type u = < foo : Html5.uri > +end + +(* Requires -package tyxml +module type PR6513_orig = sig +module type S = +sig + type t + type u +end + +module Make: functor (Html5: Html5_sigs.T with type 'a Xml.wrap = 'a and type 'a wrap = 'a and type 'a list_wrap = 'a list) -> S with + type t = Html5_types.div Html5.elt and + type u = < foo: Html5.uri > +end +*) diff --git a/testsuite/tests/typing-modules/Test.ml b/testsuite/tests/typing-modules/Test.ml index e5cbe9f39..640655eb1 100644 --- a/testsuite/tests/typing-modules/Test.ml +++ b/testsuite/tests/typing-modules/Test.ml @@ -52,5 +52,11 @@ type u = X of bool;; module type B = A with type t = u;; (* fail *) (* PR#5815 *) +(* ---> duplicated exception name is now an error *) module type S = sig exception Foo of int exception Foo of bool end;; + +(* PR#6410 *) + +module F(X : sig end) = struct let x = 3 end;; +F.x;; (* fail *) diff --git a/testsuite/tests/typing-modules/Test.ml.principal.reference b/testsuite/tests/typing-modules/Test.ml.principal.reference index 8e993fa3a..9646d3d0a 100644 --- a/testsuite/tests/typing-modules/Test.ml.principal.reference +++ b/testsuite/tests/typing-modules/Test.ml.principal.reference @@ -28,5 +28,14 @@ Error: Signature mismatch: ^^^^^^^^^^ Error: This variant or record definition does not match that of type u The types for field X are not equal. -# module type S = sig exception Foo of bool end +# Characters 121-124: + module type S = sig exception Foo of int exception Foo of bool end;; + ^^^ +Error: Multiple definition of the extension constructor name Foo. + Names must be unique in a given structure or signature. +# module F : functor (X : sig end) -> sig val x : int end +# Characters 0-3: + F.x;; (* fail *) + ^^^ +Error: The module F is a functor, not a structure # diff --git a/testsuite/tests/typing-modules/Test.ml.reference b/testsuite/tests/typing-modules/Test.ml.reference index 8e993fa3a..9646d3d0a 100644 --- a/testsuite/tests/typing-modules/Test.ml.reference +++ b/testsuite/tests/typing-modules/Test.ml.reference @@ -28,5 +28,14 @@ Error: Signature mismatch: ^^^^^^^^^^ Error: This variant or record definition does not match that of type u The types for field X are not equal. -# module type S = sig exception Foo of bool end +# Characters 121-124: + module type S = sig exception Foo of int exception Foo of bool end;; + ^^^ +Error: Multiple definition of the extension constructor name Foo. + Names must be unique in a given structure or signature. +# module F : functor (X : sig end) -> sig val x : int end +# Characters 0-3: + F.x;; (* fail *) + ^^^ +Error: The module F is a functor, not a structure # diff --git a/testsuite/tests/typing-modules/aliases.ml b/testsuite/tests/typing-modules/aliases.ml index 0b7e7ae2b..3eca52714 100644 --- a/testsuite/tests/typing-modules/aliases.ml +++ b/testsuite/tests/typing-modules/aliases.ml @@ -4,11 +4,6 @@ C.chr 66;; module C' : module type of Char = C;; C'.chr 66;; -module C'' : (module C) = C';; (* fails *) - -module C'' : (module Char) = C;; -C''.chr 66;; - module C3 = struct include Char end;; C3.chr 66;; @@ -112,7 +107,7 @@ let f (x : t) : T.t = x ;; module A = struct module B = struct type t let compare x y = 0 end module S = Set.Make(B) - let empty = S.empty + let empty = S.empty end module A1 = A;; A1.empty = A.empty;; @@ -192,3 +187,51 @@ module M = struct end end;; module type S = module type of M ;; + +(* PR#6365 *) +module type S = sig module M : sig type t val x : t end end;; +module H = struct type t = A let x = A end;; +module H' = H;; +module type S' = S with module M = H';; (* shouldn't introduce an alias *) + +(* PR#6376 *) +module type Alias = sig module N : sig end module M = N end;; +module F (X : sig end) = struct type t end;; +module type A = Alias with module N := F(List);; +module rec Bad : A = Bad;; + +(* Shinwell 2014-04-23 *) +module B = struct + module R = struct + type t = string + end + + module O = R +end + +module K = struct + module E = B + module N = E.O +end;; + +let x : K.N.t = "foo";; + +(* PR#6465 *) + +module M = struct type t = A module B = struct type u = B end end;; +module P : sig type t = M.t = A module B = M.B end = M;; (* should be ok *) +module P : sig type t = M.t = A module B = M.B end = struct include M end;; + +module type S = sig + module M : sig module P : sig end end + module Q = M +end;; +module type S = sig + module M : sig module N : sig end module P : sig end end + module Q : sig module N = M.N module P = M.P end +end;; +module R = struct + module M = struct module N = struct end module P = struct end end + module Q = M +end;; +module R' : S = R;; (* should be ok *) diff --git a/testsuite/tests/typing-modules/aliases.ml.reference b/testsuite/tests/typing-modules/aliases.ml.reference index 730252b58..e6611acbb 100644 --- a/testsuite/tests/typing-modules/aliases.ml.reference +++ b/testsuite/tests/typing-modules/aliases.ml.reference @@ -13,13 +13,6 @@ external unsafe_chr : int -> char = "%identity" end # - : char = 'B' -# Characters 27-29: - module C'' : (module C) = C';; (* fails *) - ^^ -Error: Signature mismatch: - Modules do not match: (module C') is not included in (module C) -# module C'' = Char -# - : char = 'B' # module C3 : sig external code : char -> int = "%identity" @@ -347,4 +340,46 @@ Error: In this `with' constraint, the new definition of I module Q : sig type wrap' = wrap = W of (Set.Make(Int).t, Set.Make(N.I).t) eq end end +# module type S = sig module M : sig type t val x : t end end +# module H : sig type t = A val x : t end +# module H' = H +# module type S' = sig module M : sig type t = H.t = A val x : t end end +# module type Alias = sig module N : sig end module M = N end +# module F : functor (X : sig end) -> sig type t end +# Characters -1--1: + module type A = Alias with module N := F(List);; + +Error: Module type declarations do not match: + module type A = sig module M = F(List) end + does not match + module type A = sig module M = F(List) end + At position module type A = <here> + Modules do not match: + sig module M = F(List) end + is not included in + sig module M = F(List) end + At position module type A = sig module M : <here> end + Module F(List) cannot be aliased +# Characters 17-18: + module rec Bad : A = Bad;; + ^ +Error: Unbound module type A +# module B : sig module R : sig type t = string end module O = R end +module K : sig module E = B module N = E.O end +# val x : K.N.t = "foo" +# module M : sig type t = A module B : sig type u = B end end +# module P : sig type t = M.t = A module B = M.B end +# module P : sig type t = M.t = A module B = M.B end +# module type S = sig module M : sig module P : sig end end module Q = M end +# module type S = + sig + module M : sig module N : sig end module P : sig end end + module Q : sig module N = M.N module P = M.P end + end +# module R : + sig + module M : sig module N : sig end module P : sig end end + module Q = M + end +# module R' : S # diff --git a/testsuite/tests/typing-modules/generative.ml b/testsuite/tests/typing-modules/generative.ml index 2768aba61..dc5bf5289 100644 --- a/testsuite/tests/typing-modules/generative.ml +++ b/testsuite/tests/typing-modules/generative.ml @@ -27,7 +27,8 @@ module F4 : functor (X : sig end) -> sig end = F3;; (* fail *) (* tests for shortened functor notation () *) module X (X: sig end) (Y: sig end) = functor (Z: sig end) -> struct end;; -module Y = functor (X: sig end) (Y:sig end) -> functor (Z: sig end) -> struct end;; +module Y = functor (X: sig end) (Y:sig end) -> functor (Z: sig end) -> + struct end;; module Z = functor (_: sig end) (_:sig end) (_: sig end) -> struct end;; module GZ : functor (X: sig end) () (Z: sig end) -> sig end = functor (X: sig end) () (Z: sig end) -> struct end;; diff --git a/testsuite/tests/typing-modules/generative.ml.reference b/testsuite/tests/typing-modules/generative.ml.reference index 19aaa1284..a6aa10026 100644 --- a/testsuite/tests/typing-modules/generative.ml.reference +++ b/testsuite/tests/typing-modules/generative.ml.reference @@ -38,7 +38,7 @@ Error: Signature mismatch: is not included in functor (X : sig end) -> sig end # module X : functor (X : sig end) (Y : sig end) (Z : sig end) -> sig end -# module Y : functor (X : sig end) (Y : sig end) (Z : sig end) -> sig end +# module Y : functor (X : sig end) (Y : sig end) (Z : sig end) -> sig end # module Z : functor (_ : sig end) (_ : sig end) (_ : sig end) -> sig end # module GZ : functor (X : sig end) () (Z : sig end) -> sig end # diff --git a/testsuite/tests/typing-objects/Exemples.ml b/testsuite/tests/typing-objects/Exemples.ml index ba3e64f01..5ffc6498f 100644 --- a/testsuite/tests/typing-objects/Exemples.ml +++ b/testsuite/tests/typing-objects/Exemples.ml @@ -170,14 +170,14 @@ p1#print (fun x -> x#print);; (*******************************************************************) class virtual comparable () = object (self : 'a) - method virtual leq : 'a -> bool + method virtual cmp : 'a -> int end;; class int_comparable (x : int) = object inherit comparable () val x = x method x = x - method leq p = x <= p#x + method cmp p = compare x p#x end;; class int_comparable2 xi = object @@ -193,7 +193,7 @@ class ['a] sorted_list () = object let rec insert = function [] -> [x] - | a::l as l' -> if a#leq x then a::(insert l) else x::l' + | a::l as l' -> if a#cmp x <= 0 then a::(insert l) else x::l' in l <- insert l method hd = List.hd l @@ -209,7 +209,7 @@ l#add (c2 :> int_comparable);; (* Echec : 'a comp2 n'est un sous-type *) class int_comparable3 (x : int) = object val mutable x = x - method leq (y : int_comparable) = x < y#x + method cmp (y : int_comparable) = compare x y#x method x = x method setx y = x <- y end;; @@ -218,7 +218,7 @@ let c3 = new int_comparable3 15;; l#add (c3 :> int_comparable);; (new sorted_list ())#add c3;; (* Error; strange message with -principal *) -let sort (l : #comparable list) = Sort.list (fun x -> x#leq) l;; +let sort (l : #comparable list) = List.sort (fun x -> x#cmp) l;; let pr l = List.map (fun c -> print_int c#x; print_string " ") l; print_newline ();; @@ -231,7 +231,7 @@ pr l;; pr (sort l);; let min (x : #comparable) y = - if x#leq y then x else y;; + if x#cmp y <= 0 then x else y;; (min (new int_comparable 7) (new int_comparable 11))#x;; (min (new int_comparable2 5) (new int_comparable2 3))#x;; diff --git a/testsuite/tests/typing-objects/Exemples.ml.principal.reference b/testsuite/tests/typing-objects/Exemples.ml.principal.reference index 0b04607a2..2b12a7d9b 100644 --- a/testsuite/tests/typing-objects/Exemples.ml.principal.reference +++ b/testsuite/tests/typing-objects/Exemples.ml.principal.reference @@ -183,15 +183,15 @@ and ['a] cons : # val p1 : printable_color_point lst = <obj> # ((3, red)::(10, red)::[])- : unit = () # class virtual comparable : - unit -> object ('a) method virtual leq : 'a -> bool end + unit -> object ('a) method virtual cmp : 'a -> int end # class int_comparable : - int -> object ('a) val x : int method leq : 'a -> bool method x : int end + int -> object ('a) val x : int method cmp : 'a -> int method x : int end # class int_comparable2 : int -> object ('a) val x : int val mutable x' : int - method leq : 'a -> bool + method cmp : 'a -> int method set_x : int -> unit method x : int end @@ -212,19 +212,19 @@ and ['a] cons : ^^^^^^^^^^^^^^^^^^^^^^ Error: Type int_comparable2 = - < leq : int_comparable2 -> bool; set_x : int -> unit; x : int > + < cmp : int_comparable2 -> int; set_x : int -> unit; x : int > is not a subtype of - int_comparable = < leq : int_comparable -> bool; x : int > - Type int_comparable = < leq : int_comparable -> bool; x : int > + int_comparable = < cmp : int_comparable -> int; x : int > + Type int_comparable = < cmp : int_comparable -> int; x : int > is not a subtype of int_comparable2 = - < leq : int_comparable2 -> bool; set_x : int -> unit; x : int > + < cmp : int_comparable2 -> int; set_x : int -> unit; x : int > # - : unit = () # class int_comparable3 : int -> object val mutable x : int - method leq : int_comparable -> bool + method cmp : int_comparable -> int method setx : int -> unit method x : int end @@ -235,11 +235,11 @@ Error: Type ^^ Error: This expression has type int_comparable3 = - < leq : int_comparable -> bool; setx : int -> unit; x : int > + < cmp : int_comparable -> int; setx : int -> unit; x : int > but an expression was expected of type - #comparable as 'a = < leq : 'a -> bool; .. > - Type int_comparable = < leq : int_comparable -> bool; x : int > - is not compatible with type 'a = < leq : 'a -> bool; .. > + #comparable as 'a = < cmp : 'a -> int; .. > + Type int_comparable = < cmp : int_comparable -> int; x : int > + is not compatible with type 'a = < cmp : 'a -> int; .. > The first object type has no method setx # val sort : (#comparable as 'a) list -> 'a list = <fun> # Characters 13-66: diff --git a/testsuite/tests/typing-objects/Exemples.ml.reference b/testsuite/tests/typing-objects/Exemples.ml.reference index 353f607cb..7cbd68ec2 100644 --- a/testsuite/tests/typing-objects/Exemples.ml.reference +++ b/testsuite/tests/typing-objects/Exemples.ml.reference @@ -183,15 +183,15 @@ and ['a] cons : # val p1 : printable_color_point lst = <obj> # ((3, red)::(10, red)::[])- : unit = () # class virtual comparable : - unit -> object ('a) method virtual leq : 'a -> bool end + unit -> object ('a) method virtual cmp : 'a -> int end # class int_comparable : - int -> object ('a) val x : int method leq : 'a -> bool method x : int end + int -> object ('a) val x : int method cmp : 'a -> int method x : int end # class int_comparable2 : int -> object ('a) val x : int val mutable x' : int - method leq : 'a -> bool + method cmp : 'a -> int method set_x : int -> unit method x : int end @@ -212,19 +212,19 @@ and ['a] cons : ^^^^^^^^^^^^^^^^^^^^^^ Error: Type int_comparable2 = - < leq : int_comparable2 -> bool; set_x : int -> unit; x : int > + < cmp : int_comparable2 -> int; set_x : int -> unit; x : int > is not a subtype of - int_comparable = < leq : int_comparable -> bool; x : int > - Type int_comparable = < leq : int_comparable -> bool; x : int > + int_comparable = < cmp : int_comparable -> int; x : int > + Type int_comparable = < cmp : int_comparable -> int; x : int > is not a subtype of int_comparable2 = - < leq : int_comparable2 -> bool; set_x : int -> unit; x : int > + < cmp : int_comparable2 -> int; set_x : int -> unit; x : int > # - : unit = () # class int_comparable3 : int -> object val mutable x : int - method leq : int_comparable -> bool + method cmp : int_comparable -> int method setx : int -> unit method x : int end @@ -235,13 +235,13 @@ Error: Type ^^ Error: This expression has type int_comparable3 = - < leq : int_comparable -> bool; setx : int -> unit; x : int > + < cmp : int_comparable -> int; setx : int -> unit; x : int > but an expression was expected of type - #comparable as 'a = < leq : 'a -> bool; .. > - Type int_comparable = < leq : int_comparable -> bool; x : int > + #comparable as 'a = < cmp : 'a -> int; .. > + Type int_comparable = < cmp : int_comparable -> int; x : int > is not compatible with type int_comparable3 = - < leq : int_comparable -> bool; setx : int -> unit; x : int > + < cmp : int_comparable -> int; setx : int -> unit; x : int > The first object type has no method setx # val sort : (#comparable as 'a) list -> 'a list = <fun> # Characters 13-66: diff --git a/testsuite/tests/typing-objects/Tests.ml b/testsuite/tests/typing-objects/Tests.ml index befd70d94..917474f96 100644 --- a/testsuite/tests/typing-objects/Tests.ml +++ b/testsuite/tests/typing-objects/Tests.ml @@ -236,7 +236,7 @@ end;; let d = new d () in d#xc, d#xd;; class virtual ['a] matrix (sz, init : int * 'a) = object - val m = Array.create_matrix sz sz init + val m = Array.make_matrix sz sz init method add (mtx : 'a matrix) = (mtx#m.(0).(0) : 'a) end;; @@ -305,26 +305,28 @@ class c () = object method virtual m : int method private m = 1 end;; (* Marshaling (cf. PR#5436) *) -Oo.id (object end);; -Oo.id (object end);; -Oo.id (object end);; +let r = ref 0;; +let id o = Oo.id o - !r;; +r := Oo.id (object end);; +id (object end);; +id (object end);; let o = object end in let s = Marshal.to_string o [] in let o' : < > = Marshal.from_string s 0 in let o'' : < > = Marshal.from_string s 0 in - (Oo.id o, Oo.id o', Oo.id o'');; + (id o, id o', id o'');; let o = object val x = 33 method m = x end in let s = Marshal.to_string o [Marshal.Closures] in let o' : <m:int> = Marshal.from_string s 0 in let o'' : <m:int> = Marshal.from_string s 0 in - (Oo.id o, Oo.id o', Oo.id o'', o#m, o'#m);; + (id o, id o', id o'', o#m, o'#m);; let o = object val x = 33 val y = 44 method m = x end in - let s = Marshal.to_string o [Marshal.Closures] in - let o' : <m:int> = Marshal.from_string s 0 in - let o'' : <m:int> = Marshal.from_string s 0 in - (Oo.id o, Oo.id o', Oo.id o'', o#m, o'#m);; + let s = Marshal.to_string (o,o) [Marshal.Closures] in + let (o1, o2) : (<m:int> * <m:int>) = Marshal.from_string s 0 in + let (o3, o4) : (<m:int> * <m:int>) = Marshal.from_string s 0 in + (id o, id o1, id o2, id o3, id o4, o#m, o1#m);; (* Recursion (cf. PR#5291) *) diff --git a/testsuite/tests/typing-objects/Tests.ml.principal.reference b/testsuite/tests/typing-objects/Tests.ml.principal.reference index 76ade6755..e5d9bb8d5 100644 --- a/testsuite/tests/typing-objects/Tests.ml.principal.reference +++ b/testsuite/tests/typing-objects/Tests.ml.principal.reference @@ -217,9 +217,9 @@ class e : # * * * * * * * * * * * * * * * * * * * * * module M : sig class c : unit -> object method xc : int end end # class d : unit -> object val x : int method xc : int method xd : int end # - : int * int = (1, 2) -# Characters 7-156: +# Characters 7-154: ......virtual ['a] matrix (sz, init : int * 'a) = object - val m = Array.create_matrix sz sz init + val m = Array.make_matrix sz sz init method add (mtx : 'a matrix) = (mtx#m.(0).(0) : 'a) end.. Error: The abbreviation 'a matrix expands to type < add : 'a matrix -> 'a > @@ -244,9 +244,9 @@ Error: Signature mismatch: val f : (#c as 'a) -> 'a is not included in val f : #c -> #c -# Characters 32-55: +# Characters 38-39: module M = struct type t = int class t () = object end end;; - ^^^^^^^^^^^^^^^^^^^^^^^ + ^ Error: Multiple definition of the type name t. Names must be unique in a given structure or signature. # - : < m : (< m : 'a > as 'b) -> 'b as 'a; .. > -> 'b = <fun> @@ -295,12 +295,14 @@ Warning 10: this expression should have type unit. unit -> object method private m : int method n : int method o : int end # - : int * int = (1, 1) # class c : unit -> object method m : int end -# - : int = 95 -# - : int = 96 -# - : int = 97 -# - : int * int * int = (98, 99, 100) -# - : int * int * int * int * int = (101, 102, 103, 33, 33) -# - : int * int * int * int * int = (104, 105, 106, 33, 33) +# val r : int ref = {contents = 0} +# val id : < .. > -> int = <fun> +# - : unit = () +# - : int = 1 +# - : int = 2 +# - : int * int * int = (3, 4, 5) +# - : int * int * int * int * int = (6, 7, 8, 33, 33) +# - : int * int * int * int * int * int * int = (9, 10, 10, 11, 11, 33, 33) # Characters 42-69: class a = let _ = new b in object end ^^^^^^^^^^^^^^^^^^^^^^^^^^^ diff --git a/testsuite/tests/typing-objects/Tests.ml.reference b/testsuite/tests/typing-objects/Tests.ml.reference index 97ed42ca7..ed4df922d 100644 --- a/testsuite/tests/typing-objects/Tests.ml.reference +++ b/testsuite/tests/typing-objects/Tests.ml.reference @@ -217,9 +217,9 @@ class e : # * * * * * * * * * * * * * * * * * * * * * module M : sig class c : unit -> object method xc : int end end # class d : unit -> object val x : int method xc : int method xd : int end # - : int * int = (1, 2) -# Characters 7-156: +# Characters 7-154: ......virtual ['a] matrix (sz, init : int * 'a) = object - val m = Array.create_matrix sz sz init + val m = Array.make_matrix sz sz init method add (mtx : 'a matrix) = (mtx#m.(0).(0) : 'a) end.. Error: The abbreviation 'a matrix expands to type < add : 'a matrix -> 'a > @@ -244,9 +244,9 @@ Error: Signature mismatch: val f : (#c as 'a) -> 'a is not included in val f : #c -> #c -# Characters 32-55: +# Characters 38-39: module M = struct type t = int class t () = object end end;; - ^^^^^^^^^^^^^^^^^^^^^^^ + ^ Error: Multiple definition of the type name t. Names must be unique in a given structure or signature. # - : < m : (< m : 'a > as 'b) -> 'b as 'a; .. > -> 'b = <fun> @@ -294,12 +294,14 @@ Warning 10: this expression should have type unit. unit -> object method private m : int method n : int method o : int end # - : int * int = (1, 1) # class c : unit -> object method m : int end -# - : int = 95 -# - : int = 96 -# - : int = 97 -# - : int * int * int = (98, 99, 100) -# - : int * int * int * int * int = (101, 102, 103, 33, 33) -# - : int * int * int * int * int = (104, 105, 106, 33, 33) +# val r : int ref = {contents = 0} +# val id : < .. > -> int = <fun> +# - : unit = () +# - : int = 1 +# - : int = 2 +# - : int * int * int = (3, 4, 5) +# - : int * int * int * int * int = (6, 7, 8, 33, 33) +# - : int * int * int * int * int * int * int = (9, 10, 10, 11, 11, 33, 33) # Characters 42-69: class a = let _ = new b in object end ^^^^^^^^^^^^^^^^^^^^^^^^^^^ diff --git a/testsuite/tests/typing-objects/pr6383.ml b/testsuite/tests/typing-objects/pr6383.ml new file mode 100644 index 000000000..bd2fdb06f --- /dev/null +++ b/testsuite/tests/typing-objects/pr6383.ml @@ -0,0 +1 @@ +let f (x: #M.foo) = 0;; diff --git a/testsuite/tests/typing-objects/pr6383.ml.reference b/testsuite/tests/typing-objects/pr6383.ml.reference new file mode 100644 index 000000000..01b6141d3 --- /dev/null +++ b/testsuite/tests/typing-objects/pr6383.ml.reference @@ -0,0 +1,6 @@ + +# Characters 10-16: + let f (x: #M.foo) = 0;; + ^^^^^^ +Error: Unbound module M +# diff --git a/testsuite/tests/typing-private/private.ml.principal.reference b/testsuite/tests/typing-private/private.ml.principal.reference index 03e795701..96b1d7595 100644 --- a/testsuite/tests/typing-private/private.ml.principal.reference +++ b/testsuite/tests/typing-private/private.ml.principal.reference @@ -107,7 +107,7 @@ Error: Cannot create values of the private type Test2.t # * Characters 148-171: module Test2 : module type of Test with type t = private Test.t = Test;; ^^^^^^^^^^^^^^^^^^^^^^^ -Warning 3: deprecated feature: spurious use of private +Warning 3: deprecated: spurious use of private module Test2 : sig type t = Test.t = private A end # type t = private < x : int; .. > # type t = private < x : int; .. > diff --git a/testsuite/tests/typing-private/private.ml.reference b/testsuite/tests/typing-private/private.ml.reference index 360940c92..cb1573ed4 100644 --- a/testsuite/tests/typing-private/private.ml.reference +++ b/testsuite/tests/typing-private/private.ml.reference @@ -107,7 +107,7 @@ Error: Cannot create values of the private type Test2.t # * Characters 148-171: module Test2 : module type of Test with type t = private Test.t = Test;; ^^^^^^^^^^^^^^^^^^^^^^^ -Warning 3: deprecated feature: spurious use of private +Warning 3: deprecated: spurious use of private module Test2 : sig type t = Test.t = private A end # type t = private < x : int; .. > # type t = private < x : int; .. > diff --git a/testsuite/tests/typing-recordarg/recordarg.ml b/testsuite/tests/typing-recordarg/recordarg.ml new file mode 100644 index 000000000..82fad0783 --- /dev/null +++ b/testsuite/tests/typing-recordarg/recordarg.ml @@ -0,0 +1,86 @@ +type t = A of {x:int; mutable y:int};; +let f (A r) = r;; (* -> escape *) +let f (A r) = r.x;; (* ok *) +let f x = A {x; y = x};; (* ok *) +let f (A r) = A {r with y = r.x + 1};; (* ok *) +let f () = A {a = 1};; (* customized error message *) +let f () = A {x = 1; y = 3};; (* ok *) + +type _ t = A: {x : 'a; y : 'b} -> 'a t;; +let f (A {x; y}) = A {x; y = ()};; (* ok *) +let f (A ({x; y} as r)) = A {x = r.x; y = r.y};; (* ok *) + +module M = struct + type 'a t = + | A of {x : 'a} + | B: {u : 'b} -> unit t;; + + exception Foo of {x : int};; +end;; + +module N : sig + type 'b t = 'b M.t = + | A of {x : 'b} + | B: {u : 'bla} -> unit t + + exception Foo of {x : int} +end = struct + type 'b t = 'b M.t = + | A of {x : 'b} + | B: {u : 'z} -> unit t + + exception Foo = M.Foo +end;; + + +module type S = sig exception A of {x:int} end;; + +module F (X : sig val x : (module S) end) = struct + module A = (val X.x) +end;; (* -> this expression creates fresh types (not really!) *) + + +module type S = sig + exception A of {x : int} + exception A of {x : string} +end;; + +module M = struct + exception A of {x : int} + exception A of {x : string} +end;; + + +module M1 = struct + exception A of {x : int} +end;; + +module M = struct + include M1 + include M1 +end;; + + +module type S1 = sig + exception A of {x : int} +end;; + +module type S = sig + include S1 + include S1 +end;; + +module M = struct + exception A = M1.A +end;; + +module X1 = struct + type t = .. +end;; +module X2 = struct + type t = .. +end;; +module Z = struct + type X1.t += A of {x: int} + type X2.t += A of {x: int} +end;; diff --git a/testsuite/tests/typing-recordarg/recordarg.ml.reference b/testsuite/tests/typing-recordarg/recordarg.ml.reference index 96198167a..12f609aca 100644 --- a/testsuite/tests/typing-recordarg/recordarg.ml.reference +++ b/testsuite/tests/typing-recordarg/recordarg.ml.reference @@ -1,8 +1,64 @@ -# module M : +# type t = A of { x : int; mutable y : int; } +# Characters 14-15: + let f (A r) = r;; (* -> escape *) + ^ +Error: This form is not allowed as the type of the inlined record could escape. +# val f : t -> int = <fun> +# val f : int -> t = <fun> +# val f : t -> t = <fun> +# Characters 14-15: + let f () = A {a = 1};; (* customized error message *) + ^ +Error: The field a is not part of the record argument for the t.A constructor +# val f : unit -> t = <fun> +# type _ t = A : { x : 'a; y : 'b; } -> 'a t +# val f : 'a t -> 'a t = <fun> +# val f : 'a t -> 'a t = <fun> +# module M : sig type 'a t = A of { x : 'a; } | B : { u : 'b; } -> unit t exception Foo of { x : int; } end -# module N : sig exception Foo of { x : int; } end +# module N : + sig + type 'b t = 'b M.t = A of { x : 'b; } | B : { u : 'bla; } -> unit t + exception Foo of { x : int; } + end +# module type S = sig exception A of { x : int; } end +# Characters 65-74: + module A = (val X.x) + ^^^^^^^^^ +Error: This expression creates fresh types. + It is not allowed inside applicative functors. +# Characters 61-62: + exception A of {x : string} + ^ +Error: Multiple definition of the extension constructor name A. + Names must be unique in a given structure or signature. +# Characters 58-59: + exception A of {x : string} + ^ +Error: Multiple definition of the extension constructor name A. + Names must be unique in a given structure or signature. +# module M1 : sig exception A of { x : int; } end +# Characters 34-44: + include M1 + ^^^^^^^^^^ +Error: Multiple definition of the extension constructor name A. + Names must be unique in a given structure or signature. +# module type S1 = sig exception A of { x : int; } end +# Characters 36-46: + include S1 + ^^^^^^^^^^ +Error: Multiple definition of the extension constructor name A. + Names must be unique in a given structure or signature. +# module M : sig exception A of { x : int; } end +# module X1 : sig type t = .. end +# module X2 : sig type t = .. end +# Characters 62-63: + type X2.t += A of {x: int} + ^ +Error: Multiple definition of the extension constructor name A. + Names must be unique in a given structure or signature. # diff --git a/testsuite/tests/typing-signatures/pr6371.ml b/testsuite/tests/typing-signatures/pr6371.ml new file mode 100644 index 000000000..d717b9e68 --- /dev/null +++ b/testsuite/tests/typing-signatures/pr6371.ml @@ -0,0 +1,7 @@ +module M = struct + type t = int * (< m : 'a > as 'a) +end;; + +module type S = + sig module M : sig type t end end with module M = M +;; diff --git a/testsuite/tests/typing-signatures/pr6371.ml.reference b/testsuite/tests/typing-signatures/pr6371.ml.reference new file mode 100644 index 000000000..d6d916a71 --- /dev/null +++ b/testsuite/tests/typing-signatures/pr6371.ml.reference @@ -0,0 +1,4 @@ + +# module M : sig type t = int * (< m : 'a > as 'a) end +# module type S = sig module M : sig type t = int * (< m : 'a > as 'a) end end +# diff --git a/testsuite/tests/typing-warnings/coercions.ml b/testsuite/tests/typing-warnings/coercions.ml new file mode 100644 index 000000000..1ca390b28 --- /dev/null +++ b/testsuite/tests/typing-warnings/coercions.ml @@ -0,0 +1,5 @@ +(* comment 9644 of PR#6000 *) + +fun b -> if b then format_of_string "x" else "y";; +fun b -> if b then "x" else format_of_string "y";; +fun b -> (if b then "x" else "y" : (_,_,_) format);; diff --git a/testsuite/tests/typing-warnings/coercions.ml.principal.reference b/testsuite/tests/typing-warnings/coercions.ml.principal.reference new file mode 100644 index 000000000..d5397bf05 --- /dev/null +++ b/testsuite/tests/typing-warnings/coercions.ml.principal.reference @@ -0,0 +1,15 @@ + +# Characters 76-79: + fun b -> if b then format_of_string "x" else "y";; + ^^^ +Warning 18: this coercion to format6 is not principal. +- : bool -> ('a, 'b, 'c, 'd, 'd, 'a) format6 = <fun> +# Characters 28-48: + fun b -> if b then "x" else format_of_string "y";; + ^^^^^^^^^^^^^^^^^^^^ +Error: This expression has type + ('a, 'b, 'c, 'd, 'd, 'a) format6 = + ('a, 'b, 'c, 'd, 'd, 'a) CamlinternalFormatBasics.format6 + but an expression was expected of type string +# - : bool -> ('a, 'b, 'a) format = <fun> +# diff --git a/testsuite/tests/typing-warnings/coercions.ml.reference b/testsuite/tests/typing-warnings/coercions.ml.reference new file mode 100644 index 000000000..f44213051 --- /dev/null +++ b/testsuite/tests/typing-warnings/coercions.ml.reference @@ -0,0 +1,11 @@ + +# - : bool -> ('a, 'b, 'c, 'd, 'd, 'a) format6 = <fun> +# Characters 28-48: + fun b -> if b then "x" else format_of_string "y";; + ^^^^^^^^^^^^^^^^^^^^ +Error: This expression has type + ('a, 'b, 'c, 'd, 'd, 'a) format6 = + ('a, 'b, 'c, 'd, 'd, 'a) CamlinternalFormatBasics.format6 + but an expression was expected of type string +# - : bool -> ('a, 'b, 'a) format = <fun> +# diff --git a/testsuite/typing b/testsuite/typing index ff3818c1c..4357fdf3c 100644 --- a/testsuite/typing +++ b/testsuite/typing @@ -1,3 +1,13 @@ +tests/basic +tests/basic-float +tests/basic-io +tests/basic-io-2 +tests/basic-manyargs +tests/basic-modules +tests/basic-more +tests/basic-multdef +tests/basic-private +tests/typing-extensions tests/typing-fstclassmod tests/typing-gadts tests/typing-implicit_unpack diff --git a/tools/.depend b/tools/.depend index a058ee37f..b0407009d 100644 --- a/tools/.depend +++ b/tools/.depend @@ -28,25 +28,25 @@ depend.cmx : ../parsing/parsetree.cmi ../utils/misc.cmx \ ../parsing/longident.cmx ../parsing/location.cmx ../parsing/asttypes.cmi \ depend.cmi dumpobj.cmo : ../utils/tbl.cmi opnames.cmo ../bytecomp/opcodes.cmo \ - ../utils/misc.cmi ../parsing/location.cmi ../bytecomp/lambda.cmi \ - ../bytecomp/instruct.cmi ../typing/ident.cmi ../utils/config.cmi \ - ../bytecomp/cmo_format.cmi ../bytecomp/bytesections.cmi \ - ../parsing/asttypes.cmi + ../parsing/location.cmi ../bytecomp/lambda.cmi ../bytecomp/instruct.cmi \ + ../typing/ident.cmi ../utils/config.cmi ../bytecomp/cmo_format.cmi \ + ../bytecomp/bytesections.cmi ../parsing/asttypes.cmi dumpobj.cmx : ../utils/tbl.cmx opnames.cmx ../bytecomp/opcodes.cmx \ - ../utils/misc.cmx ../parsing/location.cmx ../bytecomp/lambda.cmx \ - ../bytecomp/instruct.cmx ../typing/ident.cmx ../utils/config.cmx \ - ../bytecomp/cmo_format.cmi ../bytecomp/bytesections.cmx \ - ../parsing/asttypes.cmi + ../parsing/location.cmx ../bytecomp/lambda.cmx ../bytecomp/instruct.cmx \ + ../typing/ident.cmx ../utils/config.cmx ../bytecomp/cmo_format.cmi \ + ../bytecomp/bytesections.cmx ../parsing/asttypes.cmi eqparsetree.cmo : ../parsing/parsetree.cmi ../parsing/longident.cmi \ ../parsing/location.cmi ../parsing/asttypes.cmi eqparsetree.cmx : ../parsing/parsetree.cmi ../parsing/longident.cmx \ ../parsing/location.cmx ../parsing/asttypes.cmi objinfo.cmo : ../asmcomp/printclambda.cmi ../utils/misc.cmi \ - ../utils/config.cmi ../asmcomp/cmx_format.cmi ../bytecomp/cmo_format.cmi \ - ../typing/cmi_format.cmi ../bytecomp/bytesections.cmi + ../utils/config.cmi ../asmcomp/cmx_format.cmi ../typing/cmt_format.cmi \ + ../bytecomp/cmo_format.cmi ../typing/cmi_format.cmi \ + ../bytecomp/bytesections.cmi objinfo.cmx : ../asmcomp/printclambda.cmx ../utils/misc.cmx \ - ../utils/config.cmx ../asmcomp/cmx_format.cmi ../bytecomp/cmo_format.cmi \ - ../typing/cmi_format.cmx ../bytecomp/bytesections.cmx + ../utils/config.cmx ../asmcomp/cmx_format.cmi ../typing/cmt_format.cmx \ + ../bytecomp/cmo_format.cmi ../typing/cmi_format.cmx \ + ../bytecomp/bytesections.cmx ocaml299to3.cmo : ocaml299to3.cmx : ocamlcp.cmo : ../driver/main_args.cmi diff --git a/tools/.ignore b/tools/.ignore index ce14846de..94fac02fb 100644 --- a/tools/.ignore +++ b/tools/.ignore @@ -18,11 +18,10 @@ keywords lexer299.ml ocaml299to3 ocamlmklib -ocamlmklib.ml +ocamlmklibconfig.ml lexer301.ml scrapelabels addlabels -myocamlbuild_config.ml objinfo_helper read_cmt read_cmt.opt diff --git a/tools/Makefile b/tools/Makefile index e2f3cb26e..b5cc10109 100644 --- a/tools/Makefile +++ b/tools/Makefile @@ -19,7 +19,7 @@ ocamlmktop: ocamlmktop.tpl ../config/Makefile chmod +x ocamlmktop install:: - cp ocamlmktop $(BINDIR) + cp ocamlmktop $(INSTALL_BINDIR) clean:: rm -f ocamlmktop diff --git a/tools/Makefile.nt b/tools/Makefile.nt index 052af81c2..ed9b35946 100644 --- a/tools/Makefile.nt +++ b/tools/Makefile.nt @@ -21,7 +21,7 @@ ocamlmktop: $(OCAMLMKTOP) $(CAMLC) $(LINKFLAGS) -o ocamlmktop $(OCAMLMKTOP_IMPORTS) $(OCAMLMKTOP) install:: - cp ocamlmktop $(BINDIR)/ocamlmktop$(EXE) + cp ocamlmktop $(INSTALL_BINDIR)/ocamlmktop$(EXE) clean:: rm -f ocamlmktop$(EXE) diff --git a/tools/Makefile.shared b/tools/Makefile.shared index 39be1db4e..251743449 100644 --- a/tools/Makefile.shared +++ b/tools/Makefile.shared @@ -13,12 +13,12 @@ include ../config/Makefile CAMLRUN=../boot/ocamlrun -CAMLC=$(CAMLRUN) ../boot/ocamlc -strict-sequence -nostdlib -I ../boot +CAMLC=$(CAMLRUN) ../boot/ocamlc -nostdlib -I ../boot CAMLOPT=$(CAMLRUN) ../ocamlopt -nostdlib -I ../stdlib CAMLLEX=$(CAMLRUN) ../boot/ocamllex INCLUDES=-I ../utils -I ../parsing -I ../typing -I ../bytecomp -I ../asmcomp \ -I ../driver -I ../toplevel -COMPFLAGS= -w +32..39 -warn-error A $(INCLUDES) +COMPFLAGS= -strict-sequence -w +27+32..39 -warn-error A -safe-string $(INCLUDES) LINKFLAGS=$(INCLUDES) all: ocamldep ocamlprof ocamlcp ocamloptp ocamlmktop ocamlmklib dumpobj \ @@ -39,7 +39,7 @@ CAMLDEP_OBJ=depend.cmo ocamldep.cmo CAMLDEP_IMPORTS=misc.cmo config.cmo clflags.cmo terminfo.cmo \ warnings.cmo location.cmo longident.cmo \ syntaxerr.cmo ast_helper.cmo parser.cmo lexer.cmo parse.cmo \ - ccomp.cmo pparse.cmo compenv.cmo + ccomp.cmo ast_mapper.cmo pparse.cmo compenv.cmo ocamldep: depend.cmi $(CAMLDEP_OBJ) $(CAMLC) $(LINKFLAGS) -compat-32 -o ocamldep $(CAMLDEP_IMPORTS) $(CAMLDEP_OBJ) @@ -54,10 +54,14 @@ clean:: if test -f ocamldep; then mv -f ocamldep ocamldep.bak; else :; fi rm -f ocamldep.opt + +INSTALL_BINDIR=$(DESTDIR)$(BINDIR) +INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR) + install:: - cp ocamldep $(BINDIR)/ocamldep$(EXE) + cp ocamldep $(INSTALL_BINDIR)/ocamldep$(EXE) if test -f ocamldep.opt; \ - then cp ocamldep.opt $(BINDIR)/ocamldep.opt$(EXE); else :; fi + then cp ocamldep.opt $(INSTALL_BINDIR)/ocamldep.opt$(EXE); else :; fi # The profiler @@ -79,13 +83,13 @@ ocamloptp: ocamloptp.cmo opt:: profiling.cmx install:: - cp ocamlprof $(BINDIR)/ocamlprof$(EXE) - cp ocamlcp $(BINDIR)/ocamlcp$(EXE) - cp ocamloptp $(BINDIR)/ocamloptp$(EXE) - cp profiling.cmi profiling.cmo $(LIBDIR) + cp ocamlprof $(INSTALL_BINDIR)/ocamlprof$(EXE) + cp ocamlcp $(INSTALL_BINDIR)/ocamlcp$(EXE) + cp ocamloptp $(INSTALL_BINDIR)/ocamloptp$(EXE) + cp profiling.cmi profiling.cmo $(INSTALL_LIBDIR) installopt:: - cp profiling.cmx profiling.o $(LIBDIR) + cp profiling.cmx profiling.$(O) $(INSTALL_LIBDIR) clean:: rm -f ocamlprof ocamlcp ocamloptp @@ -97,7 +101,7 @@ ocamlmklib: ocamlmklibconfig.cmo ocamlmklib.cmo $(CAMLC) $(LINKFLAGS) -o ocamlmklib ocamlmklibconfig.cmo ocamlmklib.cmo install:: - cp ocamlmklib $(BINDIR)/ocamlmklib$(EXE) + cp ocamlmklib $(INSTALL_BINDIR)/ocamlmklib$(EXE) clean:: rm -f ocamlmklib @@ -132,7 +136,7 @@ lexer299.ml: lexer299.mll $(CAMLLEX) lexer299.mll #install:: -# cp ocaml299to3 $(BINDIR)/ocaml299to3$(EXE) +# cp ocaml299to3 $(INSTALL_BINDIR)/ocaml299to3$(EXE) clean:: rm -f ocaml299to3 lexer299.ml @@ -148,7 +152,7 @@ lexer301.ml: lexer301.mll $(CAMLLEX) lexer301.mll #install:: -# cp scrapelabels $(LIBDIR) +# cp scrapelabels $(INSTALL_LIBDIR) clean:: rm -f scrapelabels lexer301.ml @@ -164,7 +168,7 @@ addlabels: addlabels.cmo $(ADDLABELS_IMPORTS) addlabels.cmo #install:: -# cp addlabels $(LIBDIR) +# cp addlabels $(INSTALL_LIBDIR) clean:: rm -f addlabels @@ -260,7 +264,7 @@ opnames.ml: ../byterun/instruct.h sed -e '/\/\*/d' \ -e '/^#/d' \ -e 's/enum \(.*\) {/let names_of_\1 = [|/' \ - -e 's/};$$/ |]/' \ + -e 's/.*};$$/ |]/' \ -e 's/\([A-Z][A-Z_0-9a-z]*\)/"\1"/g' \ -e 's/,/;/g' \ ../byterun/instruct.h > opnames.ml @@ -285,8 +289,8 @@ objinfo: objinfo_helper$(EXE) $(OBJINFO) $(CAMLC) -o objinfo $(OBJINFO) install:: - cp objinfo $(BINDIR)/ocamlobjinfo$(EXE) - cp objinfo_helper$(EXE) $(LIBDIR)/objinfo_helper$(EXE) + cp objinfo $(INSTALL_BINDIR)/ocamlobjinfo$(EXE) + cp objinfo_helper$(EXE) $(INSTALL_LIBDIR)/objinfo_helper$(EXE) clean:: rm -f objinfo objinfo_helper$(EXE) diff --git a/tools/check-typo b/tools/check-typo index 05c7c68c0..bd48dc7a3 100755 --- a/tools/check-typo +++ b/tools/check-typo @@ -23,6 +23,7 @@ # - absence of empty lines at end of file (white-at-eof) # - presence of a LF character at the end of the file (missing-lf) # - maximum line length of 80 characters (long-line) +# - maximum line length of 132 characters (very-long-line) # - presence of a copyright header (missing-header) # - absence of a leftover "$Id" string (svn-keyword) @@ -34,22 +35,24 @@ # Built-in exceptions: # - Any binary file (i.e. with svn:mime-type = application/octet-stream) # is automatically exempt from all the rules. +# - Any file whose name matches one of the following patterns is +# automatically exempt from all rules +# *.reference +# */reference +# */.depend* # - Any file whose name begins with "Makefile" is automatically exempt # from the "tabs" rule. # - Any file whose name matches one of the following patterns is # automatically exempt from the "missing-header" rule. -# */.depend* # */.ignore # *.mlpack # *.mllib # *.mltop # *.odocl # *.clib -# *.reference -# */reference -# - Any file whose name matches one of the following patterns is -# automatically exempt from the "long-line" rule. -# *.reference +# - Any file whose name matches the following pattern is automatically +# exempt from the "long-line" rule (but not from "very-long-line"). +# */ocamldoc/* # ASCII characters are bytes from 0 to 127. Any other byte is # flagged as a non-ASCII character. @@ -131,17 +134,15 @@ IGNORE_DIRS=" svnrules=`svn propget ocaml:typo "$f"` fi rules="$userrules" + add_hd(){ rules="missing-header,$rules"; } case "$f" in Makefile*|*/Makefile*) rules="tab,$rules";; - esac - h(){ rules="missing-header,$rules"; } - case "$f" in - */.depend*|*/.ignore) h;; - *.mlpack|*.mllib|*.mltop|*.odocl|*.itarget|*.clib) h;; - *.reference|*/reference) h;; + */.ignore) add_hd;; + *.mlpack|*.mllib|*.mltop|*.odocl|*.itarget|*.clib) add_hd;; + *.reference|*/reference|*/.depend*) continue;; esac case "$f" in - *.reference) rules="long-line,$rules";; + ocamldoc/*|*/ocamldoc/*) rules="long-line,$rules";; esac (cat "$f"; echo) \ @@ -186,6 +187,12 @@ IGNORE_DIRS=" err("long-line", "line is over 80 characters"); } + length($0) > 132 { + RSTART = 133; + RLENGTH = 0; + err("very-long-line", "line is over 132 characters"); + } + 3 <= NR && NR <= 5 \ && (/ OCaml / || / ocamlbuild / || / OCamldoc /) { header_ocaml = NR; diff --git a/tools/ci-build b/tools/ci-build new file mode 100755 index 000000000..4bb2593eb --- /dev/null +++ b/tools/ci-build @@ -0,0 +1,159 @@ +#!/bin/sh +######################################################################### +# # +# OCaml # +# # +# Damien Doligez, projet Gallium, INRIA Rocquencourt # +# # +# Copyright 2014 Institut National de Recherche en Informatique et # +# en Automatique. All rights reserved. This file is distributed # +# under the terms of the Q Public License version 1.0. # +# # +######################################################################### + +# This script is run on our continuous-integration servers to recompile +# from scratch and run the test suite. + +# arguments: +# 1. architecture: bsd, macos, linux, cygwin, mingw, mingw64, msvc, msvc64 +# 2. directory in which to build (trunk, 4.02, etc) +# for windows, this is relative to $HOME/jenkins-workspace +# for bsd, macos, linux, this is "." or an absolute directory +# 3. options: +# -conf configure-option +# -patch1 file-name apply patch with -p1 + +error () { + echo "$1" >&2 + exit 3 +} + +######################################################################### +# be verbose +set -x + +######################################################################### +# "Parse" mandatory command-line arguments. + +arch="$1" +branch="$2" +shift 2 + +######################################################################### +# If we are called from a Windows batch script, we must set up the +# Unix environment variables (e.g. PATH). + +case "$arch" in + bsd|macos|linux) ;; + cygwin|mingw|mingw64) + . /etc/profile + . "$HOME/.profile" + ;; + msvc) + . /etc/profile + . "$HOME/.profile" + . "$HOME/.msenv32" + ;; + msvc64) + . /etc/profile + . "$HOME/.profile" + . "$HOME/.msenv64" + ;; + *) error "unknown architecture: $arch";; +esac + +######################################################################### + +# be verbose and stop on error +set -ex + +######################################################################### +# set up variables + +# default values +make=make +instdir="$HOME/ocaml-tmp-install" +workdir="$branch" +docheckout=false +nt= + +case "$arch" in + bsd) + make=gmake + ;; + macos) ;; + linux) ;; + cygwin) + workdir="$HOME/jenkins-workspace/$branch" + docheckout=true + ;; + mingw) + instdir=/cygdrive/c/ocamlmgw + workdir="$HOME/jenkins-workspace/$branch" + docheckout=true + nt=.nt + ;; + mingw64) + instdir=/cygdrive/c/ocamlmgw64 + workdir="$HOME/jenkins-workspace/$branch" + docheckout=true + nt=.nt + ;; + msvc) + instdir=/cygdrive/c/ocamlms + workdir="$HOME/jenkins-workspace/$branch" + docheckout=true + nt=.nt + ;; + msvc64) + instdir=/cygdrive/c/ocamlms64 + workdir="$HOME/jenkins-workspace/$branch" + docheckout=true + nt=.nt + ;; + *) error "unknown architecture: $arch";; +esac + +######################################################################### +# Go to the right directory + +cd "$workdir" + +######################################################################### +# parse optional command-line arguments (has to be done after the "cd") +# Configure options are not allowed to have spaces or special characters +# for the moment. We'll fix that when needed. +confoptions="" +while [ $# -gt 0 ]; do + case $1 in + -conf) confoptions="$confoptions $2"; shift 2;; + -patch1) patch -f -p1 <"$2"; shift 2;; + *) error "unknown option $1";; + esac +done + +######################################################################### +# Do the work + +$make -f Makefile$nt distclean || : + +if $docheckout; then + svn update --accept theirs-full +fi + +case $nt in + "") ./configure -prefix "$instdir" $confoptions;; + .nt) + cp config/m-nt.h config/m.h + cp config/s-nt.h config/s.h + cp config/Makefile.$arch config/Makefile + ;; + *) error "internal error";; +esac + +$make -f Makefile$nt world.opt +$make -f Makefile$nt install + +rm -rf "$instdir" +cd testsuite +$make all diff --git a/tools/cmt2annot.ml b/tools/cmt2annot.ml index a7c5a005f..36ca187ca 100644 --- a/tools/cmt2annot.ml +++ b/tools/cmt2annot.ml @@ -87,8 +87,10 @@ let iterator rebuild_env = bind_bindings exp.exp_loc bindings | Texp_let (Nonrecursive, bindings, body) -> bind_bindings body.exp_loc bindings + | Texp_match (_, f1, f2, _) -> + bind_cases f1; + bind_cases f2 | Texp_function (_, f, _) - | Texp_match (_, f, _) | Texp_try (_, f) -> bind_cases f | _ -> () @@ -154,7 +156,7 @@ let gen_annot target_filename filename match target_filename with | None -> Some (filename ^ ".annot") | Some "-" -> None - | Some filename -> target_filename + | Some _ -> target_filename in let iterator = iterator cmt_use_summaries in match cmt_annots with @@ -177,9 +179,13 @@ let gen_ml target_filename filename cmt = let (printer, ext) = match cmt.Cmt_format.cmt_annots with | Cmt_format.Implementation typedtree -> - (fun ppf -> Pprintast.structure ppf (Untypeast.untype_structure typedtree)), ".ml" + (fun ppf -> Pprintast.structure ppf + (Untypeast.untype_structure typedtree)), + ".ml" | Cmt_format.Interface typedtree -> - (fun ppf -> Pprintast.signature ppf (Untypeast.untype_signature typedtree)), ".mli" + (fun ppf -> Pprintast.signature ppf + (Untypeast.untype_signature typedtree)), + ".mli" | _ -> Printf.fprintf stderr "File was generated with an error\n%!"; exit 2 @@ -187,7 +193,7 @@ let gen_ml target_filename filename cmt = let target_filename = match target_filename with None -> Some (filename ^ ext) | Some "-" -> None - | Some filename -> target_filename + | Some _ -> target_filename in let oc = match target_filename with None -> None diff --git a/tools/depend.ml b/tools/depend.ml index 82c2db832..222d08d31 100644 --- a/tools/depend.ml +++ b/tools/depend.ml @@ -21,34 +21,35 @@ module StringSet = Set.Make(struct type t = string let compare = compare end) let free_structure_names = ref StringSet.empty -let rec addmodule bv lid = - match lid with - Lident s -> +let rec add_path bv = function + | Lident s -> if not (StringSet.mem s bv) then free_structure_names := StringSet.add s !free_structure_names - | Ldot(l, s) -> addmodule bv l - | Lapply(l1, l2) -> addmodule bv l1; addmodule bv l2 + | Ldot(l, _s) -> add_path bv l + | Lapply(l1, l2) -> add_path bv l1; add_path bv l2 + +let open_module bv lid = add_path bv lid let add bv lid = match lid.txt with - Ldot(l, s) -> addmodule bv l + Ldot(l, _s) -> add_path bv l | _ -> () -let addmodule bv lid = addmodule bv lid.txt +let addmodule bv lid = add_path bv lid.txt let rec add_type bv ty = match ty.ptyp_desc with Ptyp_any -> () - | Ptyp_var v -> () + | Ptyp_var _ -> () | Ptyp_arrow(_, t1, t2) -> add_type bv t1; add_type bv t2 | Ptyp_tuple tl -> List.iter (add_type bv) tl | Ptyp_constr(c, tl) -> add bv c; List.iter (add_type bv) tl - | Ptyp_object (fl, _) -> List.iter (fun (_, t) -> add_type bv t) fl + | Ptyp_object (fl, _) -> List.iter (fun (_, _, t) -> add_type bv t) fl | Ptyp_class(c, tl) -> add bv c; List.iter (add_type bv) tl - | Ptyp_alias(t, s) -> add_type bv t + | Ptyp_alias(t, _) -> add_type bv t | Ptyp_variant(fl, _, _) -> List.iter - (function Rtag(_,_,stl) -> List.iter (add_type bv) stl + (function Rtag(_,_,_,stl) -> List.iter (add_type bv) stl | Rinherit sty -> add_type bv sty) fl | Ptyp_poly(_, t) -> add_type bv t @@ -63,11 +64,12 @@ let add_opt add_fn bv = function None -> () | Some x -> add_fn bv x -let add_constructor_decl bv pcd = - begin match pcd.pcd_args with +let add_constructor_arguments bv = function | Pcstr_tuple l -> List.iter (add_type bv) l | Pcstr_record l -> List.iter (fun l -> add_type bv l.pld_type) l - end; + +let add_constructor_decl bv pcd = + add_constructor_arguments bv pcd.pcd_args; Misc.may (add_type bv) pcd.pcd_res let add_type_declaration bv td = @@ -80,9 +82,21 @@ let add_type_declaration bv td = | Ptype_variant cstrs -> List.iter (add_constructor_decl bv) cstrs | Ptype_record lbls -> - List.iter (fun pld -> add_type bv pld.pld_type) lbls in + List.iter (fun pld -> add_type bv pld.pld_type) lbls + | Ptype_open -> () in add_tkind td.ptype_kind +let add_extension_constructor bv ext = + match ext.pext_kind with + Pext_decl(args, rty) -> + add_constructor_arguments bv args; + Misc.may (add_type bv) rty + | Pext_rebind lid -> add bv lid + +let add_type_extension bv te = + add bv te.ptyext_path; + List.iter (add_extension_constructor bv) te.ptyext_constructors + let rec add_class_type bv cty = match cty.pcty_desc with Pcty_constr(l, tyl) -> @@ -100,6 +114,7 @@ and add_class_type_field bv pctf = | Pctf_val(_, _, _, ty) -> add_type bv ty | Pctf_method(_, _, _, ty) -> add_type bv ty | Pctf_constraint(ty1, ty2) -> add_type bv ty1; add_type bv ty2 + | Pctf_attribute _ -> () | Pctf_extension _ -> () let add_class_description bv infos = @@ -127,6 +142,7 @@ let rec add_pattern bv pat = | Ppat_type li -> add bv li | Ppat_lazy p -> add_pattern bv p | Ppat_unpack id -> pattern_bv := StringSet.add id.txt !pattern_bv + | Ppat_exception p -> add_pattern bv p | Ppat_extension _ -> () let add_pattern bv pat = @@ -170,10 +186,10 @@ let rec add_expr bv exp = | Pexp_constraint(e1, ty2) -> add_expr bv e1; add_type bv ty2 - | Pexp_send(e, m) -> add_expr bv e + | Pexp_send(e, _m) -> add_expr bv e | Pexp_new li -> add bv li - | Pexp_setinstvar(v, e) -> add_expr bv e - | Pexp_override sel -> List.iter (fun (s, e) -> add_expr bv e) sel + | Pexp_setinstvar(_v, e) -> add_expr bv e + | Pexp_override sel -> List.iter (fun (_s, e) -> add_expr bv e) sel | Pexp_letmodule(id, m, e) -> add_module bv m; add_expr (StringSet.add id.txt bv) e | Pexp_assert (e) -> add_expr bv e @@ -183,7 +199,7 @@ let rec add_expr bv exp = let bv = add_pattern bv pat in List.iter (add_class_field bv) fieldl | Pexp_newtype (_, e) -> add_expr bv e | Pexp_pack m -> add_module bv m - | Pexp_open (_ovf, m, e) -> addmodule bv m; add_expr bv e + | Pexp_open (_ovf, m, e) -> open_module bv m.txt; add_expr bv e | Pexp_extension _ -> () and add_cases bv cases = @@ -231,8 +247,10 @@ and add_sig_item bv item = add_type bv vd.pval_type; bv | Psig_type dcls -> List.iter (add_type_declaration bv) dcls; bv - | Psig_exception pcd -> - add_constructor_decl bv pcd; bv + | Psig_typext te -> + add_type_extension bv te; bv + | Psig_exception pext -> + add_extension_constructor bv pext; bv | Psig_module pmd -> add_modtype bv pmd.pmd_type; StringSet.add pmd.pmd_name.txt bv | Psig_recmodule decls -> @@ -248,10 +266,10 @@ and add_sig_item bv item = | Some mty -> add_modtype bv mty end; bv - | Psig_open (_ovf, lid, _) -> - addmodule bv lid; bv - | Psig_include (mty, _) -> - add_modtype bv mty; bv + | Psig_open od -> + open_module bv od.popen_lid.txt; bv + | Psig_include incl -> + add_modtype bv incl.pincl_mod; bv | Psig_class cdl -> List.iter (add_class_description bv) cdl; bv | Psig_class_type cdtl -> @@ -288,10 +306,11 @@ and add_struct_item bv item = add_type bv vd.pval_type; bv | Pstr_type dcls -> List.iter (add_type_declaration bv) dcls; bv - | Pstr_exception pcd -> - add_constructor_decl bv pcd; bv - | Pstr_exn_rebind(id, l, _attrs) -> - add bv l; bv + | Pstr_typext te -> + add_type_extension bv te; + bv + | Pstr_exception pext -> + add_extension_constructor bv pext; bv | Pstr_module x -> add_module bv x.pmb_expr; StringSet.add x.pmb_name.txt bv | Pstr_recmodule bindings -> @@ -308,14 +327,14 @@ and add_struct_item bv item = | Some mty -> add_modtype bv mty end; bv - | Pstr_open (_ovf, l, _attrs) -> - addmodule bv l; bv + | Pstr_open od -> + open_module bv od.popen_lid.txt; bv | Pstr_class cdl -> List.iter (add_class_declaration bv) cdl; bv | Pstr_class_type cdtl -> List.iter (add_class_type_declaration bv) cdtl; bv - | Pstr_include (modl, _attrs) -> - add_module bv modl; bv + | Pstr_include incl -> + add_module bv incl.pincl_mod; bv | Pstr_attribute _ | Pstr_extension _ -> bv @@ -355,7 +374,7 @@ and add_class_field bv pcf = | Pcf_method(_, _, Cfk_virtual ty) -> add_type bv ty | Pcf_constraint(ty1, ty2) -> add_type bv ty1; add_type bv ty2 | Pcf_initializer e -> add_expr bv e - | Pcf_extension _ -> () + | Pcf_attribute _ | Pcf_extension _ -> () and add_class_declaration bv decl = add_class_expr bv decl.pci_expr diff --git a/tools/depend.mli b/tools/depend.mli index f859cfef2..93fc084f7 100644 --- a/tools/depend.mli +++ b/tools/depend.mli @@ -16,6 +16,8 @@ module StringSet : Set.S with type elt = string val free_structure_names : StringSet.t ref +val open_module : StringSet.t -> Longident.t -> unit + val add_use_file : StringSet.t -> Parsetree.toplevel_phrase list -> unit val add_signature : StringSet.t -> Parsetree.signature -> unit diff --git a/tools/dumpobj.ml b/tools/dumpobj.ml index db8494cc2..f1e289738 100644 --- a/tools/dumpobj.ml +++ b/tools/dumpobj.ml @@ -481,8 +481,8 @@ let print_reloc (info, pos) = (* Print a .cmo file *) -let dump_obj filename ic = - let buffer = Misc.input_bytes ic (String.length cmo_magic_number) in +let dump_obj ic = + let buffer = really_input_string ic (String.length cmo_magic_number) in if buffer <> cmo_magic_number then begin prerr_endline "Not an object file"; exit 2 end; @@ -493,6 +493,7 @@ let dump_obj filename ic = if cu.cu_debug > 0 then begin seek_in ic cu.cu_debug; let evl = (input_value ic : debug_event list) in + ignore (input_value ic); (* Skip the list of absolute directory names *) record_events 0 evl end; seek_in ic cu.cu_pos; @@ -501,7 +502,7 @@ let dump_obj filename ic = (* Read the primitive table from an executable *) let read_primitive_table ic len = - let p = Misc.input_bytes ic len in + let p = really_input_string ic len in let rec split beg cur = if cur >= len then [] else if p.[cur] = '\000' then @@ -518,7 +519,7 @@ let dump_exe ic = primitives := read_primitive_table ic prim_size; ignore(Bytesections.seek_section ic "DATA"); let init_data = (input_value ic : Obj.t array) in - globals := Array.create (Array.length init_data) Empty; + globals := Array.make (Array.length init_data) Empty; for i = 0 to Array.length init_data - 1 do !globals.(i) <- Constant (init_data.(i)) done; @@ -531,6 +532,7 @@ let dump_exe ic = for _i = 1 to num_eventlists do let orig = input_binary_int ic in let evl = (input_value ic : debug_event list) in + ignore (input_value ic); (* Skip the list of absolute directory names *) record_events orig evl done with Not_found -> () @@ -555,7 +557,7 @@ let arg_fun filename = begin try objfile := false; dump_exe ic with Bytesections.Bad_magic_number -> - objfile := true; seek_in ic 0; dump_obj filename ic + objfile := true; seek_in ic 0; dump_obj ic end; close_in ic; printf "## end of ocaml dump of %S\n%!" filename diff --git a/tools/eqparsetree.ml b/tools/eqparsetree.ml index 332efa3e1..128453e0c 100644 --- a/tools/eqparsetree.ml +++ b/tools/eqparsetree.ml @@ -120,7 +120,7 @@ module Asttypes = struct (('all_a0 loc) * ('all_a0 loc)) -> 'result = fun mf_a ({ txt = a0; loc = a1 }, { txt = b0; loc = b1 }) -> (mf_a (a0, b0)) && (Location.eq_t (a1, b1)) - + end let rec eq_row_field : (row_field * row_field) -> 'result = @@ -185,7 +185,7 @@ and eq_core_type : (core_type * core_type) -> 'result = ({ ptyp_desc = a0; ptyp_loc = a1 }, { ptyp_desc = b0; ptyp_loc = b1 }) -> (eq_core_type_desc (a0, b0)) && (Location.eq_t (a1, b1)) - + let eq_class_infos : 'all_a0. (('all_a0 * 'all_a0) -> 'result) -> @@ -221,7 +221,7 @@ let eq_class_infos : (eq_bool (a0, b0)) && (eq_bool (a1, b1))) (a4, b4))) && (Location.eq_t (a5, b5)) - + let rec eq_pattern_desc : (pattern_desc * pattern_desc) -> 'result = function | (Ppat_any, Ppat_any) -> true @@ -259,7 +259,7 @@ and eq_pattern : (pattern * pattern) -> 'result = ({ ppat_desc = a0; ppat_loc = a1 }, { ppat_desc = b0; ppat_loc = b1 }) -> (eq_pattern_desc (a0, b0)) && (Location.eq_t (a1, b1)) - + let rec eq_structure_item_desc : (structure_item_desc * structure_item_desc) -> 'result = function @@ -760,7 +760,7 @@ and eq_expression : (expression * expression) -> 'result = ({ pexp_desc = a0; pexp_loc = a1 }, { pexp_desc = b0; pexp_loc = b1 }) -> (eq_expression_desc (a0, b0)) && (Location.eq_t (a1, b1)) - + let rec eq_directive_argument : (directive_argument * directive_argument) -> 'result = function diff --git a/tools/make-package-macosx b/tools/make-package-macosx index 1fa08919d..e823156ba 100755 --- a/tools/make-package-macosx +++ b/tools/make-package-macosx @@ -85,7 +85,7 @@ mkdir -p resources cat >resources/ReadMe.txt <<EOF This package installs OCaml version ${VERSION}. You need Mac OS X 10.7.x (Lion) or later, with the -XCode tools installed (v4.3.3 or later). +XCode tools installed (v4.6.3 or later). Files will be installed in the following directories: diff --git a/tools/make-version-header.sh b/tools/make-version-header.sh index b5e69be95..26c5c1428 100755 --- a/tools/make-version-header.sh +++ b/tools/make-version-header.sh @@ -13,9 +13,6 @@ # # ######################################################################### -# For maximal compatibility with older versions, we Use "ocamlc -v" -# instead of "ocamlc -vnum" or the VERSION file in .../lib/ocaml/. - # This script extracts the components from an OCaml version number # and provides them as C defines: # OCAML_VERSION_MAJOR: the major version number @@ -26,7 +23,18 @@ # Note that additional-info is always absent in officially-released # versions of OCaml. -version="`ocamlc -v | sed -n -e 's/.*version //p'`" +# usage: +# make-version-header.sh [version-file] +# The argument is the VERSION file from the OCaml sources. +# If the argument is not given, the version number from "ocamlc -v" will +# be used. + +case $# in + 0) version="`ocamlc -v | sed -n -e 's/.*version //p'`";; + 1) version="`sed -e 1q $1`";; + *) echo "usage: make-version-header.sh [version-file]" >&2 + exit 2;; +esac major="`echo "$version" | sed -n -e '1s/^\([0-9]*\)\..*/\1/p'`" minor="`echo "$version" | sed -n -e '1s/^[0-9]*\.\([0-9]*\).*/\1/p'`" @@ -34,10 +42,12 @@ patchlvl="`echo "$version" | sed -n -e '1s/^[0-9]*\.[0-9]*\.\([0-9]*\).*/\1/p'`" suffix="`echo "$version" | sed -n -e '1s/^[^+]*+\(.*\)/\1/p'`" echo "#define OCAML_VERSION_MAJOR $major" -echo "#define OCAML_VERSION_MINOR $minor" +printf "#define OCAML_VERSION_MINOR %d\n" $minor case $patchlvl in "") patchlvl=0;; esac echo "#define OCAML_VERSION_PATCHLEVEL $patchlvl" case "$suffix" in "") echo "#undef OCAML_VERSION_ADDITIONAL";; *) echo "#define OCAML_VERSION_ADDITIONAL \"$suffix\"";; esac +printf "#define OCAML_VERSION %d%02d%02d\n" $major $minor $patchlvl +echo "#define OCAML_VERSION_STRING \"$version\"" diff --git a/tools/objinfo.ml b/tools/objinfo.ml index 6f3ec7566..37a03b342 100644 --- a/tools/objinfo.ml +++ b/tools/objinfo.ml @@ -31,11 +31,18 @@ let input_stringlist ic len = else acc in fold 0 0 [] in - let sect = Misc.input_bytes ic len in + let sect = really_input_string ic len in get_string_list sect len -let print_name_crc (name, crc) = - printf "\t%s\t%s\n" (Digest.to_hex crc) name +let dummy_crc = String.make 32 '-' + +let print_name_crc (name, crco) = + let crc = + match crco with + None -> dummy_crc + | Some crc -> Digest.to_hex crc + in + printf "\t%s\t%s\n" crc name let print_line name = printf "\t%s\n" name @@ -69,11 +76,28 @@ let print_cma_infos (lib : Cmo_format.library) = printf "\n"; List.iter print_cmo_infos lib.lib_units -let print_cmi_infos name sign crcs = +let print_cmi_infos name crcs = printf "Unit name: %s\n" name; printf "Interfaces imported:\n"; List.iter print_name_crc crcs +let print_cmt_infos cmt = + let open Cmt_format in + printf "Cmt unit name: %s\n" cmt.cmt_modname; + print_string "Cmt interfaces imported:\n"; + List.iter print_name_crc cmt.cmt_imports; + printf "Source file: %s\n" + (match cmt.cmt_sourcefile with None -> "(none)" | Some f -> f); + printf "Compilation flags:"; + Array.iter print_spaced_string cmt.cmt_args; + printf "\nLoad path:"; + List.iter print_spaced_string cmt.cmt_loadpath; + printf "\n"; + printf "cmt interface digest: %s\n" + (match cmt.cmt_interface_digest with + | None -> "" + | Some crc -> Digest.to_hex crc) + let print_general_infos name crc defines cmi cmx = printf "Name: %s\n" name; printf "CRC of implementation: %s\n" (Digest.to_hex crc); @@ -143,7 +167,7 @@ let dump_byte ic = | "CRCS" -> p_section "Imported units" - (input_value ic : (string * Digest.t) list) + (input_value ic : (string * Digest.t option) list) | "DLLS" -> p_list "Used DLLs" @@ -189,7 +213,7 @@ let dump_obj filename = printf "File %s\n" filename; let ic = open_in_bin filename in let len_magic_number = String.length cmo_magic_number in - let magic_number = Misc.input_bytes ic len_magic_number in + let magic_number = really_input_string ic len_magic_number in if magic_number = cmo_magic_number then begin let cu_pos = input_binary_int ic in seek_in ic cu_pos; @@ -202,11 +226,19 @@ let dump_obj filename = let toc = (input_value ic : library) in close_in ic; print_cma_infos toc - end else if magic_number = cmi_magic_number then begin - let cmi = Cmi_format.input_cmi ic in + end else if magic_number = cmi_magic_number || + magic_number = cmt_magic_number then begin close_in ic; - print_cmi_infos cmi.Cmi_format.cmi_name cmi.Cmi_format.cmi_sign - cmi.Cmi_format.cmi_crcs + let cmi, cmt = Cmt_format.read filename in + begin match cmi with + | None -> () + | Some cmi -> + print_cmi_infos cmi.Cmi_format.cmi_name cmi.Cmi_format.cmi_crcs + end; + begin match cmt with + | None -> () + | Some cmt -> print_cmt_infos cmt + end end else if magic_number = cmx_magic_number then begin let ui = (input_value ic : unit_infos) in let crc = Digest.input ic in @@ -219,7 +251,7 @@ let dump_obj filename = end else begin let pos_trailer = in_channel_length ic - len_magic_number in let _ = seek_in ic pos_trailer in - let _ = really_input ic magic_number 0 len_magic_number in + let magic_number = really_input_string ic len_magic_number in if magic_number = Config.exec_magic_number then begin dump_byte ic; close_in ic diff --git a/tools/objinfo_helper.c b/tools/objinfo_helper.c index 58dfd2d45..a8c79bd39 100644 --- a/tools/objinfo_helper.c +++ b/tools/objinfo_helper.c @@ -17,7 +17,12 @@ #ifdef HAS_LIBBFD #include <stdlib.h> #include <string.h> + +// PACKAGE: protect against binutils change +// https://sourceware.org/bugzilla/show_bug.cgi?id=14243 +#define PACKAGE "ocamlobjinfo" #include <bfd.h> +#undef PACKAGE int main(int argc, char ** argv) { diff --git a/tools/ocamlcp.ml b/tools/ocamlcp.ml index bca5ae63c..51559aea3 100644 --- a/tools/ocamlcp.ml +++ b/tools/ocamlcp.ml @@ -54,6 +54,7 @@ module Options = Main_args.Make_bytecomp_options (struct let _dllib = option_with_arg "-dllib" let _dllpath = option_with_arg "-dllpath" let _dtypes = option "-dtypes" + let _for_pack = option_with_arg "-for-pack" let _g = option "-g" let _i = option "-i" let _I s = option_with_arg "-I" s @@ -64,25 +65,29 @@ module Options = Main_args.Make_bytecomp_options (struct let _labels = option "-labels" let _linkall = option "-linkall" let _make_runtime = option "-make-runtime" + let _no_alias_deps = option "-no-alias-deps" let _no_app_funct = option "-no-app-funct" let _noassert = option "-noassert" let _nolabels = option "-nolabels" let _noautolink = option "-noautolink" let _nostdlib = option "-nostdlib" let _o s = option_with_arg "-o" s + let _open s = option_with_arg "-open" s let _output_obj = option "-output-obj" let _pack = option "-pack" - let _pp s = incompatible "-pp" - let _ppx s = incompatible "-ppx" + let _pp _s = incompatible "-pp" + let _ppx _s = incompatible "-ppx" let _principal = option "-principal" let _rectypes = option "-rectypes" let _runtime_variant s = option_with_arg "-runtime-variant" s + let _safe_string = option "-safe-string" let _short_paths = option "-short-paths" let _strict_sequence = option "-strict-sequence" - let _trans_mod = option "-trans-mod" + let _strict_formats = option "-strict-formats" let _thread () = option "-thread" () let _vmthread () = option "-vmthread" () let _unsafe = option "-unsafe" + let _unsafe_string = option "-unsafe-string" let _use_prims s = option_with_arg "-use-prims" s let _use_runtime s = option_with_arg "-use-runtime" s let _v = option "-v" diff --git a/tools/ocamldep.ml b/tools/ocamldep.ml index 735a5f97b..db0695c9c 100644 --- a/tools/ocamldep.ml +++ b/tools/ocamldep.ml @@ -18,7 +18,6 @@ let ppf = Format.err_formatter type file_kind = ML | MLI;; -let include_dirs = ref [] let load_path = ref ([] : (string * string array) list) let ml_synonyms = ref [".ml"] let mli_synonyms = ref [".mli"] @@ -35,11 +34,7 @@ let files = ref [] let fix_slash s = if Sys.os_type = "Unix" then s else begin - let r = String.copy s in - for i = 0 to String.length r - 1 do - if r.[i] = '\\' then r.[i] <- '/' - done; - r + String.map (function '\\' -> '/' | c -> c) s end (* Since we reinitialize load_path after reading OCAMLCOMP, @@ -61,18 +56,21 @@ let readdir dir = dirs := StringMap.add dir contents !dirs; contents +let add_to_list li s = + li := s :: !li + let add_to_load_path dir = try let dir = Misc.expand_directory Config.standard_library dir in let contents = readdir dir in - load_path := (dir, contents) :: !load_path + add_to_list load_path (dir, contents) with Sys_error msg -> Format.fprintf Format.err_formatter "@[Bad -I option: %s@]@." msg; error_occurred := true let add_to_synonym_list synonyms suffix = if (String.length suffix) > 1 && suffix.[0] = '.' then - synonyms := suffix :: !synonyms + add_to_list synonyms suffix else begin Format.fprintf Format.err_formatter "@[Bad suffix: '%s'@]@." suffix; error_occurred := true @@ -160,20 +158,20 @@ let print_filename s = else count n (i+1) in let spaces = count 0 0 in - let result = String.create (String.length s + spaces) in + let result = Bytes.create (String.length s + spaces) in let rec loop i j = if i >= String.length s then () else if s.[i] = ' ' then begin - result.[j] <- '\\'; - result.[j+1] <- ' '; + Bytes.set result j '\\'; + Bytes.set result (j+1) ' '; loop (i+1) (j+2); end else begin - result.[j] <- s.[i]; + Bytes.set result j s.[i]; loop (i+1) (j+1); end in loop 0 0; - print_string result; + print_bytes result; end ;; @@ -205,7 +203,7 @@ let print_raw_dependencies source_file deps = (* Process one file *) -let report_err source_file exn = +let report_err exn = error_occurred := true; match exn with | Sys_error msg -> @@ -217,14 +215,22 @@ let report_err source_file exn = Location.report_error err | None -> raise x +let tool_name = "ocamldep" + let read_parse_and_extract parse_function extract_function magic source_file = Depend.free_structure_names := Depend.StringSet.empty; try let input_file = Pparse.preprocess source_file in begin try let ast = - Pparse.file Format.err_formatter input_file parse_function magic in - extract_function Depend.StringSet.empty ast; + Pparse.file ~tool_name Format.err_formatter + input_file parse_function magic + in + let bound_vars = Depend.StringSet.empty in + List.iter (fun modname -> + Depend.open_module bound_vars (Longident.Lident modname) + ) !Clflags.open_modules; + extract_function bound_vars ast; Pparse.remove_preprocessed input_file; !Depend.free_structure_names with x -> @@ -232,7 +238,7 @@ let read_parse_and_extract parse_function extract_function magic source_file = raise x end with x -> - report_err source_file x; + report_err x; Depend.StringSet.empty let ml_file_dependencies source_file = @@ -288,7 +294,7 @@ let mli_file_dependencies source_file = print_raw_dependencies source_file extracted_deps end else begin let basename = Filename.chop_extension source_file in - let (byt_deps, opt_deps) = + let (byt_deps, _opt_deps) = Depend.StringSet.fold (find_dependency MLI) extracted_deps ([], []) in print_dependencies [basename ^ ".cmi"] byt_deps @@ -299,7 +305,7 @@ let file_dependencies_as kind source_file = load_path := []; List.iter add_to_load_path ( (!Compenv.last_include_dirs @ - !include_dirs @ + !Clflags.include_dirs @ !Compenv.first_include_dirs )); Location.input_name := source_file; @@ -309,7 +315,7 @@ let file_dependencies_as kind source_file = | ML -> ml_file_dependencies source_file | MLI -> mli_file_dependencies source_file end - with x -> report_err source_file x + with x -> report_err x let file_dependencies source_file = if List.exists (Filename.check_suffix source_file) !ml_synonyms then @@ -324,8 +330,9 @@ let sort_files_by_dependencies files = (* Init Hashtbl with all defined modules *) let files = List.map (fun (file, file_kind, deps) -> - let modname = Filename.chop_extension (Filename.basename file) in - modname.[0] <- Char.uppercase modname.[0]; + let modname = + String.capitalize (Filename.chop_extension (Filename.basename file)) + in let key = (modname, file_kind) in let new_deps = ref [] in Hashtbl.add h key (file, new_deps); @@ -407,14 +414,14 @@ let print_version_num () = let _ = Clflags.classic := false; - first_include_dirs := Filename.current_dir_name :: !first_include_dirs; + add_to_list first_include_dirs Filename.current_dir_name; Compenv.readenv ppf Before_args; Arg.parse [ "-absname", Arg.Set Location.absname, " Show absolute filenames in error messages"; "-all", Arg.Set all_dependencies, " Generate dependencies on all files"; - "-I", Arg.String (fun s -> include_dirs := s :: !include_dirs), + "-I", Arg.String (add_to_list Clflags.include_dirs), "<dir> Add <dir> to the list of include directories"; "-impl", Arg.String (file_dependencies_as ML), "<f> Process <f> as a .ml file"; @@ -430,9 +437,11 @@ let _ = " Generate dependencies for native-code only (no .cmo files)"; "-one-line", Arg.Set one_line, " Output one line per file, regardless of the length"; + "-open", Arg.String (add_to_list Clflags.open_modules), + "<module> Opens the module <module> before typing"; "-pp", Arg.String(fun s -> Clflags.preprocessor := Some s), "<cmd> Pipe sources through preprocessor <cmd>"; - "-ppx", Arg.String(fun s -> first_ppx := s :: !first_ppx), + "-ppx", Arg.String (add_to_list first_ppx), "<cmd> Pipe abstract syntax trees through preprocessor <cmd>"; "-slash", Arg.Set Clflags.force_slash, " (Windows) Use forward slash / instead of backslash \\ in file paths"; diff --git a/tools/ocamlmklib.ml b/tools/ocamlmklib.ml index 0ef86979b..77ae57bec 100644 --- a/tools/ocamlmklib.ml +++ b/tools/ocamlmklib.ml @@ -215,10 +215,14 @@ let prepostfix pre name post = let transl_path s = match Sys.os_type with | "Win32" -> + let s = Bytes.of_string s in let rec aux i = - if i = String.length s || s.[i] = ' ' then s - else (if s.[i] = '/' then s.[i] <- '\\'; aux (i + 1)) - in aux 0 + if i = Bytes.length s || Bytes.get s i = ' ' then s + else begin + if Bytes.get s i = '/' then Bytes.set s i '\\'; + aux (i + 1) + end + in Bytes.to_string (aux 0) | _ -> s let build_libs () = diff --git a/tools/ocamloptp.ml b/tools/ocamloptp.ml index 6d730f2c3..0b788843f 100644 --- a/tools/ocamloptp.ml +++ b/tools/ocamloptp.ml @@ -64,28 +64,33 @@ module Options = Main_args.Make_optcomp_options (struct let _keep_locs = option "-keep-locs" let _labels = option "-labels" let _linkall = option "-linkall" + let _no_alias_deps = option "-no-alias-deps" let _no_app_funct = option "-no-app-funct" + let _no_float_const_prop = option "-no-float-const-prop" let _noassert = option "-noassert" let _noautolink = option "-noautolink" let _nodynlink = option "-nodynlink" let _nolabels = option "-nolabels" let _nostdlib = option "-nostdlib" let _o s = option_with_arg "-o" s + let _open s = option_with_arg "-open" s let _output_obj = option "-output-obj" let _p = option "-p" let _pack = option "-pack" - let _pp s = incompatible "-pp" - let _ppx s = incompatible "-ppx" + let _pp _s = incompatible "-pp" + let _ppx _s = incompatible "-ppx" let _principal = option "-principal" let _rectypes = option "-rectypes" let _runtime_variant s = option_with_arg "-runtime-variant" s let _S = option "-S" + let _safe_string = option "-safe-string" let _short_paths = option "-short-paths" let _strict_sequence = option "-strict-sequence" + let _strict_formats = option "-strict-formats" let _shared = option "-shared" let _thread = option "-thread" - let _trans_mod = option "-trans-mod" let _unsafe = option "-unsafe" + let _unsafe_string = option "-unsafe-string" let _v = option "-v" let _version = option "-version" let _vnum = option "-vnum" @@ -105,6 +110,7 @@ module Options = Main_args.Make_optcomp_options (struct let _dcmm = option "-dcmm" let _dsel = option "-dsel" let _dcombine = option "-dcombine" + let _dcse = option "-dcse" let _dlive = option "-dlive" let _dspill = option "-dspill" let _dsplit = option "-dsplit" @@ -115,6 +121,7 @@ module Options = Main_args.Make_optcomp_options (struct let _dscheduling = option "-dscheduling" let _dlinear = option "-dlinear" let _dstartup = option "-dstartup" + let _opaque = option "-opaque" let anonymous = process_file end);; diff --git a/tools/ocamlprof.ml b/tools/ocamlprof.ml index 1fde3fe49..dde248cd4 100644 --- a/tools/ocamlprof.ml +++ b/tools/ocamlprof.ml @@ -35,7 +35,7 @@ and inchan = ref stdin and outchan = ref stdout (* To copy source fragments *) -let copy_buffer = String.create 256 +let copy_buffer = Bytes.create 256 let copy_chars_unix nchars = let n = ref nchars in @@ -86,7 +86,7 @@ let add_incr_counter modul (kind,pos) = | Close -> fprintf !outchan ")"; ;; -let counters = ref (Array.create 0 0) +let counters = ref (Array.make 0 0) (* User defined marker *) let special_id = ref "" @@ -122,7 +122,7 @@ let init_rewrite modes mod_name = cur_point := 0; if !instr_mode then begin fprintf !outchan "module %sProfiling = Profiling;; " modprefix; - fprintf !outchan "let %s%s_cnt = Array.create 000000000" idprefix mod_name; + fprintf !outchan "let %s%s_cnt = Array.make 000000000" idprefix mod_name; pos_len := pos_out !outchan; fprintf !outchan " 0;; Profiling.counters := \ @@ -131,7 +131,7 @@ let init_rewrite modes mod_name = end let final_rewrite add_function = - to_insert := Sort.list (fun x y -> snd x < snd y) !to_insert; + to_insert := List.sort (fun x y -> compare (snd x) (snd y)) !to_insert; prof_counter := 0; List.iter add_function !to_insert; copy (in_channel_length !inchan); @@ -173,8 +173,8 @@ and rewrite_exp iflag sexp = and rw_exp iflag sexp = match sexp.pexp_desc with - Pexp_ident lid -> () - | Pexp_constant cst -> () + Pexp_ident _lid -> () + | Pexp_constant _cst -> () | Pexp_let(_, spat_sexp_list, sbody) -> rewrite_patexp_list iflag spat_sexp_list; @@ -314,7 +314,7 @@ and rewrite_annotate_exp_list l = l and rewrite_function iflag = function - | [{pc_lhs=spat; pc_guard=None; + | [{pc_lhs=_; pc_guard=None; pc_rhs={pexp_desc = (Pexp_function _|Pexp_fun _)} as sexp}] -> rewrite_exp iflag sexp | l -> rewrite_funmatching l @@ -344,6 +344,7 @@ and rewrite_class_field iflag cf = | Pcf_method (_, _, Cfk_virtual _) | Pcf_val (_, _, Cfk_virtual _) | Pcf_constraint _ -> () + | Pcf_attribute _ -> () | Pcf_extension _ -> () and rewrite_class_expr iflag cexpr = @@ -370,11 +371,11 @@ and rewrite_class_declaration iflag cl = and rewrite_mod iflag smod = match smod.pmod_desc with - Pmod_ident lid -> () + Pmod_ident _ -> () | Pmod_structure sstr -> List.iter (rewrite_str_item iflag) sstr - | Pmod_functor(param, smty, sbody) -> rewrite_mod iflag sbody + | Pmod_functor(_param, _smty, sbody) -> rewrite_mod iflag sbody | Pmod_apply(smod1, smod2) -> rewrite_mod iflag smod1; rewrite_mod iflag smod2 - | Pmod_constraint(smod, smty) -> rewrite_mod iflag smod + | Pmod_constraint(smod, _smty) -> rewrite_mod iflag smod | Pmod_unpack(sexp) -> rewrite_exp iflag sexp | Pmod_extension _ -> () diff --git a/tools/profiling.ml b/tools/profiling.ml index 5dae8e461..49a84108e 100644 --- a/tools/profiling.ml +++ b/tools/profiling.ml @@ -37,7 +37,7 @@ let dump_counters () = then raise Bad_profile) !counters prevl; List.iter2 - (fun (curname, (_,curcount)) (prevname, (_,prevcount)) -> + (fun (_curname, (_,curcount)) (_prevname, (_,prevcount)) -> for i = 0 to Array.length curcount - 1 do curcount.(i) <- curcount.(i) + prevcount.(i) done) diff --git a/tools/read_cmt.ml b/tools/read_cmt.ml index c0c5eb09d..eacba02a5 100644 --- a/tools/read_cmt.ml +++ b/tools/read_cmt.ml @@ -16,46 +16,59 @@ let print_info_arg = ref false let target_filename = ref None let arg_list = [ - "-o", Arg.String (fun s -> - target_filename := Some s - ), " FILE (or -) : dump to file FILE (or stdout)"; + "-o", Arg.String (fun s -> target_filename := Some s), + " FILE (or -) : dump to file FILE (or stdout)"; "-annot", Arg.Set gen_annot, " : generate the corresponding .annot file"; - "-src", Arg.Set gen_ml, " : generate an equivalent of the original source file (without comments) from a .cmt or a .cmti file"; + "-src", Arg.Set gen_ml, + " : convert .cmt or .cmti back to source code (without comments)"; "-info", Arg.Set print_info_arg, " : print information on the file"; ] -let arg_usage = "read_cmt [OPTIONS] FILE.cmt : read FILE.cmt and print related information" +let arg_usage = + "read_cmt [OPTIONS] FILE.cmt : read FILE.cmt and print related information" + +let dummy_crc = String.make 32 '-' let print_info cmt = let open Cmt_format in Printf.printf "module name: %s\n" cmt.cmt_modname; begin match cmt.cmt_annots with - Packed (_, list) -> Printf.printf "pack: %s\n" (String.concat " " list) + Packed (_, list) -> + Printf.printf "pack: %s\n" (String.concat " " list) | Implementation _ -> Printf.printf "kind: implementation\n" | Interface _ -> Printf.printf "kind: interface\n" - | Partial_implementation _ -> Printf.printf "kind: implementation with errors\n" + | Partial_implementation _ -> + Printf.printf "kind: implementation with errors\n" | Partial_interface _ -> Printf.printf "kind: interface with errors\n" end; - Printf.printf "command: %s\n" (String.concat " " (Array.to_list cmt.cmt_args)); + Printf.printf "command: %s\n" + (String.concat " " (Array.to_list cmt.cmt_args)); begin match cmt.cmt_sourcefile with None -> () | Some name -> Printf.printf "sourcefile: %s\n" name; end; Printf.printf "build directory: %s\n" cmt.cmt_builddir; - List.iter (fun dir -> Printf.printf "load path: %s\n%!" dir) cmt.cmt_loadpath; + List.iter (Printf.printf "load path: %s\n%!") cmt.cmt_loadpath; begin match cmt.cmt_source_digest with None -> () - | Some digest -> Printf.printf "source digest: %s\n" (Digest.to_hex digest); + | Some digest -> + Printf.printf "source digest: %s\n" (Digest.to_hex digest); end; begin match cmt.cmt_interface_digest with None -> () - | Some digest -> Printf.printf "interface digest: %s\n" (Digest.to_hex digest); + | Some digest -> + Printf.printf "interface digest: %s\n" (Digest.to_hex digest); end; - List.iter (fun (name, digest) -> - Printf.printf "import: %s %s\n" name (Digest.to_hex digest); + List.iter (fun (name, crco) -> + let crc = + match crco with + None -> dummy_crc + | Some crc -> Digest.to_hex crc + in + Printf.printf "import: %s %s\n" name crc; ) (List.sort compare cmt.cmt_imports); Printf.printf "%!"; () @@ -74,7 +87,8 @@ let _ = if !gen_ml then Cmt2annot.gen_ml !target_filename filename cmt; if !print_info_arg || not (!gen_ml || !gen_annot) then print_info cmt; end else begin - Printf.fprintf stderr "Error: the file must have an extension in .cmt or .cmti.\n%!"; + Printf.fprintf stderr + "Error: the file's extension must be .cmt or .cmti.\n%!"; Arg.usage arg_list arg_usage end ) arg_usage diff --git a/tools/tast_iter.ml b/tools/tast_iter.ml index c8af13670..be5b85441 100644 --- a/tools/tast_iter.ml +++ b/tools/tast_iter.ml @@ -17,18 +17,14 @@ let opt f = function None -> () | Some x -> f x let structure sub str = List.iter (sub # structure_item) str.str_items -let constructor_decl sub cd = - List.iter (sub # core_type) cd.cd_args; - opt (sub # core_type) cd.cd_res - let structure_item sub x = match x.str_desc with | Tstr_eval (exp, _attrs) -> sub # expression exp | Tstr_value (rec_flag, list) -> sub # bindings (rec_flag, list) | Tstr_primitive v -> sub # value_description v | Tstr_type list -> List.iter (sub # type_declaration) list - | Tstr_exception decl -> constructor_decl sub decl - | Tstr_exn_rebind (_id, _, _p, _, _) -> () + | Tstr_typext te -> sub # type_extension te + | Tstr_exception ext -> sub # extension_constructor ext | Tstr_module mb -> sub # module_binding mb | Tstr_recmodule list -> List.iter (sub # module_binding) list | Tstr_modtype mtd -> opt (sub # module_type) mtd.mtd_type @@ -37,12 +33,23 @@ let structure_item sub x = List.iter (fun (ci, _, _) -> sub # class_expr ci.ci_expr) list | Tstr_class_type list -> List.iter (fun (_id, _, ct) -> sub # class_type ct.ci_expr) list - | Tstr_include (mexpr, _, _) -> sub # module_expr mexpr + | Tstr_include incl -> sub # module_expr incl.incl_mod | Tstr_attribute _ -> () let value_description sub x = sub # core_type x.val_desc +let constructor_args sub = function + | Cstr_tuple l -> List.iter (sub # core_type) l + | Cstr_record l -> List.iter (fun ld -> sub # core_type ld.ld_type) l + +let constructor_decl sub cd = + constructor_args sub cd.cd_args; + opt (sub # core_type) cd.cd_res + +let label_decl sub ld = + sub # core_type ld.ld_type + let type_declaration sub decl = List.iter (fun (ct1, ct2, _loc) -> sub # core_type ct1; sub # core_type ct2) @@ -52,10 +59,21 @@ let type_declaration sub decl = | Ttype_variant list -> List.iter (constructor_decl sub) list | Ttype_record list -> - List.iter (fun ld -> sub # core_type ld.ld_type) list + List.iter (label_decl sub) list + | Ttype_open -> () end; opt (sub # core_type) decl.typ_manifest +let type_extension sub te = + List.iter (sub # extension_constructor) te.tyext_constructors + +let extension_constructor sub ext = + match ext.ext_kind with + Text_decl(ctl, cto) -> + constructor_args sub ctl; + opt (sub # core_type) cto + | Text_rebind _ -> () + let pattern sub pat = let extra = function | Tpat_type _ @@ -98,9 +116,10 @@ let expression sub exp = | Texp_apply (exp, list) -> sub # expression exp; List.iter (fun (_, expo, _) -> opt (sub # expression) expo) list - | Texp_match (exp, cases, _) -> + | Texp_match (exp, cases, exn_cases, _) -> sub # expression exp; - sub # cases cases + sub # cases cases; + sub # cases exn_cases | Texp_try (exp, cases) -> sub # expression exp; sub # cases cases @@ -166,8 +185,10 @@ let signature_item sub item = sub # value_description v | Tsig_type list -> List.iter (sub # type_declaration) list - | Tsig_exception decl -> - constructor_decl sub decl + | Tsig_typext te -> + sub # type_extension te + | Tsig_exception ext -> + sub # extension_constructor ext | Tsig_module md -> sub # module_type md.md_type | Tsig_recmodule list -> @@ -175,7 +196,7 @@ let signature_item sub item = | Tsig_modtype mtd -> opt (sub # module_type) mtd.mtd_type | Tsig_open _ -> () - | Tsig_include (mty,_,_) -> sub # module_type mty + | Tsig_include incl -> sub # module_type incl.incl_mod | Tsig_class list -> List.iter (sub # class_description) list | Tsig_class_type list -> @@ -274,6 +295,7 @@ let class_type_field sub ctf = | Tctf_constraint (ct1, ct2) -> sub # core_type ct1; sub # core_type ct2 + | Tctf_attribute _ -> () let core_type sub ct = match ct.ctyp_desc with @@ -286,7 +308,7 @@ let core_type sub ct = | Ttyp_constr (_path, _, list) -> List.iter (sub # core_type) list | Ttyp_object (list, _o) -> - List.iter (fun (_, t) -> sub # core_type t) list + List.iter (fun (_, _, t) -> sub # core_type t) list | Ttyp_class (_path, _, list) -> List.iter (sub # core_type) list | Ttyp_alias (ct, _s) -> @@ -302,7 +324,7 @@ let class_structure sub cs = let row_field sub rf = match rf with - | Ttag (_label, _bool, list) -> List.iter (sub # core_type) list + | Ttag (_label, _attrs, _bool, list) -> List.iter (sub # core_type) list | Tinherit ct -> sub # core_type ct let class_field sub cf = @@ -322,6 +344,7 @@ let class_field sub cf = sub # expression exp | Tcf_initializer exp -> sub # expression exp + | Tcf_attribute _ -> () let bindings sub (_rec_flag, list) = List.iter (sub # binding) list @@ -353,6 +376,7 @@ class iter = object(this) method class_type_field = class_type_field this method core_type = core_type this method expression = expression this + method extension_constructor = extension_constructor this method module_binding = module_binding this method module_expr = module_expr this method module_type = module_type this @@ -364,6 +388,7 @@ class iter = object(this) method structure = structure this method structure_item = structure_item this method type_declaration = type_declaration this + method type_extension = type_extension this method value_description = value_description this method with_constraint = with_constraint this end diff --git a/tools/tast_iter.mli b/tools/tast_iter.mli index f80609566..1d81afa56 100644 --- a/tools/tast_iter.mli +++ b/tools/tast_iter.mli @@ -28,6 +28,7 @@ class iter: object method class_type_field: class_type_field -> unit method core_type: core_type -> unit method expression: expression -> unit + method extension_constructor: extension_constructor -> unit method module_binding: module_binding -> unit method module_expr: module_expr -> unit method module_type: module_type -> unit @@ -39,6 +40,7 @@ class iter: object method structure: structure -> unit method structure_item: structure_item -> unit method type_declaration: type_declaration -> unit + method type_extension: type_extension -> unit method value_description: value_description -> unit method with_constraint: with_constraint -> unit end @@ -63,6 +65,7 @@ val class_type_declaration: iter -> class_type_declaration -> unit val class_type_field: iter -> class_type_field -> unit val core_type: iter -> core_type -> unit val expression: iter -> expression -> unit +val extension_constructor: iter -> extension_constructor -> unit val module_binding: iter -> module_binding -> unit val module_expr: iter -> module_expr -> unit val module_type: iter -> module_type -> unit @@ -74,5 +77,6 @@ val signature_item: iter -> signature_item -> unit val structure: iter -> structure -> unit val structure_item: iter -> structure_item -> unit val type_declaration: iter -> type_declaration -> unit +val type_extension: iter -> type_extension -> unit val value_description: iter -> value_description -> unit val with_constraint: iter -> with_constraint -> unit diff --git a/tools/untypeast.ml b/tools/untypeast.ml index 4d2304e27..58242fc23 100644 --- a/tools/untypeast.ml +++ b/tools/untypeast.ml @@ -30,6 +30,9 @@ Some notes: *) +let string_is_prefix sub str = + let sublen = String.length sub in + String.length str >= sublen && String.sub str 0 sublen = sub let option f = function None -> None | Some e -> Some (f e) @@ -53,41 +56,38 @@ and untype_structure_item item = Pstr_primitive (untype_value_description vd) | Tstr_type list -> Pstr_type (List.map untype_type_declaration list) - | Tstr_exception decl -> - Pstr_exception (untype_constructor_declaration decl) - | Tstr_exn_rebind (_id, name, _p, lid, attrs) -> - Pstr_exn_rebind (name, lid, attrs) + | Tstr_typext tyext -> + Pstr_typext (untype_type_extension tyext) + | Tstr_exception ext -> + Pstr_exception (untype_extension_constructor ext) | Tstr_module mb -> Pstr_module (untype_module_binding mb) | Tstr_recmodule list -> Pstr_recmodule (List.map untype_module_binding list) | Tstr_modtype mtd -> - Pstr_modtype {pmtd_name=mtd.mtd_name; pmtd_type=option untype_module_type mtd.mtd_type; + Pstr_modtype {pmtd_name=mtd.mtd_name; + pmtd_type=option untype_module_type mtd.mtd_type; pmtd_loc=mtd.mtd_loc;pmtd_attributes=mtd.mtd_attributes;} - | Tstr_open (ovf, _path, lid, attrs) -> Pstr_open (ovf, lid, attrs) + | Tstr_open od -> + Pstr_open {popen_lid = od.open_txt; popen_override = od.open_override; + popen_attributes = od.open_attributes; + popen_loc = od.open_loc; + } | Tstr_class list -> - Pstr_class (List.map (fun (ci, _, _) -> - { pci_virt = ci.ci_virt; - pci_params = ci.ci_params; - pci_name = ci.ci_id_name; - pci_expr = untype_class_expr ci.ci_expr; - pci_loc = ci.ci_loc; - pci_attributes = ci.ci_attributes; - } - ) list) + Pstr_class + (List.map + (fun (ci, _, _) -> untype_class_declaration ci) + list) | Tstr_class_type list -> - Pstr_class_type (List.map (fun (_id, _name, ct) -> - { - pci_virt = ct.ci_virt; - pci_params = ct.ci_params; - pci_name = ct.ci_id_name; - pci_expr = untype_class_type ct.ci_expr; - pci_loc = ct.ci_loc; - pci_attributes = ct.ci_attributes; - } - ) list) - | Tstr_include (mexpr, _, attrs) -> - Pstr_include (untype_module_expr mexpr, attrs) + Pstr_class_type + (List.map + (fun (_id, _name, ct) -> untype_class_type_declaration ct) + list) + | Tstr_include incl -> + Pstr_include {pincl_mod = untype_module_expr incl.incl_mod; + pincl_attributes = incl.incl_attributes; + pincl_loc = incl.incl_loc; + } | Tstr_attribute x -> Pstr_attribute x in @@ -113,7 +113,7 @@ and untype_module_binding mb = and untype_type_declaration decl = { ptype_name = decl.typ_name; - ptype_params = decl.typ_params; + ptype_params = List.map untype_type_parameter decl.typ_params; ptype_cstrs = List.map (fun (ct1, ct2, loc) -> (untype_core_type ct1, untype_core_type ct2, loc) @@ -123,13 +123,8 @@ and untype_type_declaration decl = | Ttype_variant list -> Ptype_variant (List.map untype_constructor_declaration list) | Ttype_record list -> - Ptype_record (List.map (fun ld -> - {pld_name=ld.ld_name; - pld_mutable=ld.ld_mutable; - pld_type=untype_core_type ld.ld_type; - pld_loc=ld.ld_loc; - pld_attributes=ld.ld_attributes} - ) list) + Ptype_record (List.map untype_label_declaration list) + | Ttype_open -> Ptype_open ); ptype_private = decl.typ_private; ptype_manifest = option untype_core_type decl.typ_manifest; @@ -137,15 +132,53 @@ and untype_type_declaration decl = ptype_loc = decl.typ_loc; } +and untype_type_parameter (ct, v) = (untype_core_type ct, v) + +and untype_constructor_arguments = function + | Cstr_tuple l -> Pcstr_tuple (List.map untype_core_type l) + | Cstr_record l -> Pcstr_record (List.map untype_label_declaration l) + and untype_constructor_declaration cd = { pcd_name = cd.cd_name; - pcd_args = Pcstr_tuple (List.map untype_core_type cd.cd_args); + pcd_args = untype_constructor_arguments cd.cd_args; pcd_res = option untype_core_type cd.cd_res; pcd_loc = cd.cd_loc; pcd_attributes = cd.cd_attributes; } +and untype_label_declaration ld = + { + pld_name=ld.ld_name; + pld_mutable=ld.ld_mutable; + pld_type=untype_core_type ld.ld_type; + pld_loc=ld.ld_loc; + pld_attributes=ld.ld_attributes + } + +and untype_type_extension tyext = + { + ptyext_path = tyext.tyext_txt; + ptyext_params = List.map untype_type_parameter tyext.tyext_params; + ptyext_constructors = + List.map untype_extension_constructor tyext.tyext_constructors; + ptyext_private = tyext.tyext_private; + ptyext_attributes = tyext.tyext_attributes; + } + +and untype_extension_constructor ext = + { + pext_name = ext.ext_name; + pext_kind = (match ext.ext_kind with + Text_decl (args, ret) -> + Pext_decl (untype_constructor_arguments args, + option untype_core_type ret) + | Text_rebind (_p, lid) -> Pext_rebind lid + ); + pext_loc = ext.ext_loc; + pext_attributes = ext.ext_attributes; + } + and untype_pattern pat = let desc = match pat with @@ -191,7 +224,8 @@ and untype_pattern pat = | Tpat_or (p1, p2, _) -> Ppat_or (untype_pattern p1, untype_pattern p2) | Tpat_lazy p -> Ppat_lazy (untype_pattern p) in - Pat.mk ~loc:pat.pat_loc ~attrs:pat.pat_attributes desc (* todo: fix attributes on extras *) + Pat.mk ~loc:pat.pat_loc ~attrs:pat.pat_attributes desc + (* todo: fix attributes on extras *) and untype_extra (extra, loc, attrs) sexp = let desc = @@ -217,11 +251,12 @@ and untype_case {c_lhs; c_guard; c_rhs} = pc_rhs = untype_expression c_rhs; } -and untype_binding {vb_pat; vb_expr; vb_attributes} = +and untype_binding {vb_pat; vb_expr; vb_attributes; vb_loc} = { pvb_pat = untype_pattern vb_pat; pvb_expr = untype_expression vb_expr; pvb_attributes = vb_attributes; + pvb_loc = vb_loc; } and untype_expression exp = @@ -246,8 +281,18 @@ and untype_expression exp = None -> list | Some exp -> (label, untype_expression exp) :: list ) list []) - | Texp_match (exp, cases, _) -> - Pexp_match (untype_expression exp, untype_cases cases) + | Texp_match (exp, cases, exn_cases, _) -> + let merged_cases = untype_cases cases + @ List.map + (fun c -> + let uc = untype_case c in + let pat = { uc.pc_lhs + with ppat_desc = Ppat_exception uc.pc_lhs } + in + { uc with pc_lhs = pat }) + exn_cases + in + Pexp_match (untype_expression exp, merged_cases) | Texp_try (exp, cases) -> Pexp_try (untype_expression exp, untype_cases cases) | Texp_tuple list -> @@ -328,10 +373,13 @@ and untype_signature_item item = Psig_value (untype_value_description v) | Tsig_type list -> Psig_type (List.map untype_type_declaration list) - | Tsig_exception decl -> - Psig_exception (untype_constructor_declaration decl) + | Tsig_typext tyext -> + Psig_typext (untype_type_extension tyext) + | Tsig_exception ext -> + Psig_exception (untype_extension_constructor ext) | Tsig_module md -> - Psig_module {pmd_name = md.md_name; pmd_type = untype_module_type md.md_type; + Psig_module {pmd_name = md.md_name; + pmd_type = untype_module_type md.md_type; pmd_attributes = md.md_attributes; pmd_loc = md.md_loc; } | Tsig_recmodule list -> @@ -339,10 +387,20 @@ and untype_signature_item item = {pmd_name = md.md_name; pmd_type = untype_module_type md.md_type; pmd_attributes = md.md_attributes; pmd_loc = md.md_loc}) list) | Tsig_modtype mtd -> - Psig_modtype {pmtd_name=mtd.mtd_name; pmtd_type=option untype_module_type mtd.mtd_type; + Psig_modtype {pmtd_name=mtd.mtd_name; + pmtd_type=option untype_module_type mtd.mtd_type; pmtd_attributes=mtd.mtd_attributes; pmtd_loc=mtd.mtd_loc} - | Tsig_open (ovf, _path, lid, attrs) -> Psig_open (ovf, lid, attrs) - | Tsig_include (mty, _, attrs) -> Psig_include (untype_module_type mty, attrs) + | Tsig_open od -> + Psig_open {popen_lid = od.open_txt; + popen_override = od.open_override; + popen_attributes = od.open_attributes; + popen_loc = od.open_loc; + } + | Tsig_include incl -> + Psig_include {pincl_mod = untype_module_type incl.incl_mod; + pincl_attributes = incl.incl_attributes; + pincl_loc = incl.incl_loc; + } | Tsig_class list -> Psig_class (List.map untype_class_description list) | Tsig_class_type list -> @@ -354,10 +412,20 @@ and untype_signature_item item = psig_loc = item.sig_loc; } +and untype_class_declaration cd = + { + pci_virt = cd.ci_virt; + pci_params = List.map untype_type_parameter cd.ci_params; + pci_name = cd.ci_id_name; + pci_expr = untype_class_expr cd.ci_expr; + pci_loc = cd.ci_loc; + pci_attributes = cd.ci_attributes; + } + and untype_class_description cd = { pci_virt = cd.ci_virt; - pci_params = cd.ci_params; + pci_params = List.map untype_type_parameter cd.ci_params; pci_name = cd.ci_id_name; pci_expr = untype_class_type cd.ci_expr; pci_loc = cd.ci_loc; @@ -367,7 +435,7 @@ and untype_class_description cd = and untype_class_type_declaration cd = { pci_virt = cd.ci_virt; - pci_params = cd.ci_params; + pci_params = List.map untype_type_parameter cd.ci_params; pci_name = cd.ci_id_name; pci_expr = untype_class_type cd.ci_expr; pci_loc = cd.ci_loc; @@ -488,6 +556,7 @@ and untype_class_type_field ctf = Pctf_method (s, priv, virt, untype_core_type ct) | Tctf_constraint (ct1, ct2) -> Pctf_constraint (untype_core_type ct1, untype_core_type ct2) + | Tctf_attribute x -> Pctf_attribute x in { pctf_desc = desc; @@ -506,7 +575,8 @@ and untype_core_type ct = Ptyp_constr (lid, List.map untype_core_type list) | Ttyp_object (list, o) -> - Ptyp_object (List.map (fun (s, t) -> (s, untype_core_type t)) list, o) + Ptyp_object + (List.map (fun (s, a, t) -> (s, a, untype_core_type t)) list, o) | Ttyp_class (_path, lid, list) -> Ptyp_class (lid, List.map untype_core_type list) | Ttyp_alias (ct, s) -> @@ -519,16 +589,26 @@ and untype_core_type ct = Typ.mk ~loc:ct.ctyp_loc desc and untype_class_structure cs = - { pcstr_self = untype_pattern cs.cstr_self; + let rec remove_self = function + | { pat_desc = Tpat_alias (p, id, _s) } when string_is_prefix "selfpat-" id.Ident.name -> + remove_self p + | p -> p + in + { pcstr_self = untype_pattern (remove_self cs.cstr_self); pcstr_fields = List.map untype_class_field cs.cstr_fields; } and untype_row_field rf = match rf with - Ttag (label, bool, list) -> - Rtag (label, bool, List.map untype_core_type list) + Ttag (label, attrs, bool, list) -> + Rtag (label, attrs, bool, List.map untype_core_type list) | Tinherit ct -> Rinherit (untype_core_type ct) +and is_self_pat = function + | { pat_desc = Tpat_alias(_pat, id, _) } -> + string_is_prefix "self-" (Ident.name id) + | _ -> false + and untype_class_field cf = let desc = match cf.cf_desc with Tcf_inherit (ovf, cl, super, _vals, _meths) -> @@ -542,7 +622,19 @@ and untype_class_field cf = | Tcf_method (lab, priv, Tcfk_virtual cty) -> Pcf_method (lab, priv, Cfk_virtual (untype_core_type cty)) | Tcf_method (lab, priv, Tcfk_concrete (o, exp)) -> + let remove_fun_self = function + | { exp_desc = Texp_function("", [case], _) } when is_self_pat case.c_lhs && case.c_guard = None -> case.c_rhs + | e -> e + in + let exp = remove_fun_self exp in Pcf_method (lab, priv, Cfk_concrete (o, untype_expression exp)) - | Tcf_initializer exp -> Pcf_initializer (untype_expression exp) + | Tcf_initializer exp -> + let remove_fun_self = function + | { exp_desc = Texp_function("", [case], _) } when is_self_pat case.c_lhs && case.c_guard = None -> case.c_rhs + | e -> e + in + let exp = remove_fun_self exp in + Pcf_initializer (untype_expression exp) + | Tcf_attribute x -> Pcf_attribute x in { pcf_desc = desc; pcf_loc = cf.cf_loc; pcf_attributes = cf.cf_attributes } diff --git a/tools/untypeast.mli b/tools/untypeast.mli index 0e0351ef9..efd0a031d 100644 --- a/tools/untypeast.mli +++ b/tools/untypeast.mli @@ -13,7 +13,8 @@ val untype_structure : Typedtree.structure -> Parsetree.structure val untype_signature : Typedtree.signature -> Parsetree.signature val untype_expression : Typedtree.expression -> Parsetree.expression -val untype_type_declaration : Typedtree.type_declaration -> Parsetree.type_declaration +val untype_type_declaration : + Typedtree.type_declaration -> Parsetree.type_declaration val untype_module_type : Typedtree.module_type -> Parsetree.module_type val lident_of_path : Path.t -> Longident.t diff --git a/toplevel/expunge.ml b/toplevel/expunge.ml index fa6fd7ca5..a893c60dd 100644 --- a/toplevel/expunge.ml +++ b/toplevel/expunge.ml @@ -65,7 +65,7 @@ let main () = let global_map = (input_value ic : Symtable.global_map) in output_value oc (expunge_map global_map) | "CRCS" -> - let crcs = (input_value ic : (string * Digest.t) list) in + let crcs = (input_value ic : (string * Digest.t option) list) in output_value oc (expunge_crcs crcs) | _ -> copy_file_chunk ic oc len diff --git a/toplevel/genprintval.ml b/toplevel/genprintval.ml index 5dc829b52..9af483ca9 100644 --- a/toplevel/genprintval.ml +++ b/toplevel/genprintval.ml @@ -50,6 +50,15 @@ module type S = Env.t -> t -> type_expr -> Outcometree.out_value end +module ObjTbl = Hashtbl.Make(struct + type t = Obj.t + let equal = (==) + let hash x = + try + Hashtbl.hash x + with exn -> 0 + end) + module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct type t = O.t @@ -173,6 +182,24 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct let printer_steps = ref max_steps in + let nested_values = ObjTbl.create 8 in + let nest_gen err f depth obj ty = + let repr = Obj.repr obj in + if not (Obj.is_block repr) then + f depth obj ty + else + if ObjTbl.mem nested_values repr then + err + else begin + ObjTbl.add nested_values repr (); + let ret = f depth obj ty in + ObjTbl.remove nested_values repr; + ret + end + in + + let nest f = nest_gen (Oval_stuff "<cycle>") f in + let rec tree_of_val depth obj ty = decr printer_steps; if !printer_steps < 0 || depth < 0 then Oval_ellipsis @@ -187,25 +214,26 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct Oval_stuff "<fun>" | Ttuple(ty_list) -> Oval_tuple (tree_of_val_list 0 depth obj ty_list) - | Tconstr(path, [], _) when Path.same path Predef.path_exn -> - tree_of_exception depth obj | Tconstr(path, [ty_arg], _) when Path.same path Predef.path_list -> if O.is_block obj then match check_depth depth obj ty with Some x -> x | None -> - let rec tree_of_conses tree_list obj = + let rec tree_of_conses tree_list depth obj ty_arg = if !printer_steps < 0 || depth < 0 then Oval_ellipsis :: tree_list else if O.is_block obj then let tree = - tree_of_val (depth - 1) (O.field obj 0) ty_arg in + nest tree_of_val (depth - 1) (O.field obj 0) ty_arg + in let next_obj = O.field obj 1 in - tree_of_conses (tree :: tree_list) next_obj + nest_gen (Oval_stuff "<cycle>" :: tree :: tree_list) + (tree_of_conses (tree :: tree_list)) + depth next_obj ty_arg else tree_list in - Oval_list (List.rev (tree_of_conses [] obj)) + Oval_list (List.rev (tree_of_conses [] depth obj ty_arg)) else Oval_list [] | Tconstr(path, [ty_arg], _) @@ -220,7 +248,8 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct Oval_ellipsis :: tree_list else if i < length then let tree = - tree_of_val (depth - 1) (O.field obj i) ty_arg in + nest tree_of_val (depth - 1) (O.field obj i) ty_arg + in tree_of_items (tree :: tree_list) (i + 1) else tree_list in @@ -229,12 +258,14 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct Oval_array [] | Tconstr (path, [ty_arg], _) when Path.same path Predef.path_lazy_t -> - if Lazy.lazy_is_val (O.obj obj) - then let v = tree_of_val depth (Lazy.force (O.obj obj)) ty_arg in - Oval_constr (Oide_ident "lazy", [v]) + if Lazy.is_val (O.obj obj) + then let v = + nest tree_of_val depth (Lazy.force (O.obj obj)) ty_arg + in + Oval_constr (Oide_ident "lazy", [v]) else Oval_stuff "<lazy>" - | Tconstr(path, ty_list, _) -> - begin try + | Tconstr(path, ty_list, _) -> begin + try let decl = Env.find_type path env in match decl with | {type_kind = Type_abstract; type_manifest = None} -> @@ -248,7 +279,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct if O.is_block obj then Cstr_block(O.tag obj) else Cstr_constant(O.obj obj) in - let {cd_id;cd_args;cd_res;cd_inlined} = + let {cd_id;cd_args;cd_res} = Datarepr.find_constr_by_tag tag constr_list in let type_params = match cd_res with @@ -259,47 +290,44 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct | _ -> assert false end | None -> decl.type_params in - let ty_args = - List.map - (function ty -> - try Ctype.apply env type_params ty ty_list with - Ctype.Cannot_apply -> abstract_type) - cd_args in - tree_of_constr_with_args (tree_of_constr env path) - (Ident.name cd_id) cd_inlined 0 depth obj - ty_args + begin + match cd_args with + | Cstr_tuple l -> + let ty_args = + List.map + (function ty -> + try Ctype.apply env type_params ty ty_list with + Ctype.Cannot_apply -> abstract_type) + l + in + tree_of_constr_with_args (tree_of_constr env path) + (Ident.name cd_id) false 0 depth obj + ty_args + | Cstr_record lbls -> + let r = + tree_of_record_fields depth + env path type_params ty_list + lbls 0 obj + in + Oval_constr(tree_of_constr env path + (Ident.name cd_id), + [ r ]) + end | {type_kind = Type_record(lbl_list, rep)} -> begin match check_depth depth obj ty with Some x -> x | None -> - let rec tree_of_fields pos = function - | [] -> [] - | {ld_id; ld_type} :: remainder -> - let ty_arg = - try - Ctype.apply env decl.type_params ld_type - ty_list - with - Ctype.Cannot_apply -> abstract_type in - let name = Ident.name ld_id in - (* PR#5722: print full module path only - for first record field *) - let lid = - if pos = 0 then tree_of_label env path name - else Oide_ident name - and v = - tree_of_val (depth - 1) (O.field obj pos) - ty_arg - in - (lid, v) :: tree_of_fields (pos + 1) remainder - in let pos = match rep with - | Record_exception _ -> 1 + | Record_extension -> 1 | _ -> 0 in - Oval_record (tree_of_fields pos lbl_list) + tree_of_record_fields depth + env path decl.type_params ty_list + lbl_list pos obj end + | {type_kind = Type_open} -> + tree_of_extension path depth obj with Not_found -> (* raised by Env.find_type *) Oval_stuff "<abstr>" @@ -316,8 +344,9 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct match Btype.row_field_repr f with | Rpresent(Some ty) | Reither(_,[ty],_,_) -> let args = - tree_of_val (depth - 1) (O.field obj 1) ty in - Oval_variant (l, Some args) + nest tree_of_val (depth - 1) (O.field obj 1) ty + in + Oval_variant (l, Some args) | _ -> find fields else find fields | [] -> Oval_stuff "<variant>" in @@ -343,11 +372,36 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct Oval_stuff "<module>" end + and tree_of_record_fields depth env path type_params ty_list + lbl_list pos obj = + let rec tree_of_fields pos = function + | [] -> [] + | {ld_id; ld_type} :: remainder -> + let ty_arg = + try + Ctype.apply env type_params ld_type + ty_list + with + Ctype.Cannot_apply -> abstract_type in + let name = Ident.name ld_id in + (* PR#5722: print full module path only + for first record field *) + let lid = + if pos = 0 then tree_of_label env path name + else Oide_ident name + and v = + nest tree_of_val (depth - 1) (O.field obj pos) + ty_arg + in + (lid, v) :: tree_of_fields (pos + 1) remainder + in + Oval_record (tree_of_fields pos lbl_list) + and tree_of_val_list start depth obj ty_list = let rec tree_list i = function | [] -> [] | ty :: ty_list -> - let tree = tree_of_val (depth - 1) (O.field obj i) ty in + let tree = nest tree_of_val (depth - 1) (O.field obj i) ty in tree :: tree_list (i + 1) ty_list in tree_list start ty_list @@ -364,7 +418,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct in Oval_constr (lid, args) - and tree_of_exception depth bucket = + and tree_of_extension type_path depth bucket = let slot = if O.tag bucket <> 0 then bucket else O.field bucket 0 @@ -377,20 +431,26 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct let cstr = Env.lookup_constructor lid env in let path = match cstr.cstr_tag with - Cstr_exception (p, _) -> p | _ -> raise Not_found in + Cstr_extension(p, _) -> p + | _ -> raise Not_found + in (* Make sure this is the right exception and not an homonym, by evaluating the exception found and comparing with the identifier contained in the exception bucket *) if not (EVP.same_value slot (EVP.eval_path env path)) then raise Not_found; tree_of_constr_with_args - (fun x -> Oide_ident x) name cstr.cstr_inlined 1 depth bucket + (fun x -> Oide_ident x) name (cstr.cstr_inlined <> None) + 1 depth bucket cstr.cstr_args with Not_found | EVP.Error -> match check_depth depth bucket ty with Some x -> x - | None -> outval_of_untyped_exception bucket + | None when Path.same type_path Predef.path_exn-> + outval_of_untyped_exception bucket + | None -> + Oval_stuff "<extension>" - in tree_of_val max_depth obj ty + in nest tree_of_val max_depth obj ty end diff --git a/toplevel/opttoploop.ml b/toplevel/opttoploop.ml index 5bac89781..9e9e3d744 100644 --- a/toplevel/opttoploop.ml +++ b/toplevel/opttoploop.ml @@ -92,6 +92,7 @@ let print_out_value = Oprint.out_value let print_out_type = Oprint.out_type let print_out_class_type = Oprint.out_class_type let print_out_module_type = Oprint.out_module_type +let print_out_type_extension = Oprint.out_type_extension let print_out_sig_item = Oprint.out_sig_item let print_out_signature = Oprint.out_signature let print_out_phrase = Oprint.out_phrase @@ -171,8 +172,8 @@ let rec pr_item env = function | Sig_type(id, decl, rs) :: rem -> let tree = Printtyp.tree_of_type_declaration id decl rs in Some (tree, None, rem) - | Sig_exception(id, decl) :: rem -> - let tree = Printtyp.tree_of_exception_declaration id decl in + | Sig_typext(id, ext, es) :: rem -> + let tree = Printtyp.tree_of_extension_constructor id ext es in Some (tree, None, rem) | Sig_module(id, mty, rs) :: rem -> let tree = Printtyp.tree_of_module id mty rs in diff --git a/toplevel/opttoploop.mli b/toplevel/opttoploop.mli index 3be9a51ea..223625581 100644 --- a/toplevel/opttoploop.mli +++ b/toplevel/opttoploop.mli @@ -84,6 +84,8 @@ val print_out_class_type : (formatter -> Outcometree.out_class_type -> unit) ref val print_out_module_type : (formatter -> Outcometree.out_module_type -> unit) ref +val print_out_type_extension : + (formatter -> Outcometree.out_type_extension -> unit) ref val print_out_sig_item : (formatter -> Outcometree.out_sig_item -> unit) ref val print_out_signature : diff --git a/toplevel/opttopmain.ml b/toplevel/opttopmain.ml index 3e15c1988..51d1daac5 100644 --- a/toplevel/opttopmain.ml +++ b/toplevel/opttopmain.ml @@ -69,6 +69,7 @@ module Options = Main_args.Make_opttop_options (struct let _init s = init_file := Some s let _inline n = inline_threshold := n * 8 let _labels = clear classic + let _no_alias_deps = set transparent_modules let _no_app_funct = clear applicative_functors let _noassert = set noassert let _nolabels = set classic @@ -80,6 +81,7 @@ module Options = Main_args.Make_opttop_options (struct let _real_paths = set real_paths let _rectypes = set recursive_types let _strict_sequence = set strict_sequence + let _strict_formats = set strict_formats let _S = set keep_asm_file let _short_paths = clear real_paths let _stdin () = file_argument "" diff --git a/toplevel/topdirs.ml b/toplevel/topdirs.ml index 20fe39b26..1e260139e 100644 --- a/toplevel/topdirs.ml +++ b/toplevel/topdirs.ml @@ -61,7 +61,12 @@ exception Load_failed let check_consistency ppf filename cu = try List.iter - (fun (name, crc) -> Consistbl.check Env.crc_units name crc filename) + (fun (name, crco) -> + Env.add_import name; + match crco with + None -> () + | Some crc-> + Consistbl.check Env.crc_units name crc filename) cu.cu_imports with Consistbl.Inconsistency(name, user, auth) -> fprintf ppf "@[<hv 0>The files %s@ and %s@ \ @@ -75,7 +80,7 @@ let load_compunit ic filename ppf compunit = let code_size = compunit.cu_codesize + 8 in let code = Meta.static_alloc code_size in unsafe_really_input ic code 0 compunit.cu_codesize; - String.unsafe_set code compunit.cu_codesize (Char.chr Opcodes.opRETURN); + Bytes.unsafe_set code compunit.cu_codesize (Char.chr Opcodes.opRETURN); String.unsafe_blit "\000\000\000\001\000\000\000" 0 code (compunit.cu_codesize + 1) 7; let initial_symtable = Symtable.current_state() in @@ -110,7 +115,7 @@ let rec load_file recursive ppf name = and really_load_file recursive ppf name filename ic = let ic = open_in_bin filename in - let buffer = Misc.input_bytes ic (String.length Config.cmo_magic_number) in + let buffer = really_input_string ic (String.length Config.cmo_magic_number) in try if buffer = Config.cmo_magic_number then begin let compunit_pos = input_binary_int ic in (* Go to descriptor *) @@ -318,6 +323,131 @@ let parse_warnings ppf iserr s = try Warnings.parse_options iserr s with Arg.Bad err -> fprintf ppf "%s.@." err +(* Typing information *) + +let rec trim_modtype = function + Mty_signature _ -> Mty_signature [] + | Mty_functor (id, mty, mty') -> + Mty_functor (id, mty, trim_modtype mty') + | Mty_ident _ | Mty_alias _ as mty -> mty + +let trim_signature = function + Mty_signature sg -> + Mty_signature + (List.map + (function + Sig_module (id, md, rs) -> + Sig_module (id, {md with md_type = trim_modtype md.md_type}, + rs) + (*| Sig_modtype (id, Modtype_manifest mty) -> + Sig_modtype (id, Modtype_manifest (trim_modtype mty))*) + | item -> item) + sg) + | mty -> mty + +let show_prim to_sig ppf lid = + let env = !Toploop.toplevel_env in + let loc = Location.none in + try + let s = + match lid with + | Longident.Lident s -> s + | Longident.Ldot (_,s) -> s + | Longident.Lapply _ -> + fprintf ppf "Invalid path %a@." Printtyp.longident lid; + raise Exit + in + let id = Ident.create_persistent s in + let sg = to_sig env loc id lid in + fprintf ppf "@[%a@]@." Printtyp.signature sg + with + | Not_found -> + fprintf ppf "@[Unknown element.@]@." + | Exit -> () + +let all_show_funs = ref [] + +let reg_show_prim name to_sig = + all_show_funs := to_sig :: !all_show_funs; + Hashtbl.add directive_table name (Directive_ident (show_prim to_sig std_out)) + +let () = + reg_show_prim "show_val" + (fun env loc id lid -> + let path, desc = Typetexp.find_value env loc lid in + [ Sig_value (id, desc) ] + ) + +let () = + reg_show_prim "show_type" + (fun env loc id lid -> + let path, desc = Typetexp.find_type env loc lid in + [ Sig_type (id, desc, Trec_not) ] + ) + +let () = + reg_show_prim "show_exception" + (fun env loc id lid -> + let desc = Typetexp.find_constructor env loc lid in + if not (Ctype.equal env true [desc.cstr_res] [Predef.type_exn]) then + raise Not_found; + let ret_type = + if desc.cstr_generalized then Some Predef.type_exn + else None + in + let ext = + { ext_type_path = Predef.path_exn; + ext_type_params = []; + ext_args = Cstr_tuple desc.cstr_args; + ext_ret_type = ret_type; + ext_private = Asttypes.Public; + Types.ext_loc = desc.cstr_loc; + Types.ext_attributes = desc.cstr_attributes; } + in + [Sig_typext (id, ext, Text_exception)] + ) + +let () = + reg_show_prim "show_module" + (fun env loc id lid -> + let path, md = Typetexp.find_module env loc lid in + [ Sig_module (id, {md with md_type = trim_signature md.md_type}, + Trec_not) ] + ) + +let () = + reg_show_prim "show_module_type" + (fun env loc id lid -> + let path, desc = Typetexp.find_modtype env loc lid in + [ Sig_modtype (id, desc) ] + ) + +let () = + reg_show_prim "show_class" + (fun env loc id lid -> + let path, desc = Typetexp.find_class env loc lid in + [ Sig_class (id, desc, Trec_not) ] + ) + +let () = + reg_show_prim "show_class_type" + (fun env loc id lid -> + let path, desc = Typetexp.find_class_type env loc lid in + [ Sig_class_type (id, desc, Trec_not) ] + ) + + +let show env loc id lid = + let sg = + List.fold_left + (fun sg f -> try (f env loc id lid) @ sg with _ -> sg) + [] !all_show_funs + in + if sg = [] then raise Not_found else sg + +let () = + Hashtbl.add directive_table "show" (Directive_ident (show_prim show std_out)) + let _ = Hashtbl.add directive_table "trace" (Directive_ident (dir_trace std_out)); Hashtbl.add directive_table "untrace" (Directive_ident (dir_untrace std_out)); @@ -342,8 +472,13 @@ let _ = Hashtbl.add directive_table "rectypes" (Directive_none(fun () -> Clflags.recursive_types := true)); + Hashtbl.add directive_table "ppx" + (Directive_string(fun s -> Clflags.all_ppx := s :: !Clflags.all_ppx)); + Hashtbl.add directive_table "warnings" (Directive_string (parse_warnings std_out false)); Hashtbl.add directive_table "warn_error" - (Directive_string (parse_warnings std_out true)) + (Directive_string (parse_warnings std_out true)); + + () diff --git a/toplevel/toploop.ml b/toplevel/toploop.ml index a0f6072d8..66a2b1abe 100644 --- a/toplevel/toploop.ml +++ b/toplevel/toploop.ml @@ -31,17 +31,18 @@ type directive_fun = (* The table of toplevel value bindings and its accessors *) -let toplevel_value_bindings = - (Hashtbl.create 37 : (string, Obj.t) Hashtbl.t) +module StringMap = Map.Make(String) + +let toplevel_value_bindings : Obj.t StringMap.t ref = ref StringMap.empty let getvalue name = try - Hashtbl.find toplevel_value_bindings name + StringMap.find name !toplevel_value_bindings with Not_found -> fatal_error (name ^ " unbound at toplevel") let setvalue name v = - Hashtbl.replace toplevel_value_bindings name v + toplevel_value_bindings := StringMap.add name v !toplevel_value_bindings (* Return the value referred to by a path *) @@ -52,7 +53,7 @@ let rec eval_path = function else begin let name = Translmod.toplevel_name id in try - Hashtbl.find toplevel_value_bindings name + StringMap.find name !toplevel_value_bindings with Not_found -> raise (Symtable.Error(Symtable.Undefined_global name)) end @@ -82,6 +83,7 @@ let print_out_value = Oprint.out_value let print_out_type = Oprint.out_type let print_out_class_type = Oprint.out_class_type let print_out_module_type = Oprint.out_module_type +let print_out_type_extension = Oprint.out_type_extension let print_out_sig_item = Oprint.out_sig_item let print_out_signature = Oprint.out_signature let print_out_phrase = Oprint.out_phrase @@ -149,6 +151,7 @@ let load_lambda ppf lam = Symtable.patch_object code reloc; Symtable.check_global_initialized reloc; Symtable.update_global_table(); + let initial_bindings = !toplevel_value_bindings in try may_trace := true; let retval = (Meta.reify_bytecode code code_size) () in @@ -164,6 +167,7 @@ let load_lambda ppf lam = Meta.static_release_bytecode code code_size; Meta.static_free code; end; + toplevel_value_bindings := initial_bindings; (* PR#6211 *) Symtable.restore_state initial_symtable; Exception x @@ -244,19 +248,27 @@ let execute_phrase print_outcome ppf phr = toplevel_env := oldenv; raise x end | Ptop_dir(dir_name, dir_arg) -> - try - match (Hashtbl.find directive_table dir_name, dir_arg) with - | (Directive_none f, Pdir_none) -> f (); true - | (Directive_string f, Pdir_string s) -> f s; true - | (Directive_int f, Pdir_int n) -> f n; true - | (Directive_ident f, Pdir_ident lid) -> f lid; true - | (Directive_bool f, Pdir_bool b) -> f b; true - | (_, _) -> - fprintf ppf "Wrong type of argument for directive `%s'.@." dir_name; - false - with Not_found -> - fprintf ppf "Unknown directive `%s'.@." dir_name; - false + let d = + try Some (Hashtbl.find directive_table dir_name) + with Not_found -> None + in + begin match d with + | None -> + fprintf ppf "Unknown directive `%s'.@." dir_name; + false + | Some d -> + match d, dir_arg with + | Directive_none f, Pdir_none -> f (); true + | Directive_string f, Pdir_string s -> f s; true + | Directive_int f, Pdir_int n -> f n; true + | Directive_ident f, Pdir_ident lid -> f lid; true + | Directive_bool f, Pdir_bool b -> f b; true + | _ -> + fprintf ppf "Wrong type of argument for directive `%s'.@." + dir_name; + false + end + (* Temporary assignment to a reference *) @@ -275,11 +287,14 @@ let protect r newval body = let use_print_results = ref true -let phrase ppf phr = +let preprocess_phrase ppf phr = let phr = match phr with | Ptop_def str -> - Ptop_def (Pparse.apply_rewriters ast_impl_magic_number str) + let str = + Pparse.apply_rewriters_str ~restore:true ~tool_name:"ocaml" str + in + Ptop_def str | phr -> phr in if !Clflags.dump_parsetree then Printast.top_phrase ppf phr; @@ -306,7 +321,7 @@ let use_file ppf wrap_mod name = try List.iter (fun ph -> - let ph = phrase ppf ph in + let ph = preprocess_phrase ppf ph in if not (execute_phrase !use_print_results ppf ph) then raise Exit) (if wrap_mod then parse_mod_use_file name lb @@ -339,7 +354,7 @@ let read_input_default prompt buffer len = while true do if !i >= len then raise Exit; let c = input_char Pervasives.stdin in - buffer.[!i] <- c; + Bytes.set buffer !i c; incr i; if c = '\n' then raise Exit; done; @@ -380,8 +395,12 @@ let _ = let crc_intfs = Symtable.init_toplevel() in Compmisc.init_path false; List.iter - (fun (name, crc) -> - Consistbl.set Env.crc_units name crc Sys.executable_name) + (fun (name, crco) -> + Env.add_import name; + match crco with + None -> () + | Some crc-> + Consistbl.set Env.crc_units name crc Sys.executable_name) crc_intfs let load_ocamlinit ppf = @@ -428,7 +447,7 @@ let loop ppf = Location.reset(); first_line := true; let phr = try !parse_toplevel_phrase lb with Exit -> raise PPerror in - let phr = phrase ppf phr in + let phr = preprocess_phrase ppf phr in Env.reset_cache_toplevel (); ignore(execute_phrase true ppf phr) with diff --git a/toplevel/toploop.mli b/toplevel/toploop.mli index 324857a83..1867c001e 100644 --- a/toplevel/toploop.mli +++ b/toplevel/toploop.mli @@ -53,6 +53,9 @@ val execute_phrase : bool -> formatter -> Parsetree.toplevel_phrase -> bool phrase executed with no errors and [false] otherwise. First bool says whether the values and types of the results should be printed. Uncaught exceptions are always printed. *) +val preprocess_phrase : formatter -> Parsetree.toplevel_phrase -> Parsetree.toplevel_phrase + (* Preprocess the given toplevel phrase using regular and ppx + preprocessors. Return the updated phrase. *) val use_file : formatter -> string -> bool val use_silently : formatter -> string -> bool val mod_use_file : formatter -> string -> bool @@ -92,6 +95,8 @@ val print_out_class_type : (formatter -> Outcometree.out_class_type -> unit) ref val print_out_module_type : (formatter -> Outcometree.out_module_type -> unit) ref +val print_out_type_extension : + (formatter -> Outcometree.out_type_extension -> unit) ref val print_out_sig_item : (formatter -> Outcometree.out_sig_item -> unit) ref val print_out_signature : @@ -101,7 +106,7 @@ val print_out_phrase : (* Hooks for external line editor *) -val read_interactive_input : (string -> string -> int -> int * bool) ref +val read_interactive_input : (string -> bytes -> int -> int * bool) ref (* Hooks for initialization *) diff --git a/toplevel/topmain.ml b/toplevel/topmain.ml index 0f3ac66f9..0d8f2d4c2 100644 --- a/toplevel/topmain.ml +++ b/toplevel/topmain.ml @@ -41,6 +41,7 @@ let file_argument name = let newargs = Array.sub Sys.argv !Arg.current (Array.length Sys.argv - !Arg.current) in + Compenv.readenv ppf Before_link; if prepare ppf && Toploop.run_script ppf name newargs then exit 0 else exit 2 @@ -67,20 +68,24 @@ module Options = Main_args.Make_bytetop_options (struct let _init s = init_file := Some s let _noinit = set noinit let _labels = clear classic + let _no_alias_deps = set transparent_modules let _no_app_funct = clear applicative_functors let _noassert = set noassert let _nolabels = set classic let _noprompt = set noprompt let _nopromptcont = set nopromptcont let _nostdlib = set no_std_include + let _open s = open_modules := s :: !open_modules let _ppx s = first_ppx := s :: !first_ppx let _principal = set principal let _rectypes = set recursive_types + let _safe_string = clear unsafe_string let _short_paths = clear real_paths let _stdin () = file_argument "" let _strict_sequence = set strict_sequence - let _trans_mod = set transparent_modules + let _strict_formats = set strict_formats let _unsafe = set fast + let _unsafe_string = set unsafe_string let _version () = print_version () let _vnum () = print_version_num () let _w s = Warnings.parse_options false s diff --git a/toplevel/trace.ml b/toplevel/trace.ml index 60cfb9539..669044836 100644 --- a/toplevel/trace.ml +++ b/toplevel/trace.ml @@ -96,14 +96,18 @@ let rec instrument_result env name ppf clos_typ = (* Same as instrument_result, but for a toplevel closure (modified in place) *) +exception Dummy +let _ = Dummy + let instrument_closure env name ppf clos_typ = match (Ctype.repr(Ctype.expand_head env clos_typ)).desc with | Tarrow(l, t1, t2, _) -> let trace_res = instrument_result env name ppf t2 in (fun actual_code closure arg -> if not !may_trace then begin - let res = invoke_traced_function actual_code closure arg - in res (* do not remove let, prevents tail-call to invoke_traced_ *) + try invoke_traced_function actual_code closure arg + with Dummy -> assert false + (* do not remove handler, prevents tail-call to invoke_traced_ *) end else begin may_trace := false; try diff --git a/typing/btype.ml b/typing/btype.ml index 366e09e9a..f23b7387b 100644 --- a/typing/btype.ml +++ b/typing/btype.ml @@ -241,7 +241,7 @@ type type_iterators = it_signature_item: type_iterators -> signature_item -> unit; it_value_description: type_iterators -> value_description -> unit; it_type_declaration: type_iterators -> type_declaration -> unit; - it_exception_declaration: type_iterators -> exception_declaration -> unit; + it_extension_constructor: type_iterators -> extension_constructor -> unit; it_module_declaration: type_iterators -> module_declaration -> unit; it_modtype_declaration: type_iterators -> modtype_declaration -> unit; it_class_declaration: type_iterators -> class_declaration -> unit; @@ -249,16 +249,41 @@ type type_iterators = it_module_type: type_iterators -> module_type -> unit; it_class_type: type_iterators -> class_type -> unit; it_type_kind: type_iterators -> type_kind -> unit; + it_do_type_expr: type_iterators -> type_expr -> unit; it_type_expr: type_iterators -> type_expr -> unit; it_path: Path.t -> unit; } +let iter_type_expr_cstr_args f = function + | Cstr_tuple tl -> List.iter f tl + | Cstr_record lbls -> List.iter (fun d -> f d.ld_type) lbls + +let map_type_expr_cstr_args f = function + | Cstr_tuple tl -> Cstr_tuple (List.map f tl) + | Cstr_record lbls -> + Cstr_record (List.map (fun d -> {d with ld_type=f d.ld_type}) lbls) + +let iter_type_expr_kind f = function + | Type_abstract -> () + | Type_variant cstrs -> + List.iter + (fun cd -> + iter_type_expr_cstr_args f cd.cd_args; + Misc.may f cd.cd_res + ) + cstrs + | Type_record(lbls, _) -> + List.iter (fun d -> f d.ld_type) lbls + | Type_open -> + () + + let type_iterators = let it_signature it = List.iter (it.it_signature_item it) and it_signature_item it = function Sig_value (_, vd) -> it.it_value_description it vd | Sig_type (_, td, _) -> it.it_type_declaration it td - | Sig_exception (_, ed) -> it.it_exception_declaration it ed + | Sig_typext (_, td, _) -> it.it_extension_constructor it td | Sig_module (_, md, _) -> it.it_module_declaration it md | Sig_modtype (_, mtd) -> it.it_modtype_declaration it mtd | Sig_class (_, cd, _) -> it.it_class_declaration it cd @@ -269,8 +294,11 @@ let type_iterators = List.iter (it.it_type_expr it) td.type_params; may (it.it_type_expr it) td.type_manifest; it.it_type_kind it td.type_kind - and it_exception_declaration it ed = - List.iter (it.it_type_expr it) ed.exn_args + and it_extension_constructor it td = + it.it_path td.ext_type_path; + List.iter (it.it_type_expr it) td.ext_type_params; + iter_type_expr_cstr_args (it.it_type_expr it) td.ext_args; + may (it.it_type_expr it) td.ext_ret_type and it_module_declaration it md = it.it_module_type it md.md_type and it_modtype_declaration it mtd = @@ -305,16 +333,9 @@ let type_iterators = | Cty_arrow (_, ty, cty) -> it.it_type_expr it ty; it.it_class_type it cty - and it_type_kind it = function - Type_abstract -> () - | Type_record (ll, _) -> - List.iter (fun ld -> it.it_type_expr it ld.ld_type) ll - | Type_variant cl -> - List.iter (fun cd -> - List.iter (it.it_type_expr it) cd.cd_args; - may (it.it_type_expr it) cd.cd_res) - cl - and it_type_expr it ty = + and it_type_kind it kind = + iter_type_expr_kind (it.it_type_expr it) kind + and it_do_type_expr it ty = iter_type_expr (it.it_type_expr it) ty; match ty.desc with Tconstr (p, _, _) @@ -326,9 +347,10 @@ let type_iterators = | _ -> () and it_path p = () in - { it_path; it_type_expr; it_type_kind; it_class_type; it_module_type; + { it_path; it_type_expr = it_do_type_expr; it_do_type_expr; + it_type_kind; it_class_type; it_module_type; it_signature; it_class_type_declaration; it_class_declaration; - it_modtype_declaration; it_module_declaration; it_exception_declaration; + it_modtype_declaration; it_module_declaration; it_extension_constructor; it_type_declaration; it_value_description; it_signature_item; } let copy_row f fixed row keep more = @@ -430,6 +452,17 @@ let mark_type_node ty = let mark_type_params ty = iter_type_expr mark_type ty +let type_iterators = + let it_type_expr it ty = + let ty = repr ty in + if ty.level >= lowest_level then begin + mark_type_node ty; + it.it_do_type_expr it ty; + end + in + {type_iterators with it_type_expr} + + (* Remove marks from a type. *) let rec unmark_type ty = let ty = repr ty in @@ -438,36 +471,24 @@ let rec unmark_type ty = iter_type_expr unmark_type ty end +let unmark_iterators = + let it_type_expr it ty = unmark_type ty in + {type_iterators with it_type_expr} + let unmark_type_decl decl = - List.iter unmark_type decl.type_params; - begin match decl.type_kind with - Type_abstract -> () - | Type_variant cstrs -> - List.iter - (fun d -> - List.iter unmark_type d.cd_args; - Misc.may unmark_type d.cd_res) - cstrs - | Type_record(lbls, rep) -> - List.iter (fun d -> unmark_type d.ld_type) lbls - end; - begin match decl.type_manifest with - None -> () - | Some ty -> unmark_type ty - end + unmark_iterators.it_type_declaration unmark_iterators decl + +let unmark_extension_constructor ext = + List.iter unmark_type ext.ext_type_params; + iter_type_expr_cstr_args unmark_type ext.ext_args; + Misc.may unmark_type ext.ext_ret_type let unmark_class_signature sign = unmark_type sign.csig_self; Vars.iter (fun l (m, v, t) -> unmark_type t) sign.csig_vars -let rec unmark_class_type = - function - Cty_constr (p, tyl, cty) -> - List.iter unmark_type tyl; unmark_class_type cty - | Cty_signature sign -> - unmark_class_signature sign - | Cty_arrow (_, ty, cty) -> - unmark_type ty; unmark_class_type cty +let unmark_class_type cty = + unmark_iterators.it_class_type unmark_iterators cty (*******************************************) @@ -547,6 +568,9 @@ let label_name l = if is_optional l then String.sub l 1 (String.length l - 1) else l +let prefixed_label_name l = + if is_optional l then l else "~" ^ l + let rec extract_label_aux hd l = function [] -> raise Not_found | (l',t as p) :: ls -> diff --git a/typing/btype.mli b/typing/btype.mli index 871760093..ec63e9ae6 100644 --- a/typing/btype.mli +++ b/typing/btype.mli @@ -95,7 +95,7 @@ type type_iterators = it_signature_item: type_iterators -> signature_item -> unit; it_value_description: type_iterators -> value_description -> unit; it_type_declaration: type_iterators -> type_declaration -> unit; - it_exception_declaration: type_iterators -> exception_declaration -> unit; + it_extension_constructor: type_iterators -> extension_constructor -> unit; it_module_declaration: type_iterators -> module_declaration -> unit; it_modtype_declaration: type_iterators -> modtype_declaration -> unit; it_class_declaration: type_iterators -> class_declaration -> unit; @@ -103,10 +103,14 @@ type type_iterators = it_module_type: type_iterators -> module_type -> unit; it_class_type: type_iterators -> class_type -> unit; it_type_kind: type_iterators -> type_kind -> unit; + it_do_type_expr: type_iterators -> type_expr -> unit; it_type_expr: type_iterators -> type_expr -> unit; it_path: Path.t -> unit; } -val type_iterators : type_iterators - (* Iteration on arbitrary type information *) +val type_iterators: type_iterators + (* Iteration on arbitrary type information. + [it_type_expr] calls [mark_type_node] to avoid loops. *) +val unmark_iterators: type_iterators + (* Unmark any structure containing types. See [unmark_type] below. *) val copy_type_desc: ?keep_names:bool -> (type_expr -> type_expr) -> type_desc -> type_desc @@ -135,6 +139,7 @@ val mark_type_params: type_expr -> unit (* Mark the sons of a type node *) val unmark_type: type_expr -> unit val unmark_type_decl: type_declaration -> unit +val unmark_extension_constructor: extension_constructor -> unit val unmark_class_type: class_type -> unit val unmark_class_signature: class_signature -> unit (* Remove marks from a type *) @@ -159,6 +164,10 @@ val forget_abbrev: val is_optional : label -> bool val label_name : label -> label + +(* Returns the label name with first character '?' or '~' as appropriate. *) +val prefixed_label_name : label -> label + val extract_label : label -> (label * 'a) list -> label * 'a * (label * 'a) list * (label * 'a) list @@ -194,3 +203,10 @@ val log_type: type_expr -> unit (**** Forward declarations ****) val print_raw: (Format.formatter -> type_expr -> unit) ref + +val iter_type_expr_kind: (type_expr -> unit) -> (type_kind -> unit) + +val iter_type_expr_cstr_args: (type_expr -> unit) -> + (constructor_arguments -> unit) +val map_type_expr_cstr_args: (type_expr -> type_expr) -> + (constructor_arguments -> constructor_arguments) diff --git a/typing/cmi_format.ml b/typing/cmi_format.ml index e5a8399fa..6f421fdcf 100644 --- a/typing/cmi_format.ml +++ b/typing/cmi_format.ml @@ -22,7 +22,7 @@ exception Error of error type cmi_infos = { cmi_name : string; cmi_sign : Types.signature_item list; - cmi_crcs : (string * Digest.t) list; + cmi_crcs : (string * Digest.t option) list; cmi_flags : pers_flags list; } @@ -40,7 +40,9 @@ let input_cmi ic = let read_cmi filename = let ic = open_in_bin filename in try - let buffer = Misc.input_bytes ic (String.length Config.cmi_magic_number) in + let buffer = + really_input_string ic (String.length Config.cmi_magic_number) + in if buffer <> Config.cmi_magic_number then begin close_in ic; let pre_len = String.length Config.cmi_magic_number - 3 in @@ -70,7 +72,7 @@ let output_cmi filename oc cmi = output_value oc (cmi.cmi_name, cmi.cmi_sign); flush oc; let crc = Digest.file filename in - let crcs = (cmi.cmi_name, crc) :: cmi.cmi_crcs in + let crcs = (cmi.cmi_name, Some crc) :: cmi.cmi_crcs in output_value oc crcs; output_value oc cmi.cmi_flags; crc diff --git a/typing/cmi_format.mli b/typing/cmi_format.mli index 2d6fdec6b..32cec451f 100644 --- a/typing/cmi_format.mli +++ b/typing/cmi_format.mli @@ -15,7 +15,7 @@ type pers_flags = Rectypes type cmi_infos = { cmi_name : string; cmi_sign : Types.signature_item list; - cmi_crcs : (string * Digest.t) list; + cmi_crcs : (string * Digest.t option) list; cmi_flags : pers_flags list; } diff --git a/typing/cmt_format.ml b/typing/cmt_format.ml index c2e3791f0..6cecb1b69 100644 --- a/typing/cmt_format.ml +++ b/typing/cmt_format.ml @@ -23,9 +23,7 @@ open Typedtree let read_magic_number ic = let len_magic_number = String.length Config.cmt_magic_number in - let magic_number = String.create len_magic_number in - really_input ic magic_number 0 len_magic_number; - magic_number + really_input_string ic len_magic_number type binary_annots = | Packed of Types.signature * string list @@ -56,7 +54,7 @@ type cmt_infos = { cmt_loadpath : string list; cmt_source_digest : Digest.t option; cmt_initial_env : Env.t; - cmt_imports : (string * Digest.t) list; + cmt_imports : (string * Digest.t option) list; cmt_interface_digest : Digest.t option; cmt_use_summaries : bool; } @@ -203,7 +201,7 @@ let record_value_dependency vd1 vd2 = let save_cmt filename modname binary_annots sourcefile initial_env sg = if !Clflags.binary_annotations && not !Clflags.print_types then begin - let imports = Env.imported_units () in + let imports = Env.imports () in let oc = open_out_bin filename in let this_crc = match sg with @@ -239,4 +237,3 @@ let save_cmt filename modname binary_annots sourcefile initial_env sg = close_out oc; end; clear () - diff --git a/typing/cmt_format.mli b/typing/cmt_format.mli index 30493063d..48fbc639e 100644 --- a/typing/cmt_format.mli +++ b/typing/cmt_format.mli @@ -57,7 +57,7 @@ type cmt_infos = { cmt_loadpath : string list; cmt_source_digest : string option; cmt_initial_env : Env.t; - cmt_imports : (string * Digest.t) list; + cmt_imports : (string * Digest.t option) list; cmt_interface_digest : Digest.t option; cmt_use_summaries : bool; } @@ -102,7 +102,8 @@ val add_saved_type : binary_part -> unit val get_saved_types : unit -> binary_part list val set_saved_types : binary_part list -> unit -val record_value_dependency: Types.value_description -> Types.value_description -> unit +val record_value_dependency: + Types.value_description -> Types.value_description -> unit (* diff --git a/typing/ctype.ml b/typing/ctype.ml index d75dea43e..aa6eabfae 100644 --- a/typing/ctype.ml +++ b/typing/ctype.ml @@ -217,23 +217,38 @@ type unification_mode = let umode = ref Expression let generate_equations = ref false +let assume_injective = ref false -let set_mode mode ?(generate = (mode = Pattern)) f = +let set_mode_expression f = + let old_unification_mode = !umode in + try + umode := Expression; + let ret = f () in + umode := old_unification_mode; + ret + with e -> + umode := old_unification_mode; + raise e + +let set_mode_pattern ~generate ~injective f = let old_unification_mode = !umode - and old_gen = !generate_equations in + and old_gen = !generate_equations + and old_inj = !assume_injective in try - umode := mode; + umode := Pattern; generate_equations := generate; + assume_injective := injective; let ret = f () in umode := old_unification_mode; generate_equations := old_gen; + assume_injective := old_inj; ret with e -> umode := old_unification_mode; generate_equations := old_gen; + assume_injective := old_inj; raise e - (*** Checks for type definitions ***) let in_current_module = function @@ -242,12 +257,12 @@ let in_current_module = function let in_pervasives p = in_current_module p && - try ignore (Env.find_type p Env.initial); true + try ignore (Env.find_type p Env.initial_safe_string); true with Not_found -> false let is_datatype decl= match decl.type_kind with - Type_record _ | Type_variant _ -> true + Type_record _ | Type_variant _ | Type_open -> true | Type_abstract -> false @@ -278,7 +293,7 @@ let flatten_fields ty = (l, ty) in let (l, r) = flatten [] ty in - (Sort.list (fun (n, _, _) (n', _, _) -> n < n') l, r) + (List.sort (fun (n, _, _) (n', _, _) -> compare n n') l, r) let build_fields level = List.fold_right @@ -407,7 +422,7 @@ let rec class_type_arity = (* Miscellaneous operations on row types *) (*******************************************) -let sort_row_fields = Sort.list (fun (p,_) (q,_) -> p < q) +let sort_row_fields = List.sort (fun (p,_) (q,_) -> compare p q) let rec merge_rf r1 r2 pairs fi1 fi2 = match fi1, fi2 with @@ -439,7 +454,7 @@ let rec filter_row_fields erase = function (**************************************) -exception Non_closed +exception Non_closed0 let rec closed_schema_rec ty = let ty = repr ty in @@ -448,7 +463,7 @@ let rec closed_schema_rec ty = ty.level <- pivot_level - level; match ty.desc with Tvar _ when level <> generic_level -> - raise Non_closed + raise Non_closed0 | Tfield(_, kind, t1, t2) -> if field_kind_repr kind = Fpresent then closed_schema_rec t1; @@ -467,7 +482,7 @@ let closed_schema ty = closed_schema_rec ty; unmark_type ty; true - with Non_closed -> + with Non_closed0 -> unmark_type ty; false @@ -546,10 +561,15 @@ let closed_type_decl decl = (fun {cd_args; cd_res; _} -> match cd_res with | Some _ -> () - | None -> List.iter closed_type cd_args) + | None -> + match cd_args with + | Cstr_tuple l -> List.iter closed_type l + | Cstr_record l -> List.iter (fun l -> closed_type l.ld_type) l + ) v | Type_record(r, rep) -> List.iter (fun l -> closed_type l.ld_type) r + | Type_open -> () end; begin match decl.type_manifest with None -> () @@ -561,11 +581,24 @@ let closed_type_decl decl = unmark_type_decl decl; Some ty +let closed_extension_constructor ext = + try + List.iter mark_type ext.ext_type_params; + begin match ext.ext_ret_type with + | Some _ -> () + | None -> iter_type_expr_cstr_args closed_type ext.ext_args + end; + unmark_extension_constructor ext; + None + with Non_closed (ty, _) -> + unmark_extension_constructor ext; + Some ty + type closed_class_failure = CC_Method of type_expr * bool * string * type_expr | CC_Value of type_expr * bool * string * type_expr -exception Failure of closed_class_failure +exception CCFailure of closed_class_failure let closed_class params sign = let ty = object_fields (repr sign.csig_self) in @@ -581,13 +614,13 @@ let closed_class params sign = (fun (lab, kind, ty) -> if field_kind_repr kind = Fpresent then try closed_type ty with Non_closed (ty0, real) -> - raise (Failure (CC_Method (ty0, real, lab, ty)))) + raise (CCFailure (CC_Method (ty0, real, lab, ty)))) fields; mark_type_params (repr sign.csig_self); List.iter unmark_type params; unmark_class_signature sign; None - with Failure reason -> + with CCFailure reason -> mark_type_params (repr sign.csig_self); List.iter unmark_type params; unmark_class_signature sign; @@ -746,7 +779,7 @@ let rec update_level env level ty = if level < get_level env p then raise (Unify [(ty, newvar2 level)]); iter_type_expr (update_level env level) ty end - | Tpackage (p, nl, tl) when level < get_level env p -> + | Tpackage (p, nl, tl) when level < Path.binding_time p -> let p' = normalize_package_path env p in if Path.same p p' then raise (Unify [(ty, newvar2 level)]); log_type ty; ty.desc <- Tpackage (p', nl, tl); @@ -1156,25 +1189,31 @@ let instance_parameterized_type_2 sch_args sch_lst sch = cleanup_types (); (ty_args, ty_lst, ty) +let map_kind f = function + | Type_abstract -> Type_abstract + | Type_open -> Type_open + | Type_variant cl -> + Type_variant ( + List.map + (fun c -> + {c with + cd_args = map_type_expr_cstr_args f c.cd_args; + cd_res = may_map f c.cd_res + }) + cl) + | Type_record (fl, rr) -> + Type_record ( + List.map + (fun l -> + {l with ld_type = f l.ld_type} + ) fl, rr) + + let instance_declaration decl = let decl = {decl with type_params = List.map simple_copy decl.type_params; type_manifest = may_map simple_copy decl.type_manifest; - type_kind = match decl.type_kind with - | Type_abstract -> Type_abstract - | Type_variant cl -> - Type_variant ( - List.map - (fun c -> - {c with cd_args=List.map simple_copy c.cd_args; - cd_res=may_map simple_copy c.cd_res}) - cl) - | Type_record (fl, rr) -> - Type_record ( - List.map - (fun l -> - {l with ld_type = copy l.ld_type} - ) fl, rr) + type_kind = map_kind simple_copy decl.type_kind; } in cleanup_types (); @@ -1571,12 +1610,14 @@ let generic_private_abbrev env path = | _ -> false with Not_found -> false - (*****************) - (* Occur check *) - (*****************) - +let is_contractive env ty = + match (repr ty).desc with + Tconstr (p, _, _) -> + in_pervasives p || + (try is_datatype (Env.find_type p env) with Not_found -> false) + | _ -> true -exception Occur +(* Code moved to Typedecl (* The marks are already used by [expand_abbrev]... *) let visited = ref [] @@ -1619,6 +1660,14 @@ let correct_abbrev env path params ty = simple_abbrevs := Mnil; visited := []; raise exn +*) + + (*****************) + (* Occur check *) + (*****************) + + +exception Occur let rec occur_rec env visited ty0 ty = if ty == ty0 then raise Occur; @@ -1664,7 +1713,9 @@ let occur env ty0 ty = let occur_in env ty0 t = try occur env ty0 t; false with Unify _ -> true -(* checks that a local constraint is non recursive *) +(* Check that a local constraint is well-founded *) +(* PR#6405: not needed since we allow recursion and work on normalized types *) +(* let rec local_non_recursive_abbrev visited env p ty = let ty = repr ty in if not (List.memq ty !visited) then begin @@ -1674,19 +1725,14 @@ let rec local_non_recursive_abbrev visited env p ty = if Path.same p p' then raise Recursive_abbrev; begin try local_non_recursive_abbrev visited env p (try_expand_once_opt env ty) - with Cannot_expand -> - if !Clflags.recursive_types then () else - iter_type_expr (local_non_recursive_abbrev visited env p) ty + with Cannot_expand -> () end - | Tobject _ | Tvariant _ -> - () - | _ -> - if !Clflags.recursive_types then () else - iter_type_expr (local_non_recursive_abbrev visited env p) ty + | _ -> () end let local_non_recursive_abbrev env p = local_non_recursive_abbrev (ref []) env p +*) (*****************************) (* Polymorphic Unification *) @@ -1964,6 +2010,18 @@ let non_aliasable p decl = (* in_pervasives p || (subsumed by in_current_module) *) in_current_module p && decl.type_newtype_level = None +(* Check for datatypes carefully; see PR#6348 *) +let rec expands_to_datatype env ty = + let ty = repr ty in + match ty.desc with + Tconstr (p, _, _) -> + begin try + is_datatype (Env.find_type p env) || + expands_to_datatype env (try_expand_once env ty) + with Not_found | Cannot_expand -> false + end + | _ -> false + (* mcomp type_pairs subst env t1 t2 does not raise an exception if it is possible that t1 and t2 are actually equal, assuming the types in type_pairs are equal and @@ -2088,10 +2146,6 @@ and mcomp_type_decl type_pairs env p1 p2 tl1 tl2 = let decl = Env.find_type p1 env in let decl' = Env.find_type p2 env in if Path.same p1 p2 then begin - (* Format.eprintf "@[%a@ %a@]@." - !print_raw (newconstr p1 tl2) !print_raw (newconstr p2 tl2); - if non_aliasable p1 decl then Format.eprintf "non_aliasable@." - else Format.eprintf "aliasable@."; *) let inj = try List.map Variance.(mem Inj) (Env.find_type p1 env).type_variance with Not_found -> List.map (fun _ -> false) tl1 @@ -2099,19 +2153,22 @@ and mcomp_type_decl type_pairs env p1 p2 tl1 tl2 = List.iter2 (fun i (t1,t2) -> if i then mcomp type_pairs env t1 t2) inj (List.combine tl1 tl2) - end - else match decl.type_kind, decl'.type_kind with - | Type_record (lst,r), Type_record (lst',r') when r = r' -> - mcomp_list type_pairs env tl1 tl2; - mcomp_record_description type_pairs env lst lst' - | Type_variant v1, Type_variant v2 -> - mcomp_list type_pairs env tl1 tl2; - mcomp_variant_description type_pairs env v1 v2 - | Type_variant _, Type_record _ - | Type_record _, Type_variant _ -> raise (Unify []) - | _ -> - if non_aliasable p1 decl && (non_aliasable p2 decl'||is_datatype decl') - || is_datatype decl && non_aliasable p2 decl' then raise (Unify []) + end else if non_aliasable p1 decl && non_aliasable p2 decl' then + raise (Unify []) + else + match decl.type_kind, decl'.type_kind with + | Type_record (lst,r), Type_record (lst',r') when r = r' -> + mcomp_list type_pairs env tl1 tl2; + mcomp_record_description type_pairs env lst lst' + | Type_variant v1, Type_variant v2 -> + mcomp_list type_pairs env tl1 tl2; + mcomp_variant_description type_pairs env v1 v2 + | Type_open, Type_open -> + mcomp_list type_pairs env tl1 tl2 + | Type_abstract, Type_abstract -> () + | Type_abstract, _ when not (non_aliasable p1 decl)-> () + | _, Type_abstract when not (non_aliasable p2 decl') -> () + | _ -> raise (Unify []) with Not_found -> () and mcomp_type_option type_pairs env t t' = @@ -2125,7 +2182,12 @@ and mcomp_variant_description type_pairs env xs ys = match x, y with | c1 :: xs, c2 :: ys -> mcomp_type_option type_pairs env c1.cd_res c2.cd_res; - mcomp_list type_pairs env c1.cd_args c2.cd_args; + begin match c1.cd_args, c2.cd_args with + | Cstr_tuple l1, Cstr_tuple l2 -> mcomp_list type_pairs env l1 l2 + | Cstr_record l1, Cstr_record l2 -> + mcomp_record_description type_pairs env l1 l2 + | _ -> raise (Unify []) + end; if Ident.name c1.cd_id = Ident.name c2.cd_id then iter xs ys else raise (Unify []) @@ -2243,7 +2305,7 @@ let unify_package env unify_list lv1 p1 n1 tl1 lv2 p2 n2 tl2 = let ntl2 = complete_type_list env n1 lv2 (Mty_ident p2) n2 tl2 and ntl1 = complete_type_list env n2 lv2 (Mty_ident p1) n1 tl1 in unify_list (List.map snd ntl1) (List.map snd ntl2); - if eq_package_path env p1 p2 + if eq_package_path env p1 p2 || !package_subtype env p1 n1 tl1 p2 n2 tl2 && !package_subtype env p2 n2 tl2 p1 n1 tl1 then () else raise Not_found @@ -2394,10 +2456,13 @@ and unify3 env t1 t1' t2 t2' = | (Ttuple tl1, Ttuple tl2) -> unify_list env tl1 tl2 | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _)) when Path.same p1 p2 -> - if !umode = Expression || not !generate_equations - || in_current_module p1 (* || in_pervasives p1 *) - || try is_datatype (Env.find_type p1 !env) with Not_found -> false - then + if !umode = Expression || not !generate_equations then + unify_list env tl1 tl2 + else if !assume_injective then + set_mode_pattern ~generate:true ~injective:false + (fun () -> unify_list env tl1 tl2) + else if in_current_module p1 (* || in_pervasives p1 *) + || List.exists (expands_to_datatype !env) [t1'; t1; t2] then unify_list env tl1 tl2 else let inj = @@ -2408,7 +2473,7 @@ and unify3 env t1 t1' t2 t2' = List.iter2 (fun i (t1, t2) -> if i then unify env t1 t2 else - set_mode Pattern ~generate:false + set_mode_pattern ~generate:false ~injective:false begin fun () -> let snap = snapshot () in try unify env t1 t2 with Unify _ -> @@ -2428,12 +2493,12 @@ and unify3 env t1 t1' t2 t2' = | (Tconstr ((Path.Pident p) as path,[],_), _) when is_newtype !env path && !generate_equations -> reify env t2'; - local_non_recursive_abbrev !env (Path.Pident p) t2'; + (* local_non_recursive_abbrev !env (Path.Pident p) t2'; *) add_gadt_equation env p t2' | (_, Tconstr ((Path.Pident p) as path,[],_)) when is_newtype !env path && !generate_equations -> reify env t1' ; - local_non_recursive_abbrev !env (Path.Pident p) t1'; + (* local_non_recursive_abbrev !env (Path.Pident p) t1'; *) add_gadt_equation env p t1' | (Tconstr (_,_,_), _) | (_, Tconstr (_,_,_)) when !umode = Pattern -> reify env t1'; @@ -2715,7 +2780,8 @@ let unify_gadt ~newtype_level:lev (env:Env.t ref) ty1 ty2 = try univar_pairs := []; newtype_level := Some lev; - set_mode Pattern (fun () -> unify env ty1 ty2); + set_mode_pattern ~generate:true ~injective:true + (fun () -> unify env ty1 ty2); newtype_level := None; TypePairs.clear unify_eq_set; with e -> @@ -4273,27 +4339,7 @@ let nondep_type_decl env mid id is_covariant decl = try let params = List.map (nondep_type_rec env mid) decl.type_params in let tk = - try match decl.type_kind with - Type_abstract -> - Type_abstract - | Type_variant cstrs -> - Type_variant - (List.map - (fun c -> - {c with - cd_args = List.map (nondep_type_rec env mid) c.cd_args; - cd_res = may_map (nondep_type_rec env mid) c.cd_res; - } - ) - cstrs) - | Type_record(lbls, rep) -> - Type_record - (List.map - (fun l -> - {l with ld_type = nondep_type_rec env mid l.ld_type} - ) - lbls, - rep) + try map_kind (nondep_type_rec env mid) decl.type_kind with Not_found when is_covariant -> Type_abstract and tm = try match decl.type_manifest with @@ -4323,6 +4369,42 @@ let nondep_type_decl env mid id is_covariant decl = clear_hash (); raise Not_found +(* Preserve sharing inside extension constructors. *) +let nondep_extension_constructor env mid ext = + try + let type_path, type_params = + if Path.isfree mid ext.ext_type_path then + begin + let ty = + newgenty (Tconstr(ext.ext_type_path, ext.ext_type_params, ref Mnil)) + in + let ty' = nondep_type_rec env mid ty in + match (repr ty').desc with + Tconstr(p, tl, _) -> p, tl + | _ -> raise Not_found + end + else + let type_params = + List.map (nondep_type_rec env mid) ext.ext_type_params + in + ext.ext_type_path, type_params + in + let args = map_type_expr_cstr_args (nondep_type_rec env mid) ext.ext_args in + let ret_type = may_map (nondep_type_rec env mid) ext.ext_ret_type in + clear_hash (); + { ext_type_path = type_path; + ext_type_params = type_params; + ext_args = args; + ext_ret_type = ret_type; + ext_private = ext.ext_private; + ext_attributes = ext.ext_attributes; + ext_loc = ext.ext_loc; + } + with Not_found -> + clear_hash (); + raise Not_found + + (* Preserve sharing inside class types. *) let nondep_class_signature env id sign = { csig_self = nondep_type_rec env id sign.csig_self; diff --git a/typing/ctype.mli b/typing/ctype.mli index 2af24c368..37daf3a42 100644 --- a/typing/ctype.mli +++ b/typing/ctype.mli @@ -228,14 +228,19 @@ val nondep_type_decl: Env.t -> Ident.t -> Ident.t -> bool -> type_declaration -> type_declaration (* Same for type declarations. *) +val nondep_extension_constructor: + Env.t -> Ident.t -> extension_constructor -> + extension_constructor + (* Same for extension constructor *) val nondep_class_declaration: Env.t -> Ident.t -> class_declaration -> class_declaration (* Same for class declarations. *) val nondep_cltype_declaration: Env.t -> Ident.t -> class_type_declaration -> class_type_declaration (* Same for class type declarations. *) -val correct_abbrev: Env.t -> Path.t -> type_expr list -> type_expr -> unit +(*val correct_abbrev: Env.t -> Path.t -> type_expr list -> type_expr -> unit*) val cyclic_abbrev: Env.t -> Ident.t -> type_expr -> bool +val is_contractive: Env.t -> type_expr -> bool val normalize_type: Env.t -> type_expr -> unit val closed_schema: type_expr -> bool @@ -245,6 +250,7 @@ val closed_schema: type_expr -> bool val free_variables: ?env:Env.t -> type_expr -> type_expr list (* If env present, then check for incomplete definitions too *) val closed_type_decl: type_declaration -> type_expr option +val closed_extension_constructor: extension_constructor -> type_expr option type closed_class_failure = CC_Method of type_expr * bool * string * type_expr | CC_Value of type_expr * bool * string * type_expr diff --git a/typing/datarepr.ml b/typing/datarepr.ml index 5c1f987b4..1c121d35a 100644 --- a/typing/datarepr.ml +++ b/typing/datarepr.ml @@ -39,16 +39,54 @@ let free_vars ty = unmark_type ty; !ret -let constructor_descrs ty_res cstrs priv = +let newgenconstr path tyl = newgenty (Tconstr (path, tyl, ref Mnil)) + +let constructor_args cd_args cd_res path rep = + let tyl = + match cd_args with + | Cstr_tuple l -> l + | Cstr_record l -> List.map (fun l -> l.ld_type) l + in + let arg_vars_set = free_vars (newgenty (Ttuple tyl)) in + let existentials = + match cd_res with + | None -> [] + | Some type_ret -> + let res_vars = free_vars type_ret in + TypeSet.elements (TypeSet.diff arg_vars_set res_vars) + in + match cd_args with + | Cstr_tuple l -> existentials, l, None + | Cstr_record lbls -> + let type_params = TypeSet.elements arg_vars_set in + let tdecl = + { + type_params; + type_arity = List.length type_params; + type_kind = Type_record (lbls, rep); + type_private = Public; + type_manifest = None; + type_variance = List.map (fun _ -> Variance.full) type_params; + type_newtype_level = None; + type_loc = Location.none; + type_attributes = []; + } + in + existentials, + [ newgenconstr path type_params ], + Some tdecl + +let constructor_descrs ty_path decl cstrs = + let ty_res = newgenconstr ty_path decl.type_params in let num_consts = ref 0 and num_nonconsts = ref 0 and num_normal = ref 0 in List.iter (fun {cd_args; cd_res; _} -> - if cd_args = [] then incr num_consts else incr num_nonconsts; + if cd_args = Cstr_tuple [] then incr num_consts else incr num_nonconsts; if cd_res = None then incr num_normal) cstrs; let rec describe_constructors idx_const idx_nonconst = function [] -> [] - | {cd_id; cd_args; cd_res; cd_loc; cd_attributes; cd_inlined} :: rem -> + | {cd_id; cd_args; cd_res; cd_loc; cd_attributes} :: rem -> let ty_res = match cd_res with | Some ty_res' -> ty_res' @@ -56,53 +94,61 @@ let constructor_descrs ty_res cstrs priv = in let (tag, descr_rem) = match cd_args with - [] -> (Cstr_constant idx_const, + Cstr_tuple [] -> (Cstr_constant idx_const, describe_constructors (idx_const+1) idx_nonconst rem) | _ -> (Cstr_block idx_nonconst, describe_constructors idx_const (idx_nonconst+1) rem) in - let existentials = - match cd_res with - | None -> [] - | Some type_ret -> - let res_vars = free_vars type_ret in - let arg_vars = free_vars (newgenty (Ttuple cd_args)) in - TypeSet.elements (TypeSet.diff arg_vars res_vars) + + let cstr_name = Ident.name cd_id in + let existentials, cstr_args, cstr_inlined = + constructor_args cd_args cd_res + (Path.Pdot (ty_path, cstr_name, Path.nopos)) + (Record_inlined idx_nonconst) in let cstr = - { cstr_name = Ident.name cd_id; + { cstr_name; cstr_res = ty_res; cstr_existentials = existentials; - cstr_args = cd_args; - cstr_arity = List.length cd_args; + cstr_args; + cstr_arity = List.length cstr_args; cstr_tag = tag; cstr_consts = !num_consts; cstr_nonconsts = !num_nonconsts; cstr_normal = !num_normal; - cstr_private = priv; + cstr_private = decl.type_private; cstr_generalized = cd_res <> None; cstr_loc = cd_loc; cstr_attributes = cd_attributes; - cstr_inlined = cd_inlined; + cstr_inlined; } in (cd_id, cstr) :: descr_rem in describe_constructors 0 0 cstrs -let exception_descr path_exc decl = - { cstr_name = Path.last path_exc; - cstr_res = Predef.type_exn; - cstr_existentials = []; - cstr_args = decl.exn_args; - cstr_arity = List.length decl.exn_args; - cstr_tag = Cstr_exception (path_exc, decl.exn_loc); - cstr_consts = -1; - cstr_nonconsts = -1; - cstr_private = Public; - cstr_normal = -1; - cstr_generalized = false; - cstr_loc = decl.exn_loc; - cstr_attributes = decl.exn_attributes; - cstr_inlined = decl.exn_inlined; - } +let extension_descr path_ext ext = + let ty_res = + match ext.ext_ret_type with + Some type_ret -> type_ret + | None -> newgenconstr ext.ext_type_path ext.ext_type_params + in + let existentials, cstr_args, cstr_inlined = + constructor_args ext.ext_args ext.ext_ret_type + path_ext Record_extension + in + { cstr_name = Path.last path_ext; + cstr_res = ty_res; + cstr_existentials = existentials; + cstr_args; + cstr_arity = List.length cstr_args; + cstr_tag = Cstr_extension(path_ext, cstr_args = []); + cstr_consts = -1; + cstr_nonconsts = -1; + cstr_private = ext.ext_private; + cstr_normal = -1; + cstr_generalized = ext.ext_ret_type <> None; + cstr_loc = ext.ext_loc; + cstr_attributes = ext.ext_attributes; + cstr_inlined; + } let none = {desc = Ttuple []; level = -1; id = -1} (* Clearly ill-formed type *) @@ -115,7 +161,7 @@ let dummy_label = } let label_descrs ty_res lbls repres priv = - let all_labels = Array.create (List.length lbls) dummy_label in + let all_labels = Array.make (List.length lbls) dummy_label in let rec describe_labels num = function [] -> [] | l :: rest -> @@ -140,7 +186,7 @@ exception Constr_not_found let rec find_constr tag num_const num_nonconst = function [] -> raise Constr_not_found - | {cd_args = []; _} as c :: rem -> + | {cd_args = Cstr_tuple []; _} as c :: rem -> if tag = Cstr_constant num_const then c else find_constr tag (num_const + 1) num_nonconst rem @@ -151,3 +197,15 @@ let rec find_constr tag num_const num_nonconst = function let find_constr_by_tag tag cstrlist = find_constr tag 0 0 cstrlist + +let constructors_of_type ty_path decl = + match decl.type_kind with + | Type_variant cstrs -> constructor_descrs ty_path decl cstrs + | Type_record _ | Type_abstract | Type_open -> [] + +let labels_of_type ty_path decl = + match decl.type_kind with + | Type_record(labels, rep) -> + label_descrs (newgenconstr ty_path decl.type_params) + labels rep decl.type_private + | Type_variant _ | Type_abstract | Type_open -> [] diff --git a/typing/datarepr.mli b/typing/datarepr.mli index 13ced4609..d56446a24 100644 --- a/typing/datarepr.mli +++ b/typing/datarepr.mli @@ -13,18 +13,18 @@ (* Compute constructor and label descriptions from type declarations, determining their representation. *) -open Asttypes open Types -val constructor_descrs: - type_expr -> constructor_declaration list -> - private_flag -> (Ident.t * constructor_description) list -val exception_descr: - Path.t -> exception_declaration -> constructor_description -val label_descrs: - type_expr -> label_declaration list -> - record_representation -> private_flag -> - (Ident.t * label_description) list +val extension_descr: + Path.t -> extension_constructor -> constructor_description + +val labels_of_type: + Path.t -> type_declaration -> + (Ident.t * label_description) list +val constructors_of_type: + Path.t -> type_declaration -> + (Ident.t * constructor_description) list + exception Constr_not_found diff --git a/typing/env.ml b/typing/env.ml index 92b0c0f0d..4e6bba0c5 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -106,7 +106,7 @@ type summary = Env_empty | Env_value of summary * Ident.t * value_description | Env_type of summary * Ident.t * type_declaration - | Env_exception of summary * Ident.t * exception_declaration + | Env_extension of summary * Ident.t * extension_constructor | Env_module of summary * Ident.t * module_declaration | Env_modtype of summary * Ident.t * modtype_declaration | Env_class of summary * Ident.t * class_declaration @@ -164,6 +164,9 @@ module EnvTbl = type type_descriptions = constructor_description list * label_description list +let in_signature_flag = 0x01 +let implicit_coercion_flag = 0x02 + type t = { values: (Path.t * value_description) EnvTbl.t; constrs: constructor_description EnvTbl.t; @@ -178,7 +181,7 @@ type t = { summary: summary; local_constraints: bool; gadt_instances: (int * TypeSet.t ref) list; - in_signature: bool; + flags: int; } and module_components = @@ -221,11 +224,17 @@ let empty = { components = EnvTbl.empty; classes = EnvTbl.empty; cltypes = EnvTbl.empty; summary = Env_empty; local_constraints = false; gadt_instances = []; - in_signature = false; + flags = 0; functor_args = Ident.empty; } -let in_signature env = {env with in_signature = true} +let in_signature env = + {env with flags = env.flags lor in_signature_flag} +let implicit_coercion env = + {env with flags = env.flags lor implicit_coercion_flag} + +let is_in_signature env = env.flags land in_signature_flag <> 0 +let is_implicit_coercion env = env.flags land implicit_coercion_flag <> 0 let diff_keys is_local tbl1 tbl2 = let keys2 = EnvTbl.keys tbl2 in @@ -242,13 +251,13 @@ let is_ident = function let is_local (p, _) = is_ident p -let is_local_exn = function - | {cstr_tag = Cstr_exception (p, _)} -> is_ident p +let is_local_ext = function + | {cstr_tag = Cstr_extension(p, _)} -> is_ident p | _ -> false let diff env1 env2 = diff_keys is_local env1.values env2.values @ - diff_keys is_local_exn env1.constrs env2.constrs @ + diff_keys is_local_ext env1.constrs env2.constrs @ diff_keys is_local env1.modules env2.modules @ diff_keys is_local env1.classes env2.classes @@ -284,12 +293,12 @@ let current_unit = ref "" type pers_struct = { ps_name: string; - ps_sig: signature; + ps_sig: signature Lazy.t; ps_comps: module_components; - ps_crcs: (string * Digest.t) list; + ps_crcs: (string * Digest.t option) list; + mutable ps_crcs_checked: bool; ps_filename: string; - ps_flags: pers_flags list; - mutable ps_crcs_checked: bool } + ps_flags: pers_flags list } let persistent_structures = (Hashtbl.create 17 : (string, pers_struct option) Hashtbl.t) @@ -298,13 +307,30 @@ let persistent_structures = let crc_units = Consistbl.create() +module StringSet = + Set.Make(struct type t = string let compare = String.compare end) + +let imported_units = ref StringSet.empty + +let add_import s = + imported_units := StringSet.add s !imported_units + +let clear_imports () = + Consistbl.clear crc_units; + imported_units := StringSet.empty + let check_consistency ps = - if ps.ps_crcs_checked then () else + if not ps.ps_crcs_checked then try List.iter - (fun (name, crc) -> Consistbl.check crc_units name crc ps.ps_filename) + (fun (name, crco) -> + match crco with + None -> () + | Some crc -> + add_import name; + Consistbl.check crc_units name crc ps.ps_filename) ps.ps_crcs; - ps.ps_crcs_checked <- true + ps.ps_crcs_checked <- true; with Consistbl.Inconsistency(name, source, auth) -> error (Inconsistent_import(name, auth, source)) @@ -322,15 +348,16 @@ let read_pers_struct modname filename = (Mty_signature sign) in let ps = { ps_name = name; - ps_sig = sign; + ps_sig = lazy (Subst.signature Subst.identity sign); ps_comps = comps; ps_crcs = crcs; - ps_crcs_checked = false; ps_filename = filename; - ps_flags = flags } in + ps_flags = flags; + ps_crcs_checked = false; + } in if ps.ps_name <> modname then error (Illegal_renaming(modname, ps.ps_name, filename)); - if not !Clflags.transparent_modules then check_consistency ps; + add_import name; List.iter (function Rectypes -> if not !Clflags.recursive_types then @@ -350,13 +377,13 @@ let find_pers_struct ?(check=true) name = | Some None -> raise Not_found | Some (Some sg) -> sg | None -> - let filename = - try find_in_path_uncap !load_path (name ^ ".cmi") - with Not_found -> - Hashtbl.add persistent_structures name None; - raise Not_found - in - read_pers_struct name filename + let filename = + try find_in_path_uncap !load_path (name ^ ".cmi") + with Not_found -> + Hashtbl.add persistent_structures name None; + raise Not_found + in + read_pers_struct name filename in if check then check_consistency ps; ps @@ -364,7 +391,7 @@ let find_pers_struct ?(check=true) name = let reset_cache () = current_unit := ""; Hashtbl.clear persistent_structures; - Consistbl.clear crc_units; + clear_imports (); Hashtbl.clear value_declarations; Hashtbl.clear type_declarations; Hashtbl.clear used_constructors; @@ -448,6 +475,51 @@ and find_class = and find_cltype = find (fun env -> env.cltypes) (fun sc -> sc.comp_cltypes) +let type_of_cstr path = function + | {cstr_inlined = Some d; _} -> + (d, ([], List.map snd (Datarepr.labels_of_type path d))) + | _ -> + assert false + +let find_type_full path env = + match Path.constructor_typath path with + | Regular p -> find_type_full p env + | Cstr (ty_path, s) -> + let (_, (cstrs, _)) = + try find_type_full ty_path env + with Not_found -> assert false + in + let cstr = + try List.find (fun cstr -> cstr.cstr_name = s) cstrs + with Not_found -> assert false + in + type_of_cstr path cstr + | LocalExt id -> + let cstr = + try EnvTbl.find_same id env.constrs + with Not_found -> assert false + in + type_of_cstr path cstr + | Ext (mod_path, s) -> + let comps = + try find_module_descr mod_path env + with Not_found -> assert false + in + let comps = + match EnvLazy.force !components_of_module_maker' comps with + | Structure_comps c -> c + | Functor_comps _ -> assert false + in + let exts = + List.filter + (function ({cstr_tag=Cstr_extension _}, _) -> true | _ -> false) + (try Tbl.find s comps.comp_constrs + with Not_found -> assert false) + in + match exts with + | [(cstr, _)] -> type_of_cstr path cstr + | _ -> assert false + let find_type p env = fst (find_type_full p env) let find_type_descrs p env = @@ -462,7 +534,7 @@ let find_module ~alias path env = with Not_found -> if Ident.persistent id then let ps = find_pers_struct (Ident.name id) in - md (Mty_signature(ps.ps_sig)) + md (Mty_signature(Lazy.force ps.ps_sig)) else raise Not_found end | Pdot(p, s, pos) -> @@ -615,7 +687,7 @@ let rec lookup_module_descr lid env = end | Lapply(l1, l2) -> let (p1, desc1) = lookup_module_descr l1 env in - let p2 = lookup_module l2 env in + let p2 = lookup_module true l2 env in let {md_type=mty2} = find_module p2 env in begin match EnvLazy.force !components_of_module_maker' desc1 with Functor_comps f -> @@ -625,7 +697,7 @@ let rec lookup_module_descr lid env = raise Not_found end -and lookup_module lid env : Path.t = +and lookup_module ~load lid env : Path.t = match lid with Lident s -> begin try @@ -639,7 +711,11 @@ and lookup_module lid env : Path.t = p with Not_found -> if s = !current_unit then raise Not_found; - ignore (find_pers_struct ~check:false s); + if !Clflags.transparent_modules && not load then + try ignore (find_pers_struct ~check:false s) + with Not_found -> + Location.prerr_warning Location.none (Warnings.No_cmi_file s) + else ignore (find_pers_struct s); Pident(Ident.create_persistent s) end | Ldot(l, s) -> @@ -653,7 +729,7 @@ and lookup_module lid env : Path.t = end | Lapply(l1, l2) -> let (p1, desc1) = lookup_module_descr l1 env in - let p2 = lookup_module l2 env in + let p2 = lookup_module true l2 env in let {md_type=mty2} = find_module p2 env in let p = Papply(p1, p2) in begin match EnvLazy.force !components_of_module_maker' desc1 with @@ -728,7 +804,7 @@ let has_local_constraints env = env.local_constraints let cstr_shadow cstr1 cstr2 = match cstr1.cstr_tag, cstr2.cstr_tag with - Cstr_exception _, Cstr_exception _ -> true + | Cstr_extension _, Cstr_extension _ -> true | _ -> false let lbl_shadow lbl1 lbl2 = false @@ -750,21 +826,26 @@ and lookup_class = and lookup_cltype = lookup (fun env -> env.cltypes) (fun sc -> sc.comp_cltypes) -let mark_value_used name vd = - try Hashtbl.find value_declarations (name, vd.val_loc) () - with Not_found -> () +let mark_value_used env name vd = + if not (is_implicit_coercion env) then + try Hashtbl.find value_declarations (name, vd.val_loc) () + with Not_found -> () -let mark_type_used name vd = - try Hashtbl.find type_declarations (name, vd.type_loc) () - with Not_found -> () +let mark_type_used env name vd = + if not (is_implicit_coercion env) then + try Hashtbl.find type_declarations (name, vd.type_loc) () + with Not_found -> () -let mark_constructor_used usage name vd constr = - try Hashtbl.find used_constructors (name, vd.type_loc, constr) usage - with Not_found -> () +let mark_constructor_used usage env name vd constr = + if not (is_implicit_coercion env) then + try Hashtbl.find used_constructors (name, vd.type_loc, constr) usage + with Not_found -> () -let mark_exception_used usage ed constr = - try Hashtbl.find used_constructors ("exn", ed.exn_loc, constr) usage - with Not_found -> () +let mark_extension_used usage env ext name = + if not (is_implicit_coercion env) then + let ty_name = Path.last ext.ext_type_path in + try Hashtbl.find used_constructors (ty_name, ext.ext_loc, name) usage + with Not_found -> () let set_value_used_callback name vd callback = let key = (name, vd.val_loc) in @@ -790,12 +871,12 @@ let set_type_used_callback name td callback = let lookup_value lid env = let (_, desc) as r = lookup_value lid env in - mark_value_used (Longident.last lid) desc; + mark_value_used env (Longident.last lid) desc; r let lookup_type lid env = let (path, (decl, _)) = lookup_type lid env in - mark_type_used (Longident.last lid) decl; + mark_type_used env (Longident.last lid) decl; (path, decl) (* [path] must be the path to a type, not to a module ! *) @@ -808,7 +889,7 @@ let path_subst_last path id = let mark_type_path env path = try let decl = find_type path env in - mark_type_used (Path.last path) decl + mark_type_used env (Path.last path) decl with Not_found -> () let ty_path t = @@ -840,17 +921,20 @@ let lookup_all_constructors lid env = Not_found when is_lident lid -> [] let mark_constructor usage env name desc = - match desc.cstr_tag with - | Cstr_exception (_, loc) -> + if not (is_implicit_coercion env) + then match desc.cstr_tag with + | Cstr_extension _ -> begin - try Hashtbl.find used_constructors ("exn", loc, name) usage + let ty_path = ty_path desc.cstr_res in + let ty_name = Path.last ty_path in + try Hashtbl.find used_constructors (ty_name, desc.cstr_loc, name) usage with Not_found -> () end | _ -> let ty_path = ty_path desc.cstr_res in let ty_decl = try find_type ty_path env with Not_found -> assert false in let ty_name = Path.last ty_path in - mark_constructor_used usage ty_name ty_decl name + mark_constructor_used usage env ty_name ty_decl name let lookup_label lid env = match lookup_all_labels lid env with @@ -1020,51 +1104,16 @@ let rec scrape_alias env ?path mty = begin try scrape_alias env (find_module path env).md_type ~path with Not_found -> - Location.prerr_warning Location.none - (Warnings.Deprecated - ("module " ^ Path.name path ^ " cannot be accessed")); + (*Location.prerr_warning Location.none + (Warnings.No_cmi_file (Path.name path));*) mty - end + end | mty, Some path -> !strengthen env mty path | _ -> mty let scrape_alias env mty = scrape_alias env mty -(* Compute constructor descriptions *) - -let constructors_of_type ty_path decl = - let handle_variants cstrs = - Datarepr.constructor_descrs - (newgenty (Tconstr(ty_path, decl.type_params, ref Mnil))) - cstrs decl.type_private - in - match decl.type_kind with - | Type_variant cstrs -> handle_variants cstrs - | Type_record _ | Type_abstract -> [] - -(* Compute label descriptions *) - -let labels_of_type ty_path decl = - match decl.type_kind with - Type_record(labels, rep) -> - let rep = - match rep with - | Record_exception (Pident id) -> - begin match ty_path with - | Path.Pdot (path, _, pos) -> - Record_exception (Path.Pdot (path, Ident.name id, pos)) - | Path.Pident _ -> - rep - | Path.Papply _ -> assert false - end - | rep -> rep - in - Datarepr.label_descrs - (newgenty (Tconstr(ty_path, decl.type_params, ref Mnil))) - labels rep decl.type_private - | Type_variant _ | Type_abstract -> [] - (* Given a signature and a root path, prefix all idents in the signature by the root path and build the corresponding substitution. *) @@ -1076,17 +1125,15 @@ let rec prefix_idents root pos sub = function let (pl, final_sub) = prefix_idents root nextpos sub rem in (p::pl, final_sub) | Sig_type(id, decl, _) :: rem -> - let p = Pdot(root, Ident.name id, pos) in - (* the position is used for the type declaration corresponding - to a constructor declaration with a record argument - (the exception comes immediately after the synthesized type - declaration). *) + let p = Pdot(root, Ident.name id, nopos) in let (pl, final_sub) = prefix_idents root pos (Subst.add_type id p sub) rem in (p::pl, final_sub) - | Sig_exception(id, decl) :: rem -> + | Sig_typext(id, ext, _) :: rem -> let p = Pdot(root, Ident.name id, pos) in - let (pl, final_sub) = prefix_idents root (pos+1) sub rem in + (* we extend the substitution in case of an inlined record *) + let (pl, final_sub) = + prefix_idents root (pos+1) (Subst.add_type id p sub) rem in (p::pl, final_sub) | Sig_module(id, mty, _) :: rem -> let p = Pdot(root, Ident.name id, pos) in @@ -1116,8 +1163,8 @@ let subst_signature sub sg = Sig_value (id, Subst.value_description sub decl) | Sig_type(id, decl, x) -> Sig_type(id, Subst.type_declaration sub decl, x) - | Sig_exception(id, decl) -> - Sig_exception (id, Subst.exception_declaration sub decl) + | Sig_typext(id, ext, es) -> + Sig_typext (id, Subst.extension_constructor sub ext, es) | Sig_module(id, mty, x) -> Sig_module(id, Subst.module_declaration sub mty,x) | Sig_modtype(id, decl) -> @@ -1187,8 +1234,10 @@ and components_of_module_maker (env, sub, path, mty) = end | Sig_type(id, decl, _) -> let decl' = Subst.type_declaration sub decl in - let constructors = List.map snd (constructors_of_type path decl') in - let labels = List.map snd (labels_of_type path decl') in + let constructors = + List.map snd (Datarepr.constructors_of_type path decl') in + let labels = + List.map snd (Datarepr.labels_of_type path decl') in c.comp_types <- Tbl.add (Ident.name id) ((decl', (constructors, labels)), nopos) @@ -1203,13 +1252,12 @@ and components_of_module_maker (env, sub, path, mty) = c.comp_labels <- add_to_tbl descr.lbl_name (descr, nopos) c.comp_labels) labels; - env := store_type_infos None id path decl !env !env - | Sig_exception(id, decl) -> - let decl' = Subst.exception_declaration sub decl in - let cstr = Datarepr.exception_descr path decl' in - let s = Ident.name id in + env := store_type_infos None id (Pident id) decl !env !env + | Sig_typext(id, ext, _) -> + let ext' = Subst.extension_constructor sub ext in + let descr = Datarepr.extension_descr path ext' in c.comp_constrs <- - add_to_tbl s (cstr, !pos) c.comp_constrs; + add_to_tbl (Ident.name id) (descr, !pos) c.comp_constrs; incr pos | Sig_module(id, md, _) -> let mty = md.md_type in @@ -1219,13 +1267,13 @@ and components_of_module_maker (env, sub, path, mty) = let comps = components_of_module !env sub path mty in c.comp_components <- Tbl.add (Ident.name id) (comps, !pos) c.comp_components; - env := store_module None id path md !env !env; + env := store_module None id (Pident id) md !env !env; incr pos | Sig_modtype(id, decl) -> let decl' = Subst.modtype_declaration sub decl in c.comp_modtypes <- Tbl.add (Ident.name id) (decl', nopos) c.comp_modtypes; - env := store_modtype None id path decl !env !env + env := store_modtype None id (Pident id) decl !env !env | Sig_class(id, decl, _) -> let decl' = Subst.class_declaration sub decl in c.comp_classes <- @@ -1286,8 +1334,8 @@ and store_type ~check slot id path info env renv = if check then check_usage loc id (fun s -> Warnings.Unused_type_declaration s) type_declarations; - let constructors = constructors_of_type path info in - let labels = labels_of_type path info in + let constructors = Datarepr.constructors_of_type path info in + let labels = Datarepr.labels_of_type path info in let descrs = (List.map snd constructors, List.map snd labels) in if check && not loc.Location.loc_ghost && @@ -1303,7 +1351,7 @@ and store_type ~check slot id path info env renv = if not (ty = "" || ty.[0] = '_') then !add_delayed_check_forward (fun () -> - if not env.in_signature && not used.cu_positive then + if not (is_in_signature env) && not used.cu_positive then Location.prerr_warning loc (Warnings.Unused_constructor (c, used.cu_pattern, used.cu_privatize))) @@ -1338,32 +1386,32 @@ and store_type_infos slot id path info env renv = renv.types; summary = Env_type(env.summary, id, info) } -and store_exception ~check slot id path decl env renv = - let loc = decl.exn_loc in +and store_extension ~check slot id path ext env renv = + let loc = ext.ext_loc in if check && not loc.Location.loc_ghost && - Warnings.is_active (Warnings.Unused_exception ("", false)) + Warnings.is_active (Warnings.Unused_extension ("", false, false)) then begin - let ty = "exn" in - let c = Ident.name id in - let k = (ty, loc, c) in + let ty = Path.last ext.ext_type_path in + let n = Ident.name id in + let k = (ty, loc, n) in if not (Hashtbl.mem used_constructors k) then begin let used = constructor_usages () in Hashtbl.add used_constructors k (add_constructor_usage used); !add_delayed_check_forward (fun () -> - if not env.in_signature && not used.cu_positive then + if not (is_in_signature env) && not used.cu_positive then Location.prerr_warning loc - (Warnings.Unused_exception - (c, used.cu_pattern) + (Warnings.Unused_extension + (n, used.cu_pattern, used.cu_privatize) ) ) end; end; { env with constrs = EnvTbl.add "constructor" slot id - (Datarepr.exception_descr path decl) env.constrs - renv.constrs; - summary = Env_exception(env.summary, id, decl) } + (Datarepr.extension_descr path ext) + env.constrs renv.constrs; + summary = Env_extension(env.summary, id, ext) } and store_module slot id path md env renv = { env with @@ -1414,8 +1462,7 @@ let _ = (* Insertion of bindings by identifier *) -let add_functor_arg ?(arg=false) id env = - if not arg then env else +let add_functor_arg id env = {env with functor_args = Ident.add id () env.functor_args; summary = Env_functor_arg (env.summary, id)} @@ -1426,17 +1473,17 @@ let add_value ?check id desc env = let add_type ~check id info env = store_type ~check None id (Pident id) info env env -and add_exception ~check id decl env = - store_exception ~check None id (Pident id) decl env env +and add_extension ~check id ext env = + store_extension ~check None id (Pident id) ext env env -and add_module_declaration ?arg id md env = +and add_module_declaration ?(arg=false) id md env = let path = (*match md.md_type with Mty_alias path -> normalize_path env path | _ ->*) Pident id in let env = store_module None id path md env env in - add_functor_arg ?arg id env + if arg then add_functor_arg id env else env and add_modtype id info env = store_modtype None id (Pident id) info env env @@ -1467,7 +1514,7 @@ let enter store_fun name data env = let enter_value ?check = enter (store_value ?check) and enter_type = enter (store_type ~check:true) -and enter_exception = enter (store_exception ~check:true) +and enter_extension = enter (store_extension ~check:true) and enter_module_declaration ?arg name md env = let id = Ident.create name in (id, add_module_declaration ?arg id md env) @@ -1486,8 +1533,8 @@ let add_item comp env = match comp with Sig_value(id, decl) -> add_value id decl env | Sig_type(id, decl, _) -> add_type ~check:false id decl env - | Sig_exception(id, decl) -> add_exception ~check:false id decl env - | Sig_module(id, md, _) -> add_module_declaration id md env + | Sig_typext(id, ext, _) -> add_extension ~check:false id ext env + | Sig_module(id, md, _) -> add_module_declaration id md env | Sig_modtype(id, decl) -> add_modtype id decl env | Sig_class(id, decl, _) -> add_class id decl env | Sig_class_type(id, decl, _) -> add_cltype id decl env @@ -1514,8 +1561,8 @@ let open_signature slot root sg env0 = store_value slot (Ident.hide id) p decl env env0 | Sig_type(id, decl, _) -> store_type ~check:false slot (Ident.hide id) p decl env env0 - | Sig_exception(id, decl) -> - store_exception ~check:false slot (Ident.hide id) p decl env env0 + | Sig_typext(id, ext, _) -> + store_extension ~check:false slot (Ident.hide id) p ext env env0 | Sig_module(id, mty, _) -> store_module slot (Ident.hide id) p mty env env0 | Sig_modtype(id, decl) -> @@ -1532,7 +1579,8 @@ let open_signature slot root sg env0 = let open_pers_signature name env = let ps = find_pers_struct name in - open_signature None (Pident(Ident.create_persistent name)) ps.ps_sig env + open_signature None (Pident(Ident.create_persistent name)) + (Lazy.force ps.ps_sig) env let open_signature ?(loc = Location.none) ?(toplevel = false) ovf root sg env = if not toplevel && ovf = Asttypes.Fresh && not loc.Location.loc_ghost @@ -1569,21 +1617,26 @@ let open_signature ?(loc = Location.none) ?(toplevel = false) ovf root sg env = let read_signature modname filename = let ps = read_pers_struct modname filename in check_consistency ps; - ps.ps_sig + Lazy.force ps.ps_sig (* Return the CRC of the interface of the given compilation unit *) let crc_of_unit name = - let ps = find_pers_struct ~check:false name in - try - List.assoc name ps.ps_crcs - with Not_found -> - assert false + let ps = find_pers_struct name in + let crco = + try + List.assoc name ps.ps_crcs + with Not_found -> + assert false + in + match crco with + None -> assert false + | Some crc -> crc (* Return the list of imported interfaces with their CRCs *) -let imported_units() = - Consistbl.extract crc_units +let imports() = + Consistbl.extract (StringSet.elements !imported_units) crc_units (* Save a signature to a file *) @@ -1610,14 +1663,16 @@ let save_signature_with_imports sg modname filename imports = (Pident(Ident.create_persistent modname)) (Mty_signature sg) in let ps = { ps_name = modname; - ps_sig = sg; + ps_sig = lazy (Subst.signature Subst.identity sg); ps_comps = comps; - ps_crcs = (cmi.cmi_name, crc) :: imports; + ps_crcs = (cmi.cmi_name, Some crc) :: imports; ps_filename = filename; ps_flags = cmi.cmi_flags; - ps_crcs_checked = true } in + ps_crcs_checked = false; + } in Hashtbl.add persistent_structures modname (Some ps); Consistbl.set crc_units modname crc filename; + add_import modname; sg with exn -> close_out oc; @@ -1625,7 +1680,7 @@ let save_signature_with_imports sg modname filename imports = raise exn let save_signature sg modname filename = - save_signature_with_imports sg modname filename (imported_units()) + save_signature_with_imports sg modname filename (imports()) (* Folding on environments *) @@ -1682,7 +1737,7 @@ let fold_modules f lid env acc = None -> acc | Some ps -> f name (Pident(Ident.create_persistent name)) - (md (Mty_signature ps.ps_sig)) acc) + (md (Mty_signature (Lazy.force ps.ps_sig))) acc) persistent_structures acc | Some l -> @@ -1716,11 +1771,10 @@ and fold_cltypes f = (* Make the initial environment *) - -let initial = +let (initial_safe_string, initial_unsafe_string) = Predef.build_initial_env (add_type ~check:false) - (add_exception ~check:false) + (add_extension ~check:false) empty (* Return the environment summary *) @@ -1738,7 +1792,7 @@ let keep_only_summary env = empty with summary = env.summary; local_constraints = env.local_constraints; - in_signature = env.in_signature; + flags = env.flags; } in last_env := env; @@ -1751,7 +1805,7 @@ let env_of_only_summary env_from_summary env = let new_env = env_from_summary env.summary Subst.identity in { new_env with local_constraints = env.local_constraints; - in_signature = env.in_signature; + flags = env.flags; } (* Error report *) @@ -1759,9 +1813,10 @@ let env_of_only_summary env_from_summary env = open Format let report_error ppf = function - | Illegal_renaming(name, modname, filename) -> fprintf ppf - "Wrong file naming: %a@ contains the compiled interface for @ %s when %s was expected" - Location.print_filename filename name modname + | Illegal_renaming(modname, ps_name, filename) -> fprintf ppf + "Wrong file naming: %a@ contains the compiled interface for @ \ + %s when %s was expected" + Location.print_filename filename ps_name modname | Inconsistent_import(name, source1, source2) -> fprintf ppf "@[<hov>The files %a@ and %a@ \ make inconsistent assumptions@ over interface %s@]" @@ -1789,4 +1844,3 @@ let () = | Error err -> Some (Location.error_of_printer_file report_error err) | _ -> None ) - diff --git a/typing/env.mli b/typing/env.mli index 888869ebf..4ab08e83a 100644 --- a/typing/env.mli +++ b/typing/env.mli @@ -18,7 +18,7 @@ type summary = Env_empty | Env_value of summary * Ident.t * value_description | Env_type of summary * Ident.t * type_declaration - | Env_exception of summary * Ident.t * exception_declaration + | Env_extension of summary * Ident.t * extension_constructor | Env_module of summary * Ident.t * module_declaration | Env_modtype of summary * Ident.t * modtype_declaration | Env_class of summary * Ident.t * class_declaration @@ -29,7 +29,8 @@ type summary = type t val empty: t -val initial: t +val initial_safe_string: t +val initial_unsafe_string: t val diff: t -> t -> Ident.t list type type_descriptions = @@ -60,6 +61,7 @@ val find_type_expansion_opt: (* Find the manifest type information associated to a type for the sake of the compiler's type-based optimisations. *) val find_modtype_expansion: Path.t -> t -> module_type +val add_functor_arg: Ident.t -> t -> t val is_functor_arg: Path.t -> t -> bool val normalize_path: Location.t option -> t -> Path.t -> Path.t (* Normalize the path to a concrete value or module. @@ -86,7 +88,7 @@ val lookup_label: Longident.t -> t -> label_description val lookup_all_labels: Longident.t -> t -> (label_description * (unit -> unit)) list val lookup_type: Longident.t -> t -> Path.t * type_declaration -val lookup_module: Longident.t -> t -> Path.t +val lookup_module: load:bool -> Longident.t -> t -> Path.t val lookup_modtype: Longident.t -> t -> Path.t * modtype_declaration val lookup_class: Longident.t -> t -> Path.t * class_declaration val lookup_cltype: Longident.t -> t -> Path.t * class_type_declaration @@ -101,7 +103,7 @@ exception Recmodule val add_value: ?check:(string -> Warnings.t) -> Ident.t -> value_description -> t -> t val add_type: check:bool -> Ident.t -> type_declaration -> t -> t -val add_exception: check:bool -> Ident.t -> exception_declaration -> t -> t +val add_extension: check:bool -> Ident.t -> extension_constructor -> t -> t val add_module: ?arg:bool -> Ident.t -> module_type -> t -> t val add_module_declaration: ?arg:bool -> Ident.t -> module_declaration -> t -> t val add_modtype: Ident.t -> modtype_declaration -> t -> t @@ -128,7 +130,7 @@ val enter_value: ?check:(string -> Warnings.t) -> string -> value_description -> t -> Ident.t * t val enter_type: string -> type_declaration -> t -> Ident.t * t -val enter_exception: string -> exception_declaration -> t -> Ident.t * t +val enter_extension: string -> extension_constructor -> t -> Ident.t * t val enter_module: ?arg:bool -> string -> module_type -> t -> Ident.t * t val enter_module_declaration: ?arg:bool -> string -> module_declaration -> t -> Ident.t * t @@ -152,7 +154,7 @@ val read_signature: string -> string -> signature val save_signature: signature -> string -> string -> signature (* Arguments: signature, module name, file name. *) val save_signature_with_imports: - signature -> string -> string -> (string * Digest.t) list -> signature + signature -> string -> string -> (string * Digest.t option) list -> signature (* Arguments: signature, module name, file name, imported units with their CRCs. *) @@ -162,11 +164,12 @@ val crc_of_unit: string -> Digest.t (* Return the set of compilation units imported, with their CRC *) -val imported_units: unit -> (string * Digest.t) list +val imports: unit -> (string * Digest.t option) list (* Direct access to the table of imported compilation units with their CRC *) val crc_units: Consistbl.t +val add_import: string -> unit (* Summaries -- compact representation of an environment, to be exported in debugging information. *) @@ -195,18 +198,19 @@ open Format val report_error: formatter -> error -> unit -val mark_value_used: string -> value_description -> unit -val mark_type_used: string -> type_declaration -> unit +val mark_value_used: t -> string -> value_description -> unit +val mark_type_used: t -> string -> type_declaration -> unit type constructor_usage = Positive | Pattern | Privatize val mark_constructor_used: - constructor_usage -> string -> type_declaration -> string -> unit + constructor_usage -> t -> string -> type_declaration -> string -> unit val mark_constructor: constructor_usage -> t -> string -> constructor_description -> unit -val mark_exception_used: - constructor_usage -> exception_declaration -> string -> unit +val mark_extension_used: + constructor_usage -> t -> extension_constructor -> string -> unit val in_signature: t -> t +val implicit_coercion: t -> t val set_value_used_callback: string -> value_description -> (unit -> unit) -> unit diff --git a/typing/envaux.ml b/typing/envaux.ml index 04d6d256f..708da443d 100644 --- a/typing/envaux.ml +++ b/typing/envaux.ml @@ -28,7 +28,7 @@ let reset_cache () = Env.reset_cache() let extract_sig env mty = - match Mtype.scrape env mty with + match Env.scrape_alias env mty with Mty_signature sg -> sg | _ -> fatal_error "Envaux.extract_sig" @@ -47,9 +47,9 @@ let rec env_from_summary sum subst = Env.add_type ~check:false id (Subst.type_declaration subst desc) (env_from_summary s subst) - | Env_exception(s, id, desc) -> - Env.add_exception ~check:false id - (Subst.exception_declaration subst desc) + | Env_extension(s, id, desc) -> + Env.add_extension ~check:false id + (Subst.extension_constructor subst desc) (env_from_summary s subst) | Env_module(s, id, desc) -> Env.add_module_declaration id diff --git a/typing/ident.ml b/typing/ident.ml index 70438c83d..db4ea6991 100644 --- a/typing/ident.ml +++ b/typing/ident.ml @@ -209,3 +209,15 @@ let rec iter f = function Empty -> () | Node(l, k, r, _) -> iter f l; f k.ident k.data; iter f r + +(* Idents for sharing keys *) + +(* They should be 'totally fresh' -> neg numbers *) +let key_name = "" + +let make_key_generator () = + let c = ref 1 in + fun id -> + let stamp = !c in + decr c ; + { id with name = key_name; stamp = stamp; } diff --git a/typing/ident.mli b/typing/ident.mli index d1cfa4ccb..be226c2dd 100644 --- a/typing/ident.mli +++ b/typing/ident.mli @@ -58,3 +58,8 @@ val find_all: string -> 'a tbl -> 'a list val fold_name: (t -> 'a -> 'b -> 'b) -> 'a tbl -> 'b -> 'b val fold_all: (t -> 'a -> 'b -> 'b) -> 'a tbl -> 'b -> 'b val iter: (t -> 'a -> unit) -> 'a tbl -> unit + + +(* Idents for sharing keys *) + +val make_key_generator : unit -> (t -> t) diff --git a/typing/includecore.ml b/typing/includecore.ml index f783e49a1..a4da854cf 100644 --- a/typing/includecore.ml +++ b/typing/includecore.ml @@ -120,7 +120,7 @@ type type_mismatch = | Field_arity of Ident.t | Field_names of int * Ident.t * Ident.t | Field_missing of bool * Ident.t - | Record_representation of record_representation * record_representation + | Record_representation of bool let report_type_mismatch0 first second decl ppf err = let pr fmt = Format.fprintf ppf fmt in @@ -143,16 +143,10 @@ let report_type_mismatch0 first second decl ppf err = | Field_missing (b, s) -> pr "The field %s is only present in %s %s" (Ident.name s) (if b then second else first) decl - | Record_representation (r1, r2) -> - let repr = function - | Record_regular -> "regular" - | Record_inlined i -> Printf.sprintf"inlined(tag %i)" i - | Record_float -> "unboxed float" - | Record_exception p -> Printf.sprintf "exception %s" (Path.name p) - in - pr "Their internal representations differ:@ %s vs %s" - (repr r1) - (repr r2) + | Record_representation b -> + pr "Their internal representations differ:@ %s %s %s" + (if b then second else first) decl + "uses unboxed float representation" let report_type_mismatch first second decl ppf = List.iter @@ -160,7 +154,19 @@ let report_type_mismatch first second decl ppf = if err = Manifest then () else Format.fprintf ppf "@ %a." (report_type_mismatch0 first second decl) err) -let rec compare_variants env decl1 decl2 n cstrs1 cstrs2 = +let rec compare_constructor_arguments env cstr params1 params2 arg1 arg2 = + match arg1, arg2 with + | Types.Cstr_tuple arg1, Types.Cstr_tuple arg2 -> + if List.length arg1 <> List.length arg2 then [Field_arity cstr] + else if Misc.for_all2 + (fun ty1 ty2 -> Ctype.equal env true (ty1::params1) (ty2::params2)) + (arg1) (arg2) + then [] else [Field_type cstr] + | Types.Cstr_record l1, Types.Cstr_record l2 -> + compare_records env params1 params2 0 l1 l2 + | _ -> [Field_type cstr] + +and compare_variants env params1 params2 n cstrs1 cstrs2 = match cstrs1, cstrs2 with [], [] -> [] | [], c::_ -> [Field_missing (true, c.Types.cd_id)] @@ -169,25 +175,21 @@ let rec compare_variants env decl1 decl2 n cstrs1 cstrs2 = {Types.cd_id=cstr2; cd_args=arg2; cd_res=ret2}::rem2 -> if Ident.name cstr1 <> Ident.name cstr2 then [Field_names (n, cstr1, cstr2)] - else if List.length arg1 <> List.length arg2 then - [Field_arity cstr1] else match ret1, ret2 with | Some r1, Some r2 when not (Ctype.equal env true [r1] [r2]) -> [Field_type cstr1] | Some _, None | None, Some _ -> [Field_type cstr1] | _ -> - if Misc.for_all2 - (fun ty1 ty2 -> - Ctype.equal env true (ty1::decl1.type_params) - (ty2::decl2.type_params)) - (arg1) (arg2) - then - compare_variants env decl1 decl2 (n+1) rem1 rem2 - else [Field_type cstr1] + let r = + compare_constructor_arguments env cstr1 + params1 params2 arg1 arg2 + in + if r <> [] then r + else compare_variants env params1 params2 (n+1) rem1 rem2 -let rec compare_records env decl1 decl2 n labels1 labels2 = +and compare_records env params1 params2 n labels1 labels2 = match labels1, labels2 with [], [] -> [] | [], l::_ -> [Field_missing (true, l.ld_id)] @@ -197,20 +199,11 @@ let rec compare_records env decl1 decl2 n labels1 labels2 = if Ident.name lab1 <> Ident.name lab2 then [Field_names (n, lab1, lab2)] else if mut1 <> mut2 then [Field_mutable lab1] else - if Ctype.equal env true (arg1::decl1.type_params) - (arg2::decl2.type_params) - then compare_records env decl1 decl2 (n+1) rem1 rem2 + if Ctype.equal env true (arg1::params1) + (arg2::params2) + then compare_records env params1 params2 (n+1) rem1 rem2 else [Field_type lab1] -let record_representations r1 r2 = - match r1, r2 with - | Record_regular, Record_regular -> true - | Record_inlined i, Record_inlined j -> i = j - | Record_float, Record_float -> true - | Record_exception _, Record_exception _ -> true - (* allow a different path to support exception rebinding *) - | _ -> false - let type_declarations ?(equality = false) env name decl1 id decl2 = if decl1.type_arity <> decl2.type_arity then [Arity] else if not (private_flags decl1 decl2) then [Privacy] else @@ -220,7 +213,8 @@ let type_declarations ?(equality = false) env name decl1 id decl2 = let mark cstrs usage name decl = List.iter (fun c -> - Env.mark_constructor_used usage name decl (Ident.name c.Types.cd_id)) + Env.mark_constructor_used usage env name decl + (Ident.name c.Types.cd_id)) cstrs in let usage = @@ -229,11 +223,13 @@ let type_declarations ?(equality = false) env name decl1 id decl2 = in mark cstrs1 usage name decl1; if equality then mark cstrs2 Env.Positive (Ident.name id) decl2; - compare_variants env decl1 decl2 1 cstrs1 cstrs2 + compare_variants env decl1.type_params decl2.type_params 1 cstrs1 cstrs2 | (Type_record(labels1,rep1), Type_record(labels2,rep2)) -> - let err = compare_records env decl1 decl2 1 labels1 labels2 in - if err <> [] || record_representations rep1 rep2 then err else - [Record_representation (rep1, rep2)] + let err = compare_records env decl1.type_params decl2.type_params + 1 labels1 labels2 in + if err <> [] || rep1 = rep2 then err else + [Record_representation (rep2 = Record_float)] + | (Type_open, Type_open) -> [] | (_, _) -> [Kind] in if err <> [] then err else @@ -258,23 +254,53 @@ let type_declarations ?(equality = false) env name decl1 id decl2 = let abstr = decl2.type_private = Private || decl2.type_kind = Type_abstract && decl2.type_manifest = None in + let opn = decl2.type_kind = Type_open && decl2.type_manifest = None in + let constrained ty = not (Btype.(is_Tvar (repr ty))) in if List.for_all2 (fun ty (v1,v2) -> let open Variance in let imp a b = not a || b in let (co1,cn1) = get_upper v1 and (co2,cn2) = get_upper v2 in - imp abstr (imp co1 co2 && imp cn1 cn2) && - (abstr || Btype.(is_Tvar (repr ty)) || co1 = co2 && cn1 = cn2) && + (if abstr then (imp co1 co2 && imp cn1 cn2) + else if opn || constrained ty then (co1 = co2 && cn1 = cn2) + else true) && let (p1,n1,i1,j1) = get_lower v1 and (p2,n2,i2,j2) = get_lower v2 in imp abstr (imp p2 p1 && imp n2 n1 && imp i2 i1 && imp j2 j1)) decl2.type_params (List.combine decl1.type_variance decl2.type_variance) then [] else [Variance] -(* Inclusion between exception declarations *) +(* Inclusion between extension constructors *) -let exception_declarations env ed1 ed2 = - Misc.for_all2 (fun ty1 ty2 -> Ctype.equal env false [ty1] [ty2]) - ed1.exn_args ed2.exn_args +let extension_constructors env id ext1 ext2 = + let usage = + if ext1.ext_private = Private || ext2.ext_private = Public + then Env.Positive else Env.Privatize + in + Env.mark_extension_used usage env ext1 (Ident.name id); + let ty1 = + Btype.newgenty (Tconstr(ext1.ext_type_path, ext1.ext_type_params, ref Mnil)) + in + let ty2 = + Btype.newgenty (Tconstr(ext2.ext_type_path, ext2.ext_type_params, ref Mnil)) + in + if Ctype.equal env true + (ty1 :: ext1.ext_type_params) + (ty2 :: ext2.ext_type_params) + then + if compare_constructor_arguments env (Ident.create "") + ext1.ext_type_params ext2.ext_type_params + ext1.ext_args ext2.ext_args = [] then + if match ext1.ext_ret_type, ext2.ext_ret_type with + Some r1, Some r2 when not (Ctype.equal env true [r1] [r2]) -> false + | Some _, None | None, Some _ -> false + | _ -> true + then + match ext1.ext_private, ext2.ext_private with + Private, Public -> false + | _, _ -> true + else false + else false + else false (* Inclusion between class types *) let encode_val (mut, ty) rem = diff --git a/typing/includecore.mli b/typing/includecore.mli index 75e6c1957..0c8e9558f 100644 --- a/typing/includecore.mli +++ b/typing/includecore.mli @@ -29,7 +29,7 @@ type type_mismatch = | Field_arity of Ident.t | Field_names of int * Ident.t * Ident.t | Field_missing of bool * Ident.t - | Record_representation of record_representation * record_representation + | Record_representation of bool val value_descriptions: Env.t -> value_description -> value_description -> module_coercion @@ -37,8 +37,8 @@ val type_declarations: ?equality:bool -> Env.t -> string -> type_declaration -> Ident.t -> type_declaration -> type_mismatch list -val exception_declarations: - Env.t -> exception_declaration -> exception_declaration -> bool +val extension_constructors: + Env.t -> Ident.t -> extension_constructor -> extension_constructor -> bool (* val class_types: Env.t -> class_type -> class_type -> bool diff --git a/typing/includemod.ml b/typing/includemod.ml index 7316a26af..3eb26fbd6 100644 --- a/typing/includemod.ml +++ b/typing/includemod.ml @@ -22,8 +22,8 @@ type symptom = | Value_descriptions of Ident.t * value_description * value_description | Type_declarations of Ident.t * type_declaration * type_declaration * Includecore.type_mismatch list - | Exception_declarations of - Ident.t * exception_declaration * exception_declaration + | Extension_constructors of + Ident.t * extension_constructor * extension_constructor | Module_types of module_type * module_type | Modtype_infos of Ident.t * modtype_declaration * modtype_declaration | Modtype_permutation @@ -36,6 +36,7 @@ type symptom = Ctype.class_match_failure list | Unbound_modtype_path of Path.t | Unbound_module_path of Path.t + | Invalid_module_alias of Path.t type pos = Module of Ident.t | Modtype of Ident.t | Arg of Ident.t | Body of Ident.t @@ -51,7 +52,7 @@ exception Error of error list let value_descriptions env cxt subst id vd1 vd2 = Cmt_format.record_value_dependency vd1 vd2; - Env.mark_value_used (Ident.name id) vd1; + Env.mark_value_used env (Ident.name id) vd1; let vd2 = Subst.value_description subst vd2 in try Includecore.value_descriptions env vd1 vd2 @@ -61,20 +62,19 @@ let value_descriptions env cxt subst id vd1 vd2 = (* Inclusion between type declarations *) let type_declarations env cxt subst id decl1 decl2 = - Env.mark_type_used (Ident.name id) decl1; + Env.mark_type_used env (Ident.name id) decl1; let decl2 = Subst.type_declaration subst decl2 in let err = Includecore.type_declarations env (Ident.name id) decl1 id decl2 in if err <> [] then raise(Error[cxt, env, Type_declarations(id, decl1, decl2, err)]) -(* Inclusion between exception declarations *) +(* Inclusion between extension constructors *) -let exception_declarations env cxt subst id decl1 decl2 = - Env.mark_exception_used Env.Positive decl1 (Ident.name id); - let decl2 = Subst.exception_declaration subst decl2 in - if Includecore.exception_declarations env decl1 decl2 +let extension_constructors env cxt subst id ext1 ext2 = + let ext2 = Subst.extension_constructor subst ext2 in + if Includecore.extension_constructors env id ext1 ext2 then () - else raise(Error[cxt, env, Exception_declarations(id, decl1, decl2)]) + else raise(Error[cxt, env, Extension_constructors(id, ext1, ext2)]) (* Inclusion between class declarations *) @@ -123,7 +123,7 @@ let rec normalize_module_path env cxt path = type field_desc = Field_value of string | Field_type of string - | Field_exception of string + | Field_typext of string | Field_module of string | Field_modtype of string | Field_class of string @@ -132,7 +132,7 @@ type field_desc = let kind_of_field_desc = function | Field_value _ -> "value" | Field_type _ -> "type" - | Field_exception _ -> "exception" + | Field_typext _ -> "extension constructor" | Field_module _ -> "module" | Field_modtype _ -> "module type" | Field_class _ -> "class" @@ -141,7 +141,7 @@ let kind_of_field_desc = function let item_ident_name = function Sig_value(id, d) -> (id, d.val_loc, Field_value(Ident.name id)) | Sig_type(id, d, _) -> (id, d.type_loc, Field_type(Ident.name id)) - | Sig_exception(id, d) -> (id, d.exn_loc, Field_exception(Ident.name id)) + | Sig_typext(id, d, _) -> (id, d.ext_loc, Field_typext(Ident.name id)) | Sig_module(id, d, _) -> (id, d.md_loc, Field_module(Ident.name id)) | Sig_modtype(id, d) -> (id, d.mtd_loc, Field_modtype(Ident.name id)) | Sig_class(id, d, _) -> (id, d.cty_loc, Field_class(Ident.name id)) @@ -153,10 +153,43 @@ let is_runtime_component = function | Sig_modtype(_,_) | Sig_class_type(_,_,_) -> false | Sig_value(_,_) - | Sig_exception(_,_) + | Sig_typext(_,_,_) | Sig_module(_,_,_) | Sig_class(_, _,_) -> true +(* Print a coercion *) + +let rec print_list pr ppf = function + [] -> () + | [a] -> pr ppf a + | a :: l -> pr ppf a; Format.fprintf ppf ";@ "; print_list pr ppf l +let print_list pr ppf l = + Format.fprintf ppf "[@[%a@]]" (print_list pr) l + +let rec print_coercion ppf c = + let pr fmt = Format.fprintf ppf fmt in + match c with + Tcoerce_none -> pr "id" + | Tcoerce_structure (fl, nl) -> + pr "@[<2>struct@ %a@ %a@]" + (print_list print_coercion2) fl + (print_list print_coercion3) nl + | Tcoerce_functor (inp, out) -> + pr "@[<2>functor@ (%a)@ (%a)@]" + print_coercion inp + print_coercion out + | Tcoerce_primitive pd -> + pr "prim %s" pd.Primitive.prim_name + | Tcoerce_alias (p, c) -> + pr "@[<2>alias %a@ (%a)@]" + Printtyp.path p + print_coercion c +and print_coercion2 ppf (n, c) = + Format.fprintf ppf "@[%d,@ %a@]" n print_coercion c +and print_coercion3 ppf (i, n, c) = + Format.fprintf ppf "@[%s, %d,@ %a@]" + (Ident.unique_name i) n print_coercion c + (* Simplify a structure coercion *) let simplify_structure_coercion cc id_pos_list = @@ -189,7 +222,9 @@ let rec modtypes env cxt subst mty1 mty2 = and try_modtypes env cxt subst mty1 mty2 = match (mty1, mty2) with - (Mty_alias p1, Mty_alias p2) -> + | (Mty_alias p1, Mty_alias p2) -> + if Env.is_functor_arg p2 env then + raise (Error[cxt, env, Invalid_module_alias p2]); if Path.same p1 p2 then Tcoerce_none else let p1 = Env.normalize_path None env p1 and p2 = Env.normalize_path None env (Subst.module_path subst p2) in @@ -309,7 +344,8 @@ and signatures env cxt subst sig1 sig2 = Subst.add_module id2 (Pident id1) subst | Sig_modtype _ -> Subst.add_modtype id2 (Mty_ident (Pident id1)) subst - | Sig_value _ | Sig_exception _ | Sig_class _ | Sig_class_type _ -> + | Sig_value _ | Sig_typext _ + | Sig_class _ | Sig_class_type _ -> subst in pair_components new_subst @@ -338,14 +374,16 @@ and signature_components env cxt subst = function | (Sig_type(id1, tydecl1, _), Sig_type(id2, tydecl2, _), pos) :: rem -> type_declarations env cxt subst id1 tydecl1 tydecl2; signature_components env cxt subst rem - | (Sig_exception(id1, excdecl1), Sig_exception(id2, excdecl2), pos) + | (Sig_typext(id1, ext1, _), Sig_typext(id2, ext2, _), pos) :: rem -> - exception_declarations env cxt subst id1 excdecl1 excdecl2; + extension_constructors env cxt subst id1 ext1 ext2; (pos, Tcoerce_none) :: signature_components env cxt subst rem | (Sig_module(id1, mty1, _), Sig_module(id2, mty2, _), pos) :: rem -> + let p1 = Pident id1 in let cc = modtypes env (Module id1::cxt) subst - (Mtype.strengthen env mty1.md_type (Pident id1)) mty2.md_type in + (Mtype.strengthen (Env.add_functor_arg id1 env) mty1.md_type p1) + mty2.md_type in (pos, cc) :: signature_components env cxt subst rem | (Sig_modtype(id1, info1), Sig_modtype(id2, info2), pos) :: rem -> modtype_infos env cxt subst id1 info1 info2; @@ -382,7 +420,10 @@ and check_modtype_equiv env cxt mty1 mty2 = modtypes env cxt Subst.identity mty2 mty1) with (Tcoerce_none, Tcoerce_none) -> () - | (_, _) -> raise(Error [cxt, env, Modtype_permutation]) + | (c1, c2) -> + (* Format.eprintf "@[c1 = %a@ c2 = %a@]@." + print_coercion c1 print_coercion c2; *) + raise(Error [cxt, env, Modtype_permutation]) (* Simplified inclusion check between module types (for Env) *) @@ -398,9 +439,9 @@ let _ = Env.check_modtype_inclusion := check_modtype_inclusion (* Check that an implementation of a compilation unit meets its interface. *) -let compunit impl_name impl_sig intf_name intf_sig = +let compunit env impl_name impl_sig intf_name intf_sig = try - signatures Env.initial [] Subst.identity impl_sig intf_sig + signatures env [] Subst.identity impl_sig intf_sig with Error reasons -> raise(Error(([], Env.empty,Interface_mismatch(impl_name, intf_name)) :: reasons)) @@ -412,6 +453,15 @@ let signatures env sig1 sig2 = signatures env [] Subst.identity sig1 sig2 let type_declarations env id decl1 decl2 = type_declarations env [] Subst.identity id decl1 decl2 +(* +let modtypes env m1 m2 = + let c = modtypes env m1 m2 in + Format.eprintf "@[<2>modtypes@ %a@ %a =@ %a@]@." + Printtyp.modtype m1 Printtyp.modtype m2 + print_coercion c; + c +*) + (* Error report *) open Format @@ -444,13 +494,13 @@ let include_err ppf = function show_locs (d1.type_loc, d2.type_loc) (Includecore.report_type_mismatch "the first" "the second" "declaration") errs - | Exception_declarations(id, d1, d2) -> + | Extension_constructors(id, x1, x2) -> fprintf ppf - "@[<hv 2>Exception declarations do not match:@ \ + "@[<hv 2>Extension declarations do not match:@ \ %a@;<1 -2>is not included in@ %a@]" - (exception_declaration id) d1 - (exception_declaration id) d2; - show_locs ppf (d1.exn_loc, d2.exn_loc) + (extension_constructor id) x1 + (extension_constructor id) x2; + show_locs ppf (x1.ext_loc, x2.ext_loc) | Module_types(mty1, mty2)-> fprintf ppf "@[<hv 2>Modules do not match:@ \ @@ -486,6 +536,8 @@ let include_err ppf = function fprintf ppf "Unbound module type %a" Printtyp.path path | Unbound_module_path path -> fprintf ppf "Unbound module %a" Printtyp.path path + | Invalid_module_alias path -> + fprintf ppf "Module %a cannot be aliased" Printtyp.path path let rec context ppf = function Module id :: rem -> @@ -530,12 +582,12 @@ let include_err ppf (cxt, env, err) = Printtyp.wrap_printing_env env (fun () -> fprintf ppf "@[<v>%a%a@]" context (List.rev cxt) include_err err) -let buffer = ref "" +let buffer = ref Bytes.empty let is_big obj = let size = !Clflags.error_size in size > 0 && begin - if String.length !buffer < size then buffer := String.create size; + if Bytes.length !buffer < size then buffer := Bytes.create size; try ignore (Marshal.to_buffer !buffer 0 size obj []); false with _ -> true end @@ -560,4 +612,3 @@ let () = | Error err -> Some (Location.error_of_printer_file report_error err) | _ -> None ) - diff --git a/typing/includemod.mli b/typing/includemod.mli index 7786ee4ab..5bc3c336b 100644 --- a/typing/includemod.mli +++ b/typing/includemod.mli @@ -18,17 +18,19 @@ open Format val modtypes: Env.t -> module_type -> module_type -> module_coercion val signatures: Env.t -> signature -> signature -> module_coercion -val compunit: string -> signature -> string -> signature -> module_coercion +val compunit: + Env.t -> string -> signature -> string -> signature -> module_coercion val type_declarations: Env.t -> Ident.t -> type_declaration -> type_declaration -> unit +val print_coercion: formatter -> module_coercion -> unit type symptom = Missing_field of Ident.t * Location.t * string (* kind *) | Value_descriptions of Ident.t * value_description * value_description | Type_declarations of Ident.t * type_declaration * type_declaration * Includecore.type_mismatch list - | Exception_declarations of - Ident.t * exception_declaration * exception_declaration + | Extension_constructors of + Ident.t * extension_constructor * extension_constructor | Module_types of module_type * module_type | Modtype_infos of Ident.t * modtype_declaration * modtype_declaration | Modtype_permutation @@ -41,6 +43,7 @@ type symptom = Ctype.class_match_failure list | Unbound_modtype_path of Path.t | Unbound_module_path of Path.t + | Invalid_module_alias of Path.t type pos = Module of Ident.t | Modtype of Ident.t | Arg of Ident.t | Body of Ident.t diff --git a/typing/mtype.ml b/typing/mtype.ml index a5e0d811d..3c3b4b8c7 100644 --- a/typing/mtype.ml +++ b/typing/mtype.ml @@ -33,18 +33,18 @@ let freshen mty = let rec strengthen env mty p = match scrape env mty with Mty_signature sg -> - Mty_signature(strengthen_sig env sg p) + Mty_signature(strengthen_sig env sg p 0) | Mty_functor(param, arg, res) when !Clflags.applicative_functors && Ident.name param <> "*" -> Mty_functor(param, arg, strengthen env res (Papply(p, Pident param))) | mty -> mty -and strengthen_sig env sg p = +and strengthen_sig env sg p pos = match sg with [] -> [] | (Sig_value(id, desc) as sigelt) :: rem -> - sigelt :: strengthen_sig env rem p + sigelt :: strengthen_sig env rem p (pos+1) | Sig_type(id, decl, rs) :: rem -> let newdecl = match decl.type_manifest, decl.type_private, decl.type_kind with @@ -59,29 +59,34 @@ and strengthen_sig env sg p = else { decl with type_manifest = manif } in - Sig_type(id, newdecl, rs) :: strengthen_sig env rem p - | (Sig_exception(id, d) as sigelt) :: rem -> - sigelt :: strengthen_sig env rem p + Sig_type(id, newdecl, rs) :: strengthen_sig env rem p pos + | (Sig_typext(id, ext, es) as sigelt) :: rem -> + sigelt :: strengthen_sig env rem p (pos+1) | Sig_module(id, md, rs) :: rem -> - let str = strengthen_decl env md (Pdot(p, Ident.name id, nopos)) in + let str = + if Env.is_functor_arg p env then + strengthen_decl env md (Pdot(p, Ident.name id, pos)) + else + {md with md_type = Mty_alias (Pdot(p, Ident.name id, pos))} + in Sig_module(id, str, rs) - :: strengthen_sig (Env.add_module_declaration id md env) rem p + :: strengthen_sig (Env.add_module_declaration id md env) rem p (pos+1) (* Need to add the module in case it defines manifest module types *) | Sig_modtype(id, decl) :: rem -> let newdecl = match decl.mtd_type with None -> - {decl with mtd_type = Some(Mty_ident(Pdot(p, Ident.name id, nopos)))} + {decl with mtd_type = Some(Mty_ident(Pdot(p,Ident.name id,nopos)))} | Some _ -> decl in Sig_modtype(id, newdecl) :: - strengthen_sig (Env.add_modtype id decl env) rem p + strengthen_sig (Env.add_modtype id decl env) rem p pos (* Need to add the module type in case it is manifest *) | (Sig_class(id, decl, rs) as sigelt) :: rem -> - sigelt :: strengthen_sig env rem p + sigelt :: strengthen_sig env rem p (pos+1) | (Sig_class_type(id, decl, rs) as sigelt) :: rem -> - sigelt :: strengthen_sig env rem p + sigelt :: strengthen_sig env rem p pos and strengthen_decl env md p = {md with md_type = strengthen env md.md_type p} @@ -128,13 +133,9 @@ let nondep_supertype env mid mty = | Sig_type(id, d, rs) -> Sig_type(id, Ctype.nondep_type_decl env mid id (va = Co) d, rs) :: rem' - | Sig_exception(id, d) -> - let d = - {d with - exn_args = List.map (Ctype.nondep_type env mid) d.exn_args - } - in - Sig_exception(id, d) :: rem' + | Sig_typext(id, ext, es) -> + Sig_typext(id, Ctype.nondep_extension_constructor env mid ext, es) + :: rem' | Sig_module(id, md, rs) -> Sig_module(id, {md with md_type=nondep_mty env va md.md_type}, rs) :: rem' @@ -212,7 +213,7 @@ and type_paths_sig env p pos sg = type_paths_sig (Env.add_module_declaration id md env) p (pos+1) rem | Sig_modtype(id, decl) :: rem -> type_paths_sig (Env.add_modtype id decl env) p pos rem - | (Sig_exception _ | Sig_class _) :: rem -> + | (Sig_typext _ | Sig_class _) :: rem -> type_paths_sig env p (pos+1) rem | (Sig_class_type _) :: rem -> type_paths_sig env p pos rem @@ -237,7 +238,7 @@ and no_code_needed_sig env sg = no_code_needed_sig (Env.add_module_declaration id md env) rem | (Sig_type _ | Sig_modtype _ | Sig_class_type _) :: rem -> no_code_needed_sig env rem - | (Sig_exception _ | Sig_class _) :: rem -> + | (Sig_typext _ | Sig_class _) :: rem -> false @@ -245,8 +246,11 @@ and no_code_needed_sig env sg = let rec contains_type env = function Mty_ident path -> - (try Misc.may (contains_type env) (Env.find_modtype path env).mtd_type - with Not_found -> raise Exit) + begin try match (Env.find_modtype path env).mtd_type with + | None -> raise Exit (* PR#6427 *) + | Some mty -> contains_type env mty + with Not_found -> raise Exit + end | Mty_signature sg -> contains_type_sig env sg | Mty_functor (_, _, body) -> @@ -259,13 +263,19 @@ and contains_type_sig env = List.iter (contains_type_item env) and contains_type_item env = function Sig_type (_,({type_manifest = None} | {type_kind = Type_abstract; type_private = Private}),_) - | Sig_modtype _ -> + | Sig_modtype _ + | Sig_typext (_, {ext_args = Cstr_record _}, _) -> + (* We consider that extension constructors with an inlined + record create a type (the inlined record), even though + it would be technically safe to ignore that considering + the current constraints which guarantee that this type + is kept local to expressions. *) raise Exit | Sig_module (_, {md_type = mty}, _) -> contains_type env mty | Sig_value _ | Sig_type _ - | Sig_exception _ + | Sig_typext _ | Sig_class _ | Sig_class_type _ -> () @@ -342,6 +352,7 @@ let collect_arg_paths mty = in let it = {type_iterators with it_path; it_signature_item} in it.it_module_type it mty; + it.it_module_type unmark_iterators mty; PathSet.fold (fun p -> IdentSet.union (collect_ids !subst !bindings p)) !paths IdentSet.empty diff --git a/typing/oprint.ml b/typing/oprint.ml index 8084dff06..3c2d63708 100644 --- a/typing/oprint.ml +++ b/typing/oprint.ml @@ -223,7 +223,8 @@ and print_simple_out_type ppf = print_out_type ppf ty; pp_print_char ppf ')'; pp_close_box ppf () - | Otyp_abstract | Otyp_sum _ | Otyp_manifest (_, _) -> () + | Otyp_abstract | Otyp_open + | Otyp_sum _ | Otyp_manifest (_, _) -> () | Otyp_record lbls -> print_record_decl ppf lbls | Otyp_module (p, n, tyl) -> fprintf ppf "@[<1>(module %s" p; @@ -347,6 +348,7 @@ let out_class_type = ref print_out_class_type let out_module_type = ref (fun _ -> failwith "Oprint.out_module_type") let out_sig_item = ref (fun _ -> failwith "Oprint.out_sig_item") let out_signature = ref (fun _ -> failwith "Oprint.out_signature") +let out_type_extension = ref (fun _ -> failwith "Oprint.out_type_extension") let rec print_out_functor ppf = function @@ -369,6 +371,28 @@ and print_out_signature ppf = function [] -> () | [item] -> !out_sig_item ppf item + | Osig_typext(ext, Oext_first) :: items -> + (* Gather together the extension constructors *) + let rec gather_extensions acc items = + match items with + Osig_typext(ext, Oext_next) :: items -> + gather_extensions + ((ext.oext_name, ext.oext_args, ext.oext_ret_type) :: acc) + items + | _ -> (List.rev acc, items) + in + let exts, items = + gather_extensions + [(ext.oext_name, ext.oext_args, ext.oext_ret_type)] + items + in + let te = + { otyext_name = ext.oext_type_name; + otyext_params = ext.oext_type_params; + otyext_constructors = exts; + otyext_private = ext.oext_private } + in + fprintf ppf "%a@ %a" !out_type_extension te print_out_signature items | item :: items -> fprintf ppf "%a@ %a" !out_sig_item item print_out_signature items and print_out_sig_item ppf = @@ -383,8 +407,11 @@ and print_out_sig_item ppf = (if rs = Orec_next then "and" else "class type") (if vir_flag then " virtual" else "") print_out_class_params params name !out_class_type clt - | Osig_exception (id, tyl) -> - fprintf ppf "@[<2>exception %a@]" print_out_constr (id, tyl,None) + | Osig_typext (ext, Oext_exception) -> + fprintf ppf "@[<2>exception %a@]" + print_out_constr (ext.oext_name, ext.oext_args, ext.oext_ret_type) + | Osig_typext (ext, es) -> + print_out_extension_constructor ppf ext | Osig_modtype (name, Omty_abstract) -> fprintf ppf "@[<2>module type %s@]" name | Osig_modtype (name, mty) -> @@ -413,57 +440,63 @@ and print_out_sig_item ppf = fprintf ppf "@[<2>%s %a :@ %a%a@]" kwd value_ident name !out_type ty pr_prims prims -and print_out_type_decl kwd ppf (name, args, ty, priv, constraints) = - let print_constraints ppf params = +and print_out_type_decl kwd ppf td = + let print_constraints ppf = List.iter (fun (ty1, ty2) -> fprintf ppf "@ @[<2>constraint %a =@ %a@]" !out_type ty1 !out_type ty2) - params + td.otype_cstrs in let type_defined ppf = - match args with - [] -> pp_print_string ppf name - | [arg] -> fprintf ppf "@[%a@ %s@]" type_parameter arg name + match td.otype_params with + [] -> pp_print_string ppf td.otype_name + | [param] -> fprintf ppf "@[%a@ %s@]" type_parameter param td.otype_name | _ -> fprintf ppf "@[(@[%a)@]@ %s@]" - (print_list type_parameter (fun ppf -> fprintf ppf ",@ ")) args name + (print_list type_parameter (fun ppf -> fprintf ppf ",@ ")) + td.otype_params + td.otype_name in let print_manifest ppf = function Otyp_manifest (ty, _) -> fprintf ppf " =@ %a" !out_type ty | _ -> () in - let print_name_args ppf = - fprintf ppf "%s %t%a" kwd type_defined print_manifest ty + let print_name_params ppf = + fprintf ppf "%s %t%a" kwd type_defined print_manifest td.otype_type in let ty = - match ty with + match td.otype_type with Otyp_manifest (_, ty) -> ty - | _ -> ty + | _ -> td.otype_type in let print_private ppf = function Asttypes.Private -> fprintf ppf " private" - | Asttypes.Public -> () in + | Asttypes.Public -> () + in let print_out_tkind ppf = function | Otyp_abstract -> () | Otyp_record lbls -> fprintf ppf " =%a %a" - print_private priv + print_private td.otype_private print_record_decl lbls | Otyp_sum constrs -> fprintf ppf " =%a@;<1 2>%a" - print_private priv + print_private td.otype_private (print_list print_out_constr (fun ppf -> fprintf ppf "@ | ")) constrs + | Otyp_open -> + fprintf ppf " = .." | ty -> fprintf ppf " =%a@;<1 2>%a" - print_private priv + print_private td.otype_private !out_type ty in - fprintf ppf "@[<2>@[<hv 2>%t%a@]%a@]" - print_name_args + fprintf ppf "@[<2>@[<hv 2>%t%a@]%t@]" + print_name_params print_out_tkind ty - print_constraints constraints + print_constraints + and print_out_constr ppf (name, tyl,ret_type_opt) = match ret_type_opt with | None -> @@ -484,9 +517,58 @@ and print_out_constr ppf (name, tyl,ret_type_opt) = tyl print_simple_out_type ret_type end +and print_out_extension_constructor ppf ext = + let print_extended_type ppf = + let print_type_parameter ppf ty = + fprintf ppf "%s" + (if ty = "_" then ty else "'"^ty) + in + match ext.oext_type_params with + [] -> fprintf ppf "%s" ext.oext_type_name + | [ty_param] -> + fprintf ppf "@[%a@ %s@]" + print_type_parameter + ty_param + ext.oext_type_name + | _ -> + fprintf ppf "@[(@[%a)@]@ %s@]" + (print_list print_type_parameter (fun ppf -> fprintf ppf ",@ ")) + ext.oext_type_params + ext.oext_type_name + in + fprintf ppf "@[<hv 2>type %t +=%s@;<1 2>%a@]" + print_extended_type + (if ext.oext_private = Asttypes.Private then " private" else "") + print_out_constr (ext.oext_name, ext.oext_args, ext.oext_ret_type) + +and print_out_type_extension ppf te = + let print_extended_type ppf = + let print_type_parameter ppf ty = + fprintf ppf "%s" + (if ty = "_" then ty else "'"^ty) + in + match te.otyext_params with + [] -> fprintf ppf "%s" te.otyext_name + | [param] -> + fprintf ppf "@[%a@ %s@]" + print_type_parameter param + te.otyext_name + | _ -> + fprintf ppf "@[(@[%a)@]@ %s@]" + (print_list print_type_parameter (fun ppf -> fprintf ppf ",@ ")) + te.otyext_params + te.otyext_name + in + fprintf ppf "@[<hv 2>type %t +=%s@;<1 2>%a@]" + print_extended_type + (if te.otyext_private = Asttypes.Private then " private" else "") + (print_list print_out_constr (fun ppf -> fprintf ppf "@ | ")) + te.otyext_constructors + let _ = out_module_type := print_out_module_type let _ = out_signature := print_out_signature let _ = out_sig_item := print_out_sig_item +let _ = out_type_extension := print_out_type_extension (* Phrases *) @@ -501,6 +583,29 @@ let print_out_exception ppf exn outv = let rec print_items ppf = function [] -> () + | (Osig_typext(ext, Oext_first), None) :: items -> + (* Gather together extension constructors *) + let rec gather_extensions acc items = + match items with + (Osig_typext(ext, Oext_next), None) :: items -> + gather_extensions + ((ext.oext_name, ext.oext_args, ext.oext_ret_type) :: acc) + items + | _ -> (List.rev acc, items) + in + let exts, items = + gather_extensions + [(ext.oext_name, ext.oext_args, ext.oext_ret_type)] + items + in + let te = + { otyext_name = ext.oext_type_name; + otyext_params = ext.oext_type_params; + otyext_constructors = exts; + otyext_private = ext.oext_private } + in + fprintf ppf "@[%a@]" !out_type_extension te; + if items <> [] then fprintf ppf "@ %a" print_items items | (tree, valopt) :: items -> begin match valopt with Some v -> diff --git a/typing/oprint.mli b/typing/oprint.mli index 56caa6095..1f9ec32b1 100644 --- a/typing/oprint.mli +++ b/typing/oprint.mli @@ -19,6 +19,7 @@ val out_class_type : (formatter -> out_class_type -> unit) ref val out_module_type : (formatter -> out_module_type -> unit) ref val out_sig_item : (formatter -> out_sig_item -> unit) ref val out_signature : (formatter -> out_sig_item list -> unit) ref +val out_type_extension : (formatter -> out_type_extension -> unit) ref val out_phrase : (formatter -> out_phrase -> unit) ref val parenthesized_ident : string -> bool diff --git a/typing/outcometree.mli b/typing/outcometree.mli index eae7b2fbe..18885e8de 100644 --- a/typing/outcometree.mli +++ b/typing/outcometree.mli @@ -44,6 +44,7 @@ type out_value = type out_type = | Otyp_abstract + | Otyp_open | Otyp_alias of out_type * string | Otyp_arrow of string * out_type * out_type | Otyp_class of bool * out_ident * out_type list @@ -86,18 +87,37 @@ and out_sig_item = | Osig_class_type of bool * string * (string * (bool * bool)) list * out_class_type * out_rec_status - | Osig_exception of string * out_type list + | Osig_typext of out_extension_constructor * out_ext_status | Osig_modtype of string * out_module_type | Osig_module of string * out_module_type * out_rec_status | Osig_type of out_type_decl * out_rec_status | Osig_value of string * out_type * string list and out_type_decl = - string * (string * (bool * bool)) list * out_type * Asttypes.private_flag * - (out_type * out_type) list + { otype_name: string; + otype_params: (string * (bool * bool)) list; + otype_type: out_type; + otype_private: Asttypes.private_flag; + otype_cstrs: (out_type * out_type) list } +and out_extension_constructor = + { oext_name: string; + oext_type_name: string; + oext_type_params: string list; + oext_args: out_type list; + oext_ret_type: out_type option; + oext_private: Asttypes.private_flag } +and out_type_extension = + { otyext_name: string; + otyext_params: string list; + otyext_constructors: (string * out_type list * out_type option) list; + otyext_private: Asttypes.private_flag } and out_rec_status = | Orec_not | Orec_first | Orec_next +and out_ext_status = + | Oext_first + | Oext_next + | Oext_exception type out_phrase = | Ophr_eval of out_value * out_type diff --git a/typing/parmatch.ml b/typing/parmatch.ml index b425144a1..172979745 100644 --- a/typing/parmatch.ml +++ b/typing/parmatch.ml @@ -110,13 +110,12 @@ and compats ps qs = match ps,qs with | p::ps, q::qs -> compat p q && compats ps qs | _,_ -> assert false +exception Empty (* Empty pattern *) + (****************************************) -(* Utilities for retrieving constructor *) -(* and record label names *) +(* Utilities for retrieving type paths *) (****************************************) -exception Empty (* Empty pattern *) - (* May need a clean copy, cf. PR#4745 *) let clean_copy ty = if ty.level = Btype.generic_level then ty @@ -128,33 +127,6 @@ let get_type_path ty tenv = | Tconstr (path,_,_) -> path | _ -> fatal_error "Parmatch.get_type_path" -let get_type_descr ty tenv = - match (Ctype.repr ty).desc with - | Tconstr (path,_,_) -> Env.find_type path tenv - | _ -> fatal_error "Parmatch.get_type_descr" - -let rec get_constr tag ty tenv = - match get_type_descr ty tenv with - | {type_kind=Type_variant constr_list} -> - Datarepr.find_constr_by_tag tag constr_list - | {type_manifest = Some _} -> - get_constr tag (Ctype.expand_head_once tenv (clean_copy ty)) tenv - | _ -> fatal_error "Parmatch.get_constr" - -let find_label lbl lbls = - try - let l = List.nth lbls lbl.lbl_pos in - l.Types.ld_id - with Failure "nth" -> Ident.create "*Unknown label*" - -let rec get_record_labels ty tenv = - match get_type_descr ty tenv with - | {type_kind = Type_record(lbls, rep)} -> lbls - | {type_manifest = Some _} -> - get_record_labels (Ctype.expand_head_once tenv (clean_copy ty)) tenv - | _ -> fatal_error "Parmatch.get_record_labels" - - (*************************************) (* Values as patterns pretty printer *) (*************************************) @@ -162,16 +134,8 @@ let rec get_record_labels ty tenv = open Format ;; -let get_constr_name tag ty tenv = match tag with -| Cstr_exception (path, _) -> Path.name path -| _ -> - try - let cd = get_constr tag ty tenv in Ident.name cd.cd_id - with - | Datarepr.Constr_not_found -> "*Unknown constructor*" - -let is_cons tag v = match get_constr_name tag v.pat_type v.pat_env with -| "::" -> true +let is_cons = function +| {cstr_name = "::"} -> true | _ -> false let pretty_const c = match c with @@ -201,14 +165,12 @@ let rec pretty_val ppf v = | Tpat_constant c -> fprintf ppf "%s" (pretty_const c) | Tpat_tuple vs -> fprintf ppf "@[(%a)@]" (pretty_vals ",") vs - | Tpat_construct (_, {cstr_tag=tag},[]) -> - let name = get_constr_name tag v.pat_type v.pat_env in - fprintf ppf "%s" name - | Tpat_construct (_, {cstr_tag=tag},[w]) -> - let name = get_constr_name tag v.pat_type v.pat_env in - fprintf ppf "@[<2>%s@ %a@]" name pretty_arg w - | Tpat_construct (_, {cstr_tag=tag},vs) -> - let name = get_constr_name tag v.pat_type v.pat_env in + | Tpat_construct (_, cstr, []) -> + fprintf ppf "%s" cstr.cstr_name + | Tpat_construct (_, cstr, [w]) -> + fprintf ppf "@[<2>%s@ %a@]" cstr.cstr_name pretty_arg w + | Tpat_construct (_, cstr, vs) -> + let name = cstr.cstr_name in begin match (name, vs) with ("::", [v1;v2]) -> fprintf ppf "@[%a::@,%a@]" pretty_car v1 pretty_cdr v2 @@ -221,7 +183,7 @@ let rec pretty_val ppf v = fprintf ppf "@[<2>`%s@ %a@]" l pretty_arg w | Tpat_record (lvs,_) -> fprintf ppf "@[{%a}@]" - (pretty_lvals (get_record_labels v.pat_type v.pat_env)) + pretty_lvals (List.filter (function | (_,_,{pat_desc=Tpat_any}) -> false (* do not show lbl=_ *) @@ -236,14 +198,14 @@ let rec pretty_val ppf v = fprintf ppf "@[(%a|@,%a)@]" pretty_or v pretty_or w and pretty_car ppf v = match v.pat_desc with -| Tpat_construct (_,{cstr_tag=tag}, [_ ; _]) - when is_cons tag v -> +| Tpat_construct (_,cstr, [_ ; _]) + when is_cons cstr -> fprintf ppf "(%a)" pretty_val v | _ -> pretty_val ppf v and pretty_cdr ppf v = match v.pat_desc with -| Tpat_construct (_,{cstr_tag=tag}, [v1 ; v2]) - when is_cons tag v -> +| Tpat_construct (_,cstr, [v1 ; v2]) + when is_cons cstr -> fprintf ppf "%a::@,%a" pretty_car v1 pretty_cdr v2 | _ -> pretty_val ppf v @@ -262,15 +224,13 @@ and pretty_vals sep ppf = function | v::vs -> fprintf ppf "%a%s@ %a" pretty_val v sep (pretty_vals sep) vs -and pretty_lvals lbls ppf = function +and pretty_lvals ppf = function | [] -> () | [_,lbl,v] -> - let name = find_label lbl lbls in - fprintf ppf "%s=%a" (Ident.name name) pretty_val v + fprintf ppf "%s=%a" lbl.lbl_name pretty_val v | (_, lbl,v)::rest -> - let name = find_label lbl lbls in fprintf ppf "%s=%a;@ %a" - (Ident.name name) pretty_val v (pretty_lvals lbls) rest + lbl.lbl_name pretty_val v pretty_lvals rest let top_pretty ppf v = fprintf ppf "@[%a@]@?" pretty_val v @@ -661,16 +621,16 @@ let clean_env env = loop env let full_match ignore_generalized closing env = match env with -| ({pat_desc = Tpat_construct (_,{cstr_tag=Cstr_exception _},_)},_)::_ -> - false | ({pat_desc = Tpat_construct(_,c,_);pat_type=typ},_) :: _ -> - if ignore_generalized then - (* remove generalized constructors; - those cases will be handled separately *) - let env = clean_env env in - List.length env = c.cstr_normal + if c.cstr_consts < 0 then false (* extensions *) else - List.length env = c.cstr_consts + c.cstr_nonconsts + if ignore_generalized then + (* remove generalized constructors; + those cases will be handled separately *) + let env = clean_env env in + List.length env = c.cstr_normal + else + List.length env = c.cstr_consts + c.cstr_nonconsts | ({pat_desc = Tpat_variant _} as p,_) :: _ -> let fields = @@ -733,8 +693,8 @@ let should_extend ext env = match ext with (* complement constructor tags *) let complete_tags nconsts nconstrs tags = - let seen_const = Array.create nconsts false - and seen_constr = Array.create nconstrs false in + let seen_const = Array.make nconsts false + and seen_constr = Array.make nconstrs false in List.iter (function | Cstr_constant i -> seen_const.(i) <- true @@ -768,19 +728,18 @@ let rec pat_of_constrs ex_pat = function (pat_of_constr ex_pat cstr, pat_of_constrs ex_pat rem, None)} -exception Not_an_adt - -let rec adt_path env ty = - match get_type_descr ty env with - | {type_kind=Type_variant constr_list} -> - begin match (Ctype.repr ty).desc with - | Tconstr (path,_,_) -> - path - | _ -> assert false end - | {type_manifest = Some _} -> - adt_path env (Ctype.expand_head_once env (clean_copy ty)) - | _ -> raise Not_an_adt -;; +let rec get_variant_constructors env ty = + match (Ctype.repr ty).desc with + | Tconstr (path,_,_) -> begin + match Env.find_type path env with + | {type_kind=Type_variant _} -> + fst (Env.find_type_descrs path env) + | {type_manifest = Some _} -> + get_variant_constructors env + (Ctype.expand_head_once env (clean_copy ty)) + | _ -> fatal_error "Parmatch.get_variant_constructors" + end + | _ -> fatal_error "Parmatch.get_variant_constructors" let rec map_filter f = function @@ -794,18 +753,12 @@ let rec map_filter f = let complete_constrs p all_tags = match p.pat_desc with | Tpat_construct (_,c,_) -> - begin try - let not_tags = complete_tags c.cstr_consts c.cstr_nonconsts all_tags in - let (constrs, _) = - Env.find_type_descrs (adt_path p.pat_env p.pat_type) p.pat_env in + let not_tags = complete_tags c.cstr_consts c.cstr_nonconsts all_tags in + let constrs = get_variant_constructors p.pat_env c.cstr_res in map_filter (fun cnstr -> if List.mem cnstr.cstr_tag not_tags then Some cnstr else None) constrs - with - | Datarepr.Constr_not_found -> - fatal_error "Parmatch.complete_constr: constr_not_found" - end | _ -> fatal_error "Parmatch.complete_constr" @@ -825,16 +778,10 @@ let build_other_constant proj make first next p env = *) let build_other ext env = match env with -| ({pat_desc = - Tpat_construct (lid, ({cstr_tag=Cstr_exception _} as c),_)},_) - ::_ -> - make_pat - (Tpat_construct - (lid, {c with - cstr_tag=(Cstr_exception - (Path.Pident (Ident.create "*exception*"), Location.none))}, - [])) - Ctype.none Env.empty +| ({pat_desc = Tpat_construct (lid, + ({cstr_tag=Cstr_extension _} as c),_)},_) :: _ -> + let c = {c with cstr_name = "*extension*"} in + make_pat (Tpat_construct(lid, c, [])) Ctype.none Env.empty | ({pat_desc = Tpat_construct (_, _,_)} as p,_) :: _ -> begin match ext with | Some ext when Path.same ext (get_type_path p.pat_type p.pat_env) -> @@ -1921,7 +1868,7 @@ let rec collect_paths_from_pat r p = match p.pat_desc with ps | Tpat_any|Tpat_var _|Tpat_constant _| Tpat_variant (_,None,_) -> r | Tpat_tuple ps | Tpat_array ps -| Tpat_construct (_, {cstr_tag=Cstr_exception _}, ps)-> +| Tpat_construct (_, {cstr_tag=Cstr_extension _}, ps)-> List.fold_left collect_paths_from_pat r ps | Tpat_record (lps,_) -> List.fold_left @@ -1990,7 +1937,7 @@ let check_unused tdefs casel = p.pat_loc Warnings.Unused_pat) ps | Used -> () - with Empty | Not_an_adt | Not_found | NoGuard -> assert false + with Empty | Not_found | NoGuard -> assert false end ; if c_guard <> None then diff --git a/typing/path.ml b/typing/path.ml index 260fc0731..6afa3841b 100644 --- a/typing/path.ml +++ b/typing/path.ml @@ -52,3 +52,27 @@ let rec last = function | Pident id -> Ident.name id | Pdot(_, s, _) -> s | Papply(_, p) -> last p + +let is_uident s = + assert (s <> ""); + match s.[0] with + | 'A'..'Z' -> true + | _ -> false + +type typath = + | Regular of t + | Ext of t * string + | LocalExt of Ident.t + | Cstr of t * string + +let constructor_typath = function + | Pident id when is_uident (Ident.name id) -> LocalExt id + | Pdot(ty_path, s, _) when is_uident s -> + if is_uident (last ty_path) then Ext (ty_path, s) + else Cstr (ty_path, s) + | p -> Regular p + +let is_constructor_typath p = + match constructor_typath p with + | Regular _ -> false + | _ -> true diff --git a/typing/path.mli b/typing/path.mli index c3f84130d..07de1c2c5 100644 --- a/typing/path.mli +++ b/typing/path.mli @@ -28,3 +28,12 @@ val name: ?paren:(string -> bool) -> t -> string val head: t -> Ident.t val last: t -> string + +type typath = + | Regular of t + | Ext of t * string + | LocalExt of Ident.t + | Cstr of t * string + +val constructor_typath: t -> typath +val is_constructor_typath: t -> bool diff --git a/typing/predef.ml b/typing/predef.ml index 062bed4ee..bcad58efd 100644 --- a/typing/predef.ml +++ b/typing/predef.ml @@ -35,12 +35,12 @@ and ident_unit = ident_create "unit" and ident_exn = ident_create "exn" and ident_array = ident_create "array" and ident_list = ident_create "list" -and ident_format6 = ident_create "format6" and ident_option = ident_create "option" and ident_nativeint = ident_create "nativeint" and ident_int32 = ident_create "int32" and ident_int64 = ident_create "int64" and ident_lazy_t = ident_create "lazy_t" +and ident_bytes = ident_create "bytes" let path_int = Pident ident_int and path_char = Pident ident_char @@ -51,12 +51,12 @@ and path_unit = Pident ident_unit and path_exn = Pident ident_exn and path_array = Pident ident_array and path_list = Pident ident_list -and path_format6 = Pident ident_format6 and path_option = Pident ident_option and path_nativeint = Pident ident_nativeint and path_int32 = Pident ident_int32 and path_int64 = Pident ident_int64 and path_lazy_t = Pident ident_lazy_t +and path_bytes = Pident ident_bytes let type_int = newgenty (Tconstr(path_int, [], ref Mnil)) and type_char = newgenty (Tconstr(path_char, [], ref Mnil)) @@ -72,6 +72,7 @@ and type_nativeint = newgenty (Tconstr(path_nativeint, [], ref Mnil)) and type_int32 = newgenty (Tconstr(path_int32, [], ref Mnil)) and type_int64 = newgenty (Tconstr(path_int64, [], ref Mnil)) and type_lazy_t t = newgenty (Tconstr(path_lazy_t, [t], ref Mnil)) +and type_bytes = newgenty (Tconstr(path_bytes, [], ref Mnil)) let ident_match_failure = ident_create_predef_exn "Match_failure" and ident_out_of_memory = ident_create_predef_exn "Out_of_memory" @@ -106,11 +107,10 @@ let decl_abstr = let cstr id args = { cd_id = id; - cd_args = args; + cd_args = Cstr_tuple args; cd_res = None; cd_loc = Location.none; cd_attributes = []; - cd_inlined = false; } let ident_false = ident_create "false" @@ -120,7 +120,7 @@ and ident_nil = ident_create "[]" and ident_cons = ident_create "::" and ident_none = ident_create "None" and ident_some = ident_create "Some" -let build_initial_env add_type add_exception empty_env = +let common_initial_env add_type add_extension empty_env = let decl_bool = {decl_abstr with type_kind = Type_variant([cstr ident_false []; cstr ident_true []])} @@ -129,7 +129,7 @@ let build_initial_env add_type add_exception empty_env = type_kind = Type_variant([cstr ident_void []])} and decl_exn = {decl_abstr with - type_kind = Type_variant []} + type_kind = Type_open} and decl_array = let tvar = newgenvar() in {decl_abstr with @@ -144,12 +144,6 @@ let build_initial_env add_type add_exception empty_env = type_kind = Type_variant([cstr ident_nil []; cstr ident_cons [tvar; type_list tvar]]); type_variance = [Variance.covariant]} - and decl_format6 = - let params = List.map (newgenvar ?name:None) [();();();();();()] in - {decl_abstr with - type_params = params; - type_arity = 6; - type_variance = List.map (fun _ -> Variance.full) params} and decl_option = let tvar = newgenvar() in {decl_abstr with @@ -165,33 +159,36 @@ let build_initial_env add_type add_exception empty_env = type_variance = [Variance.covariant]} in - let add_exception id l = - add_exception id - { exn_args = l; exn_loc = Location.none; exn_attributes = []; - exn_inlined = false; - } + let add_extension id l = + add_extension id + { ext_type_path = path_exn; + ext_type_params = []; + ext_args = Cstr_tuple l; + ext_ret_type = None; + ext_private = Asttypes.Public; + ext_loc = Location.none; + ext_attributes = [] } in - add_exception ident_match_failure + add_extension ident_match_failure [newgenty (Ttuple[type_string; type_int; type_int])] ( - add_exception ident_out_of_memory [] ( - add_exception ident_stack_overflow [] ( - add_exception ident_invalid_argument [type_string] ( - add_exception ident_failure [type_string] ( - add_exception ident_not_found [] ( - add_exception ident_sys_blocked_io [] ( - add_exception ident_sys_error [type_string] ( - add_exception ident_end_of_file [] ( - add_exception ident_division_by_zero [] ( - add_exception ident_assert_failure + add_extension ident_out_of_memory [] ( + add_extension ident_stack_overflow [] ( + add_extension ident_invalid_argument [type_string] ( + add_extension ident_failure [type_string] ( + add_extension ident_not_found [] ( + add_extension ident_sys_blocked_io [] ( + add_extension ident_sys_error [type_string] ( + add_extension ident_end_of_file [] ( + add_extension ident_division_by_zero [] ( + add_extension ident_assert_failure [newgenty (Ttuple[type_string; type_int; type_int])] ( - add_exception ident_undefined_recursive_module + add_extension ident_undefined_recursive_module [newgenty (Ttuple[type_string; type_int; type_int])] ( add_type ident_int64 decl_abstr ( add_type ident_int32 decl_abstr ( add_type ident_nativeint decl_abstr ( add_type ident_lazy_t decl_lazy_t ( add_type ident_option decl_option ( - add_type ident_format6 decl_format6 ( add_type ident_list decl_list ( add_type ident_array decl_array ( add_type ident_exn decl_exn ( @@ -201,7 +198,14 @@ let build_initial_env add_type add_exception empty_env = add_type ident_string decl_abstr ( add_type ident_char decl_abstr ( add_type ident_int decl_abstr ( - empty_env))))))))))))))))))))))))))) + empty_env)))))))))))))))))))))))))) + +let build_initial_env add_type add_exception empty_env = + let common = common_initial_env add_type add_exception empty_env in + let safe_string = add_type ident_bytes decl_abstr common in + let decl_bytes_unsafe = {decl_abstr with type_manifest = Some type_string} in + let unsafe_string = add_type ident_bytes decl_bytes_unsafe common in + (safe_string, unsafe_string) let builtin_values = List.map (fun id -> Ident.make_global id; (Ident.name id, id)) diff --git a/typing/predef.mli b/typing/predef.mli index a2f472471..972367116 100644 --- a/typing/predef.mli +++ b/typing/predef.mli @@ -17,6 +17,7 @@ open Types val type_int: type_expr val type_char: type_expr val type_string: type_expr +val type_bytes: type_expr val type_float: type_expr val type_bool: type_expr val type_unit: type_expr @@ -32,13 +33,13 @@ val type_lazy_t: type_expr -> type_expr val path_int: Path.t val path_char: Path.t val path_string: Path.t +val path_bytes: Path.t val path_float: Path.t val path_bool: Path.t val path_unit: Path.t val path_exn: Path.t val path_array: Path.t val path_list: Path.t -val path_format6: Path.t val path_option: Path.t val path_nativeint: Path.t val path_int32: Path.t @@ -51,12 +52,12 @@ val path_undefined_recursive_module : Path.t (* To build the initial environment. Since there is a nasty mutual recursion between predef and env, we break it by parameterizing - over Env.t, Env.add_type and Env.add_exception. *) + over Env.t, Env.add_type and Env.add_extension. *) val build_initial_env: (Ident.t -> type_declaration -> 'a -> 'a) -> - (Ident.t -> exception_declaration -> 'a -> 'a) -> - 'a -> 'a + (Ident.t -> extension_constructor -> 'a -> 'a) -> + 'a -> 'a * 'a (* To initialize linker tables *) diff --git a/typing/printtyp.ml b/typing/printtyp.ml index 2fd5ad967..db856958b 100644 --- a/typing/printtyp.ml +++ b/typing/printtyp.ml @@ -232,7 +232,7 @@ module Path2 = struct | _ -> Pervasives.compare p1 p2 end module PathMap = Map.Make(Path2) -let printing_map = ref (Lazy.lazy_from_val PathMap.empty) +let printing_map = ref (Lazy.from_val PathMap.empty) let same_type t t' = repr t == repr t' @@ -740,43 +740,9 @@ let string_of_mutable = function | Mutable -> "mutable " -(* Support for inlined records *) - -let inlined_records = ref [] - (* We don't reset this reference too often, as a hack to make - the error message produced by: - - module X : sig type 'a t = A of int end - = struct type 'a t = A of {x:int} end - - - work as expected (the type declaration is printed after - the signature, and so the definition of the inlined record is - available *) - -let register_inlined_record id td = - let td = Ctype.instance_declaration td in - let lbls = - match td.type_kind with - | Type_record(lbls, _) -> lbls - | _ -> assert false - in - inlined_records := (id, (lbls, td.type_params)) :: !inlined_records - -let get_inlined_record cd_args = - let id, args = - match cd_args with - | [ {desc = Tconstr(Path.Pident id, args, _)} ] -> id, args - | _ -> assert false - in - try - let lbls, params = List.assoc id !inlined_records in - lbls, params, args - with Not_found -> [], [], [] - (* This can happen in an error message, where the - variant type declaration is displayed on its own *) - - +let mark_loops_constructor_arguments = function + | Cstr_tuple l -> List.iter mark_loops l + | Cstr_record l -> List.iter (fun l -> mark_loops l.ld_type) l let rec tree_of_type_decl id decl = @@ -820,17 +786,13 @@ let rec tree_of_type_decl id decl = | Type_abstract -> () | Type_variant cstrs -> List.iter - (fun cd -> - if cd.cd_inlined then - let lbls, params, args = get_inlined_record cd.cd_args in - List.iter2 link_type params args; - List.iter (fun l -> mark_loops l.ld_type) lbls - else - List.iter mark_loops cd.cd_args; - may mark_loops cd.cd_res) + (fun c -> + mark_loops_constructor_arguments c.cd_args; + may mark_loops c.cd_res) cstrs | Type_record(l, rep) -> List.iter (fun l -> mark_loops l.ld_type) l + | Type_open -> () end; let type_param = @@ -848,6 +810,8 @@ let rec tree_of_type_decl id decl = | Type_variant tll -> decl.type_private = Private || List.exists (fun cd -> cd.cd_res <> None) tll + | Type_open -> + decl.type_manifest = None in let vari = List.map2 @@ -881,18 +845,23 @@ let rec tree_of_type_decl id decl = | Type_record(lbls, rep) -> tree_of_manifest (Otyp_record (List.map tree_of_label lbls)), decl.type_private + | Type_open -> + tree_of_manifest Otyp_open, + Public in - (name, args, ty, priv, constraints) + { otype_name = name; + otype_params = args; + otype_type = ty; + otype_private = priv; + otype_cstrs = constraints } + +and tree_of_constructor_arguments = function + | Cstr_tuple l -> tree_of_typlist false l + | Cstr_record l -> [ Otyp_record (List.map tree_of_label l) ] and tree_of_constructor cd = let name = Ident.name cd.cd_id in - let arg () = - if cd.cd_inlined then - let lbls, _, _ = get_inlined_record cd.cd_args in - [ Otyp_record (List.map tree_of_label lbls) ] - else - tree_of_typlist false cd.cd_args - in + let arg () = tree_of_constructor_arguments cd.cd_args in match cd.cd_res with | None -> (name, arg (), None) | Some res -> @@ -903,12 +872,6 @@ and tree_of_constructor cd = names := nm; (name, args, Some ret) - -and tree_of_constructor_ret = - function - | None -> None - | Some ret_type -> Some (tree_of_typexp false ret_type) - and tree_of_label l = (Ident.name l.ld_id, l.ld_mutable = Mutable, tree_of_typexp false l.ld_type) @@ -918,30 +881,64 @@ let tree_of_type_declaration id decl rs = let type_declaration id ppf decl = !Oprint.out_sig_item ppf (tree_of_type_declaration id decl Trec_first) -(* Print an exception declaration *) - -let tree_of_exception_declaration id decl = - let tyl = - if decl.exn_inlined then begin - let lbls, params, args = get_inlined_record decl.exn_args in - reset (); - List.iter2 link_type params args; - List.iter (fun l -> mark_loops l.ld_type) lbls; - [ Otyp_record (List.map tree_of_label lbls) ] - end else begin - reset_and_mark_loops_list decl.exn_args; - let tyl = tree_of_typlist false decl.exn_args in - tyl - end +let constructor_arguments ppf a = + let tys = tree_of_constructor_arguments a in + !Oprint.out_type ppf (Otyp_tuple tys) + +(* Print an extension declaration *) + +let tree_of_extension_constructor id ext es = + reset (); + let ty_name = Path.name ext.ext_type_path in + let ty_params = filter_params ext.ext_type_params in + List.iter add_alias ty_params; + List.iter mark_loops ty_params; + List.iter check_name_of_type (List.map proxy ty_params); + mark_loops_constructor_arguments ext.ext_args; + may mark_loops ext.ext_ret_type; + let type_param = + function + | Otyp_var (_, id) -> id + | _ -> "?" + in + let ty_params = + List.map (fun ty -> type_param (tree_of_typexp false ty)) ty_params + in + let name = Ident.name id in + let args, ret = + match ext.ext_ret_type with + | None -> (tree_of_constructor_arguments ext.ext_args, None) + | Some res -> + let nm = !names in + names := []; + let ret = tree_of_typexp false res in + let args = tree_of_constructor_arguments ext.ext_args in + names := nm; + (args, Some ret) + in + let ext = + { oext_name = name; + oext_type_name = ty_name; + oext_type_params = ty_params; + oext_args = args; + oext_ret_type = ret; + oext_private = ext.ext_private } in - Osig_exception (Ident.name id, tyl) + let es = + match es with + Text_first -> Oext_first + | Text_next -> Oext_next + | Text_exception -> Oext_exception + in + Osig_typext (ext, es) -let exception_declaration id ppf decl = - !Oprint.out_sig_item ppf (tree_of_exception_declaration id decl) +let extension_constructor id ppf ext = + !Oprint.out_sig_item ppf (tree_of_extension_constructor id ext Text_first) (* Print a value declaration *) let tree_of_value_description id decl = + (* Format.eprintf "@[%a@]@." raw_type_expr decl.val_type; *) let id = Ident.name id in let ty = tree_of_type_scheme decl.val_type in let prims = @@ -1141,17 +1138,6 @@ let filter_rem_sig item rem = ([ctydecl; tydecl1; tydecl2], rem) | Sig_class_type _, tydecl1 :: tydecl2 :: rem -> ([tydecl1; tydecl2], rem) - | Sig_type _, rem -> - let rec loop sg = function - | (Sig_type (id, - ({type_kind = Type_record (lbls, Record_inlined _)} as td), - Trec_next)) as it :: rem -> - register_inlined_record id td; - loop (it :: sg) rem - | rem -> - List.rev sg, rem - in - loop [] rem | _ -> ([], rem) @@ -1213,13 +1199,10 @@ and trees_of_sigitem = function [tree_of_value_description id decl] | Sig_type(id, _, _) when is_row_name (Ident.name id) -> [] - | Sig_type(id, ({type_kind=Type_record(_, Record_exception _)} as td), _) -> - register_inlined_record id td; - [] | Sig_type(id, decl, rs) -> [tree_of_type_declaration id decl rs] - | Sig_exception(id, decl) -> - [tree_of_exception_declaration id decl] + | Sig_typext(id, ext, es) -> + [tree_of_extension_constructor id ext es] | Sig_module(id, md, rs) -> [tree_of_module id md.md_type rs] | Sig_modtype(id, decl) -> @@ -1254,11 +1237,6 @@ let rec print_items showval env = function List.map (fun d -> (d, showval env item)) trees @ print_items showval env rem -let print_items showval env l = - let r = print_items showval env l in - inlined_records := []; - r - (* Print a signature body (used by -i when compiling a .ml) *) let print_signature ppf tree = diff --git a/typing/printtyp.mli b/typing/printtyp.mli index 82b8608e5..14b67cd05 100644 --- a/typing/printtyp.mli +++ b/typing/printtyp.mli @@ -32,6 +32,7 @@ val mark_loops: type_expr -> unit val reset_and_mark_loops: type_expr -> unit val reset_and_mark_loops_list: type_expr list -> unit val type_expr: formatter -> type_expr -> unit +val constructor_arguments: formatter -> constructor_arguments -> unit val tree_of_type_scheme: type_expr -> out_type val type_sch : formatter -> type_expr -> unit val type_scheme: formatter -> type_expr -> unit @@ -42,15 +43,13 @@ val type_scheme_max: ?b_reset_names: bool -> (* Fin Maxence *) val tree_of_value_description: Ident.t -> value_description -> out_sig_item val value_description: Ident.t -> formatter -> value_description -> unit -(* val tree_of_type_declaration: Ident.t -> type_declaration -> rec_status -> out_sig_item -*) val type_declaration: Ident.t -> formatter -> type_declaration -> unit -val tree_of_exception_declaration: - Ident.t -> exception_declaration -> out_sig_item -val exception_declaration: - Ident.t -> formatter -> exception_declaration -> unit +val tree_of_extension_constructor: + Ident.t -> extension_constructor -> ext_status -> out_sig_item +val extension_constructor: + Ident.t -> formatter -> extension_constructor -> unit val tree_of_module: Ident.t -> module_type -> rec_status -> out_sig_item val modtype: formatter -> module_type -> unit val signature: formatter -> signature -> unit diff --git a/typing/printtyped.ml b/typing/printtyped.ml index 209121e83..5184b19e5 100644 --- a/typing/printtyped.ml +++ b/typing/printtyped.ml @@ -171,8 +171,9 @@ let rec core_type i ppf x = line i ppf "Ptyp_object %a\n" fmt_closed_flag c; let i = i + 1 in List.iter - (fun (s, t) -> - line i ppf "method %s" s; + (fun (s, attrs, t) -> + line i ppf "method %s\n" s; + attributes i ppf attrs; core_type (i + 1) ppf t ) l @@ -186,7 +187,7 @@ let rec core_type i ppf x = line i ppf "Ptyp_poly%a\n" (fun ppf -> List.iter (fun x -> fprintf ppf " '%s" x)) sl; core_type i ppf ct; - | Ttyp_package { pack_name = s; pack_fields = l } -> + | Ttyp_package { pack_path = s; pack_fields = l } -> line i ppf "Ptyp_package %a\n" fmt_path s; list i package_with ppf l; @@ -288,10 +289,11 @@ and expression i ppf x = line i ppf "Pexp_apply\n"; expression i ppf e; list i label_x_expression ppf l; - | Texp_match (e, l, partial) -> + | Texp_match (e, l1, l2, partial) -> line i ppf "Pexp_match\n"; expression i ppf e; - list i case ppf l; + list i case ppf l1; + list i case ppf l2; | Texp_try (e, l) -> line i ppf "Pexp_try\n"; expression i ppf e; @@ -377,12 +379,7 @@ and value_description i ppf x = core_type (i+1) ppf x.val_desc; list (i+1) string ppf x.val_prim; -and type_parameter i ppf (x, _variance) = - match x with - | Some x -> - string i ppf x.txt - | None -> - string i ppf "_" +and type_parameter i ppf (x, _variance) = core_type i ppf x and type_declaration i ppf x = line i ppf "type_declaration %a %a\n" fmt_ident x.typ_id fmt_location x.typ_loc; @@ -408,6 +405,37 @@ and type_kind i ppf x = | Ttype_record l -> line i ppf "Ptype_record\n"; list (i+1) label_decl ppf l; + | Ttype_open -> + line i ppf "Ptype_open\n" + +and type_extension i ppf x = + line i ppf "type_extension\n"; + attributes i ppf x.tyext_attributes; + let i = i+1 in + line i ppf "ptyext_path = %a\n" fmt_path x.tyext_path; + line i ppf "ptyext_params =\n"; + list (i+1) type_parameter ppf x.tyext_params; + line i ppf "ptyext_constructors =\n"; + list (i+1) extension_constructor ppf x.tyext_constructors; + line i ppf "ptyext_private = %a\n" fmt_private_flag x.tyext_private; + +and extension_constructor i ppf x = + line i ppf "extension_constructor %a\n" fmt_location x.ext_loc; + attributes i ppf x.ext_attributes; + let i = i + 1 in + line i ppf "pext_name = \"%a\"\n" fmt_ident x.ext_id; + line i ppf "pext_kind =\n"; + extension_constructor_kind (i + 1) ppf x.ext_kind; + +and extension_constructor_kind i ppf x = + match x with + Text_decl(a, r) -> + line i ppf "Pext_decl\n"; + constructor_arguments (i+1) ppf a; + option (i+1) core_type ppf r; + | Text_rebind(p, _) -> + line i ppf "Pext_rebind\n"; + line (i+1) ppf "%a\n" fmt_path p; and class_type i ppf x = line i ppf "class_type %a\n" fmt_location x.cltyp_loc; @@ -449,6 +477,9 @@ and class_type_field i ppf x = line i ppf "Pctf_constraint\n"; core_type (i+1) ppf ct1; core_type (i+1) ppf ct2; + | Tctf_attribute (s, arg) -> + line i ppf "Pctf_attribute \"%s\"\n" s.txt; + Printast.payload i ppf arg and class_description i ppf x = line i ppf "class_description %a\n" fmt_location x.ci_loc; @@ -456,7 +487,7 @@ and class_description i ppf x = let i = i+1 in line i ppf "pci_virt = %a\n" fmt_virtual_flag x.ci_virt; line i ppf "pci_params =\n"; - cl_type_parameters (i+1) ppf x.ci_params; + list (i+1) type_parameter ppf x.ci_params; line i ppf "pci_name = \"%s\"\n" x.ci_id_name.txt; line i ppf "pci_expr =\n"; class_type (i+1) ppf x.ci_expr; @@ -466,7 +497,7 @@ and class_type_declaration i ppf x = let i = i+1 in line i ppf "pci_virt = %a\n" fmt_virtual_flag x.ci_virt; line i ppf "pci_params =\n"; - cl_type_parameters (i+1) ppf x.ci_params; + list (i+1) type_parameter ppf x.ci_params; line i ppf "pci_name = \"%s\"\n" x.ci_id_name.txt; line i ppf "pci_expr =\n"; class_type (i+1) ppf x.ci_expr; @@ -482,12 +513,11 @@ and class_expr i ppf x = | Tcl_structure (cs) -> line i ppf "Pcl_structure\n"; class_structure i ppf cs; - | Tcl_fun (l, eo, p, e, _) -> assert false (* TODO *) -(* line i ppf "Pcl_fun\n"; + | Tcl_fun (l, p, _, ce, _) -> + line i ppf "Pcl_fun\n"; label i ppf l; - option i expression ppf eo; pattern i ppf p; - class_expr i ppf e; *) + class_expr i ppf ce | Tcl_apply (ce, l) -> line i ppf "Pcl_apply\n"; class_expr i ppf ce; @@ -500,53 +530,54 @@ and class_expr i ppf x = | Tcl_constraint (ce, Some ct, _, _, _) -> line i ppf "Pcl_constraint\n"; class_expr i ppf ce; - class_type i ppf ct; - | Tcl_constraint (_, None, _, _, _) -> assert false - (* TODO : is it possible ? see parsetree *) + class_type i ppf ct + | Tcl_constraint (ce, None, _, _, _) -> class_expr i ppf ce and class_structure i ppf { cstr_self = p; cstr_fields = l } = line i ppf "class_structure\n"; pattern (i+1) ppf p; list (i+1) class_field ppf l; -and class_field i ppf x = assert false (* TODO *) -(* let loc = x.cf_loc in +and class_field i ppf x = + line i ppf "class_field %a\n" fmt_location x.cf_loc; + let i = i + 1 in + attributes i ppf x.cf_attributes; match x.cf_desc with - | Tcf_inher (ovf, ce, so) -> - line i ppf "Pcf_inher %a\n" fmt_override_flag ovf; + | Tcf_inherit (ovf, ce, so, _, _) -> + line i ppf "Pcf_inherit %a\n" fmt_override_flag ovf; class_expr (i+1) ppf ce; option (i+1) string ppf so; - | Tcf_valvirt (s, mf, ct) -> - line i ppf "Pcf_valvirt \"%s\" %a %a\n" - s.txt fmt_mutable_flag mf fmt_location loc; - core_type (i+1) ppf ct; - | Tcf_val (s, mf, ovf, e) -> - line i ppf "Pcf_val \"%s\" %a %a %a\n" - s.txt fmt_mutable_flag mf fmt_override_flag ovf fmt_location loc; - expression (i+1) ppf e; - | Tcf_virt (s, pf, ct) -> - line i ppf "Pcf_virt \"%s\" %a %a\n" - s.txt fmt_private_flag pf fmt_location loc; - core_type (i+1) ppf ct; - | Tcf_meth (s, pf, ovf, e) -> - line i ppf "Pcf_meth \"%s\" %a %a %a\n" - s.txt fmt_private_flag pf fmt_override_flag ovf fmt_location loc; - expression (i+1) ppf e; - | Tcf_constr (ct1, ct2) -> - line i ppf "Pcf_constr %a\n" fmt_location loc; + | Tcf_val (s, mf, _, k, _) -> + line i ppf "Pcf_val \"%s\" %a\n" s.txt fmt_mutable_flag mf; + class_field_kind (i+1) ppf k + | Tcf_method (s, pf, k) -> + line i ppf "Pcf_method \"%s\" %a\n" s.txt fmt_private_flag pf; + class_field_kind (i+1) ppf k + | Tcf_constraint (ct1, ct2) -> + line i ppf "Pcf_constraint\n"; core_type (i+1) ppf ct1; core_type (i+1) ppf ct2; - | Tcf_init (e) -> - line i ppf "Pcf_init\n"; + | Tcf_initializer (e) -> + line i ppf "Pcf_initializer\n"; expression (i+1) ppf e; -*) + | Tcf_attribute (s, arg) -> + line i ppf "Pcf_attribute \"%s\"\n" s.txt; + Printast.payload i ppf arg + +and class_field_kind i ppf = function + | Tcfk_concrete (o, e) -> + line i ppf "Concrete %a\n" fmt_override_flag o; + expression i ppf e + | Tcfk_virtual t -> + line i ppf "Virtual\n"; + core_type i ppf t and class_declaration i ppf x = line i ppf "class_declaration %a\n" fmt_location x.ci_loc; let i = i+1 in line i ppf "pci_virt = %a\n" fmt_virtual_flag x.ci_virt; line i ppf "pci_params =\n"; - cl_type_parameters (i+1) ppf x.ci_params; + list (i+1) type_parameter ppf x.ci_params; line i ppf "pci_name = \"%s\"\n" x.ci_id_name.txt; line i ppf "pci_expr =\n"; class_expr (i+1) ppf x.ci_expr; @@ -585,9 +616,12 @@ and signature_item i ppf x = | Tsig_type l -> line i ppf "Psig_type\n"; list i type_declaration ppf l; - | Tsig_exception cd -> + | Tsig_typext e -> + line i ppf "Psig_typext\n"; + type_extension i ppf e; + | Tsig_exception ext -> line i ppf "Psig_exception\n"; - constructor_decl i ppf cd + extension_constructor i ppf ext | Tsig_module md -> line i ppf "Psig_module \"%a\"\n" fmt_ident md.md_id; attributes i ppf md.md_attributes; @@ -599,13 +633,15 @@ and signature_item i ppf x = line i ppf "Psig_modtype \"%a\"\n" fmt_ident x.mtd_id; attributes i ppf x.mtd_attributes; modtype_declaration i ppf x.mtd_type - | Tsig_open (ovf, li,_,attrs) -> - line i ppf "Psig_open %a %a\n" fmt_override_flag ovf fmt_path li; - attributes i ppf attrs - | Tsig_include (mt, _, attrs) -> + | Tsig_open od -> + line i ppf "Psig_open %a %a\n" + fmt_override_flag od.open_override + fmt_path od.open_path; + attributes i ppf od.open_attributes + | Tsig_include incl -> line i ppf "Psig_include\n"; - attributes i ppf attrs; - module_type i ppf mt + attributes i ppf incl.incl_attributes; + module_type i ppf incl.incl_mod | Tsig_class (l) -> line i ppf "Psig_class\n"; list i class_description ppf l; @@ -662,10 +698,7 @@ and module_expr i ppf x = line i ppf "Pmod_constraint\n"; module_expr i ppf me; module_type i ppf mt; - | Tmod_constraint (me, _, Tmodtype_implicit, _) -> assert false (* TODO *) -(* line i ppf "Pmod_constraint\n"; - module_expr i ppf me; - module_type i ppf mt; *) + | Tmod_constraint (me, _, Tmodtype_implicit, _) -> module_expr i ppf me | Tmod_unpack (e, _) -> line i ppf "Pmod_unpack\n"; expression i ppf e; @@ -689,12 +722,12 @@ and structure_item i ppf x = | Tstr_type l -> line i ppf "Pstr_type\n"; list i type_declaration ppf l; - | Tstr_exception cd -> + | Tstr_typext te -> + line i ppf "Pstr_typext\n"; + type_extension i ppf te + | Tstr_exception ext -> line i ppf "Pstr_exception\n"; - constructor_decl i ppf cd; - | Tstr_exn_rebind (s, _, li, _, attrs) -> - line i ppf "Pstr_exn_rebind \"%a\" %a\n" fmt_ident s fmt_path li; - attributes i ppf attrs + extension_constructor i ppf ext; | Tstr_module x -> line i ppf "Pstr_module\n"; module_binding i ppf x @@ -705,19 +738,21 @@ and structure_item i ppf x = line i ppf "Pstr_modtype \"%a\"\n" fmt_ident x.mtd_id; attributes i ppf x.mtd_attributes; modtype_declaration i ppf x.mtd_type - | Tstr_open (ovf, li, _, attrs) -> - line i ppf "Pstr_open %a %a\n" fmt_override_flag ovf fmt_path li; - attributes i ppf attrs + | Tstr_open od -> + line i ppf "Pstr_open %a %a\n" + fmt_override_flag od.open_override + fmt_path od.open_path; + attributes i ppf od.open_attributes | Tstr_class (l) -> line i ppf "Pstr_class\n"; list i class_declaration ppf (List.map (fun (cl, _,_) -> cl) l); | Tstr_class_type (l) -> line i ppf "Pstr_class_type\n"; list i class_type_declaration ppf (List.map (fun (_, _, cl) -> cl) l); - | Tstr_include (me, _, attrs) -> + | Tstr_include incl -> line i ppf "Pstr_include"; - attributes i ppf attrs; - module_expr i ppf me; + attributes i ppf incl.incl_attributes; + module_expr i ppf incl.incl_mod; | Tstr_attribute (s, arg) -> line i ppf "Pstr_attribute \"%s\"\n" s.txt; Printast.payload i ppf arg @@ -742,11 +777,15 @@ and core_type_x_core_type_x_location i ppf (ct1, ct2, l) = and constructor_decl i ppf {cd_id; cd_name = _; cd_args; cd_res; cd_loc; cd_attributes} = line i ppf "%a\n" fmt_location cd_loc; - attributes i ppf cd_attributes; line (i+1) ppf "%a\n" fmt_ident cd_id; - list (i+1) core_type ppf cd_args; + attributes i ppf cd_attributes; + constructor_arguments (i+1) ppf cd_args; option (i+1) core_type ppf cd_res +and constructor_arguments i ppf = function + | Cstr_tuple l -> list i core_type ppf l + | Cstr_record l -> list i label_decl ppf l + and label_decl i ppf {ld_id; ld_name = _; ld_mutable; ld_type; ld_loc; ld_attributes} = line i ppf "%a\n" fmt_location ld_loc; attributes i ppf ld_attributes; @@ -754,13 +793,6 @@ and label_decl i ppf {ld_id; ld_name = _; ld_mutable; ld_type; ld_loc; ld_attrib line (i+1) ppf "%a" fmt_ident ld_id; core_type (i+1) ppf ld_type -and cl_type_parameters i ppf l = - line i ppf "<params>\n"; - list (i+1) cl_type_parameter ppf l; - -and cl_type_parameter i ppf (x, _variance) = - string_loc i ppf x - and longident_x_pattern i ppf (li, _, p) = line i ppf "%a\n" fmt_longident li; pattern (i+1) ppf p; @@ -798,8 +830,9 @@ and ident_x_loc_x_expression_def i ppf (l,_, e) = and label_x_bool_x_core_type_list i ppf x = match x with - Ttag (l, b, ctl) -> + Ttag (l, attrs, b, ctl) -> line i ppf "Rtag \"%s\" %s\n" l (string_of_bool b); + attributes (i+1) ppf attrs; list (i+1) core_type ppf ctl | Tinherit (ct) -> line i ppf "Rinherit\n"; diff --git a/typing/subst.ml b/typing/subst.ml index c2d12b1ae..b6a0edbc5 100644 --- a/typing/subst.ml +++ b/typing/subst.ml @@ -76,6 +76,13 @@ let type_path s = function | Papply(p1, p2) -> fatal_error "Subst.type_path" +let type_path s p = + match Path.constructor_typath p with + | Regular p -> type_path s p + | Cstr (ty_path, cstr) -> Pdot(type_path s ty_path, cstr, nopos) + | LocalExt _ -> type_path s p + | Ext (p, cstr) -> Pdot(module_path s p, cstr, nopos) + (* Special type ids for saved signatures *) let new_id = ref (-1) @@ -184,6 +191,30 @@ let type_expr s ty = cleanup_types (); ty' +let label_declaration s l = + { + ld_id = l.ld_id; + ld_mutable = l.ld_mutable; + ld_type = typexp s l.ld_type; + ld_loc = loc s l.ld_loc; + ld_attributes = attrs s l.ld_attributes; + } + +let constructor_arguments s = function + | Cstr_tuple l -> + Cstr_tuple (List.map (typexp s) l) + | Cstr_record l -> + Cstr_record (List.map (label_declaration s) l) + +let constructor_declaration s c = + { + cd_id = c.cd_id; + cd_args = constructor_arguments s c.cd_args; + cd_res = may_map (typexp s) c.cd_res; + cd_loc = loc s c.cd_loc; + cd_attributes = attrs s c.cd_attributes; + } + let type_declaration s decl = let decl = { type_params = List.map (typexp s) decl.type_params; @@ -192,32 +223,10 @@ let type_declaration s decl = begin match decl.type_kind with Type_abstract -> Type_abstract | Type_variant cstrs -> - Type_variant - (List.map - (fun c -> - { - cd_id = c.cd_id; - cd_args = List.map (typexp s) c.cd_args; - cd_res = may_map (typexp s) c.cd_res; - cd_loc = loc s c.cd_loc; - cd_attributes = attrs s c.cd_attributes; - cd_inlined = c.cd_inlined; - } - ) - cstrs) + Type_variant (List.map (constructor_declaration s) cstrs) | Type_record(lbls, rep) -> - Type_record - (List.map (fun l -> - { - ld_id = l.ld_id; - ld_mutable = l.ld_mutable; - ld_type = typexp s l.ld_type; - ld_loc = loc s l.ld_loc; - ld_attributes = attrs s l.ld_attributes; - } - ) - lbls, - rep) + Type_record (List.map (label_declaration s) lbls, rep) + | Type_open -> Type_open end; type_manifest = begin @@ -299,12 +308,18 @@ let value_description s descr = val_attributes = attrs s descr.val_attributes; } -let exception_declaration s descr = - { exn_args = List.map (type_expr s) descr.exn_args; - exn_loc = loc s descr.exn_loc; - exn_attributes = attrs s descr.exn_attributes; - exn_inlined = descr.exn_inlined; - } +let extension_constructor s ext = + let ext = + { ext_type_path = type_path s ext.ext_type_path; + ext_type_params = List.map (typexp s) ext.ext_type_params; + ext_args = constructor_arguments s ext.ext_args; + ext_ret_type = may_map (typexp s) ext.ext_ret_type; + ext_private = ext.ext_private; + ext_attributes = ext.ext_attributes; + ext_loc = if s.for_saving then Location.none else ext.ext_loc; } + in + cleanup_types (); + ext let rec rename_bound_idents s idents = function [] -> (List.rev idents, s) @@ -318,7 +333,7 @@ let rec rename_bound_idents s idents = function let id' = Ident.rename id in rename_bound_idents (add_modtype id (Mty_ident(Pident id')) s) (id' :: idents) sg - | (Sig_value(id, _) | Sig_exception(id, _) | + | (Sig_value(id, _) | Sig_typext(id, _, _) | Sig_class(id, _, _) | Sig_class_type(id, _, _)) :: sg -> let id' = Ident.rename id in rename_bound_idents s (id' :: idents) sg @@ -356,8 +371,8 @@ and signature_component s comp newid = Sig_value(newid, value_description s d) | Sig_type(id, d, rs) -> Sig_type(newid, type_declaration s d, rs) - | Sig_exception(id, d) -> - Sig_exception(newid, exception_declaration s d) + | Sig_typext(id, ext, es) -> + Sig_typext(newid, extension_constructor s ext, es) | Sig_module(id, d, rs) -> Sig_module(newid, module_declaration s d, rs) | Sig_modtype(id, d) -> diff --git a/typing/subst.mli b/typing/subst.mli index 24a63b3e3..a197f82f4 100644 --- a/typing/subst.mli +++ b/typing/subst.mli @@ -43,8 +43,8 @@ val type_expr: t -> type_expr -> type_expr val class_type: t -> class_type -> class_type val value_description: t -> value_description -> value_description val type_declaration: t -> type_declaration -> type_declaration -val exception_declaration: - t -> exception_declaration -> exception_declaration +val extension_constructor: + t -> extension_constructor -> extension_constructor val class_declaration: t -> class_declaration -> class_declaration val cltype_declaration: t -> class_type_declaration -> class_type_declaration val modtype: t -> module_type -> module_type diff --git a/typing/typeclass.ml b/typing/typeclass.ml index 79c8bc7ee..eb7746214 100644 --- a/typing/typeclass.ml +++ b/typing/typeclass.ml @@ -46,9 +46,9 @@ type error = | Mutability_mismatch of string * mutable_flag | No_overriding of string * string | Duplicate of string * string - | Extension of string exception Error of Location.t * Env.t * error +exception Error_forward of Location.error open Typedtree @@ -70,7 +70,7 @@ let dummy_method = Btype.dummy_method Path associated to the temporary class type of a class being typed (its constructor is not available). *) -let unbound_class = Path.Pident (Ident.create "") +let unbound_class = Path.Pident (Ident.create "*undef*") (************************************) @@ -410,8 +410,13 @@ let rec class_type_field env self_type meths (mkctf (Tctf_constraint (cty, cty')) :: fields, val_sig, concr_meths, inher) - | Pctf_extension (s, _arg) -> - raise (Error (s.loc, env, Extension s.txt)) + | Pctf_attribute x -> + Typetexp.warning_attribute [x]; + (mkctf (Tctf_attribute x) :: fields, + val_sig, concr_meths, inher) + + | Pctf_extension ext -> + raise (Error_forward (Typetexp.error_of_extension ext)) and class_signature env {pcsig_self=sty; pcsig_fields=sign} = let meths = ref Meths.empty in @@ -432,20 +437,22 @@ and class_signature env {pcsig_self=sty; pcsig_fields=sign} = end; (* Class type fields *) - let (fields, val_sig, concr_meths, inher) = + Typetexp.warning_enter_scope (); + let (rev_fields, val_sig, concr_meths, inher) = List.fold_left (class_type_field env self_type meths) ([], Vars.empty, Concr.empty, []) sign in + Typetexp.warning_leave_scope (); let cty = {csig_self = self_type; csig_vars = val_sig; csig_concr = concr_meths; csig_inher = inher} in { csig_self = self_cty; - csig_fields = fields; + csig_fields = List.rev rev_fields; csig_type = cty; - } + } and class_type env scty = let cltyp desc typ = @@ -494,8 +501,8 @@ and class_type env scty = let clty = class_type env scty in let typ = Cty_arrow (l, ty, clty.cltyp_type) in cltyp (Tcty_arrow (l, cty, clty)) typ - | Pcty_extension (s, _arg) -> - raise (Error (s.loc, env, Extension s.txt)) + | Pcty_extension ext -> + raise (Error_forward (Typetexp.error_of_extension ext)) let class_type env scty = delayed_meth_specs := []; @@ -700,9 +707,13 @@ let rec class_field self_loc cl_num self_type meths vars end in (val_env, met_env, par_env, field::fields, concr_meths, warn_vals, inher, local_meths, local_vals) - - | Pcf_extension (s, _arg) -> - raise (Error (s.loc, val_env, Extension s.txt)) + | Pcf_attribute x -> + Typetexp.warning_attribute [x]; + (val_env, met_env, par_env, + lazy (mkcf (Tcf_attribute x)) :: fields, + concr_meths, warn_vals, inher, local_meths, local_vals) + | Pcf_extension ext -> + raise (Error_forward (Typetexp.error_of_extension ext)) and class_structure cl_num final val_env met_env loc { pcstr_self = spat; pcstr_fields = str } = @@ -751,12 +762,14 @@ and class_structure cl_num final val_env met_env loc end; (* Typing of class fields *) + Typetexp.warning_enter_scope (); let (_, _, _, fields, concr_meths, _, inher, _local_meths, _local_vals) = List.fold_left (class_field self_loc cl_num self_type meths vars) (val_env, meth_env, par_env, [], Concr.empty, Concr.empty, [], Concr.empty, Concr.empty) str in + Typetexp.warning_leave_scope (); Ctype.unify val_env self_type (Ctype.newvar ()); let sign = {csig_self = public_self; @@ -955,6 +968,9 @@ and class_expr cl_num val_env met_env scl = cl_attributes = scl.pcl_attributes; } | Pcl_apply (scl', sargs) -> + if sargs = [] then + Syntaxerr.ill_formed_ast scl.pcl_loc + "Function application with no argument."; if !Clflags.principal then Ctype.begin_def (); let cl = class_expr cl_num val_env met_env scl' in if !Clflags.principal then begin @@ -1132,8 +1148,8 @@ and class_expr cl_num val_env met_env scl = cl_env = val_env; cl_attributes = scl.pcl_attributes; } - | Pcl_extension (s, _arg) -> - raise (Error (s.loc, val_env, Extension s.txt)) + | Pcl_extension ext -> + raise (Error_forward (Typetexp.error_of_extension ext)) (*******************************) @@ -1252,12 +1268,16 @@ let class_infos define_class kind Ctype.begin_class_def (); (* Introduce class parameters *) - let params = - try - List.map (fun (x, _v) -> enter_type_variable x) cl.pci_params - with Already_bound loc -> - raise(Error(loc, env, Repeated_parameter)) + let ci_params = + let make_param (sty, v) = + try + (transl_type_param env sty, v) + with Already_bound -> + raise(Error(sty.ptyp_loc, env, Repeated_parameter)) + in + List.map make_param cl.pci_params in + let params = List.map (fun (cty, _) -> cty.ctyp_type) ci_params in (* Allow self coercions (only for class declarations) *) let coercion_locs = ref [] in @@ -1443,12 +1463,12 @@ let class_infos define_class kind type_attributes = []; (* or keep attrs from cl? *) } in - ((cl, id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, + ((cl, id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, ci_params, arity, pub_meths, List.rev !coercion_locs, expr) :: res, env) let final_decl env define_class - (cl, id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, + (cl, id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, ci_params, arity, pub_meths, coe, expr) = begin try Ctype.collapse_conj_params env clty.cty_params @@ -1485,7 +1505,7 @@ let final_decl env define_class arity, pub_meths, coe, expr, { ci_loc = cl.pci_loc; ci_virt = cl.pci_virt; - ci_params = cl.pci_params; + ci_params = ci_params; (* TODO : check that we have the correct use of identifiers *) ci_id_name = cl.pci_name; ci_id_class = id; @@ -1818,8 +1838,6 @@ let report_error env ppf = function | Duplicate (kind, name) -> fprintf ppf "@[The %s `%s'@ has multiple definitions in this object@]" kind name - | Extension s -> - fprintf ppf "Uninterpreted extension '%s'." s let report_error env ppf err = Printtyp.wrap_printing_env env (fun () -> report_error env ppf err) @@ -1829,6 +1847,8 @@ let () = (function | Error (loc, env, err) -> Some (Location.error_of_printer loc (report_error env) err) + | Error_forward err -> + Some err | _ -> None ) diff --git a/typing/typeclass.mli b/typing/typeclass.mli index a4a360bcc..8e8675fe7 100644 --- a/typing/typeclass.mli +++ b/typing/typeclass.mli @@ -104,8 +104,8 @@ type error = | Mutability_mismatch of string * mutable_flag | No_overriding of string * string | Duplicate of string * string - | Extension of string exception Error of Location.t * Env.t * error +exception Error_forward of Location.error val report_error : Env.t -> formatter -> error -> unit diff --git a/typing/typecore.ml b/typing/typecore.ml index 9351572e2..9395b5295 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -37,8 +37,7 @@ type error = | Wrong_name of string * type_expr * string * Path.t * Longident.t | Name_type_mismatch of string * Longident.t * (Path.t * Path.t) * (Path.t * Path.t) list - | Incomplete_format of string - | Bad_conversion of string * int * char + | Invalid_format of string | Undefined_method of type_expr * string | Undefined_inherited_method of string | Virtual_class of Longident.t @@ -66,9 +65,12 @@ type error = | Unqualified_gadt_pattern of Path.t * string | Invalid_interval | Invalid_for_loop_index - | Extension of string + | No_value_clauses + | Exception_pattern_below_toplevel + | Inlined_record_escape exception Error of Location.t * Env.t * error +exception Error_forward of Location.error (* Forward declaration, to be filled in by Typemod.type_module *) @@ -110,6 +112,17 @@ let rp node = ;; +let is_recarg d = + match (repr d.val_type).desc with + | Tconstr(p, _, _) -> Path.is_constructor_typath p + | _ -> false + +type recarg = + | Allowed + | Required + | Rejected + + let fst3 (x, _, _) = x let snd3 (_,x,_) = x @@ -183,14 +196,14 @@ let iter_expression f e = | Pstr_value (_, pel) -> List.iter binding pel | Pstr_primitive _ | Pstr_type _ + | Pstr_typext _ | Pstr_exception _ | Pstr_modtype _ | Pstr_open _ | Pstr_class_type _ | Pstr_attribute _ - | Pstr_extension _ - | Pstr_exn_rebind _ -> () - | Pstr_include (me, _) + | Pstr_extension _ -> () + | Pstr_include {pincl_mod = me} | Pstr_module {pmb_expr = me} -> module_expr me | Pstr_recmodule l -> List.iter (fun x -> module_expr x.pmb_expr) l | Pstr_class cdl -> List.iter (fun c -> class_expr c.pci_expr) cdl @@ -215,7 +228,7 @@ let iter_expression f e = | Pcf_val (_, _, Cfk_concrete (_, e)) | Pcf_method (_, _, Cfk_concrete (_, e)) -> expr e | Pcf_initializer e -> expr e - | Pcf_extension _ -> () + | Pcf_attribute _ | Pcf_extension _ -> () in expr e @@ -257,14 +270,14 @@ let mkexp exp_desc exp_type exp_loc exp_env = { exp_desc; exp_type; exp_loc; exp_env; exp_extra = []; exp_attributes = [] } let option_none ty loc = - let lid = Longident.Lident "None" in - let cnone = Env.lookup_constructor lid Env.initial in - mkexp (Texp_construct(mknoloc lid, cnone, [])) - ty loc Env.initial + let lid = Longident.Lident "None" + and env = Env.initial_safe_string in + let cnone = Env.lookup_constructor lid env in + mkexp (Texp_construct(mknoloc lid, cnone, [])) ty loc env let option_some texp = let lid = Longident.Lident "Some" in - let csome = Env.lookup_constructor lid Env.initial in + let csome = Env.lookup_constructor lid Env.initial_safe_string in mkexp ( Texp_construct(mknoloc lid , csome, [texp]) ) (type_option texp.exp_type) texp.exp_loc texp.exp_env @@ -280,8 +293,7 @@ let extract_concrete_record env ty = let extract_concrete_variant env ty = match extract_concrete_typedecl env ty with - (* exclude exceptions *) - (p0, p, {type_kind=Type_variant (_::_ as cstrs)}) -> (p0, p, cstrs) + (p0, p, {type_kind=Type_variant cstrs}) -> (p0, p, cstrs) | _ -> raise Not_found let extract_label_names sexp env ty = @@ -291,6 +303,13 @@ let extract_label_names sexp env ty = with Not_found -> assert false +let explicit_arity = + List.exists + (function + | ({txt="ocaml.explicit_arity"|"explicit_arity"; _}, _) -> true + | _ -> false + ) + (* Typing of patterns *) (* unification inside type_pat*) @@ -565,7 +584,8 @@ let rec expand_path env p = Some {type_manifest = Some ty} -> begin match repr ty with {desc=Tconstr(p,_,_)} -> expand_path env p - | _ -> assert false + | _ -> p + (* PR#6394: recursive module may introduce incoherent manifest *) end | _ -> let p' = Env.normalize_path None env p in @@ -584,6 +604,7 @@ module NameChoice(Name : sig val get_descrs: Env.type_descriptions -> t list val fold: (t -> 'a -> 'a) -> Longident.t option -> Env.t -> 'a -> 'a val unbound_name_error: Env.t -> Longident.t loc -> 'a + val in_env: t -> bool end) = struct open Name @@ -600,7 +621,7 @@ end) = struct let lookup_from_type env tpath lid = let descrs = get_descrs (Env.find_type_descrs tpath env) in - Env.mark_type_used (Path.last tpath) (Env.find_type tpath env); + Env.mark_type_used env (Path.last tpath) (Env.find_type tpath env); match lid.txt with Longident.Lident s -> begin try @@ -677,9 +698,12 @@ end) = struct with Not_found -> try let lbl = lookup_from_type env tpath lid in check_lk tpath lbl; + if in_env lbl then + begin let s = Printtyp.string_of_path tpath in warn lid.loc (Warnings.Name_out_of_scope (s, [Longident.last lid.txt], false)); + end; if not pr then warn_pr (); lbl with Not_found -> @@ -696,6 +720,7 @@ end) = struct raise (Error (lid.loc, env, Name_type_mismatch (type_kind, lid.txt, tp, tpl))) in + if in_env lbl then begin match scope with (lab1,_)::_ when lab1 == lbl -> () | _ -> @@ -717,6 +742,10 @@ module Label = NameChoice (struct let get_descrs = snd let fold = Env.fold_labels let unbound_name_error = Typetexp.unbound_label_error + let in_env lbl = + match lbl.lbl_repres with + | Record_regular | Record_float -> true + | Record_inlined _ | Record_extension -> false end) let disambiguate_label_by_ids keep env closed ids labels = @@ -861,13 +890,6 @@ let check_recordpat_labels loc lbl_pat_list closed = (* Constructors *) -let lookup_constructor_from_type env tpath lid = - let (constructors, _) = Env.find_type_descrs tpath env in - match lid with - Longident.Lident s -> - List.find (fun cstr -> cstr.cstr_name = s) constructors - | _ -> raise Not_found - module Constructor = NameChoice (struct type t = constructor_description let type_kind = "variant" @@ -876,6 +898,7 @@ module Constructor = NameChoice (struct let get_descrs = fst let fold = Env.fold_constructors let unbound_name_error = Typetexp.unbound_constructor_error + let in_env _ = true end) (* unification of a type with a tconstr with @@ -990,6 +1013,8 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty = | Ppat_interval _ -> raise (Error (loc, !env, Invalid_interval)) | Ppat_tuple spl -> + if List.length spl < 2 then + Syntaxerr.ill_formed_ast loc "Tuples must have at least 2 components."; let spl_ann = List.map (fun p -> (p,newvar ())) spl in let ty = newty (Ttuple(List.map snd spl_ann)) in unify_pat_types loc !env ty expected_ty; @@ -1033,7 +1058,9 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty = let sargs = match sarg with None -> [] - | Some {ppat_desc = Ppat_tuple spl} when constr.cstr_arity > 1 -> spl + | Some {ppat_desc = Ppat_tuple spl} when + constr.cstr_arity > 1 || explicit_arity sp.ppat_attributes + -> spl | Some({ppat_desc = Ppat_any} as sp) when constr.cstr_arity <> 1 -> if constr.cstr_arity = 0 then Location.prerr_warning sp.ppat_loc @@ -1050,6 +1077,21 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty = unify_pat_types_gadt loc env ty_res expected_ty else unify_pat_types loc !env ty_res expected_ty; + + let rec check_non_escaping p = + match p.ppat_desc with + | Ppat_or (p1, p2) -> + check_non_escaping p1; + check_non_escaping p2 + | Ppat_alias (p, _) -> + check_non_escaping p + | Ppat_constraint _ -> + raise (Error (p.ppat_loc, !env, Inlined_record_escape)) + | _ -> + () + in + if constr.cstr_inlined <> None then List.iter check_non_escaping sargs; + let args = List.map2 (fun p t -> type_pat p t) sargs ty_args in rp { pat_desc=Tpat_construct(lid, constr, args); @@ -1080,6 +1122,8 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty = pat_attributes = sp.ppat_attributes; pat_env = !env } | Ppat_record(lid_sp_list, closed) -> + if lid_sp_list = [] then + Syntaxerr.ill_formed_ast loc "Records cannot be empty."; let opath, record_ty = try let (p0, p,_) = extract_concrete_record !env expected_ty in @@ -1197,8 +1241,10 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty = unify_pat_types loc !env ty expected_ty; { p with pat_extra = (Tpat_type (path, lid), loc, sp.ppat_attributes) :: p.pat_extra } - | Ppat_extension (s, _arg) -> - raise (Error (s.loc, !env, Extension s.txt)) + | Ppat_exception _ -> + raise (Error (loc, !env, Exception_pattern_below_toplevel)) + | Ppat_extension ext -> + raise (Error_forward (Typetexp.error_of_extension ext)) let type_pat ?(allow_existentials=false) ?constrs ?labels ?(lev=get_current_level()) env sp expected_ty = @@ -1341,11 +1387,17 @@ let type_self_pattern cl_num privty val_env met_env par_env spat = let delayed_checks = ref [] let reset_delayed_checks () = delayed_checks := [] -let add_delayed_check f = delayed_checks := f :: !delayed_checks +let add_delayed_check f = + delayed_checks := (f, Warnings.backup ()) :: !delayed_checks + let force_delayed_checks () = (* checks may change type levels *) let snap = Btype.snapshot () in - List.iter (fun f -> f ()) (List.rev !delayed_checks); + let w_old = Warnings.backup () in + List.iter + (fun (f, w) -> Warnings.restore w; f ()) + (List.rev !delayed_checks); + Warnings.restore w_old; reset_delayed_checks (); Btype.backtrack snap @@ -1371,7 +1423,7 @@ let rec is_nonexpansive exp = | Texp_function _ -> true | Texp_apply(e, (_,None,_)::el) -> is_nonexpansive e && List.for_all is_nonexpansive_opt (List.map snd3 el) - | Texp_match(e, cases, _) -> + | Texp_match(e, cases, [], _) -> is_nonexpansive e && List.for_all (fun {c_lhs = _; c_guard; c_rhs} -> @@ -1407,7 +1459,8 @@ let rec is_nonexpansive exp = incr count; true | Tcf_initializer e -> is_nonexpansive e | Tcf_constraint _ -> true - | Tcf_inherit _ -> false) + | Tcf_inherit _ -> false + | Tcf_attribute _ -> true) fields && Vars.fold (fun _ (mut,_,_) b -> decr count; b && mut = Immutable) vars true && @@ -1427,16 +1480,23 @@ and is_nonexpansive_mod mexp = | Tmod_structure str -> List.for_all (fun item -> match item.str_desc with - | Tstr_eval _ | Tstr_primitive _ | Tstr_type _ | Tstr_modtype _ - | Tstr_open _ | Tstr_class_type _ | Tstr_exn_rebind _ -> true + | Tstr_eval _ | Tstr_primitive _ | Tstr_type _ + | Tstr_modtype _ | Tstr_open _ | Tstr_class_type _ -> true | Tstr_value (_, pat_exp_list) -> List.for_all (fun vb -> is_nonexpansive vb.vb_expr) pat_exp_list | Tstr_module {mb_expr=m;_} - | Tstr_include (m, _, _) -> is_nonexpansive_mod m + | Tstr_include {incl_mod=m;_} -> is_nonexpansive_mod m | Tstr_recmodule id_mod_list -> List.for_all (fun {mb_expr=m;_} -> is_nonexpansive_mod m) id_mod_list - | Tstr_exception _ -> false (* true would be unsound *) + | Tstr_exception {ext_kind = Text_decl _} -> + false (* true would be unsound *) + | Tstr_exception {ext_kind = Text_rebind _} -> true + | Tstr_typext te -> + List.for_all + (function {ext_kind = Text_decl _} -> false + | {ext_kind = Text_rebind _} -> true) + te.tyext_constructors | Tstr_class _ -> false (* could be more precise *) | Tstr_attribute _ -> true ) @@ -1447,211 +1507,6 @@ and is_nonexpansive_opt = function None -> true | Some e -> is_nonexpansive e -(* Typing format strings for printing or reading. - - These format strings are used by functions in modules Printf, Format, and - Scanf. - - (Handling of * modifiers contributed by Thorsten Ohl.) *) - -external string_to_format : - string -> ('a, 'b, 'c, 'd, 'e, 'f) format6 = "%identity" -external format_to_string : - ('a, 'b, 'c, 'd, 'e, 'f) format6 -> string = "%identity" - -let type_format loc fmt = - - let ty_arrow gty ty = newty (Tarrow ("", instance_def gty, ty, Cok)) in - - let bad_conversion fmt i c = - raise (Error (loc, Env.empty, Bad_conversion (fmt, i, c))) in - let incomplete_format fmt = - raise (Error (loc, Env.empty, Incomplete_format fmt)) in - - let rec type_in_format fmt = - - let len = String.length fmt in - - let ty_input = newvar () - and ty_result = newvar () - and ty_aresult = newvar () - and ty_uresult = newvar () in - - let meta = ref 0 in - - let rec scan_format i = - if i >= len then - if !meta = 0 - then ty_uresult, ty_result - else incomplete_format fmt else - match fmt.[i] with - | '%' -> scan_opts i (i + 1) - | _ -> scan_format (i + 1) - and scan_opts i j = - if j >= len then incomplete_format fmt else - match fmt.[j] with - | '_' -> scan_rest true i (j + 1) - | _ -> scan_rest false i j - and scan_rest skip i j = - let rec scan_flags i j = - if j >= len then incomplete_format fmt else - match fmt.[j] with - | '#' | '0' | '-' | ' ' | '+' -> scan_flags i (j + 1) - | _ -> scan_width i j - and scan_width i j = scan_width_or_prec_value scan_precision i j - and scan_decimal_string scan i j = - if j >= len then incomplete_format fmt else - match fmt.[j] with - | '0' .. '9' -> scan_decimal_string scan i (j + 1) - | _ -> scan i j - and scan_width_or_prec_value scan i j = - if j >= len then incomplete_format fmt else - match fmt.[j] with - | '*' -> - let ty_uresult, ty_result = scan i (j + 1) in - ty_uresult, ty_arrow Predef.type_int ty_result - | '-' | '+' -> scan_decimal_string scan i (j + 1) - | _ -> scan_decimal_string scan i j - and scan_precision i j = - if j >= len then incomplete_format fmt else - match fmt.[j] with - | '.' -> scan_width_or_prec_value scan_conversion i (j + 1) - | _ -> scan_conversion i j - and scan_indication j = - if j >= len then j - 1 else - match fmt.[j] with - | '@' -> - let k = j + 1 in - if k >= len then j - 1 else - begin match fmt.[k] with - | '%' -> - let k = k + 1 in - if k >= len then j - 1 else - begin match fmt.[k] with - | '%' | '@' -> k - | _c -> j - 1 - end - | _c -> k - end - | _c -> j - 1 - and scan_range j = - let rec scan_closing j = - if j >= len then incomplete_format fmt else - match fmt.[j] with - | ']' -> j - | '%' -> - let j = j + 1 in - if j >= len then incomplete_format fmt else - begin match fmt.[j] with - | '%' | '@' -> scan_closing (j + 1) - | c -> bad_conversion fmt j c - end - | c -> scan_closing (j + 1) in - let scan_first_pos j = - if j >= len then incomplete_format fmt else - match fmt.[j] with - | ']' -> scan_closing (j + 1) - | c -> scan_closing j in - let scan_first_neg j = - if j >= len then incomplete_format fmt else - match fmt.[j] with - | '^' -> scan_first_pos (j + 1) - | c -> scan_first_pos j in - - scan_first_neg j - - and conversion j ty_arg = - let ty_uresult, ty_result = scan_format (j + 1) in - ty_uresult, - if skip then ty_result else ty_arrow ty_arg ty_result - - and conversion_a j ty_e ty_arg = - let ty_uresult, ty_result = conversion j ty_arg in - let ty_a = ty_arrow ty_input (ty_arrow ty_e ty_aresult) in - ty_uresult, ty_arrow ty_a ty_result - - and conversion_r j ty_e ty_arg = - let ty_uresult, ty_result = conversion j ty_arg in - let ty_r = ty_arrow ty_input ty_e in - ty_arrow ty_r ty_uresult, ty_result - - and scan_conversion i j = - if j >= len then incomplete_format fmt else - match fmt.[j] with - | '%' | '@' | '!' | ',' -> scan_format (j + 1) - | 's' | 'S' -> - let j = scan_indication (j + 1) in - conversion j Predef.type_string - | '[' -> - let j = scan_range (j + 1) in - let j = scan_indication (j + 1) in - conversion j Predef.type_string - | 'c' | 'C' -> conversion j Predef.type_char - | 'd' | 'i' | 'o' | 'u' | 'x' | 'X' | 'N' -> - conversion j Predef.type_int - | 'f' | 'e' | 'E' | 'g' | 'G' | 'F' -> conversion j Predef.type_float - | 'B' | 'b' -> conversion j Predef.type_bool - | 'a' | 'r' as conv -> - let conversion = - if conv = 'a' then conversion_a else conversion_r in - let ty_e = newvar () in - let j = j + 1 in - if j >= len then conversion (j - 1) ty_e ty_e else begin - match fmt.[j] with -(* | 'a' | 'A' -> conversion j ty_e (Predef.type_array ty_e) - | 'l' | 'L' -> conversion j ty_e (Predef.type_list ty_e) - | 'o' | 'O' -> conversion j ty_e (Predef.type_option ty_e)*) - | _ -> conversion (j - 1) ty_e ty_e end -(* | 'r' -> - let ty_e = newvar () in - let j = j + 1 in - if j >= len then conversion_r (j - 1) ty_e ty_e else begin - match fmt.[j] with - | 'a' | 'A' -> conversion_r j ty_e (Pref.type_array ty_e) - | 'l' | 'L' -> conversion_r j ty_e (Pref.type_list ty_e) - | 'o' | 'O' -> conversion_r j ty_e (Pref.type_option ty_e) - | _ -> conversion_r (j - 1) ty_e ty_e end *) - | 't' -> conversion j (ty_arrow ty_input ty_aresult) - | 'l' | 'n' | 'L' as c -> - let j = j + 1 in - if j >= len then conversion (j - 1) Predef.type_int else begin - match fmt.[j] with - | 'd' | 'i' | 'o' | 'u' | 'x' | 'X' -> - let ty_arg = - match c with - | 'l' -> Predef.type_int32 - | 'n' -> Predef.type_nativeint - | _ -> Predef.type_int64 in - conversion j ty_arg - | c -> conversion (j - 1) Predef.type_int - end - | '{' | '(' as c -> - let j = j + 1 in - if j >= len then incomplete_format fmt else - let sj = - Printf.CamlinternalPr.Tformat.sub_format - (fun fmt -> incomplete_format (format_to_string fmt)) - (fun fmt -> bad_conversion (format_to_string fmt)) - c (string_to_format fmt) j in - let sfmt = String.sub fmt j (sj - 2 - j) in - let ty_sfmt = type_in_format sfmt in - begin match c with - | '{' -> conversion (sj - 1) ty_sfmt - | _ -> incr meta; conversion (j - 1) ty_sfmt end - | ')' when !meta > 0 -> decr meta; scan_format (j + 1) - | c -> bad_conversion fmt i c in - scan_flags i j in - - let ty_ureader, ty_args = scan_format 0 in - newty - (Tconstr - (Predef.path_format6, - [ ty_args; ty_input; ty_aresult; - ty_ureader; ty_uresult; ty_result; ], - ref Mnil)) in - - type_in_format fmt - (* Approximate the type of an expression, for better recursion *) let rec approx_type env sty = @@ -1826,7 +1681,8 @@ let iter_ppat f p = | Ppat_or (p1,p2) -> f p1; f p2 | Ppat_variant (_, arg) | Ppat_construct (_, arg) -> may f arg | Ppat_tuple lst -> List.iter f lst - | Ppat_alias (p,_) | Ppat_constraint (p,_) | Ppat_lazy p -> f p + | Ppat_exception p | Ppat_alias (p,_) + | Ppat_constraint (p,_) | Ppat_lazy p -> f p | Ppat_record (args, flag) -> List.iter (fun (_,p) -> f p) args let contains_polymorphic_variant p = @@ -1897,9 +1753,9 @@ let unify_exp env exp expected_ty = Printtyp.raw_type_expr expected_ty; *) unify_exp_types exp.exp_loc env exp.exp_type expected_ty -let rec type_exp env sexp = +let rec type_exp ?recarg env sexp = (* We now delegate everything to type_expect *) - type_expect env sexp (newvar ()) + type_expect ?recarg env sexp (newvar ()) (* Typing of an expression with an expected type. This provide better error messages, and allows controlled @@ -1907,15 +1763,17 @@ let rec type_exp env sexp = In the principal case, [type_expected'] may be at generic_level. *) -and type_expect ?in_function env sexp ty_expected = +and type_expect ?in_function ?recarg env sexp ty_expected = let previous_saved_types = Cmt_format.get_saved_types () in - let prev_warnings = Typetexp.warning_attribute sexp.pexp_attributes in - let exp = type_expect_ ?in_function env sexp ty_expected in - begin match prev_warnings with Some x -> Warnings.restore x | None -> () end; - Cmt_format.set_saved_types (Cmt_format.Partial_expression exp :: previous_saved_types); + Typetexp.warning_enter_scope (); + Typetexp.warning_attribute sexp.pexp_attributes; + let exp = type_expect_ ?in_function ?recarg env sexp ty_expected in + Typetexp.warning_leave_scope (); + Cmt_format.set_saved_types + (Cmt_format.Partial_expression exp :: previous_saved_types); exp -and type_expect_ ?in_function env sexp ty_expected = +and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected = let loc = sexp.pexp_loc in (* Record the expression type before unifying it with the expected type *) let rue exp = @@ -1935,6 +1793,11 @@ and type_expect_ ?in_function env sexp ty_expected = let name = Path.name ~paren:Oprint.parenthesized_ident path in Stypes.record (Stypes.An_ident (loc, name, annot)) end; + begin match is_recarg desc, recarg with + | _, Allowed | true, Required | false, Rejected -> () + | true, Rejected | false, Required -> + raise (Error (loc, env, Inlined_record_escape)); + end; rue { exp_desc = begin match desc.val_kind with @@ -1965,19 +1828,32 @@ and type_expect_ ?in_function env sexp ty_expected = exp_attributes = sexp.pexp_attributes; exp_env = env } end - | Pexp_constant(Const_string (s, _) as cst) -> + | Pexp_constant(Const_string (str, _) as cst) -> ( + (* Terrible hack for format strings *) + let ty_exp = expand_head env ty_expected in + let fmt6_path = + Path.(Pdot (Pident (Ident.create_persistent "CamlinternalFormatBasics"), + "format6", 0)) in + let is_format = match ty_exp.desc with + | Tconstr(path, _, _) when Path.same path fmt6_path -> + if !Clflags.principal && ty_exp.level <> generic_level then + Location.prerr_warning loc + (Warnings.Not_principal "this coercion to format6"); + true + | _ -> false + in + if is_format then + let format_parsetree = + { (type_format loc str env) with pexp_loc = sexp.pexp_loc } in + type_expect ?in_function env format_parsetree ty_expected + else rue { exp_desc = Texp_constant cst; exp_loc = loc; exp_extra = []; - exp_type = - (* Terrible hack for format strings *) - begin match (repr (expand_head env ty_expected)).desc with - Tconstr(path, _, _) when Path.same path Predef.path_format6 -> - type_format loc s - | _ -> instance_def Predef.type_string - end; + exp_type = instance_def Predef.type_string; exp_attributes = sexp.pexp_attributes; exp_env = env } + ) | Pexp_constant cst -> rue { exp_desc = Texp_constant cst; @@ -2048,6 +1924,8 @@ and type_expect_ ?in_function env sexp ty_expected = type_function ?in_function loc sexp.pexp_attributes env ty_expected "" caselist | Pexp_apply(sfunct, sargs) -> + if sargs = [] then + Syntaxerr.ill_formed_ast loc "Function application with no argument."; begin_def (); (* one more level for non-returning functions *) if !Clflags.principal then begin_def (); let funct = type_exp env sfunct in @@ -2083,11 +1961,25 @@ and type_expect_ ?in_function env sexp ty_expected = end_def (); if is_nonexpansive arg then generalize arg.exp_type else generalize_expansive env arg.exp_type; - let cases, partial = - type_cases env arg.exp_type ty_expected true loc caselist + let rec split_cases vc ec = function + | [] -> List.rev vc, List.rev ec + | {pc_lhs = {ppat_desc=Ppat_exception p}} as c :: rest -> + split_cases vc ({c with pc_lhs = p} :: ec) rest + | c :: rest -> + split_cases (c :: vc) ec rest in + let val_caselist, exn_caselist = split_cases [] [] caselist in + if val_caselist = [] && exn_caselist <> [] then + raise (Error (loc, env, No_value_clauses)); + (* Note: val_caselist = [] and exn_caselist = [], i.e. a fully + empty pattern matching can be generated by Camlp4 with its + revised syntax. Let's accept it for backward compatibility. *) + let val_cases, partial = + type_cases env arg.exp_type ty_expected true loc val_caselist in + let exn_cases, _ = + type_cases env Predef.type_exn ty_expected false loc exn_caselist in re { - exp_desc = Texp_match(arg, cases, partial); + exp_desc = Texp_match(arg, val_cases, exn_cases, partial); exp_loc = loc; exp_extra = []; exp_type = instance env ty_expected; exp_attributes = sexp.pexp_attributes; @@ -2103,6 +1995,8 @@ and type_expect_ ?in_function env sexp ty_expected = exp_attributes = sexp.pexp_attributes; exp_env = env } | Pexp_tuple sexpl -> + if List.length sexpl < 2 then + Syntaxerr.ill_formed_ast loc "Tuples must have at least 2 components."; let subtypes = List.map (fun _ -> newgenvar ()) sexpl in let to_unify = newgenty (Ttuple subtypes) in unify_exp_types loc env to_unify ty_expected; @@ -2153,12 +2047,14 @@ and type_expect_ ?in_function env sexp ty_expected = exp_env = env } end | Pexp_record(lid_sexp_list, opt_sexp) -> + if lid_sexp_list = [] then + Syntaxerr.ill_formed_ast loc "Records cannot be empty."; let opt_exp = match opt_sexp with None -> None | Some sexp -> if !Clflags.principal then begin_def (); - let exp = type_exp env sexp in + let exp = type_exp ~recarg env sexp in if !Clflags.principal then begin end_def (); generalize_structure exp.exp_type @@ -2820,8 +2716,8 @@ and type_expect_ ?in_function env sexp ty_expected = sexp.pexp_attributes) :: exp.exp_extra; } - | Pexp_extension (s, _arg) -> - raise (Error (s.loc, env, Extension s.txt)) + | Pexp_extension ext -> + raise (Error_forward (Typetexp.error_of_extension ext)) and type_function ?in_function loc attrs env ty_expected l caselist = let (loc_fun, ty_fun) = @@ -2875,7 +2771,7 @@ and type_function ?in_function loc attrs env ty_expected l caselist = and type_label_access env loc srecord lid = if !Clflags.principal then begin_def (); - let record = type_exp env srecord in + let record = type_exp ~recarg:Allowed env srecord in if !Clflags.principal then begin end_def (); generalize_structure record.exp_type @@ -2893,6 +2789,241 @@ and type_label_access env loc srecord lid = (Label.disambiguate lid env opath) labels in (record, label, opath) +(* Typing format strings for printing or reading. + These formats are used by functions in modules Printf, Format, and Scanf. + (Handling of * modifiers contributed by Thorsten Ohl.) *) + +and type_format loc str env = + let loc = {loc with Location.loc_ghost = true} in + try + CamlinternalFormatBasics.(CamlinternalFormat.( + let mk_exp_loc pexp_desc = { + pexp_desc = pexp_desc; + pexp_loc = loc; + pexp_attributes = []; + } and mk_lid_loc lid = { + txt = lid; + loc = loc; + } in + let mk_constr name args = + let lid = Longident.(Ldot(Lident "CamlinternalFormatBasics", name)) in + let arg = match args with + | [] -> None + | [ e ] -> Some e + | _ :: _ :: _ -> Some (mk_exp_loc (Pexp_tuple args)) in + mk_exp_loc (Pexp_construct (mk_lid_loc lid, arg)) in + let mk_cst cst = mk_exp_loc (Pexp_constant cst) in + let mk_int n = mk_cst (Const_int n) + and mk_string str = mk_cst (Const_string (str, None)) + and mk_char chr = mk_cst (Const_char chr) in + let rec mk_formatting_lit fmting = match fmting with + | Close_box -> + mk_constr "Close_box" [] + | Close_tag -> + mk_constr "Close_tag" [] + | Break (org, ns, ni) -> + mk_constr "Break" [ mk_string org; mk_int ns; mk_int ni ] + | FFlush -> + mk_constr "FFlush" [] + | Force_newline -> + mk_constr "Force_newline" [] + | Flush_newline -> + mk_constr "Flush_newline" [] + | Magic_size (org, sz) -> + mk_constr "Magic_size" [ mk_string org; mk_int sz ] + | Escaped_at -> + mk_constr "Escaped_at" [] + | Escaped_percent -> + mk_constr "Escaped_percent" [] + | Scan_indic c -> + mk_constr "Scan_indic" [ mk_char c ] + and mk_formatting_gen : type a b c d e f . + (a, b, c, d, e, f) formatting_gen -> Parsetree.expression = + fun fmting -> match fmting with + | Open_tag (Format (fmt', str')) -> + mk_constr "Open_tag" [ mk_format fmt' str' ] + | Open_box (Format (fmt', str')) -> + mk_constr "Open_box" [ mk_format fmt' str' ] + and mk_format : type a b c d e f . + (a, b, c, d, e, f) CamlinternalFormatBasics.fmt -> string -> + Parsetree.expression = fun fmt str -> + mk_constr "Format" [ mk_fmt fmt; mk_string str ] + and mk_side side = match side with + | Left -> mk_constr "Left" [] + | Right -> mk_constr "Right" [] + | Zeros -> mk_constr "Zeros" [] + and mk_iconv iconv = match iconv with + | Int_d -> mk_constr "Int_d" [] | Int_pd -> mk_constr "Int_pd" [] + | Int_sd -> mk_constr "Int_sd" [] | Int_i -> mk_constr "Int_i" [] + | Int_pi -> mk_constr "Int_pi" [] | Int_si -> mk_constr "Int_si" [] + | Int_x -> mk_constr "Int_x" [] | Int_Cx -> mk_constr "Int_Cx" [] + | Int_X -> mk_constr "Int_X" [] | Int_CX -> mk_constr "Int_CX" [] + | Int_o -> mk_constr "Int_o" [] | Int_Co -> mk_constr "Int_Co" [] + | Int_u -> mk_constr "Int_u" [] + and mk_fconv fconv = match fconv with + | Float_f -> mk_constr "Float_f" [] + | Float_pf -> mk_constr "Float_pf" [] + | Float_sf -> mk_constr "Float_sf" [] + | Float_e -> mk_constr "Float_e" [] + | Float_pe -> mk_constr "Float_pe" [] + | Float_se -> mk_constr "Float_se" [] + | Float_E -> mk_constr "Float_E" [] + | Float_pE -> mk_constr "Float_pE" [] + | Float_sE -> mk_constr "Float_sE" [] + | Float_g -> mk_constr "Float_g" [] + | Float_pg -> mk_constr "Float_pg" [] + | Float_sg -> mk_constr "Float_sg" [] + | Float_G -> mk_constr "Float_G" [] + | Float_pG -> mk_constr "Float_pG" [] + | Float_sG -> mk_constr "Float_sG" [] + | Float_F -> mk_constr "Float_F" [] + and mk_counter cnt = match cnt with + | Line_counter -> mk_constr "Line_counter" [] + | Char_counter -> mk_constr "Char_counter" [] + | Token_counter -> mk_constr "Token_counter" [] + and mk_int_opt n_opt = match n_opt with + | None -> + let lid_loc = mk_lid_loc (Longident.Lident "None") in + mk_exp_loc (Pexp_construct (lid_loc, None)) + | Some n -> + let lid_loc = mk_lid_loc (Longident.Lident "Some") in + mk_exp_loc (Pexp_construct (lid_loc, Some (mk_int n))) + and mk_fmtty : type a b c d e f g h i j k l . + (a, b, c, d, e, f, g, h, i, j, k, l) fmtty_rel -> Parsetree.expression = + fun fmtty -> match fmtty with + | Char_ty rest -> mk_constr "Char_ty" [ mk_fmtty rest ] + | String_ty rest -> mk_constr "String_ty" [ mk_fmtty rest ] + | Int_ty rest -> mk_constr "Int_ty" [ mk_fmtty rest ] + | Int32_ty rest -> mk_constr "Int32_ty" [ mk_fmtty rest ] + | Nativeint_ty rest -> mk_constr "Nativeint_ty" [ mk_fmtty rest ] + | Int64_ty rest -> mk_constr "Int64_ty" [ mk_fmtty rest ] + | Float_ty rest -> mk_constr "Float_ty" [ mk_fmtty rest ] + | Bool_ty rest -> mk_constr "Bool_ty" [ mk_fmtty rest ] + | Alpha_ty rest -> mk_constr "Alpha_ty" [ mk_fmtty rest ] + | Theta_ty rest -> mk_constr "Theta_ty" [ mk_fmtty rest ] + | Reader_ty rest -> mk_constr "Reader_ty" [ mk_fmtty rest ] + | Ignored_reader_ty rest -> + mk_constr "Ignored_reader_ty" [ mk_fmtty rest ] + | Format_arg_ty (sub_fmtty, rest) -> + mk_constr "Format_arg_ty" [ mk_fmtty sub_fmtty; mk_fmtty rest ] + | Format_subst_ty (sub_fmtty1, sub_fmtty2, rest) -> + mk_constr "Format_subst_ty" + [ mk_fmtty sub_fmtty1; mk_fmtty sub_fmtty2; mk_fmtty rest ] + | End_of_fmtty -> mk_constr "End_of_fmtty" [] + and mk_ignored : type a b c d e f . + (a, b, c, d, e, f) ignored -> Parsetree.expression = + fun ign -> match ign with + | Ignored_char -> + mk_constr "Ignored_char" [] + | Ignored_caml_char -> + mk_constr "Ignored_caml_char" [] + | Ignored_string pad_opt -> + mk_constr "Ignored_string" [ mk_int_opt pad_opt ] + | Ignored_caml_string pad_opt -> + mk_constr "Ignored_caml_string" [ mk_int_opt pad_opt ] + | Ignored_int (iconv, pad_opt) -> + mk_constr "Ignored_int" [ mk_iconv iconv; mk_int_opt pad_opt ] + | Ignored_int32 (iconv, pad_opt) -> + mk_constr "Ignored_int32" [ mk_iconv iconv; mk_int_opt pad_opt ] + | Ignored_nativeint (iconv, pad_opt) -> + mk_constr "Ignored_nativeint" [ mk_iconv iconv; mk_int_opt pad_opt ] + | Ignored_int64 (iconv, pad_opt) -> + mk_constr "Ignored_int64" [ mk_iconv iconv; mk_int_opt pad_opt ] + | Ignored_float (pad_opt, prec_opt) -> + mk_constr "Ignored_float" [ mk_int_opt pad_opt; mk_int_opt prec_opt ] + | Ignored_bool -> + mk_constr "Ignored_bool" [] + | Ignored_format_arg (pad_opt, fmtty) -> + mk_constr "Ignored_format_arg" [ mk_int_opt pad_opt; mk_fmtty fmtty ] + | Ignored_format_subst (pad_opt, fmtty) -> + mk_constr "Ignored_format_subst" [ + mk_int_opt pad_opt; mk_fmtty fmtty ] + | Ignored_reader -> + mk_constr "Ignored_reader" [] + | Ignored_scan_char_set (width_opt, char_set) -> + mk_constr "Ignored_scan_char_set" [ + mk_int_opt width_opt; mk_string char_set ] + | Ignored_scan_get_counter counter -> + mk_constr "Ignored_scan_get_counter" [ + mk_counter counter + ] + and mk_padding : type x y . (x, y) padding -> Parsetree.expression = + fun pad -> match pad with + | No_padding -> mk_constr "No_padding" [] + | Lit_padding (s, w) -> mk_constr "Lit_padding" [ mk_side s; mk_int w ] + | Arg_padding s -> mk_constr "Arg_padding" [ mk_side s ] + and mk_precision : type x y . (x, y) precision -> Parsetree.expression = + fun prec -> match prec with + | No_precision -> mk_constr "No_precision" [] + | Lit_precision w -> mk_constr "Lit_precision" [ mk_int w ] + | Arg_precision -> mk_constr "Arg_precision" [] + and mk_fmt : type a b c d e f . + (a, b, c, d, e, f) fmt -> Parsetree.expression = + fun fmt -> match fmt with + | Char rest -> + mk_constr "Char" [ mk_fmt rest ] + | Caml_char rest -> + mk_constr "Caml_char" [ mk_fmt rest ] + | String (pad, rest) -> + mk_constr "String" [ mk_padding pad; mk_fmt rest ] + | Caml_string (pad, rest) -> + mk_constr "Caml_string" [ mk_padding pad; mk_fmt rest ] + | Int (iconv, pad, prec, rest) -> + mk_constr "Int" [ + mk_iconv iconv; mk_padding pad; mk_precision prec; mk_fmt rest ] + | Int32 (iconv, pad, prec, rest) -> + mk_constr "Int32" [ + mk_iconv iconv; mk_padding pad; mk_precision prec; mk_fmt rest ] + | Nativeint (iconv, pad, prec, rest) -> + mk_constr "Nativeint" [ + mk_iconv iconv; mk_padding pad; mk_precision prec; mk_fmt rest ] + | Int64 (iconv, pad, prec, rest) -> + mk_constr "Int64" [ + mk_iconv iconv; mk_padding pad; mk_precision prec; mk_fmt rest ] + | Float (fconv, pad, prec, rest) -> + mk_constr "Float" [ + mk_fconv fconv; mk_padding pad; mk_precision prec; mk_fmt rest ] + | Bool rest -> + mk_constr "Bool" [ mk_fmt rest ] + | Flush rest -> + mk_constr "Flush" [ mk_fmt rest ] + | String_literal (s, rest) -> + mk_constr "String_literal" [ mk_string s; mk_fmt rest ] + | Char_literal (c, rest) -> + mk_constr "Char_literal" [ mk_char c; mk_fmt rest ] + | Format_arg (pad_opt, fmtty, rest) -> + mk_constr "Format_arg" [ + mk_int_opt pad_opt; mk_fmtty fmtty; mk_fmt rest ] + | Format_subst (pad_opt, fmtty, rest) -> + mk_constr "Format_subst" [ + mk_int_opt pad_opt; mk_fmtty fmtty; mk_fmt rest ] + | Alpha rest -> + mk_constr "Alpha" [ mk_fmt rest ] + | Theta rest -> + mk_constr "Theta" [ mk_fmt rest ] + | Formatting_lit (fmting, rest) -> + mk_constr "Formatting_lit" [ mk_formatting_lit fmting; mk_fmt rest ] + | Formatting_gen (fmting, rest) -> + mk_constr "Formatting_gen" [ mk_formatting_gen fmting; mk_fmt rest ] + | Reader rest -> + mk_constr "Reader" [ mk_fmt rest ] + | Scan_char_set (width_opt, char_set, rest) -> + mk_constr "Scan_char_set" [ + mk_int_opt width_opt; mk_string char_set; mk_fmt rest ] + | Scan_get_counter (cnt, rest) -> + mk_constr "Scan_get_counter" [ mk_counter cnt; mk_fmt rest ] + | Ignored_param (ign, rest) -> + mk_constr "Ignored_param" [ mk_ignored ign; mk_fmt rest ] + | End_of_format -> + mk_constr "End_of_format" [] + in + let legacy_behavior = not !Clflags.strict_formats in + let Fmt_EBB fmt = fmt_ebb_of_string ~legacy_behavior str in + mk_constr "Format" [ mk_fmt fmt; mk_string str ] + )) + with Failure msg -> + raise (Error (loc, env, Invalid_format msg)) + and type_label_exp create env loc ty_expected (lid, label, sarg) = (* Here also ty_expected may be at generic_level *) @@ -2945,7 +3076,7 @@ and type_label_exp create env loc ty_expected in (lid, label, {arg with exp_type = instance env arg.exp_type}) -and type_argument env sarg ty_expected' ty_expected = +and type_argument ?recarg env sarg ty_expected' ty_expected = (* ty_expected' may be generic *) let no_labels ty = let ls, tvar = list_labels env ty in @@ -2953,8 +3084,10 @@ and type_argument env sarg ty_expected' ty_expected = in let rec is_inferred sexp = match sexp.pexp_desc with - Pexp_ident _ | Pexp_apply _ | Pexp_send _ | Pexp_field _ -> true - | Pexp_open (_, _, e) -> is_inferred e + Pexp_ident _ | Pexp_apply _ | Pexp_field _ | Pexp_constraint _ + | Pexp_coerce _ | Pexp_send _ | Pexp_new _ -> true + | Pexp_sequence (_, e) | Pexp_open (_, _, e) -> is_inferred e + | Pexp_ifthenelse (_, e1, Some e2) -> is_inferred e1 && is_inferred e2 | _ -> false in match expand_head env ty_expected' with @@ -3022,11 +3155,13 @@ and type_argument env sarg ty_expected' ty_expected = let let_pat, let_var = var_pair "arg" texp.exp_type in re { texp with exp_type = ty_fun; exp_desc = Texp_let (Nonrecursive, - [{vb_pat=let_pat; vb_expr=texp; vb_attributes=[]}], + [{vb_pat=let_pat; vb_expr=texp; vb_attributes=[]; + vb_loc=Location.none; + }], func let_var) } end | _ -> - let texp = type_expect env sarg ty_expected' in + let texp = type_expect ?recarg env sarg ty_expected' in unify_exp env texp ty_expected; texp @@ -3235,7 +3370,9 @@ and type_construct env loc lid sarg ty_expected attrs = let sargs = match sarg with None -> [] - | Some {pexp_desc = Pexp_tuple sel} when constr.cstr_arity > 1 -> sel + | Some {pexp_desc = Pexp_tuple sel} when + constr.cstr_arity > 1 || explicit_arity attrs + -> sel | Some se -> [se] in if List.length sargs <> constr.cstr_arity then raise(Error(loc, env, Constructor_arity_mismatch @@ -3266,7 +3403,21 @@ and type_construct env loc lid sarg ty_expected attrs = in let texp = {texp with exp_type = ty_res} in if not separate then unify_exp env texp (instance env ty_expected); - let args = List.map2 (fun e (t,t0) -> type_argument env e t t0) sargs + let recarg = + match constr.cstr_inlined with + | None -> Rejected + | Some _ -> + begin match sargs with + | [{pexp_desc = + Pexp_ident _ | + Pexp_record (_, (Some {pexp_desc = Pexp_ident _}| None))}] -> + Required + | _ -> + raise (Error(loc, env, Inlined_record_escape)) + end + in + let args = + List.map2 (fun e (t,t0) -> type_argument ~recarg env e t t0) sargs (List.combine ty_args ty_args0) in if constr.cstr_private = Private then raise(Error(loc, env, Private_type ty_res)); @@ -3559,7 +3710,7 @@ and type_let ?(check = fun s -> Warnings.Unused_var s) slot := (name, vd) :: !slot; rec_needed := true | None -> List.iter - (fun (name, vd) -> Env.mark_value_used name vd) + (fun (name, vd) -> Env.mark_value_used env name vd) (get_ref slot); used := true; some_used := true @@ -3612,7 +3763,9 @@ and type_let ?(check = fun s -> Warnings.Unused_var s) let l = List.map2 (fun (p, e) pvb -> - {vb_pat=p; vb_expr=e; vb_attributes=pvb.pvb_attributes}) + {vb_pat=p; vb_expr=e; vb_attributes=pvb.pvb_attributes; + vb_loc=pvb.pvb_loc; + }) l spat_sexp_list in (l, new_env, unpacks) @@ -3711,7 +3864,7 @@ let report_error env ppf = function let print_label ppf = function | "" -> fprintf ppf "without label" | l -> - fprintf ppf "with label %s%s" (if is_optional l then "" else "~") l + fprintf ppf "with label %s" (prefixed_label_name l) in reset_and_mark_loops ty; fprintf ppf @@ -3729,6 +3882,12 @@ let report_error env ppf = function fprintf ppf "The record field %a is not mutable" longident lid | Wrong_name (eorp, ty, kind, p, lid) -> reset_and_mark_loops ty; + if Path.is_constructor_typath p then begin + fprintf ppf "@[The field %a is not part of the record \ + argument for the %a constructor@]" + longident lid + path p; + end else begin fprintf ppf "@[@[<2>%s type@ %a@]@ " eorp type_expr ty; fprintf ppf "The %s %a does not belong to type %a@]" @@ -3736,6 +3895,7 @@ let report_error env ppf = function longident lid (*kind*) path p; if kind = "record" then Label.spellcheck ppf env p lid else Constructor.spellcheck ppf env p lid + end | Name_type_mismatch (kind, lid, tp, tpl) -> let name = if kind = "record" then "field" else "constructor" in report_ambiguous_type_error ppf env tp tpl @@ -3748,12 +3908,8 @@ let report_error env ppf = function (function ppf -> fprintf ppf "but a %s was expected belonging to the %s type" name kind) - | Incomplete_format s -> - fprintf ppf "Premature end of format string ``%S''" s - | Bad_conversion (fmt, i, c) -> - fprintf ppf - "Bad conversion %%%c, at char number %d \ - in format string ``%s''" c i fmt + | Invalid_format msg -> + fprintf ppf "%s" msg | Undefined_method (ty, me) -> reset_and_mark_loops ty; fprintf ppf @@ -3804,7 +3960,8 @@ let report_error env ppf = function | Abstract_wrong_label (l, ty) -> let label_mark = function | "" -> "but its first argument is not labelled" - | l -> sprintf "but its first argument is labelled ~%s" l in + | l -> sprintf "but its first argument is labelled %s" + (prefixed_label_name l) in reset_and_mark_loops ty; fprintf ppf "@[<v>@[<2>This function should have type@ %a@]@,%s@]" type_expr ty (label_mark l) @@ -3861,8 +4018,16 @@ let report_error env ppf = function | Invalid_for_loop_index -> fprintf ppf "@[Invalid for-loop index: only variables and _ are allowed.@]" - | Extension s -> - fprintf ppf "Uninterpreted extension '%s'." s + | No_value_clauses -> + fprintf ppf + "None of the patterns in this 'match' expression match values." + | Exception_pattern_below_toplevel -> + fprintf ppf + "@[Exception patterns must be at the top level of a match case.@]" + | Inlined_record_escape -> + fprintf ppf + "@[This form is not allowed as the type of the inlined record could \ + escape.@]" let report_error env ppf err = wrap_printing_env env (fun () -> report_error env ppf err) @@ -3872,9 +4037,16 @@ let () = (function | Error (loc, env, err) -> Some (Location.error_of_printer loc (report_error env) err) + | Error_forward err -> + Some err | _ -> None ) let () = Env.add_delayed_check_forward := add_delayed_check + +(* drop ?recarg argument from the external API *) +let type_expect ?in_function env e ty = type_expect ?in_function env e ty +let type_exp env e = type_exp env e +let type_argument env e t1 t2 = type_argument env e t1 t2 diff --git a/typing/typecore.mli b/typing/typecore.mli index 8dae2c988..4a450e344 100644 --- a/typing/typecore.mli +++ b/typing/typecore.mli @@ -79,8 +79,7 @@ type error = | Wrong_name of string * type_expr * string * Path.t * Longident.t | Name_type_mismatch of string * Longident.t * (Path.t * Path.t) * (Path.t * Path.t) list - | Incomplete_format of string - | Bad_conversion of string * int * char + | Invalid_format of string | Undefined_method of type_expr * string | Undefined_inherited_method of string | Virtual_class of Longident.t @@ -108,9 +107,12 @@ type error = | Unqualified_gadt_pattern of Path.t * string | Invalid_interval | Invalid_for_loop_index - | Extension of string + | No_value_clauses + | Exception_pattern_below_toplevel + | Inlined_record_escape exception Error of Location.t * Env.t * error +exception Error_forward of Location.error val report_error: Env.t -> formatter -> error -> unit (* Deprecated. Use Location.{error_of_exn, report_error}. *) diff --git a/typing/typedecl.ml b/typing/typedecl.ml index 6bab0c06d..90c432bc5 100644 --- a/typing/typedecl.ml +++ b/typing/typedecl.ml @@ -25,6 +25,7 @@ type error = | Too_many_constructors | Duplicate_label of string | Recursive_abbrev of string + | Cycle_in_def of string * type_expr | Definition_mismatch of type_expr * Includecore.type_mismatch list | Constraint_failed of type_expr * type_expr | Inconsistent_constraint of Env.t * (type_expr * type_expr) list @@ -33,14 +34,17 @@ type error = | Null_arity_external | Missing_native_external | Unbound_type_var of type_expr * type_declaration - | Unbound_exception of Longident.t - | Not_an_exception of Longident.t + | Not_open_type of Path.t + | Not_extensible_type of Path.t + | Extension_mismatch of Path.t * Includecore.type_mismatch list + | Rebind_wrong_type of Longident.t * Env.t * (type_expr * type_expr) list + | Rebind_mismatch of Longident.t * Path.t * Path.t + | Rebind_private of Longident.t | Bad_variance of int * (bool * bool * bool) * (bool * bool * bool) | Unavailable_type_constructor of Path.t | Bad_fixed_type of string - | Unbound_type_var_exc of type_expr * type_expr + | Unbound_type_var_ext of type_expr * extension_constructor | Varying_anonymous - | Exception_constructor_with_result open Typedtree @@ -133,59 +137,90 @@ module StringSet = let compare (x:t) y = compare x y end) -module StringMap = - Map.Make(struct - type t = string - let compare (x:t) y = compare x y - end) - -let make_params sdecl = - try - List.map - (fun (x, _) -> - match x with - | None -> Ctype.new_global_var ~name:"_" () - | Some x -> enter_type_variable x) - sdecl.ptype_params - with Already_bound loc -> - raise(Error(loc, Repeated_parameter)) - -let freevars bound kind = - let open Ast_mapper in - let vars = ref StringMap.empty in - let bound = ref bound in - let super = default_mapper in - let typ m ct = - match ct.ptyp_desc with - | Ptyp_var s -> - if not (StringSet.mem s !bound) then - vars := StringMap.add s ct.ptyp_loc !vars; - ct - | Ptyp_poly (sl, t) -> - let old_bound = !bound in - List.iter (fun s -> bound := StringSet.add s !bound) sl; - ignore (m.typ m t); - bound := old_bound; - ct - | _ -> super.typ m ct +let make_params env params = + let make_param (sty, v) = + try + (transl_type_param env sty, v) + with Already_bound -> + raise(Error(sty.ptyp_loc, Repeated_parameter)) in - let mapper = {super with typ} in - ignore (mapper.type_kind mapper kind); - StringMap.bindings !vars - -let get_args = function - | Pcstr_tuple l -> l - | _ -> assert false + List.map make_param params -let is_inline_record = function - | [ {ptyp_attributes = [{txt="#inline#"}, _]} ] -> true - | _ -> false +let transl_labels loc env closed lbls = + if lbls = [] then + Syntaxerr.ill_formed_ast loc "Records cannot be empty."; + let all_labels = ref StringSet.empty in + List.iter + (fun {pld_name = {txt=name; loc}} -> + if StringSet.mem name !all_labels then + raise(Error(loc, Duplicate_label name)); + all_labels := StringSet.add name !all_labels) + lbls; + let mk {pld_name=name;pld_mutable=mut;pld_type=arg;pld_loc=loc;pld_attributes=attrs} = + let arg = Ast_helper.Typ.force_poly arg in + let cty = transl_simple_type env closed arg in + {ld_id = Ident.create name.txt; ld_name = name; ld_mutable = mut; ld_type = cty; + ld_loc = loc; ld_attributes = attrs} + in + let lbls = List.map mk lbls in + let lbls' = + List.map + (fun ld -> + let ty = ld.ld_type.ctyp_type in + let ty = match ty.desc with Tpoly(t,[]) -> t | _ -> ty in + {Types.ld_id = ld.ld_id; + ld_mutable = ld.ld_mutable; + ld_type = ty; + ld_loc = ld.ld_loc; + ld_attributes = ld.ld_attributes + } + ) + lbls in + lbls, lbls' + +let transl_constructor_arguments loc env closed = function + | Pcstr_tuple l -> + let l = List.map (transl_simple_type env closed) l in + Types.Cstr_tuple (List.map (fun t -> t.ctyp_type) l), + Cstr_tuple l + | Pcstr_record l -> + let lbls, lbls' = transl_labels loc env closed l in + Types.Cstr_record lbls', + Cstr_record lbls + +let make_constructor loc env type_path type_params sargs sret_type = + match sret_type with + | None -> + let args, targs = + transl_constructor_arguments loc env true sargs + in + targs, None, args, None + | Some sret_type -> + (* if it's a generalized constructor we must first narrow and + then widen so as to not introduce any new constraints *) + let z = narrow () in + reset_type_variables (); + let args, targs = + transl_constructor_arguments loc env false sargs + in + let tret_type = transl_simple_type env false sret_type in + let ret_type = tret_type.ctyp_type in + begin + match (Ctype.repr ret_type).desc with + Tconstr (p', _, _) when Path.same type_path p' -> () + | _ -> + raise (Error (sret_type.ptyp_loc, Constraint_failed + (ret_type, Ctype.newconstr type_path type_params))) + end; + widen z; + targs, Some tret_type, args, Some ret_type -let transl_declaration ?exnid env sdecl id = +let transl_declaration env sdecl id = (* Bind type parameters *) reset_type_variables(); Ctype.begin_def (); - let params = make_params sdecl in + let tparams = make_params env sdecl.ptype_params in + let params = List.map (fun (cty, _) -> cty.ctyp_type) tparams in let cstrs = List.map (fun (sty, sty', loc) -> transl_simple_type env false sty, @@ -195,97 +230,55 @@ let transl_declaration ?exnid env sdecl id = let (tkind, kind) = match sdecl.ptype_kind with Ptype_abstract -> Ttype_abstract, Type_abstract - | Ptype_variant cstrs -> + | Ptype_variant scstrs -> + if scstrs = [] then + Syntaxerr.ill_formed_ast sdecl.ptype_loc + "Variant types cannot be empty."; let all_constrs = ref StringSet.empty in List.iter (fun {pcd_name = {txt = name}} -> if StringSet.mem name !all_constrs then raise(Error(sdecl.ptype_loc, Duplicate_constructor name)); all_constrs := StringSet.add name !all_constrs) - cstrs; + scstrs; if List.length - (List.filter (fun cd -> get_args cd.pcd_args <> []) cstrs) + (List.filter (fun cd -> cd.pcd_args <> Pcstr_tuple []) scstrs) > (Config.max_tag + 1) then raise(Error(sdecl.ptype_loc, Too_many_constructors)); - let make_cstr {pcd_name = lid; pcd_args; pcd_res = ret_type; pcd_loc = loc; pcd_attributes = attrs} = - let name = Ident.create lid.txt in - let args = get_args pcd_args in - let inlined = is_inline_record args in - match ret_type with - | None -> - (name, lid, List.map (transl_simple_type env true) args, - None, None, loc, attrs, inlined) - | Some sty -> - (* if it's a generalized constructor we must first narrow and - then widen so as to not introduce any new constraints *) - let z = narrow () in - reset_type_variables (); - let args = List.map (transl_simple_type env false) args in - let cty = transl_simple_type env false sty in - let ret_type = - let ty = cty.ctyp_type in - let p = Path.Pident id in - match (Ctype.repr ty).desc with - Tconstr (p', _, _) when Path.same p p' -> ty - | _ -> - raise (Error (sty.ptyp_loc, Constraint_failed - (ty, Ctype.newconstr p params))) - in - widen z; - (name, lid, args, Some cty, Some ret_type, loc, attrs, inlined) + let make_cstr scstr = + let name = Ident.create scstr.pcd_name.txt in + let targs, tret_type, args, ret_type = + make_constructor scstr.pcd_loc env (Path.Pident id) params + scstr.pcd_args scstr.pcd_res + in + let tcstr = + { cd_id = name; + cd_name = scstr.pcd_name; + cd_args = targs; + cd_res = tret_type; + cd_loc = scstr.pcd_loc; + cd_attributes = scstr.pcd_attributes } + in + let cstr = + { Types.cd_id = name; + cd_args = args; + cd_res = ret_type; + cd_loc = scstr.pcd_loc; + cd_attributes = scstr.pcd_attributes } + in + tcstr, cstr in - let cstrs = List.map make_cstr cstrs in - Ttype_variant (List.map (fun (name, lid, ctys, res, _, loc, attrs, _) -> - {cd_id = name; cd_name = lid; cd_args = ctys; cd_res = res; - cd_loc = loc; cd_attributes = attrs} - ) cstrs), - Type_variant (List.map (fun (name, name_loc, ctys, _, option, loc, attrs, inlined) -> - {Types.cd_id = name; cd_args = List.map (fun cty -> cty.ctyp_type) ctys; - cd_res = option; - cd_loc = loc; cd_attributes = attrs; - cd_inlined = inlined; - } - ) cstrs) - + let tcstrs, cstrs = List.split (List.map make_cstr scstrs) in + Ttype_variant tcstrs, Type_variant cstrs | Ptype_record lbls -> - let all_labels = ref StringSet.empty in - List.iter - (fun {pld_name = {txt=name}} -> - if StringSet.mem name !all_labels then - raise(Error(sdecl.ptype_loc, Duplicate_label name)); - all_labels := StringSet.add name !all_labels) - lbls; - let lbls = List.map (fun {pld_name=name;pld_mutable=mut;pld_type=arg;pld_loc=loc;pld_attributes=attrs} -> - let arg = Ast_helper.Typ.force_poly arg in - let cty = transl_simple_type env true arg in - {ld_id = Ident.create name.txt; ld_name = name; ld_mutable = mut; ld_type = cty; - ld_loc = loc; ld_attributes = attrs} - ) lbls in - let lbls' = - List.map - (fun ld -> - let ty = ld.ld_type.ctyp_type in - let ty = match ty.desc with Tpoly(t,[]) -> t | _ -> ty in - {Types.ld_id = ld.ld_id; - ld_mutable = ld.ld_mutable; - ld_type = ty; - ld_loc = ld.ld_loc; - ld_attributes = ld.ld_attributes - } - ) - lbls in - let rep = - match sdecl.ptype_attributes with - | [{txt="#tag#"}, PStr [{pstr_desc=Pstr_eval({pexp_desc=Pexp_constant(Const_int tag)}, _)}]] -> - begin match exnid with - | Some id -> Record_exception (Path.Pident id) - | None -> Record_inlined tag - end - | _ -> - if List.for_all (fun l -> is_float env l.Types.ld_type) lbls' - then Record_float - else Record_regular in - Ttype_record lbls, Type_record(lbls', rep) + let lbls, lbls' = transl_labels sdecl.ptype_loc env true lbls in + let rep = + if List.for_all (fun l -> is_float env l.Types.ld_type) lbls' + then Record_float + else Record_regular + in + Ttype_record lbls, Type_record(lbls', rep) + | Ptype_open -> Ttype_open, Type_open in let (tman, man) = match sdecl.ptype_manifest with None -> None, None @@ -331,7 +324,7 @@ let transl_declaration ?exnid env sdecl id = { typ_id = id; typ_name = sdecl.ptype_name; - typ_params = sdecl.ptype_params; + typ_params = tparams; typ_type = decl; typ_cstrs = cstrs; typ_loc = sdecl.ptype_loc; @@ -345,18 +338,7 @@ let transl_declaration ?exnid env sdecl id = let generalize_decl decl = List.iter Ctype.generalize decl.type_params; - begin match decl.type_kind with - Type_abstract -> - () - | Type_variant v -> - List.iter - (fun c -> - List.iter Ctype.generalize c.Types.cd_args; - may Ctype.generalize c.Types.cd_res) - v - | Type_record(r, rep) -> - List.iter (fun l -> Ctype.generalize l.Types.ld_type) r - end; + Btype.iter_type_expr_kind Ctype.generalize decl.type_kind; begin match decl.type_manifest with | None -> () | Some ty -> Ctype.generalize ty @@ -365,6 +347,7 @@ let generalize_decl decl = (* Check that all constraints are enforced *) module TypeSet = Btype.TypeSet +module TypeMap = Btype.TypeMap let rec check_constraints_rec env loc visited ty = let ty = Ctype.repr ty in @@ -390,6 +373,18 @@ let rec check_constraints_rec env loc visited ty = module SMap = Map.Make(String) +let check_constraints_labels env visited l pl = + let rec get_loc name = function + [] -> assert false + | pld :: tl -> + if name = pld.pld_name.txt then pld.pld_type.ptyp_loc + else get_loc name tl + in + List.iter + (fun {Types.ld_id=name; ld_type=ty} -> + check_constraints_rec env (get_loc (Ident.name name) pl) visited ty) + l + let check_constraints env sdecl (_, decl) = let visited = ref TypeSet.empty in begin match decl.type_kind with @@ -397,7 +392,7 @@ let check_constraints env sdecl (_, decl) = | Type_variant l -> let find_pl = function Ptype_variant pl -> pl - | Ptype_record _ | Ptype_abstract -> assert false + | Ptype_record _ | Ptype_abstract | Ptype_open -> assert false in let pl = find_pl sdecl.ptype_kind in let pl_index = @@ -407,15 +402,21 @@ let check_constraints env sdecl (_, decl) = List.fold_left foldf SMap.empty pl in List.iter - (fun {Types.cd_id=name; cd_args=tyl; cd_res=ret_type} -> - let {pcd_args; pcd_res = sret_type; _} = + (fun {Types.cd_id=name; cd_args; cd_res} -> + let {pcd_args; pcd_res; _} = try SMap.find (Ident.name name) pl_index with Not_found -> assert false in - List.iter2 - (fun sty ty -> - check_constraints_rec env sty.ptyp_loc visited ty) - (get_args pcd_args) tyl; - match sret_type, ret_type with + begin match cd_args, pcd_args with + | Cstr_tuple tyl, Pcstr_tuple styl -> + List.iter2 + (fun sty ty -> + check_constraints_rec env sty.ptyp_loc visited ty) + styl tyl + | Cstr_record tyl, Pcstr_record styl -> + check_constraints_labels env visited tyl styl + | _ -> assert false + end; + match pcd_res, cd_res with | Some sr, Some r -> check_constraints_rec env sr.ptyp_loc visited r | _ -> @@ -424,18 +425,11 @@ let check_constraints env sdecl (_, decl) = | Type_record (l, _) -> let find_pl = function Ptype_record pl -> pl - | Ptype_variant _ | Ptype_abstract -> assert false + | Ptype_variant _ | Ptype_abstract | Ptype_open -> assert false in let pl = find_pl sdecl.ptype_kind in - let rec get_loc name = function - [] -> assert false - | pld :: tl -> - if name = pld.pld_name.txt then pld.pld_type.ptyp_loc else get_loc name tl - in - List.iter - (fun {Types.ld_id=name; ld_type=ty} -> - check_constraints_rec env (get_loc (Ident.name name) pl) visited ty) - l + check_constraints_labels env visited l pl + | Type_open -> () end; begin match decl.type_manifest with | None -> () @@ -453,7 +447,8 @@ let check_constraints env sdecl (_, decl) = *) let check_coherence env loc id decl = match decl with - {type_kind = (Type_variant _ | Type_record _); type_manifest = Some ty} -> + { type_kind = (Type_variant _ | Type_record _| Type_open); + type_manifest = Some ty } -> begin match (Ctype.repr ty).desc with Tconstr(path, args, _) -> begin try @@ -485,14 +480,61 @@ let check_abbrev env sdecl (id, decl) = (* Check that recursion is well-founded *) -let check_well_founded env loc path decl = - Misc.may - (fun body -> - try Ctype.correct_abbrev env path decl.type_params body with - | Ctype.Recursive_abbrev -> - raise(Error(loc, Recursive_abbrev (Path.name path))) - | Ctype.Unify trace -> raise(Error(loc, Type_clash (env, trace)))) - decl.type_manifest +let check_well_founded env loc path to_check ty = + let visited = ref TypeMap.empty in + let rec check ty0 exp_nodes ty = + let ty = Btype.repr ty in + if TypeSet.mem ty exp_nodes then begin + (*Format.eprintf "@[%a@]@." Printtyp.raw_type_expr ty;*) + if match ty0.desc with + | Tconstr (p, _, _) -> Path.same p path + | _ -> false + then raise (Error (loc, Recursive_abbrev (Path.name path))) + else raise (Error (loc, Cycle_in_def (Path.name path, ty0))) + end; + let (fini, exp_nodes) = + try + let prev = TypeMap.find ty !visited in + if TypeSet.subset exp_nodes prev then (true, exp_nodes) else + (false, TypeSet.union exp_nodes prev) + with Not_found -> + (false, exp_nodes) + in + let snap = Btype.snapshot () in + if fini then () else try + visited := TypeMap.add ty exp_nodes !visited; + match ty.desc with + | Tconstr(p, args, _) + when not (TypeSet.is_empty exp_nodes) || to_check p -> + let ty' = Ctype.try_expand_once_opt env ty in + let ty0 = if TypeSet.is_empty exp_nodes then ty else ty0 in + check ty0 (TypeSet.add ty exp_nodes) ty' + | _ -> raise Ctype.Cannot_expand + with + | Ctype.Cannot_expand -> + let nodes = + if !Clflags.recursive_types && Ctype.is_contractive env ty + || match ty.desc with Tobject _ | Tvariant _ -> true | _ -> false + then TypeSet.empty + else exp_nodes in + Btype.iter_type_expr (check ty0 nodes) ty + | Ctype.Unify _ -> + (* Will be detected by check_recursion *) + Btype.backtrack snap + in + check ty TypeSet.empty ty + +let check_well_founded_manifest env loc path decl = + if decl.type_manifest = None then () else + let args = List.map (fun _ -> Ctype.newvar()) decl.type_params in + check_well_founded env loc path (Path.same path) (Ctype.newconstr path args) + +let check_well_founded_decl env loc path decl to_check = + let open Btype in + let it = + {type_iterators with + it_type_expr = (fun _ -> check_well_founded env loc path to_check)} in + it.it_type_declaration it (Ctype.instance_declaration decl) (* Check for ill-defined abbrevs *) @@ -552,16 +594,13 @@ let check_recursion env loc path decl to_check = check_regular path args [] body) decl.type_manifest -let check_abbrev_recursion env id_loc_list tdecl = +let check_abbrev_recursion env id_loc_list to_check tdecl = let decl = tdecl.typ_type in let id = tdecl.typ_id in - check_recursion env (List.assoc id id_loc_list) (Path.Pident id) decl - (function Path.Pident id -> List.mem_assoc id id_loc_list | _ -> false) + check_recursion env (List.assoc id id_loc_list) (Path.Pident id) decl to_check (* Compute variance *) -module TypeMap = Btype.TypeMap - let get_variance ty visited = try TypeMap.find ty !visited with Not_found -> Variance.null @@ -650,21 +689,10 @@ let compute_variance env visited vari ty = in compute_variance_rec vari ty -let make_variance ty = (ty, ref Variance.null) - let make p n i = let open Variance in set May_pos p (set May_neg n (set May_weak n (set Inj i null))) -let flags (v, i) = - let (c, n) = - match v with - | Covariant -> (true, false) - | Contravariant -> (false, true) - | Invariant -> (true, true) - in - (c, n, i) - let compute_variance_type env check (required, loc) decl tyl = (* Requirements *) let required = @@ -755,20 +783,27 @@ let add_false = List.map (fun ty -> false, ty) (* A parameter is constrained if either is is instantiated, or it is a variable appearing in another parameter *) -let constrained env vars ty = +let constrained vars ty = match ty.desc with | Tvar _ -> List.exists (fun tl -> List.memq ty tl) vars | _ -> true +let for_constr = function + | Types.Cstr_tuple l -> add_false l + | Types.Cstr_record l -> + List.map + (fun {Types.ld_mutable; ld_type} -> (ld_mutable = Mutable, ld_type)) + l + let compute_variance_gadt env check (required, loc as rloc) decl (tl, ret_type_opt) = match ret_type_opt with | None -> compute_variance_type env check rloc {decl with type_private = Private} - (add_false tl) + (for_constr tl) | Some ret_type -> match Ctype.repr ret_type with - | {desc=Tconstr (path, tyl, _)} -> + | {desc=Tconstr (_, tyl, _)} -> (* let tyl = List.map (Ctype.expand_head env) tyl in *) let tyl = List.map Ctype.repr tyl in let fvl = List.map (Ctype.free_variables ?env:None) tyl in @@ -778,21 +813,27 @@ let compute_variance_gadt env check (required, loc as rloc) decl match fv2 with [] -> assert false | fv :: fv2 -> (* fv1 @ fv2 = free_variables of other parameters *) - if (c||n) && constrained env (fv1 @ fv2) ty then + if (c||n) && constrained (fv1 @ fv2) ty then raise (Error(loc, Varying_anonymous)); (fv :: fv1, fv2)) ([], fvl) tyl required in compute_variance_type env check rloc {decl with type_params = tyl; type_private = Private} - (add_false tl) + (for_constr tl) | _ -> assert false -let compute_variance_decl env check decl (required, loc as rloc) = - if decl.type_kind = Type_abstract && decl.type_manifest = None then +let compute_variance_extension env check decl ext rloc = + compute_variance_gadt env check rloc + {decl with type_params = ext.ext_type_params} + (ext.ext_args, ext.ext_ret_type) + +let compute_variance_decl env check decl (required, _ as rloc) = + if (decl.type_kind = Type_abstract || decl.type_kind = Type_open) + && decl.type_manifest = None then List.map (fun (c, n, i) -> - make (not n) (not c) (i (*|| decl.type_transparence = Type_new*))) + make (not n) (not c) (decl.type_kind <> Type_abstract || i)) required else let mn = @@ -801,16 +842,18 @@ let compute_variance_decl env check decl (required, loc as rloc) = | Some ty -> [false, ty] in match decl.type_kind with - Type_abstract -> + Type_abstract | Type_open -> compute_variance_type env check rloc decl mn | Type_variant tll -> if List.for_all (fun c -> c.Types.cd_res = None) tll then compute_variance_type env check rloc decl - (mn @ add_false (List.flatten (List.map (fun c -> c.Types.cd_args) tll))) + (mn @ List.flatten (List.map (fun c -> for_constr c.Types.cd_args) + tll)) else begin let mn = - List.map (fun (_,ty) -> ([ty],None)) mn in - let tll = mn @ List.map (fun c -> c.Types.cd_args, c.Types.cd_res) tll in + List.map (fun (_,ty) -> (Types.Cstr_tuple [ty],None)) mn in + let tll = + mn @ List.map (fun c -> c.Types.cd_args, c.Types.cd_res) tll in match List.map (compute_variance_gadt env check rloc decl) tll with | vari :: rem -> let varl = List.fold_left (List.map2 Variance.union) vari rem in @@ -907,8 +950,10 @@ let check_duplicates sdecl_list = let name' = Hashtbl.find constrs pcd.pcd_name.txt in Location.prerr_warning pcd.pcd_loc (Warnings.Duplicate_definitions - ("constructor", pcd.pcd_name.txt, name', sdecl.ptype_name.txt)) - with Not_found -> Hashtbl.add constrs pcd.pcd_name.txt sdecl.ptype_name.txt) + ("constructor", pcd.pcd_name.txt, name', + sdecl.ptype_name.txt)) + with Not_found -> + Hashtbl.add constrs pcd.pcd_name.txt sdecl.ptype_name.txt) cl | Ptype_record fl -> List.iter @@ -920,7 +965,8 @@ let check_duplicates sdecl_list = ("label", cname.txt, name', sdecl.ptype_name.txt)) with Not_found -> Hashtbl.add labels cname.txt sdecl.ptype_name.txt) fl - | Ptype_abstract -> ()) + | Ptype_abstract -> () + | Ptype_open -> ()) sdecl_list (* Force recursion to go through id for private types*) @@ -938,95 +984,20 @@ let name_recursion sdecl id decl = else decl | _ -> decl -(* Add fake record declarations for record constructor arguments *) -let inline_record_decls params manifest tag typname pcd = - let open Ast_helper in - match pcd.pcd_args with - | Pcstr_record lbls -> - let ptype_kind = Ptype_record lbls in - let bound = - List.fold_left (fun acc -> function - | Some {txt}, _ -> StringSet.add txt acc - | _ -> acc) StringSet.empty params - in - let extra_params = freevars bound ptype_kind in - let prepare_param (s, loc) = Some (mkloc s loc), Invariant in - let params = params @ List.map prepare_param extra_params in - let mk_arg = function - | (Some {txt;loc}, _) -> Typ.var ~loc txt - | (None, _) -> Typ.any () - in - let args = List.map mk_arg params in - let name = typname ^ "." ^ pcd.pcd_name.txt in - let ptype_attributes = - [ - mknoloc "#tag#", - PStr [ Str.eval (Exp.constant (Const_int !tag)) ] - ] - in - let ptype_manifest = - match manifest with - | Some {ptyp_desc=Ptyp_constr(lid, _args)} -> - (* does not make sense with 'as' clause *) - let rec append lid = - let open Longident in - match lid with - | Lident s -> Lident (s ^ "." ^ pcd.pcd_name.txt) - | Ldot (p, s) -> Ldot (p, s ^ "." ^ pcd.pcd_name.txt) - | Lapply (p1, p2) -> Lapply (p1, append p2) - in - Some (Typ.constr (mknoloc (append lid.txt)) args) (* todo: type parameters *) - | _ -> None - in - let decl = - { - ptype_name = mkloc name pcd.pcd_name.loc; - ptype_params = params; - ptype_cstrs = []; - ptype_kind; - ptype_private = Public; - ptype_manifest; - ptype_attributes; - ptype_loc = pcd.pcd_loc; - } in - incr tag; - let lid = mknoloc (Longident.Lident name) in - let attrs = [ mknoloc "#inline#", PStr [] ] in - let pcd_args = Pcstr_tuple [Typ.constr ~attrs lid args] in - {pcd with pcd_args}, [decl] - | Pcstr_tuple [] -> pcd, [] - | Pcstr_tuple _ -> incr tag; pcd, [] - (* Translate a set of mutually recursive type declarations *) -let transl_type_decl ?exnid env sdecl_list = +let transl_type_decl env sdecl_list = (* Add dummy types for fixed rows *) let fixed_types = List.filter is_fixed_type sdecl_list in let sdecl_list = List.map (fun sdecl -> - let ptype_name = mkloc (sdecl.ptype_name.txt ^"#row") sdecl.ptype_name.loc in - {sdecl with ptype_name; ptype_kind = Ptype_abstract; ptype_manifest = None}) + let ptype_name = + mkloc (sdecl.ptype_name.txt ^"#row") sdecl.ptype_name.loc in + {sdecl with + ptype_name; ptype_kind = Ptype_abstract; ptype_manifest = None}) fixed_types @ sdecl_list in - let sdecl_list = - List.map - (function - | {ptype_kind = Ptype_variant cstrs} as sdecl -> - let tname = sdecl.ptype_name.txt in - let tag = ref 0 in - let do_cstr = - inline_record_decls sdecl.ptype_params sdecl.ptype_manifest - tag tname - in - let decls = List.map do_cstr cstrs in - let cstrs, more = List.split decls in - {sdecl with ptype_kind=Ptype_variant cstrs} :: List.flatten more - | x -> [ x ] - ) - sdecl_list - in - let sdecl_list = List.flatten sdecl_list in (* Create identifiers. *) let id_list = @@ -1059,14 +1030,14 @@ let transl_type_decl ?exnid env sdecl_list = match !current_slot with | Some slot -> slot := (name, td) :: !slot | None -> - List.iter (fun (name, d) -> Env.mark_type_used name d) + List.iter (fun (name, d) -> Env.mark_type_used env name d) (get_ref slot); old_callback () ); id, Some slot in let transl_declaration name_sdecl (id, slot) = - current_slot := slot; transl_declaration ?exnid temp_env name_sdecl id in + current_slot := slot; transl_declaration temp_env name_sdecl id in let tdecls = List.map2 transl_declaration sdecl_list (List.map id_slots id_list) in let decls = @@ -1093,9 +1064,16 @@ let transl_type_decl ?exnid env sdecl_list = id_list sdecl_list in List.iter (fun (id, decl) -> - check_well_founded newenv (List.assoc id id_loc_list) (Path.Pident id) decl) + check_well_founded_manifest newenv (List.assoc id id_loc_list) + (Path.Pident id) decl) + decls; + let to_check = + function Path.Pident id -> List.mem_assoc id id_loc_list | _ -> false in + List.iter (fun (id, decl) -> + check_well_founded_decl newenv (List.assoc id id_loc_list) (Path.Pident id) + decl to_check) decls; - List.iter (check_abbrev_recursion newenv id_loc_list) tdecls; + List.iter (check_abbrev_recursion newenv id_loc_list to_check) tdecls; (* Check that all type variable are closed *) List.iter2 (fun sdecl tdecl -> @@ -1135,97 +1113,232 @@ let transl_type_decl ?exnid env sdecl_list = (* Done *) (final_decls, final_env) -(* Translate an exception declaration *) -let transl_closed_type env sty = - let cty = transl_simple_type env true sty in - let ty = cty.ctyp_type in - let ty = - match Ctype.free_variables ty with - | [] -> ty - | tv :: _ -> raise (Error (sty.ptyp_loc, Unbound_type_var_exc (tv, ty))) - in - { cty with ctyp_type = ty } - -let transl_exception env excdecl = - let loc = excdecl.pcd_loc in - let id = Ident.create excdecl.pcd_name.txt in - if excdecl.pcd_res <> None then - raise (Error (loc, Exception_constructor_with_result)); - let excdecl, inlined_records = - inline_record_decls [] None (ref 0) "exn" excdecl +(* Translating type extensions *) + +let transl_extension_constructor env type_path type_params + typext_params priv sext = + let id = Ident.create sext.pext_name.txt in + let args, ret_type, kind = + match sext.pext_kind with + Pext_decl(sargs, sret_type) -> + let targs, tret_type, args, ret_type = + make_constructor sext.pext_loc env type_path typext_params + sargs sret_type + in + args, ret_type, Text_decl(targs, tret_type) + | Pext_rebind lid -> + let cdescr = Typetexp.find_constructor env sext.pext_loc lid.txt in + let usage = + if cdescr.cstr_private = Private || priv = Public + then Env.Positive else Env.Privatize + in + Env.mark_constructor usage env (Longident.last lid.txt) cdescr; + let (args, cstr_res) = Ctype.instance_constructor cdescr in + let res, ret_type = + if cdescr.cstr_generalized then + let params = Ctype.instance_list env type_params in + let res = Ctype.newconstr type_path params in + let ret_type = Some (Ctype.newconstr type_path params) in + res, ret_type + else (Ctype.newconstr type_path typext_params), None + in + begin + try + Ctype.unify env cstr_res res + with Ctype.Unify trace -> + raise (Error(lid.loc, + Rebind_wrong_type(lid.txt, env, trace))) + end; + (* Remove "_" names from parameters used in the constructor *) + if not cdescr.cstr_generalized then begin + let vars = + Ctype.free_variables (Btype.newgenty (Ttuple args)) + in + List.iter + (function {desc = Tvar (Some "_")} as ty -> + if List.memq ty vars then ty.desc <- Tvar None + | _ -> ()) + typext_params + end; + (* Ensure that constructor's type matches the type being extended *) + let cstr_type_path, cstr_type_params = + match cdescr.cstr_res.desc with + Tconstr (p, _, _) -> + let decl = Env.find_type p env in + p, decl.type_params + | _ -> assert false + in + let cstr_types = + (Btype.newgenty + (Tconstr(cstr_type_path, cstr_type_params, ref Mnil))) + :: cstr_type_params + in + let ext_types = + (Btype.newgenty + (Tconstr(type_path, type_params, ref Mnil))) + :: type_params + in + if not (Ctype.equal env true cstr_types ext_types) then + raise (Error(lid.loc, + Rebind_mismatch(lid.txt, cstr_type_path, type_path))); + (* Disallow rebinding private constructors to non-private *) + begin + match cdescr.cstr_private, priv with + Private, Public -> + raise (Error(lid.loc, Rebind_private lid.txt)) + | _ -> () + end; + let path = + match cdescr.cstr_tag with + Cstr_extension(path, _) -> path + | _ -> assert false + in + let args = + match cdescr.cstr_inlined with + | None -> + Types.Cstr_tuple args + | Some decl -> + let tl = + match args with + | [ {desc=Tconstr(_, tl, _)} ] -> tl + | _ -> assert false + in + let decl = Ctype.instance_declaration decl in + assert (List.length decl.type_params = List.length tl); + List.iter2 (Ctype.unify env) decl.type_params tl; + let lbls = + match decl.type_kind with + | Type_record (lbls, Record_extension) -> lbls + | _ -> assert false + in + Types.Cstr_record lbls + in + args, ret_type, Text_rebind(path, lid) in - let (_, env) as tdecls = - match inlined_records with - | [] -> ([], env) - | decls -> transl_type_decl ~exnid:id env decls + let ext = + { ext_type_path = type_path; + ext_type_params = typext_params; + ext_args = args; + ext_ret_type = ret_type; + ext_private = priv; + Types.ext_loc = sext.pext_loc; + Types.ext_attributes = sext.pext_attributes; } in + { ext_id = id; + ext_name = sext.pext_name; + ext_type = ext; + ext_kind = kind; + Typedtree.ext_loc = sext.pext_loc; + Typedtree.ext_attributes = sext.pext_attributes; } + +let transl_type_extension check_open env loc styext = reset_type_variables(); Ctype.begin_def(); - let args = get_args excdecl.pcd_args in - let ttypes = List.map (transl_closed_type env) args in - Ctype.end_def(); - let types = List.map (fun cty -> cty.ctyp_type) ttypes in - List.iter Ctype.generalize types; - let exn_decl = - { - exn_args = types; - exn_attributes = excdecl.pcd_attributes; - exn_inlined = is_inline_record args; - Types.exn_loc = loc; - } + let (type_path, type_decl) = + Typetexp.find_type env loc styext.ptyext_path.txt in - let newenv = Env.add_exception ~check:true id exn_decl env in - let cd = - { cd_id = id; - cd_name = excdecl.pcd_name; - cd_args = ttypes; - cd_loc = loc; - cd_res = None; - cd_attributes = excdecl.pcd_attributes; - } - in - tdecls, cd, exn_decl, newenv - -let transl_type_decl = transl_type_decl ?exnid:None - -(* Translate an exception rebinding *) -let transl_exn_rebind env loc name lid = - let cdescr = - try - Env.lookup_constructor lid env - with Not_found -> - raise(Error(loc, Unbound_exception lid)) in - Env.mark_constructor Env.Positive env (Longident.last lid) cdescr; - let path = - match cdescr.cstr_tag with - | Cstr_exception (path, _) -> path - | _ -> raise(Error(loc, Not_an_exception lid)) + begin + match type_decl.type_kind with + Type_open -> () + | Type_abstract -> + if check_open then begin + try + let {pext_loc} = + List.find (function {pext_kind = Pext_decl _} -> true + | {pext_kind = Pext_rebind _} -> false) + styext.ptyext_constructors + in + raise (Error(pext_loc, Not_open_type type_path)) + with Not_found -> () + end + | _ -> raise (Error(loc, Not_extensible_type type_path)) + end; + let type_variance = + List.map (fun v -> + let (co, cn) = Variance.get_upper v in + (not cn, not co, false)) + type_decl.type_variance in - let tdecls, exn_args = - if cdescr.cstr_inlined then - match cdescr.cstr_args with - | [{desc=Tconstr(p, [], _)} as ty] -> - let tdecl = - try Env.find_type p env - with Not_found -> assert false - in - let tdecl = {tdecl with type_manifest = Some ty} in - let (id, env) = - Env.enter_type ("exn." ^ name) tdecl env - in - ([id, tdecl], env), [ Ctype.newconstr (Path.Pident id) [] ] - | _ -> assert false + let err = + if type_decl.type_arity <> List.length styext.ptyext_params then + [Includecore.Arity] else - ([], env), cdescr.cstr_args + if List.for_all2 + (fun (c1, n1, _) (c2, n2, _) -> (not c2 || c1) && (not n2 || n1)) + type_variance + (add_injectivity (List.map snd styext.ptyext_params)) + then [] else [Includecore.Variance] in - let d = { - Types.exn_args; - exn_attributes = []; - exn_inlined = cdescr.cstr_inlined; - exn_loc = loc - } + if err <> [] then + raise (Error(loc, Extension_mismatch (type_path, err))); + let ttype_params = make_params env styext.ptyext_params in + let type_params = List.map (fun (cty, _) -> cty.ctyp_type) ttype_params in + List.iter2 (Ctype.unify_var env) + (Ctype.instance_list env type_decl.type_params) + type_params; + let constructors = + List.map (transl_extension_constructor env type_path + type_decl.type_params type_params styext.ptyext_private) + styext.ptyext_constructors + in + Ctype.end_def(); + (* Generalize types *) + List.iter Ctype.generalize type_params; + List.iter + (fun ext -> + Btype.iter_type_expr_cstr_args Ctype.generalize ext.ext_type.ext_args; + may Ctype.generalize ext.ext_type.ext_ret_type) + constructors; + (* Check that all type variable are closed *) + List.iter + (fun ext -> + match Ctype.closed_extension_constructor ext.ext_type with + Some ty -> + raise(Error(ext.ext_loc, Unbound_type_var_ext(ty, ext.ext_type))) + | None -> ()) + constructors; + (* Check variances are correct *) + List.iter + (fun ext-> + ignore (compute_variance_extension env true type_decl + ext.ext_type (type_variance, loc))) + constructors; + (* Add extension constructors to the environment *) + let newenv = + List.fold_left + (fun env ext -> + Env.add_extension ~check:true ext.ext_id ext.ext_type env) + env constructors + in + let tyext = + { tyext_path = type_path; + tyext_txt = styext.ptyext_path; + tyext_params = ttype_params; + tyext_constructors = constructors; + tyext_private = styext.ptyext_private; + tyext_attributes = styext.ptyext_attributes; } + in + (tyext, newenv) + +let transl_exception env sext = + reset_type_variables(); + Ctype.begin_def(); + let ext = + transl_extension_constructor env + Predef.path_exn [] [] Asttypes.Public sext in - (tdecls, path, d) + Ctype.end_def(); + (* Generalize types *) + Btype.iter_type_expr_cstr_args Ctype.generalize ext.ext_type.ext_args; + may Ctype.generalize ext.ext_type.ext_ret_type; + (* Check that all type variable are closed *) + begin match Ctype.closed_extension_constructor ext.ext_type with + Some ty -> + raise (Error(ext.ext_loc, Unbound_type_var_ext(ty, ext.ext_type))) + | None -> () + end; + let newenv = Env.add_extension ~check:true ext.ext_id ext.ext_type env in + ext, newenv (* Translate a value declaration *) let transl_value_decl env loc valdecl = @@ -1238,9 +1351,9 @@ let transl_value_decl env loc valdecl = val_attributes = valdecl.pval_attributes } | decl -> let arity = Ctype.arity ty in - if arity = 0 then - raise(Error(valdecl.pval_type.ptyp_loc, Null_arity_external)); let prim = Primitive.parse_declaration arity decl in + if arity = 0 && prim.prim_name.[0] <> '%' then + raise(Error(valdecl.pval_type.ptyp_loc, Null_arity_external)); if !Clflags.native_code && prim.prim_arity > 5 && prim.prim_native_name = "" @@ -1267,10 +1380,11 @@ let transl_value_decl env loc valdecl = (* Translate a "with" constraint -- much simplified version of transl_type_decl. *) let transl_with_constraint env id row_path orig_decl sdecl = - Env.mark_type_used (Ident.name id) orig_decl; + Env.mark_type_used env (Ident.name id) orig_decl; reset_type_variables(); Ctype.begin_def(); - let params = make_params sdecl in + let tparams = make_params env sdecl.ptype_params in + let params = List.map (fun (cty, _) -> cty.ctyp_type) tparams in let orig_decl = Ctype.instance_declaration orig_decl in let arity_ok = List.length params = orig_decl.type_arity in if arity_ok then @@ -1333,7 +1447,7 @@ let transl_with_constraint env id row_path orig_decl sdecl = { typ_id = id; typ_name = sdecl.ptype_name; - typ_params = sdecl.ptype_params; + typ_params = tparams; typ_type = decl; typ_cstrs = constraints; typ_loc = sdecl.ptype_loc; @@ -1377,26 +1491,31 @@ let approx_type_decl env sdecl_list = let check_recmod_typedecl env loc recmod_ids path decl = (* recmod_ids is the list of recursively-defined module idents. (path, decl) is the type declaration to be checked. *) - check_well_founded env loc path decl; - check_recursion env loc path decl - (fun path -> List.exists (fun id -> Path.isfree id path) recmod_ids) + let to_check path = + List.exists (fun id -> Path.isfree id path) recmod_ids in + check_well_founded_decl env loc path decl to_check; + check_recursion env loc path decl to_check (**** Error report ****) open Format -let explain_unbound ppf tv tl typ kwd lab = +let explain_unbound_gen ppf tv tl typ kwd pr = try let ti = List.find (fun ti -> Ctype.deep_occur tv (typ ti)) tl in let ty0 = (* Hack to force aliasing when needed *) Btype.newgenty (Tobject(tv, ref None)) in Printtyp.reset_and_mark_loops_list [typ ti; ty0]; fprintf ppf - ".@.@[<hov2>In %s@ %s%a@;<1 -2>the variable %a is unbound@]" - kwd (lab ti) Printtyp.type_expr (typ ti) Printtyp.type_expr tv + ".@.@[<hov2>In %s@ %a@;<1 -2>the variable %a is unbound@]" + kwd pr ti Printtyp.type_expr tv with Not_found -> () +let explain_unbound ppf tv tl typ kwd lab = + explain_unbound_gen ppf tv tl typ kwd + (fun ppf ti -> fprintf ppf "%s%a" (lab ti) Printtyp.type_expr (typ ti)) + let explain_unbound_single ppf tv ty = let trivial ty = explain_unbound ppf tv [ty] (fun t -> t) "type" (fun _ -> "") in @@ -1418,6 +1537,11 @@ let explain_unbound_single ppf tv ty = "case" (fun (lab,_) -> "`" ^ lab ^ " of ") | _ -> trivial ty + +let tys_of_constr_args = function + | Types.Cstr_tuple tl -> tl + | Types.Cstr_record lbls -> List.map (fun l -> l.Types.ld_type) lbls + let report_error ppf = function | Repeated_parameter -> fprintf ppf "A type parameter occurs several times" @@ -1431,6 +1555,10 @@ let report_error ppf = function fprintf ppf "Two labels are named %s" s | Recursive_abbrev s -> fprintf ppf "The type abbreviation %s is cyclic" s + | Cycle_in_def (s, ty) -> + Printtyp.reset_and_mark_loops ty; + fprintf ppf "@[<v>The definition of %s contains a cycle:@ %a@]" + s Printtyp.type_expr ty | Definition_mismatch (ty, errs) -> Printtyp.reset_and_mark_loops ty; fprintf ppf "@[<v>@[<hov>%s@ %s@;<1 2>%a@]%a@]" @@ -1472,9 +1600,14 @@ let report_error ppf = function let ty = Ctype.repr ty in begin match decl.type_kind, decl.type_manifest with | Type_variant tl, _ -> - explain_unbound ppf ty tl (fun c -> - Btype.newgenty (Ttuple c.Types.cd_args)) - "case" (fun c -> Ident.name c.Types.cd_id ^ " of ") + explain_unbound_gen ppf ty tl (fun c -> + let tl = tys_of_constr_args c.cd_args in + Btype.newgenty (Ttuple tl) + ) + "case" (fun ppf c -> + fprintf ppf + "%s of %a" (Ident.name c.Types.cd_id) + Printtyp.constructor_arguments c.cd_args) | Type_record (tl, _), _ -> explain_unbound ppf ty tl (fun l -> l.Types.ld_type) "field" (fun l -> Ident.name l.Types.ld_id ^ ": ") @@ -1482,14 +1615,45 @@ let report_error ppf = function explain_unbound_single ppf ty ty' | _ -> () end - | Unbound_type_var_exc (tv, ty) -> - fprintf ppf "A type variable is unbound in this exception declaration"; - explain_unbound_single ppf (Ctype.repr tv) ty - | Unbound_exception lid -> - fprintf ppf "Unbound exception constructor@ %a" Printtyp.longident lid - | Not_an_exception lid -> - fprintf ppf "The constructor@ %a@ is not an exception" + | Unbound_type_var_ext (ty, ext) -> + fprintf ppf "A type variable is unbound in this extension constructor"; + let args = tys_of_constr_args ext.ext_args in + explain_unbound ppf ty args (fun c -> c) "type" (fun _ -> "") + | Not_open_type path -> + fprintf ppf "@[%s@ %a@]" + "Cannot extend type definition" + Printtyp.path path + | Not_extensible_type path -> + fprintf ppf "@[%s@ %a@ %s@]" + "Type" + Printtyp.path path + "is not extensible" + | Extension_mismatch (path, errs) -> + fprintf ppf "@[<v>@[<hov>%s@ %s@;<1 2>%s@]%a@]" + "This extension" "does not match the definition of type" + (Path.name path) + (Includecore.report_type_mismatch + "the type" "this extension" "definition") + errs + | Rebind_wrong_type (lid, env, trace) -> + Printtyp.report_unification_error ppf env trace + (function ppf -> + fprintf ppf "The constructor %a@ has type" + Printtyp.longident lid) + (function ppf -> + fprintf ppf "but was expected to be of type") + | Rebind_mismatch (lid, p, p') -> + fprintf ppf + "@[%s@ %a@ %s@ %s@ %s@ %s@ %s@]" + "The constructor" Printtyp.longident lid + "extends type" (Path.name p) + "whose declaration does not match" + "the declaration of type" (Path.name p') + | Rebind_private lid -> + fprintf ppf "@[%s@ %a@ %s@]" + "The constructor" Printtyp.longident lid + "is private" | Bad_variance (n, v1, v2) -> let variance (p,n,i) = let inj = if i then "injective " else "" in @@ -1535,8 +1699,6 @@ let report_error ppf = function fprintf ppf "@[%s@ %s@ %s@]" "In this GADT definition," "the variance of some parameter" "cannot be checked" - | Exception_constructor_with_result -> - fprintf ppf "Exception constructors cannot specify a result type" let () = Location.register_error_of_exn diff --git a/typing/typedecl.mli b/typing/typedecl.mli index ee68aa2e3..452674958 100644 --- a/typing/typedecl.mli +++ b/typing/typedecl.mli @@ -21,10 +21,11 @@ val transl_type_decl: val transl_exception: Env.t -> - Parsetree.constructor_declaration -> (Typedtree.type_declaration list * Env.t) * Typedtree.constructor_declaration * exception_declaration * Env.t + Parsetree.extension_constructor -> Typedtree.extension_constructor * Env.t -val transl_exn_rebind: - Env.t -> Location.t -> string -> Longident.t -> ((Ident.t * Types.type_declaration) list * Env.t) * Path.t * exception_declaration +val transl_type_extension: + bool -> Env.t -> Location.t -> Parsetree.type_extension -> + Typedtree.type_extension * Env.t val transl_value_decl: Env.t -> Location.t -> @@ -61,6 +62,7 @@ type error = | Too_many_constructors | Duplicate_label of string | Recursive_abbrev of string + | Cycle_in_def of string * type_expr | Definition_mismatch of type_expr * Includecore.type_mismatch list | Constraint_failed of type_expr * type_expr | Inconsistent_constraint of Env.t * (type_expr * type_expr) list @@ -69,14 +71,17 @@ type error = | Null_arity_external | Missing_native_external | Unbound_type_var of type_expr * type_declaration - | Unbound_exception of Longident.t - | Not_an_exception of Longident.t + | Not_open_type of Path.t + | Not_extensible_type of Path.t + | Extension_mismatch of Path.t * Includecore.type_mismatch list + | Rebind_wrong_type of Longident.t * Env.t * (type_expr * type_expr) list + | Rebind_mismatch of Longident.t * Path.t * Path.t + | Rebind_private of Longident.t | Bad_variance of int * (bool*bool*bool) * (bool*bool*bool) | Unavailable_type_constructor of Path.t | Bad_fixed_type of string - | Unbound_type_var_exc of type_expr * type_expr + | Unbound_type_var_ext of type_expr * extension_constructor | Varying_anonymous - | Exception_constructor_with_result exception Error of Location.t * error diff --git a/typing/typedtree.ml b/typing/typedtree.ml index 166086ae8..52067415c 100644 --- a/typing/typedtree.ml +++ b/typing/typedtree.ml @@ -76,7 +76,7 @@ and expression_desc = | Texp_let of rec_flag * value_binding list * expression | Texp_function of label * case list * partial | Texp_apply of expression * (label * expression option * optional) list - | Texp_match of expression * case list * partial + | Texp_match of expression * case list * case list * partial | Texp_try of expression * case list | Texp_tuple of expression list | Texp_construct of @@ -169,6 +169,7 @@ and class_field_desc = | Tcf_method of string loc * private_flag * class_field_kind | Tcf_constraint of core_type * core_type | Tcf_initializer of expression + | Tcf_attribute of attribute (* Value expressions for the module language *) @@ -210,16 +211,15 @@ and structure_item_desc = | Tstr_value of rec_flag * value_binding list | Tstr_primitive of value_description | Tstr_type of type_declaration list - | Tstr_exception of constructor_declaration - | Tstr_exn_rebind of - Ident.t * string loc * Path.t * Longident.t loc * attribute list + | Tstr_typext of type_extension + | Tstr_exception of extension_constructor | Tstr_module of module_binding | Tstr_recmodule of module_binding list | Tstr_modtype of module_type_declaration - | Tstr_open of override_flag * Path.t * Longident.t loc * attribute list + | Tstr_open of open_description | Tstr_class of (class_declaration * string list * virtual_flag) list | Tstr_class_type of (Ident.t * string loc * class_type_declaration) list - | Tstr_include of module_expr * Types.signature * attribute list + | Tstr_include of include_declaration | Tstr_attribute of attribute and module_binding = @@ -236,6 +236,7 @@ and value_binding = vb_pat: pattern; vb_expr: expression; vb_attributes: attributes; + vb_loc: Location.t; } and module_coercion = @@ -276,12 +277,13 @@ and signature_item = and signature_item_desc = Tsig_value of value_description | Tsig_type of type_declaration list - | Tsig_exception of constructor_declaration + | Tsig_typext of type_extension + | Tsig_exception of extension_constructor | Tsig_module of module_declaration | Tsig_recmodule of module_declaration list | Tsig_modtype of module_type_declaration - | Tsig_open of override_flag * Path.t * Longident.t loc * attribute list - | Tsig_include of module_type * Types.signature * attribute list + | Tsig_open of open_description + | Tsig_include of include_description | Tsig_class of class_description list | Tsig_class_type of class_type_declaration list | Tsig_attribute of attribute @@ -304,6 +306,27 @@ and module_type_declaration = mtd_loc: Location.t; } +and open_description = + { + open_path: Path.t; + open_txt: Longident.t loc; + open_override: override_flag; + open_loc: Location.t; + open_attributes: attribute list; + } + +and 'a include_infos = + { + incl_mod: 'a; + incl_type: Types.signature; + incl_loc: Location.t; + incl_attributes: attribute list; + } + +and include_description = module_type include_infos + +and include_declaration = module_expr include_infos + and with_constraint = Twith_type of type_declaration | Twith_module of Path.t * Longident.t loc @@ -325,7 +348,7 @@ and core_type_desc = | Ttyp_arrow of label * core_type * core_type | Ttyp_tuple of core_type list | Ttyp_constr of Path.t * Longident.t loc * core_type list - | Ttyp_object of (string * core_type) list * closed_flag + | Ttyp_object of (string * attributes * core_type) list * closed_flag | Ttyp_class of Path.t * Longident.t loc * core_type list | Ttyp_alias of core_type * string | Ttyp_variant of row_field list * closed_flag * label list option @@ -333,14 +356,14 @@ and core_type_desc = | Ttyp_package of package_type and package_type = { - pack_name : Path.t; + pack_path : Path.t; pack_fields : (Longident.t loc * core_type) list; pack_type : Types.module_type; pack_txt : Longident.t loc; } and row_field = - Ttag of label * bool * core_type list + Ttag of label * attributes * bool * core_type list | Tinherit of core_type and value_description = @@ -356,7 +379,7 @@ and value_description = and type_declaration = { typ_id: Ident.t; typ_name: string loc; - typ_params: (string loc option * variance) list; + typ_params: (core_type * variance) list; typ_type: Types.type_declaration; typ_cstrs: (core_type * core_type * Location.t) list; typ_kind: type_kind; @@ -370,6 +393,7 @@ and type_kind = Ttype_abstract | Ttype_variant of constructor_declaration list | Ttype_record of label_declaration list + | Ttype_open and label_declaration = { @@ -385,12 +409,40 @@ and constructor_declaration = { cd_id: Ident.t; cd_name: string loc; - cd_args: core_type list; + cd_args: constructor_arguments; cd_res: core_type option; cd_loc: Location.t; cd_attributes: attribute list; } +and constructor_arguments = + | Cstr_tuple of core_type list + | Cstr_record of label_declaration list + +and type_extension = + { + tyext_path: Path.t; + tyext_txt: Longident.t loc; + tyext_params: (core_type * variance) list; + tyext_constructors: extension_constructor list; + tyext_private: private_flag; + tyext_attributes: attribute list; + } + +and extension_constructor = + { + ext_id: Ident.t; + ext_name: string loc; + ext_type : Types.extension_constructor; + ext_kind : extension_constructor_kind; + ext_loc : Location.t; + ext_attributes: attribute list; + } + +and extension_constructor_kind = + Text_decl of constructor_arguments * core_type option + | Text_rebind of Path.t * Longident.t loc + and class_type = { cltyp_desc: class_type_desc; @@ -422,6 +474,7 @@ and class_type_field_desc = | Tctf_val of (string * mutable_flag * virtual_flag * core_type) | Tctf_method of (string * private_flag * virtual_flag * core_type) | Tctf_constraint of (core_type * core_type) + | Tctf_attribute of attribute and class_declaration = class_expr class_infos @@ -434,7 +487,7 @@ and class_type_declaration = and 'a class_infos = { ci_virt: virtual_flag; - ci_params: (string loc * variance) list; + ci_params: (core_type * variance) list; ci_id_name : string loc; ci_id_class: Ident.t; ci_id_class_type : Ident.t; diff --git a/typing/typedtree.mli b/typing/typedtree.mli index a7161914c..fa36dac8c 100644 --- a/typing/typedtree.mli +++ b/typing/typedtree.mli @@ -75,7 +75,7 @@ and expression_desc = | Texp_let of rec_flag * value_binding list * expression | Texp_function of label * case list * partial | Texp_apply of expression * (label * expression option * optional) list - | Texp_match of expression * case list * partial + | Texp_match of expression * case list * case list * partial | Texp_try of expression * case list | Texp_tuple of expression list | Texp_construct of @@ -168,6 +168,7 @@ and class_field_desc = | Tcf_method of string loc * private_flag * class_field_kind | Tcf_constraint of core_type * core_type | Tcf_initializer of expression + | Tcf_attribute of attribute (* Value expressions for the module language *) @@ -209,15 +210,15 @@ and structure_item_desc = | Tstr_value of rec_flag * value_binding list | Tstr_primitive of value_description | Tstr_type of type_declaration list - | Tstr_exception of constructor_declaration - | Tstr_exn_rebind of Ident.t * string loc * Path.t * Longident.t loc * attributes + | Tstr_typext of type_extension + | Tstr_exception of extension_constructor | Tstr_module of module_binding | Tstr_recmodule of module_binding list | Tstr_modtype of module_type_declaration - | Tstr_open of override_flag * Path.t * Longident.t loc * attributes + | Tstr_open of open_description | Tstr_class of (class_declaration * string list * virtual_flag) list | Tstr_class_type of (Ident.t * string loc * class_type_declaration) list - | Tstr_include of module_expr * Types.signature * attributes + | Tstr_include of include_declaration | Tstr_attribute of attribute and module_binding = @@ -234,6 +235,7 @@ and value_binding = vb_pat: pattern; vb_expr: expression; vb_attributes: attributes; + vb_loc: Location.t; } and module_coercion = @@ -274,12 +276,13 @@ and signature_item = and signature_item_desc = Tsig_value of value_description | Tsig_type of type_declaration list - | Tsig_exception of constructor_declaration + | Tsig_typext of type_extension + | Tsig_exception of extension_constructor | Tsig_module of module_declaration | Tsig_recmodule of module_declaration list | Tsig_modtype of module_type_declaration - | Tsig_open of override_flag * Path.t * Longident.t loc * attributes - | Tsig_include of module_type * Types.signature * attributes + | Tsig_open of open_description + | Tsig_include of include_description | Tsig_class of class_description list | Tsig_class_type of class_type_declaration list | Tsig_attribute of attribute @@ -302,6 +305,27 @@ and module_type_declaration = mtd_loc: Location.t; } +and open_description = + { + open_path: Path.t; + open_txt: Longident.t loc; + open_override: override_flag; + open_loc: Location.t; + open_attributes: attribute list; + } + +and 'a include_infos = + { + incl_mod: 'a; + incl_type: Types.signature; + incl_loc: Location.t; + incl_attributes: attribute list; + } + +and include_description = module_type include_infos + +and include_declaration = module_expr include_infos + and with_constraint = Twith_type of type_declaration | Twith_module of Path.t * Longident.t loc @@ -323,7 +347,7 @@ and core_type_desc = | Ttyp_arrow of label * core_type * core_type | Ttyp_tuple of core_type list | Ttyp_constr of Path.t * Longident.t loc * core_type list - | Ttyp_object of (string * core_type) list * closed_flag + | Ttyp_object of (string * attributes * core_type) list * closed_flag | Ttyp_class of Path.t * Longident.t loc * core_type list | Ttyp_alias of core_type * string | Ttyp_variant of row_field list * closed_flag * label list option @@ -331,14 +355,14 @@ and core_type_desc = | Ttyp_package of package_type and package_type = { - pack_name : Path.t; + pack_path : Path.t; pack_fields : (Longident.t loc * core_type) list; pack_type : Types.module_type; pack_txt : Longident.t loc; } and row_field = - Ttag of label * bool * core_type list + Ttag of label * attributes * bool * core_type list | Tinherit of core_type and value_description = @@ -355,7 +379,7 @@ and type_declaration = { typ_id: Ident.t; typ_name: string loc; - typ_params: (string loc option * variance) list; + typ_params: (core_type * variance) list; typ_type: Types.type_declaration; typ_cstrs: (core_type * core_type * Location.t) list; typ_kind: type_kind; @@ -369,6 +393,7 @@ and type_kind = Ttype_abstract | Ttype_variant of constructor_declaration list | Ttype_record of label_declaration list + | Ttype_open and label_declaration = { @@ -384,12 +409,40 @@ and constructor_declaration = { cd_id: Ident.t; cd_name: string loc; - cd_args: core_type list; + cd_args: constructor_arguments; cd_res: core_type option; cd_loc: Location.t; cd_attributes: attributes; } +and constructor_arguments = + | Cstr_tuple of core_type list + | Cstr_record of label_declaration list + +and type_extension = + { + tyext_path: Path.t; + tyext_txt: Longident.t loc; + tyext_params: (core_type * variance) list; + tyext_constructors: extension_constructor list; + tyext_private: private_flag; + tyext_attributes: attributes; + } + +and extension_constructor = + { + ext_id: Ident.t; + ext_name: string loc; + ext_type : Types.extension_constructor; + ext_kind : extension_constructor_kind; + ext_loc : Location.t; + ext_attributes: attributes; + } + +and extension_constructor_kind = + Text_decl of constructor_arguments * core_type option + | Text_rebind of Path.t * Longident.t loc + and class_type = { cltyp_desc: class_type_desc; @@ -421,6 +474,7 @@ and class_type_field_desc = | Tctf_val of (string * mutable_flag * virtual_flag * core_type) | Tctf_method of (string * private_flag * virtual_flag * core_type) | Tctf_constraint of (core_type * core_type) + | Tctf_attribute of attribute and class_declaration = class_expr class_infos @@ -433,7 +487,7 @@ and class_type_declaration = and 'a class_infos = { ci_virt: virtual_flag; - ci_params: (string loc * variance) list; + ci_params: (core_type * variance) list; ci_id_name : string loc; ci_id_class: Ident.t; ci_id_class_type : Ident.t; diff --git a/typing/typedtreeIter.ml b/typing/typedtreeIter.ml index c0d61297d..28026b598 100644 --- a/typing/typedtreeIter.ml +++ b/typing/typedtreeIter.ml @@ -24,6 +24,8 @@ module type IteratorArgument = sig val enter_structure : structure -> unit val enter_value_description : value_description -> unit val enter_type_declaration : type_declaration -> unit + val enter_type_extension : type_extension -> unit + val enter_extension_constructor : extension_constructor -> unit val enter_pattern : pattern -> unit val enter_expression : expression -> unit val enter_package_type : package_type -> unit @@ -49,6 +51,8 @@ module type IteratorArgument = sig val leave_structure : structure -> unit val leave_value_description : value_description -> unit val leave_type_declaration : type_declaration -> unit + val leave_type_extension : type_extension -> unit + val leave_extension_constructor : extension_constructor -> unit val leave_pattern : pattern -> unit val leave_expression : expression -> unit val leave_package_type : package_type -> unit @@ -130,26 +134,19 @@ module MakeIterator(Iter : IteratorArgument) : sig iter_bindings rec_flag list | Tstr_primitive vd -> iter_value_description vd | Tstr_type list -> List.iter iter_type_declaration list - | Tstr_exception cd -> iter_constructor_declaration cd - | Tstr_exn_rebind _ -> () + | Tstr_typext tyext -> iter_type_extension tyext + | Tstr_exception ext -> iter_extension_constructor ext | Tstr_module x -> iter_module_binding x | Tstr_recmodule list -> List.iter iter_module_binding list | Tstr_modtype mtd -> iter_module_type_declaration mtd | Tstr_open _ -> () | Tstr_class list -> - List.iter (fun (ci, _, _) -> - Iter.enter_class_declaration ci; - iter_class_expr ci.ci_expr; - Iter.leave_class_declaration ci; - ) list + List.iter (fun (ci, _, _) -> iter_class_declaration ci) list | Tstr_class_type list -> - List.iter (fun (id, _, ct) -> - Iter.enter_class_type_declaration ct; - iter_class_type ct.ci_expr; - Iter.leave_class_type_declaration ct; - ) list - | Tstr_include (mexpr, _, _attrs) -> - iter_module_expr mexpr + List.iter + (fun (id, _, ct) -> iter_class_type_declaration ct) + list + | Tstr_include incl -> iter_module_expr incl.incl_mod | Tstr_attribute _ -> () end; @@ -163,12 +160,20 @@ module MakeIterator(Iter : IteratorArgument) : sig iter_core_type v.val_desc; Iter.leave_value_description v + and iter_constructor_arguments = function + | Cstr_tuple l -> List.iter iter_core_type l + | Cstr_record l -> List.iter (fun ld -> iter_core_type ld.ld_type) l + and iter_constructor_declaration cd = - List.iter iter_core_type cd.cd_args; + iter_constructor_arguments cd.cd_args; option iter_core_type cd.cd_res; + and iter_type_parameter (ct, v) = + iter_core_type ct + and iter_type_declaration decl = Iter.enter_type_declaration decl; + List.iter iter_type_parameter decl.typ_params; List.iter (fun (ct1, ct2, loc) -> iter_core_type ct1; iter_core_type ct2 @@ -182,13 +187,27 @@ module MakeIterator(Iter : IteratorArgument) : sig (fun ld -> iter_core_type ld.ld_type ) list + | Ttype_open -> () end; - begin match decl.typ_manifest with - None -> () - | Some ct -> iter_core_type ct - end; + option iter_core_type decl.typ_manifest; Iter.leave_type_declaration decl + and iter_extension_constructor ext = + Iter.enter_extension_constructor ext; + begin match ext.ext_kind with + Text_decl(args, ret) -> + iter_constructor_arguments args; + option iter_core_type ret + | Text_rebind _ -> () + end; + Iter.leave_extension_constructor ext; + + and iter_type_extension tyext = + Iter.enter_type_extension tyext; + List.iter iter_type_parameter tyext.tyext_params; + List.iter iter_extension_constructor tyext.tyext_constructors; + Iter.leave_type_extension tyext + and iter_pattern pat = Iter.enter_pattern pat; List.iter (fun (cstr, _, _attrs) -> match cstr with @@ -248,9 +267,10 @@ module MakeIterator(Iter : IteratorArgument) : sig None -> () | Some exp -> iter_expression exp ) list - | Texp_match (exp, list, _) -> + | Texp_match (exp, list1, list2, _) -> iter_expression exp; - iter_cases list + iter_cases list1; + iter_cases list2; | Texp_try (exp, list) -> iter_expression exp; iter_cases list @@ -338,8 +358,10 @@ module MakeIterator(Iter : IteratorArgument) : sig iter_value_description vd | Tsig_type list -> List.iter iter_type_declaration list - | Tsig_exception cd -> - iter_constructor_declaration cd + | Tsig_exception ext -> + iter_extension_constructor ext + | Tsig_typext tyext -> + iter_type_extension tyext | Tsig_module md -> iter_module_type md.md_type | Tsig_recmodule list -> @@ -347,7 +369,7 @@ module MakeIterator(Iter : IteratorArgument) : sig | Tsig_modtype mtd -> iter_module_type_declaration mtd | Tsig_open _ -> () - | Tsig_include (mty, _, _attrs) -> iter_module_type mty + | Tsig_include incl -> iter_module_type incl.incl_mod | Tsig_class list -> List.iter iter_class_description list | Tsig_class_type list -> @@ -365,16 +387,23 @@ module MakeIterator(Iter : IteratorArgument) : sig end; Iter.leave_module_type_declaration mtd + and iter_class_declaration cd = + Iter.enter_class_declaration cd; + List.iter iter_type_parameter cd.ci_params; + iter_class_expr cd.ci_expr; + Iter.leave_class_declaration cd; and iter_class_description cd = Iter.enter_class_description cd; + List.iter iter_type_parameter cd.ci_params; iter_class_type cd.ci_expr; Iter.leave_class_description cd; and iter_class_type_declaration cd = Iter.enter_class_type_declaration cd; + List.iter iter_type_parameter cd.ci_params; iter_class_type cd.ci_expr; - Iter.leave_class_type_declaration cd; + Iter.leave_class_type_declaration cd; and iter_module_type mty = Iter.enter_module_type mty; @@ -495,6 +524,7 @@ module MakeIterator(Iter : IteratorArgument) : sig | Tctf_constraint (ct1, ct2) -> iter_core_type ct1; iter_core_type ct2 + | Tctf_attribute _ -> () end; Iter.leave_class_type_field ctf @@ -511,7 +541,7 @@ module MakeIterator(Iter : IteratorArgument) : sig | Ttyp_constr (path, _, list) -> List.iter iter_core_type list | Ttyp_object (list, o) -> - List.iter (fun (_, t) -> iter_core_type t) list + List.iter (fun (_, _, t) -> iter_core_type t) list | Ttyp_class (path, _, list) -> List.iter iter_core_type list | Ttyp_alias (ct, s) -> @@ -532,7 +562,7 @@ module MakeIterator(Iter : IteratorArgument) : sig and iter_row_field rf = match rf with - Ttag (label, bool, list) -> + Ttag (label, _attrs, bool, list) -> List.iter iter_core_type list | Tinherit ct -> iter_core_type ct @@ -555,6 +585,7 @@ module MakeIterator(Iter : IteratorArgument) : sig iter_expression exp | Tcf_initializer exp -> iter_expression exp + | Tcf_attribute _ -> () end; Iter.leave_class_field cf; end @@ -564,7 +595,8 @@ module DefaultIteratorArgument = struct let enter_structure _ = () let enter_value_description _ = () let enter_type_declaration _ = () - let enter_exception_declaration _ = () + let enter_type_extension _ = () + let enter_extension_constructor _ = () let enter_pattern _ = () let enter_expression _ = () let enter_package_type _ = () @@ -591,7 +623,8 @@ module DefaultIteratorArgument = struct let leave_structure _ = () let leave_value_description _ = () let leave_type_declaration _ = () - let leave_exception_declaration _ = () + let leave_type_extension _ = () + let leave_extension_constructor _ = () let leave_pattern _ = () let leave_expression _ = () let leave_package_type _ = () diff --git a/typing/typedtreeIter.mli b/typing/typedtreeIter.mli index 158292980..547fc5c34 100644 --- a/typing/typedtreeIter.mli +++ b/typing/typedtreeIter.mli @@ -18,6 +18,8 @@ module type IteratorArgument = sig val enter_structure : structure -> unit val enter_value_description : value_description -> unit val enter_type_declaration : type_declaration -> unit + val enter_type_extension : type_extension -> unit + val enter_extension_constructor : extension_constructor -> unit val enter_pattern : pattern -> unit val enter_expression : expression -> unit val enter_package_type : package_type -> unit @@ -43,6 +45,8 @@ module type IteratorArgument = sig val leave_structure : structure -> unit val leave_value_description : value_description -> unit val leave_type_declaration : type_declaration -> unit + val leave_type_extension : type_extension -> unit + val leave_extension_constructor : extension_constructor -> unit val leave_pattern : pattern -> unit val leave_expression : expression -> unit val leave_package_type : package_type -> unit diff --git a/typing/typedtreeMap.ml b/typing/typedtreeMap.ml index 93881a0f1..6b28cc850 100644 --- a/typing/typedtreeMap.ml +++ b/typing/typedtreeMap.ml @@ -16,6 +16,9 @@ module type MapArgument = sig val enter_structure : structure -> structure val enter_value_description : value_description -> value_description val enter_type_declaration : type_declaration -> type_declaration + val enter_type_extension : type_extension -> type_extension + val enter_extension_constructor : + extension_constructor -> extension_constructor val enter_pattern : pattern -> pattern val enter_expression : expression -> expression val enter_package_type : package_type -> package_type @@ -27,10 +30,10 @@ module type MapArgument = sig val enter_with_constraint : with_constraint -> with_constraint val enter_class_expr : class_expr -> class_expr val enter_class_signature : class_signature -> class_signature + val enter_class_declaration : class_declaration -> class_declaration val enter_class_description : class_description -> class_description val enter_class_type_declaration : class_type_declaration -> class_type_declaration - val enter_class_infos : 'a class_infos -> 'a class_infos val enter_class_type : class_type -> class_type val enter_class_type_field : class_type_field -> class_type_field val enter_core_type : core_type -> core_type @@ -41,6 +44,9 @@ module type MapArgument = sig val leave_structure : structure -> structure val leave_value_description : value_description -> value_description val leave_type_declaration : type_declaration -> type_declaration + val leave_type_extension : type_extension -> type_extension + val leave_extension_constructor : + extension_constructor -> extension_constructor val leave_pattern : pattern -> pattern val leave_expression : expression -> expression val leave_package_type : package_type -> package_type @@ -52,10 +58,10 @@ module type MapArgument = sig val leave_with_constraint : with_constraint -> with_constraint val leave_class_expr : class_expr -> class_expr val leave_class_signature : class_signature -> class_signature + val leave_class_declaration : class_declaration -> class_declaration val leave_class_description : class_description -> class_description val leave_class_type_declaration : class_type_declaration -> class_type_declaration - val leave_class_infos : 'a class_infos -> 'a class_infos val leave_class_type : class_type -> class_type val leave_class_type_field : class_type_field -> class_type_field val leave_core_type : core_type -> core_type @@ -86,6 +92,7 @@ module MakeMap(Map : MapArgument) = struct vb_pat = map_pattern vb.vb_pat; vb_expr = map_expression vb.vb_expr; vb_attributes = vb.vb_attributes; + vb_loc = vb.vb_loc; } and map_bindings rec_flag list = @@ -112,10 +119,10 @@ module MakeMap(Map : MapArgument) = struct Tstr_primitive (map_value_description vd) | Tstr_type list -> Tstr_type (List.map map_type_declaration list) - | Tstr_exception cd -> - Tstr_exception (map_constructor_declaration cd) - | Tstr_exn_rebind (id, name, path, lid, attrs) -> - Tstr_exn_rebind (id, name, path, lid, attrs) + | Tstr_typext tyext -> + Tstr_typext (map_type_extension tyext) + | Tstr_exception ext -> + Tstr_exception (map_extension_constructor ext) | Tstr_module x -> Tstr_module (map_module_binding x) | Tstr_recmodule list -> @@ -123,26 +130,25 @@ module MakeMap(Map : MapArgument) = struct Tstr_recmodule list | Tstr_modtype mtd -> Tstr_modtype (map_module_type_declaration mtd) - | Tstr_open (ovf, path, lid, attrs) -> Tstr_open (ovf, path, lid, attrs) + | Tstr_open od -> Tstr_open od | Tstr_class list -> let list = - List.map (fun (ci, string_list, virtual_flag) -> - let ci = Map.enter_class_infos ci in - let ci_expr = map_class_expr ci.ci_expr in - (Map.leave_class_infos { ci with ci_expr = ci_expr}, - string_list, virtual_flag) - ) list + List.map + (fun (ci, string_list, virtual_flag) -> + map_class_declaration ci, string_list, virtual_flag) + list in - Tstr_class list + Tstr_class list | Tstr_class_type list -> - let list = List.map (fun (id, name, ct) -> - let ct = Map.enter_class_infos ct in - let ci_expr = map_class_type ct.ci_expr in - (id, name, Map.leave_class_infos { ct with ci_expr = ci_expr}) - ) list in - Tstr_class_type list - | Tstr_include (mexpr, sg, attrs) -> - Tstr_include (map_module_expr mexpr, sg, attrs) + let list = + List.map + (fun (id, name, ct) -> + id, name, map_class_type_declaration ct) + list + in + Tstr_class_type list + | Tstr_include incl -> + Tstr_include {incl with incl_mod = map_module_expr incl.incl_mod} | Tstr_attribute x -> Tstr_attribute x in Map.leave_structure_item { item with str_desc = str_desc} @@ -157,6 +163,7 @@ module MakeMap(Map : MapArgument) = struct and map_type_declaration decl = let decl = Map.enter_type_declaration decl in + let typ_params = List.map map_type_parameter decl.typ_params in let typ_cstrs = List.map (fun (ct1, ct2, loc) -> (map_core_type ct1, map_core_type ct2, @@ -175,20 +182,48 @@ module MakeMap(Map : MapArgument) = struct ) list in Ttype_record list + | Ttype_open -> Ttype_open in - let typ_manifest = - match decl.typ_manifest with - None -> None - | Some ct -> Some (map_core_type ct) - in - Map.leave_type_declaration { decl with typ_cstrs = typ_cstrs; - typ_kind = typ_kind; typ_manifest = typ_manifest } + let typ_manifest = may_map map_core_type decl.typ_manifest in + Map.leave_type_declaration { decl with typ_params = typ_params; + typ_cstrs = typ_cstrs; typ_kind = typ_kind; typ_manifest = typ_manifest } + + and map_type_parameter (ct, v) = (map_core_type ct, v) + + and map_constructor_arguments = function + | Cstr_tuple l -> + Cstr_tuple (List.map map_core_type l) + | Cstr_record l -> + Cstr_record + (List.map (fun ld -> {ld with ld_type = map_core_type ld.ld_type}) + l) and map_constructor_declaration cd = - {cd with cd_args = List.map map_core_type cd.cd_args; + let cd_args = map_constructor_arguments cd.cd_args in + {cd with cd_args; cd_res = may_map map_core_type cd.cd_res } + and map_type_extension tyext = + let tyext = Map.enter_type_extension tyext in + let tyext_params = List.map map_type_parameter tyext.tyext_params in + let tyext_constructors = + List.map map_extension_constructor tyext.tyext_constructors + in + Map.leave_type_extension { tyext with tyext_params = tyext_params; + tyext_constructors = tyext_constructors } + + and map_extension_constructor ext = + let ext = Map.enter_extension_constructor ext in + let ext_kind = match ext.ext_kind with + Text_decl(args, ret) -> + let args = map_constructor_arguments args in + let ret = may_map map_core_type ret in + Text_decl(args, ret) + | Text_rebind(p, lid) -> Text_rebind(p, lid) + in + Map.leave_extension_constructor {ext with ext_kind = ext_kind} + and map_pattern pat = let pat = Map.enter_pattern pat in let pat_desc = @@ -248,10 +283,11 @@ module MakeMap(Map : MapArgument) = struct in (label, expo, optional) ) list ) - | Texp_match (exp, list, partial) -> + | Texp_match (exp, list1, list2, partial) -> Texp_match ( map_expression exp, - map_cases list, + map_cases list1, + map_cases list2, partial ) | Texp_try (exp, list) -> @@ -382,8 +418,10 @@ module MakeMap(Map : MapArgument) = struct Tsig_value vd -> Tsig_value (map_value_description vd) | Tsig_type list -> Tsig_type (List.map map_type_declaration list) - | Tsig_exception cd -> - Tsig_exception (map_constructor_declaration cd) + | Tsig_typext tyext -> + Tsig_typext (map_type_extension tyext) + | Tsig_exception ext -> + Tsig_exception (map_extension_constructor ext) | Tsig_module md -> Tsig_module {md with md_type = map_module_type md.md_type} | Tsig_recmodule list -> @@ -395,7 +433,8 @@ module MakeMap(Map : MapArgument) = struct | Tsig_modtype mtd -> Tsig_modtype (map_module_type_declaration mtd) | Tsig_open _ -> item.sig_desc - | Tsig_include (mty, sg, attrs) -> Tsig_include (map_module_type mty, sg, attrs) + | Tsig_include incl -> + Tsig_include {incl with incl_mod = map_module_type incl.incl_mod} | Tsig_class list -> Tsig_class (List.map map_class_description list) | Tsig_class_type list -> Tsig_class_type (List.map map_class_type_declaration list) @@ -408,16 +447,26 @@ module MakeMap(Map : MapArgument) = struct let mtd = {mtd with mtd_type = may_map map_module_type mtd.mtd_type} in Map.leave_module_type_declaration mtd + and map_class_declaration cd = + let cd = Map.enter_class_declaration cd in + let ci_params = List.map map_type_parameter cd.ci_params in + let ci_expr = map_class_expr cd.ci_expr in + Map.leave_class_declaration + { cd with ci_params = ci_params; ci_expr = ci_expr } and map_class_description cd = let cd = Map.enter_class_description cd in + let ci_params = List.map map_type_parameter cd.ci_params in let ci_expr = map_class_type cd.ci_expr in - Map.leave_class_description { cd with ci_expr = ci_expr} + Map.leave_class_description + { cd with ci_params = ci_params; ci_expr = ci_expr} and map_class_type_declaration cd = let cd = Map.enter_class_type_declaration cd in + let ci_params = List.map map_type_parameter cd.ci_params in let ci_expr = map_class_type cd.ci_expr in - Map.leave_class_type_declaration { cd with ci_expr = ci_expr } + Map.leave_class_type_declaration + { cd with ci_params = ci_params; ci_expr = ci_expr } and map_module_type mty = let mty = Map.enter_module_type mty in @@ -540,6 +589,7 @@ module MakeMap(Map : MapArgument) = struct Tctf_method (s, priv, virt, map_core_type ct) | Tctf_constraint (ct1, ct2) -> Tctf_constraint (map_core_type ct1, map_core_type ct2) + | Tctf_attribute _ as x -> x in Map.leave_class_type_field { ctf with ctf_desc = ctf_desc } @@ -555,7 +605,8 @@ module MakeMap(Map : MapArgument) = struct | Ttyp_constr (path, lid, list) -> Ttyp_constr (path, lid, List.map map_core_type list) | Ttyp_object (list, o) -> - Ttyp_object (List.map (fun (s, t) -> (s, map_core_type t)) list, o) + Ttyp_object + (List.map (fun (s, a, t) -> (s, a, map_core_type t)) list, o) | Ttyp_class (path, lid, list) -> Ttyp_class (path, lid, List.map map_core_type list) | Ttyp_alias (ct, s) -> Ttyp_alias (map_core_type ct, s) @@ -574,8 +625,8 @@ module MakeMap(Map : MapArgument) = struct and map_row_field rf = match rf with - Ttag (label, bool, list) -> - Ttag (label, bool, List.map map_core_type list) + Ttag (label, attrs, bool, list) -> + Ttag (label, attrs, bool, List.map map_core_type list) | Tinherit ct -> Tinherit (map_core_type ct) and map_class_field cf = @@ -595,6 +646,7 @@ module MakeMap(Map : MapArgument) = struct | Tcf_method (lab, priv, Tcfk_concrete (o, exp)) -> Tcf_method (lab, priv, Tcfk_concrete (o, map_expression exp)) | Tcf_initializer exp -> Tcf_initializer (map_expression exp) + | Tcf_attribute _ as x -> x in Map.leave_class_field { cf with cf_desc = cf_desc } end @@ -605,7 +657,8 @@ module DefaultMapArgument = struct let enter_structure t = t let enter_value_description t = t let enter_type_declaration t = t - let enter_exception_declaration t = t + let enter_type_extension t = t + let enter_extension_constructor t = t let enter_pattern t = t let enter_expression t = t let enter_package_type t = t @@ -617,9 +670,9 @@ module DefaultMapArgument = struct let enter_with_constraint t = t let enter_class_expr t = t let enter_class_signature t = t + let enter_class_declaration t = t let enter_class_description t = t let enter_class_type_declaration t = t - let enter_class_infos t = t let enter_class_type t = t let enter_class_type_field t = t let enter_core_type t = t @@ -631,7 +684,8 @@ module DefaultMapArgument = struct let leave_structure t = t let leave_value_description t = t let leave_type_declaration t = t - let leave_exception_declaration t = t + let leave_type_extension t = t + let leave_extension_constructor t = t let leave_pattern t = t let leave_expression t = t let leave_package_type t = t @@ -643,9 +697,9 @@ module DefaultMapArgument = struct let leave_with_constraint t = t let leave_class_expr t = t let leave_class_signature t = t + let leave_class_declaration t = t let leave_class_description t = t let leave_class_type_declaration t = t - let leave_class_infos t = t let leave_class_type t = t let leave_class_type_field t = t let leave_core_type t = t diff --git a/typing/typedtreeMap.mli b/typing/typedtreeMap.mli index 9ee2c8c4a..5178a5180 100644 --- a/typing/typedtreeMap.mli +++ b/typing/typedtreeMap.mli @@ -16,6 +16,9 @@ module type MapArgument = sig val enter_structure : structure -> structure val enter_value_description : value_description -> value_description val enter_type_declaration : type_declaration -> type_declaration + val enter_type_extension : type_extension -> type_extension + val enter_extension_constructor : + extension_constructor -> extension_constructor val enter_pattern : pattern -> pattern val enter_expression : expression -> expression val enter_package_type : package_type -> package_type @@ -27,10 +30,10 @@ module type MapArgument = sig val enter_with_constraint : with_constraint -> with_constraint val enter_class_expr : class_expr -> class_expr val enter_class_signature : class_signature -> class_signature + val enter_class_declaration : class_declaration -> class_declaration val enter_class_description : class_description -> class_description val enter_class_type_declaration : class_type_declaration -> class_type_declaration - val enter_class_infos : 'a class_infos -> 'a class_infos val enter_class_type : class_type -> class_type val enter_class_type_field : class_type_field -> class_type_field val enter_core_type : core_type -> core_type @@ -41,6 +44,9 @@ module type MapArgument = sig val leave_structure : structure -> structure val leave_value_description : value_description -> value_description val leave_type_declaration : type_declaration -> type_declaration + val leave_type_extension : type_extension -> type_extension + val leave_extension_constructor : + extension_constructor -> extension_constructor val leave_pattern : pattern -> pattern val leave_expression : expression -> expression val leave_package_type : package_type -> package_type @@ -52,10 +58,10 @@ module type MapArgument = sig val leave_with_constraint : with_constraint -> with_constraint val leave_class_expr : class_expr -> class_expr val leave_class_signature : class_signature -> class_signature + val leave_class_declaration : class_declaration -> class_declaration val leave_class_description : class_description -> class_description val leave_class_type_declaration : class_type_declaration -> class_type_declaration - val leave_class_infos : 'a class_infos -> 'a class_infos val leave_class_type : class_type -> class_type val leave_class_type_field : class_type_field -> class_type_field val leave_core_type : core_type -> core_type diff --git a/typing/typemod.ml b/typing/typemod.ml index ddea66977..bf3e1bfaf 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -37,11 +37,11 @@ type error = | Not_a_packed_module of type_expr | Incomplete_packed_module of type_expr | Scoping_pack of Longident.t * type_expr - | Extension of string | Recursive_module_require_explicit_type | Apply_generative exception Error of Location.t * Env.t * error +exception Error_forward of Location.error open Typedtree @@ -67,12 +67,26 @@ let extract_sig_open env loc mty = (* Compute the environment after opening a module *) -let type_open ?toplevel ovf env loc lid = - let path = Typetexp.find_module env loc lid.txt in - let md = Env.find_module path env in - let sg = extract_sig_open env loc md.md_type in +let type_open_ ?toplevel ovf env loc lid = + let path, md = Typetexp.find_module env lid.loc lid.txt in + let sg = extract_sig_open env lid.loc md.md_type in path, Env.open_signature ~loc ?toplevel ovf path sg env +let type_open ?toplevel env sod = + let (path, newenv) = + type_open_ ?toplevel sod.popen_override env sod.popen_loc sod.popen_lid + in + let od = + { + open_override = sod.popen_override; + open_path = path; + open_txt = sod.popen_lid; + open_attributes = sod.popen_attributes; + open_loc = sod.popen_loc; + } + in + (path, newenv, od) + (* Record a module type *) let rm node = Stypes.record (Stypes.Ti_mod node); @@ -124,6 +138,10 @@ let make p n i = let open Variance in set May_pos p (set May_neg n (set May_weak n (set Inj i null))) +let ensure_functor_arg p env = + if Env.is_functor_arg p env then env else + Env.add_functor_arg (Path.head p) env + let merge_constraint initial_env loc sg constr = let lid = match constr with @@ -194,22 +212,23 @@ let merge_constraint initial_env loc sg constr = real_id := Some id; (Pident id, lid, Twith_typesubst tdecl), make_next_first rs rem - | (Sig_module(id, md, rs) :: rem, [s], Pwith_module (_, lid)) + | (Sig_module(id, md, rs) :: rem, [s], Pwith_module (_, lid')) when Ident.name id = s -> - let path = Typetexp.find_module initial_env loc lid.txt in - let md' = Env.find_module path env in - let newmd = Mtype.strengthen_decl env md' path in + let path, md' = Typetexp.find_module initial_env loc lid'.txt in + let md'' = {md' with md_type = Mtype.remove_aliases env md'.md_type} in + let env = ensure_functor_arg path env in + let newmd = Mtype.strengthen_decl env md'' path in ignore(Includemod.modtypes env newmd.md_type md.md_type); - (Pident id, lid, Twith_module (path, lid)), + (Pident id, lid, Twith_module (path, lid')), Sig_module(id, newmd, rs) :: rem - | (Sig_module(id, md, rs) :: rem, [s], Pwith_modsubst (_, lid)) + | (Sig_module(id, md, rs) :: rem, [s], Pwith_modsubst (_, lid')) when Ident.name id = s -> - let path = Typetexp.find_module initial_env loc lid.txt in - let md' = Env.find_module path env in + let path, md' = Typetexp.find_module initial_env loc lid'.txt in + let env = ensure_functor_arg path env in let newmd = Mtype.strengthen_decl env md' path in ignore(Includemod.modtypes env newmd.md_type md.md_type); real_id := Some id; - (Pident id, lid, Twith_modsubst (path, lid)), + (Pident id, lid, Twith_modsubst (path, lid')), make_next_first rs rem | (Sig_module(id, md, rs) :: rem, s :: namelist, _) when Ident.name id = s -> @@ -234,15 +253,12 @@ let merge_constraint initial_env loc sg constr = try match sdecl.ptype_manifest with | Some {ptyp_desc = Ptyp_constr (lid, stl)} when List.length stl = List.length sdecl.ptype_params -> - let params = - List.map - (function {ptyp_desc=Ptyp_var s} -> s | _ -> raise Exit) - stl in - List.iter2 (fun x (ox, _) -> - match ox with - Some y when x = y.txt -> () - | _ -> raise Exit - ) params sdecl.ptype_params; + List.iter2 (fun x (y, _) -> + match x, y with + {ptyp_desc=Ptyp_var sx}, {ptyp_desc=Ptyp_var sy} + when sx = sy -> () + | _, _ -> raise Exit) + stl sdecl.ptype_params; lid | _ -> raise Exit with Exit -> @@ -256,7 +272,7 @@ let merge_constraint initial_env loc sg constr = | [s], Pwith_modsubst (_, lid) -> let id = match !real_id with None -> assert false | Some id -> id in - let path = Typetexp.find_module initial_env loc lid.txt in + let path = Typetexp.lookup_module initial_env loc lid.txt in let sub = Subst.add_module id path Subst.identity in Subst.signature sub sg | _ -> @@ -289,6 +305,12 @@ let rec map_rec'' fn decls rem = fn Trec_not d1 :: map_rec'' fn dl rem | _ -> map_rec fn decls rem +(* Add type extension flags to extension contructors *) +let map_ext fn exts rem = + match exts with + | [] -> rem + | d1 :: dl -> fn Text_first d1 :: map_end (fn Text_next) dl rem + (* Auxiliary for translating recursively-defined module types. Return a module type that approximates the shape of the given module type AST. Retain only module, type, and module type @@ -301,7 +323,7 @@ let rec approx_modtype env smty = let (path, info) = Typetexp.find_modtype env smty.pmty_loc lid.txt in Mty_ident path | Pmty_alias lid -> - let path = Typetexp.find_module env smty.pmty_loc lid.txt in + let path = Typetexp.lookup_module env smty.pmty_loc lid.txt in Mty_alias path | Pmty_signature ssg -> Mty_signature(approx_sig env ssg) @@ -316,8 +338,8 @@ let rec approx_modtype env smty = | Pmty_typeof smod -> let (_, mty) = !type_module_type_of_fwd env smod in mty - | Pmty_extension (s, _arg) -> - raise (Error (s.loc, env, Extension s.txt)) + | Pmty_extension ext -> + raise (Error_forward (Typetexp.error_of_extension ext)) and approx_module_declaration env pmd = { @@ -360,10 +382,11 @@ and approx_sig env ssg = let info = approx_modtype_info env d in let (id, newenv) = Env.enter_modtype d.pmtd_name.txt info env in Sig_modtype(id, info) :: approx_sig newenv srem - | Psig_open (ovf, lid, _attrs) -> - let (path, mty) = type_open ovf env item.psig_loc lid in + | Psig_open sod -> + let (path, mty, _od) = type_open env sod in approx_sig mty srem - | Psig_include (smty, _attrs) -> + | Psig_include sincl -> + let smty = sincl.pincl_mod in let mty = approx_modtype env smty in let sg = Subst.signature Subst.identity (extract_sig env smty.pmty_loc mty) in @@ -414,35 +437,56 @@ let check cl loc set_ref name = then raise(Error(loc, Env.empty, Repeated_name(cl, name))) else set_ref := StringSet.add name !set_ref -let check_sig_item type_names module_names modtype_names loc = function - Sig_type(id, _, _) -> - check "type" loc type_names (Ident.name id) - | Sig_module(id, _, _) -> - check "module" loc module_names (Ident.name id) - | Sig_modtype(id, _) -> - check "module type" loc modtype_names (Ident.name id) - | _ -> () +type names = + { + types: StringSet.t ref; + modules: StringSet.t ref; + modtypes: StringSet.t ref; + typexts: StringSet.t ref; + } -let rec remove_duplicates val_ids exn_ids = function - [] -> [] - | Sig_value (id, _) :: rem - when List.exists (Ident.equal id) val_ids -> - remove_duplicates val_ids exn_ids rem - | Sig_exception(id, _) :: rem - when List.exists (Ident.equal id) exn_ids -> - remove_duplicates val_ids exn_ids rem - | f :: rem -> f :: remove_duplicates val_ids exn_ids rem - -let rec get_values = function - [] -> [] - | Sig_value (id, _) :: rem -> id :: get_values rem - | f :: rem -> get_values rem +let new_names () = + { + types = ref StringSet.empty; + modules = ref StringSet.empty; + modtypes = ref StringSet.empty; + typexts = ref StringSet.empty; + } -let rec get_exceptions = function - [] -> [] - | Sig_exception (id, _) :: rem -> id :: get_exceptions rem - | f :: rem -> get_exceptions rem +let check_name check names name = check names name.loc name.txt +let check_type names loc s = check "type" loc names.types s +let check_module names loc s = check "module" loc names.modules s +let check_modtype names loc s = check "module type" loc names.modtypes s +let check_typext names loc s = check "extension constructor" loc names.typexts s + + +let check_sig_item names loc = function + | Sig_type(id, _, _) -> check_type names loc (Ident.name id) + | Sig_module(id, _, _) -> check_module names loc (Ident.name id) + | Sig_modtype(id, _) -> check_modtype names loc (Ident.name id) + | Sig_typext(id, _, _) -> check_typext names loc (Ident.name id) + | _ -> () + +(* Simplify multiple specifications of a value or an extension in a signature. + (Other signature components, e.g. types, modules, etc, are checked for + name uniqueness.) If multiple specifications with the same name, + keep only the last (rightmost) one. *) + +let simplify_signature sg = + let rec aux = function + | [] -> [], StringSet.empty + | (Sig_value(id, descr) as component) :: sg -> + let (sg, val_names) as k = aux sg in + let name = Ident.name id in + if StringSet.mem name val_names then k + else (component :: sg, StringSet.add name val_names) + | component :: sg -> + let (sg, val_names) = aux sg in + (component :: sg, val_names) + in + let (sg, _) = aux sg in + sg (* Check and translate a module type expression *) @@ -451,7 +495,7 @@ let transl_modtype_longident loc env lid = path let transl_module_alias loc env lid = - Typetexp.find_module env loc lid + Typetexp.lookup_module env loc lid let mkmty desc typ env loc attrs = let mty = { @@ -471,13 +515,6 @@ let mksig desc env loc = (* let signature sg = List.map (fun item -> item.sig_type) sg *) -let prepend_sig_types decls rem = - map_rec'' (fun rs td -> Sig_type(td.typ_id, td.typ_type, rs)) decls rem - -let prepend_sig_types' decls rem = - map_rec (fun rs (id, td) -> Sig_type(id, td, rs)) decls rem - - let rec transl_modtype env smty = let loc = smty.pmty_loc in match smty.pmty_desc with @@ -498,6 +535,7 @@ let rec transl_modtype env smty = let ty_arg = Misc.may_map (fun m -> m.mty_type) arg in let (id, newenv) = Env.enter_module ~arg:true param.txt (Btype.default_mty ty_arg) env in + Ctype.init_def(Ident.current_time()); (* PR#6513 *) let res = transl_modtype newenv sres in mkmty (Tmty_functor (id, param, arg, res)) (Mty_functor(id, ty_arg, res.mty_type)) env loc @@ -505,27 +543,25 @@ let rec transl_modtype env smty = | Pmty_with(sbody, constraints) -> let body = transl_modtype env sbody in let init_sg = extract_sig env sbody.pmty_loc body.mty_type in - let (tcstrs, final_sg) = + let (rev_tcstrs, final_sg) = List.fold_left - (fun (tcstrs,sg) sdecl -> + (fun (rev_tcstrs,sg) sdecl -> let (tcstr, sg) = merge_constraint env smty.pmty_loc sg sdecl in - (tcstr :: tcstrs, sg) + (tcstr :: rev_tcstrs, sg) ) ([],init_sg) constraints in - mkmty (Tmty_with ( body, tcstrs)) + mkmty (Tmty_with ( body, List.rev rev_tcstrs)) (Mtype.freshen (Mty_signature final_sg)) env loc smty.pmty_attributes | Pmty_typeof smod -> let tmty, mty = !type_module_type_of_fwd env smod in mkmty (Tmty_typeof tmty) mty env loc smty.pmty_attributes - | Pmty_extension (s, _arg) -> - raise (Error (s.loc, env, Extension s.txt)) + | Pmty_extension ext -> + raise (Error_forward (Typetexp.error_of_extension ext)) and transl_signature env sg = - let type_names = ref StringSet.empty - and module_names = ref StringSet.empty - and modtype_names = ref StringSet.empty in + let names = new_names () in let rec transl_sig env sg = Ctype.init_def(Ident.current_time()); match sg with @@ -538,36 +574,40 @@ and transl_signature env sg = Typedecl.transl_value_decl env item.psig_loc sdesc in let (trem,rem, final_env) = transl_sig newenv srem in mksig (Tsig_value tdesc) env loc :: trem, - (if List.exists (Ident.equal tdesc.val_id) (get_values rem) then rem - else Sig_value(tdesc.val_id, tdesc.val_val) :: rem), + Sig_value(tdesc.val_id, tdesc.val_val) :: rem, final_env | Psig_type sdecls -> List.iter - (fun decl -> - check "type" item.psig_loc type_names decl.ptype_name.txt) + (fun decl -> check_name check_type names decl.ptype_name) sdecls; let (decls, newenv) = Typedecl.transl_type_decl env sdecls in let (trem, rem, final_env) = transl_sig newenv srem in mksig (Tsig_type decls) env loc :: trem, - prepend_sig_types decls rem, + map_rec'' (fun rs td -> + Sig_type(td.typ_id, td.typ_type, rs)) decls rem, final_env - | Psig_exception sarg -> - let ((tdecls, tenv), arg, decl, newenv) = - Typedecl.transl_exception env sarg + | Psig_typext styext -> + List.iter + (fun pext -> check_name check_typext names pext.pext_name) + styext.ptyext_constructors; + let (tyext, newenv) = + Typedecl.transl_type_extension false env item.psig_loc styext in let (trem, rem, final_env) = transl_sig newenv srem in - let id = arg.cd_id in - let trem = mksig (Tsig_exception arg) tenv loc :: trem in - let trem = - if tdecls = [] then trem else - mksig (Tsig_type tdecls) env loc :: trem - in - trem, - (if List.exists (Ident.equal id) (get_exceptions rem) then rem - else prepend_sig_types tdecls (Sig_exception(id, decl) :: rem)), + let constructors = tyext.tyext_constructors in + mksig (Tsig_typext tyext) env loc :: trem, + map_ext (fun es ext -> + Sig_typext(ext.ext_id, ext.ext_type, es)) constructors rem, + final_env + | Psig_exception sext -> + check_name check_typext names sext.pext_name; + let (ext, newenv) = Typedecl.transl_exception env sext in + let (trem, rem, final_env) = transl_sig newenv srem in + mksig (Tsig_exception ext) env loc :: trem, + Sig_typext(ext.ext_id, ext.ext_type, Text_exception) :: rem, final_env | Psig_module pmd -> - check "module" item.psig_loc module_names pmd.pmd_name.txt; + check_name check_module names pmd.pmd_name; let tmty = transl_modtype env pmd.pmd_type in let md = { md_type=tmty.mty_type; @@ -586,8 +626,7 @@ and transl_signature env sg = final_env | Psig_recmodule sdecls -> List.iter - (fun pmd -> - check "module" item.psig_loc module_names pmd.pmd_name.txt) + (fun pmd -> check_name check_module names pmd.pmd_name) sdecls; let (decls, newenv) = transl_recmodule_modtypes item.psig_loc env sdecls in @@ -603,35 +642,39 @@ and transl_signature env sg = final_env | Psig_modtype pmtd -> let newenv, mtd, sg = - transl_modtype_decl modtype_names env item.psig_loc pmtd + transl_modtype_decl names env item.psig_loc pmtd in let (trem, rem, final_env) = transl_sig newenv srem in mksig (Tsig_modtype mtd) env loc :: trem, sg :: rem, final_env - | Psig_open (ovf, lid, attrs) -> - let (path, newenv) = type_open ovf env item.psig_loc lid in + | Psig_open sod -> + let (path, newenv, od) = type_open env sod in let (trem, rem, final_env) = transl_sig newenv srem in - mksig (Tsig_open (ovf, path,lid,attrs)) env loc :: trem, + mksig (Tsig_open od) env loc :: trem, rem, final_env - | Psig_include (smty, attrs) -> + | Psig_include sincl -> + let smty = sincl.pincl_mod in let tmty = transl_modtype env smty in let mty = tmty.mty_type in let sg = Subst.signature Subst.identity (extract_sig env smty.pmty_loc mty) in - List.iter - (check_sig_item type_names module_names modtype_names - item.psig_loc) - sg; + List.iter (check_sig_item names item.psig_loc) sg; let newenv = Env.add_signature sg env in + let incl = + { incl_mod = tmty; + incl_type = sg; + incl_attributes = sincl.pincl_attributes; + incl_loc = sincl.pincl_loc; + } + in let (trem, rem, final_env) = transl_sig newenv srem in - mksig (Tsig_include (tmty, sg, attrs)) env loc :: trem, - remove_duplicates (get_values rem) (get_exceptions rem) sg @ rem, + mksig (Tsig_include incl) env loc :: trem, + sg @ rem, final_env | Psig_class cl -> List.iter - (fun {pci_name = name} -> - check "type" item.psig_loc type_names name.txt ) + (fun {pci_name} -> check_name check_type names pci_name) cl; let (classes, newenv) = Typeclass.class_descriptions env cl in let (trem, rem, final_env) = transl_sig newenv srem in @@ -653,8 +696,7 @@ and transl_signature env sg = final_env | Psig_class_type cl -> List.iter - (fun {pci_name = name} -> - check "type" item.psig_loc type_names name.txt) + (fun {pci_name} -> check_name check_type names pci_name) cl; let (classes, newenv) = Typeclass.class_type_declarations env cl in let (trem,rem, final_env) = transl_sig newenv srem in @@ -671,22 +713,25 @@ and transl_signature env sg = classes [rem]), final_env | Psig_attribute x -> - let _back = Typetexp.warning_attribute [x] in + Typetexp.warning_attribute [x]; let (trem,rem, final_env) = transl_sig env srem in mksig (Tsig_attribute x) env loc :: trem, rem, final_env - | Psig_extension ((s, _), _) -> - raise (Error (s.loc, env, Extension s.txt)) + | Psig_extension (ext, _attrs) -> + raise (Error_forward (Typetexp.error_of_extension ext)) in let previous_saved_types = Cmt_format.get_saved_types () in + Typetexp.warning_enter_scope (); let (trem, rem, final_env) = transl_sig (Env.in_signature env) sg in + let rem = simplify_signature rem in let sg = { sig_items = trem; sig_type = rem; sig_final_env = final_env } in + Typetexp.warning_leave_scope (); Cmt_format.set_saved_types ((Cmt_format.Partial_signature sg) :: previous_saved_types); sg -and transl_modtype_decl modtype_names env loc +and transl_modtype_decl names env loc {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} = - check "module type" loc modtype_names pmtd_name.txt; + check_name check_modtype names pmtd_name; let tmty = Misc.may_map (transl_modtype env) pmtd_type in let decl = { @@ -855,8 +900,10 @@ let check_recmodule_inclusion env bindings = the number of mutually recursive declarations. *) let subst_and_strengthen env s id mty = - Mtype.strengthen env (Subst.modtype s mty) - (Subst.module_path s (Pident id)) in + let p = Subst.module_path s (Pident id) in + let env = ensure_functor_arg p env in + Mtype.strengthen env (Subst.modtype s mty) p + in let rec check_incl first_time n env s = if n > 0 then begin @@ -991,7 +1038,8 @@ let wrap_constraint env arg mty explicit = let rec type_module ?(alias=false) sttn funct_body anchor env smod = match smod.pmod_desc with Pmod_ident lid -> - let path = Typetexp.find_module env smod.pmod_loc lid.txt in + let path = + Typetexp.lookup_module ~load:(not alias) env smod.pmod_loc lid.txt in let md = { mod_desc = Tmod_ident (path, lid); mod_type = Mty_alias path; mod_env = env; @@ -1016,11 +1064,17 @@ let rec type_module ?(alias=false) sttn funct_body anchor env smod = | Pmod_structure sstr -> let (str, sg, finalenv) = type_structure funct_body anchor env sstr smod.pmod_loc in - rm { mod_desc = Tmod_structure str; - mod_type = Mty_signature sg; - mod_env = env; - mod_attributes = smod.pmod_attributes; - mod_loc = smod.pmod_loc } + let md = + rm { mod_desc = Tmod_structure str; + mod_type = Mty_signature sg; + mod_env = env; + mod_attributes = smod.pmod_attributes; + mod_loc = smod.pmod_loc } + in + let sg' = simplify_signature sg in + if List.length sg' = List.length sg then md else + wrap_constraint (Env.implicit_coercion env) md (Mty_signature sg') + Tmodtype_implicit | Pmod_functor(name, smty, sbody) -> let mty = may_map (transl_modtype env) smty in let ty_arg = may_map (fun m -> m.mty_type) mty in @@ -1116,13 +1170,11 @@ let rec type_module ?(alias=false) sttn funct_body anchor env smod = mod_env = env; mod_attributes = smod.pmod_attributes; mod_loc = smod.pmod_loc } - | Pmod_extension (s, _arg) -> - raise (Error (s.loc, env, Extension s.txt)) + | Pmod_extension ext -> + raise (Error_forward (Typetexp.error_of_extension ext)) and type_structure ?(toplevel = false) funct_body anchor env sstr scope = - let type_names = ref StringSet.empty - and module_names = ref StringSet.empty - and modtype_names = ref StringSet.empty in + let names = new_names () in let type_str_item env srem {pstr_loc = loc; pstr_desc = desc} = match desc with @@ -1156,32 +1208,35 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = Tstr_primitive desc, [Sig_value(desc.val_id, desc.val_val)], newenv | Pstr_type sdecls -> List.iter - (fun decl -> check "type" loc type_names decl.ptype_name.txt) + (fun decl -> check_name check_type names decl.ptype_name) sdecls; let (decls, newenv) = Typedecl.transl_type_decl env sdecls in Tstr_type decls, - prepend_sig_types decls [], + map_rec'' (fun rs info -> Sig_type(info.typ_id, info.typ_type, rs)) + decls [], enrich_type_decls anchor decls env newenv - | Pstr_exception sarg -> - let ((tdecls, tenv), arg, decl, newenv) = - Typedecl.transl_exception env sarg - in - (* Note: we should keep tdecls in the typedtree *) - Tstr_exception arg, - prepend_sig_types tdecls [Sig_exception(arg.cd_id, decl)], - newenv - | Pstr_exn_rebind(name, longid, attrs) -> - let ((tdecls, env), path, arg) = - Typedecl.transl_exn_rebind env loc name.txt longid.txt + | Pstr_typext styext -> + List.iter + (fun pext -> check_name check_typext names pext.pext_name) + styext.ptyext_constructors; + let (tyext, newenv) = + Typedecl.transl_type_extension true env loc styext in - let (id, newenv) = Env.enter_exception name.txt arg env in - Tstr_exn_rebind(id, name, path, longid, attrs), - prepend_sig_types' tdecls [Sig_exception(id, arg)], + (Tstr_typext tyext, + map_ext + (fun es ext -> Sig_typext(ext.ext_id, ext.ext_type, es)) + tyext.tyext_constructors [], + newenv) + | Pstr_exception sext -> + check_name check_typext names sext.pext_name; + let (ext, newenv) = Typedecl.transl_exception env sext in + Tstr_exception ext, + [Sig_typext(ext.ext_id, ext.ext_type, Text_exception)], newenv | Pstr_module {pmb_name = name; pmb_expr = smodl; pmb_attributes = attrs; pmb_loc; } -> - check "module" loc module_names name.txt; + check_name check_module names name; let modl = type_module ~alias:true true funct_body (anchor_submodule name.txt anchor) env smodl in @@ -1218,7 +1273,7 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = sbind in List.iter - (fun (name, _, _, _, _) -> check "module" loc module_names name.txt) + (fun (name, _, _, _, _) -> check_name check_module names name) sbind; let (decls, newenv) = transl_recmodule_modtypes loc env @@ -1239,7 +1294,16 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = decls sbind in let newenv = (* allow aliasing recursive modules from outside *) List.fold_left - (fun env md -> Env.add_module md.md_id md.md_type.mty_type env) + (fun env md -> + let mdecl = + { + md_type = md.md_type.mty_type; + md_attributes = md.md_attributes; + md_loc = md.md_loc; + } + in + Env.add_module_declaration md.md_id mdecl env + ) env decls in let bindings2 = @@ -1256,15 +1320,15 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = | Pstr_modtype pmtd -> (* check that it is non-abstract *) let newenv, mtd, sg = - transl_modtype_decl modtype_names env loc pmtd + transl_modtype_decl names env loc pmtd in Tstr_modtype mtd, [sg], newenv - | Pstr_open (ovf, lid, attrs) -> - let (path, newenv) = type_open ovf ~toplevel env loc lid in - Tstr_open (ovf, path, lid, attrs), [], newenv + | Pstr_open sod -> + let (path, newenv, od) = type_open ~toplevel env sod in + Tstr_open od, [], newenv | Pstr_class cl -> List.iter - (fun {pci_name = name} -> check "type" loc type_names name.txt) + (fun {pci_name} -> check_name check_type names pci_name) cl; let (classes, new_env) = Typeclass.class_declarations env cl in Tstr_class @@ -1291,7 +1355,7 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = new_env | Pstr_class_type cl -> List.iter - (fun {pci_name = name} -> check "type" loc type_names name.txt) + (fun {pci_name} -> check_name check_type names pci_name) cl; let (classes, new_env) = Typeclass.class_type_declarations env cl in Tstr_class_type @@ -1310,40 +1374,26 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = Sig_type(i'', d'', rs)]) classes []), new_env - | Pstr_include (smodl, attrs) -> + | Pstr_include sincl -> + let smodl = sincl.pincl_mod in let modl = type_module true funct_body None env smodl in (* Rename all identifiers bound by this signature to avoid clashes *) let sg = Subst.signature Subst.identity (extract_sig_open env smodl.pmod_loc modl.mod_type) in - let sg = - match modl.mod_desc with - Tmod_ident (p, _) when not (Env.is_functor_arg p env) -> - Env.add_required_global (Path.head p); - let pos = ref 0 in - List.map - (function - | Sig_module (id, md, rs) -> - let n = !pos in incr pos; - Sig_module (id, {md with md_type = - Mty_alias (Pdot(p,Ident.name id,n))}, - rs) - | Sig_value (_, {val_kind=Val_reg}) | Sig_exception _ - | Sig_class _ as it -> - incr pos; it - | Sig_value _ | Sig_type _ | Sig_modtype _ - | Sig_class_type _ as it -> - it) - sg - | _ -> sg - in - List.iter - (check_sig_item type_names module_names modtype_names loc) sg; + List.iter (check_sig_item names loc) sg; let new_env = Env.add_signature sg env in - Tstr_include (modl, sg, attrs), sg, new_env - | Pstr_extension ((s, _), _) -> - raise (Error (s.loc, env, Extension s.txt)) + let incl = + { incl_mod = modl; + incl_type = sg; + incl_attributes = sincl.pincl_attributes; + incl_loc = sincl.pincl_loc; + } + in + Tstr_include incl, sg, new_env + | Pstr_extension (ext, _attrs) -> + raise (Error_forward (Typetexp.error_of_extension ext)) | Pstr_attribute x -> - let _back = Typetexp.warning_attribute [x] in + Typetexp.warning_attribute [x]; Tstr_attribute x, [], env in let rec type_struct env sstr = @@ -1363,8 +1413,10 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = (* moved to genannot *) List.iter (function {pstr_loc = l} -> Stypes.record_phrase l) sstr; let previous_saved_types = Cmt_format.get_saved_types () in + Typetexp.warning_enter_scope (); let (items, sg, final_env) = type_struct env sstr in let str = { str_items = items; str_type = sg; str_final_env = final_env } in + Typetexp.warning_leave_scope (); Cmt_format.set_saved_types (Cmt_format.Partial_structure str :: previous_saved_types); str, sg, final_env @@ -1391,48 +1443,13 @@ and normalize_signature_item env = function | Sig_module(id, md, _) -> normalize_modtype env md.md_type | _ -> () -(* Simplify multiple specifications of a value or an exception in a signature. - (Other signature components, e.g. types, modules, etc, are checked for - name uniqueness.) If multiple specifications with the same name, - keep only the last (rightmost) one. *) - -let rec simplify_modtype mty = - match mty with - Mty_ident path -> mty - | Mty_alias path -> mty - | Mty_functor(id, arg, res) -> Mty_functor(id, arg, simplify_modtype res) - | Mty_signature sg -> Mty_signature(simplify_signature sg) - -and simplify_signature sg = - let rec simplif val_names exn_names res = function - [] -> res - | (Sig_value(id, descr) as component) :: sg -> - let name = Ident.name id in - simplif (StringSet.add name val_names) exn_names - (if StringSet.mem name val_names then res else component :: res) - sg - | (Sig_exception(id, decl) as component) :: sg -> - let name = Ident.name id in - simplif val_names (StringSet.add name exn_names) - (if StringSet.mem name exn_names then res else component :: res) - sg - | Sig_module(id, md, rs) :: sg -> - let md = {md with md_type = simplify_modtype md.md_type} in - simplif val_names exn_names - (Sig_module(id, md, rs) :: res) sg - | component :: sg -> - simplif val_names exn_names (component :: res) sg - in - simplif StringSet.empty StringSet.empty [] (List.rev sg) - (* Extract the module type of a module expression *) let type_module_type_of env smod = let tmty = match smod.pmod_desc with | Pmod_ident lid -> (* turn off strengthening in this case *) - let path = Typetexp.find_module env smod.pmod_loc lid.txt in - let md = Env.find_module path env in + let path, md = Typetexp.find_module env smod.pmod_loc lid.txt in rm { mod_desc = Tmod_ident (path, lid); mod_type = md.md_type; mod_env = env; @@ -1442,8 +1459,6 @@ let type_module_type_of env smod = let mty = tmty.mod_type in (* PR#6307: expand aliases at root and submodules *) let mty = Mtype.remove_aliases env mty in - (* PR#5037: clean up inferred signature to remove duplicate specs *) - let mty = simplify_modtype mty in (* PR#5036: must not contain non-generalized type variables *) if not (closed_modtype mty) then raise(Error(smod.pmod_loc, env, Non_generalizable_module mty)); @@ -1501,10 +1516,11 @@ let () = Typecore.type_module := type_module; Typetexp.transl_modtype_longident := transl_modtype_longident; Typetexp.transl_modtype := transl_modtype; - Typecore.type_open := type_open ?toplevel:None; + Typecore.type_open := type_open_ ?toplevel:None; Typecore.type_package := type_package; type_module_type_of_fwd := type_module_type_of + (* Typecheck an implementation file *) let type_implementation sourcefile outputprefix modulename initial_env ast = @@ -1512,6 +1528,11 @@ let type_implementation sourcefile outputprefix modulename initial_env ast = try Typecore.reset_delayed_checks (); Env.reset_required_globals (); + begin + let map = Typetexp.emit_external_warnings in + ignore (map.Ast_mapper.structure map ast) + end; + let (str, sg, finalenv) = type_structure initial_env ast (Location.in_file sourcefile) in let simple_sg = simplify_signature sg in @@ -1530,7 +1551,8 @@ let type_implementation sourcefile outputprefix modulename initial_env ast = raise(Error(Location.in_file sourcefile, Env.empty, Interface_not_compiled sourceintf)) in let dclsig = Env.read_signature modulename intf_file in - let coercion = Includemod.compunit sourcefile sg intf_file dclsig in + let coercion = + Includemod.compunit initial_env sourcefile sg intf_file dclsig in Typecore.force_delayed_checks (); (* It is important to run these checks after the inclusion test above, so that value declarations which are not used internally but exported @@ -1542,7 +1564,7 @@ let type_implementation sourcefile outputprefix modulename initial_env ast = check_nongen_schemes finalenv str.str_items; normalize_signature finalenv simple_sg; let coercion = - Includemod.compunit sourcefile sg + Includemod.compunit initial_env sourcefile sg "(inferred signature)" simple_sg in Typecore.force_delayed_checks (); (* See comment above. Here the target signature contains all @@ -1571,6 +1593,13 @@ let save_signature modname tsg outputprefix source_file initial_env cmi = Cmt_format.save_cmt (outputprefix ^ ".cmti") modname (Cmt_format.Interface tsg) (Some source_file) initial_env (Some cmi) +let type_interface env ast = + begin + let map = Typetexp.emit_external_warnings in + ignore (map.Ast_mapper.signature map ast) + end; + transl_signature env ast + (* "Packaging" of several compilation units into one unit having them as sub-modules. *) @@ -1587,7 +1616,7 @@ let rec package_signatures subst = function Trec_not) :: package_signatures (Subst.add_module oldid (Pident newid) subst) rem -let package_units objfiles cmifile modulename = +let package_units initial_env objfiles cmifile modulename = (* Read the signatures of the units *) let units = List.map @@ -1596,7 +1625,7 @@ let package_units objfiles cmifile modulename = let modname = String.capitalize(Filename.basename pref) in let sg = Env.read_signature modname (pref ^ ".cmi") in if Filename.check_suffix f ".cmi" && - not(Mtype.no_code_needed_sig Env.initial sg) + not(Mtype.no_code_needed_sig Env.initial_safe_string sg) then raise(Error(Location.none, Env.empty, Implementation_is_required f)); (modname, Env.read_signature modname (pref ^ ".cmi"))) @@ -1614,22 +1643,22 @@ let package_units objfiles cmifile modulename = end; let dclsig = Env.read_signature modulename cmifile in Cmt_format.save_cmt (prefix ^ ".cmt") modulename - (Cmt_format.Packed (sg, objfiles)) None Env.initial None ; - Includemod.compunit "(obtained by packing)" sg mlifile dclsig + (Cmt_format.Packed (sg, objfiles)) None initial_env None ; + Includemod.compunit initial_env "(obtained by packing)" sg mlifile dclsig end else begin (* Determine imports *) let unit_names = List.map fst units in let imports = List.filter (fun (name, crc) -> not (List.mem name unit_names)) - (Env.imported_units()) in + (Env.imports()) in (* Write packaged signature *) if not !Clflags.dont_write_files then begin let sg = Env.save_signature_with_imports sg modulename (prefix ^ ".cmi") imports in Cmt_format.save_cmt (prefix ^ ".cmt") modulename - (Cmt_format.Packed (sg, objfiles)) None Env.initial (Some sg) + (Cmt_format.Packed (sg, objfiles)) None initial_env (Some sg) end; Tcoerce_none end @@ -1712,8 +1741,6 @@ let report_error ppf = function "The type %a in this module cannot be exported.@ " longident lid; fprintf ppf "Its type contains local dependencies:@ %a" type_expr ty - | Extension s -> - fprintf ppf "Uninterpreted extension '%s'." s | Recursive_module_require_explicit_type -> fprintf ppf "Recursive modules require an explicit module type." | Apply_generative -> @@ -1727,6 +1754,8 @@ let () = (function | Error (loc, env, err) -> Some (Location.error_of_printer loc (report_error env) err) + | Error_forward err -> + Some err | _ -> None ) diff --git a/typing/typemod.mli b/typing/typemod.mli index 051a28360..889501788 100644 --- a/typing/typemod.mli +++ b/typing/typemod.mli @@ -26,18 +26,24 @@ val type_toplevel_phrase: val type_implementation: string -> string -> string -> Env.t -> Parsetree.structure -> Typedtree.structure * Typedtree.module_coercion +val type_interface: + Env.t -> Parsetree.signature -> Typedtree.signature val transl_signature: Env.t -> Parsetree.signature -> Typedtree.signature val check_nongen_schemes: Env.t -> Typedtree.structure_item list -> unit +val type_open_: + ?toplevel:bool -> Asttypes.override_flag -> + Env.t -> Location.t -> Longident.t Asttypes.loc -> Path.t * Env.t val simplify_signature: signature -> signature -val save_signature : string -> Typedtree.signature -> string -> string -> +val save_signature: + string -> Typedtree.signature -> string -> string -> Env.t -> Types.signature_item list -> unit val package_units: - string list -> string -> string -> Typedtree.module_coercion + Env.t -> string list -> string -> string -> Typedtree.module_coercion type error = Cannot_apply of module_type @@ -58,10 +64,10 @@ type error = | Not_a_packed_module of type_expr | Incomplete_packed_module of type_expr | Scoping_pack of Longident.t * type_expr - | Extension of string | Recursive_module_require_explicit_type | Apply_generative exception Error of Location.t * Env.t * error +exception Error_forward of Location.error val report_error: Env.t -> formatter -> error -> unit diff --git a/typing/types.ml b/typing/types.ml index 3eff6c70a..1aff7356f 100644 --- a/typing/types.ml +++ b/typing/types.ml @@ -103,51 +103,6 @@ and value_kind = (* Ancestor *) | Val_unbound (* Unbound variable *) -(* Constructor descriptions *) - -type constructor_description = - { cstr_name: string; (* Constructor name *) - cstr_res: type_expr; (* Type of the result *) - cstr_existentials: type_expr list; (* list of existentials *) - cstr_args: type_expr list; (* Type of the arguments *) - cstr_arity: int; (* Number of arguments *) - cstr_tag: constructor_tag; (* Tag for heap blocks *) - cstr_consts: int; (* Number of constant constructors *) - cstr_nonconsts: int; (* Number of non-const constructors *) - cstr_normal: int; (* Number of non generalized constrs *) - cstr_generalized: bool; (* Constrained return type? *) - cstr_private: private_flag; (* Read-only constructor? *) - cstr_loc: Location.t; - cstr_attributes: Parsetree.attributes; - cstr_inlined: bool; - } - -and constructor_tag = - Cstr_constant of int (* Constant constructor (an int) *) - | Cstr_block of int (* Regular constructor (a block) *) - | Cstr_exception of Path.t * Location.t (* Exception constructor *) - -(* Record label descriptions *) - -type label_description = - { lbl_name: string; (* Short name *) - lbl_res: type_expr; (* Type of the result *) - lbl_arg: type_expr; (* Type of the argument *) - lbl_mut: mutable_flag; (* Is this a mutable field? *) - lbl_pos: int; (* Position in block *) - lbl_all: label_description array; (* All the labels in this type *) - lbl_repres: record_representation; (* Representation for this record *) - lbl_private: private_flag; (* Read-only field? *) - lbl_loc: Location.t; - lbl_attributes: Parsetree.attributes; - } - -and record_representation = - Record_regular (* All fields are boxed / tagged *) - | Record_inlined of int (* Same, for inlined records *) - | Record_float (* All fields are floats *) - | Record_exception of Path.t (* Inlined record under exception *) - (* Variance *) module Variance = struct @@ -196,6 +151,13 @@ and type_kind = Type_abstract | Type_record of label_declaration list * record_representation | Type_variant of constructor_declaration list + | Type_open + +and record_representation = + Record_regular (* All fields are boxed / tagged *) + | Record_float (* All fields are floats *) + | Record_inlined of int (* Inlined record *) + | Record_extension (* Inlined record under extension *) and label_declaration = { @@ -209,26 +171,30 @@ and label_declaration = and constructor_declaration = { cd_id: Ident.t; - cd_args: type_expr list; + cd_args: constructor_arguments; cd_res: type_expr option; cd_loc: Location.t; cd_attributes: Parsetree.attributes; - cd_inlined: bool; } +and constructor_arguments = + | Cstr_tuple of type_expr list + | Cstr_record of label_declaration list + +type extension_constructor = + { ext_type_path: Path.t; + ext_type_params: type_expr list; + ext_args: constructor_arguments; + ext_ret_type: type_expr option; + ext_private: private_flag; + ext_loc: Location.t; + ext_attributes: Parsetree.attributes; } and type_transparence = Type_public (* unrestricted expansion *) | Type_new (* "new" type *) | Type_private (* private type *) -type exception_declaration = - { exn_args: type_expr list; - exn_loc: Location.t; - exn_attributes: Parsetree.attributes; - exn_inlined: bool; (* merge with constructor_declaration? *) - } - (* Type expressions for the class language *) module Concr = Set.Make(OrderedString) @@ -277,7 +243,7 @@ and signature = signature_item list and signature_item = Sig_value of Ident.t * value_description | Sig_type of Ident.t * type_declaration * rec_status - | Sig_exception of Ident.t * exception_declaration + | Sig_typext of Ident.t * extension_constructor * ext_status | Sig_module of Ident.t * module_declaration * rec_status | Sig_modtype of Ident.t * modtype_declaration | Sig_class of Ident.t * class_declaration * rec_status @@ -301,3 +267,48 @@ and rec_status = Trec_not (* not recursive *) | Trec_first (* first in a recursive group *) | Trec_next (* not first in a recursive group *) + +and ext_status = + Text_first (* first constructor of an extension *) + | Text_next (* not first constructor of an extension *) + | Text_exception (* an exception *) + + +(* Constructor and record label descriptions inserted held in typing + environments *) + +type constructor_description = + { cstr_name: string; (* Constructor name *) + cstr_res: type_expr; (* Type of the result *) + cstr_existentials: type_expr list; (* list of existentials *) + cstr_args: type_expr list; (* Type of the arguments *) + cstr_arity: int; (* Number of arguments *) + cstr_tag: constructor_tag; (* Tag for heap blocks *) + cstr_consts: int; (* Number of constant constructors *) + cstr_nonconsts: int; (* Number of non-const constructors *) + cstr_normal: int; (* Number of non generalized constrs *) + cstr_generalized: bool; (* Constrained return type? *) + cstr_private: private_flag; (* Read-only constructor? *) + cstr_loc: Location.t; + cstr_attributes: Parsetree.attributes; + cstr_inlined: type_declaration option; + } + +and constructor_tag = + Cstr_constant of int (* Constant constructor (an int) *) + | Cstr_block of int (* Regular constructor (a block) *) + | Cstr_extension of Path.t * bool (* Extension constructor + true if a constant false if a block*) + +type label_description = + { lbl_name: string; (* Short name *) + lbl_res: type_expr; (* Type of the result *) + lbl_arg: type_expr; (* Type of the argument *) + lbl_mut: mutable_flag; (* Is this a mutable field? *) + lbl_pos: int; (* Position in block *) + lbl_all: label_description array; (* All the labels in this type *) + lbl_repres: record_representation; (* Representation for this record *) + lbl_private: private_flag; (* Read-only field? *) + lbl_loc: Location.t; + lbl_attributes: Parsetree.attributes; + } diff --git a/typing/types.mli b/typing/types.mli index 8cf172a8f..0438f897b 100644 --- a/typing/types.mli +++ b/typing/types.mli @@ -100,51 +100,6 @@ and value_kind = (* Ancestor *) | Val_unbound (* Unbound variable *) -(* Constructor descriptions *) - -type constructor_description = - { cstr_name: string; (* Constructor name *) - cstr_res: type_expr; (* Type of the result *) - cstr_existentials: type_expr list; (* list of existentials *) - cstr_args: type_expr list; (* Type of the arguments *) - cstr_arity: int; (* Number of arguments *) - cstr_tag: constructor_tag; (* Tag for heap blocks *) - cstr_consts: int; (* Number of constant constructors *) - cstr_nonconsts: int; (* Number of non-const constructors *) - cstr_normal: int; (* Number of non generalized constrs *) - cstr_generalized: bool; (* Constrained return type? *) - cstr_private: private_flag; (* Read-only constructor? *) - cstr_loc: Location.t; - cstr_attributes: Parsetree.attributes; - cstr_inlined: bool; - } - -and constructor_tag = - Cstr_constant of int (* Constant constructor (an int) *) - | Cstr_block of int (* Regular constructor (a block) *) - | Cstr_exception of Path.t * Location.t (* Exception constructor *) - -(* Record label descriptions *) - -type label_description = - { lbl_name: string; (* Short name *) - lbl_res: type_expr; (* Type of the result *) - lbl_arg: type_expr; (* Type of the argument *) - lbl_mut: mutable_flag; (* Is this a mutable field? *) - lbl_pos: int; (* Position in block *) - lbl_all: label_description array; (* All the labels in this type *) - lbl_repres: record_representation; (* Representation for this record *) - lbl_private: private_flag; (* Read-only field? *) - lbl_loc: Location.t; - lbl_attributes: Parsetree.attributes; - } - -and record_representation = - Record_regular (* All fields are boxed / tagged *) - | Record_inlined of int (* Same, for inlined records *) - | Record_float (* All fields are floats *) - | Record_exception of Path.t (* Inlined record under exception *) - (* Variance *) module Variance : sig @@ -184,6 +139,13 @@ and type_kind = Type_abstract | Type_record of label_declaration list * record_representation | Type_variant of constructor_declaration list + | Type_open + +and record_representation = + Record_regular (* All fields are boxed / tagged *) + | Record_float (* All fields are floats *) + | Record_inlined of int (* Inlined record *) + | Record_extension (* Inlined record under extension *) and label_declaration = { @@ -197,25 +159,32 @@ and label_declaration = and constructor_declaration = { cd_id: Ident.t; - cd_args: type_expr list; + cd_args: constructor_arguments; cd_res: type_expr option; cd_loc: Location.t; cd_attributes: Parsetree.attributes; - cd_inlined: bool; } +and constructor_arguments = + | Cstr_tuple of type_expr list + | Cstr_record of label_declaration list + +type extension_constructor = + { + ext_type_path: Path.t; + ext_type_params: type_expr list; + ext_args: constructor_arguments; + ext_ret_type: type_expr option; + ext_private: private_flag; + ext_loc: Location.t; + ext_attributes: Parsetree.attributes; + } + and type_transparence = Type_public (* unrestricted expansion *) | Type_new (* "new" type *) | Type_private (* private type *) -type exception_declaration = - { exn_args: type_expr list; - exn_loc: Location.t; - exn_attributes: Parsetree.attributes; - exn_inlined: bool; (* merge with constructor_declaration? *) - } - (* Type expressions for the class language *) module Concr : Set.S with type elt = string @@ -264,7 +233,7 @@ and signature = signature_item list and signature_item = Sig_value of Ident.t * value_description | Sig_type of Ident.t * type_declaration * rec_status - | Sig_exception of Ident.t * exception_declaration + | Sig_typext of Ident.t * extension_constructor * ext_status | Sig_module of Ident.t * module_declaration * rec_status | Sig_modtype of Ident.t * modtype_declaration | Sig_class of Ident.t * class_declaration * rec_status @@ -288,3 +257,48 @@ and rec_status = Trec_not (* not recursive *) | Trec_first (* first in a recursive group *) | Trec_next (* not first in a recursive group *) + +and ext_status = + Text_first (* first constructor in an extension *) + | Text_next (* not first constructor in an extension *) + | Text_exception + + +(* Constructor and record label descriptions inserted held in typing + environments *) + +type constructor_description = + { cstr_name: string; (* Constructor name *) + cstr_res: type_expr; (* Type of the result *) + cstr_existentials: type_expr list; (* list of existentials *) + cstr_args: type_expr list; (* Type of the arguments *) + cstr_arity: int; (* Number of arguments *) + cstr_tag: constructor_tag; (* Tag for heap blocks *) + cstr_consts: int; (* Number of constant constructors *) + cstr_nonconsts: int; (* Number of non-const constructors *) + cstr_normal: int; (* Number of non generalized constrs *) + cstr_generalized: bool; (* Constrained return type? *) + cstr_private: private_flag; (* Read-only constructor? *) + cstr_loc: Location.t; + cstr_attributes: Parsetree.attributes; + cstr_inlined: type_declaration option; + } + +and constructor_tag = + Cstr_constant of int (* Constant constructor (an int) *) + | Cstr_block of int (* Regular constructor (a block) *) + | Cstr_extension of Path.t * bool (* Extension constructor + true if a constant false if a block*) + +type label_description = + { lbl_name: string; (* Short name *) + lbl_res: type_expr; (* Type of the result *) + lbl_arg: type_expr; (* Type of the argument *) + lbl_mut: mutable_flag; (* Is this a mutable field? *) + lbl_pos: int; (* Position in block *) + lbl_all: label_description array; (* All the labels in this type *) + lbl_repres: record_representation; (* Representation for this record *) + lbl_private: private_flag; (* Read-only field? *) + lbl_loc: Location.t; + lbl_attributes: Parsetree.attributes; + } diff --git a/typing/typetexp.ml b/typing/typetexp.ml index 7af01dc3e..523d435bc 100644 --- a/typing/typetexp.ml +++ b/typing/typetexp.ml @@ -21,7 +21,7 @@ open Typedtree open Types open Ctype -exception Already_bound of Location.t +exception Already_bound type error = Unbound_type_variable of string @@ -51,48 +51,123 @@ type error = | Unbound_cltype of Longident.t | Ill_typed_functor_application of Longident.t | Illegal_reference_to_recursive_module - | Extension of string + | Access_functor_as_structure of Longident.t exception Error of Location.t * Env.t * error +exception Error_forward of Location.error + +let string_of_cst = function + | Const_string(s, _) -> Some s + | _ -> None + +let string_of_payload = function + | PStr[{pstr_desc=Pstr_eval({pexp_desc=Pexp_constant c},_)}] -> + string_of_cst c + | _ -> None + +let rec error_of_extension ext = + match ext with + | ({txt = ("ocaml.error"|"error") as txt; loc}, p) -> + let rec sub_from inner = + match inner with + | {pstr_desc=Pstr_extension (ext, _)} :: rest -> + error_of_extension ext :: sub_from rest + | {pstr_loc} :: rest -> + (Location.errorf ~loc + "Invalid syntax for sub-error of extension '%s'." txt) :: + sub_from rest + | [] -> [] + in + begin match p with + | PStr({pstr_desc=Pstr_eval + ({pexp_desc=Pexp_constant(Const_string(msg,_))}, _)}:: + {pstr_desc=Pstr_eval + ({pexp_desc=Pexp_constant(Const_string(if_highlight,_))}, _)}:: + inner) -> + Location.error ~loc ~if_highlight ~sub:(sub_from inner) msg + | PStr({pstr_desc=Pstr_eval + ({pexp_desc=Pexp_constant(Const_string(msg,_))}, _)}::inner) -> + Location.error ~loc ~sub:(sub_from inner) msg + | _ -> Location.errorf ~loc "Invalid syntax for extension '%s'." txt + end + | ({txt; loc}, _) -> + Location.errorf ~loc "Uninterpreted extension '%s'." txt let check_deprecated loc attrs s = - if - List.exists - (function ({txt = "deprecated"; _}, _) -> true | _ -> false) - attrs - then - Location.prerr_warning loc (Warnings.Deprecated s) + List.iter + (function + | ({txt = "ocaml.deprecated"|"deprecated"; _}, p) -> + begin match string_of_payload p with + | Some txt -> + Location.prerr_warning loc (Warnings.Deprecated (s ^ "\n" ^ txt)) + | None -> + Location.prerr_warning loc (Warnings.Deprecated s) + end + | _ -> ()) + attrs + +let emit_external_warnings = + (* Note: this is run as a preliminary pass when type-checking an + interface or implementation. This allows to cover all kinds of + attributes, but the drawback is that it doesn't take local + configuration of warnings (with '@@warning'/'@@warnerror' + attributes) into account. We should rather check for + 'ppwarning' attributes during the actual type-checking, making + sure to cover all contexts (easier and more ugly alternative: + duplicate here the logic which control warnings locally). *) + let open Ast_mapper in + { + default_mapper with + attribute = (fun _ a -> + begin match a with + | {txt="ocaml.ppwarning"|"ppwarning"}, + PStr[{pstr_desc=Pstr_eval({pexp_desc=Pexp_constant + (Const_string (s, _))},_); + pstr_loc}] -> + Location.prerr_warning pstr_loc (Warnings.Preprocessor s) + | _ -> () + end; + a + ) + } + + +let warning_scope = ref [] + +let warning_enter_scope () = + warning_scope := (Warnings.backup ()) :: !warning_scope +let warning_leave_scope () = + match !warning_scope with + | [] -> assert false + | hd :: tl -> + Warnings.restore hd; + warning_scope := tl let warning_attribute attrs = - let prev_warnings = ref None in + let process loc txt errflag payload = + match string_of_payload payload with + | Some s -> + begin try Warnings.parse_options errflag s + with Arg.Bad _ -> + Location.prerr_warning loc + (Warnings.Attribute_payload + (txt, "Ill-formed list of warnings")) + end + | None -> + Location.prerr_warning loc + (Warnings.Attribute_payload + (txt, "A single string literal is expected")) + in List.iter (function - | ({txt = "warning"; loc}, payload) -> - begin match payload with - | PStr [{pstr_desc=Pstr_eval - ({pexp_desc=Pexp_constant(Const_string(s, _))}, _)}] -> - if !prev_warnings = None then - prev_warnings := Some (Warnings.backup ()); - begin try Warnings.parse_options false s - with Arg.Bad _ -> - Location.prerr_warning loc - (Warnings.Attribute_payload - ("warning", - "Ill-formed list of warnings")) - end - | _ -> - Location.prerr_warning loc - (Warnings.Attribute_payload - ("warning", - "A single string literal is expected")) - end + | ({txt = ("ocaml.warning"|"warning") as txt; loc}, payload) -> + process loc txt false payload + | ({txt = ("ocaml.warnerror"|"warnerror") as txt; loc}, payload) -> + process loc txt true payload | _ -> () ) - attrs; - !prev_warnings - - + attrs type variable_context = int * (string, type_expr) Tbl.t @@ -105,16 +180,22 @@ let instance_list = Ctype.instance_list Env.empty let rec narrow_unbound_lid_error : 'a. _ -> _ -> _ -> _ -> 'a = fun env loc lid make_error -> let check_module mlid = - try ignore (Env.lookup_module mlid env) - with Not_found -> - narrow_unbound_lid_error env loc mlid - (fun lid -> Unbound_module lid) - | Env.Recmodule -> - raise (Error (loc, env, Illegal_reference_to_recursive_module)) + try ignore (Env.lookup_module true mlid env) with + | Not_found -> + narrow_unbound_lid_error env loc mlid (fun lid -> Unbound_module lid) + | Env.Recmodule -> + raise (Error (loc, env, Illegal_reference_to_recursive_module)) in begin match lid with | Longident.Lident _ -> () - | Longident.Ldot (mlid, _) -> check_module mlid + | Longident.Ldot (mlid, _) -> + check_module mlid; + let md = Env.find_module (Env.lookup_module true mlid env) env in + begin match Env.scrape_alias env md.md_type with + Mty_functor _ -> + raise (Error (loc, env, Access_functor_as_structure mlid)) + | _ -> () + end | Longident.Lapply (flid, mlid) -> check_module flid; check_module mlid; @@ -126,7 +207,7 @@ let find_component lookup make_error env loc lid = try match lid with | Longident.Ldot (Longident.Lident "*predef*", s) -> - lookup (Longident.Lident s) Env.initial + lookup (Longident.Lident s) Env.initial_safe_string | _ -> lookup lid env with Not_found -> narrow_unbound_lid_error env loc lid make_error @@ -165,13 +246,17 @@ let find_value env loc lid = check_deprecated loc decl.val_attributes (Path.name path); r -let find_module env loc lid = +let lookup_module ?(load=false) env loc lid = let (path, decl) as r = - find_component (fun lid env -> (Env.lookup_module lid env, ())) + find_component (fun lid env -> (Env.lookup_module ~load lid env, ())) (fun lid -> Unbound_module lid) env loc lid - in - (* check_deprecated loc decl.md_attributes (Path.name path); *) - path + in path + +let find_module env loc lid = + let path = lookup_module ~load:true env loc lid in + let decl = Env.find_module path env in + check_deprecated loc decl.md_attributes (Path.name path); + (path, decl) let find_modtype env loc lid = let (path, decl) as r = @@ -258,24 +343,35 @@ let new_global_var ?name () = let newvar ?name () = newvar ?name:(validate_name name) () -let enter_type_variable {Location.txt=name; loc} = - try - if name <> "" && name.[0] = '_' then - raise (Error (loc, Env.empty, Invalid_variable_name ("'" ^ name))); - let v = Tbl.find name !type_variables in - raise (Already_bound loc); - v - with Not_found -> - let v = new_global_var ~name () in - type_variables := Tbl.add name v !type_variables; - v - let type_variable loc name = try Tbl.find name !type_variables with Not_found -> raise(Error(loc, Env.empty, Unbound_type_variable ("'" ^ name))) +let transl_type_param env styp = + let loc = styp.ptyp_loc in + match styp.ptyp_desc with + Ptyp_any -> + let ty = new_global_var ~name:"_" () in + { ctyp_desc = Ttyp_any; ctyp_type = ty; ctyp_env = env; + ctyp_loc = loc; ctyp_attributes = styp.ptyp_attributes; } + | Ptyp_var name -> + let ty = + try + if name <> "" && name.[0] = '_' then + raise (Error (loc, Env.empty, Invalid_variable_name ("'" ^ name))); + ignore (Tbl.find name !type_variables); + raise Already_bound + with Not_found -> + let v = new_global_var ~name () in + type_variables := Tbl.add name v !type_variables; + v + in + { ctyp_desc = Ttyp_var name; ctyp_type = ty; ctyp_env = env; + ctyp_loc = loc; ctyp_attributes = styp.ptyp_attributes; } + | _ -> assert false + let wrap_method ty = match (Ctype.repr ty).desc with Tpoly _ -> ty @@ -328,14 +424,22 @@ let rec transl_type env policy styp = let ty = newty (Tarrow(l, cty1.ctyp_type, cty2.ctyp_type, Cok)) in ctyp (Ttyp_arrow (l, cty1, cty2)) ty | Ptyp_tuple stl -> + if List.length stl < 2 then + Syntaxerr.ill_formed_ast loc "Tuples must have at least 2 components."; let ctys = List.map (transl_type env policy) stl in let ty = newty (Ttuple (List.map (fun ctyp -> ctyp.ctyp_type) ctys)) in ctyp (Ttyp_tuple ctys) ty | Ptyp_constr(lid, stl) -> let (path, decl) = find_type env styp.ptyp_loc lid.txt in + let stl = + match stl with + | [ {ptyp_desc=Ptyp_any} as t ] when decl.type_arity > 1 -> + List.map (fun _ -> t) decl.type_params + | _ -> stl + in if List.length stl <> decl.type_arity then raise(Error(styp.ptyp_loc, env, - Type_arity_mismatch(lid.txt, decl.type_arity, + Type_arity_mismatch(lid.txt, decl.type_arity, List.length stl))); let args = List.map (transl_type env policy) stl in let params = instance_list decl.type_params in @@ -360,7 +464,7 @@ let rec transl_type env policy styp = ctyp (Ttyp_constr (path, lid, args)) constr | Ptyp_object (fields, o) -> let fields = - List.map (fun (s, t) -> (s, transl_poly_type env policy t)) + List.map (fun (s, a, t) -> (s, a, transl_poly_type env policy t)) fields in let ty = newobj (transl_fields loc env policy [] o fields) in @@ -392,7 +496,7 @@ let rec transl_type env policy styp = let (path, decl) = Env.lookup_type lid2 env in (path, decl, false) with Not_found -> - raise(Error(styp.ptyp_loc, env, Unbound_class lid.txt)) + ignore (find_class env styp.ptyp_loc lid.txt); assert false in if List.length stl <> decl.type_arity then raise(Error(styp.ptyp_loc, env, @@ -502,7 +606,7 @@ let rec transl_type env policy styp = Hashtbl.add hfields h (l,f) in let add_field = function - Rtag (l, c, stl) -> + Rtag (l, attrs, c, stl) -> name := None; let tl = List.map (transl_type env policy) stl in let f = match present with @@ -517,7 +621,7 @@ let rec transl_type env policy styp = Rpresent (Some st.ctyp_type) in add_typed_field styp.ptyp_loc l f; - Ttag (l,c,tl) + Ttag (l,attrs,c,tl) | Rinherit sty -> let cty = transl_type env policy sty in let ty = cty.ctyp_type in @@ -623,13 +727,13 @@ let rec transl_type env policy styp = List.map (fun (_,cty) -> cty.ctyp_type) ptys)) in ctyp (Ttyp_package { - pack_name = path; + pack_path = path; pack_type = mty.mty_type; pack_fields = ptys; pack_txt = p; }) ty - | Ptyp_extension (s, _arg) -> - raise (Error (s.loc, env, Extension s.txt)) + | Ptyp_extension ext -> + raise (Error_forward (error_of_extension ext)) and transl_poly_type env policy t = transl_type env policy (Ast_helper.Typ.force_poly t) @@ -642,7 +746,7 @@ and transl_fields loc env policy seen o = | Open, Univars -> new_pre_univar () | Open, _ -> newvar () end - | (s, ty1) :: l -> + | (s, _attrs, ty1) :: l -> if List.mem s seen then raise (Error (loc, env, Repeated_method_label s)); let ty2 = transl_fields loc env policy (s :: seen) o l in newty (Tfield (s, Fpresent, ty1.ctyp_type, ty2)) @@ -843,8 +947,8 @@ let report_error env ppf = function fprintf ppf "The present constructor %s has no type" l | Constructor_mismatch (ty, ty') -> wrap_printing_env env (fun () -> - Printtyp.reset_and_mark_loops_list [ty; ty']; - fprintf ppf "@[<hov>%s %a@ %s@ %a@]" + Printtyp.reset_and_mark_loops_list [ty; ty']; + fprintf ppf "@[<hov>%s %a@ %s@ %a@]" "This variant type contains a constructor" Printtyp.type_expr ty "which should be" @@ -880,7 +984,7 @@ let report_error env ppf = function | Unbound_constructor lid -> fprintf ppf "Unbound constructor %a" longident lid; spellcheck_simple ppf Env.fold_constructors (fun d -> d.cstr_name) - env lid; + env lid; | Unbound_label lid -> fprintf ppf "Unbound record field %a" longident lid; spellcheck_simple ppf Env.fold_labels (fun d -> d.lbl_name) env lid; @@ -897,15 +1001,16 @@ let report_error env ppf = function fprintf ppf "Ill-typed functor application %a" longident lid | Illegal_reference_to_recursive_module -> fprintf ppf "Illegal recursive module reference" - | Extension s -> - fprintf ppf "Uninterpreted extension '%s'." s + | Access_functor_as_structure lid -> + fprintf ppf "The module %a is a functor, not a structure" longident lid let () = Location.register_error_of_exn (function | Error (loc, env, err) -> Some (Location.error_of_printer loc (report_error env) err) + | Error_forward err -> + Some err | _ -> None ) - diff --git a/typing/typetexp.mli b/typing/typetexp.mli index 1d90eb759..7bff403f0 100644 --- a/typing/typetexp.mli +++ b/typing/typetexp.mli @@ -25,14 +25,15 @@ val transl_simple_type_delayed: val transl_type_scheme: Env.t -> Parsetree.core_type -> Typedtree.core_type val reset_type_variables: unit -> unit -val enter_type_variable: string Location.loc -> type_expr val type_variable: Location.t -> string -> type_expr +val transl_type_param: + Env.t -> Parsetree.core_type -> Typedtree.core_type type variable_context val narrow: unit -> variable_context val widen: variable_context -> unit -exception Already_bound of Location.t +exception Already_bound type error = Unbound_type_variable of string @@ -62,7 +63,7 @@ type error = | Unbound_cltype of Longident.t | Ill_typed_functor_application of Longident.t | Illegal_reference_to_recursive_module - | Extension of string + | Access_functor_as_structure of Longident.t exception Error of Location.t * Env.t * error @@ -95,7 +96,9 @@ val find_value: val find_class: Env.t -> Location.t -> Longident.t -> Path.t * class_declaration val find_module: - Env.t -> Location.t -> Longident.t -> Path.t + Env.t -> Location.t -> Longident.t -> Path.t * module_declaration +val lookup_module: + ?load:bool -> Env.t -> Location.t -> Longident.t -> Path.t val find_modtype: Env.t -> Location.t -> Longident.t -> Path.t * modtype_declaration val find_class_type: @@ -112,4 +115,10 @@ val spellcheck_simple: val check_deprecated: Location.t -> Parsetree.attributes -> string -> unit -val warning_attribute: Parsetree.attributes -> Warnings.state option +val warning_enter_scope: unit -> unit +val warning_leave_scope: unit -> unit +val warning_attribute: Parsetree.attributes -> unit + +val error_of_extension: Parsetree.extension -> Location.error + +val emit_external_warnings: Ast_mapper.mapper diff --git a/utils/clflags.ml b/utils/clflags.ml index 829393a00..57834ccf9 100644 --- a/utils/clflags.ml +++ b/utils/clflags.ml @@ -43,12 +43,14 @@ and noprompt = ref false (* -noprompt *) and nopromptcont = ref false (* -nopromptcont *) and init_file = ref (None : string option) (* -init *) and noinit = ref false (* -noinit *) +and open_modules = ref [] (* -open *) and use_prims = ref "" (* -use-prims ... *) and use_runtime = ref "" (* -use-runtime ... *) and principal = ref false (* -principal *) and real_paths = ref true (* -short-paths *) and recursive_types = ref false (* -rectypes *) and strict_sequence = ref false (* -strict-sequence *) +and strict_formats = ref false (* -strict-formats *) and applicative_functors = ref true (* -no-app-funct *) and make_runtime = ref false (* -make-runtime *) and gprofile = ref false (* -p *) @@ -58,6 +60,7 @@ and dllpaths = ref ([] : string list) (* -dllpath *) and make_package = ref false (* -pack *) and for_package = ref (None: string option) (* -for-pack *) and error_size = ref 500 (* -error-size *) +and float_const_prop = ref true (* -no-float-const-prop *) and transparent_modules = ref false (* -trans-mod *) let dump_source = ref false (* -dsource *) let dump_parsetree = ref false (* -dparsetree *) @@ -69,9 +72,11 @@ and dump_instr = ref false (* -dinstr *) let keep_asm_file = ref false (* -S *) let optimize_for_speed = ref true (* -compact *) +and opaque = ref false (* -opaque *) and dump_cmm = ref false (* -dcmm *) let dump_selection = ref false (* -dsel *) +let dump_cse = ref false (* -dcse *) let dump_live = ref false (* -dlive *) let dump_spill = ref false (* -dspill *) let dump_split = ref false (* -dsplit *) @@ -83,7 +88,6 @@ let dump_scheduling = ref false (* -dscheduling *) let dump_linear = ref false (* -dlinear *) let keep_startup_file = ref false (* -dstartup *) let dump_combine = ref false (* -dcombine *) - let native_code = ref false (* set to true under ocamlopt *) let inline_threshold = ref 10 let force_slash = ref false (* for ocamldep *) @@ -105,3 +109,4 @@ let dlcode = ref true (* not -nodynlink *) let runtime_variant = ref "";; (* -runtime-variant *) let keep_locs = ref false (* -keep-locs *) +let unsafe_string = ref true;; (* -safe-string / -unsafe-string *) diff --git a/utils/clflags.mli b/utils/clflags.mli index 876776acd..7e51cf33d 100644 --- a/utils/clflags.mli +++ b/utils/clflags.mli @@ -23,11 +23,12 @@ val debug : bool ref val fast : bool ref val link_everything : bool ref val custom_runtime : bool ref -val bytecode_compatible_32: bool ref +val bytecode_compatible_32 : bool ref val output_c_object : bool ref val all_ccopts : string list ref val classic : bool ref val nopervasives : bool ref +val open_modules : string list ref val preprocessor : string option ref val all_ppx : string list ref val annotations : bool ref @@ -46,6 +47,7 @@ val principal : bool ref val real_paths : bool ref val recursive_types : bool ref val strict_sequence : bool ref +val strict_formats : bool ref val applicative_functors : bool ref val make_runtime : bool ref val gprofile : bool ref @@ -55,6 +57,7 @@ val dllpaths : string list ref val make_package : bool ref val for_package : string option ref val error_size : int ref +val float_const_prop : bool ref val transparent_modules : bool ref val dump_source : bool ref val dump_parsetree : bool ref @@ -67,6 +70,7 @@ val keep_asm_file : bool ref val optimize_for_speed : bool ref val dump_cmm : bool ref val dump_selection : bool ref +val dump_cse : bool ref val dump_live : bool ref val dump_spill : bool ref val dump_split : bool ref @@ -88,3 +92,5 @@ val dlcode : bool ref val runtime_variant : string ref val force_slash : bool ref val keep_locs : bool ref +val unsafe_string : bool ref +val opaque : bool ref diff --git a/utils/config.mlbuild b/utils/config.mlbuild index 524558b16..c887ac2b4 100644 --- a/utils/config.mlbuild +++ b/utils/config.mlbuild @@ -60,10 +60,10 @@ let mkdll = C.mkdll let mkexe = C.mkexe let mkmaindll = C.mkmaindll -let exec_magic_number = "Caml1999X010" +let exec_magic_number = "Caml1999X011" and cmi_magic_number = "Caml1999I016" -and cmo_magic_number = "Caml1999O008" -and cma_magic_number = "Caml1999A009" +and cmo_magic_number = "Caml1999O009" +and cma_magic_number = "Caml1999A010" and cmx_magic_number = "Caml1999Y011" and cmxa_magic_number = "Caml1999Z010" and ast_impl_magic_number = "Caml1999M016" diff --git a/utils/config.mlp b/utils/config.mlp index 867b19fc6..ce216cc1f 100644 --- a/utils/config.mlp +++ b/utils/config.mlp @@ -48,16 +48,16 @@ let mkdll = "%%MKDLL%%" let mkexe = "%%MKEXE%%" let mkmaindll = "%%MKMAINDLL%%" -let exec_magic_number = "Caml1999X010" -and cmi_magic_number = "Caml1999I017" -and cmo_magic_number = "Caml1999O008" -and cma_magic_number = "Caml1999A009" -and cmx_magic_number = "Caml1999Y012" -and cmxa_magic_number = "Caml1999Z011" -and ast_impl_magic_number = "Caml1999M016" -and ast_intf_magic_number = "Caml1999N015" -and cmxs_magic_number = "Caml2007D001" -and cmt_magic_number = "Caml2012T003" +let exec_magic_number = "Caml1999X011" +and cmi_magic_number = "Caml1999I018" +and cmo_magic_number = "Caml1999O010" +and cma_magic_number = "Caml1999A011" +and cmx_magic_number = "Caml1999Y014" +and cmxa_magic_number = "Caml1999Z013" +and ast_impl_magic_number = "Caml1999M017" +and ast_intf_magic_number = "Caml1999N016" +and cmxs_magic_number = "Caml2007D002" +and cmt_magic_number = "Caml2012T005" let load_path = ref ([] : string list) diff --git a/utils/consistbl.ml b/utils/consistbl.ml index 4bc42dc5b..37f6a2b1e 100644 --- a/utils/consistbl.ml +++ b/utils/consistbl.ml @@ -40,8 +40,16 @@ let set tbl name crc source = Hashtbl.add tbl name (crc, source) let source tbl name = snd (Hashtbl.find tbl name) -let extract tbl = - Hashtbl.fold (fun name (crc, auth) accu -> (name, crc) :: accu) tbl [] +let extract l tbl = + let l = List.sort_uniq String.compare l in + List.fold_left + (fun assc name -> + try + let (crc, _) = Hashtbl.find tbl name in + (name, Some crc) :: assc + with Not_found -> + (name, None) :: assc) + [] l let filter p tbl = let to_remove = ref [] in diff --git a/utils/consistbl.mli b/utils/consistbl.mli index d3f2afcec..012bd734f 100644 --- a/utils/consistbl.mli +++ b/utils/consistbl.mli @@ -40,9 +40,10 @@ val source: t -> string -> string if the latter has an associated CRC in [tbl]. Raise [Not_found] otherwise. *) -val extract: t -> (string * Digest.t) list - (* Return all bindings ([name], [crc]) contained in the given - table. *) +val extract: string list -> t -> (string * Digest.t option) list + (* [extract tbl names] returns an associative list mapping each string + in [names] to the CRC associated with it in [tbl]. If no CRC is + associated with a name then it is mapped to [None]. *) val filter: (string -> bool) -> t -> unit (* [filter pred tbl] removes from [tbl] table all (name, CRC) pairs diff --git a/utils/misc.ml b/utils/misc.ml index 1a2a87139..898880cb0 100644 --- a/utils/misc.ml +++ b/utils/misc.ml @@ -124,14 +124,14 @@ let create_hashtable size init = (* File copy *) let copy_file ic oc = - let buff = String.create 0x1000 in + let buff = Bytes.create 0x1000 in let rec copy () = let n = input ic buff 0 0x1000 in if n = 0 then () else (output oc buff 0 n; copy()) in copy() let copy_file_chunk ic oc len = - let buff = String.create 0x1000 in + let buff = Bytes.create 0x1000 in let rec copy n = if n <= 0 then () else begin let r = input ic buff 0 (min n 0x1000) in @@ -141,23 +141,13 @@ let copy_file_chunk ic oc len = let string_of_file ic = let b = Buffer.create 0x10000 in - let buff = String.create 0x1000 in + let buff = Bytes.create 0x1000 in let rec copy () = let n = input ic buff 0 0x1000 in if n = 0 then Buffer.contents b else - (Buffer.add_substring b buff 0 n; copy()) + (Buffer.add_subbytes b buff 0 n; copy()) in copy() - - -(* Reading from a channel *) - -let input_bytes ic n = - let result = String.create n in - really_input ic result 0 n; - result -;; - (* Integer operations *) let rec log2 n = @@ -226,26 +216,27 @@ let for4 (_,_,_,x) = x module LongString = struct - type t = string array + type t = bytes array let create str_size = let tbl_size = str_size / Sys.max_string_length + 1 in - let tbl = Array.make tbl_size "" in + let tbl = Array.make tbl_size Bytes.empty in for i = 0 to tbl_size - 2 do - tbl.(i) <- String.create Sys.max_string_length; + tbl.(i) <- Bytes.create Sys.max_string_length; done; - tbl.(tbl_size - 1) <- String.create (str_size mod Sys.max_string_length); + tbl.(tbl_size - 1) <- Bytes.create (str_size mod Sys.max_string_length); tbl let length tbl = let tbl_size = Array.length tbl in - Sys.max_string_length * (tbl_size - 1) + String.length tbl.(tbl_size - 1) + Sys.max_string_length * (tbl_size - 1) + Bytes.length tbl.(tbl_size - 1) let get tbl ind = - tbl.(ind / Sys.max_string_length).[ind mod Sys.max_string_length] + Bytes.get tbl.(ind / Sys.max_string_length) (ind mod Sys.max_string_length) let set tbl ind c = - tbl.(ind / Sys.max_string_length).[ind mod Sys.max_string_length] <- c + Bytes.set tbl.(ind / Sys.max_string_length) (ind mod Sys.max_string_length) + c let blit src srcoff dst dstoff len = for i = 0 to len - 1 do @@ -257,14 +248,14 @@ module LongString = struct output_char oc (get tbl i) done - let unsafe_blit_to_string src srcoff dst dstoff len = + let unsafe_blit_to_bytes src srcoff dst dstoff len = for i = 0 to len - 1 do - String.unsafe_set dst (dstoff + i) (get src (srcoff + i)) + Bytes.unsafe_set dst (dstoff + i) (get src (srcoff + i)) done let input_bytes ic len = let tbl = create len in - Array.iter (fun str -> really_input ic str 0 (String.length str)) tbl; + Array.iter (fun str -> really_input ic str 0 (Bytes.length str)) tbl; tbl end diff --git a/utils/misc.mli b/utils/misc.mli index 67316365e..4a3c84b2d 100644 --- a/utils/misc.mli +++ b/utils/misc.mli @@ -66,11 +66,6 @@ val copy_file_chunk: in_channel -> out_channel -> int -> unit val string_of_file: in_channel -> string (* [string_of_file ic] reads the contents of file [ic] and copies them to a string. It stops when encountering EOF on [ic]. *) -val input_bytes : in_channel -> int -> string;; - (* [input_bytes ic n] reads [n] bytes from [ic] and returns them - in a new string. It raises [End_of_file] if EOF is encountered - before all the bytes are read. *) - val log2: int -> int (* [log2 n] returns [s] such that [n = 1 lsl s] if [n] is a power of 2*) @@ -124,14 +119,14 @@ val for4: 'a * 'b * 'c * 'd -> 'd module LongString : sig - type t = string array + type t = bytes array val create : int -> t val length : t -> int val get : t -> int -> char val set : t -> int -> char -> unit val blit : t -> int -> t -> int -> int -> unit val output : out_channel -> t -> int -> int -> unit - val unsafe_blit_to_string : t -> int -> string -> int -> int -> unit + val unsafe_blit_to_bytes : t -> int -> bytes -> int -> int -> unit val input_bytes : in_channel -> int -> t end diff --git a/utils/warnings.ml b/utils/warnings.ml index 58d275396..103789c4e 100644 --- a/utils/warnings.ml +++ b/utils/warnings.ml @@ -39,7 +39,7 @@ type t = | Without_principality of string (* 19 *) | Unused_argument (* 20 *) | Nonreturning_statement (* 21 *) - | Camlp4 of string (* 22 *) + | Preprocessor of string (* 22 *) | Useless_record_with (* 23 *) | Bad_module_name of string (* 24 *) | All_clauses_guarded (* 25 *) @@ -55,7 +55,7 @@ type t = | Unused_for_index of string (* 35 *) | Unused_ancestor of string (* 36 *) | Unused_constructor of string * bool * bool (* 37 *) - | Unused_exception of string * bool (* 38 *) + | Unused_extension of string * bool * bool (* 38 *) | Unused_rec_flag (* 39 *) | Name_out_of_scope of string * string list * bool (* 40 *) | Ambiguous_name of string list * string list * bool (* 41 *) @@ -66,6 +66,7 @@ type t = | Bad_env_variable of string * string (* 46 *) | Attribute_payload of string * string (* 47 *) | Eliminated_optional_arguments of string list (* 48 *) + | No_cmi_file of string (* 49 *) ;; (* If you remove a warning, leave a hole in the numbering. NEVER change @@ -96,7 +97,7 @@ let number = function | Without_principality _ -> 19 | Unused_argument -> 20 | Nonreturning_statement -> 21 - | Camlp4 _ -> 22 + | Preprocessor _ -> 22 | Useless_record_with -> 23 | Bad_module_name _ -> 24 | All_clauses_guarded -> 25 @@ -112,7 +113,7 @@ let number = function | Unused_for_index _ -> 35 | Unused_ancestor _ -> 36 | Unused_constructor _ -> 37 - | Unused_exception _ -> 38 + | Unused_extension _ -> 38 | Unused_rec_flag -> 39 | Name_out_of_scope _ -> 40 | Ambiguous_name _ -> 41 @@ -123,9 +124,10 @@ let number = function | Bad_env_variable _ -> 46 | Attribute_payload _ -> 47 | Eliminated_optional_arguments _ -> 48 + | No_cmi_file _ -> 49 ;; -let last_warning_number = 48 +let last_warning_number = 49 (* Must be the max number returned by the [number] function. *) let letter = function @@ -160,21 +162,27 @@ let letter = function | _ -> assert false ;; -let active = Array.create (last_warning_number + 1) true;; -let error = Array.create (last_warning_number + 1) false;; +type state = + { + active: bool array; + error: bool array; + } -type state = bool array * bool array -let backup () = (Array.copy active, Array.copy error) -let restore (a, e) = - assert(Array.length a = Array.length active); - assert(Array.length e = Array.length error); - Array.blit a 0 active 0 (Array.length active); - Array.blit e 0 error 0 (Array.length error) +let current = + ref + { + active = Array.make (last_warning_number + 1) true; + error = Array.make (last_warning_number + 1) false; + } -let is_active x = active.(number x);; -let is_error x = error.(number x);; +let backup () = !current -let parse_opt flags s = +let restore x = current := x + +let is_active x = (!current).active.(number x);; +let is_error x = (!current).error.(number x);; + +let parse_opt error active flags s = let set i = flags.(i) <- true in let clear i = flags.(i) <- false in let set_all i = active.(i) <- true; error.(i) <- true in @@ -225,7 +233,11 @@ let parse_opt flags s = loop 0 ;; -let parse_options errflag s = parse_opt (if errflag then error else active) s;; +let parse_options errflag s = + let error = Array.copy (!current).error in + let active = Array.copy (!current).active in + parse_opt error active (if errflag then error else active) s; + current := {error; active} (* If you change these, don't forget to change them in man/ocamlc.m *) let defaults_w = "+a-4-6-7-9-27-29-32..39-41..42-44-45-48";; @@ -237,7 +249,7 @@ let () = parse_options true defaults_warn_error;; let message = function | Comment_start -> "this is the start of a comment." | Comment_not_end -> "this is not the end of a comment." - | Deprecated s -> "deprecated feature: " ^ s + | Deprecated s -> "deprecated: " ^ s | Fragile_match "" -> "this pattern-matching is fragile." | Fragile_match s -> @@ -286,7 +298,7 @@ let message = function | Unused_argument -> "this argument will not be used by the function." | Nonreturning_statement -> "this statement never returns (or has an unsound type.)" - | Camlp4 s -> s + | Preprocessor s -> s | Useless_record_with -> "all the fields are explicitly listed in this record:\n\ the 'with' clause is useless." @@ -320,12 +332,16 @@ let message = function "constructor " ^ s ^ " is never used to build values.\n\ Its type is exported as a private type." - | Unused_exception (s, false) -> - "unused exception constructor " ^ s ^ "." - | Unused_exception (s, true) -> - "exception constructor " ^ s ^ - " is never raised or used to build values.\n\ + | Unused_extension (s, false, false) -> + "unused extension constructor " ^ s ^ "." + | Unused_extension (s, true, _) -> + "extension constructor " ^ s ^ + " is never used to build values.\n\ (However, this constructor appears in patterns.)" + | Unused_extension (s, false, true) -> + "extension constructor " ^ s ^ + " is never used to build values.\n\ + It is exported or rebound as a private extension." | Unused_rec_flag -> "unused rec flag." | Name_out_of_scope (ty, [nm], false) -> @@ -366,6 +382,8 @@ let message = function Printf.sprintf "implicit elimination of optional argument%s %s" (if List.length sl = 1 then "" else "s") (String.concat ", " sl) + | No_cmi_file s -> + "no cmi file was found in path for module " ^ s ;; let nerrors = ref 0;; @@ -377,15 +395,14 @@ let print ppf w = for i = 0 to String.length msg - 1 do if msg.[i] = '\n' then incr newlines; done; - let (out, flush, newline, space) = - Format.pp_get_all_formatter_output_functions ppf () - in - let countnewline x = incr newlines; newline x in - Format.pp_set_all_formatter_output_functions ppf out flush countnewline space; + let out_functions = Format.pp_get_formatter_out_functions ppf () in + let countnewline x = incr newlines; out_functions.Format.out_newline x in + Format.pp_set_formatter_out_functions ppf + {out_functions with Format.out_newline = countnewline}; Format.fprintf ppf "%d: %s" num msg; Format.pp_print_flush ppf (); - Format.pp_set_all_formatter_output_functions ppf out flush newline space; - if error.(num) then incr nerrors; + Format.pp_set_formatter_out_functions ppf out_functions; + if (!current).error.(num) then incr nerrors; !newlines ;; @@ -426,7 +443,7 @@ let descriptions = 19, "Type without principality."; 20, "Unused function argument."; 21, "Non-returning statement."; - 22, "Camlp4 warning."; + 22, "Proprocessor warning."; 23, "Useless record \"with\" clause."; 24, "Bad module name: the source file name is not a valid OCaml module \ name."; @@ -449,7 +466,7 @@ let descriptions = 35, "Unused for-loop index."; 36, "Unused ancestor variable."; 37, "Unused constructor."; - 38, "Unused exception constructor."; + 38, "Unused extension constructor."; 39, "Unused rec flag."; 40, "Constructor or label name used out of scope."; 41, "Ambiguous constructor or label name."; @@ -457,9 +474,10 @@ let descriptions = 43, "Nonoptional label applied as optional."; 44, "Open statement shadows an already defined identifier."; 45, "Open statement shadows an already defined label or constructor."; - 46, "Illegal environment variable"; - 47, "Illegal attribute payload"; - 48, "Implicit elimination of optional arguments"; + 46, "Illegal environment variable."; + 47, "Illegal attribute payload."; + 48, "Implicit elimination of optional arguments."; + 49, "Absent cmi file when looking up module alias."; ] ;; diff --git a/utils/warnings.mli b/utils/warnings.mli index 05bf66bde..edfd732c3 100644 --- a/utils/warnings.mli +++ b/utils/warnings.mli @@ -34,7 +34,7 @@ type t = | Without_principality of string (* 19 *) | Unused_argument (* 20 *) | Nonreturning_statement (* 21 *) - | Camlp4 of string (* 22 *) + | Preprocessor of string (* 22 *) | Useless_record_with (* 23 *) | Bad_module_name of string (* 24 *) | All_clauses_guarded (* 25 *) @@ -50,7 +50,7 @@ type t = | Unused_for_index of string (* 35 *) | Unused_ancestor of string (* 36 *) | Unused_constructor of string * bool * bool (* 37 *) - | Unused_exception of string * bool (* 38 *) + | Unused_extension of string * bool * bool (* 38 *) | Unused_rec_flag (* 39 *) | Name_out_of_scope of string * string list * bool (* 40 *) | Ambiguous_name of string list * string list * bool (* 41 *) @@ -61,6 +61,7 @@ type t = | Bad_env_variable of string * string (* 46 *) | Attribute_payload of string * string (* 47 *) | Eliminated_optional_arguments of string list (* 48 *) + | No_cmi_file of string (* 49 *) ;; val parse_options : bool -> string -> unit;; diff --git a/yacc/defs.h b/yacc/defs.h index 0a823874f..32114ea56 100644 --- a/yacc/defs.h +++ b/yacc/defs.h @@ -312,45 +312,45 @@ extern action *add_reductions(int stateno, register action *actions); extern action *add_reduce(register action *actions, register int ruleno, register int symbol); extern void closure (short int *nucleus, int n); extern void create_symbol_table (void); -extern void default_action_error (void); +extern void default_action_error (void) Noreturn; extern void done (int k) Noreturn; -extern void entry_without_type (char *s); -extern void fatal (char *msg); +extern void entry_without_type (char *s) Noreturn; +extern void fatal (char *msg) Noreturn; extern void finalize_closure (void); extern void free_parser (void); extern void free_symbol_table (void); extern void free_symbols (void); -extern void illegal_character (char *c_cptr); -extern void illegal_token_ref (int i, char *name); +extern void illegal_character (char *c_cptr) Noreturn; +extern void illegal_token_ref (int i, char *name) Noreturn; extern void lalr (void); extern void lr0 (void); extern void make_parser (void); -extern void no_grammar (void); -extern void no_space (void); -extern void open_error (char *filename); +extern void no_grammar (void) Noreturn; +extern void no_space (void) Noreturn; +extern void open_error (char *filename) Noreturn; extern void output (void); -extern void over_unionized (char *u_cptr); +extern void over_unionized (char *u_cptr) Noreturn; extern void prec_redeclared (void); -extern void polymorphic_entry_point(char *s); +extern void polymorphic_entry_point(char *s) Noreturn; extern void reader (void); extern void reflexive_transitive_closure (unsigned int *R, int n); extern void reprec_warning (char *s); extern void retyped_warning (char *s); extern void revalued_warning (char *s); extern void set_first_derives (void); -extern void syntax_error (int st_lineno, char *st_line, char *st_cptr) Noreturn, terminal_lhs (int s_lineno); -extern void terminal_start (char *s); -extern void tokenized_start (char *s); -extern void too_many_entries (void); +extern void syntax_error (int st_lineno, char *st_line, char *st_cptr) Noreturn, terminal_lhs (int s_lineno) Noreturn; +extern void terminal_start (char *s) Noreturn; +extern void tokenized_start (char *s) Noreturn; +extern void too_many_entries (void) Noreturn; extern void undefined_goal (char *s); extern void undefined_symbol (char *s); -extern void unexpected_EOF (void); -extern void unknown_rhs (int i); -extern void unterminated_action (int a_lineno, char *a_line, char *a_cptr); -extern void unterminated_comment (int c_lineno, char *c_line, char *c_cptr); -extern void unterminated_string (int s_lineno, char *s_line, char *s_cptr); -extern void unterminated_text (int t_lineno, char *t_line, char *t_cptr); -extern void unterminated_union (int u_lineno, char *u_line, char *u_cptr); -extern void used_reserved (char *s); +extern void unexpected_EOF (void) Noreturn; +extern void unknown_rhs (int i) Noreturn; +extern void unterminated_action (int a_lineno, char *a_line, char *a_cptr) Noreturn; +extern void unterminated_comment (int c_lineno, char *c_line, char *c_cptr) Noreturn; +extern void unterminated_string (int s_lineno, char *s_line, char *s_cptr) Noreturn; +extern void unterminated_text (int t_lineno, char *t_line, char *t_cptr) Noreturn; +extern void unterminated_union (int u_lineno, char *u_line, char *u_cptr) Noreturn; +extern void used_reserved (char *s) Noreturn; extern void verbose (void); extern void write_section (char **section); diff --git a/yacc/main.c b/yacc/main.c index d2f329310..9388b9d1a 100644 --- a/yacc/main.c +++ b/yacc/main.c @@ -55,11 +55,7 @@ char *text_file_name; char *union_file_name; char *verbose_file_name; -#if defined(__OpenBSD__) || defined(__NetBSD__) || defined(__FreeBSD__) || defined(__DragonFly__) || (__APPLE__) -#define HAVE_MKSTEMP -#endif - -#ifdef HAVE_MKSTEMP +#ifdef HAS_MKSTEMP int action_fd = -1, entry_fd = -1, text_fd = -1, union_fd = -1; #endif @@ -101,7 +97,7 @@ char *rassoc; short **derives; char *nullable; -#if !defined(HAVE_MKSTEMP) +#if !defined(HAS_MKSTEMP) extern char *mktemp(char *); #endif #ifndef NO_UNIX @@ -111,7 +107,7 @@ extern char *getenv(const char *); void done(int k) { -#ifdef HAVE_MKSTEMP +#ifdef HAS_MKSTEMP if (action_fd != -1) unlink(action_file_name); if (entry_fd != -1) @@ -325,7 +321,7 @@ void create_file_names(void) text_file_name[len + 5] = 't'; union_file_name[len + 5] = 'u'; -#ifdef HAVE_MKSTEMP +#ifdef HAS_MKSTEMP action_fd = mkstemp(action_file_name); if (action_fd == -1) open_error(action_file_name); @@ -384,7 +380,7 @@ void open_files(void) open_error(input_file_name); } -#ifdef HAVE_MKSTEMP +#ifdef HAS_MKSTEMP action_file = fdopen(action_fd, "w"); #else action_file = fopen(action_file_name, "w"); @@ -392,7 +388,7 @@ void open_files(void) if (action_file == 0) open_error(action_file_name); -#ifdef HAVE_MKSTEMP +#ifdef HAS_MKSTEMP entry_file = fdopen(entry_fd, "w"); #else entry_file = fopen(entry_file_name, "w"); @@ -400,7 +396,7 @@ void open_files(void) if (entry_file == 0) open_error(entry_file_name); -#ifdef HAVE_MKSTEMP +#ifdef HAS_MKSTEMP text_file = fdopen(text_fd, "w"); #else text_file = fopen(text_file_name, "w"); @@ -420,7 +416,7 @@ void open_files(void) defines_file = fopen(defines_file_name, "w"); if (defines_file == 0) open_error(defines_file_name); -#ifdef HAVE_MKSTEMP +#ifdef HAS_MKSTEMP union_file = fdopen(union_fd, "w"); #else union_file = fopen(union_file_name, "w"); |