diff options
771 files changed, 22243 insertions, 18154 deletions
@@ -25,14 +25,16 @@ utils/terminfo.cmx : utils/terminfo.cmi utils/warnings.cmo : utils/warnings.cmi utils/warnings.cmx : utils/warnings.cmi parsing/ast_helper.cmi : parsing/parsetree.cmi parsing/longident.cmi \ - parsing/location.cmi parsing/asttypes.cmi + parsing/location.cmi parsing/docstrings.cmi parsing/asttypes.cmi parsing/ast_mapper.cmi : parsing/parsetree.cmi parsing/location.cmi parsing/asttypes.cmi : parsing/location.cmi +parsing/docstrings.cmi : parsing/parsetree.cmi parsing/location.cmi parsing/lexer.cmi : parsing/parser.cmi parsing/location.cmi parsing/location.cmi : utils/warnings.cmi parsing/longident.cmi : parsing/parse.cmi : parsing/parsetree.cmi -parsing/parser.cmi : parsing/parsetree.cmi parsing/location.cmi +parsing/parser.cmi : parsing/parsetree.cmi parsing/location.cmi \ + parsing/docstrings.cmi parsing/parsetree.cmi : parsing/longident.cmi parsing/location.cmi \ parsing/asttypes.cmi parsing/pprintast.cmi : parsing/parsetree.cmi parsing/longident.cmi \ @@ -40,9 +42,11 @@ parsing/pprintast.cmi : parsing/parsetree.cmi parsing/longident.cmi \ parsing/printast.cmi : parsing/parsetree.cmi parsing/syntaxerr.cmi : parsing/location.cmi parsing/ast_helper.cmo : parsing/parsetree.cmi parsing/longident.cmi \ - parsing/location.cmi parsing/asttypes.cmi parsing/ast_helper.cmi + parsing/location.cmi parsing/docstrings.cmi parsing/asttypes.cmi \ + parsing/ast_helper.cmi parsing/ast_helper.cmx : parsing/parsetree.cmi parsing/longident.cmx \ - parsing/location.cmx parsing/asttypes.cmi parsing/ast_helper.cmi + parsing/location.cmx parsing/docstrings.cmx parsing/asttypes.cmi \ + parsing/ast_helper.cmi parsing/ast_mapper.cmo : parsing/parsetree.cmi utils/misc.cmi \ parsing/longident.cmi parsing/location.cmi utils/config.cmi \ utils/clflags.cmi parsing/asttypes.cmi parsing/ast_helper.cmi \ @@ -51,10 +55,14 @@ parsing/ast_mapper.cmx : parsing/parsetree.cmi utils/misc.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/docstrings.cmo : utils/warnings.cmi parsing/parsetree.cmi \ + parsing/location.cmi parsing/asttypes.cmi parsing/docstrings.cmi +parsing/docstrings.cmx : utils/warnings.cmx parsing/parsetree.cmi \ + parsing/location.cmx parsing/asttypes.cmi parsing/docstrings.cmi parsing/lexer.cmo : utils/warnings.cmi parsing/parser.cmi utils/misc.cmi \ - parsing/location.cmi parsing/lexer.cmi + parsing/location.cmi parsing/docstrings.cmi parsing/lexer.cmi parsing/lexer.cmx : utils/warnings.cmx parsing/parser.cmx utils/misc.cmx \ - parsing/location.cmx parsing/lexer.cmi + parsing/location.cmx parsing/docstrings.cmx parsing/lexer.cmi parsing/location.cmo : utils/warnings.cmi utils/terminfo.cmi \ parsing/location.cmi parsing/location.cmx : utils/warnings.cmx utils/terminfo.cmx \ @@ -62,15 +70,19 @@ parsing/location.cmx : utils/warnings.cmx utils/terminfo.cmx \ parsing/longident.cmo : utils/misc.cmi parsing/longident.cmi parsing/longident.cmx : utils/misc.cmx parsing/longident.cmi parsing/parse.cmo : parsing/syntaxerr.cmi parsing/parser.cmi \ - parsing/location.cmi parsing/lexer.cmi parsing/parse.cmi + parsing/location.cmi parsing/lexer.cmi parsing/docstrings.cmi \ + parsing/parse.cmi parsing/parse.cmx : parsing/syntaxerr.cmx parsing/parser.cmx \ - parsing/location.cmx parsing/lexer.cmx parsing/parse.cmi + parsing/location.cmx parsing/lexer.cmx parsing/docstrings.cmx \ + parsing/parse.cmi parsing/parser.cmo : parsing/syntaxerr.cmi parsing/parsetree.cmi \ - parsing/longident.cmi parsing/location.cmi utils/clflags.cmi \ - parsing/asttypes.cmi parsing/ast_helper.cmi parsing/parser.cmi + parsing/longident.cmi parsing/location.cmi parsing/docstrings.cmi \ + utils/clflags.cmi parsing/asttypes.cmi parsing/ast_helper.cmi \ + parsing/parser.cmi parsing/parser.cmx : parsing/syntaxerr.cmx parsing/parsetree.cmi \ - parsing/longident.cmx parsing/location.cmx utils/clflags.cmx \ - parsing/asttypes.cmi parsing/ast_helper.cmx parsing/parser.cmi + parsing/longident.cmx parsing/location.cmx parsing/docstrings.cmx \ + utils/clflags.cmx parsing/asttypes.cmi parsing/ast_helper.cmx \ + parsing/parser.cmi parsing/pprintast.cmo : parsing/parsetree.cmi utils/misc.cmi \ parsing/longident.cmi parsing/location.cmi parsing/asttypes.cmi \ parsing/pprintast.cmi @@ -116,11 +128,13 @@ typing/predef.cmi : typing/types.cmi typing/path.cmi typing/ident.cmi typing/primitive.cmi : typing/printtyp.cmi : typing/types.cmi typing/path.cmi \ typing/outcometree.cmi parsing/longident.cmi typing/ident.cmi \ - typing/env.cmi + typing/env.cmi parsing/asttypes.cmi typing/printtyped.cmi : typing/typedtree.cmi typing/stypes.cmi : typing/typedtree.cmi parsing/location.cmi \ typing/annot.cmi typing/subst.cmi : typing/types.cmi typing/path.cmi typing/ident.cmi +typing/tast_mapper.cmi : typing/typedtree.cmi typing/env.cmi \ + parsing/asttypes.cmi typing/typeclass.cmi : typing/types.cmi typing/typedtree.cmi \ parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \ typing/ident.cmi typing/env.cmi typing/ctype.cmi parsing/asttypes.cmi @@ -129,7 +143,8 @@ typing/typecore.cmi : typing/types.cmi typing/typedtree.cmi typing/path.cmi \ typing/ident.cmi typing/env.cmi parsing/asttypes.cmi typing/annot.cmi typing/typedecl.cmi : typing/types.cmi typing/typedtree.cmi typing/path.cmi \ parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \ - typing/includecore.cmi typing/ident.cmi typing/env.cmi + typing/includecore.cmi typing/ident.cmi typing/env.cmi \ + parsing/asttypes.cmi typing/typedtree.cmi : typing/types.cmi typing/primitive.cmi typing/path.cmi \ parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \ typing/ident.cmi typing/env.cmi parsing/asttypes.cmi @@ -145,20 +160,22 @@ typing/types.cmi : typing/primitive.cmi typing/path.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/untypeast.cmi : typing/typedtree.cmi typing/path.cmi \ + parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi typing/btype.cmo : typing/types.cmi typing/path.cmi utils/misc.cmi \ - typing/ident.cmi typing/btype.cmi + typing/ident.cmi parsing/asttypes.cmi typing/btype.cmi typing/btype.cmx : typing/types.cmx typing/path.cmx utils/misc.cmx \ - typing/ident.cmx typing/btype.cmi + typing/ident.cmx parsing/asttypes.cmi typing/btype.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 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 \ +typing/cmt_format.cmo : typing/types.cmi typing/typedtree.cmi \ + typing/tast_mapper.cmi utils/misc.cmi parsing/location.cmi \ parsing/lexer.cmi typing/env.cmi utils/config.cmi typing/cmi_format.cmi \ utils/clflags.cmi typing/cmt_format.cmi -typing/cmt_format.cmx : typing/types.cmx typing/typedtreeMap.cmx \ - typing/typedtree.cmx utils/misc.cmx parsing/location.cmx \ +typing/cmt_format.cmx : typing/types.cmx typing/typedtree.cmx \ + typing/tast_mapper.cmx utils/misc.cmx parsing/location.cmx \ parsing/lexer.cmx typing/env.cmx utils/config.cmx typing/cmi_format.cmx \ utils/clflags.cmx typing/cmt_format.cmi typing/ctype.cmo : typing/types.cmi typing/subst.cmi typing/path.cmi \ @@ -252,17 +269,17 @@ typing/predef.cmx : typing/types.cmx typing/path.cmx parsing/location.cmx \ typing/primitive.cmo : utils/misc.cmi typing/primitive.cmi typing/primitive.cmx : utils/misc.cmx typing/primitive.cmi typing/printtyp.cmo : typing/types.cmi typing/primitive.cmi \ - typing/predef.cmi typing/path.cmi typing/outcometree.cmi \ - typing/oprint.cmi utils/misc.cmi parsing/longident.cmi \ - parsing/location.cmi typing/ident.cmi typing/env.cmi typing/ctype.cmi \ - utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi \ - typing/printtyp.cmi + typing/predef.cmi typing/path.cmi parsing/parsetree.cmi \ + typing/outcometree.cmi typing/oprint.cmi utils/misc.cmi \ + parsing/longident.cmi parsing/location.cmi typing/ident.cmi \ + typing/env.cmi typing/ctype.cmi utils/clflags.cmi typing/btype.cmi \ + parsing/asttypes.cmi typing/printtyp.cmi typing/printtyp.cmx : typing/types.cmx typing/primitive.cmx \ - typing/predef.cmx typing/path.cmx typing/outcometree.cmi \ - typing/oprint.cmx utils/misc.cmx parsing/longident.cmx \ - parsing/location.cmx typing/ident.cmx typing/env.cmx typing/ctype.cmx \ - utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \ - typing/printtyp.cmi + typing/predef.cmx typing/path.cmx parsing/parsetree.cmi \ + typing/outcometree.cmi typing/oprint.cmx utils/misc.cmx \ + parsing/longident.cmx parsing/location.cmx typing/ident.cmx \ + typing/env.cmx typing/ctype.cmx utils/clflags.cmx typing/btype.cmx \ + parsing/asttypes.cmi typing/printtyp.cmi typing/printtyped.cmo : typing/typedtree.cmi parsing/printast.cmi \ typing/path.cmi utils/misc.cmi parsing/longident.cmi parsing/location.cmi \ typing/ident.cmi parsing/asttypes.cmi typing/printtyped.cmi @@ -279,24 +296,28 @@ typing/subst.cmo : typing/types.cmi utils/tbl.cmi typing/path.cmi \ typing/subst.cmx : typing/types.cmx utils/tbl.cmx typing/path.cmx \ utils/misc.cmx parsing/location.cmx typing/ident.cmx utils/clflags.cmx \ typing/btype.cmx parsing/ast_mapper.cmx typing/subst.cmi +typing/tast_mapper.cmo : typing/typedtree.cmi typing/env.cmi \ + parsing/asttypes.cmi typing/tast_mapper.cmi +typing/tast_mapper.cmx : typing/typedtree.cmx typing/env.cmx \ + parsing/asttypes.cmi typing/tast_mapper.cmi typing/typeclass.cmo : utils/warnings.cmi typing/typetexp.cmi \ typing/types.cmi typing/typedtree.cmi typing/typedecl.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 \ - utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi \ - parsing/ast_helper.cmi typing/typeclass.cmi + parsing/parsetree.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 utils/clflags.cmi \ + typing/btype.cmi parsing/asttypes.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 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 + parsing/parsetree.cmi 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 parsing/syntaxerr.cmi \ typing/subst.cmi typing/stypes.cmi typing/printtyp.cmi \ @@ -373,16 +394,26 @@ typing/types.cmx : typing/primitive.cmx typing/path.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 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/printtyp.cmi typing/predef.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 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 + typing/printtyp.cmx typing/predef.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 +typing/untypeast.cmo : typing/typedtree.cmi typing/path.cmi \ + parsing/parsetree.cmi utils/misc.cmi parsing/longident.cmi \ + parsing/location.cmi typing/ident.cmi typing/env.cmi parsing/asttypes.cmi \ + parsing/ast_helper.cmi typing/untypeast.cmi +typing/untypeast.cmx : typing/typedtree.cmx typing/path.cmx \ + parsing/parsetree.cmi utils/misc.cmx parsing/longident.cmx \ + parsing/location.cmx typing/ident.cmx typing/env.cmx parsing/asttypes.cmi \ + parsing/ast_helper.cmx typing/untypeast.cmi bytecomp/bytegen.cmi : bytecomp/lambda.cmi bytecomp/instruct.cmi bytecomp/bytelibrarian.cmi : bytecomp/bytelink.cmi : bytecomp/symtable.cmi bytecomp/cmo_format.cmi @@ -397,7 +428,7 @@ bytecomp/lambda.cmi : typing/types.cmi typing/primitive.cmi typing/path.cmi \ parsing/location.cmi typing/ident.cmi typing/env.cmi parsing/asttypes.cmi bytecomp/matching.cmi : typing/typedtree.cmi parsing/location.cmi \ bytecomp/lambda.cmi typing/ident.cmi -bytecomp/meta.cmi : +bytecomp/meta.cmi : bytecomp/instruct.cmi bytecomp/printinstr.cmi : bytecomp/instruct.cmi bytecomp/printlambda.cmi : bytecomp/lambda.cmi bytecomp/runtimedef.cmi : @@ -407,14 +438,14 @@ bytecomp/symtable.cmi : utils/misc.cmi typing/ident.cmi \ bytecomp/cmo_format.cmi bytecomp/translclass.cmi : typing/typedtree.cmi parsing/location.cmi \ bytecomp/lambda.cmi typing/ident.cmi parsing/asttypes.cmi -bytecomp/translcore.cmi : typing/typedtree.cmi typing/primitive.cmi \ - typing/path.cmi parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi \ - parsing/asttypes.cmi +bytecomp/translcore.cmi : typing/types.cmi typing/typedtree.cmi \ + typing/primitive.cmi typing/path.cmi parsing/location.cmi \ + bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi parsing/asttypes.cmi bytecomp/translmod.cmi : typing/typedtree.cmi typing/primitive.cmi \ parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi bytecomp/translobj.cmi : bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi -bytecomp/typeopt.cmi : typing/typedtree.cmi typing/path.cmi \ - bytecomp/lambda.cmi +bytecomp/typeopt.cmi : typing/types.cmi typing/typedtree.cmi typing/path.cmi \ + bytecomp/lambda.cmi typing/env.cmi bytecomp/bytegen.cmo : typing/types.cmi bytecomp/switch.cmi typing/subst.cmi \ typing/primitive.cmi utils/misc.cmi bytecomp/matching.cmi \ bytecomp/lambda.cmi bytecomp/instruct.cmi typing/ident.cmi \ @@ -430,15 +461,17 @@ bytecomp/bytelibrarian.cmx : utils/misc.cmx parsing/location.cmx \ utils/config.cmx bytecomp/cmo_format.cmi utils/clflags.cmx \ bytecomp/bytelink.cmx bytecomp/bytelibrarian.cmi bytecomp/bytelink.cmo : utils/warnings.cmi bytecomp/symtable.cmi \ - bytecomp/opcodes.cmo utils/misc.cmi parsing/location.cmi typing/ident.cmi \ - bytecomp/dll.cmi utils/consistbl.cmi utils/config.cmi \ - bytecomp/cmo_format.cmi utils/clflags.cmi utils/ccomp.cmi \ - bytecomp/bytesections.cmi bytecomp/bytelink.cmi + bytecomp/opcodes.cmo utils/misc.cmi parsing/location.cmi \ + bytecomp/instruct.cmi typing/ident.cmi bytecomp/dll.cmi \ + utils/consistbl.cmi utils/config.cmi bytecomp/cmo_format.cmi \ + utils/clflags.cmi utils/ccomp.cmi bytecomp/bytesections.cmi \ + bytecomp/bytelink.cmi bytecomp/bytelink.cmx : utils/warnings.cmx bytecomp/symtable.cmx \ - bytecomp/opcodes.cmx utils/misc.cmx parsing/location.cmx typing/ident.cmx \ - bytecomp/dll.cmx utils/consistbl.cmx utils/config.cmx \ - bytecomp/cmo_format.cmi utils/clflags.cmx utils/ccomp.cmx \ - bytecomp/bytesections.cmx bytecomp/bytelink.cmi + bytecomp/opcodes.cmx utils/misc.cmx parsing/location.cmx \ + bytecomp/instruct.cmx typing/ident.cmx bytecomp/dll.cmx \ + utils/consistbl.cmx utils/config.cmx bytecomp/cmo_format.cmi \ + utils/clflags.cmx utils/ccomp.cmx bytecomp/bytesections.cmx \ + bytecomp/bytelink.cmi bytecomp/bytepackager.cmo : typing/typemod.cmi bytecomp/translmod.cmi \ typing/subst.cmi bytecomp/printlambda.cmi typing/path.cmi utils/misc.cmi \ parsing/location.cmi bytecomp/instruct.cmi typing/ident.cmi \ @@ -491,8 +524,8 @@ bytecomp/matching.cmx : typing/types.cmx bytecomp/typeopt.cmx \ parsing/location.cmx bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx \ utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \ bytecomp/matching.cmi -bytecomp/meta.cmo : bytecomp/meta.cmi -bytecomp/meta.cmx : bytecomp/meta.cmi +bytecomp/meta.cmo : bytecomp/instruct.cmi bytecomp/meta.cmi +bytecomp/meta.cmx : bytecomp/instruct.cmx bytecomp/meta.cmi bytecomp/opcodes.cmo : bytecomp/opcodes.cmx : bytecomp/printinstr.cmo : bytecomp/printlambda.cmi parsing/location.cmi \ @@ -509,22 +542,24 @@ 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 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/simplif.cmo : utils/warnings.cmi utils/tbl.cmi typing/stypes.cmi \ + utils/misc.cmi parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi \ + utils/clflags.cmi parsing/asttypes.cmi typing/annot.cmi \ + bytecomp/simplif.cmi +bytecomp/simplif.cmx : utils/warnings.cmx utils/tbl.cmx typing/stypes.cmx \ + utils/misc.cmx parsing/location.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 \ typing/predef.cmi utils/misc.cmi bytecomp/meta.cmi parsing/location.cmi \ - bytecomp/lambda.cmi typing/ident.cmi bytecomp/dll.cmi \ + bytecomp/lambda.cmi typing/ident.cmi bytecomp/dll.cmi utils/config.cmi \ bytecomp/cmo_format.cmi utils/clflags.cmi bytecomp/bytesections.cmi \ parsing/asttypes.cmi bytecomp/symtable.cmi bytecomp/symtable.cmx : utils/tbl.cmx bytecomp/runtimedef.cmx \ typing/predef.cmx utils/misc.cmx bytecomp/meta.cmx parsing/location.cmx \ - bytecomp/lambda.cmx typing/ident.cmx bytecomp/dll.cmx \ + bytecomp/lambda.cmx typing/ident.cmx bytecomp/dll.cmx utils/config.cmx \ bytecomp/cmo_format.cmi utils/clflags.cmx bytecomp/bytesections.cmx \ parsing/asttypes.cmi bytecomp/symtable.cmi bytecomp/translclass.cmo : typing/types.cmi bytecomp/typeopt.cmi \ @@ -582,6 +617,8 @@ asmcomp/asmgen.cmi : bytecomp/lambda.cmi asmcomp/cmm.cmi asmcomp/asmlibrarian.cmi : asmcomp/asmlink.cmi : asmcomp/cmx_format.cmi asmcomp/asmpackager.cmi : typing/env.cmi +asmcomp/branch_relaxation.cmi : asmcomp/linearize.cmi \ + asmcomp/branch_relaxation_intf.cmo asmcomp/clambda.cmi : bytecomp/lambda.cmi typing/ident.cmi \ asmcomp/debuginfo.cmi parsing/asttypes.cmi asmcomp/closure.cmi : bytecomp/lambda.cmi asmcomp/clambda.cmi @@ -620,14 +657,19 @@ 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/x86_ast.cmi : +asmcomp/x86_dsl.cmi : asmcomp/x86_ast.cmi +asmcomp/x86_gas.cmi : asmcomp/x86_ast.cmi +asmcomp/x86_masm.cmi : asmcomp/x86_ast.cmi +asmcomp/x86_proc.cmi : asmcomp/x86_ast.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/arch.cmo : utils/clflags.cmi +asmcomp/arch.cmx : utils/clflags.cmx asmcomp/asmgen.cmo : bytecomp/translmod.cmi asmcomp/split.cmi \ asmcomp/spill.cmi asmcomp/selection.cmi asmcomp/scheduling.cmi \ asmcomp/reload.cmi asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/printmach.cmi \ @@ -656,13 +698,13 @@ asmcomp/asmlibrarian.cmx : utils/misc.cmx parsing/location.cmx \ utils/config.cmx asmcomp/compilenv.cmx asmcomp/cmx_format.cmi \ utils/clflags.cmx asmcomp/clambda.cmx utils/ccomp.cmx asmcomp/asmlink.cmx \ asmcomp/asmlibrarian.cmi -asmcomp/asmlink.cmo : bytecomp/runtimedef.cmi asmcomp/proc.cmi \ - utils/misc.cmi parsing/location.cmi asmcomp/emitaux.cmi asmcomp/emit.cmi \ +asmcomp/asmlink.cmo : bytecomp/runtimedef.cmi utils/misc.cmi \ + parsing/location.cmi asmcomp/emitaux.cmi asmcomp/emit.cmi \ utils/consistbl.cmi utils/config.cmi asmcomp/compilenv.cmi \ asmcomp/cmx_format.cmi asmcomp/cmmgen.cmi utils/clflags.cmi \ utils/ccomp.cmi asmcomp/asmgen.cmi asmcomp/asmlink.cmi -asmcomp/asmlink.cmx : bytecomp/runtimedef.cmx asmcomp/proc.cmx \ - utils/misc.cmx parsing/location.cmx asmcomp/emitaux.cmx asmcomp/emit.cmx \ +asmcomp/asmlink.cmx : bytecomp/runtimedef.cmx utils/misc.cmx \ + parsing/location.cmx asmcomp/emitaux.cmx asmcomp/emit.cmx \ utils/consistbl.cmx utils/config.cmx asmcomp/compilenv.cmx \ asmcomp/cmx_format.cmi asmcomp/cmmgen.cmx utils/clflags.cmx \ utils/ccomp.cmx asmcomp/asmgen.cmx asmcomp/asmlink.cmi @@ -676,20 +718,26 @@ asmcomp/asmpackager.cmx : typing/typemod.cmx bytecomp/translmod.cmx \ utils/config.cmx asmcomp/compilenv.cmx asmcomp/cmx_format.cmi \ utils/clflags.cmx utils/ccomp.cmx asmcomp/asmlink.cmx asmcomp/asmgen.cmx \ asmcomp/asmpackager.cmi +asmcomp/branch_relaxation.cmo : utils/misc.cmi asmcomp/mach.cmi \ + asmcomp/linearize.cmi asmcomp/cmm.cmi asmcomp/branch_relaxation_intf.cmo \ + asmcomp/branch_relaxation.cmi +asmcomp/branch_relaxation.cmx : utils/misc.cmx asmcomp/mach.cmx \ + asmcomp/linearize.cmx asmcomp/cmm.cmx asmcomp/branch_relaxation_intf.cmx \ + asmcomp/branch_relaxation.cmi +asmcomp/branch_relaxation_intf.cmo : asmcomp/linearize.cmi asmcomp/arch.cmo +asmcomp/branch_relaxation_intf.cmx : asmcomp/linearize.cmx asmcomp/arch.cmx asmcomp/clambda.cmo : bytecomp/lambda.cmi typing/ident.cmi \ asmcomp/debuginfo.cmi parsing/asttypes.cmi asmcomp/clambda.cmi asmcomp/clambda.cmx : bytecomp/lambda.cmx typing/ident.cmx \ asmcomp/debuginfo.cmx parsing/asttypes.cmi asmcomp/clambda.cmi asmcomp/closure.cmo : utils/tbl.cmi bytecomp/switch.cmi typing/primitive.cmi \ - utils/misc.cmi parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi \ - asmcomp/debuginfo.cmi asmcomp/compilenv.cmi utils/clflags.cmi \ - asmcomp/clambda.cmi parsing/asttypes.cmi asmcomp/arch.cmo \ - asmcomp/closure.cmi + utils/misc.cmi bytecomp/lambda.cmi typing/ident.cmi asmcomp/debuginfo.cmi \ + asmcomp/compilenv.cmi utils/clflags.cmi asmcomp/clambda.cmi \ + parsing/asttypes.cmi asmcomp/arch.cmo asmcomp/closure.cmi asmcomp/closure.cmx : utils/tbl.cmx bytecomp/switch.cmx typing/primitive.cmx \ - utils/misc.cmx parsing/location.cmx bytecomp/lambda.cmx typing/ident.cmx \ - asmcomp/debuginfo.cmx asmcomp/compilenv.cmx utils/clflags.cmx \ - asmcomp/clambda.cmx parsing/asttypes.cmi asmcomp/arch.cmx \ - asmcomp/closure.cmi + utils/misc.cmx bytecomp/lambda.cmx typing/ident.cmx asmcomp/debuginfo.cmx \ + asmcomp/compilenv.cmx utils/clflags.cmx asmcomp/clambda.cmx \ + parsing/asttypes.cmi asmcomp/arch.cmx asmcomp/closure.cmi asmcomp/cmm.cmo : bytecomp/lambda.cmi typing/ident.cmi asmcomp/debuginfo.cmi \ asmcomp/arch.cmo asmcomp/cmm.cmi asmcomp/cmm.cmx : bytecomp/lambda.cmx typing/ident.cmx asmcomp/debuginfo.cmx \ @@ -736,16 +784,20 @@ asmcomp/debuginfo.cmo : parsing/location.cmi bytecomp/lambda.cmi \ asmcomp/debuginfo.cmi asmcomp/debuginfo.cmx : parsing/location.cmx bytecomp/lambda.cmx \ asmcomp/debuginfo.cmi -asmcomp/emit.cmo : asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \ - asmcomp/mach.cmi asmcomp/linearize.cmi bytecomp/lambda.cmi \ - asmcomp/emitaux.cmi asmcomp/debuginfo.cmi utils/config.cmi \ - asmcomp/compilenv.cmi asmcomp/cmm.cmi utils/clflags.cmi asmcomp/arch.cmo \ - asmcomp/emit.cmi -asmcomp/emit.cmx : asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \ - asmcomp/mach.cmx asmcomp/linearize.cmx bytecomp/lambda.cmx \ - asmcomp/emitaux.cmx asmcomp/debuginfo.cmx utils/config.cmx \ - asmcomp/compilenv.cmx asmcomp/cmm.cmx utils/clflags.cmx asmcomp/arch.cmx \ - asmcomp/emit.cmi +asmcomp/emit.cmo : asmcomp/x86_proc.cmi asmcomp/x86_masm.cmi \ + asmcomp/x86_gas.cmi asmcomp/x86_dsl.cmi asmcomp/x86_ast.cmi \ + asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi asmcomp/mach.cmi \ + asmcomp/linearize.cmi bytecomp/lambda.cmi asmcomp/emitaux.cmi \ + asmcomp/debuginfo.cmi utils/config.cmi asmcomp/compilenv.cmi \ + asmcomp/cmm.cmi utils/clflags.cmi asmcomp/branch_relaxation.cmi \ + asmcomp/arch.cmo asmcomp/emit.cmi +asmcomp/emit.cmx : asmcomp/x86_proc.cmx asmcomp/x86_masm.cmx \ + asmcomp/x86_gas.cmx asmcomp/x86_dsl.cmx asmcomp/x86_ast.cmi \ + asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx asmcomp/mach.cmx \ + asmcomp/linearize.cmx bytecomp/lambda.cmx asmcomp/emitaux.cmx \ + asmcomp/debuginfo.cmx utils/config.cmx asmcomp/compilenv.cmx \ + asmcomp/cmm.cmx utils/clflags.cmx asmcomp/branch_relaxation.cmx \ + asmcomp/arch.cmx asmcomp/emit.cmi asmcomp/emitaux.cmo : asmcomp/linearize.cmi asmcomp/debuginfo.cmi \ utils/config.cmi utils/clflags.cmi asmcomp/arch.cmo asmcomp/emitaux.cmi asmcomp/emitaux.cmx : asmcomp/linearize.cmx asmcomp/debuginfo.cmx \ @@ -794,18 +846,18 @@ asmcomp/printmach.cmx : asmcomp/reg.cmx asmcomp/proc.cmx \ asmcomp/printcmm.cmx asmcomp/mach.cmx bytecomp/lambda.cmx \ asmcomp/debuginfo.cmx asmcomp/cmm.cmx asmcomp/arch.cmx \ asmcomp/printmach.cmi -asmcomp/proc.cmo : asmcomp/reg.cmi utils/misc.cmi asmcomp/mach.cmi \ - utils/config.cmi asmcomp/cmm.cmi utils/clflags.cmi utils/ccomp.cmi \ - asmcomp/arch.cmo asmcomp/proc.cmi -asmcomp/proc.cmx : asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \ - utils/config.cmx asmcomp/cmm.cmx utils/clflags.cmx utils/ccomp.cmx \ - asmcomp/arch.cmx asmcomp/proc.cmi +asmcomp/proc.cmo : asmcomp/x86_proc.cmi asmcomp/reg.cmi utils/misc.cmi \ + asmcomp/mach.cmi utils/config.cmi asmcomp/cmm.cmi asmcomp/arch.cmo \ + asmcomp/proc.cmi +asmcomp/proc.cmx : asmcomp/x86_proc.cmx asmcomp/reg.cmx utils/misc.cmx \ + asmcomp/mach.cmx utils/config.cmx asmcomp/cmm.cmx asmcomp/arch.cmx \ + asmcomp/proc.cmi asmcomp/reg.cmo : typing/ident.cmi asmcomp/cmm.cmi asmcomp/reg.cmi asmcomp/reg.cmx : typing/ident.cmx asmcomp/cmm.cmx asmcomp/reg.cmi asmcomp/reload.cmo : asmcomp/reloadgen.cmi asmcomp/reg.cmi asmcomp/mach.cmi \ - asmcomp/cmm.cmi utils/clflags.cmi asmcomp/arch.cmo asmcomp/reload.cmi + asmcomp/cmm.cmi utils/clflags.cmi asmcomp/reload.cmi asmcomp/reload.cmx : asmcomp/reloadgen.cmx asmcomp/reg.cmx asmcomp/mach.cmx \ - asmcomp/cmm.cmx utils/clflags.cmx asmcomp/arch.cmx asmcomp/reload.cmi + asmcomp/cmm.cmx utils/clflags.cmx asmcomp/reload.cmi asmcomp/reloadgen.cmo : asmcomp/reg.cmi utils/misc.cmi asmcomp/mach.cmi \ asmcomp/reloadgen.cmi asmcomp/reloadgen.cmx : asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \ @@ -844,6 +896,22 @@ asmcomp/strmatch.cmo : bytecomp/lambda.cmi typing/ident.cmi asmcomp/cmm.cmi \ asmcomp/arch.cmo asmcomp/strmatch.cmi asmcomp/strmatch.cmx : bytecomp/lambda.cmx typing/ident.cmx asmcomp/cmm.cmx \ asmcomp/arch.cmx asmcomp/strmatch.cmi +asmcomp/x86_dsl.cmo : asmcomp/x86_proc.cmi asmcomp/x86_ast.cmi \ + asmcomp/x86_dsl.cmi +asmcomp/x86_dsl.cmx : asmcomp/x86_proc.cmx asmcomp/x86_ast.cmi \ + asmcomp/x86_dsl.cmi +asmcomp/x86_gas.cmo : asmcomp/x86_proc.cmi asmcomp/x86_ast.cmi \ + utils/misc.cmi asmcomp/x86_gas.cmi +asmcomp/x86_gas.cmx : asmcomp/x86_proc.cmx asmcomp/x86_ast.cmi \ + utils/misc.cmx asmcomp/x86_gas.cmi +asmcomp/x86_masm.cmo : asmcomp/x86_proc.cmi asmcomp/x86_ast.cmi \ + asmcomp/x86_masm.cmi +asmcomp/x86_masm.cmx : asmcomp/x86_proc.cmx asmcomp/x86_ast.cmi \ + asmcomp/x86_masm.cmi +asmcomp/x86_proc.cmo : asmcomp/x86_ast.cmi utils/config.cmi \ + utils/clflags.cmi utils/ccomp.cmi asmcomp/x86_proc.cmi +asmcomp/x86_proc.cmx : asmcomp/x86_ast.cmi utils/config.cmx \ + utils/clflags.cmx utils/ccomp.cmx asmcomp/x86_proc.cmi driver/compenv.cmi : driver/compile.cmi : driver/compmisc.cmi : typing/env.cmi @@ -951,13 +1019,15 @@ toplevel/expunge.cmo : bytecomp/symtable.cmi bytecomp/runtimedef.cmi \ toplevel/expunge.cmx : bytecomp/symtable.cmx bytecomp/runtimedef.cmx \ utils/misc.cmx typing/ident.cmx bytecomp/bytesections.cmx toplevel/genprintval.cmo : typing/types.cmi typing/printtyp.cmi \ - typing/predef.cmi typing/path.cmi typing/outcometree.cmi utils/misc.cmi \ - parsing/longident.cmi typing/ident.cmi typing/env.cmi typing/datarepr.cmi \ - typing/ctype.cmi typing/btype.cmi toplevel/genprintval.cmi + typing/predef.cmi typing/path.cmi typing/outcometree.cmi \ + typing/oprint.cmi utils/misc.cmi parsing/longident.cmi typing/ident.cmi \ + typing/env.cmi typing/datarepr.cmi typing/ctype.cmi typing/btype.cmi \ + toplevel/genprintval.cmi toplevel/genprintval.cmx : typing/types.cmx typing/printtyp.cmx \ - typing/predef.cmx typing/path.cmx typing/outcometree.cmi utils/misc.cmx \ - parsing/longident.cmx typing/ident.cmx typing/env.cmx typing/datarepr.cmx \ - typing/ctype.cmx typing/btype.cmx toplevel/genprintval.cmi + typing/predef.cmx typing/path.cmx typing/outcometree.cmi \ + typing/oprint.cmx utils/misc.cmx parsing/longident.cmx typing/ident.cmx \ + typing/env.cmx typing/datarepr.cmx typing/ctype.cmx typing/btype.cmx \ + toplevel/genprintval.cmi toplevel/opttopdirs.cmo : utils/warnings.cmi typing/types.cmi \ typing/printtyp.cmi toplevel/opttoploop.cmi utils/misc.cmi \ parsing/longident.cmi typing/ident.cmi typing/env.cmi typing/ctype.cmi \ @@ -1005,19 +1075,21 @@ toplevel/opttopstart.cmx : toplevel/opttopmain.cmx 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 + typing/path.cmi parsing/parsetree.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 typing/btype.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 + typing/path.cmx parsing/parsetree.cmi 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 typing/btype.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 \ @@ -1059,8 +1131,8 @@ toplevel/topstart.cmx : toplevel/topmain.cmx toplevel/trace.cmo : typing/types.cmi toplevel/toploop.cmi \ typing/printtyp.cmi typing/predef.cmi typing/path.cmi utils/misc.cmi \ bytecomp/meta.cmi parsing/longident.cmi typing/ctype.cmi \ - toplevel/trace.cmi + parsing/asttypes.cmi toplevel/trace.cmi toplevel/trace.cmx : typing/types.cmx toplevel/toploop.cmx \ typing/printtyp.cmx typing/predef.cmx typing/path.cmx utils/misc.cmx \ bytecomp/meta.cmx parsing/longident.cmx typing/ctype.cmx \ - toplevel/trace.cmi + parsing/asttypes.cmi toplevel/trace.cmi diff --git a/.gitignore b/.gitignore index 6c66ecc5a7..e98edf7e45 100644 --- a/.gitignore +++ b/.gitignore @@ -202,11 +202,11 @@ /byterun/.depend /byterun/.depend.nt /byterun/.DS_Store -/byterun/jumptbl.h +/byterun/caml/jumptbl.h /byterun/primitives /byterun/prims.c -/byterun/opnames.h -/byterun/version.h +/byterun/caml/opnames.h +/byterun/caml/version.h /byterun/ocamlrun /byterun/ocamlrun.exe /byterun/ocamlrund @@ -1936,6 +1936,27 @@ /testsuite/tests/misc-unsafe/.depend.nt /testsuite/tests/misc-unsafe/.DS_Store +# /testsuite/tests/ppx-attributes/ +/testsuite/tests/ppx-attributes/*.o +/testsuite/tests/ppx-attributes/*.a +/testsuite/tests/ppx-attributes/*.so +/testsuite/tests/ppx-attributes/*.obj +/testsuite/tests/ppx-attributes/*.lib +/testsuite/tests/ppx-attributes/*.dll +/testsuite/tests/ppx-attributes/*.cm[ioxat] +/testsuite/tests/ppx-attributes/*.cmx[as] +/testsuite/tests/ppx-attributes/*.cmti +/testsuite/tests/ppx-attributes/*.annot +/testsuite/tests/ppx-attributes/*.result +/testsuite/tests/ppx-attributes/*.byte +/testsuite/tests/ppx-attributes/*.native +/testsuite/tests/ppx-attributes/program +/testsuite/tests/ppx-attributes/*.exe +/testsuite/tests/ppx-attributes/*.exe.manifest +/testsuite/tests/ppx-attributes/.depend +/testsuite/tests/ppx-attributes/.depend.nt +/testsuite/tests/ppx-attributes/.DS_Store + # /testsuite/tests/prim-bigstring/ /testsuite/tests/prim-bigstring/*.o /testsuite/tests/prim-bigstring/*.a @@ -2161,6 +2182,31 @@ /testsuite/tests/tool-debugger/find-artifacts/compiler-libs /testsuite/tests/tool-debugger/find-artifacts/out +# /testsuite/tests/tool-debugger/no_debug_event/ +/testsuite/tests/tool-debugger/no_debug_event/*.o +/testsuite/tests/tool-debugger/no_debug_event/*.a +/testsuite/tests/tool-debugger/no_debug_event/*.so +/testsuite/tests/tool-debugger/no_debug_event/*.obj +/testsuite/tests/tool-debugger/no_debug_event/*.lib +/testsuite/tests/tool-debugger/no_debug_event/*.dll +/testsuite/tests/tool-debugger/no_debug_event/*.cm[ioxat] +/testsuite/tests/tool-debugger/no_debug_event/*.cmx[as] +/testsuite/tests/tool-debugger/no_debug_event/*.cmti +/testsuite/tests/tool-debugger/no_debug_event/*.annot +/testsuite/tests/tool-debugger/no_debug_event/*.result +/testsuite/tests/tool-debugger/no_debug_event/*.byte +/testsuite/tests/tool-debugger/no_debug_event/*.native +/testsuite/tests/tool-debugger/no_debug_event/program +/testsuite/tests/tool-debugger/no_debug_event/*.exe +/testsuite/tests/tool-debugger/no_debug_event/*.exe.manifest +/testsuite/tests/tool-debugger/no_debug_event/.depend +/testsuite/tests/tool-debugger/no_debug_event/.depend.nt +/testsuite/tests/tool-debugger/no_debug_event/.DS_Store +/testsuite/tests/tool-debugger/no_debug_event/compiler-libs +/testsuite/tests/tool-debugger/no_debug_event/out +/testsuite/tests/tool-debugger/no_debug_event/c +/testsuite/tests/tool-debugger/no_debug_event/c.exe + # /testsuite/tests/tool-lexyacc/ /testsuite/tests/tool-lexyacc/*.o /testsuite/tests/tool-lexyacc/*.a @@ -2239,6 +2285,27 @@ /testsuite/tests/tool-toplevel/.depend.nt /testsuite/tests/tool-toplevel/.DS_Store +# /testsuite/tests/translprim/ +/testsuite/tests/translprim/*.o +/testsuite/tests/translprim/*.a +/testsuite/tests/translprim/*.so +/testsuite/tests/translprim/*.obj +/testsuite/tests/translprim/*.lib +/testsuite/tests/translprim/*.dll +/testsuite/tests/translprim/*.cm[ioxat] +/testsuite/tests/translprim/*.cmx[as] +/testsuite/tests/translprim/*.cmti +/testsuite/tests/translprim/*.annot +/testsuite/tests/translprim/*.result +/testsuite/tests/translprim/*.byte +/testsuite/tests/translprim/*.native +/testsuite/tests/translprim/program +/testsuite/tests/translprim/*.exe +/testsuite/tests/translprim/*.exe.manifest +/testsuite/tests/translprim/.depend +/testsuite/tests/translprim/.depend.nt +/testsuite/tests/translprim/.DS_Store + # /testsuite/tests/typing-extensions/ /testsuite/tests/typing-extensions/*.o /testsuite/tests/typing-extensions/*.a @@ -2504,6 +2571,27 @@ /testsuite/tests/typing-recmod/*.cm* /testsuite/tests/typing-recmod/*.o +# /testsuite/tests/typing-recordarg/ +/testsuite/tests/typing-recordarg/*.o +/testsuite/tests/typing-recordarg/*.a +/testsuite/tests/typing-recordarg/*.so +/testsuite/tests/typing-recordarg/*.obj +/testsuite/tests/typing-recordarg/*.lib +/testsuite/tests/typing-recordarg/*.dll +/testsuite/tests/typing-recordarg/*.cm[ioxat] +/testsuite/tests/typing-recordarg/*.cmx[as] +/testsuite/tests/typing-recordarg/*.cmti +/testsuite/tests/typing-recordarg/*.annot +/testsuite/tests/typing-recordarg/*.result +/testsuite/tests/typing-recordarg/*.byte +/testsuite/tests/typing-recordarg/*.native +/testsuite/tests/typing-recordarg/program +/testsuite/tests/typing-recordarg/*.exe +/testsuite/tests/typing-recordarg/*.exe.manifest +/testsuite/tests/typing-recordarg/.depend +/testsuite/tests/typing-recordarg/.depend.nt +/testsuite/tests/typing-recordarg/.DS_Store + # /testsuite/tests/typing-short-paths/ /testsuite/tests/typing-short-paths/*.o /testsuite/tests/typing-short-paths/*.a diff --git a/.merlin b/.merlin new file mode 100644 index 0000000000..9977984088 --- /dev/null +++ b/.merlin @@ -0,0 +1,51 @@ +S ./asmcomp +B ./asmcomp + +S ./bytecomp +B ./bytecomp + +S ./driver +B ./driver + +S ./lex +B ./lex + +S ./otherlibs/bigarray +B ./otherlibs/bigarray + +S ./otherlibs/dynlink +B ./otherlibs/dynlink + +S ./otherlibs/graph +B ./otherlibs/graph + +S ./otherlibs/num +B ./otherlibs/num + +S ./otherlibs/str +B ./otherlibs/str + +S ./otherlibs/systhreads +B ./otherlibs/systhreads + +S ./otherlibs/threads +B ./otherlibs/threads + +S ./otherlibs/unix +B ./otherlibs/unix + +S ./parsing +B ./parsing + +S ./stdlib +B ./stdlib + +S ./toplevel +B ./toplevel + +S ./typing +B ./typing + +S ./utils +B ./utils + diff --git a/.travis-ci.sh b/.travis-ci.sh index d65fcbc633..ab5b3bf204 100644 --- a/.travis-ci.sh +++ b/.travis-ci.sh @@ -3,16 +3,18 @@ i386) ./configure make world.opt sudo make install - cd testsuite && make all + (cd testsuite && make all) + mkdir external-packages + cd external-packages git clone git://github.com/ocaml/camlp4 - cd camlp4 && ./configure && make && sudo make install + (cd camlp4 && ./configure && make && sudo make install) git clone git://github.com/ocaml/opam - cd opam && ./configure && make lib-ext && make && sudo make install + (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 + # opam pin add -y utop git://github.com/diml/utop ;; *) echo unknown arch @@ -1,36 +1,447 @@ OCaml 4.03.0: ------------- +(Changes that can break existing programs are marked with a "*") + +Language features: +- PR#5528: inline records for constructor arguments (Alain Frisch) +- PR#6374: allow "_ t" as a short-hand for "(_, _, ..) t" for n-ary type + constructors (Alain Frisch) +- PR#6714: allow [@@ocaml.warning] on most structure and signature items: + values, modules, module types + (Peter Zotov) +- GPR#26: support for "(type a b)" as syntactic sugar for "(type a) (type b)" + (Gabriel Scherer) +* GPR#69: Custom index operators: ( .() ), ( .[] ), ( .{} ) etc. + (user 'Octachron') + The syntax "foo.(bar) <- baz" now desugars into "( .()<- ) foo bar baz"; this + should allow user to define their own notations by overriding. + The bigarray notations ( .{} ), ( .{,} ) etc. are defined in the Bigarray + module, which means that the foo.{bar,baz} syntactic sugar is only available + when the Bigarray module is opened; this can break existing programs, + which should be fixed by opening the Bigarray module. +- GPR#88: allow field punning in object copying expressions: + {< x; y; >} is sugar for {< x = x; y = y; >} + (Jeremy Yallop) + Compilers: - PR#6501: harden the native-code generator against certain uses of "%identity" (Xavier Leroy, report by Antoine Miné). +- PR#6636: add --version option + (Peter Zotov) +- improve type-specialization of unapplied primitives + (Frédéric Bour, review by Gabriel Scherer) +- PR#6737: fix Typedtree attributes on (fun x -> body) expressions +- PR#6679: fix pprintast printing of constraints in type declarations +- PR#6845: -no-check-prims to tell ocamlc not to check primitives in runtime +- GPR#17: some cmm optimizations of integer operations with constants + (Stephen Dolan, review by Pierre Chambart) +- GPR#109: new unboxing strategy for float and int references (Vladimir Brankov, + review by Alain Frisch) 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) +- PR#6760: closures evaluated in the toplevel can now be marshalled + (Peter Zotov, review by Jacques-Henri Jourdan) +- PR#6902, GPR#210: runtime emits a warning when finalizing an I/O channel + which is still open (Alain Frisch, review by Damien Doligez) +- Signal handling: for read-and-clear, use GCC/Clang atomic builtins + if available. (Xavier Leroy) Standard library: +- PR#6316: Scanf.scanf failure on %u formats when reading big integers + (Xavier Leroy, Benoît Vaugon) +- PR#6390, GPR#36: expose Sys.{int_size,max_wosize} for improved js_of_ocaml portability + (Hugo Heuzard) +* PR#6494: Add equal function in modules + Bytes, Char, Digest, Int32, Int64, Nativeint, and String + (Romain Calascibetta) +* PR#6524, GPR#79: Filename: Optional ?perms argument to open_temp_file + (Daniel Bünzli, review by Jacques-Pascal Deplaix) - PR#6577: improve performance of %L, %l, %n, %S, %C format specifiers (Alain Frisch) - PR#6585: fix memory leak in win32unix/createprocess.c +- PR#6645, GPR#174: Guarantee that Set.add, Set.remove, Set.filter + return the original set if no change is required (Alain Frisch, + Mohamed Iguernelala) +- PR#6694, PR#6695: deprecate functions using ISO-8859-1 character set + in Char, Bytes, String and provide alternatives using US-ASCII. + (Peter Zotov) Type system: -- PR#6374: allow "_ t" as a short-hand for "(_, _, ..) t" for n-ary type - constructors (Alain Frisch) +- PR#5545: Type annotations on methods cannot control the choice of abbreviation * 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.2: +Toplevel and debugger: +- PR#6468: toplevel now supports backtraces if invoked with OCAMLRUNPARAM=b + (Peter Zotov and Jake Donham, + review by Gabriel Scherer and Jacques-Henri Jourdan) + +Other libraries: +- PR#6896: serious reimplementation of Big_int.float_of_big_int and + Ratio.float_of_ratio, ensuring that the result is correctly rounded. + (Xavier Leroy) + +OCamlbuild: +- PR#6794, PR#6809: pass package-specific include flags when building C files + (Jérémie Dimino, request by Peter Zotov) +- GPR#208: add "asm" tag to ocamlbuild to enable flag -S + (ygrek) + +Bug fixes: +* PR#4539: change exception string raised when comparing functional values + (Nicolas Braud-Santoni, report by Eric Cooper) +- PR#4832: Filling bigarrays may block out runtime + (Markus Mottl) +- PR#5663: program rejected due to nongeneralizable type variable that + appears nowhere + (Jacques Garrigue, report by Stephen Weeks) +- PR#5887: move the byterun/*.h headers to byterun/caml/*.h to avoid header + name clashes + (Jérôme Vouillon and Adrien Nader and Peter Zotov) +* PR#6081: ocaml should add script's directory to search path, not current + directory + (Thomas Leonard and Damien Doligez) +- PR#6171: Error message confusing when a type escapes its scope. +- PR#6340: Incorrect handling of \r when processing "Windows" source files + (Damien Doligez, report by David Allsopp) +* PR#6521: {Bytes,Char,String}.escaped are locale-dependent + (Damien Doligez, report by Jun Furuse) +- PR#6526: ocamllex warning: unescaped newline in comment string + (Damien Doligez, report by user 'dhekir') +- PR#6341: ocamldoc -colorize-code adds spurious <br> tags to <pre> blocks +- PR#6560: Wrong failure message for {Int32,Int64,NativeInt}.of_string + (Maxime Dénès and Gabriel Scherer) +- PR#6648: show_module should indicate its elision +- PR#6650: Cty_constr not handled correctly by Subst +- PR#6651: Failing component lookup +* PR#6664: Crash when finalising lazy values of the wrong type. + (Damien Doligez) +- PR#6672: Unused variance specification allowed in with constraint +- PR#6744: Univars can escape through polymorphic variants (partial fix) +- PR#6776: Failure to kill the "tick" thread, segfault when exiting the runtime +- PR#6752: Extensible variant types and scope escaping +- PR#6808: the parsing of OCAMLRUNPARAM is too lax + (Damien Doligez) +- PR#6874: Inefficient code generated for module function arguments +- PR#6897: Bad error message for some pattern matching on extensible variants +- PR#6899: Optional parameters and non generalizable type variables + (Thomas Refis and Leo White) +- PR#6931: Incorrect error message +- PR#6938: fix regression on "%047.27{l,L,n}{d,i,x,X,o,u}" + (Benoît Vaugon, report by Arduino Cascella) +- GPR#205: Clear caml_backtrace_last_exn before registering as root (report + and fix by Frederic Bour) + +Features wishes: +- PR#4714: List.cons +- PR#5418 (comments) : generate dependencies with $(CC) instead of gcc +- PR#6167: OCAMLPARAM support for disabling PIC generation ("pic=0") + (Gabor Pali) +- PR#6367: introduce Asttypes.arg_label to encode labelled arguments +- PR#6452, GPR#140: add internal suport for custom printing formats + (Jérémie Dimino) +- PR#6611: remove the option wrapper on optional arguments in the syntax tree +- PR#6635: support M.[], M.(), M.{< >} and M.[| |] + (Jeremy Yallop, review by Gabriel Radanne) +- PR#6691: install .cmt[i] files for stdlib and compiler-libs + (David Sheets, request by Gabriel Radanne) +- PR#6722: compatibility with x32 architecture (x86-64 in ILP32 mode). + ocamlopt is not supported, but bytecode compiles cleanly. +- PR#6742: remove duplicate virtual_flag information from Tstr_class +- PR#6719: improve Buffer.add_channel when not enough input is available + (Simon Cruanes) +* PR#6816: reject integer and float literals followed by alphanum + (Hugo Heuzard) +- PR#6876: improve warning 6 by listing the omitted labels. + (Eyyüb Sari) +- PR#6924: tiny optim to avoid some spilling of floats in x87 + (Alain Frisch) +- GPR#111: `(f [@taillcall]) x y` warns if `f x y` is not a tail-call + (Simon Cruanes) +- GPR#118: ocamldep -allow-approx: fallback to a lexer-based approximation + (Frédéric Bour) +- GPR#137: add untypeast.ml (in open recursion style) to compiler-libs + (Gabriel Radanne) +- GPR#142: add a CAMLdrop macro for undoing CAMLparam*/CAMLlocal* +- GPR#145: speeedup bigarray access by optimizing Cmmgen.bigarray_indexing + (Vladimir Brankov, review by Gabriel Scherer) +- GPR#147: [type 'a result = Ok of 'a | Error of 'b] in Pervasives + (Yaron Minsky) +- GPR#156: Optimize reallocation of caml_frame_descriptors (dynlink speedup) + (Pierre Chambart, review by François Bobot, Xavier Leroy and Damien Doligez) +- GPR#171: allow custom warning printers / catchers + (Benjamin Canou, review by Damien Doligez) +- GPR#191: Making gc.h and some part of memory.h public + (Thomas Refis) +- GPR#196: Make [Thread.id] and [Thread.self] [noalloc] + (Clark Gaebel) +- GPR#165: fix windows compilation warnings + (Bernhard Schommer) + +OCaml 4.02.3: ------------- +Bug fixes: +- PR#6919: corrupted final_table + (ygrek) +- PR#6930: Aliased result type of GADT constructor results in assertion failure + (Jacques Garrigue) + +OCaml 4.02.2 (17 Jun 2015): +--------------------------- + +(Changes that can break existing programs are marked with a "*") + +Language features: +- PR#6583: add a new class of binary operators with the same syntactic + precedence as method calls; these operators start with # followed + by a non-empty sequence of operator symbols (for instance #+, #!?). + It is also possible to use '#' as part of these extra symbols + (for instance ##, or #+#); this is rejected by the type-checker, + but can be used e.g. by ppx rewriters. + (Alain Frisch, request by Gabriel Radanne) +* PR#6016: add a "nonrec" keyword for type declarations + (Jérémie Dimino) + +Compilers: +- PR#6600: make -short-paths faster by building the printing map + incrementally + (Jacques Garrigue) +- PR#6642: replace $CAMLORIGIN in -ccopt with the path to cma or cmxa + (Peter Zotov, Gabriel Scherer, review by Damien Doligez) +- PR#6797: new option -output-complete-obj + to output an object file with included runtime and autolink libraries + (Peter Zotov) +- PR#6845: -no-check-prims to tell ocamlc not to check primitives in runtime + (Alain Frisch) +- GPR#149: Attach documentation comments to parse tree + (Leo White) +- GPR#159: Better locations for structure/signature items + (Leo White) + +Toplevel and debugger: +- PR#5958: generalized polymorphic #install_printer + (Pierre Chambart and Grégoire Henry) + +OCamlbuild: +- PR#6237: explicit "infer" tag to control or disable menhir --infer + (Hugo Heuzard) +- PR#6625: pass -linkpkg to files built with -output-obj. + (Peter Zotov) +- PR#6702: explicit "linkpkg" and "dontlink(foo)" flags + (Peter Zotov, Gabriel Scherer) +- PR#6712: Ignore common VCS directories + (Peter Zotov) +- PR#6720: pass -g to C compilers when tag 'debug' is set + (Peter Zotov, Gabriel Scherer) +- PR#6733: add .byte.so and .native.so targets to pass + -output-obj -cclib -shared. + (Peter Zotov) +- PR#6733: "runtime_variant(X)" to pass -runtime-variant X option. + (Peter Zotov) +- PR#6774: new menhir-specific flags "only_tokens" and "external_tokens(Foo)" + (François Pottier) + +Libraries: +- PR#6285: Add support for nanosecond precision in Unix.stat() + (Jérémie Dimino, report by user 'gfxmonk') +- PR#6781: Add higher baud rates to Unix termios + (Damien Doligez, report by Berke Durak) +- PR#6834: Add Obj.{first,last}_non_constant_constructor_tag + (Mark Shinwell, request by Gabriel Scherer) + +Libraries: +- PR#6285: Add support for nanosecond precision in Unix.stat() + (Jérémie Dimino, report by user 'gfxmonk') + +Runtime: +- PR#6078: Release the runtime system when calling caml_dlopen + (Jérémie Dimino) +- PR#6675: GC hooks + (Damien Doligez and Roshan James) + +Build system: +- PR#5418 (comments) : generate dependencies with $(CC) instead of gcc + (Damien Doligez and Michael Grünewald) +- PR#6266: Cross compilation for iOs, Android etc + (Peter Zotov, review by Damien Doligez and Mark Shinwell) + +Installation procedure: +- Update instructions for x86-64 PIC mode and POWER architecture builds + (Mark Shinwell) + +Bug fixes: +- PR#5271: Location.prerr_warning is hard-coded to use Format.err_formatter + (Damien Doligez, report by Rolf Rolles) +- PR#5395: OCamlbuild mishandles relative symlinks and include paths + (Damien Doligez, report by Didier Le Botlan) +- PR#5822: wrong value of Options.ext_dll on windows + (Damien Doligez and Daniel Weil) +- PR#5836, PR#6684: printing lazy values in ocamldebug may segfault + (Gabriel Scherer, request by the Coq team) +- PR#5887: move the byterun/*.h headers to byterun/caml/*.h to avoid + header name clashes + (Jérôme Vouillon and Adrien Nader and Peter Zotov) +- PR#6281: Graphics window does not acknowledge second click (double click) + (Kyle Headley) +- PR#6490: incorrect backtraces in gdb on AArch64. Also fixes incorrect + backtraces on 32-bit ARM. + (Mark Shinwell) +- PR#6573: extern "C" for systhreads/threads.h + (Mickaël Delahaye) +- PR#6575: Array.init evaluates callback although it should not do so + (Alain Frisch, report by Gerd Stolpmann) +- PR#6607: The manual doesn't mention 0x200 flag for OCAMLRUNPARAM=v + (Alain Frisch) +- PR#6616: allow meaningful use of -use-runtime without -custom. + (Peter Zotov) +- PR#6617: allow android build with pthreads support (since SDK r10c) + (Peter Zotov) +- PR#6626: ocamlbuild on cygwin cannot find ocamlfind + (Gergely Szilvasy) - PR#6628: Configure script rejects legitimate arguments + (Michael Grünewald, Damien Doligez) +- PR#6630: Failure of tests/prim-bigstring/{big,}string.ml on big-endian + architectures + (Pierre Chambart, testing by Mark Shinwell) +- PR#6640: ocamlbuild: wrong "unused tag" warning on "precious" + (report by user 'william') +- PR#6652: ocamlbuild -clean does not print a newline after output + (Damien Doligez, report by Andi McClure) +- PR#6658: cross-compiler: version check not working on OS X + (Gerd Stolpmann) +- PR#6665: Failure of tests/asmcomp on sparc + (Stéphane Glondu) +- PR#6667: wrong implementation of %bswap16 on ARM64 + (Xavier Leroy) +- PR#6669: fix 4.02 regression in toplevel printing of lazy values + (Leo White, review by Gabriel Scherer) +- PR#6671: Windows: environment variable 'TZ' affects Unix.gettimeofday + (Mickael Delahaye and Damien Doligez) +- PR#6680: Missing parentheses in warning about polymorphic variant value + (Jacques Garrigue and Gabriel Scherer, report by Philippe Veber) +- PR#6686: Bug in [subst_boxed_number] + (Jérémie Dimino, Mark Shinwell) +- PR#6690: Uncaught exception (Not_found) with (wrong) wildcard or unification + type variable in place of a local abstract type + (Jacques Garrigue, report by Mikhail Mandrykin) +- PR#6693 (part two): Incorrect relocation types in x86-64 runtime system + (Peter Zotov, review by Jacques-Henri Jourdan, Xavier Leroy and Mark Shinwell) +- PR#6717: Pprintast does not print let-pattern attributes + (Gabriel Scherer, report by Peter Zotov) +- PR#6727: Printf.sprintf "%F" misbehavior + (Benoît Vaugon, report by Vassili Karpov) +- PR#6747: ocamlobjinfo: missing symbol caml_plugin_header due to underscore + (Damien Doligez, Maverick Woo) +- PR#6749: ocamlopt returns n for (n mod 1) instead of 0 + (Mark Shinwell and Jérémie Dimino) +- PR#6753: Num.quo_num and Num.mod_num incorrect for some negative arguments + (Xavier Leroy) +- PR#6758: Ocamldoc "analyse_module: parsetree and typedtree don't match" + (Damien Doligez, report by user 'maro') +- PR#6759: big_int_of_string incorrectly parses some hexa literals + (Damien Doligez, report by Pierre-yves Strub) +- PR#6763: #show with -short-paths doesn't select shortest type paths + (Jacques Garrigue, report by David Sheets) +- PR#6768: Typechecker overflow the stack on cyclic type + (Jacques Garrigue, report by user 'darktenaibre') +- PR#6770: (duplicate of PR#6686) +- PR#6772: asmrun/signals_asm.c doesn't compile on NetBSD/i386 + (Kenji Tokudome) +- PR#6775: Digest.file leaks file descriptor on error + (Valentin Gatien-Baron) +- PR#6779: Cross-compilers cannot link bytecode using custom primitives + (Damien Doligez, request by Peter Zotov) +- PR#6787: Soundness bug with polymorphic variants + (Jacques Garrigue, with help from Leo White and Grégoire Henry, + report by Michael O'Connor) +- PR#6790: otherlibs should be built with -g + (Damien Doligez, report by Peter Zotov) +- PR#6791: "%s@[", "%s@{" regression in Scanf + (Benoît Vaugon) +- PR#6793: ocamlbuild passes nonsensical "-ocamlc ..." commands to menhir + (Gabriel Scherer, report by Damien Doligez) +- PR#6799: include guards missing for unixsupport.h and other files + (Andreas Hauptmann) +- PR#6810: Improve documentation of Bigarray.Genarray.map_file + (Mark Shinwell and Daniel Bünzli) +- PR#6812: -short-paths and -no-alias-deps can create inconsistent assumptions + (Jacques Garrigue, report by Valentin Gatien-Baron) +- PR#6817: GADT exhaustiveness breakage with modules + (Leo White, report by Pierre Chambart) +- PR#6824: fix buffer sharing on partial application of Format.asprintf + (Gabriel Scherer, report by Alain Frisch) +- PR#6831: Build breaks for -aspp gcc on solaris-like OSs + (John Tibble) +- PR#6836: Assertion failure using -short-paths + (Jacques Garrigue, report by David Sheets) +- PR#6837: Build profiling libraries on FreeBSD and NetBSD x86-64 + (Mark Shinwell, report by Michael Grünewald) +- PR#6841: Changing compilation unit name with -o breaks ocamldebug + (Jacques Garrigue, report by Jordan Walke) +- PR#6842: export Typemod.modtype_of_package +- PR#6843: record weak dependencies even when the .cmi is missing + (Leo White, Gabriel Scherer) +- PR#6849: Inverted pattern unification error + (Jacques Garrigue, report by Leo White) +- PR#6857: __MODULE__ doesn't give the current module with -o + (Jacques Garrigue, report by Valentin Gatien-Baron) +- PR#6862: Exhaustiveness check wrong for class constructor arguments + (Jacques Garrigue) +- PR#6869: Improve comment on [Hashtbl.hash_param] + (Mark Shinwell, report by Jun Furuse) +- PR#6870: Unsoundness when -rectypes fails to detect non-contractive type + (Jacques Garrigue, report by Stephen Dolan) +- PR#6872: Type-directed propagation fails to disambiguate variants + that are also exception constructors + (Jacques Garrigue, report by Romain Beauxis) +- PR#6878: AArch64 backend generates invalid asm: conditional branch + out of range (Mark Shinwell, report by Richard Jones, testing by Richard + Jones and Xavier Leroy, code review by Xavier Leroy and Thomas Refis) +- PR#6879: Wrong optimization of 1 mod n + (Mark Shinwell, report by Jean-Christophe Filliâtre) +- PR#6884: The __CYGWIN32__ #define should be replaced with __CYGWIN__ + (Adrien Nader) +- PR#6886: -no-alias-deps allows to build self-referential compilation units + (Jacques Garrigue, report by Valentin Gatien-Baron) +- PR#6889: ast_mapper fails to rewrite class attributes + (Sébastien Briais) +- PR#6893: ocamlbuild: "tag not used" warning when using (p)dep + (Gabriel Scherer, report by Christiano Haesbaert) +- GPR#143: fix getsockopt behaviour for boolean socket options + (Anil Madhavapeddy and Andrew Ray) +- GPR#190: typo in pervasives + (Guillaume Bury) +- Misplaced assertion in major_gc.c for no-naked-pointers mode + (Stephen Dolan, Mark Shinwell) -OCaml 4.02.1: -------------- +Feature wishes: +- PR#6452, GPR#140: add internal suport for custom printing formats + (Jérémie Dimino) +- PR#6641: add -g, -ocamlcflags, -ocamloptflags options to ocamlmklib + (Peter Zotov) +- PR#6693: also build libasmrun_shared.so and lib{asm,caml}run_pic.a + (Peter Zotov, review by Mark Shinwell) +- PR#6842: export Typemod.modtype_of_package + (Jacques Garrigue, request by Jun Furuse) +- GPR#139: more versatile specification of locations of .annot + (Christophe Troestler, review by Damien Doligez) +- GPR#171: allow custom warning printers / catchers + (Benjamin Canou, review by Damien Doligez) +- Misplaced assertion in major_gc.c for no-naked-pointers mode + (Stephen Dolan, Mark Shinwell) +- GPR#191: Making gc.h and some part of memory.h public + (Thomas Refis) + +OCaml 4.02.1 (14 Oct 2014): +--------------------------- (Changes that can break existing programs are marked with a "*") @@ -49,7 +460,7 @@ Standard library: (Xavier Leroy, Alain Frisch, relase-worthy report by Jacques-Pascal Deplaix) - PR#6530: Add stack overflow handling for native code (OpenBSD i386 and amd64) (Cristopher Zimmermann) -- PR#6533: broken semantics of %(%) when substitued by a box +- PR#6533: broken semantics of %(%) when substituted by a box (Benoît Vaugon, report by Boris Yakobowski) - PR#6534: legacy support for %.10s (Benoît Vaugon, Gabriel Scherer, report by Nick Chapman) @@ -81,6 +492,8 @@ Standard library: (Jacques Garrigue, report by Mark Shinwell) - PR#6572: Fatal error with recursive modules (Jacques Garrigue, report by Quentin Stievenart) +- PR#6575: Array.init evaluates callback although it should not do so + (Alain Frisch, report by Gerd Stolpmann) - PR#6578: Recursive module containing alias causes Segmentation fault (Jacques Garrigue) - PR#6581: Some bugs in generative functors @@ -98,8 +511,8 @@ Standard library: - ocamlbuild: add an -ocamlmklib option to change the ocamlmklib command (Jérôme Vouillon) -Ocaml 4.02.0: -------------- +OCaml 4.02.0 (29 Aug 2014): +--------------------------- (Changes that can break existing programs are marked with a "*") @@ -108,7 +521,7 @@ Language features: (Alain Frisch) - Generative functors (PR#5905) (Jacques Garrigue) -- Module aliases +* Module aliases (Jacques Garrigue) * Alternative syntax for string literals {id|...|id} (can break comments) (Alain Frisch) @@ -139,8 +552,8 @@ Type system: 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" + identity. Compiled interfaces become smaller, but may depend on the + original modules. This also 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 @@ -391,7 +804,7 @@ Features wishes: - 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') + (Daniel Weil) - PR#5650: Camlp4FoldGenerator doesn't handle well "abstract" types (Hongbo Zhang) - PR#5808: allow simple patterns, not just identifiers, in "let p : t = ..." @@ -451,8 +864,8 @@ Features wishes: - make ocamldebug -I auto-detection work with ocamlbuild (Josh Watzman) -OCaml 4.01.0: -------------- +OCaml 4.01.0 (12 Sep 2013): +--------------------------- (Changes that can break existing programs are marked with a "*") @@ -887,8 +1300,8 @@ Tools: (Guillaume Melquiond, Alain Frisch) -OCaml 4.00.1: -------------- +OCaml 4.00.1 (5 Oct 2012): +-------------------------- Bug fixes: - PR#4019: better documentation of Str.matched_string @@ -917,8 +1330,8 @@ Bug fixes: - PR#5761: Incorrect bigarray custom block size -OCaml 4.00.0: -------------- +OCaml 4.00.0 (26 Jul 2012): +--------------------------- (Changes that can break existing programs are marked with a "*") @@ -1244,8 +1657,8 @@ Other changes: - Copy VERSION file to library directory when installing. -OCaml 3.12.1: -------------- +OCaml 3.12.1 (4 Jul 2011): +-------------------------- Bug fixes: - PR#4345, PR#4767: problems with camlp4 printing of float values @@ -1342,8 +1755,8 @@ Other changes: comparing a custom block value with an unboxed integer. -Objective Caml 3.12.0: ----------------------- +Objective Caml 3.12.0 (2 Aug 2010): +----------------------------------- (Changes that can break existing programs are marked with a "*" ) @@ -1473,8 +1886,8 @@ Bug Fixes: - Small problem with representation of Int32, Int64, and Nativeint constants. - Use RTLD_LOCAL for native dynlink in private mode. -Objective Caml 3.11.2: ----------------------- +Objective Caml 3.11.2 (20 Jan 2010): +------------------------------------ Bug fixes: - PR#4151: better documentation for min and max w.r.t. NaN @@ -1522,8 +1935,8 @@ Feature wishes: - PR#4723: "clear_rules" function to empty the set of ocamlbuild rules - PR#4921: configure option to help cross-compilers -Objective Caml 3.11.1: ----------------------- +Objective Caml 3.11.1 (12 Jun 2009): +------------------------------------ Bug fixes: - PR#4095: ocamldebug: strange behaviour of control-C @@ -1578,8 +1991,8 @@ Other changes: - Support for 64-bit mode in Solaris/x86 (PR#4670). -Objective Caml 3.11.0: ----------------------- +Objective Caml 3.11.0 (03 Dec 2008): +------------------------------------ (Changes that can break existing programs are marked with a "*" ) @@ -1709,8 +2122,8 @@ Bug fixes: - PR#4614: Inconsistent declaration of CamlCBCmd in LablTk library. -Objective Caml 3.10.2: ----------------------- +Objective Caml 3.10.2 (29 Feb 2008): +------------------------------------ Bug fixes: - PR#1217 (partial) Typo in ocamldep man page @@ -1727,8 +2140,8 @@ Bug fixes: - Bug in typing of polymorphic variants (reported on caml-list) -Objective Caml 3.10.1: ----------------------- +Objective Caml 3.10.1 (11 Jan 2008): +------------------------------------ Bug fixes: - PR#3830 small bugs in docs @@ -1814,8 +2227,8 @@ New features: emacs files -Objective Caml 3.10.0: ----------------------- +Objective Caml 3.10.0 (18 May 2007): +------------------------------------ (Changes that can break existing programs are marked with a "*" ) @@ -1892,8 +2305,8 @@ Lexer generator (ocamllex): improved error reporting. License: fixed a typo in the "special exception" to the LGPL. -Objective Caml 3.09.3: ----------------------- +Objective Caml 3.09.3 (15 Sep 2006): +------------------------------------ Bug fixes: - ocamldoc: -using modtype constraint to filter module elements displayed @@ -1928,8 +2341,8 @@ New features: -Objective Caml 3.09.2: ----------------------- +Objective Caml 3.09.2 (14 Apr 2006): +------------------------------------ Bug fixes: - Makefile: problem with "make world.opt" PR#3954 @@ -1959,8 +2372,8 @@ New features: - ported to MacOS X on Intel PR#3985 - configure: added support for GNU Hurd PR#3991 -Objective Caml 3.09.1: ----------------------- +Objective Caml 3.09.1 (4 Jan 2006): +----------------------------------- Bug fixes: - compilers: raise not_found with -principal PR#3855 @@ -1994,8 +2407,8 @@ Bug fixes: New features: - otherlibs/labltk: browser uses menu bars instead of menu buttons -Objective Caml 3.09.0: ----------------------- +Objective Caml 3.09.0 (27 Oct 2006): +------------------------------------ (Changes that can break existing programs are marked with a "*" ) @@ -2069,8 +2482,8 @@ Miscellaneous: - Configuration information is installed in `ocamlc -where`/Makefile.config and can be used by client Makefiles or shell scripts. -Objective Caml 3.08.4: ----------------------- +Objective Caml 3.08.4 (11 Aug 2005): +------------------------------------ New features: - configure: find X11 config in some 64-bit Linux distribs @@ -2117,8 +2530,8 @@ Bug fixes: - yacc: avoid name capture for idents of the Parsing module -Objective Caml 3.08.3: ----------------------- +Objective Caml 3.08.3 (24 Mar 2005): +------------------------------------ New features: - support for ocamlopt -pack under Mac OS X (PR#2634, PR#3320) @@ -2162,8 +2575,8 @@ Bug fixes: - windows: better handling of InterpreterPath registry entry (PR#3334, PR#3432) -Objective Caml 3.08.2: ----------------------- +Objective Caml 3.08.2 (22 Nov 2004): +------------------------------------ Bug fixes: - runtime: memory leak when unmarshalling big data structures (PR#3247) @@ -2183,8 +2596,8 @@ Misc: - unix: added missing #includes (PR#3088) -Objective Caml 3.08.1: ----------------------- +Objective Caml 3.08.1 (19 Aug 2004): +------------------------------------ Licence: - The emacs files are now under GPL @@ -2208,8 +2621,8 @@ Misc: - added -v option to ocamllex - ocamldoc: new -intf and -impl options supported (PR#3036) -Objective Caml 3.08.0: ----------------------- +Objective Caml 3.08.0 (13 Jul 2004): +------------------------------------ (Changes that can break existing programs are marked with a "*" ) @@ -2310,8 +2723,8 @@ Camlp4: - See camlp4/CHANGES and camlp4/ICHANGES for more info. -Objective Caml 3.07: --------------------- +Objective Caml 3.07 (29 Sep 2003): +---------------------------------- Language features: - Experimental support for recursive module definitions @@ -2470,8 +2883,8 @@ OCamldoc: - fix: empty [] in generated HTML indexes -Objective Caml 3.06: --------------------- +Objective Caml 3.06 (20 Aug 2002): +---------------------------------- Type-checking: - Apply value restriction to polymorphic record fields. @@ -2496,8 +2909,8 @@ Windows ports: - Fixed two problems with the Mingw port under Cygwin 1.3. -Objective Caml 3.05: --------------------- +Objective Caml 3.05 (29 Jul 2002): +---------------------------------- Language features: - Support for polymorphic methods and record fields. @@ -2628,8 +3041,8 @@ Windows port: - LablTk library: fixed a bug in Fileinput -Objective Caml 3.04: --------------------- +Objective Caml 3.04 (13 Dec 2001): +---------------------------------- Type-checker: - Allowed coercing self to the type of the current class, avoiding @@ -2696,8 +3109,8 @@ License: added special exception to the LGPL'ed code (libraries and runtime system) allowing unrestricted linking, whether static or dynamic. -Objective Caml 3.03 ALPHA: --------------------------- +Objective Caml 3.03 ALPHA (12 Oct 2001): +---------------------------------------- Language: - Removed built-in syntactic sugar for streams and stream patterns @@ -2777,8 +3190,8 @@ Windows port: -Objective Caml 3.02: --------------------- +Objective Caml 3.02 (30 Jul 2001): +---------------------------------- Both compilers: - Fixed embarrassing bug in pattern-matching compilation @@ -2843,8 +3256,8 @@ MacOS 9 port: - Removed the last traces of support for 68k -Objective Caml 3.01: --------------------- +Objective Caml 3.01 (09 Mar 2001): +---------------------------------- New language features: - Variables are allowed in "or" patterns, e.g. @@ -2961,8 +3374,8 @@ Mac OS ports: - Int64.format works on Mac OS 8/9. -Objective Caml 3.00: --------------------- +Objective Caml 3.00 (25 Apr 2000): +---------------------------------- Language: - OCaml/OLabl merger: @@ -3072,8 +3485,8 @@ Macintosh port: program written in O'Caml. -Objective Caml 2.04: --------------------- +Objective Caml 2.04 (26 Nov 1999): +---------------------------------- - C interface: corrected inconsistent change in the CAMLparam* macros. - Fixed internal error in ocamlc -g. @@ -3086,8 +3499,8 @@ Objective Caml 2.04: - Native-code compiler: fixed bug in assembling certain floating-point constants (masm doesn't grok 2e5, wants 2.0e5). -Objective Caml 2.03: --------------------- +Objective Caml 2.03 (19 Nov 1999): +---------------------------------- New ports: - Ported to BeOS / Intel x86 (bytecode and native-code). @@ -3172,8 +3585,8 @@ Others: not loading properly. -Objective Caml 2.02: --------------------- +Objective Caml 2.02 (04 Mar 1999): +---------------------------------- * Type system: - Check that all components of a signature have unique names. @@ -3255,8 +3668,8 @@ Objective Caml 2.02: - Fixed end-of-line bug in ocamlcp causing problems with generated sources. -Objective Caml 2.01: --------------------- +Objective Caml 2.01 (09 Dec 1998): +---------------------------------- * Typing: - Added warning for expressions of the form "a; b" where a does not have @@ -3333,8 +3746,8 @@ Objective Caml 2.01: * Macintosh port: source code for Macintosh application merged in. -Objective Caml 2.00: --------------------- +Objective Caml 2.00 (19 Aug 1998): +---------------------------------- * Language: - New class language. See http://caml.inria.fr/ocaml/refman/ @@ -3432,8 +3845,8 @@ Objective Caml 2.00: - Fixed bug with next-error under Emacs 20. -Objective Caml 1.07: --------------------- +Objective Caml 1.07 (11 Dec 1997): +---------------------------------- * Native-code compiler: - Revised interface between generated code and GC, fixes serious GC @@ -3457,8 +3870,8 @@ Objective Caml 1.07: * MS Windows port: better handling of long command lines in Sys.command -Objective Caml 1.06: --------------------- +Objective Caml 1.06 (18 Nov 1997): +---------------------------------- * Language: - Added two new keywords: "assert" (check assertion) and "lazy" @@ -3555,8 +3968,8 @@ Objective Caml 1.06: * Emacs editing mode and debugger interface updated to July '97 version. -Objective Caml 1.05: --------------------- +Objective Caml 1.05 (21 Mar 1997): +---------------------------------- * Typing: fixed several bugs causing spurious type errors. @@ -3574,8 +3987,8 @@ handling of checkpoints; various other small fixes. * Macintosh port: fixed signed division problem in bytecomp/emitcode.ml -Objective Caml 1.04: --------------------- +Objective Caml 1.04 (11 Mar 1997): +---------------------------------- * Replay debugger ported from Caml Light; added debugger support in compiler (option -g) and runtime system. Debugger is alpha-quality @@ -3637,8 +4050,8 @@ Objective Caml 1.04: * Emacs editing mode and debugger interface included in distribution. -Objective Caml 1.03: --------------------- +Objective Caml 1.03 (29 Oct 1996): +---------------------------------- * Typing: - bug with type names escaping their scope via unification with @@ -3686,8 +4099,9 @@ Objective Caml 1.03: * Perl-free, cpp-free, cholesterol-free installation procedure. -Objective Caml 1.02: --------------------- +Objective Caml 1.02 (27 Sep 1996): +---------------------------------- + * Typing: - fixed bug with type names escaping their scope via unification with non-generalized type variables '_a; @@ -3743,8 +4157,9 @@ Objective Caml 1.02: and call caml_main() later. -Objective Caml 1.01: --------------------- +Objective Caml 1.01 (12 Jun 1996): +---------------------------------- + * Typing: better report of type incompatibilities; non-generalizable type variables in a struct...end no longer flagged immediately as an error; @@ -3795,8 +4210,8 @@ Objective Caml 1.01: some error messages have been made clearer; several bugs fixes. -Objective Caml 1.00: --------------------- +Objective Caml 1.00 (9 May 1996): +--------------------------------- * Merge of Jerome Vouillon and Didier Remy's object-oriented extensions. @@ -3831,8 +4246,8 @@ marshaling to/from strings. * Dynlink library: added support for linking libraries (.cma files). -Caml Special Light 1.15: ------------------------- +Caml Special Light 1.15 (15 Mar 1996): +-------------------------------------- * Caml Special Light now runs under Windows NT and 95. Many thanks to Kevin Gallo (Microsoft Research) who contributed his initial port. @@ -3862,8 +4277,8 @@ manifest module type specifications. * Unix library: bug in gethostbyaddr fixed; bounds checking for read, write, etc. -Caml Special Light 1.14: ------------------------- +Caml Special Light 1.14 (8 Feb 1996): +------------------------------------- * cslopt ported to the PowerPC/RS6000 architecture. Better support for AIX in the bytecode system as well. @@ -3876,8 +4291,8 @@ out-of-order pops fixed. * Several bug fixes in callbacks and signals. -Caml Special Light 1.13: ------------------------- +Caml Special Light 1.13 (4 Jan 1996): +------------------------------------- * Pattern-matching compilation revised to factor out accesses inside matched structures. @@ -3900,13 +4315,13 @@ Intel decided to organize the floating-point registers as a stack). * cslopt for the Sparc: don't use Sparc V8 smul and sdiv instructions, emulation on V7 processors is abysmal. -Caml Special Light 1.12: ------------------------- +Caml Special Light 1.12 (30 Nov 1995): +-------------------------------------- * Fixed an embarrassing bug with references to floats. -Caml Special Light 1.11: ------------------------- +Caml Special Light 1.11 (29 Nov 1995): +-------------------------------------- * Streams and stream parsers a la Caml Light are back (thanks to Daniel de Rauglaudre). @@ -3928,8 +4343,8 @@ core on me). * Lower memory consumption for the native-code compiler. -Caml Special Light 1.10: ------------------------- +Caml Special Light 1.10 (07 Nov 1995): +-------------------------------------- * Many bug fixes (too many to list here). @@ -3946,8 +4361,8 @@ arbitrary-precision arithmetic have been ported (thanks to John Malecki and Victor Manuel Gulias Fernandez); better docs for the Unix and regexp libraries. -Caml Special Light 1.07: ------------------------- +Caml Special Light 1.07 (20 Sep 1995): +-------------------------------------- * Syntax: optional ;; allowed in compilation units and structures (back by popular demand) @@ -3963,7 +4378,7 @@ no calls to ranlib in Solaris * Standard library: added List.memq; documentation of Array fixed. -Caml Special Light 1.06: ------------------------- +Caml Special Light 1.06 (12 Sep 1995): +-------------------------------------- * First public release. @@ -140,15 +140,24 @@ Examples: or: ./configure -prefix /usr -mandir '$(PREFIX)/man/manl' - On a Linux x86/64 bits host, to build a 32-bit version of OCaml: + On a Linux x86-64 host, to build a 32-bit version of OCaml: ./configure -cc "gcc -m32" -as "as --32" -aspp "gcc -m32 -c" \ -host i386-linux -partialld "ld -r -melf_i386" - On a Linux x86/64 bits host, to build the run-time system in PIC mode - (enables putting the runtime in a shared library, - at a small performance cost): + On a Linux x86-64 host, to build the run-time system in PIC mode, + no special options should be required---the libraries should be built + automatically. The old instructions were: ./configure -cc "gcc -fPIC" -aspp "gcc -c -fPIC" + On a 64-bit POWER architecture host running Linux, OCaml only operates + in a 32-bit environment. If your system compiler is configured as 32-bit, + e.g. Red Hat 5.9, you don't need to do anything special. If that is + not the case (e.g. Red Hat 6.4), then IBM's "Advance Toolchain" can + be used. For example: + export PATH=/opt/at7.0/bin:$PATH + ./configure -cc "gcc -m32" -as "as -a32" -aspp "gcc -m32 -c" \ + -partialld "ld -r -m elf32ppc" + On a MacOSX 10.5/Intel Core 2 or MacOSX 10.5/PowerPC host, to build a 64-bit version of OCaml: ./configure -cc "gcc -m64" @@ -13,20 +13,20 @@ # The main Makefile include config/Makefile +CAMLRUN ?= boot/ocamlrun +CAMLYACC ?= boot/ocamlyacc 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 \ +CAMLC=$(CAMLRUN) boot/ocamlc -nostdlib -I boot +CAMLOPT=$(CAMLRUN) ./ocamlopt -nostdlib -I stdlib -I otherlibs/dynlink +COMPFLAGS=-strict-sequence -w +33..39+48+50 -warn-error A -bin-annot \ -safe-string $(INCLUDES) LINKFLAGS= -CAMLYACC=boot/ocamlyacc YACCFLAGS=-v -CAMLLEX=boot/ocamlrun boot/ocamllex -CAMLDEP=boot/ocamlrun tools/ocamldep +CAMLLEX=$(CAMLRUN) boot/ocamllex +CAMLDEP=$(CAMLRUN) tools/ocamldep DEPFLAGS=$(INCLUDES) -CAMLRUN=byterun/ocamlrun SHELL=/bin/sh MKDIR=mkdir -p @@ -43,7 +43,7 @@ UTILS=utils/misc.cmo utils/tbl.cmo utils/config.cmo \ utils/consistbl.cmo PARSING=parsing/location.cmo parsing/longident.cmo \ - parsing/ast_helper.cmo \ + parsing/docstrings.cmo parsing/ast_helper.cmo \ parsing/syntaxerr.cmo parsing/parser.cmo \ parsing/lexer.cmo parsing/parse.cmo parsing/printast.cmo \ parsing/pprintast.cmo \ @@ -57,11 +57,13 @@ TYPING=typing/ident.cmo typing/path.cmo \ typing/typedtree.cmo typing/printtyped.cmo typing/ctype.cmo \ typing/printtyp.cmo typing/includeclass.cmo \ typing/mtype.cmo typing/envaux.cmo typing/includecore.cmo \ - typing/typedtreeIter.cmo typing/typedtreeMap.cmo typing/cmt_format.cmo \ + typing/typedtreeIter.cmo typing/typedtreeMap.cmo \ + typing/tast_mapper.cmo \ + typing/cmt_format.cmo \ typing/includemod.cmo typing/typetexp.cmo typing/parmatch.cmo \ typing/stypes.cmo typing/typecore.cmo \ typing/typedecl.cmo typing/typeclass.cmo \ - typing/typemod.cmo + typing/typemod.cmo typing/untypeast.cmo COMP=bytecomp/lambda.cmo bytecomp/printlambda.cmo \ bytecomp/typeopt.cmo bytecomp/switch.cmo bytecomp/matching.cmo \ @@ -79,7 +81,23 @@ BYTECOMP=bytecomp/meta.cmo bytecomp/instruct.cmo bytecomp/bytegen.cmo \ bytecomp/bytelink.cmo bytecomp/bytelibrarian.cmo bytecomp/bytepackager.cmo \ driver/errors.cmo driver/compile.cmo -ASMCOMP=asmcomp/arch.cmo asmcomp/debuginfo.cmo \ +INTEL_ASM=\ + asmcomp/x86_proc.cmo \ + asmcomp/x86_dsl.cmo \ + asmcomp/x86_gas.cmo \ + asmcomp/x86_masm.cmo + +ARCH_SPECIFIC_ASMCOMP= +ifeq ($(ARCH),i386) +ARCH_SPECIFIC_ASMCOMP=$(INTEL_ASM) +endif +ifeq ($(ARCH),amd64) +ARCH_SPECIFIC_ASMCOMP=$(INTEL_ASM) +endif + +ASMCOMP=\ + $(ARCH_SPECIFIC_ASMCOMP) \ + asmcomp/arch.cmo asmcomp/debuginfo.cmo \ asmcomp/cmm.cmo asmcomp/printcmm.cmo \ asmcomp/reg.cmo asmcomp/mach.cmo asmcomp/proc.cmo \ asmcomp/clambda.cmo asmcomp/printclambda.cmo asmcomp/compilenv.cmo \ @@ -94,6 +112,8 @@ ASMCOMP=asmcomp/arch.cmo asmcomp/debuginfo.cmo \ asmcomp/deadcode.cmo \ asmcomp/printlinear.cmo asmcomp/linearize.cmo \ asmcomp/schedgen.cmo asmcomp/scheduling.cmo \ + asmcomp/branch_relaxation_intf.cmo \ + asmcomp/branch_relaxation.cmo \ asmcomp/emitaux.cmo asmcomp/emit.cmo asmcomp/asmgen.cmo \ asmcomp/asmlink.cmo asmcomp/asmlibrarian.cmo asmcomp/asmpackager.cmo \ driver/opterrors.cmo driver/optcompile.cmo @@ -192,7 +212,7 @@ coldstart: if test -f boot/libcamlrun.a; then :; else \ ln -s ../byterun/libcamlrun.a boot/libcamlrun.a; fi if test -d stdlib/caml; then :; else \ - ln -s ../byterun stdlib/caml; fi + ln -s ../byterun/caml stdlib/caml; fi # Build the core system: the minimum needed to make depend and bootstrap core: @@ -317,9 +337,13 @@ install: cp ocaml $(INSTALL_BINDIR)/ocaml$(EXE) cd stdlib; $(MAKE) install 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 $(INSTALL_COMPLIBDIR) + cp $(CAMLYACC)$(EXE) $(INSTALL_BINDIR)/ocamlyacc$(EXE) + cp utils/*.cmi utils/*.cmt utils/*.cmti \ + parsing/*.cmi parsing/*.cmt parsing/*.cmti \ + typing/*.cmi typing/*.cmt typing/*.cmti \ + bytecomp/*.cmi bytecomp/*.cmt bytecomp/*.cmti \ + driver/*.cmi driver/*.cmt driver/*.cmti \ + toplevel/*.cmi toplevel/*.cmt toplevel/*.cmti $(INSTALL_COMPLIBDIR) cp compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma \ compilerlibs/ocamltoplevel.cma $(BYTESTART) $(TOPLEVELSTART) \ $(INSTALL_COMPLIBDIR) @@ -343,7 +367,7 @@ installopt: cd asmrun; $(MAKE) install cp ocamlopt $(INSTALL_BINDIR)/ocamlopt$(EXE) cd stdlib; $(MAKE) installopt - cp asmcomp/*.cmi $(INSTALL_COMPLIBDIR) + cp asmcomp/*.cmi asmcomp/*.cmt asmcomp/*.cmti $(INSTALL_COMPLIBDIR) cp compilerlibs/ocamloptcomp.cma $(OPTSTART) $(INSTALL_COMPLIBDIR) if test -n "$(WITH_OCAMLDOC)"; then (cd ocamldoc; $(MAKE) installopt); \ else :; fi @@ -538,8 +562,8 @@ $(COMMON:.cmo=.cmx) $(BYTECOMP:.cmo=.cmx) $(ASMCOMP:.cmo=.cmx): ocamlopt # The numeric opcodes -bytecomp/opcodes.ml: byterun/instruct.h - sed -n -e '/^enum/p' -e 's/,//g' -e '/^ /p' byterun/instruct.h | \ +bytecomp/opcodes.ml: byterun/caml/instruct.h + sed -n -e '/^enum/p' -e 's/,//g' -e '/^ /p' byterun/caml/instruct.h | \ awk -f tools/make-opcodes > bytecomp/opcodes.ml partialclean:: @@ -552,9 +576,9 @@ beforedepend:: bytecomp/opcodes.ml byterun/primitives: cd byterun; $(MAKE) primitives -bytecomp/runtimedef.ml: byterun/primitives byterun/fail.h +bytecomp/runtimedef.ml: byterun/primitives byterun/caml/fail.h (echo 'let builtin_exceptions = [|'; \ - sed -n -e 's|.*/\* \("[A-Za-z_]*"\) \*/$$| \1;|p' byterun/fail.h | \ + sed -n -e 's|.*/\* \("[A-Za-z_]*"\) \*/$$| \1;|p' byterun/caml/fail.h | \ sed -e '$$s/;$$//'; \ echo '|]'; \ echo 'let builtin_primitives = [|'; \ @@ -629,8 +653,7 @@ partialclean:: beforedepend:: asmcomp/emit.ml tools/cvt_emit: tools/cvt_emit.mll - cd tools; \ - $(MAKE) CAMLC="../$(CAMLRUN) ../boot/ocamlc -I ../stdlib" cvt_emit + cd tools && $(MAKE) cvt_emit # The "expunge" utility @@ -678,7 +701,7 @@ library: ocamlc cd stdlib; $(MAKE) all library-cross: - cd stdlib; $(MAKE) RUNTIME=../byterun/ocamlrun all + cd stdlib; $(MAKE) CAMLRUN=../byterun/ocamlrun all libraryopt: cd stdlib; $(MAKE) allopt @@ -752,7 +775,7 @@ alldepend:: otherlibraries: ocamltools for i in $(OTHERLIBRARIES); do \ - (cd otherlibs/$$i; $(MAKE) RUNTIME=$(RUNTIME) all) || exit $$?; \ + (cd otherlibs/$$i; $(MAKE) all) || exit $$?; \ done otherlibrariesopt: @@ -799,9 +822,8 @@ alldepend:: # Check that the stack limit is reasonable. checkstack: - @if $(BYTECC) $(BYTECCCOMPOPTS) $(BYTECCLINKOPTS) \ - -o tools/checkstack tools/checkstack.c; \ - then tools/checkstack; \ + @if $(MKEXE) -o tools/checkstack$(EXE) tools/checkstack.c; \ + then tools/checkstack$(EXE); \ else :; \ fi @rm -f tools/checkstack diff --git a/Makefile.nt b/Makefile.nt index 16b53fe269..398fb83365 100644 --- a/Makefile.nt +++ b/Makefile.nt @@ -13,18 +13,18 @@ # The main Makefile include config/Makefile +CAMLRUN ?= boot/ocamlrun +CAMLYACC ?= boot/ocamlyacc include stdlib/StdlibModules -CAMLC=boot/ocamlrun boot/ocamlc -nostdlib -I boot -CAMLOPT=boot/ocamlrun ./ocamlopt -nostdlib -I stdlib -I otherlibs/dynlink +CAMLC=$(CAMLRUN) boot/ocamlc -nostdlib -I boot +CAMLOPT=$(CAMLRUN) ./ocamlopt -nostdlib -I stdlib -I otherlibs/dynlink COMPFLAGS=-strict-sequence -w +33..39+48 -warn-error A -bin-annot $(INCLUDES) LINKFLAGS= -CAMLYACC=boot/ocamlyacc YACCFLAGS= -CAMLLEX=boot/ocamlrun boot/ocamllex -CAMLDEP=boot/ocamlrun tools/ocamldep +CAMLLEX=$(CAMLRUN) boot/ocamllex +CAMLDEP=$(CAMLRUN) tools/ocamldep DEPFLAGS=$(INCLUDES) -CAMLRUN=byterun/ocamlrun OCAMLBUILDBYTE=$(WITH_OCAMLBUILD:=.byte) OCAMLBUILDNATIVE=$(WITH_OCAMLBUILD:=.native) @@ -39,7 +39,7 @@ UTILS=utils/misc.cmo utils/tbl.cmo utils/config.cmo \ utils/consistbl.cmo PARSING=parsing/location.cmo parsing/longident.cmo \ - parsing/ast_helper.cmo \ + parsing/docstrings.cmo parsing/ast_helper.cmo \ parsing/syntaxerr.cmo parsing/parser.cmo \ parsing/lexer.cmo parsing/parse.cmo parsing/printast.cmo \ parsing/pprintast.cmo \ @@ -53,11 +53,13 @@ TYPING=typing/ident.cmo typing/path.cmo \ typing/typedtree.cmo typing/printtyped.cmo typing/ctype.cmo \ typing/printtyp.cmo typing/includeclass.cmo \ typing/mtype.cmo typing/envaux.cmo typing/includecore.cmo \ - typing/typedtreeIter.cmo typing/typedtreeMap.cmo typing/cmt_format.cmo \ + typing/typedtreeIter.cmo typing/typedtreeMap.cmo \ + typing/tast_mapper.cmo \ + typing/cmt_format.cmo \ typing/includemod.cmo typing/typetexp.cmo typing/parmatch.cmo \ typing/stypes.cmo typing/typecore.cmo \ typing/typedecl.cmo typing/typeclass.cmo \ - typing/typemod.cmo + typing/typemod.cmo typing/untypeast.cmo COMP=bytecomp/lambda.cmo bytecomp/printlambda.cmo \ bytecomp/typeopt.cmo bytecomp/switch.cmo bytecomp/matching.cmo \ @@ -75,7 +77,23 @@ BYTECOMP=bytecomp/meta.cmo bytecomp/instruct.cmo bytecomp/bytegen.cmo \ bytecomp/bytelink.cmo bytecomp/bytelibrarian.cmo bytecomp/bytepackager.cmo \ driver/errors.cmo driver/compile.cmo -ASMCOMP=asmcomp/arch.cmo asmcomp/debuginfo.cmo \ +INTEL_ASM=\ + asmcomp/x86_proc.cmo \ + asmcomp/x86_dsl.cmo \ + asmcomp/x86_gas.cmo \ + asmcomp/x86_masm.cmo + +ARCH_SPECIFIC_ASMCOMP= +ifeq ($(ARCH),i386) +ARCH_SPECIFIC_ASMCOMP=$(INTEL_ASM) +endif +ifeq ($(ARCH),amd64) +ARCH_SPECIFIC_ASMCOMP=$(INTEL_ASM) +endif + +ASMCOMP=\ + $(ARCH_SPECIFIC_ASMCOMP) \ + asmcomp/arch.cmo asmcomp/debuginfo.cmo \ asmcomp/cmm.cmo asmcomp/printcmm.cmo \ asmcomp/reg.cmo asmcomp/mach.cmo asmcomp/proc.cmo \ asmcomp/clambda.cmo asmcomp/printclambda.cmo asmcomp/compilenv.cmo \ @@ -244,8 +262,12 @@ installbyt: cd stdlib ; $(MAKEREC) install 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 $(INSTALL_COMPLIBDIR) + cp utils/*.cmi utils/*.cmt utils/*.cmti \ + parsing/*.cmi parsing/*.cmt parsing/*.cmti \ + typing/*.cmi typing/*.cmt typing/*.cmti \ + bytecomp/*.cmi bytecomp/*.cmt bytecomp/*.cmti \ + driver/*.cmi driver/*.cmt driver/*.cmti \ + toplevel/*.cmi toplevel/*.cmt toplevel/*.cmti $(INSTALL_COMPLIBDIR) cp compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma \ compilerlibs/ocamltoplevel.cma $(BYTESTART) $(TOPLEVELSTART) \ $(INSTALL_COMPLIBDIR) @@ -272,12 +294,14 @@ installopt: cd asmrun ; $(MAKEREC) install cp ocamlopt $(INSTALL_BINDIR)/ocamlopt.exe cd stdlib ; $(MAKEREC) installopt - cp asmcomp/*.cmi $(INSTALL_COMPLIBDIR) + cp asmcomp/*.cmi asmcomp/*.cmt asmcomp/*.cmti $(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 + for i in $(OTHERLIBRARIES); do \ + $(MAKEREC) -C otherlibs/$$i installopt || exit $$?; \ + done if test -f ocamlopt.opt ; then $(MAKEREC) installoptopt; fi cd tools; $(MAKE) installopt @@ -463,8 +487,8 @@ $(COMMON:.cmo=.cmx) $(BYTECOMP:.cmo=.cmx) $(ASMCOMP:.cmo=.cmx): ocamlopt # The numeric opcodes -bytecomp/opcodes.ml: byterun/instruct.h - sed -n -e "/^enum/p" -e "s|,||g" -e "/^ /p" byterun/instruct.h | \ +bytecomp/opcodes.ml: byterun/caml/instruct.h + sed -n -e "/^enum/p" -e "s|,||g" -e "/^ /p" byterun/caml/instruct.h | \ gawk -f tools/make-opcodes > bytecomp/opcodes.ml partialclean:: @@ -477,9 +501,9 @@ beforedepend:: bytecomp/opcodes.ml byterun/primitives: cd byterun ; $(MAKEREC) primitives -bytecomp/runtimedef.ml: byterun/primitives byterun/fail.h +bytecomp/runtimedef.ml: byterun/primitives byterun/caml/fail.h (echo 'let builtin_exceptions = [|'; \ - sed -n -e 's|.*/\* \("[A-Za-z_]*"\) \*/$$| \1;|p' byterun/fail.h | \ + sed -n -e 's|.*/\* \("[A-Za-z_]*"\) \*/$$| \1;|p' byterun/caml/fail.h | \ sed -e '$$s/;$$//'; \ echo '|]'; \ echo 'let builtin_primitives = [|'; \ @@ -501,12 +525,6 @@ partialclean:: beforedepend:: asmcomp/arch.ml -ifeq ($(TOOLCHAIN),msvc) -ASMCOMP_EMIT=asmcomp/$(ARCH)/emit_nt.mlp -else -ASMCOMP_EMIT=asmcomp/$(ARCH)/emit.mlp -endif - asmcomp/proc.ml: asmcomp/$(ARCH)/proc.ml cp asmcomp/$(ARCH)/proc.ml asmcomp/proc.ml @@ -549,8 +567,8 @@ beforedepend:: asmcomp/scheduling.ml # Preprocess the code emitters -asmcomp/emit.ml: $(ASMCOMP_EMIT) tools/cvt_emit - boot/ocamlrun tools/cvt_emit < $(ASMCOMP_EMIT) > asmcomp/emit.ml +asmcomp/emit.ml: asmcomp/$(ARCH)/emit.mlp tools/cvt_emit + $(CAMLRUN) tools/cvt_emit < asmcomp/$(ARCH)/emit.mlp > asmcomp/emit.ml partialclean:: rm -f asmcomp/emit.ml @@ -603,7 +621,7 @@ alldepend:: library: cd stdlib ; $(MAKEREC) all library-cross: - cd stdlib ; $(MAKEREC) RUNTIME=../byterun/ocamlrun all + cd stdlib ; $(MAKEREC) CAMLRUN=../byterun/ocamlrun all libraryopt: cd stdlib ; $(MAKEREC) allopt partialclean:: @@ -659,15 +677,25 @@ alldepend:: # The extra libraries otherlibraries: - for i in $(OTHERLIBRARIES); do $(MAKEREC) -C otherlibs/$$i all; done + for i in $(OTHERLIBRARIES); do \ + $(MAKEREC) -C otherlibs/$$i all || exit $$?; \ + done otherlibrariesopt: - for i in $(OTHERLIBRARIES); do $(MAKEREC) -C otherlibs/$$i allopt; done + for i in $(OTHERLIBRARIES); \ + do $(MAKEREC) -C otherlibs/$$i allopt || exit $$?; \ + done partialclean:: - for i in $(OTHERLIBRARIES); do $(MAKEREC) -C otherlibs/$$i partialclean; done + for i in $(OTHERLIBRARIES); \ + do $(MAKEREC) -C otherlibs/$$i partialclean || exit $$?; \ + done clean:: - for i in $(OTHERLIBRARIES); do $(MAKEREC) -C otherlibs/$$i clean; done + for i in $(OTHERLIBRARIES); do \ + $(MAKEREC) -C otherlibs/$$i clean || exit $$?; \ + done alldepend:: - for i in $(OTHERLIBRARIES); do $(MAKEREC) -C otherlibs/$$i depend; done + for i in $(OTHERLIBRARIES); do \ + $(MAKEREC) -C otherlibs/$$i depend || exit $$?; \ + done # The replay debugger @@ -729,6 +757,7 @@ alldepend:: depend distclean: $(MAKE) clean + rm -f asmrun/.depend.nt byterun/.depend.nt 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 diff --git a/README.win32 b/README.win32 index 111c9a107c..8e66810249 100644 --- a/README.win32 +++ b/README.win32 @@ -1,11 +1,14 @@ Release notes on the MS Windows ports of OCaml ---------------------------------------------- -There are no less than four ports of OCaml for MS Windows available: +There are no less than five ports of OCaml for MS Windows available: - a native Win32 port, built with the Microsoft development tools; - a native Win32 port, built with the 32-bit version of the gcc compiler from the mingw-w64 project, packaged in Cygwin (under the name mingw64-i686); + - a native Win32 port, built with the 64-bit version of the gcc + compiler from the mingw-w64 project, packaged in Cygwin + (under the name mingw64-x86_64); - a port consisting of the Unix sources compiled under the Cygwin Unix-like environment for Windows; - a native Win64 port (64-bit Windows), built with the Microsoft @@ -15,7 +18,7 @@ Here is a summary of the main differences between these ports: Native MS Native MinGW Cygwin -64 bits? Win32 or Win64 Win32 only Win32 only +64 bits? Win32 or Win64 Win32 or Win64 Win32 only Third-party software required - for base bytecode system none none none @@ -161,12 +164,12 @@ contributed his changes to the OCaml project. ------------------------------------------------------------------------------ - The native Win32 port built with Mingw - -------------------------------------- + The native Win32 and Win64 ports built with Mingw + ------------------------------------------------- REQUIREMENTS: -This port runs under MS Windows Seven, Vista, XP, and 2000. +Those ports run under MS Windows Seven, Vista, XP, and 2000. The base bytecode system (ocamlc, ocaml, ocamllex, ocamlyacc, ...) runs without any additional tools. @@ -177,14 +180,18 @@ the Cygwin development tools, available at http://www.cygwin.com/ and the flexdll tool, available at http://alain.frisch.fr/flexdll.html -You will need to install at least the following Cygwin packages (use -the Setup tool from Cygwin): +You will need to install at least the following Cygwin packages for +the 32-bit flavor (use the Setup tool from Cygwin): mingw64-i686-binutils - mingw64-i686-gcc mingw64-i686-gcc-core mingw64-i686-runtime +and the following packages for the 64-bit: + + mingw64-x86_64-binutils + mingw64-x86_64-gcc-core + mingw64-x86_64-runtime NOTES: @@ -202,8 +209,8 @@ NOTES: to another toolchain packaged in Cygwin. - The standalone mingw toolchain from the MinGW-w64 project - (http://mingw-w64.sourceforge.net/) is not supported. - Please use the version packaged in Cygwin instead. + (http://mingw-w64.org/) is not supported. Please use the + version packaged in Cygwin instead. INSTALLATION: @@ -218,18 +225,27 @@ You will need the following software components to perform the recompilation: - Cygwin: http://cygwin.com/ Install at least the following packages (and their dependencies, as computed by Cygwin's setup.exe): - mingw64-i686-binutils - mingw64-i686-gcc - mingw64-i686-gcc-core - mingw64-i686-runtime + + For both flavor of OCaml (32-bit and 64-bit): diffutils make ncurses + + For the 32 bit flavor of OCaml: + mingw64-i686-binutils + mingw64-i686-gcc-core + mingw64-i686-runtime + + For the 64 bit flavor of OCaml: + mingw64-x86_64-binutils + mingw64-x86_64-gcc-core + mingw64-x86_64-runtime + - The flexdll tool (see above). Do not forget to add the flexdll directory to your PATH The standalone mingw toolchain from the MinGW-w64 project -(http://mingw-w64.sourceforge.net/) is not supported. Please use the +(http://mingw-w64.org/) is not supported. Please use the version packaged in Cygwin instead. Start a new Cygwin shell and unpack the source distribution @@ -238,8 +254,13 @@ directory of the OCaml distribution. Then, do cp config/m-nt.h config/m.h cp config/s-nt.h config/s.h + +For a 32 bit OCaml: cp config/Makefile.mingw config/Makefile +For a 64 bit OCaml: + cp config/Makefile.mingw64 config/Makefile + Then, edit config/Makefile as needed, following the comments in this file. Normally, the only variable that need to be changed is PREFIX where to install everything @@ -260,7 +281,8 @@ NOTES: * The replay debugger is partially supported (no reverse execution). -* The default Makefile.mingw passes -static-libgcc to the linker. +* The default Makefile.mingw and Makefile.mingw64 pass -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 @@ -1,4 +1,4 @@ -4.03.0+dev5-2014-10-15 +4.03.0+dev9-2015-07-22 # 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/amd64/arch.ml b/asmcomp/amd64/arch.ml index a4f1abd974..b7b0b57b90 100644 --- a/asmcomp/amd64/arch.ml +++ b/asmcomp/amd64/arch.ml @@ -12,12 +12,10 @@ (* Machine-specific command-line options *) -let pic_code = ref true - let command_line_options = - [ "-fPIC", Arg.Set pic_code, + [ "-fPIC", Arg.Set Clflags.pic_code, " Generate position-independent machine code (default)"; - "-fno-PIC", Arg.Clear pic_code, + "-fno-PIC", Arg.Clear Clflags.pic_code, " Generate position-dependent machine code" ] (* Specific operations for the AMD64 processor *) diff --git a/asmcomp/amd64/emit.mlp b/asmcomp/amd64/emit.mlp index 94855f96d9..9a3d7c2e03 100644 --- a/asmcomp/amd64/emit.mlp +++ b/asmcomp/amd64/emit.mlp @@ -1,3 +1,4 @@ +# 2 "asmcomp/amd64/emit.mlp" (***********************************************************************) (* *) (* OCaml *) @@ -10,8 +11,9 @@ (* *) (***********************************************************************) -(* Emission of x86-64 (AMD 64) assembly code *) +(* Emission of Intel x86_64 assembly code *) +open Misc open Cmm open Arch open Proc @@ -20,9 +22,43 @@ open Mach open Linearize open Emitaux -let macosx = (Config.system = "macosx") -let mingw64 = (Config.system = "mingw64") -let cygwin = (Config.system = "cygwin") +open X86_ast +open X86_proc +open X86_dsl + +(* [Branch_relaxation] is not used in this file, but is required by + emit.mlp files for certain other targets; the reference here ensures + that when releases are being prepared the .depend files are correct + for all targets. *) +open! Branch_relaxation + +let _label s = D.label ~typ:QWORD s + +(* Override proc.ml *) + +let int_reg_name = + [| RAX; RBX; RDI; RSI; RDX; RCX; R8; R9; + R12; R13; R10; R11; RBP; |] + +let float_reg_name = Array.init 16 (fun i -> XMM i) + +let register_name r = + if r < 100 then Reg64 (int_reg_name.(r)) + else Regf (float_reg_name.(r - 100)) + +(* CFI directives *) + +let cfi_startproc () = + if Config.asm_cfi_supported then D.cfi_startproc () + +let cfi_endproc () = + if Config.asm_cfi_supported then D.cfi_endproc () + +let cfi_adjust_cfa_offset n = + if Config.asm_cfi_supported then D.cfi_adjust_cfa_offset n + +let emit_debug_info dbg = + emit_debug_info_gen dbg D.file D.loc let fp = Config.with_frame_pointers @@ -41,14 +77,14 @@ let frame_size () = (* includes return address *) if frame_required() then begin let sz = (!stack_offset + 8 * (num_stack_slots.(0) + num_stack_slots.(1)) + 8 - + (if fp then 8 else 0) ) + + (if fp then 8 else 0)) in Misc.align sz 16 end else !stack_offset + 8 let slot_offset loc cl = match loc with - Incoming n -> frame_size() + n + | Incoming n -> frame_size() + n | Local n -> if cl = 0 then !stack_offset + n * 8 @@ -57,106 +93,150 @@ let slot_offset loc cl = (* Symbols *) -let emit_symbol s = - if macosx then emit_string "_"; - Emitaux.emit_symbol '$' s +let symbol_prefix = if system = S_macosx then "_" else "" + +let emit_symbol s = string_of_symbol symbol_prefix s + +(* Record symbols used and defined - at the end generate extern for those + used but not defined *) + +let symbols_defined = ref StringSet.empty +let symbols_used = ref StringSet.empty + +let add_def_symbol s = symbols_defined := StringSet.add s !symbols_defined +let add_used_symbol s = symbols_used := StringSet.add s !symbols_used -let emit_call s = - if !Clflags.dlcode && not macosx && not mingw64 && not cygwin - then `call {emit_symbol s}@PLT` - else `call {emit_symbol s}` +let imp_table = Hashtbl.create 16 -let emit_jump s = - if !Clflags.dlcode && not macosx && not mingw64 && not cygwin - then `jmp {emit_symbol s}@PLT` - else `jmp {emit_symbol s}` +let reset_imp_table () = Hashtbl.clear imp_table -let load_symbol_addr s = - if !Clflags.dlcode && not mingw64 && not cygwin - then `movq {emit_symbol s}@GOTPCREL(%rip)` - else if !pic_code - then `leaq {emit_symbol s}(%rip)` - else `movq ${emit_symbol s}` +let get_imp_symbol s = + match Hashtbl.find imp_table s with + | exception Not_found -> + let imps = "__caml_imp_" ^ s in + Hashtbl.add imp_table s imps; + imps + | imps -> imps + +let emit_imp_table () = + let f s imps = + _label (emit_symbol imps); + D.qword (ConstLabel (emit_symbol s)) + in + D.data(); + D.comment "relocation table start"; + D.align 8; + Hashtbl.iter f imp_table; + D.comment "relocation table end" + +let mem__imp s = + let imp_s = get_imp_symbol s in + mem64_rip QWORD (emit_symbol imp_s) + +let rel_plt s = + if windows && !Clflags.dlcode then mem__imp s + else + let use_plt = + match system with + | S_macosx | S_mingw64 | S_cygwin | S_win64 -> false + | _ -> !Clflags.dlcode + in + sym (if use_plt then emit_symbol s ^ "@PLT" else emit_symbol s) + +let emit_call s = I.call (rel_plt s) + +let emit_jump s = I.jmp (rel_plt s) + +let load_symbol_addr s arg = + if !Clflags.dlcode then + if windows then begin + (* I.mov (mem__imp s) arg (\* mov __caml_imp_foo(%rip), ... *\) *) + I.mov (sym (emit_symbol s)) arg (* movabsq $foo, ... *) + end else I.mov (mem64_rip QWORD (emit_symbol s ^ "@GOTPCREL")) arg + else if !Clflags.pic_code then + I.lea (mem64_rip NONE (emit_symbol s)) arg + else + I.mov (sym (emit_symbol s)) arg (* Output a label *) let emit_label lbl = - emit_string ".L"; emit_int lbl + match system with + | S_win64 -> "L" ^ string_of_int lbl + | _ -> ".L" ^ string_of_int lbl let emit_data_label lbl = - emit_string ".Ld"; emit_int lbl + match system with + | S_win64 -> "Ld" ^ string_of_int lbl + | _ -> ".Ld" ^ string_of_int lbl -(* Output a .align directive. *) +let label s = sym (emit_label s) -let emit_align n = - let n = if macosx then Misc.log2 n else n in - ` .align {emit_int n}\n` +let def_label s = D.label (emit_label s) let emit_Llabel fallthrough lbl = - if not fallthrough && !fastcode_flag then emit_align 4; - emit_label lbl + if not fallthrough && !fastcode_flag then D.align 4; + def_label lbl (* Output a pseudo-register *) -let emit_reg = function - { loc = Reg r } -> - emit_string (register_name r) +let reg = function + | { loc = Reg.Reg r } -> register_name r + | { loc = Stack s; typ = Float } as r -> + let ofs = slot_offset s (register_class r) in + mem64 REAL8 ofs RSP | { loc = Stack s } as r -> let ofs = slot_offset s (register_class r) in - `{emit_int ofs}(%rsp)` + mem64 QWORD ofs RSP | { loc = Unknown } -> assert false +let reg64 = function + | { loc = Reg.Reg r } -> int_reg_name.(r) + | _ -> assert false + + +let res i n = reg i.res.(n) + +let arg i n = reg i.arg.(n) + (* Output a reference to the lower 8, 16 or 32 bits of a register *) -let reg_low_8_name = - [| "%al"; "%bl"; "%dil"; "%sil"; "%dl"; "%cl"; "%r8b"; "%r9b"; - "%r12b"; "%r13b"; "%r10b"; "%r11b"; "%bpl" |] -let reg_low_16_name = - [| "%ax"; "%bx"; "%di"; "%si"; "%dx"; "%cx"; "%r8w"; "%r9w"; - "%r12w"; "%r13w"; "%r10w"; "%r11w"; "%bp" |] -let reg_low_32_name = - [| "%eax"; "%ebx"; "%edi"; "%esi"; "%edx"; "%ecx"; "%r8d"; "%r9d"; - "%r12d"; "%r13d"; "%r10d"; "%r11d"; "%ebp" |] - -let emit_subreg tbl r = +let reg_low_8_name = Array.map (fun r -> Reg8L r) int_reg_name +let reg_low_16_name = Array.map (fun r -> Reg16 r) int_reg_name +let reg_low_32_name = Array.map (fun r -> Reg32 r) int_reg_name + +let emit_subreg tbl typ r = match r.loc with - Reg r when r < 13 -> - emit_string tbl.(r) - | Stack s -> - let ofs = slot_offset s (register_class r) in - `{emit_int ofs}(%rsp)` - | _ -> - assert false + | Reg.Reg r when r < 13 -> tbl.(r) + | Stack s -> mem64 typ (slot_offset s (register_class r)) RSP + | _ -> assert false + +let arg8 i n = emit_subreg reg_low_8_name BYTE i.arg.(n) +let arg16 i n = emit_subreg reg_low_16_name WORD i.arg.(n) +let arg32 i n = emit_subreg reg_low_32_name DWORD i.arg.(n) +let arg64 i n = reg64 i.arg.(n) -let emit_reg8 r = emit_subreg reg_low_8_name r -let emit_reg16 r = emit_subreg reg_low_16_name r -let emit_reg32 r = emit_subreg reg_low_32_name r +let res16 i n = emit_subreg reg_low_16_name WORD i.res.(n) +let res32 i n = emit_subreg reg_low_32_name DWORD i.res.(n) (* Output an addressing mode *) -let emit_addressing addr r n = +let addressing addr typ i n = match addr with - | Ibased _ when !Clflags.dlcode -> assert false - | Ibased(s, d) -> - `{emit_symbol s}`; - if d <> 0 then ` + {emit_int d}`; - `(%rip)` + | Ibased(s, ofs) -> + add_used_symbol s; + mem64_rip typ (emit_symbol s) ~ofs | Iindexed d -> - if d <> 0 then emit_int d; - `({emit_reg r.(n)})` + mem64 typ d (arg64 i n) | Iindexed2 d -> - if d <> 0 then emit_int d; - `({emit_reg r.(n)}, {emit_reg r.(n+1)})` + mem64 typ ~base:(arg64 i n) d (arg64 i (n+1)) | Iscaled(2, d) -> - if d <> 0 then emit_int d; - `({emit_reg r.(n)}, {emit_reg r.(n)})` + mem64 typ ~base:(arg64 i n) d (arg64 i n) | Iscaled(scale, d) -> - if d <> 0 then emit_int d; - `(, {emit_reg r.(n)}, {emit_int scale})` + mem64 typ ~scale d (arg64 i n) | Iindexed2scaled(scale, d) -> - if d <> 0 then emit_int d; - `({emit_reg r.(n)}, {emit_reg r.(n+1)}, {emit_int scale})` + mem64 typ ~scale ~base:(arg64 i n) d (arg64 i (n+1)) (* Record live pointers at call points -- see Emitaux *) @@ -171,7 +251,8 @@ let record_frame_label live dbg = live_offset := slot_offset s (register_class reg) :: !live_offset | {typ = Addr} as r -> Misc.fatal_error ("bad GC root " ^ Reg.name r) - | _ -> ()) + | _ -> () + ) live; frame_descriptors := { fd_lbl = lbl; @@ -181,7 +262,8 @@ let record_frame_label live dbg = lbl let record_frame live dbg = - let lbl = record_frame_label live dbg in `{emit_label lbl}:\n` + let lbl = record_frame_label live dbg in + def_label lbl (* Record calls to the GC -- we've moved them out of the way *) @@ -193,8 +275,10 @@ type gc_call = let call_gc_sites = ref ([] : gc_call list) let emit_call_gc gc = - `{emit_label gc.gc_lbl}: {emit_call "caml_call_gc"}\n`; - `{emit_label gc.gc_frame}: jmp {emit_label gc.gc_return_lbl}\n` + def_label gc.gc_lbl; + emit_call "caml_call_gc"; + def_label gc.gc_frame; + I.jmp (label gc.gc_return_lbl) (* Record calls to caml_ml_array_bound_error. In -g mode, we maintain one call to caml_ml_array_bound_error @@ -212,67 +296,70 @@ let bound_error_label dbg = let lbl_bound_error = new_label() in let lbl_frame = record_frame_label Reg.Set.empty dbg in bound_error_sites := - { bd_lbl = lbl_bound_error; bd_frame = lbl_frame } :: !bound_error_sites; - lbl_bound_error - end else begin - if !bound_error_call = 0 then bound_error_call := new_label(); - !bound_error_call - end + { bd_lbl = lbl_bound_error; bd_frame = lbl_frame } :: !bound_error_sites; + lbl_bound_error + end else begin + if !bound_error_call = 0 then bound_error_call := new_label(); + !bound_error_call + end let emit_call_bound_error bd = - `{emit_label bd.bd_lbl}: {emit_call "caml_ml_array_bound_error"}\n`; - `{emit_label bd.bd_frame}:\n` + def_label bd.bd_lbl; + emit_call "caml_ml_array_bound_error"; + def_label bd.bd_frame let emit_call_bound_errors () = List.iter emit_call_bound_error !bound_error_sites; - if !bound_error_call > 0 then - `{emit_label !bound_error_call}: {emit_call "caml_ml_array_bound_error"}\n` + if !bound_error_call > 0 then begin + def_label !bound_error_call; + emit_call "caml_ml_array_bound_error" + end (* Names for instructions *) let instr_for_intop = function - Iadd -> "addq" - | Isub -> "subq" - | Imul -> "imulq" - | Iand -> "andq" - | Ior -> "orq" - | Ixor -> "xorq" - | Ilsl -> "salq" - | Ilsr -> "shrq" - | Iasr -> "sarq" + | Iadd -> I.add + | Isub -> I.sub + | Imul -> (fun arg1 arg2 -> I.imul arg1 (Some arg2)) + | Iand -> I.and_ + | Ior -> I.or_ + | Ixor -> I.xor + | Ilsl -> I.sal + | Ilsr -> I.shr + | Iasr -> I.sar | _ -> assert false let instr_for_floatop = function - Iaddf -> "addsd" - | Isubf -> "subsd" - | Imulf -> "mulsd" - | Idivf -> "divsd" + | Iaddf -> I.addsd + | Isubf -> I.subsd + | Imulf -> I.mulsd + | Idivf -> I.divsd | _ -> assert false let instr_for_floatarithmem = function - Ifloatadd -> "addsd" - | Ifloatsub -> "subsd" - | Ifloatmul -> "mulsd" - | Ifloatdiv -> "divsd" - -let name_for_cond_branch = function - Isigned Ceq -> "e" | Isigned Cne -> "ne" - | Isigned Cle -> "le" | Isigned Cgt -> "g" - | Isigned Clt -> "l" | Isigned Cge -> "ge" - | Iunsigned Ceq -> "e" | Iunsigned Cne -> "ne" - | Iunsigned Cle -> "be" | Iunsigned Cgt -> "a" - | Iunsigned Clt -> "b" | Iunsigned Cge -> "ae" + | Ifloatadd -> I.addsd + | Ifloatsub -> I.subsd + | Ifloatmul -> I.mulsd + | Ifloatdiv -> I.divsd + +let cond = function + | Isigned Ceq -> E | Isigned Cne -> NE + | Isigned Cle -> LE | Isigned Cgt -> G + | Isigned Clt -> L | Isigned Cge -> GE + | Iunsigned Ceq -> E | Iunsigned Cne -> NE + | Iunsigned Cle -> BE | Iunsigned Cgt -> A + | Iunsigned Clt -> B | Iunsigned Cge -> AE (* Output an = 0 or <> 0 test. *) let output_test_zero arg = match arg.loc with - Reg r -> ` testq {emit_reg arg}, {emit_reg arg}\n` - | _ -> ` cmpq $0, {emit_reg arg}\n` + | Reg.Reg _ -> I.test (reg arg) (reg arg) + | _ -> I.cmp (int 0) (reg arg) (* Output a floating-point compare and branch *) -let emit_float_test cmp neg arg lbl = +let emit_float_test cmp neg i lbl = (* Effect of comisd on flags and conditional branches: ZF PF CF cond. branches taken unordered 1 1 1 je, jb, jbe, jp @@ -285,52 +372,46 @@ let emit_float_test cmp neg arg lbl = match (cmp, neg) with | (Ceq, false) | (Cne, true) -> let next = new_label() in - ` ucomisd {emit_reg arg.(1)}, {emit_reg arg.(0)}\n`; - ` jp {emit_label next}\n`; (* skip if unordered *) - ` je {emit_label lbl}\n`; (* branch taken if x=y *) - `{emit_label next}:\n` + I.ucomisd (arg i 1) (arg i 0); + I.jp (label next); (* skip if unordered *) + I.je lbl; (* branch taken if x=y *) + def_label next | (Cne, false) | (Ceq, true) -> - ` ucomisd {emit_reg arg.(1)}, {emit_reg arg.(0)}\n`; - ` jp {emit_label lbl}\n`; (* branch taken if unordered *) - ` jne {emit_label lbl}\n` (* branch taken if x<y or x>y *) + I.ucomisd (arg i 1) (arg i 0); + I.jp lbl; (* branch taken if unordered *) + I.jne lbl (* branch taken if x<y or x>y *) | (Clt, _) -> - ` comisd {emit_reg arg.(0)}, {emit_reg arg.(1)}\n`; (* swap compare *) - if not neg then - ` ja {emit_label lbl}\n` (* branch taken if y>x i.e. x<y *) - else - ` jbe {emit_label lbl}\n` (* taken if unordered or y<=x i.e. !(x<y) *) + I.comisd (arg i 0) (arg i 1); + if not neg then I.ja lbl (* branch taken if y>x i.e. x<y *) + else I.jbe lbl (* taken if unordered or y<=x i.e. !(x<y) *) | (Cle, _) -> - ` comisd {emit_reg arg.(0)}, {emit_reg arg.(1)}\n`; (* swap compare *) - if not neg then - ` jae {emit_label lbl}\n` (* branch taken if y>=x i.e. x<=y *) - else - ` jb {emit_label lbl}\n` (* taken if unordered or y<x i.e. !(x<=y) *) + I.comisd (arg i 0) (arg i 1);(* swap compare *) + if not neg then I.jae lbl (* branch taken if y>=x i.e. x<=y *) + else I.jb lbl (* taken if unordered or y<x i.e. !(x<=y) *) | (Cgt, _) -> - ` comisd {emit_reg arg.(1)}, {emit_reg arg.(0)}\n`; - if not neg then - ` ja {emit_label lbl}\n` (* branch taken if x>y *) - else - ` jbe {emit_label lbl}\n` (* taken if unordered or x<=y i.e. !(x>y) *) + I.comisd (arg i 1) (arg i 0); + if not neg then I.ja lbl (* branch taken if x>y *) + else I.jbe lbl (* taken if unordered or x<=y i.e. !(x>y) *) | (Cge, _) -> - ` comisd {emit_reg arg.(1)}, {emit_reg arg.(0)}\n`; (* swap compare *) - if not neg then - ` jae {emit_label lbl}\n` (* branch taken if x>=y *) - else - ` jb {emit_label lbl}\n` (* taken if unordered or x<y i.e. !(x>=y) *) + I.comisd (arg i 1) (arg i 0);(* swap compare *) + if not neg then I.jae lbl (* branch taken if x>=y *) + else I.jb lbl (* taken if unordered or x<y i.e. !(x>=y) *) (* Deallocate the stack frame before a return or tail call *) let output_epilogue f = if frame_required() then begin let n = frame_size() - 8 - (if fp then 8 else 0) in - ` addq ${emit_int n}, %rsp\n`; - cfi_adjust_cfa_offset (-n); - if fp then begin - ` popq %rbp\n` + if n <> 0 + then begin + I.add (int n) rsp; + cfi_adjust_cfa_offset (-n); end; + if fp then I.pop rbp; f (); (* reset CFA back cause function body may continue *) - cfi_adjust_cfa_offset n + if n <> 0 + then cfi_adjust_cfa_offset n end else f () @@ -343,15 +424,22 @@ let add_float_constant cst = let repr = Int64.bits_of_float cst in try List.assoc repr !float_constants - with - Not_found -> - let lbl = new_label() in - float_constants := (repr, lbl) :: !float_constants; - lbl + with Not_found -> + let lbl = new_label() in + float_constants := (repr, lbl) :: !float_constants; + lbl + +let emit_float_constant f lbl = + _label (emit_label lbl); + D.qword (Const f) + +let emit_global_label s = + let lbl = Compilenv.make_symbol (Some s) in + add_def_symbol lbl; + let lbl = emit_symbol lbl in + D.global lbl; + _label lbl -let emit_float_constant (cst, lbl) = - `{emit_label lbl}:`; - emit_float64_directive ".quad" cst (* Output the assembly code for an instruction *) @@ -362,326 +450,337 @@ let tailrec_entry_point = ref 0 (* Emit an instruction *) let emit_instr fallthrough i = - emit_debug_info i.dbg; - match i.desc with - Lend -> () - | Lop(Imove | Ispill | Ireload) -> - let src = i.arg.(0) and dst = i.res.(0) in - if src.loc <> dst.loc then begin - match src.typ, src.loc, dst.loc with - Float, Reg _, Reg _ -> - ` movapd {emit_reg src}, {emit_reg dst}\n` - | Float, _, _ -> - ` movsd {emit_reg src}, {emit_reg dst}\n` - | _ -> - ` movq {emit_reg src}, {emit_reg dst}\n` + emit_debug_info i.dbg; + match i.desc with + | Lend -> () + | Lop(Imove | Ispill | Ireload) -> + let src = i.arg.(0) and dst = i.res.(0) in + if src.loc <> dst.loc then + begin match src.typ, src.loc, dst.loc with + | Float, Reg.Reg _, Reg.Reg _ -> I.movapd (reg src) (reg dst) + | Float, _, _ -> I.movsd (reg src) (reg dst) + | _ -> I.mov (reg src) (reg dst) end - | Lop(Iconst_int n | Iconst_blockheader n) -> - if n = 0n then begin - match i.res.(0).loc with - Reg n -> ` xorq {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` - | _ -> ` movq $0, {emit_reg i.res.(0)}\n` - end else if n <= 0x7FFFFFFFn && n >= -0x80000000n then - ` movq ${emit_nativeint n}, {emit_reg i.res.(0)}\n` - else - ` movabsq ${emit_nativeint n}, {emit_reg i.res.(0)}\n` - | 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` - | _ -> + | Lop(Iconst_int n | Iconst_blockheader n) -> + if n = 0n then begin + match i.res.(0).loc with + | Reg _ -> I.xor (res i 0) (res i 0) + | _ -> I.mov (int 0) (res i 0) + end + else + I.mov (nat n) (res i 0) + | Lop(Iconst_float f) -> + begin match Int64.bits_of_float f with + | 0x0000_0000_0000_0000L -> (* +0.0 *) + I.xorpd (res i 0) (res i 0) + | _ -> let lbl = add_float_constant f in - ` movsd {emit_label lbl}(%rip), {emit_reg i.res.(0)}\n` - end - | Lop(Iconst_symbol s) -> - ` {load_symbol_addr s}, {emit_reg i.res.(0)}\n` - | Lop(Icall_ind) -> - ` call *{emit_reg i.arg.(0)}\n`; - record_frame i.live i.dbg - | Lop(Icall_imm(s)) -> - ` {emit_call s}\n`; - record_frame i.live i.dbg - | Lop(Itailcall_ind) -> + I.movsd (mem64_rip NONE (emit_label lbl)) (res i 0) + end + | Lop(Iconst_symbol s) -> + add_used_symbol s; + load_symbol_addr s (res i 0) + | Lop(Icall_ind) -> + I.call (arg i 0); + record_frame i.live i.dbg + | Lop(Icall_imm s) -> + add_used_symbol s; + emit_call s; + record_frame i.live i.dbg + | Lop(Itailcall_ind) -> + output_epilogue begin fun () -> + I.jmp (arg i 0) + end + | Lop(Itailcall_imm s) -> + if s = !function_name then + I.jmp (label !tailrec_entry_point) + else begin output_epilogue begin fun () -> - ` jmp *{emit_reg i.arg.(0)}\n` - end - | Lop(Itailcall_imm s) -> - if s = !function_name then - ` jmp {emit_label !tailrec_entry_point}\n` - else begin - output_epilogue begin fun () -> - ` {emit_jump s}\n` - end - end - | Lop(Iextcall(s, alloc)) -> - if alloc then begin - ` {load_symbol_addr s}, %rax\n`; - ` {emit_call "caml_c_call"}\n`; - record_frame i.live i.dbg; - ` {load_symbol_addr "caml_young_ptr"}, %r11\n`; - ` movq (%r11), %r15\n`; - end else begin - ` {emit_call s}\n` - end - | Lop(Istackoffset n) -> - if n < 0 - then ` addq ${emit_int(-n)}, %rsp\n` - else ` subq ${emit_int(n)}, %rsp\n`; - cfi_adjust_cfa_offset n; - stack_offset := !stack_offset + n - | Lop(Iload(chunk, addr)) -> - let dest = i.res.(0) in - begin match chunk with - | Word_int | Word_val -> - ` movq {emit_addressing addr i.arg 0}, {emit_reg dest}\n` - | Byte_unsigned -> - ` movzbq {emit_addressing addr i.arg 0}, {emit_reg dest}\n` - | Byte_signed -> - ` movsbq {emit_addressing addr i.arg 0}, {emit_reg dest}\n` - | Sixteen_unsigned -> - ` movzwq {emit_addressing addr i.arg 0}, {emit_reg dest}\n` - | Sixteen_signed -> - ` movswq {emit_addressing addr i.arg 0}, {emit_reg dest}\n` - | Thirtytwo_unsigned -> - ` movl {emit_addressing addr i.arg 0}, {emit_reg32 dest}\n` - | Thirtytwo_signed -> - ` movslq {emit_addressing addr i.arg 0}, {emit_reg dest}\n` - | Single -> - ` cvtss2sd {emit_addressing addr i.arg 0}, {emit_reg dest}\n` - | Double | Double_u -> - ` movsd {emit_addressing addr i.arg 0}, {emit_reg dest}\n` - end - | Lop(Istore(chunk, addr, _)) -> - begin match chunk with - | Word_int | Word_val -> - ` movq {emit_reg i.arg.(0)}, {emit_addressing addr i.arg 1}\n` - | Byte_unsigned | Byte_signed -> - ` movb {emit_reg8 i.arg.(0)}, {emit_addressing addr i.arg 1}\n` - | Sixteen_unsigned | Sixteen_signed -> - ` movw {emit_reg16 i.arg.(0)}, {emit_addressing addr i.arg 1}\n` - | Thirtytwo_signed | Thirtytwo_unsigned -> - ` movl {emit_reg32 i.arg.(0)}, {emit_addressing addr i.arg 1}\n` - | Single -> - ` cvtsd2ss {emit_reg i.arg.(0)}, %xmm15\n`; - ` movss %xmm15, {emit_addressing addr i.arg 1}\n` - | Double | Double_u -> - ` movsd {emit_reg i.arg.(0)}, {emit_addressing addr i.arg 1}\n` - end - | Lop(Ialloc n) -> - if !fastcode_flag then begin - let lbl_redo = new_label() in - `{emit_label lbl_redo}: subq ${emit_int n}, %r15\n`; - if !Clflags.dlcode then begin - ` {load_symbol_addr "caml_young_limit"}, %rax\n`; - ` cmpq (%rax), %r15\n`; - end else - ` cmpq {emit_symbol "caml_young_limit"}(%rip), %r15\n`; - let lbl_call_gc = new_label() in - let lbl_frame = record_frame_label i.live Debuginfo.none in - ` jb {emit_label lbl_call_gc}\n`; - ` leaq 8(%r15), {emit_reg i.res.(0)}\n`; - call_gc_sites := - { gc_lbl = lbl_call_gc; - gc_return_lbl = lbl_redo; - gc_frame = lbl_frame } :: !call_gc_sites - end else begin - begin match n with - 16 -> ` {emit_call "caml_alloc1"}\n` - | 24 -> ` {emit_call "caml_alloc2"}\n` - | 32 -> ` {emit_call "caml_alloc3"}\n` - | _ -> ` movq ${emit_int n}, %rax\n`; - ` {emit_call "caml_allocN"}\n` - end; - `{record_frame i.live Debuginfo.none} leaq 8(%r15), {emit_reg i.res.(0)}\n` + add_used_symbol s; + emit_jump s end - | Lop(Iintop(Icomp cmp)) -> - ` cmpq {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`; - let b = name_for_cond_branch cmp in - ` set{emit_string b} %al\n`; - ` movzbq %al, {emit_reg i.res.(0)}\n` - | Lop(Iintop_imm(Icomp cmp, n)) -> - ` cmpq ${emit_int n}, {emit_reg i.arg.(0)}\n`; - let b = name_for_cond_branch cmp in - ` set{emit_string b} %al\n`; - ` movzbq %al, {emit_reg i.res.(0)}\n` - | Lop(Iintop Icheckbound) -> - let lbl = bound_error_label i.dbg in - ` cmpq {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`; - ` jbe {emit_label lbl}\n` - | Lop(Iintop_imm(Icheckbound, n)) -> - let lbl = bound_error_label i.dbg in - ` cmpq ${emit_int n}, {emit_reg i.arg.(0)}\n`; - ` jbe {emit_label lbl}\n` - | Lop(Iintop(Idiv | Imod)) -> - ` cqto\n`; - ` idivq {emit_reg i.arg.(1)}\n` - | Lop(Iintop(Ilsl | Ilsr | Iasr as op)) -> - (* We have i.arg.(0) = i.res.(0) and i.arg.(1) = %rcx *) - ` {emit_string(instr_for_intop op)} %cl, {emit_reg i.res.(0)}\n` - | Lop(Iintop Imulh) -> - ` imulq {emit_reg i.arg.(1)}\n` - | Lop(Iintop op) -> - (* We have i.arg.(0) = i.res.(0) *) - ` {emit_string(instr_for_intop op)} {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n` - | Lop(Iintop_imm(Iadd, n)) when i.arg.(0).loc <> i.res.(0).loc -> - ` leaq {emit_int n}({emit_reg i.arg.(0)}), {emit_reg i.res.(0)}\n` - | Lop(Iintop_imm(Iadd, 1) | Iintop_imm(Isub, -1)) -> - ` incq {emit_reg i.res.(0)}\n` - | Lop(Iintop_imm(Iadd, -1) | Iintop_imm(Isub, 1)) -> - ` decq {emit_reg i.res.(0)}\n` - | Lop(Iintop_imm(op, n)) -> - (* We have i.arg.(0) = i.res.(0) *) - ` {emit_string(instr_for_intop op)} ${emit_int n}, {emit_reg i.res.(0)}\n` - | Lop(Inegf) -> - ` xorpd {emit_symbol "caml_negf_mask"}(%rip), {emit_reg i.res.(0)}\n` - | Lop(Iabsf) -> - ` andpd {emit_symbol "caml_absf_mask"}(%rip), {emit_reg i.res.(0)}\n` - | Lop(Iaddf | Isubf | Imulf | Idivf as floatop) -> - ` {emit_string(instr_for_floatop floatop)} {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n` - | Lop(Ifloatofint) -> - ` cvtsi2sdq {emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n` - | Lop(Iintoffloat) -> - ` 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, _))) -> - ` movq ${emit_nativeint n}, {emit_addressing addr i.arg 0}\n` - | 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))) -> - ` addq ${emit_int n}, {emit_addressing addr i.arg 0}\n` - | Lop(Ispecific(Ifloatarithmem(op, addr))) -> - ` {emit_string(instr_for_floatarithmem op)} {emit_addressing addr i.arg 1}, {emit_reg i.res.(0)}\n` - | Lop(Ispecific(Ibswap size)) -> - begin match size with - | 16 -> - ` xchg %ah, %al\n`; - ` movzwq {emit_reg16 i.res.(0)}, {emit_reg i.res.(0)}\n` - | 32 -> - ` bswap {emit_reg32 i.res.(0)}\n`; - ` movslq {emit_reg32 i.res.(0)}, {emit_reg i.res.(0)}\n` - | 64 -> - ` bswap {emit_reg i.res.(0)}\n` - | _ -> assert false - end - | Lop(Ispecific Isqrtf) -> - ` sqrtsd {emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n` - | Lop(Ispecific(Ifloatsqrtf addr)) -> - ` sqrtsd {emit_addressing addr i.arg 0}, {emit_reg i.res.(0)}\n` - | Lreloadretaddr -> - () - | Lreturn -> - output_epilogue begin fun () -> - ` ret\n` - end - | Llabel lbl -> - `{emit_Llabel fallthrough lbl}:\n` - | Lbranch lbl -> - ` jmp {emit_label lbl}\n` - | Lcondbranch(tst, lbl) -> - begin match tst with - Itruetest -> - output_test_zero i.arg.(0); - ` jne {emit_label lbl}\n` - | Ifalsetest -> - output_test_zero i.arg.(0); - ` je {emit_label lbl}\n` - | Iinttest cmp -> - ` cmpq {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`; - let b = name_for_cond_branch cmp in - ` j{emit_string b} {emit_label lbl}\n` - | Iinttest_imm((Isigned Ceq | Isigned Cne | - Iunsigned Ceq | Iunsigned Cne) as cmp, 0) -> - output_test_zero i.arg.(0); - let b = name_for_cond_branch cmp in - ` j{emit_string b} {emit_label lbl}\n` - | Iinttest_imm(cmp, n) -> - ` cmpq ${emit_int n}, {emit_reg i.arg.(0)}\n`; - let b = name_for_cond_branch cmp in - ` j{emit_string b} {emit_label lbl}\n` - | Ifloattest(cmp, neg) -> - emit_float_test cmp neg i.arg lbl - | Ioddtest -> - ` testb $1, {emit_reg8 i.arg.(0)}\n`; - ` jne {emit_label lbl}\n` - | Ieventest -> - ` testb $1, {emit_reg8 i.arg.(0)}\n`; - ` je {emit_label lbl}\n` - end - | Lcondbranch3(lbl0, lbl1, lbl2) -> - ` cmpq $1, {emit_reg i.arg.(0)}\n`; - begin match lbl0 with - None -> () - | Some lbl -> ` jb {emit_label lbl}\n` - end; - begin match lbl1 with - None -> () - | Some lbl -> ` je {emit_label lbl}\n` - end; - begin match lbl2 with - None -> () - | Some lbl -> ` jg {emit_label lbl}\n` - end - | Lswitch jumptbl -> - let lbl = new_label() in - (* rax and rdx are clobbered by the Lswitch, - meaning that no variable that is live across the Lswitch - is assigned to rax or rdx. However, the argument to Lswitch - can still be assigned to one of these two registers, so - we must be careful not to clobber it before use. *) - let (tmp1, tmp2) = - if i.arg.(0).loc = Reg 0 (* rax *) - then (phys_reg 4 (*rdx*), phys_reg 0 (*rax*)) - else (phys_reg 0 (*rax*), phys_reg 4 (*rdx*)) in - ` leaq {emit_label lbl}(%rip), {emit_reg tmp1}\n`; - ` movslq ({emit_reg tmp1}, {emit_reg i.arg.(0)}, 4), {emit_reg tmp2}\n`; - ` addq {emit_reg tmp2}, {emit_reg tmp1}\n`; - ` jmp *{emit_reg tmp1}\n`; - if macosx then - ` .const\n` - else if mingw64 || cygwin then - ` .section .rdata,\"dr\"\n` - else - ` .section .rodata\n`; - emit_align 4; - `{emit_label lbl}:`; - for i = 0 to Array.length jumptbl - 1 do - ` .long {emit_label jumptbl.(i)} - {emit_label lbl}\n` - done; - ` .text\n` - | Lsetuptrap lbl -> - ` call {emit_label lbl}\n` - | Lpushtrap -> - cfi_adjust_cfa_offset 8; - ` pushq %r14\n`; - cfi_adjust_cfa_offset 8; - ` movq %rsp, %r14\n`; - stack_offset := !stack_offset + 16 - | Lpoptrap -> - ` popq %r14\n`; - cfi_adjust_cfa_offset (-8); - ` addq $8, %rsp\n`; - cfi_adjust_cfa_offset (-8); - stack_offset := !stack_offset - 16 - | Lraise k -> - begin match !Clflags.debug, k with - | true, Lambda.Raise_regular -> - ` {emit_call "caml_raise_exn"}\n`; + end + | Lop(Iextcall(s, alloc)) -> + add_used_symbol s; + if alloc then begin + load_symbol_addr s rax; + emit_call "caml_c_call"; + record_frame i.live i.dbg; + if system <> S_win64 then begin + (* TODO: investigate why such a diff. + This comes from: + http://caml.inria.fr/cgi-bin/viewvc.cgi?view=revision&revision=12664 + + If we do the same for Win64, we probably need to change + amd64nt.asm accordingly. + *) + load_symbol_addr "caml_young_ptr" r11; + I.mov (mem64 QWORD 0 R11) r15 + end; + end else + emit_call s + | Lop(Istackoffset n) -> + if n < 0 + then I.add (int (-n)) rsp + else if n > 0 + then I.sub (int n) rsp; + if n <> 0 + then cfi_adjust_cfa_offset n; + stack_offset := !stack_offset + n + | Lop(Iload(chunk, addr)) -> + let dest = res i 0 in + begin match chunk with + | Word_int | Word_val -> + I.mov (addressing addr QWORD i 0) dest + | Byte_unsigned -> + I.movzx (addressing addr BYTE i 0) dest + | Byte_signed -> + I.movsx (addressing addr BYTE i 0) dest + | Sixteen_unsigned -> + I.movzx (addressing addr WORD i 0) dest + | Sixteen_signed -> + I.movsx (addressing addr WORD i 0) dest; + | Thirtytwo_unsigned -> + I.mov (addressing addr DWORD i 0) (res32 i 0) + | Thirtytwo_signed -> + I.movsxd (addressing addr DWORD i 0) dest + | Single -> + I.cvtss2sd (addressing addr REAL4 i 0) dest + | Double | Double_u -> + I.movsd (addressing addr REAL8 i 0) dest + end + | Lop(Istore(chunk, addr, _)) -> + begin match chunk with + | Word_int | Word_val -> + I.mov (arg i 0) (addressing addr QWORD i 1) + | Byte_unsigned | Byte_signed -> + I.mov (arg8 i 0) (addressing addr BYTE i 1) + | Sixteen_unsigned | Sixteen_signed -> + I.mov (arg16 i 0) (addressing addr WORD i 1) + | Thirtytwo_signed | Thirtytwo_unsigned -> + I.mov (arg32 i 0) (addressing addr DWORD i 1) + | Single -> + I.cvtsd2ss (arg i 0) xmm15; + I.movss xmm15 (addressing addr REAL4 i 1) + | Double | Double_u -> + I.movsd (arg i 0) (addressing addr REAL8 i 1) + end + | Lop(Ialloc n) -> + if !fastcode_flag then begin + let lbl_redo = new_label() in + def_label lbl_redo; + I.sub (int n) r15; + if !Clflags.dlcode then begin + load_symbol_addr "caml_young_limit" rax; + I.cmp (mem64 QWORD 0 RAX) r15; + end else + I.cmp (mem64_rip QWORD (emit_symbol "caml_young_limit")) r15; + let lbl_call_gc = new_label() in + let lbl_frame = record_frame_label i.live Debuginfo.none in + I.jb (label lbl_call_gc); + I.lea (mem64 NONE 8 R15) (res i 0); + call_gc_sites := + { gc_lbl = lbl_call_gc; + gc_return_lbl = lbl_redo; + gc_frame = lbl_frame } :: !call_gc_sites + end else begin + begin match n with + | 16 -> emit_call "caml_alloc1" + | 24 -> emit_call "caml_alloc2" + | 32 -> emit_call "caml_alloc3" + | _ -> + I.mov (int n) rax; + emit_call "caml_allocN" + end; + record_frame i.live Debuginfo.none; + I.lea (mem64 NONE 8 R15) (res i 0) + end + | Lop(Iintop(Icomp cmp)) -> + I.cmp (arg i 1) (arg i 0); + I.set (cond cmp) al; + I.movzx al (res i 0) + | Lop(Iintop_imm(Icomp cmp, n)) -> + I.cmp (int n) (arg i 0); + I.set (cond cmp) al; + I.movzx al (res i 0) + | Lop(Iintop Icheckbound) -> + let lbl = bound_error_label i.dbg in + I.cmp (arg i 1) (arg i 0); + I.jbe (label lbl) + | Lop(Iintop_imm(Icheckbound, n)) -> + let lbl = bound_error_label i.dbg in + I.cmp (int n) (arg i 0); + I.jbe (label lbl) + | Lop(Iintop(Idiv | Imod)) -> + I.cqo (); + I.idiv (arg i 1) + | Lop(Iintop(Ilsl | Ilsr | Iasr as op)) -> + (* We have i.arg.(0) = i.res.(0) and i.arg.(1) = %rcx *) + instr_for_intop op cl (res i 0) + | Lop(Iintop Imulh) -> + I.imul (arg i 1) None + | Lop(Iintop op) -> + (* We have i.arg.(0) = i.res.(0) *) + instr_for_intop op (arg i 1) (res i 0) + | Lop(Iintop_imm(Iadd, n)) when i.arg.(0).loc <> i.res.(0).loc -> + I.lea (mem64 NONE n (arg64 i 0)) (res i 0) + | Lop(Iintop_imm(Iadd, 1) | Iintop_imm(Isub, -1)) -> + I.inc (res i 0) + | Lop(Iintop_imm(Iadd, -1) | Iintop_imm(Isub, 1)) -> + I.dec (res i 0) + | Lop(Iintop_imm(op, n)) -> + (* We have i.arg.(0) = i.res.(0) *) + instr_for_intop op (int n) (res i 0) + | Lop(Inegf) -> + I.xorpd (mem64_rip OWORD (emit_symbol "caml_negf_mask")) (res i 0) + | Lop(Iabsf) -> + I.andpd (mem64_rip OWORD (emit_symbol "caml_absf_mask")) (res i 0) + | Lop(Iaddf | Isubf | Imulf | Idivf as floatop) -> + instr_for_floatop floatop (arg i 1) (res i 0) + | Lop(Ifloatofint) -> + I.cvtsi2sd (arg i 0) (res i 0) + | Lop(Iintoffloat) -> + I.cvttsd2si (arg i 0) (res i 0) + | Lop(Ispecific(Ilea addr)) -> + I.lea (addressing addr NONE i 0) (res i 0) + | Lop(Ispecific(Istore_int(n, addr, _))) -> + I.mov (nat n) (addressing addr QWORD i 0) + | Lop(Ispecific(Istore_symbol(s, addr, _))) -> + assert (not !Clflags.pic_code && not !Clflags.dlcode); + add_used_symbol s; + load_symbol_addr s (addressing addr QWORD i 0) + | Lop(Ispecific(Ioffset_loc(n, addr))) -> + I.add (int n) (addressing addr QWORD i 0) + | Lop(Ispecific(Ifloatarithmem(op, addr))) -> + instr_for_floatarithmem op (addressing addr REAL8 i 1) (res i 0) + | Lop(Ispecific(Ibswap 16)) -> + I.xchg ah al; + I.movzx (res16 i 0) (res i 0) + | Lop(Ispecific(Ibswap 32)) -> + I.bswap (res32 i 0); + I.movsxd (res32 i 0) (res i 0) + | Lop(Ispecific(Ibswap 64)) -> + I.bswap (res i 0) + | Lop(Ispecific(Ibswap _)) -> + assert false + | Lop(Ispecific Isqrtf) -> + I.sqrtsd (arg i 0) (res i 0) + | Lop(Ispecific(Ifloatsqrtf addr)) -> + I.sqrtsd (addressing addr REAL8 i 0) (res i 0) + | Lreloadretaddr -> + () + | Lreturn -> + output_epilogue begin fun () -> + I.ret () + end + | Llabel lbl -> + emit_Llabel fallthrough lbl + | Lbranch lbl -> + I.jmp (label lbl) + | Lcondbranch(tst, lbl) -> + let lbl = label lbl in + begin match tst with + | Itruetest -> + output_test_zero i.arg.(0); + I.jne lbl + | Ifalsetest -> + output_test_zero i.arg.(0); + I.je lbl + | Iinttest cmp -> + I.cmp (arg i 1) (arg i 0); + I.j (cond cmp) lbl + | Iinttest_imm((Isigned Ceq | Isigned Cne | + Iunsigned Ceq | Iunsigned Cne) as cmp, 0) -> + output_test_zero i.arg.(0); + I.j (cond cmp) lbl + | Iinttest_imm(cmp, n) -> + I.cmp (int n) (arg i 0); + I.j (cond cmp) lbl + | Ifloattest(cmp, neg) -> + emit_float_test cmp neg i lbl + | Ioddtest -> + I.test (int 1) (arg8 i 0); + I.jne lbl + | Ieventest -> + I.test (int 1) (arg8 i 0); + I.je lbl + end + | Lcondbranch3(lbl0, lbl1, lbl2) -> + I.cmp (int 1) (arg i 0); + begin match lbl0 with + | None -> () + | Some lbl -> I.jb (label lbl) + end; + begin match lbl1 with + | None -> () + | Some lbl -> I.je (label lbl) + end; + begin match lbl2 with + | None -> () + | Some lbl -> I.jg (label lbl) + end + | Lswitch jumptbl -> + let lbl = emit_label (new_label()) in + (* rax and rdx are clobbered by the Lswitch, + meaning that no variable that is live across the Lswitch + is assigned to rax or rdx. However, the argument to Lswitch + can still be assigned to one of these two registers, so + we must be careful not to clobber it before use. *) + let (tmp1, tmp2) = + if i.arg.(0).loc = Reg 0 (* rax *) + then (phys_reg 4 (*rdx*), phys_reg 0 (*rax*)) + else (phys_reg 0 (*rax*), phys_reg 4 (*rdx*)) in + + I.lea (mem64_rip NONE lbl) (reg tmp1); + I.movsxd (mem64 DWORD 0 (arg64 i 0) ~scale:4 ~base:(reg64 tmp1)) (reg tmp2); + I.add (reg tmp2) (reg tmp1); + I.jmp (reg tmp1); + + begin match system with + | S_macosx -> D.section ["__TEXT";"__const"] None [] + | S_mingw64 | S_cygwin -> D.section [".rdata"] (Some "dr") [] + | S_win64 -> () (* with MASM, use the text segment *) + | _ -> D.section [".rodata"] None [] + end; + D.align 4; + _label lbl; + for i = 0 to Array.length jumptbl - 1 do + D.long (ConstSub (ConstLabel(emit_label jumptbl.(i)), + ConstLabel lbl)) + done; + D.text () + | Lsetuptrap lbl -> + I.call (label lbl) + | Lpushtrap -> + cfi_adjust_cfa_offset 8; + I.push r14; + cfi_adjust_cfa_offset 8; + I.mov rsp r14; + stack_offset := !stack_offset + 16 + | Lpoptrap -> + I.pop r14; + cfi_adjust_cfa_offset (-8); + I.add (int 8) rsp; + cfi_adjust_cfa_offset (-8); + stack_offset := !stack_offset - 16 + | Lraise k -> + begin match !Clflags.debug, k with + | true, Lambda.Raise_regular -> + emit_call "caml_raise_exn"; record_frame Reg.Set.empty i.dbg - | true, Lambda.Raise_reraise -> - ` {emit_call "caml_reraise_exn"}\n`; + | true, Lambda.Raise_reraise -> + emit_call "caml_reraise_exn"; record_frame Reg.Set.empty i.dbg - | false, _ - | true, Lambda.Raise_notrace -> - ` movq %r14, %rsp\n`; - ` popq %r14\n`; - ` ret\n` - end + | false, _ + | true, Lambda.Raise_notrace -> + I.mov r14 rsp; + I.pop r14; + I.ret () + end let rec emit_all fallthrough i = match i.desc with - | Lend -> () + | Lend -> () | _ -> emit_instr fallthrough i; emit_all (Linearize.has_fallthrough i.desc) i.next @@ -689,20 +788,17 @@ let rec emit_all fallthrough i = (* Emission of the profiling prelude *) let emit_profile () = - match Config.system with - | "linux" | "gnu" -> - (* mcount preserves rax, rcx, rdx, rsi, rdi, r8, r9 explicitly - and rbx, rbp, r12-r15 like all C functions. This includes - all the registers used for argument passing, so we don't - need to preserve other regs. We do need to initialize rbp - like mcount expects it, though. *) - ` pushq %r10\n`; - if not fp then - ` movq %rsp, %rbp\n`; - ` {emit_call "mcount"}\n`; - ` popq %r10\n` - | _ -> - () (*unsupported yet*) + if system = S_gnu || system = S_linux then begin + (* mcount preserves rax, rcx, rdx, rsi, rdi, r8, r9 explicitly + and rbx, rbp, r12-r15 like all C functions. This includes + all the registers used for argument passing, so we don't + need to preserve other regs. We do need to initialize rbp + like mcount expects it, though. *) + I.push r10; + if not fp then I.mov rsp rbp; + emit_call "mcount"; + I.pop r10 + end (* Emission of a function declaration *) @@ -714,147 +810,194 @@ let fundecl fundecl = call_gc_sites := []; bound_error_sites := []; bound_error_call := 0; - ` .text\n`; - emit_align 16; - if macosx + D.text (); + D.align 16; + add_def_symbol fundecl.fun_name; + if system = S_macosx && not !Clflags.output_c_object && is_generic_function fundecl.fun_name then (* PR#4690 *) - ` .private_extern {emit_symbol fundecl.fun_name}\n` + D.private_extern (emit_symbol fundecl.fun_name) else - ` .globl {emit_symbol fundecl.fun_name}\n`; - `{emit_symbol fundecl.fun_name}:\n`; + D.global (emit_symbol fundecl.fun_name); + D.label (emit_symbol fundecl.fun_name); emit_debug_info fundecl.fun_dbg; cfi_startproc (); if fp then begin - ` pushq %rbp\n`; - cfi_adjust_cfa_offset 8; - ` movq %rsp, %rbp\n`; + I.push rbp; + cfi_adjust_cfa_offset 8; + I.mov rsp rbp; end; if !Clflags.gprofile then emit_profile(); if frame_required() then begin let n = frame_size() - 8 - (if fp then 8 else 0) in - ` subq ${emit_int n}, %rsp\n`; - cfi_adjust_cfa_offset n; + if n <> 0 + then begin + I.sub (int n) rsp; + cfi_adjust_cfa_offset n; + end; end; - `{emit_label !tailrec_entry_point}:\n`; + def_label !tailrec_entry_point; emit_all true fundecl.fun_body; List.iter emit_call_gc !call_gc_sites; emit_call_bound_errors (); cfi_endproc (); - begin match Config.system with - "linux" | "gnu" -> - ` .type {emit_symbol fundecl.fun_name},@function\n`; - ` .size {emit_symbol fundecl.fun_name},.-{emit_symbol fundecl.fun_name}\n` - | _ -> () + begin match system with + | S_gnu | S_linux -> + D.type_ (emit_symbol fundecl.fun_name) "@function"; + D.size (emit_symbol fundecl.fun_name) + (ConstSub ( + ConstThis, + ConstLabel (emit_symbol fundecl.fun_name))) + | _ -> () end (* Emission of data *) let emit_item = function - Cglobal_symbol s -> - ` .globl {emit_symbol s}\n`; - | Cdefine_symbol s -> - `{emit_symbol s}:\n` - | Cdefine_label lbl -> - `{emit_data_label lbl}:\n` - | Cint8 n -> - ` .byte {emit_int n}\n` - | Cint16 n -> - ` .word {emit_int n}\n` - | Cint32 n -> - ` .long {emit_nativeint n}\n` - | Cint n -> - ` .quad {emit_nativeint n}\n` - | 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 - | Cskip n -> - if n > 0 then ` .space {emit_int n}\n` - | Calign n -> - emit_align n + | Cglobal_symbol s -> D.global (emit_symbol s) + | Cdefine_symbol s -> add_def_symbol s; _label (emit_symbol s) + | Cdefine_label lbl -> _label (emit_data_label lbl) + | Cint8 n -> D.byte (const n) + | Cint16 n -> D.word (const n) + | Cint32 n -> D.long (const_nat n) + | Cint n -> D.qword (const_nat n) + | Csingle f -> D.long (Const (Int64.of_int32 (Int32.bits_of_float f))) + | Cdouble f -> D.qword (Const (Int64.bits_of_float f)) + | Csymbol_address s -> add_used_symbol s; D.qword (ConstLabel (emit_symbol s)) + | Clabel_address lbl -> D.qword (ConstLabel (emit_data_label lbl)) + | Cstring s -> D.bytes s + | Cskip n -> if n > 0 then D.space n + | Calign n -> D.align n let data l = - ` .data\n`; + D.data (); List.iter emit_item l (* Beginning / end of an assembly file *) let begin_assembly() = + X86_proc.reset_asm_code (); reset_debug_info(); (* PR#5603 *) + reset_imp_table(); float_constants := []; + if system = S_win64 then begin + D.extrn "caml_young_ptr" QWORD; + D.extrn "caml_young_limit" QWORD; + D.extrn "caml_exception_pointer" QWORD; + D.extrn "caml_call_gc" NEAR; + D.extrn "caml_c_call" NEAR; + D.extrn "caml_allocN" NEAR; + D.extrn "caml_alloc1" NEAR; + D.extrn "caml_alloc2" NEAR; + D.extrn "caml_alloc3" NEAR; + D.extrn "caml_ml_array_bound_error" NEAR; + D.extrn "caml_raise_exn" NEAR; + D.extrn "caml_reraise_exn" NEAR; + end; + + if !Clflags.dlcode then begin (* from amd64.S; could emit these constants on demand *) - if macosx then - ` .literal16\n` - else if mingw64 || cygwin then - ` .section .rdata,\"dr\"\n` - else - ` .section .rodata.cst8,\"a\",@progbits\n`; - emit_align 16; - `{emit_symbol "caml_negf_mask"}: .quad 0x8000000000000000, 0\n`; - emit_align 16; - `{emit_symbol "caml_absf_mask"}: .quad 0x7FFFFFFFFFFFFFFF, 0xFFFFFFFFFFFFFFFF\n` + begin match system with + | S_macosx -> D.section ["__TEXT";"__literal16"] None ["16byte_literals"] + | S_mingw64 | S_cygwin -> D.section [".rdata"] (Some "dr") [] + | S_win64 -> D.data () + | _ -> D.section [".rodata.cst8"] (Some "a") ["@progbits"] + end; + D.align 16; + _label (emit_symbol "caml_negf_mask"); + D.qword (Const 0x8000000000000000L); + D.qword (Const 0L); + D.align 16; + _label (emit_symbol "caml_absf_mask"); + D.qword (Const 0x7FFFFFFFFFFFFFFFL); + D.qword (Const 0xFFFFFFFFFFFFFFFFL); end; - let lbl_begin = Compilenv.make_symbol (Some "data_begin") in - ` .data\n`; - ` .globl {emit_symbol lbl_begin}\n`; - `{emit_symbol lbl_begin}:\n`; - let lbl_begin = Compilenv.make_symbol (Some "code_begin") in - ` .text\n`; - ` .globl {emit_symbol lbl_begin}\n`; - `{emit_symbol lbl_begin}:\n`; - if macosx then ` nop\n` (* PR#4690 *) + + D.data (); + emit_global_label "data_begin"; + + D.text (); + emit_global_label "code_begin"; + if system = S_macosx then I.nop (); (* PR#4690 *) + () let end_assembly() = if !float_constants <> [] then begin - if macosx then - ` .literal8\n` - else if mingw64 || cygwin then - ` .section .rdata,\"dr\"\n` - else - ` .section .rodata.cst8,\"a\",@progbits\n`; - List.iter emit_float_constant !float_constants + begin match system with + | S_macosx -> D.section ["__TEXT";"__literal8"] None ["8byte_literals"] + | S_mingw64 | S_cygwin -> D.section [".rdata"] (Some "dr") [] + | S_win64 -> D.data () + | _ -> D.section [".rodata.cst8"] (Some "a") ["@progbits"] + end; + List.iter (fun (cst,lbl) -> emit_float_constant cst lbl) !float_constants end; - let lbl_end = Compilenv.make_symbol (Some "code_end") in - ` .text\n`; - if macosx then ` nop\n`; (* suppress "ld warning: atom sorting error" *) - ` .globl {emit_symbol lbl_end}\n`; - `{emit_symbol lbl_end}:\n`; - ` .data\n`; - let lbl_end = Compilenv.make_symbol (Some "data_end") in - ` .globl {emit_symbol lbl_end}\n`; - `{emit_symbol lbl_end}:\n`; - ` .long 0\n`; - let lbl = Compilenv.make_symbol (Some "frametable") in - ` .globl {emit_symbol lbl}\n`; - `{emit_symbol lbl}:\n`; + + D.text (); + if system = S_macosx then I.nop (); + (* suppress "ld warning: atom sorting error" *) + + emit_global_label "code_end"; + + emit_imp_table(); + + D.data (); + emit_global_label "data_end"; + D.long (const 0); + + emit_global_label "frametable"; + + let setcnt = ref 0 in emit_frames - { efa_label = (fun l -> ` .quad {emit_label l}\n`); - efa_16 = (fun n -> ` .word {emit_int n}\n`); - efa_32 = (fun n -> ` .long {emit_int32 n}\n`); - efa_word = (fun n -> ` .quad {emit_int n}\n`); - efa_align = emit_align; + { efa_label = (fun l -> D.qword (ConstLabel (emit_label l))); + efa_16 = (fun n -> D.word (const n)); + efa_32 = (fun n -> D.long (const_32 n)); + efa_word = (fun n -> D.qword (const n)); + efa_align = D.align; efa_label_rel = - if macosx then begin - let setcnt = ref 0 in - fun lbl ofs -> - incr setcnt; - ` .set L$set${emit_int !setcnt}, ({emit_label lbl} - .) + {emit_int32 ofs}\n`; - ` .long L$set${emit_int !setcnt}\n` - end else begin - fun lbl ofs -> - ` .long ({emit_label lbl} - .) + {emit_int32 ofs}\n` - end; - efa_def_label = (fun l -> `{emit_label l}:\n`); - efa_string = (fun s -> emit_string_directive " .asciz " s) }; - if Config.system = "linux" then + (fun lbl ofs -> + let c = + ConstAdd ( + ConstSub(ConstLabel(emit_label lbl), ConstThis), + const_32 ofs + ) in + if system = S_macosx then begin + incr setcnt; + let s = Printf.sprintf "L$set$%d" !setcnt in + D.setvar (s, c); + D.long (ConstLabel s) + end else + D.long c + ); + efa_def_label = (fun l -> _label (emit_label l)); + efa_string = (fun s -> D.bytes (s ^ "\000")) + }; + + if system = S_linux then (* Mark stack as non-executable, PR#4564 *) - ` .section .note.GNU-stack,\"\",%progbits\n` + D.section [".note.GNU-stack"] (Some "") [ "%progbits" ]; + + if system = S_win64 then begin + D.comment "External functions"; + StringSet.iter + (fun s -> + if not (StringSet.mem s !symbols_defined) then + D.extrn (emit_symbol s) NEAR) + !symbols_used; + symbols_used := StringSet.empty; + symbols_defined := StringSet.empty; + end; + + let asm = + if !Emitaux.create_asm_file then + Some + ( + (if X86_proc.masm then X86_masm.generate_asm + else X86_gas.generate_asm) !Emitaux.output_channel + ) + else + None + in + X86_proc.generate_code asm + diff --git a/asmcomp/amd64/proc.ml b/asmcomp/amd64/proc.ml index bcc7fcb5ef..f4730142f7 100644 --- a/asmcomp/amd64/proc.ml +++ b/asmcomp/amd64/proc.ml @@ -1,3 +1,4 @@ +# 2 "asmcomp/amd64/proc.ml" (***********************************************************************) (* *) (* OCaml *) @@ -316,13 +317,7 @@ let contains_calls = ref false (* Calling the assembler *) let assemble_file infile outfile = - if masm then - Ccomp.command (Config.asm ^ - Filename.quote outfile ^ " " ^ Filename.quote infile ^ - (if !Clflags.verbose then "" else ">NUL")) - else - Ccomp.command (Config.asm ^ " -o " ^ - Filename.quote outfile ^ " " ^ Filename.quote infile) + X86_proc.assemble_file infile outfile let init () = if fp then begin diff --git a/asmcomp/amd64/reload.ml b/asmcomp/amd64/reload.ml index 49070d299f..0a4ce0db54 100644 --- a/asmcomp/amd64/reload.ml +++ b/asmcomp/amd64/reload.ml @@ -11,7 +11,6 @@ (***********************************************************************) open Cmm -open Arch open Reg open Mach @@ -93,7 +92,7 @@ method! reload_operation op arg res = then (arg, res) else super#reload_operation op arg res | Iconst_symbol _ -> - if !pic_code || !Clflags.dlcode + if !Clflags.pic_code || !Clflags.dlcode then super#reload_operation op arg res else (arg, res) | _ -> (* Other operations: all args and results in registers *) diff --git a/asmcomp/amd64/selection.ml b/asmcomp/amd64/selection.ml index 4556ac668b..857a481dcb 100644 --- a/asmcomp/amd64/selection.ml +++ b/asmcomp/amd64/selection.ml @@ -162,7 +162,7 @@ method! select_store is_assign addr exp = (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, is_assign)), Ctuple []) - | Cconst_symbol s when not (!pic_code || !Clflags.dlcode) -> + | Cconst_symbol s when not (!Clflags.pic_code || !Clflags.dlcode) -> (Ispecific(Istore_symbol(s, addr, is_assign)), Ctuple []) | _ -> super#select_store is_assign addr exp diff --git a/asmcomp/arm/arch.ml b/asmcomp/arm/arch.ml index d93c1e0e46..cc880551c6 100644 --- a/asmcomp/arm/arch.ml +++ b/asmcomp/arm/arch.ml @@ -56,8 +56,6 @@ let (arch, fpu, thumb) = end in (ref def_arch, ref def_fpu, ref def_thumb) -let pic_code = ref false - let farch spec = arch := (match spec with "armv4" when abi <> EABI_HF -> ARMv4 @@ -83,9 +81,9 @@ let command_line_options = "-ffpu", Arg.String ffpu, "<fpu> Select the floating-point hardware" ^ " (default: " ^ (string_of_fpu !fpu) ^ ")"; - "-fPIC", Arg.Set pic_code, + "-fPIC", Arg.Set Clflags.pic_code, " Generate position-independent machine code"; - "-fno-PIC", Arg.Clear pic_code, + "-fno-PIC", Arg.Clear Clflags.pic_code, " Generate position-dependent machine code"; "-fthumb", Arg.Set thumb, " Enable Thumb/Thumb-2 code generation" diff --git a/asmcomp/arm/emit.mlp b/asmcomp/arm/emit.mlp index 070397bf04..440f4630c4 100644 --- a/asmcomp/arm/emit.mlp +++ b/asmcomp/arm/emit.mlp @@ -40,12 +40,12 @@ let emit_symbol s = Emitaux.emit_symbol '$' s let emit_call s = - if !Clflags.dlcode || !pic_code + if !Clflags.dlcode || !Clflags.pic_code then `bl {emit_symbol s}(PLT)` else `bl {emit_symbol s}` let emit_jump s = - if !Clflags.dlcode || !pic_code + if !Clflags.dlcode || !Clflags.pic_code then `b {emit_symbol s}(PLT)` else `b {emit_symbol s}` @@ -323,7 +323,7 @@ let emit_literals() = end; if !symbol_literals <> [] then begin let offset = if !thumb then 4 else 8 in - let suffix = if !pic_code then "(GOT)" else "" in + let suffix = if !Clflags.pic_code then "(GOT)" else "" in ` .align 2\n`; List.iter (fun (l, lbl) -> @@ -341,7 +341,7 @@ let emit_literals() = (* Emit code to load the address of a symbol *) let emit_load_symbol_addr dst s = - if !pic_code then begin + if !Clflags.pic_code then begin let lbl_pic = new_label() in let lbl_got = gotrel_literal lbl_pic in let lbl_sym = symbol_literal s in @@ -757,7 +757,7 @@ let emit_instr i = if tramtbl.(j) <> jumptbl.(j) then `{emit_label tramtbl.(j)}: b {emit_label jumptbl.(j)}\n` done - end else if not !pic_code then begin + end else if not !Clflags.pic_code then begin ` ldr pc, [pc, {emit_reg i.arg.(0)}, lsl #2]\n`; ` nop\n`; for j = 0 to Array.length jumptbl - 1 do @@ -854,8 +854,10 @@ let fundecl fundecl = let n = frame_size() in if n > 0 then begin ignore(emit_stack_adjustment (-n)); - if !contains_calls then + if !contains_calls then begin + cfi_offset ~reg:14 (* lr *) ~offset:(-4); ` str lr, [sp, #{emit_int(n - 4)}]\n` + end end; `{emit_label !tailrec_entry_point}:\n`; emit_all 0 fundecl.fun_body; diff --git a/asmcomp/arm/proc.ml b/asmcomp/arm/proc.ml index 58bfa427b3..427287c8f5 100644 --- a/asmcomp/arm/proc.ml +++ b/asmcomp/arm/proc.ml @@ -203,7 +203,7 @@ let destroyed_at_oper = function destroyed_at_c_call | Iop(Ialloc _) -> destroyed_at_alloc - | Iop(Iconst_symbol _) when !pic_code -> + | Iop(Iconst_symbol _) when !Clflags.pic_code -> [| phys_reg 3; phys_reg 8 |] (* r3 and r12 destroyed *) | Iop(Iintop Imulh) when !arch < ARMv6 -> [| phys_reg 8 |] (* r12 destroyed *) @@ -218,14 +218,14 @@ let destroyed_at_raise = all_phys_regs 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 + | Iconst_symbol _ when !Clflags.pic_code -> 7 | Iintop Imulh when !arch < ARMv6 -> 8 | _ -> 9 let max_register_pressure = function Iextcall(_, _) -> if abi = EABI then [| 4; 0; 0 |] else [| 4; 8; 8 |] | Ialloc _ -> if abi = EABI then [| 7; 0; 0 |] else [| 7; 8; 8 |] - | Iconst_symbol _ when !pic_code -> [| 7; 16; 32 |] + | Iconst_symbol _ when !Clflags.pic_code -> [| 7; 16; 32 |] | Iintoffloat | Ifloatofint | Iload(Single, _) | Istore(Single, _, _) -> [| 9; 15; 31 |] | Iintop Imulh when !arch < ARMv6 -> [| 8; 16; 32 |] diff --git a/asmcomp/arm64/arch.ml b/asmcomp/arm64/arch.ml index bfbe183fbd..3e62da89ff 100644 --- a/asmcomp/arm64/arch.ml +++ b/asmcomp/arm64/arch.ml @@ -34,8 +34,12 @@ type addressing_mode = (* Specific operations *) type specific_operation = + | Ifar_alloc of int + | Ifar_intop_checkbound + | Ifar_intop_imm_checkbound of int | Ishiftarith of arith_operation * int | Ishiftcheckbound of int + | Ifar_shiftcheckbound of int | Imuladd (* multiply and add *) | Imulsub (* multiply and subtract *) | Inegmulf (* floating-point negate and multiply *) @@ -91,6 +95,12 @@ let print_addressing printreg addr ppf arg = let print_specific_operation printreg op ppf arg = match op with + | Ifar_alloc n -> + fprintf ppf "(far) alloc %i" n + | Ifar_intop_checkbound -> + fprintf ppf "%a (far) check > %a" printreg arg.(0) printreg arg.(1) + | Ifar_intop_imm_checkbound n -> + fprintf ppf "%a (far) check > %i" printreg arg.(0) n | Ishiftarith(op, shift) -> let op_name = function | Ishiftadd -> "+" @@ -103,6 +113,9 @@ let print_specific_operation printreg op ppf arg = printreg arg.(0) (op_name op) printreg arg.(1) shift_mark | Ishiftcheckbound n -> fprintf ppf "check %a >> %i > %a" printreg arg.(0) n printreg arg.(1) + | Ifar_shiftcheckbound n -> + fprintf ppf + "(far) check %a >> %i > %a" printreg arg.(0) n printreg arg.(1) | Imuladd -> fprintf ppf "(%a * %a) + %a" printreg arg.(0) diff --git a/asmcomp/arm64/emit.mlp b/asmcomp/arm64/emit.mlp index df82f29919..bc0513940b 100644 --- a/asmcomp/arm64/emit.mlp +++ b/asmcomp/arm64/emit.mlp @@ -233,6 +233,32 @@ let emit_intconst dst n = in if n < 0n then emit_neg true 48 else emit_pos true 48 +let num_instructions_for_intconst n = + let num_instructions = ref 0 in + let rec count_pos first shift = + if shift < 0 then begin + if first then incr num_instructions + end else begin + let s = Nativeint.(logand (shift_right_logical n shift) 0xFFFFn) in + if s = 0n then count_pos first (shift - 16) else begin + incr num_instructions; + count_pos false (shift - 16) + end + end + and count_neg first shift = + if shift < 0 then begin + if first then incr num_instructions + end else begin + let s = Nativeint.(logand (shift_right_logical n shift) 0xFFFFn) in + if s = 0xFFFFn then count_neg first (shift - 16) else begin + incr num_instructions; + count_neg false (shift - 16) + end + end + in + if n < 0n then count_neg true 48 else count_pos true 48; + !num_instructions + (* Recognize float constants appropriate for FMOV dst, #fpimm instruction: "a normalized binary floating point encoding with 1 sign bit, 4 bits of fraction and a 3-bit exponent" *) @@ -304,6 +330,217 @@ let emit_load_symbol_addr dst s = ` ldr {emit_reg dst}, [{emit_reg dst}, #:got_lo12:{emit_symbol s}]\n` end +(* The following functions are used for calculating the sizes of the + call GC and bounds check points emitted out-of-line from the function + body. See branch_relaxation.mli. *) + +let num_call_gc_and_check_bound_points instr = + let rec loop instr ((call_gc, check_bound) as totals) = + match instr.desc with + | Lend -> totals + | Lop (Ialloc _) when !fastcode_flag -> + loop instr.next (call_gc + 1, check_bound) + | Lop (Iintop Icheckbound) + | Lop (Iintop_imm (Icheckbound, _)) + | Lop (Ispecific (Ishiftcheckbound _)) -> + let check_bound = + (* When not in debug mode, there is at most one check-bound point. *) + if not !Clflags.debug then 1 + else check_bound + 1 + in + loop instr.next (call_gc, check_bound) + (* The following four should never be seen, since this function is run + before branch relaxation. *) + | Lop (Ispecific (Ifar_alloc _)) + | Lop (Ispecific Ifar_intop_checkbound) + | Lop (Ispecific (Ifar_intop_imm_checkbound _)) + | Lop (Ispecific (Ifar_shiftcheckbound _)) -> assert false + | _ -> loop instr.next totals + in + loop instr (0, 0) + +let max_out_of_line_code_offset instr ~num_call_gc ~num_check_bound = + if num_call_gc < 1 && num_check_bound < 1 then 0 + else begin + let size_of_call_gc = 2 in + let size_of_check_bound = 1 in + let size_of_last_thing = + (* Call-GC points come before check-bound points. *) + if num_check_bound >= 1 then size_of_check_bound else size_of_call_gc + in + let total_size = + size_of_call_gc*num_call_gc + size_of_check_bound*num_check_bound + in + let max_offset = total_size - size_of_last_thing in + assert (max_offset >= 0); + max_offset + end + +module BR = Branch_relaxation.Make (struct + (* CR-someday mshinwell: B and BL have +/- 128Mb ranges; for the moment we + assume we will never exceed this. It would seem to be most likely to + occur for branches between functions; in this case, the linker should be + able to insert veneers anyway. (See section 4.6.7 of the document + "ELF for the ARM 64-bit architecture (AArch64)".) *) + + type distance = int + + module Cond_branch = struct + type t = TB | CB | Bcc + + let all = [TB; CB; Bcc] + + (* AArch64 instructions are 32 bits wide, so [distance] in this module + means units of 32-bit words. *) + let max_displacement = function + | TB -> 32 * 1024 / 4 (* +/- 32Kb *) + | CB | Bcc -> 1 * 1024 * 1024 / 4 (* +/- 1Mb *) + + let classify_instr = function + | Lop (Ialloc _) + | Lop (Iintop Icheckbound) + | Lop (Iintop_imm (Icheckbound, _)) + | Lop (Ispecific (Ishiftcheckbound _)) -> Some Bcc + (* The various "far" variants in [specific_operation] don't need to + return [Some] here, since their code sequences never contain any + conditional branches that might need relaxing. *) + | Lcondbranch (Itruetest, _) + | Lcondbranch (Ifalsetest, _) -> Some CB + | Lcondbranch (Iinttest _, _) + | Lcondbranch (Iinttest_imm _, _) + | Lcondbranch (Ifloattest _, _) -> Some Bcc + | Lcondbranch (Ioddtest, _) + | Lcondbranch (Ieventest, _) -> Some TB + | Lcondbranch3 _ -> Some Bcc + | _ -> None + end + + let offset_pc_at_branch = 0 + + let epilogue_size () = + if !contains_calls then 3 else 2 + + let instr_size = function + | Lend -> 0 + | Lop (Imove | Ispill | Ireload) -> 1 + | Lop (Iconst_int n | Iconst_blockheader n) -> + num_instructions_for_intconst n + | Lop (Iconst_float _) -> 2 + | Lop (Iconst_symbol _) -> 2 + | Lop (Icall_ind) -> 1 + | Lop (Icall_imm _) -> 1 + | Lop (Itailcall_ind) -> epilogue_size () + | Lop (Itailcall_imm s) -> + if s = !function_name then 1 else epilogue_size () + | Lop (Iextcall (_, false)) -> 1 + | Lop (Iextcall (_, true)) -> 3 + | Lop (Istackoffset _) -> 2 + | Lop (Iload (size, addr)) | Lop (Istore (size, addr, _)) -> + let based = match addr with Iindexed _ -> 0 | Ibased _ -> 1 in + based + begin match size with Single -> 2 | _ -> 1 end + | Lop (Ialloc _) when !fastcode_flag -> 4 + | Lop (Ispecific (Ifar_alloc _)) when !fastcode_flag -> 5 + | Lop (Ialloc num_words) | Lop (Ispecific (Ifar_alloc num_words)) -> + begin match num_words with + | 16 | 24 | 32 -> 1 + | _ -> 1 + num_instructions_for_intconst (Nativeint.of_int num_words) + end + | Lop (Iintop (Icomp _)) -> 2 + | Lop (Iintop_imm (Icomp _, _)) -> 2 + | Lop (Iintop Icheckbound) -> 2 + | Lop (Ispecific Ifar_intop_checkbound) -> 3 + | Lop (Iintop_imm (Icheckbound, _)) -> 2 + | Lop (Ispecific (Ifar_intop_imm_checkbound _)) -> 3 + | Lop (Ispecific (Ishiftcheckbound _)) -> 2 + | Lop (Ispecific (Ifar_shiftcheckbound _)) -> 3 + | Lop (Iintop Imod) -> 2 + | Lop (Iintop Imulh) -> 1 + | Lop (Iintop _) -> 1 + | Lop (Iintop_imm _) -> 1 + | Lop (Ifloatofint | Iintoffloat | Iabsf | Inegf | Ispecific Isqrtf) -> 1 + | Lop (Iaddf | Isubf | Imulf | Idivf | Ispecific Inegmulf) -> 1 + | Lop (Ispecific (Imuladdf | Inegmuladdf | Imulsubf | Inegmulsubf)) -> 1 + | Lop (Ispecific (Ishiftarith _)) -> 1 + | Lop (Ispecific (Imuladd | Imulsub)) -> 1 + | Lop (Ispecific (Ibswap 16)) -> 2 + | Lop (Ispecific (Ibswap _)) -> 1 + | Lreloadretaddr -> 0 + | Lreturn -> epilogue_size () + | Llabel _ -> 0 + | Lbranch _ -> 1 + | Lcondbranch (tst, _) -> + begin match tst with + | Itruetest -> 1 + | Ifalsetest -> 1 + | Iinttest _ -> 2 + | Iinttest_imm _ -> 2 + | Ifloattest _ -> 2 + | Ioddtest -> 1 + | Ieventest -> 1 + end + | Lcondbranch3 (lbl0, lbl1, lbl2) -> + 1 + begin match lbl0 with None -> 0 | Some _ -> 1 end + + begin match lbl1 with None -> 0 | Some _ -> 1 end + + begin match lbl2 with None -> 0 | Some _ -> 1 end + | Lswitch jumptbl -> 3 + Array.length jumptbl + | Lsetuptrap _ -> 2 + | Lpushtrap -> 3 + | Lpoptrap -> 1 + | Lraise k -> + begin match !Clflags.debug, k with + | true, (Lambda.Raise_regular | Lambda.Raise_reraise) -> 1 + | false, _ + | true, Lambda.Raise_notrace -> 4 + end + + let relax_allocation ~num_words = + Lop (Ispecific (Ifar_alloc num_words)) + + let relax_intop_checkbound () = + Lop (Ispecific Ifar_intop_checkbound) + + let relax_intop_imm_checkbound ~bound = + Lop (Ispecific (Ifar_intop_imm_checkbound bound)) + + let relax_specific_op = function + | Ishiftcheckbound shift -> Lop (Ispecific (Ifar_shiftcheckbound shift)) + | _ -> assert false +end) + +(* Output the assembly code for allocation. *) + +let assembly_code_for_allocation i ~n ~far = + let lbl_frame = record_frame_label i.live i.dbg in + if !fastcode_flag then begin + let lbl_redo = new_label() in + let lbl_call_gc = new_label() in + `{emit_label lbl_redo}:`; + ` sub {emit_reg reg_alloc_ptr}, {emit_reg reg_alloc_ptr}, #{emit_int n}\n`; + ` cmp {emit_reg reg_alloc_ptr}, {emit_reg reg_alloc_limit}\n`; + ` add {emit_reg i.res.(0)}, {emit_reg reg_alloc_ptr}, #8\n`; + if not far then begin + ` b.lo {emit_label lbl_call_gc}\n` + end else begin + let lbl = new_label () in + ` b.cs {emit_label lbl}\n`; + ` b {emit_label lbl_call_gc}\n`; + `{emit_label lbl}:\n` + end; + call_gc_sites := + { gc_lbl = lbl_call_gc; + gc_return_lbl = lbl_redo; + gc_frame_lbl = lbl_frame } :: !call_gc_sites + end else begin + begin match n with + | 16 -> ` bl {emit_symbol "caml_alloc1"}\n` + | 24 -> ` bl {emit_symbol "caml_alloc2"}\n` + | 32 -> ` bl {emit_symbol "caml_alloc3"}\n` + | _ -> emit_intconst reg_x15 (Nativeint.of_int n); + ` bl {emit_symbol "caml_allocN"}\n` + end; + `{emit_label lbl_frame}: add {emit_reg i.res.(0)}, {emit_reg reg_alloc_ptr}, #8\n` + end + (* Output the assembly code for an instruction *) let emit_instr i = @@ -412,29 +649,9 @@ let emit_instr i = ` str {emit_reg src}, {emit_addressing addr base}\n` end | Lop(Ialloc n) -> - let lbl_frame = record_frame_label i.live i.dbg in - if !fastcode_flag then begin - let lbl_redo = new_label() in - let lbl_call_gc = new_label() in - `{emit_label lbl_redo}:`; - ` sub {emit_reg reg_alloc_ptr}, {emit_reg reg_alloc_ptr}, #{emit_int n}\n`; - ` cmp {emit_reg reg_alloc_ptr}, {emit_reg reg_alloc_limit}\n`; - ` add {emit_reg i.res.(0)}, {emit_reg reg_alloc_ptr}, #8\n`; - ` b.lo {emit_label lbl_call_gc}\n`; - call_gc_sites := - { gc_lbl = lbl_call_gc; - gc_return_lbl = lbl_redo; - gc_frame_lbl = lbl_frame } :: !call_gc_sites - end else begin - begin match n with - | 16 -> ` bl {emit_symbol "caml_alloc1"}\n` - | 24 -> ` bl {emit_symbol "caml_alloc2"}\n` - | 32 -> ` bl {emit_symbol "caml_alloc3"}\n` - | _ -> emit_intconst reg_x15 (Nativeint.of_int n); - ` bl {emit_symbol "caml_allocN"}\n` - end; - `{emit_label lbl_frame}: add {emit_reg i.res.(0)}, {emit_reg reg_alloc_ptr}, #8\n` - end + assembly_code_for_allocation i ~n ~far:false + | Lop(Ispecific (Ifar_alloc n)) -> + assembly_code_for_allocation i ~n ~far:true | Lop(Iintop(Icomp cmp)) -> ` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; ` cset {emit_reg i.res.(0)}, {emit_string (name_for_comparison cmp)}\n` @@ -445,14 +662,35 @@ let emit_instr i = let lbl = bound_error_label i.dbg in ` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; ` b.ls {emit_label lbl}\n` + | Lop(Ispecific Ifar_intop_checkbound) -> + let lbl = bound_error_label i.dbg in + let lbl2 = new_label () in + ` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; + ` b.hi {emit_label lbl2}\n`; + ` b {emit_label lbl}\n`; + `{emit_label lbl2}:\n`; | Lop(Iintop_imm(Icheckbound, n)) -> let lbl = bound_error_label i.dbg in ` cmp {emit_reg i.arg.(0)}, #{emit_int n}\n`; ` b.ls {emit_label lbl}\n` + | Lop(Ispecific(Ifar_intop_imm_checkbound bound)) -> + let lbl = bound_error_label i.dbg in + let lbl2 = new_label () in + ` cmp {emit_reg i.arg.(0)}, #{emit_int bound}\n`; + ` b.hi {emit_label lbl2}\n`; + ` b {emit_label lbl}\n`; + `{emit_label lbl2}:\n`; | Lop(Ispecific(Ishiftcheckbound shift)) -> let lbl = bound_error_label i.dbg in ` cmp {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}, lsr #{emit_int shift}\n`; ` b.cs {emit_label lbl}\n` + | Lop(Ispecific(Ifar_shiftcheckbound shift)) -> + let lbl = bound_error_label i.dbg in + let lbl2 = new_label () in + ` cmp {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}, lsr #{emit_int shift}\n`; + ` b.lo {emit_label lbl2}\n`; + ` b {emit_label lbl}\n`; + `{emit_label lbl2}:\n`; | Lop(Iintop Imod) -> ` sdiv {emit_reg reg_tmp1}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; ` msub {emit_reg i.res.(0)}, {emit_reg reg_tmp1}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n` @@ -508,7 +746,7 @@ let emit_instr i = begin match size with | 16 -> ` rev16 {emit_wreg i.res.(0)}, {emit_wreg i.arg.(0)}\n`; - ` ubfm {emit_reg i.res.(0)}, {emit_reg i.res.(0)}, #0, #16\n` + ` ubfm {emit_reg i.res.(0)}, {emit_reg i.res.(0)}, #0, #15\n` | 32 -> ` rev {emit_wreg i.res.(0)}, {emit_wreg i.arg.(0)}\n` | 64 -> @@ -656,12 +894,24 @@ let fundecl fundecl = let n = frame_size() in if n > 0 then emit_stack_adjustment (-n); - if !contains_calls then - ` str x30, [sp, #{emit_int (n-8)}]\n`; + if !contains_calls then begin + cfi_offset ~reg:30 (* return address *) ~offset:(-8); + ` str x30, [sp, #{emit_int (n-8)}]\n` + end; `{emit_label !tailrec_entry_point}:\n`; + let num_call_gc, num_check_bound = + num_call_gc_and_check_bound_points fundecl.fun_body + in + let max_out_of_line_code_offset = + max_out_of_line_code_offset fundecl.fun_body ~num_call_gc + ~num_check_bound + in + BR.relax fundecl.fun_body ~max_out_of_line_code_offset; emit_all fundecl.fun_body; List.iter emit_call_gc !call_gc_sites; List.iter emit_call_bound_error !bound_error_sites; + assert (List.length !call_gc_sites = num_call_gc); + assert (List.length !bound_error_sites = num_check_bound); cfi_endproc(); ` .type {emit_symbol fundecl.fun_name}, %function\n`; ` .size {emit_symbol fundecl.fun_name}, .-{emit_symbol fundecl.fun_name}\n`; diff --git a/asmcomp/asmgen.ml b/asmcomp/asmgen.ml index 311bb029b2..0e01f9ba3f 100644 --- a/asmcomp/asmgen.ml +++ b/asmcomp/asmgen.ml @@ -99,43 +99,55 @@ let compile_genfuns ppf f = | _ -> ()) (Cmmgen.generic_functions true [Compilenv.current_unit_infos ()]) +let compile_unit asm_filename keep_asm obj_filename gen = + let create_asm = keep_asm || not !Emitaux.binary_backend_available in + Emitaux.create_asm_file := create_asm; + try + if create_asm then Emitaux.output_channel := open_out asm_filename; + begin try + gen (); + if create_asm then close_out !Emitaux.output_channel; + with exn when create_asm -> + close_out !Emitaux.output_channel; + if not keep_asm then remove_file asm_filename; + raise exn + end; + if Proc.assemble_file asm_filename obj_filename <> 0 + then raise(Error(Assembler_error asm_filename)); + if create_asm && not keep_asm then remove_file asm_filename + with exn -> + remove_file obj_filename; + raise exn + +let gen_implementation ?toplevel ppf (size, lam) = + Emit.begin_assembly (); + Closure.intro size lam + ++ clambda_dump_if ppf + ++ Cmmgen.compunit size + ++ List.iter (compile_phrase ppf) ++ (fun () -> ()); + (match toplevel with None -> () | Some f -> compile_genfuns ppf f); + + (* We add explicit references to external primitive symbols. This + is to ensure that the object files that define these symbols, + when part of a C library, won't be discarded by the linker. + This is important if a module that uses such a symbol is later + dynlinked. *) + + compile_phrase ppf + (Cmmgen.reference_symbols + (List.filter (fun s -> s <> "" && s.[0] <> '%') + (List.map Primitive.native_name !Translmod.primitive_declarations)) + ); + Emit.end_assembly () + let compile_implementation ?toplevel prefixname ppf (size, lam) = let asmfile = - if !keep_asm_file + if !keep_asm_file || !Emitaux.binary_backend_available then prefixname ^ ext_asm - else Filename.temp_file "camlasm" ext_asm in - let oc = open_out asmfile in - begin try - Emitaux.output_channel := oc; - Emit.begin_assembly(); - Closure.intro size lam - ++ clambda_dump_if ppf - ++ Cmmgen.compunit size - ++ List.iter (compile_phrase ppf) ++ (fun () -> ()); - (match toplevel with None -> () | Some f -> compile_genfuns ppf f); - - (* We add explicit references to external primitive symbols. This - is to ensure that the object files that define these symbols, - when part of a C library, won't be discarded by the linker. - This is important if a module that uses such a symbol is later - dynlinked. *) - - compile_phrase ppf - (Cmmgen.reference_symbols - (List.filter (fun s -> s <> "" && s.[0] <> '%') - (List.map Primitive.native_name !Translmod.primitive_declarations)) - ); - - Emit.end_assembly(); - close_out oc - with x -> - close_out oc; - if !keep_asm_file then () else remove_file asmfile; - raise x - end; - if Proc.assemble_file asmfile (prefixname ^ ext_obj) <> 0 - then raise(Error(Assembler_error asmfile)); - if !keep_asm_file then () else remove_file asmfile + else Filename.temp_file "camlasm" ext_asm + in + compile_unit asmfile !keep_asm_file (prefixname ^ ext_obj) + (fun () -> gen_implementation ?toplevel ppf (size, lam)) (* Error report *) diff --git a/asmcomp/asmgen.mli b/asmcomp/asmgen.mli index 33582af4a7..0b5aa02294 100644 --- a/asmcomp/asmgen.mli +++ b/asmcomp/asmgen.mli @@ -21,3 +21,8 @@ val compile_phrase : type error = Assembler_error of string exception Error of error val report_error: Format.formatter -> error -> unit + + +val compile_unit: + string(*asm file*) -> bool(*keep asm*) -> + string(*obj file*) -> (unit -> unit) -> unit diff --git a/asmcomp/asmlink.ml b/asmcomp/asmlink.ml index 153da7cace..2be5fdf835 100644 --- a/asmcomp/asmlink.ml +++ b/asmcomp/asmlink.ml @@ -91,10 +91,11 @@ let extract_crc_implementations () = let lib_ccobjs = ref [] let lib_ccopts = ref [] -let add_ccobjs l = +let add_ccobjs origin l = if not !Clflags.no_auto_link then begin lib_ccobjs := l.lib_ccobjs @ !lib_ccobjs; - lib_ccopts := l.lib_ccopts @ !lib_ccopts + let replace_origin = Misc.replace_substring ~before:"$CAMLORIGIN" ~after:origin in + lib_ccopts := List.map replace_origin l.lib_ccopts @ !lib_ccopts end let runtime_lib () = @@ -179,7 +180,7 @@ let scan_file obj_name tolink = match read_file obj_name with | Library (file_name,infos) -> (* This is an archive file. Each unit contained in it will be linked in only if needed. *) - add_ccobjs infos; + add_ccobjs (Filename.dirname file_name) infos; List.fold_right (fun (info, crc) reqd -> if info.ui_force_link @@ -197,13 +198,11 @@ let scan_file obj_name tolink = match read_file obj_name with (* Second pass: generate the startup file and link it with everything else *) -let make_startup_file ppf filename units_list = +let make_startup_file ppf units_list = let compile_phrase p = Asmgen.compile_phrase ppf p in - let oc = open_out filename in - Emitaux.output_channel := oc; Location.input_name := "caml_startup"; (* set name of "current" input *) Compilenv.reset "_startup"; (* set the name of the "current" compunit *) - Emit.begin_assembly(); + Emit.begin_assembly (); let name_list = List.flatten (List.map (fun (info,_,_) -> info.ui_defines) units_list) in compile_phrase (Cmmgen.entry_point name_list); @@ -230,17 +229,13 @@ let make_startup_file ppf filename units_list = compile_phrase(Cmmgen.code_segment_table ("_startup" :: name_list)); compile_phrase (Cmmgen.frame_table("_startup" :: "_system" :: name_list)); + Emit.end_assembly () - Emit.end_assembly(); - close_out oc - -let make_shared_startup_file ppf units filename = +let make_shared_startup_file ppf units = let compile_phrase p = Asmgen.compile_phrase ppf p in - let oc = open_out filename in - Emitaux.output_channel := oc; Location.input_name := "caml_startup"; Compilenv.reset "_shared_startup"; - Emit.begin_assembly(); + Emit.begin_assembly (); List.iter compile_phrase (Cmmgen.generic_functions true (List.map fst units)); compile_phrase (Cmmgen.plugin_header units); @@ -249,10 +244,7 @@ let make_shared_startup_file ppf units filename = (List.map (fun (ui,_) -> ui.ui_symbol) units)); (* this is to force a reference to all units, otherwise the linker might drop some of them (in case of libraries) *) - - Emit.end_assembly(); - close_out oc - + Emit.end_assembly () let call_linker_shared file_list output_name = if not (Ccomp.call_linker Ccomp.Dll output_name file_list "") @@ -269,27 +261,29 @@ let link_shared ppf objfiles output_name = (List.rev !Clflags.ccobjs) in let startup = - if !Clflags.keep_startup_file + if !Clflags.keep_startup_file || !Emitaux.binary_backend_available then output_name ^ ".startup" ^ ext_asm else Filename.temp_file "camlstartup" ext_asm in - make_shared_startup_file ppf - (List.map (fun (ui,_,crc) -> (ui,crc)) units_tolink) startup; let startup_obj = output_name ^ ".startup" ^ ext_obj in - if Proc.assemble_file startup startup_obj <> 0 - then raise(Error(Assembler_error startup)); - if not !Clflags.keep_startup_file then remove_file startup; + Asmgen.compile_unit + startup !Clflags.keep_startup_file startup_obj + (fun () -> + make_shared_startup_file ppf + (List.map (fun (ui,_,crc) -> (ui,crc)) units_tolink) + ); call_linker_shared (startup_obj :: objfiles) output_name; remove_file startup_obj let call_linker file_list startup_file output_name = let main_dll = !Clflags.output_c_object && Filename.check_suffix output_name Config.ext_dll + and main_obj_runtime = !Clflags.output_complete_object in let files = startup_file :: (List.rev file_list) in let files, c_lib = - if (not !Clflags.output_c_object) || main_dll then + if (not !Clflags.output_c_object) || main_dll || main_obj_runtime then files @ (List.rev !Clflags.ccobjs) @ runtime_lib (), - (if !Clflags.nopervasives then "" else Config.native_c_libraries) + (if !Clflags.nopervasives || main_obj_runtime then "" else Config.native_c_libraries) else files, "" in @@ -325,19 +319,16 @@ let link ppf objfiles output_name = Clflags.all_ccopts := !lib_ccopts @ !Clflags.all_ccopts; (* put user's opts first *) let startup = - if !Clflags.keep_startup_file then output_name ^ ".startup" ^ ext_asm + if !Clflags.keep_startup_file || !Emitaux.binary_backend_available + then output_name ^ ".startup" ^ ext_asm else Filename.temp_file "camlstartup" ext_asm in - make_startup_file ppf startup units_tolink; let startup_obj = Filename.temp_file "camlstartup" ext_obj in - if Proc.assemble_file startup startup_obj <> 0 then - raise(Error(Assembler_error startup)); - try - call_linker (List.map object_file_name objfiles) startup_obj output_name; - if not !Clflags.keep_startup_file then remove_file startup; - remove_file startup_obj - with x -> - remove_file startup_obj; - raise x + Asmgen.compile_unit + startup !Clflags.keep_startup_file startup_obj + (fun () -> make_startup_file ppf units_tolink); + Misc.try_finally + (fun () -> call_linker (List.map object_file_name objfiles) startup_obj output_name) + (fun () -> remove_file startup_obj) (* Error report *) diff --git a/asmcomp/asmpackager.ml b/asmcomp/asmpackager.ml index d900df1e14..553d0fe137 100644 --- a/asmcomp/asmpackager.ml +++ b/asmcomp/asmpackager.ml @@ -38,7 +38,7 @@ type pack_member = let read_member_info pack_path file = ( let name = - String.capitalize(Filename.basename(chop_extensions file)) in + String.capitalize_ascii(Filename.basename(chop_extensions file)) in let kind = if Filename.check_suffix file ".cmx" then begin let (info, crc) = Compilenv.read_unit_info file in @@ -171,7 +171,7 @@ let package_files ppf initial_env files targetcmx = let prefix = chop_extensions targetcmx in let targetcmi = prefix ^ ".cmi" in let targetobj = chop_extension_if_any targetcmx ^ Config.ext_obj in - let targetname = String.capitalize(Filename.basename prefix) in + let targetname = String.capitalize_ascii(Filename.basename prefix) in (* Set the name of the current "input" *) Location.input_name := targetcmx; (* Set the name of the current compunit *) diff --git a/asmcomp/branch_relaxation.ml b/asmcomp/branch_relaxation.ml new file mode 100644 index 0000000000..d4609e4a8e --- /dev/null +++ b/asmcomp/branch_relaxation.ml @@ -0,0 +1,138 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* Mark Shinwell, Jane Street Europe *) +(* *) +(* Copyright 1996 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. *) +(* *) +(***********************************************************************) + +open Mach +open Linearize + +module Make (T : Branch_relaxation_intf.S) = struct + let label_map code = + let map = Hashtbl.create 37 in + let rec fill_map pc instr = + match instr.desc with + | Lend -> (pc, map) + | Llabel lbl -> Hashtbl.add map lbl pc; fill_map pc instr.next + | op -> fill_map (pc + T.instr_size op) instr.next + in + fill_map 0 code + + let branch_overflows map pc_branch lbl_dest max_branch_offset = + let pc_dest = Hashtbl.find map lbl_dest in + let delta = pc_dest - (pc_branch + T.offset_pc_at_branch) in + delta <= -max_branch_offset || delta >= max_branch_offset + + let opt_branch_overflows map pc_branch opt_lbl_dest max_branch_offset = + match opt_lbl_dest with + | None -> false + | Some lbl_dest -> + branch_overflows map pc_branch lbl_dest max_branch_offset + + let instr_overflows ~code_size ~max_out_of_line_code_offset instr map pc = + match T.Cond_branch.classify_instr instr.desc with + | None -> false + | Some branch -> + let max_branch_offset = + (* Remember to cut some slack for multi-word instructions (in the + [Linearize] sense of the word) where the branch can be anywhere in + the middle. 12 words of slack is plenty. *) + T.Cond_branch.max_displacement branch - 12 + in + match instr.desc with + | Lop (Ialloc _) + | Lop (Iintop Icheckbound) + | Lop (Iintop_imm (Icheckbound, _)) + | Lop (Ispecific _) -> + (* We assume that any branches eligible for relaxation generated + by these instructions only branch forward. We further assume + that any of these may branch to an out-of-line code block. *) + code_size + max_out_of_line_code_offset - pc >= max_branch_offset + | Lcondbranch (_, lbl) -> + branch_overflows map pc lbl max_branch_offset + | Lcondbranch3 (lbl0, lbl1, lbl2) -> + opt_branch_overflows map pc lbl0 max_branch_offset + || opt_branch_overflows map pc lbl1 max_branch_offset + || opt_branch_overflows map pc lbl2 max_branch_offset + | _ -> + Misc.fatal_error "Unsupported instruction for branch relaxation" + + let fixup_branches ~code_size ~max_out_of_line_code_offset map code = + let expand_optbranch lbl n arg next = + match lbl with + | None -> next + | Some l -> + instr_cons (Lcondbranch (Iinttest_imm (Isigned Cmm.Ceq, n), l)) + arg [||] next + in + let rec fixup did_fix pc instr = + match instr.desc with + | Lend -> did_fix + | _ -> + let overflows = + instr_overflows ~code_size ~max_out_of_line_code_offset instr map pc + in + if not overflows then + fixup did_fix (pc + T.instr_size instr.desc) instr.next + else + match instr.desc with + | Lop (Ialloc num_words) -> + instr.desc <- T.relax_allocation ~num_words; + fixup true (pc + T.instr_size instr.desc) instr.next + | Lop (Iintop Icheckbound) -> + instr.desc <- T.relax_intop_checkbound (); + fixup true (pc + T.instr_size instr.desc) instr.next + | Lop (Iintop_imm (Icheckbound, bound)) -> + instr.desc <- T.relax_intop_imm_checkbound ~bound; + fixup true (pc + T.instr_size instr.desc) instr.next + | Lop (Ispecific specific) -> + instr.desc <- T.relax_specific_op specific; + fixup true (pc + T.instr_size instr.desc) instr.next + | Lcondbranch (test, lbl) -> + let lbl2 = new_label() in + let cont = + instr_cons (Lbranch lbl) [||] [||] + (instr_cons (Llabel lbl2) [||] [||] instr.next) + in + instr.desc <- Lcondbranch (invert_test test, lbl2); + instr.next <- cont; + fixup true (pc + T.instr_size instr.desc) instr.next + | Lcondbranch3 (lbl0, lbl1, lbl2) -> + let cont = + expand_optbranch lbl0 0 instr.arg + (expand_optbranch lbl1 1 instr.arg + (expand_optbranch lbl2 2 instr.arg instr.next)) + in + instr.desc <- cont.desc; + instr.next <- cont.next; + fixup true pc instr + | _ -> + (* Any other instruction has already been rejected in + [instr_overflows] above. + We can *never* get here. *) + assert false + in + fixup false 0 code + + (* Iterate branch expansion till all conditional branches are OK *) + + let rec relax code ~max_out_of_line_code_offset = + let min_of_max_branch_offsets = + List.fold_left (fun min_of_max_branch_offsets branch -> + min min_of_max_branch_offsets + (T.Cond_branch.max_displacement branch)) + max_int T.Cond_branch.all + in + let (code_size, map) = label_map code in + if code_size >= min_of_max_branch_offsets + && fixup_branches ~code_size ~max_out_of_line_code_offset map code + then relax code ~max_out_of_line_code_offset + else () +end diff --git a/asmcomp/branch_relaxation.mli b/asmcomp/branch_relaxation.mli new file mode 100644 index 0000000000..e2a93f83d1 --- /dev/null +++ b/asmcomp/branch_relaxation.mli @@ -0,0 +1,26 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* Mark Shinwell, Jane Street Europe *) +(* *) +(* Copyright 2015 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. *) +(* *) +(***********************************************************************) + +(* Fix up conditional branches that exceed hardware-allowed ranges. *) + +module Make (T : Branch_relaxation_intf.S) : sig + val relax + : Linearize.instruction + (* [max_offset_of_out_of_line_code] specifies the furthest distance, + measured from the first address immediately after the last instruction + of the function, that may be branched to from within the function in + order to execute "out of line" code blocks such as call GC and + bounds check points. *) + -> max_out_of_line_code_offset:T.distance + -> unit +end diff --git a/asmcomp/branch_relaxation_intf.ml b/asmcomp/branch_relaxation_intf.ml new file mode 100644 index 0000000000..0812c7c1b8 --- /dev/null +++ b/asmcomp/branch_relaxation_intf.ml @@ -0,0 +1,64 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* Mark Shinwell, Jane Street Europe *) +(* *) +(* Copyright 2015 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. *) +(* *) +(***********************************************************************) + +module type S = sig + (* The distance between two instructions, in arbitrary units (typically + the natural word size of instructions). *) + type distance = int + + module Cond_branch : sig + (* The various types of conditional branches for a given target that + may require relaxation. *) + type t + + (* All values of type [t] that the emitter may produce. *) + val all : t list + + (* If [max_displacement branch] is [n] then [branch] is assumed to + reach any address in the range [pc - n, pc + n] (inclusive), after + the [pc] of the branch has been adjusted by [offset_pc_at_branch] + (see below). *) + val max_displacement : t -> distance + + (* Which variety of conditional branch may be produced by the emitter for a + given instruction description. For the moment we assume that only one + such variety per instruction description is needed. + + N.B. The only instructions supported are the following: + - Lop (Ialloc _) + - Lop (Iintop Icheckbound) + - Lop (Iintop_imm (Icheckbound, _)) + - Lop (Ispecific _) + - Lcondbranch (_, _) + - Lcondbranch3 (_, _, _) + [classify_instr] is expected to return [None] when called on any + instruction not in this list. *) + val classify_instr : Linearize.instruction_desc -> t option + end + + (* The value to be added to the program counter (in [distance] units) + when it is at a branch instruction, prior to calculating the distance + to a branch target. *) + val offset_pc_at_branch : distance + + (* The maximum size of a given instruction. *) + val instr_size : Linearize.instruction_desc -> distance + + (* Insertion of target-specific code to relax operations that cannot be + relaxed generically. It is assumed that these rewrites do not change + the size of out-of-line code (cf. branch_relaxation.mli). *) + val relax_allocation : num_words:int -> Linearize.instruction_desc + val relax_intop_checkbound : unit -> Linearize.instruction_desc + val relax_intop_imm_checkbound : bound:int -> Linearize.instruction_desc + val relax_specific_op : Arch.specific_operation -> Linearize.instruction_desc +end diff --git a/asmcomp/closure.ml b/asmcomp/closure.ml index 249e67c4e5..175932c8f5 100644 --- a/asmcomp/closure.ml +++ b/asmcomp/closure.ml @@ -119,7 +119,7 @@ let split_default_wrapper fun_id kind params body = let inner_id = Ident.create (Ident.name fun_id ^ "_inner") in let map_param p = try List.assoc p map with Not_found -> p in let args = List.map (fun p -> Lvar (map_param p)) params in - let wrapper_body = Lapply (Lvar inner_id, args, Location.none) in + let wrapper_body = Lapply (Lvar inner_id, args, no_apply_info) in let inner_params = List.map map_param params in let new_ids = List.map Ident.rename inner_params in @@ -129,14 +129,14 @@ let split_default_wrapper fun_id kind params body = Ident.empty inner_params new_ids in let body = Lambda.subst_lambda subst body in - let inner_fun = Lfunction(Curried, new_ids, body) in + let inner_fun = Lfunction{kind = Curried; params = new_ids; body} in (wrapper_body, (inner_id, inner_fun)) in try let wrapper_body, inner = aux [] body in - [(fun_id, Lfunction(kind, params, wrapper_body)); inner] + [(fun_id, Lfunction{kind; params; body = wrapper_body}); inner] with Exit -> - [(fun_id, Lfunction(kind, params, body))] + [(fun_id, Lfunction{kind; params; body})] (* Determine whether the estimated size of a clambda term is below @@ -493,6 +493,8 @@ let simplif_prim_pure fpc p (args, approxs) dbg = begin match c with | Big_endian -> make_const_bool Arch.big_endian | Word_size -> make_const_int (8*Arch.size_int) + | Int_size -> make_const_int (8*Arch.size_int - 1) + | Max_wosize -> make_const_int ((1 lsl ((8*Arch.size_int) - 10)) - 1 ) | 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") @@ -528,6 +530,16 @@ let approx_ulam = function Uconst c -> Value_const c | _ -> Value_unknown +let find_action idxs acts tag = + if 0 <= tag && tag < Array.length idxs then begin + let idx = idxs.(tag) in + assert(0 <= idx && idx < Array.length acts); + Some acts.(idx) + end else + (* Can this happen? *) + None + + let rec substitute fpc sb ulam = match ulam with Uvar v -> @@ -572,13 +584,32 @@ let rec substitute fpc sb ulam = simplif_prim fpc p (sargs, List.map approx_ulam sargs) dbg in res | Uswitch(arg, sw) -> - Uswitch(substitute fpc sb arg, - { sw with - us_actions_consts = - Array.map (substitute fpc sb) sw.us_actions_consts; - us_actions_blocks = - Array.map (substitute fpc sb) sw.us_actions_blocks; - }) + let sarg = substitute fpc sb arg in + let action = + (* Unfortunately, we cannot easily deal with the + case of a constructed block (makeblock) bound to a local + identifier. This would require to keep track of + local let bindings (at least their approximations) + in this substitute function. + *) + match sarg with + | Uconst (Uconst_ref (_, Uconst_block (tag, _))) -> + find_action sw.us_index_blocks sw.us_actions_blocks tag + | Uconst (Uconst_ptr tag) -> + find_action sw.us_index_consts sw.us_actions_consts tag + | _ -> None + in + begin match action with + | Some u -> substitute fpc sb u + | None -> + Uswitch(sarg, + { sw with + us_actions_consts = + Array.map (substitute fpc sb) sw.us_actions_consts; + us_actions_blocks = + Array.map (substitute fpc sb) sw.us_actions_blocks; + }) + end | Ustringswitch(arg,sw,d) -> Ustringswitch (substitute fpc sb arg, @@ -809,12 +840,12 @@ let rec close fenv cenv = function | Const_base(Const_nativeint x) -> str (Uconst_nativeint x) in make_const (transl cst) - | Lfunction(kind, params, body) as funct -> + | Lfunction{kind; params; body} as funct -> close_one_function fenv cenv (Ident.create "fun") funct (* We convert [f a] to [let a' = a in fun b c -> f a' b c] when fun_arity > nargs *) - | Lapply(funct, args, loc) -> + | Lapply(funct, args, {apply_loc=loc}) -> let nargs = List.length args in begin match (close fenv cenv funct, close_list fenv cenv args) with ((ufunct, Value_closure(fundesc, approx_res)), @@ -846,8 +877,10 @@ let rec close fenv cenv = function @ (List.map (fun arg -> Lvar arg ) final_args) in let (new_fun, approx) = close fenv cenv - (Lfunction( - Curried, final_args, Lapply(funct, internal_args, loc))) + (Lfunction{ + kind = Curried; + params = final_args; + body = Lapply(funct, internal_args, mk_apply_info loc)}) in let new_fun = iter first_args new_fun in (new_fun, approx) @@ -881,7 +914,7 @@ let rec close fenv cenv = function end | Lletrec(defs, body) -> if List.for_all - (function (id, Lfunction(_, _, _)) -> true | _ -> false) + (function (id, Lfunction _) -> true | _ -> false) defs then begin (* Simple case: only function definitions *) @@ -913,7 +946,7 @@ let rec close fenv cenv = function end | Lprim(Pdirapply loc,[funct;arg]) | Lprim(Prevapply loc,[arg;funct]) -> - close fenv cenv (Lapply(funct, [arg], loc)) + close fenv cenv (Lapply(funct, [arg], mk_apply_info loc)) | Lprim(Pgetglobal id, []) as lam -> check_constant_result lam (getglobal id) @@ -1035,7 +1068,7 @@ and close_list_approx fenv cenv = function (ulam :: ulams, approx :: approxs) and close_named fenv cenv id = function - Lfunction(kind, params, body) as funct -> + Lfunction{kind; params; body} as funct -> close_one_function fenv cenv id funct | lam -> close fenv cenv lam @@ -1047,7 +1080,7 @@ and close_functions fenv cenv fun_defs = List.flatten (List.map (function - | (id, Lfunction(kind, params, body)) -> + | (id, Lfunction{kind; params; body}) -> split_default_wrapper id kind params body | _ -> assert false ) @@ -1067,7 +1100,7 @@ and close_functions fenv cenv fun_defs = let uncurried_defs = List.map (function - (id, Lfunction(kind, params, body)) -> + (id, Lfunction{kind; params; body}) -> let label = Compilenv.make_symbol (Some (Ident.unique_name id)) in let arity = List.length params in let fundesc = diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml index 0d904491e8..aabe9e152c 100644 --- a/asmcomp/cmmgen.ml +++ b/asmcomp/cmmgen.ml @@ -31,6 +31,11 @@ let bind name arg fn = | Cconst_blockheader _ -> fn arg | _ -> let id = Ident.create name in Clet(id, arg, fn (Cvar id)) +let bind_load name arg fn = + match arg with + | Cop(Cload _, [Cvar _]) -> fn arg + | _ -> bind name arg fn + let bind_nonvar name arg fn = match arg with Cconst_int _ | Cconst_natint _ | Cconst_symbol _ @@ -88,70 +93,68 @@ let rec add_const c n = if n = 0 then c else match c with | Cconst_int x when no_overflow_add x n -> Cconst_int (x + n) + | Cop(Caddi, ([Cconst_int x; c] | [c; Cconst_int x])) when no_overflow_add n x -> + let d = n + x in + if d = 0 then c else Cop(Caddi, [c; Cconst_int d]) | Cop(Csubi, [Cconst_int x; c]) when no_overflow_add n x -> Cop(Csubi, [Cconst_int (n + x); c]) | Cop(Csubi, [c; Cconst_int x]) when no_overflow_sub n x -> add_const c (n - x) | c -> Cop(Caddi, [c; Cconst_int n]) -let incr_int = function - Cconst_int n when n < max_int -> Cconst_int(n+1) - | Cop(Caddi, [c; Cconst_int n]) when n < max_int -> add_const c (n + 1) - | c -> add_const c 1 +let incr_int c = add_const c 1 +let decr_int c = add_const c (-1) -let decr_int = function - Cconst_int n when n > min_int -> Cconst_int(n-1) - | Cop(Caddi, [c; Cconst_int n]) when n > min_int -> add_const c (n - 1) - | c -> add_const c (-1) - -let add_int c1 c2 = +let rec add_int c1 c2 = match (c1, c2) with - (Cop(Caddi, [c1; Cconst_int n1]), - Cop(Caddi, [c2; Cconst_int n2])) when no_overflow_add n1 n2 -> - add_const (Cop(Caddi, [c1; c2])) (n1 + n2) + | (Cconst_int n, c) | (c, Cconst_int n) -> + add_const c n | (Cop(Caddi, [c1; Cconst_int n1]), c2) -> - add_const (Cop(Caddi, [c1; c2])) n1 + add_const (add_int c1 c2) n1 | (c1, Cop(Caddi, [c2; Cconst_int n2])) -> - add_const (Cop(Caddi, [c1; c2])) n2 - | (Cconst_int _, _) -> - Cop(Caddi, [c2; c1]) + add_const (add_int c1 c2) n2 | (_, _) -> Cop(Caddi, [c1; c2]) -let sub_int c1 c2 = +let rec sub_int c1 c2 = match (c1, c2) with - (Cop(Caddi, [c1; Cconst_int n1]), - Cop(Caddi, [c2; Cconst_int n2])) when no_overflow_sub n1 n2 -> - add_const (Cop(Csubi, [c1; c2])) (n1 - n2) - | (Cop(Caddi, [c1; Cconst_int n1]), c2) -> - add_const (Cop(Csubi, [c1; c2])) n1 + | (c1, Cconst_int n2) when n2 <> min_int -> + add_const c1 (-n2) | (c1, Cop(Caddi, [c2; Cconst_int n2])) when n2 <> min_int -> - add_const (Cop(Csubi, [c1; c2])) (-n2) - | (c1, Cconst_int n) when n <> min_int -> - add_const c1 (-n) + add_const (sub_int c1 c2) (-n2) + | (Cop(Caddi, [c1; Cconst_int n1]), c2) -> + add_const (sub_int c1 c2) n1 | (c1, c2) -> Cop(Csubi, [c1; c2]) -let mul_int c1 c2 = +let rec lsl_int c1 c2 = + match (c1, c2) with + | (Cop(Clsl, [c; Cconst_int n1]), Cconst_int n2) + when n1 > 0 && n2 > 0 && n1 + n2 < size_int * 8 -> + Cop(Clsl, [c; Cconst_int (n1 + n2)]) + | (Cop(Caddi, [c1; Cconst_int n1]), Cconst_int n2) + when no_overflow_lsl n1 n2 -> + add_const (lsl_int c1 c2) (n1 lsl n2) + | (_, _) -> + Cop(Clsl, [c1; c2]) + +let rec mul_int c1 c2 = match (c1, c2) with - (c, Cconst_int 0) | (Cconst_int 0, c) -> + | (c, Cconst_int 0) | (Cconst_int 0, c) -> Cconst_int 0 | (c, Cconst_int 1) | (Cconst_int 1, c) -> c | (c, Cconst_int(-1)) | (Cconst_int(-1), c) -> sub_int (Cconst_int 0) c | (c, Cconst_int n) | (Cconst_int n, c) when n = 1 lsl Misc.log2 n-> - Cop(Clsl, [c; Cconst_int(Misc.log2 n)]) + lsl_int c (Cconst_int (Misc.log2 n)) + | (Cop(Caddi, [c; Cconst_int n]), Cconst_int k) | + (Cconst_int k, Cop(Caddi, [c; Cconst_int n])) + when no_overflow_mul n k -> + add_const (mul_int c (Cconst_int k)) (n * k) | (c1, c2) -> Cop(Cmuli, [c1; c2]) -let lsl_int c1 c2 = - match (c1, c2) with - (Cop(Clsl, [c; Cconst_int n1]), Cconst_int n2) - when n1 > 0 && n2 > 0 && n1 + n2 < size_int * 8 -> - Cop(Clsl, [c; Cconst_int (n1 + n2)]) - | (_, _) -> - Cop(Clsl, [c1; c2]) let ignore_low_bit_int = function Cop(Caddi, [(Cop(Clsl, [_; Cconst_int n]) as c); Cconst_int 1]) when n > 0 @@ -349,10 +352,10 @@ let mod_int c1 c2 dbg = (c1, Cconst_int 0) -> Csequence(c1, Cop(Craise (Raise_regular, dbg), [Cconst_symbol "caml_exn_Division_by_zero"])) - | (c1, Cconst_int 1) -> - c1 - | (Cconst_int(0 | 1) as c1, c2) -> - Csequence(c2, c1) + | (c1, Cconst_int (1 | (-1))) -> + Csequence(c1, Cconst_int 0) + | (Cconst_int 0, c2) -> + Csequence(c2, Cconst_int 0) | (Cconst_int n1, Cconst_int n2) -> Cconst_int (n1 mod n2) | (c1, (Cconst_int n as c2)) when n <> min_int -> @@ -513,20 +516,38 @@ let addr_array_length hdr = Cop(Clsr, [hdr; Cconst_int wordsize_shift]) let float_array_length hdr = Cop(Clsr, [hdr; Cconst_int numfloat_shift]) let lsl_const c n = - Cop(Clsl, [c; Cconst_int n]) - -let array_indexing log2size ptr ofs = + if n = 0 then c + else Cop(Clsl, [c; Cconst_int n]) + +(* Produces a pointer to the element of the array [ptr] on the position [ofs] + with the given element [log2size] log2 element size. [ofs] is given as a + tagged int expression. + The optional ?typ argument is the C-- type of the result. + By default, it is Addr, meaning we are constructing a derived pointer + into the heap. If we know the pointer is outside the heap + (this is the case for bigarray indexing), we give type Int instead. *) + +let array_indexing ?typ log2size ptr ofs = + let add = + match typ with + | None | Some Addr -> Cadda + | Some Int -> Caddi + | _ -> assert false in match ofs with Cconst_int n -> let i = n asr 1 in - if i = 0 then ptr else Cop(Cadda, [ptr; Cconst_int(i lsl log2size)]) + if i = 0 then ptr else Cop(add, [ptr; Cconst_int(i lsl log2size)]) | Cop(Caddi, [Cop(Clsl, [c; Cconst_int 1]); Cconst_int 1]) -> - Cop(Cadda, [ptr; lsl_const c log2size]) + Cop(add, [ptr; lsl_const c log2size]) + | Cop(Caddi, [c; Cconst_int n]) when log2size = 0 -> + Cop(add, [Cop(add, [ptr; untag_int c]); Cconst_int (n asr 1)]) | Cop(Caddi, [c; Cconst_int n]) -> - Cop(Cadda, [Cop(Cadda, [ptr; lsl_const c (log2size - 1)]); + Cop(add, [Cop(add, [ptr; lsl_const c (log2size - 1)]); Cconst_int((n-1) lsl (log2size - 1))]) + | _ when log2size = 0 -> + Cop(add, [ptr; untag_int ofs]) | _ -> - Cop(Cadda, [Cop(Cadda, [ptr; lsl_const ofs (log2size - 1)]); + Cop(add, [Cop(add, [ptr; lsl_const ofs (log2size - 1)]); Cconst_int((-1) lsl (log2size - 1))]) let addr_array_ref arr ofs = @@ -776,23 +797,40 @@ let bigarray_elt_size = function | Pbigarray_complex32 -> 8 | Pbigarray_complex64 -> 16 +(* Produces a pointer to the element of the bigarray [b] on the position + [args]. [args] is given as a list of tagged int expressions, one per array + dimension. *) let bigarray_indexing unsafe elt_kind layout b args dbg = - let check_bound a1 a2 k = - if unsafe then k else Csequence(make_checkbound dbg [a1;a2], k) in + let check_ba_bound bound idx v = + Csequence(make_checkbound dbg [bound;idx], v) in + (* Validates the given multidimensional offset against the array bounds and + transforms it into a one dimensional offset. The offsets are expressions + evaluating to tagged int. *) let rec ba_indexing dim_ofs delta_ofs = function [] -> assert false | [arg] -> - bind "idx" (untag_int arg) - (fun idx -> - check_bound (Cop(Cload Word_int,[field_address b dim_ofs])) - idx idx) + if unsafe then arg + else + bind "idx" arg (fun idx -> + (* Load the untagged int bound for the given dimension *) + let bound = Cop(Cload Word_int,[field_address b dim_ofs]) in + let idxn = untag_int idx in + check_ba_bound bound idxn idx) | arg1 :: argl -> + (* The remainder of the list is transformed into a one dimensional offset + *) let rem = ba_indexing (dim_ofs + delta_ofs) delta_ofs argl in - bind "idx" (untag_int arg1) - (fun idx -> - bind "bound" (Cop(Cload Word_int, [field_address b dim_ofs])) - (fun bound -> - check_bound bound idx (add_int (mul_int rem bound) idx))) in + (* Load the untagged int bound for the given dimension *) + let bound = Cop(Cload Word_int, [field_address b dim_ofs]) in + if unsafe then add_int (mul_int (decr_int rem) bound) arg1 + else + bind "idx" arg1 (fun idx -> + bind "bound" bound (fun bound -> + let idxn = untag_int idx in + (* [offset = rem * (tag_int bound) + idx] *) + let offset = add_int (mul_int (decr_int rem) bound) idx in + check_ba_bound bound idxn offset)) in + (* The offset as an expression evaluating to int *) let offset = match layout with Pbigarray_unknown_layout -> @@ -803,12 +841,9 @@ let bigarray_indexing unsafe elt_kind layout b args dbg = ba_indexing 5 1 (List.map (fun idx -> sub_int idx (Cconst_int 2)) args) and elt_size = bigarray_elt_size elt_kind in - let byte_offset = - if elt_size = 1 - then offset - else Cop(Clsl, [offset; Cconst_int(log2 elt_size)]) in - Cop(Caddi, [Cop(Cload Word_int, [field_address b 1]); byte_offset]) - (* this produces a pointer outside the heap, hence Caddi instead of Cadda *) + (* [array_indexing] can simplify the given expressions *) + array_indexing ~typ:Int (log2 elt_size) + (Cop(Cload Word_int, [field_address b 1])) offset let bigarray_word_kind = function Pbigarray_unknown -> assert false @@ -1246,28 +1281,29 @@ let rec is_unboxed_number = function | Ulet (_, _, e) | Usequence (_, e) -> is_unboxed_number e | _ -> No_unboxing -let subst_boxed_number unbox_fn boxed_id unboxed_id box_chunk box_offset exp = - let need_boxed = ref false in - let assigned = ref false in +let subst_boxed_number box_fn unbox_fn boxed_id unboxed_id box_chunk box_offset exp = let rec subst = function Cvar id as e -> - if Ident.same id boxed_id then need_boxed := true; e + if Ident.same id boxed_id then + box_fn (Cvar unboxed_id) + else e | Clet(id, arg, body) -> Clet(id, subst arg, subst body) | Cassign(id, arg) -> if Ident.same id boxed_id then begin - assigned := true; Cassign(unboxed_id, subst(unbox_fn arg)) end else Cassign(id, subst arg) | Ctuple argv -> Ctuple(List.map subst argv) - | Cop(Cload chunk, [Cvar id]) as e -> - if Ident.same id boxed_id && chunk = box_chunk && box_offset = 0 - then Cvar unboxed_id - else e - | Cop(Cload chunk, [Cop(Cadda, [Cvar id; Cconst_int ofs])]) as e -> - if Ident.same id boxed_id && chunk = box_chunk && ofs = box_offset - then Cvar unboxed_id - else e + | Cop(Cload chunk, [Cvar id]) + when Ident.same id boxed_id && + chunk = box_chunk && box_offset = 0 + -> + Cvar unboxed_id + | Cop(Cload chunk, [Cop(Cadda, [Cvar id; Cconst_int ofs])]) + when Ident.same id boxed_id && + chunk = box_chunk && ofs = box_offset + -> + Cvar unboxed_id | Cop(op, argv) -> Cop(op, List.map subst argv) | Csequence(e1, e2) -> Csequence(subst e1, subst e2) | Cifthenelse(e1, e2, e3) -> Cifthenelse(subst e1, subst e2, subst e3) @@ -1277,9 +1313,11 @@ let subst_boxed_number unbox_fn boxed_id unboxed_id box_chunk box_offset exp = | Ccatch(nfail, ids, e1, e2) -> Ccatch(nfail, ids, subst e1, subst e2) | Cexit (nfail, el) -> Cexit (nfail, List.map subst el) | Ctrywith(e1, id, e2) -> Ctrywith(subst e1, id, subst e2) - | e -> e in - let res = subst exp in - (res, !need_boxed, !assigned) + | Cconst_int _ | Cconst_natint _ | Cconst_float _ | Cconst_symbol _ + | Cconst_pointer _ | Cconst_natpointer _ + | Cconst_blockheader _ as e -> e + in + subst exp (* Translate an expression *) @@ -1584,12 +1622,14 @@ and transl_prim_1 p arg dbg = match c with | Big_endian -> const_of_bool Arch.big_endian | Word_size -> tag_int (Cconst_int (8*Arch.size_int)) + | Int_size -> tag_int (Cconst_int ((8*Arch.size_int) - 1)) + | Max_wosize -> tag_int (Cconst_int ((1 lsl ((8*Arch.size_int) - 10)) - 1 )) | Ostype_unix -> const_of_bool (Sys.os_type = "Unix") | Ostype_win32 -> const_of_bool (Sys.os_type = "Win32") | Ostype_cygwin -> const_of_bool (Sys.os_type = "Cygwin") end | Poffsetint n -> - if no_overflow_lsl n then + if no_overflow_lsl n 1 then add_const (transl arg) (n lsl 1) else transl_prim_2 Paddint arg (Uconst (Uconst_int n)) @@ -1691,7 +1731,17 @@ and transl_prim_2 p arg1 arg2 dbg = | Psubint -> incr_int(sub_int (transl arg1) (transl arg2)) | Pmulint -> - incr_int(mul_int (decr_int(transl arg1)) (untag_int(transl arg2))) + begin + (* decrementing the non-constant part helps when the multiplication is followed by an addition; + for example, using this trick compiles (100 * a + 7) into + (+ ( * a 100) -85) + rather than + (+ ( * 200 (>>s a 1)) 15) + *) + match transl arg1, transl arg2 with + | Cconst_int _ as c1, c2 -> incr_int (mul_int (untag_int c1) (decr_int c2)) + | c1, c2 -> incr_int (mul_int (decr_int c1) (untag_int c2)) + end | Pdivint -> tag_int(div_int (untag_int(transl arg1)) (untag_int(transl arg2)) dbg) | Pmodint -> @@ -1964,7 +2014,7 @@ and transl_prim_3 p arg1 arg2 arg3 dbg = Csequence(make_checkbound dbg [addr_array_length(header arr); idx], int_array_set arr idx newval)))) | Pfloatarray -> - bind "newval" (transl_unbox_float arg3) (fun newval -> + bind_load "newval" (transl_unbox_float arg3) (fun newval -> bind "index" (transl arg2) (fun idx -> bind "arr" (transl arg1) (fun arr -> Csequence(make_checkbound dbg [float_array_length(header arr);idx], @@ -2047,15 +2097,9 @@ 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 - let (trbody2, need_boxed, is_assigned) = - subst_boxed_number unbox_fn id unboxed_id box_chunk box_offset trbody1 in - if need_boxed && is_assigned then - Clet(id, transl exp, trbody1) - else - Clet(unboxed_id, transl_unbox_fn exp, - if need_boxed - then Clet(id, box_fn(Cvar unboxed_id), trbody2) - else trbody2) + let trbody2 = + subst_boxed_number box_fn unbox_fn id unboxed_id box_chunk box_offset trbody1 in + Clet(unboxed_id, transl_unbox_fn exp, trbody2) and make_catch ncatch body handler = match body with | Cexit (nexit,[]) when nexit=ncatch -> handler diff --git a/asmcomp/emitaux.ml b/asmcomp/emitaux.ml index 24a621b339..1e5ed0b5f3 100644 --- a/asmcomp/emitaux.ml +++ b/asmcomp/emitaux.ml @@ -195,6 +195,15 @@ let cfi_adjust_cfa_offset n = emit_string "\t.cfi_adjust_cfa_offset\t"; emit_int n; emit_string "\n"; end +let cfi_offset ~reg ~offset = + if is_cfi_enabled () then begin + emit_string "\t.cfi_offset "; + emit_int reg; + emit_string ", "; + emit_int offset; + emit_string "\n" + end + (* Emit debug information *) (* This assoc list is expected to be very short *) @@ -211,7 +220,7 @@ let reset_debug_info () = (* We only diplay .file if the file has not been seen before. We display .loc for every instruction. *) -let emit_debug_info dbg = +let emit_debug_info_gen dbg file_emitter loc_emitter = if is_cfi_enabled () && (!Clflags.debug || Config.with_frame_pointers) && dbg.Debuginfo.dinfo_line > 0 (* PR#6243 *) @@ -223,16 +232,27 @@ let emit_debug_info dbg = with Not_found -> let file_num = !file_pos_num_cnt in incr file_pos_num_cnt; - emit_string "\t.file\t"; - emit_int file_num; emit_char '\t'; - emit_string_literal file_name; emit_char '\n'; + file_emitter file_num file_name; file_pos_nums := (file_name,file_num) :: !file_pos_nums; file_num in - emit_string "\t.loc\t"; - emit_int file_num; emit_char '\t'; - emit_int line; emit_char '\n' + loc_emitter file_num line; end +let emit_debug_info dbg = + emit_debug_info_gen dbg (fun file_num file_name -> + emit_string "\t.file\t"; + emit_int file_num; emit_char '\t'; + emit_string_literal file_name; emit_char '\n'; + ) + (fun file_num line -> + emit_string "\t.loc\t"; + emit_int file_num; emit_char '\t'; + emit_int line; emit_char '\n') + let reset () = reset_debug_info (); frame_descriptors := [] + +let binary_backend_available = ref false +let create_asm_file = ref true + diff --git a/asmcomp/emitaux.mli b/asmcomp/emitaux.mli index 486a5839ce..290967c5d4 100644 --- a/asmcomp/emitaux.mli +++ b/asmcomp/emitaux.mli @@ -30,6 +30,10 @@ val emit_float32_directive: string -> int32 -> unit val reset : unit -> unit val reset_debug_info: unit -> unit val emit_debug_info: Debuginfo.t -> unit +val emit_debug_info_gen : + Debuginfo.t -> + (int -> string -> unit) -> + (int -> int -> unit) -> unit type frame_descr = { fd_lbl: int; (* Return address *) @@ -56,3 +60,13 @@ val is_generic_function: string -> bool val cfi_startproc : unit -> unit val cfi_endproc : unit -> unit val cfi_adjust_cfa_offset : int -> unit +val cfi_offset : reg:int -> offset:int -> unit + + +val binary_backend_available: bool ref + (** Is a binary backend available. If yes, we don't need + to generate the textual assembly file (unless the user + request it with -S). *) + +val create_asm_file: bool ref + (** Are we actually generating the textual assembly file? *) diff --git a/asmcomp/i386/emit.mlp b/asmcomp/i386/emit.mlp index 82608c2215..e13e22f682 100644 --- a/asmcomp/i386/emit.mlp +++ b/asmcomp/i386/emit.mlp @@ -1,3 +1,4 @@ +#2 "asmcomp/i386/emit.mlp" (***********************************************************************) (* *) (* OCaml *) @@ -12,9 +13,6 @@ (* Emission of Intel 386 assembly code *) -module StringSet = - Set.Make(struct type t = string let compare (x:t) y = compare x y end) - open Misc open Cmm open Arch @@ -24,6 +22,29 @@ open Mach open Linearize open Emitaux +open X86_ast +open X86_proc +open X86_dsl + +let _label s = D.label ~typ:DWORD s + +let mem_sym typ ?(ofs = 0) sym = + mem32 typ ~scale:0 ?base:None ~sym ofs RAX (*ignored since scale=0*) + +(* CFI directives *) + +let cfi_startproc () = + if Config.asm_cfi_supported then D.cfi_startproc () + +let cfi_endproc () = + if Config.asm_cfi_supported then D.cfi_endproc () + +let cfi_adjust_cfa_offset n = + if Config.asm_cfi_supported then D.cfi_adjust_cfa_offset n + +let emit_debug_info dbg = + emit_debug_info_gen dbg D.file D.loc + (* Tradeoff between code size and code speed *) let fastcode_flag = ref true @@ -39,7 +60,7 @@ let frame_size () = (* includes return address *) let slot_offset loc cl = match loc with - Incoming n -> + | Incoming n -> assert (n >= 0); frame_size() + n | Local n -> @@ -50,129 +71,122 @@ let slot_offset loc cl = assert (n >= 0); n +(* Record symbols used and defined - at the end generate extern for those + used but not defined *) + +let symbols_defined = ref StringSet.empty +let symbols_used = ref StringSet.empty + +let add_def_symbol s = symbols_defined := StringSet.add s !symbols_defined +let add_used_symbol s = symbols_used := StringSet.add s !symbols_used + let trap_frame_size = Misc.align 8 stack_alignment (* Prefixing of symbols with "_" *) let symbol_prefix = - match Config.system with - "linux_elf" -> "" - | "bsd_elf" -> "" - | "solaris" -> "" - | "beos" -> "" - | "gnu" -> "" - | _ -> "_" + match system with + | S_linux_elf -> "" + | S_bsd_elf -> "" + | S_solaris -> "" + | S_beos -> "" + | S_gnu -> "" + | _ -> "_" (* win32 & others *) -let emit_symbol s = - emit_string symbol_prefix; Emitaux.emit_symbol '$' s +let emit_symbol s = string_of_symbol symbol_prefix s + +let immsym s = sym (emit_symbol s) + +let emit_call s = I.call (immsym s) (* Output a label *) let label_prefix = - match Config.system with - "linux_elf" -> ".L" - | "bsd_elf" -> ".L" - | "solaris" -> ".L" - | "beos" -> ".L" - | "gnu" -> ".L" + match system with + | S_linux_elf -> ".L" + | S_bsd_elf -> ".L" + | S_solaris -> ".L" + | S_beos -> ".L" + | S_gnu -> ".L" | _ -> "L" let emit_label lbl = - emit_string label_prefix; emit_int lbl + Printf.sprintf "%s%d" label_prefix lbl let emit_data_label lbl = - emit_string label_prefix; emit_string "d"; emit_int lbl - - -(* Some data directives have different names under Solaris *) - -let word_dir = - match Config.system with - "solaris" -> ".value" - | _ -> ".word" -let skip_dir = - match Config.system with - "solaris" -> ".zero" - | _ -> ".space" -let use_ascii_dir = - match Config.system with - "solaris" -> false - | _ -> true - -(* MacOSX has its own way to reference symbols potentially defined in - shared objects *) - -let macosx = - match Config.system with - | "macosx" -> true - | _ -> false - -(* Output a .align directive. - The numerical argument to .align is log2 of alignment size, except - under ELF, where it is the alignment size... *) - -let emit_align = - match Config.system with - "linux_elf" | "bsd_elf" | "solaris" | "beos" | "cygwin" | "mingw" | "gnu" -> - (fun n -> ` .align {emit_int n}\n`) - | _ -> - (fun n -> ` .align {emit_int(Misc.log2 n)}\n`) + Printf.sprintf "%sd%d" label_prefix lbl + +let label s = sym (emit_label s) + +let def_label s = D.label (emit_label s) let emit_Llabel fallthrough lbl = - if not fallthrough && !fastcode_flag then - emit_align 16 ; - emit_label lbl + if not fallthrough && !fastcode_flag then D.align 16 ; + def_label lbl (* Output a pseudo-register *) -let emit_reg = function - { loc = Reg r } -> - emit_string (register_name r) +let int_reg_name = [| RAX; RBX; RCX; RDX; RSI; RDI; RBP |] + +let float_reg_name = [| TOS |] + +let register_name r = + if r < 100 then Reg32 (int_reg_name.(r)) + else Regf (float_reg_name.(r - 100)) + +let sym32 ?ofs s = mem_sym ?ofs DWORD (emit_symbol s) + +let reg = function + | { loc = Reg r } -> register_name r | { loc = Stack(Incoming n | Outgoing n) } when n < 0 -> - `{emit_symbol "caml_extra_params"} + {emit_int (n + 64)}` + sym32 "caml_extra_params" ~ofs:(n + 64) + | { loc = Stack s; typ = Float } as r -> + let ofs = slot_offset s (register_class r) in + mem32 REAL8 ofs RSP | { loc = Stack s } as r -> let ofs = slot_offset s (register_class r) in - `{emit_int ofs}(%esp)` + mem32 DWORD ofs RSP | { loc = Unknown } -> - fatal_error "Emit_i386.emit_reg" + fatal_error "Emit_i386.reg" (* Output a reference to the lower 8 bits or lower 16 bits of a register *) -let reg_low_byte_name = [| "%al"; "%bl"; "%cl"; "%dl" |] -let reg_low_half_name = [| "%ax"; "%bx"; "%cx"; "%dx"; "%si"; "%di"; "%bp" |] +let reg_low_8_name = Array.map (fun r -> Reg8L r) int_reg_name +let reg_low_16_name = Array.map (fun r -> Reg16 r) int_reg_name -let emit_reg8 r = +let reg8 r = match r.loc with - Reg r when r < 4 -> emit_string (reg_low_byte_name.(r)) - | _ -> fatal_error "Emit_i386.emit_reg8" + | Reg r when r < 4 -> reg_low_8_name.(r) + | _ -> fatal_error "Emit_i386.reg8" -let emit_reg16 r = +let reg16 r = match r.loc with - Reg r when r < 7 -> emit_string (reg_low_half_name.(r)) - | _ -> fatal_error "Emit_i386.emit_reg16" + | Reg r when r < 7 -> reg_low_16_name.(r) + | _ -> fatal_error "Emit_i386.reg16" + +let reg32 = function + | { loc = Reg.Reg r } -> int_reg_name.(r) + | _ -> assert false + +let arg32 i n = reg32 i.arg.(n) (* Output an addressing mode *) -let emit_addressing addr r n = +let addressing addr typ i n = match addr with - Ibased(s, d) -> - `{emit_symbol s}`; - if d <> 0 then ` + {emit_int d}` + | Ibased(s, ofs) -> + add_used_symbol s; + mem_sym typ (emit_symbol s) ~ofs | Iindexed d -> - if d <> 0 then emit_int d; - `({emit_reg r.(n)})` + mem32 typ d (arg32 i n) | Iindexed2 d -> - if d <> 0 then emit_int d; - `({emit_reg r.(n)}, {emit_reg r.(n+1)})` + mem32 typ ~base:(arg32 i n) d (arg32 i (n+1)) | Iscaled(2, d) -> - if d <> 0 then emit_int d; - `({emit_reg r.(n)}, {emit_reg r.(n)})` + mem32 typ ~base:(arg32 i n) d (arg32 i n) | Iscaled(scale, d) -> - if d <> 0 then emit_int d; - `(, {emit_reg r.(n)}, {emit_int scale})` + mem32 typ ~scale d (arg32 i n) | Iindexed2scaled(scale, d) -> - if d <> 0 then emit_int d; - `({emit_reg r.(n)}, {emit_reg r.(n+1)}, {emit_int scale})` + mem32 typ ~scale ~base:(arg32 i n) d (arg32 i (n+1)) (* Record live pointers at call points *) @@ -181,7 +195,7 @@ let record_frame_label live dbg = let live_offset = ref [] in Reg.Set.iter (function - {typ = Val; loc = Reg r} -> + | {typ = Val; loc = Reg r} -> live_offset := ((r lsl 1) + 1) :: !live_offset | {typ = Val; loc = Stack s} as reg -> live_offset := slot_offset s (register_class reg) :: !live_offset @@ -197,7 +211,8 @@ let record_frame_label live dbg = lbl let record_frame live dbg = - let lbl = record_frame_label live dbg in `{emit_label lbl}:\n` + let lbl = record_frame_label live dbg in + def_label lbl (* Record calls to the GC -- we've moved them out of the way *) @@ -209,8 +224,10 @@ type gc_call = let call_gc_sites = ref ([] : gc_call list) let emit_call_gc gc = - `{emit_label gc.gc_lbl}: call {emit_symbol "caml_call_gc"}\n`; - `{emit_label gc.gc_frame}: jmp {emit_label gc.gc_return_lbl}\n` + def_label gc.gc_lbl; + emit_call "caml_call_gc"; + def_label gc.gc_frame; + I.jmp (label gc.gc_return_lbl) (* Record calls to caml_ml_array_bound_error. In -g mode, we maintain one call to caml_ml_array_bound_error @@ -228,100 +245,107 @@ let bound_error_label dbg = let lbl_bound_error = new_label() in let lbl_frame = record_frame_label Reg.Set.empty dbg in bound_error_sites := - { bd_lbl = lbl_bound_error; bd_frame = lbl_frame } :: !bound_error_sites; - lbl_bound_error - end else begin - if !bound_error_call = 0 then bound_error_call := new_label(); - !bound_error_call - end + { bd_lbl = lbl_bound_error; bd_frame = lbl_frame } :: !bound_error_sites; + lbl_bound_error + end else begin + if !bound_error_call = 0 then bound_error_call := new_label(); + !bound_error_call + end let emit_call_bound_error bd = - `{emit_label bd.bd_lbl}: call {emit_symbol "caml_ml_array_bound_error"}\n`; - `{emit_label bd.bd_frame}:\n` + def_label bd.bd_lbl; + emit_call "caml_ml_array_bound_error"; + def_label bd.bd_frame let emit_call_bound_errors () = List.iter emit_call_bound_error !bound_error_sites; - if !bound_error_call > 0 then - `{emit_label !bound_error_call}: call {emit_symbol "caml_ml_array_bound_error"}\n` + if !bound_error_call > 0 then begin + def_label !bound_error_call; + emit_call "caml_ml_array_bound_error" + end (* Names for instructions *) let instr_for_intop = function - Iadd -> "addl" - | Isub -> "subl" - | Imul -> "imull" - | Iand -> "andl" - | Ior -> "orl" - | Ixor -> "xorl" - | Ilsl -> "sall" - | Ilsr -> "shrl" - | Iasr -> "sarl" + | Iadd -> I.add + | Isub -> I.sub + | Imul -> (fun arg1 arg2 -> I.imul arg1 (Some arg2)) + | Iand -> I.and_ + | Ior -> I.or_ + | Ixor -> I.xor + | Ilsl -> I.sal + | Ilsr -> I.shr + | Iasr -> I.sar | _ -> fatal_error "Emit_i386: instr_for_intop" +let unary_instr_for_floatop = function + | Inegf -> I.fchs () + | Iabsf -> I.fabs () + | _ -> fatal_error "Emit_i386: unary_instr_for_floatop" + let instr_for_floatop = function - Inegf -> "fchs" - | Iabsf -> "fabs" - | Iaddf -> "faddl" - | Isubf -> "fsubl" - | Imulf -> "fmull" - | Idivf -> "fdivl" - | Ispecific Isubfrev -> "fsubrl" - | Ispecific Idivfrev -> "fdivrl" + | Iaddf -> I.fadd + | Isubf -> I.fsub + | Imulf -> I.fmul + | Idivf -> I.fdiv + | Ispecific Isubfrev -> I.fsubr + | Ispecific Idivfrev -> I.fdivr | _ -> fatal_error "Emit_i386: instr_for_floatop" let instr_for_floatop_reversed = function - Iaddf -> "faddl" - | Isubf -> "fsubrl" - | Imulf -> "fmull" - | Idivf -> "fdivrl" - | Ispecific Isubfrev -> "fsubl" - | Ispecific Idivfrev -> "fdivl" + | Iaddf -> I.fadd + | Isubf -> I.fsubr + | Imulf -> I.fmul + | Idivf -> I.fdivr + | Ispecific Isubfrev -> I.fsub + | Ispecific Idivfrev -> I.fdiv | _ -> fatal_error "Emit_i386: instr_for_floatop_reversed" -let instr_for_floatop_pop = function - Iaddf -> "faddp" - | Isubf -> "fsubp" - | Imulf -> "fmulp" - | Idivf -> "fdivp" - | Ispecific Isubfrev -> "fsubrp" - | Ispecific Idivfrev -> "fdivrp" - | _ -> fatal_error "Emit_i386: instr_for_floatop_pop" - -let instr_for_floatarithmem double = function - Ifloatadd -> if double then "faddl" else "fadds" - | Ifloatsub -> if double then "fsubl" else "fsubs" - | Ifloatsubrev -> if double then "fsubrl" else "fsubrs" - | Ifloatmul -> if double then "fmull" else "fmuls" - | Ifloatdiv -> if double then "fdivl" else "fdivs" - | Ifloatdivrev -> if double then "fdivrl" else "fdivrs" - -let name_for_cond_branch = function - Isigned Ceq -> "e" | Isigned Cne -> "ne" - | Isigned Cle -> "le" | Isigned Cgt -> "g" - | Isigned Clt -> "l" | Isigned Cge -> "ge" - | Iunsigned Ceq -> "e" | Iunsigned Cne -> "ne" - | Iunsigned Cle -> "be" | Iunsigned Cgt -> "a" - | Iunsigned Clt -> "b" | Iunsigned Cge -> "ae" + +let instr_for_floatop_reversed_pop = function + | Iaddf -> I.faddp + | Isubf -> I.fsubrp + | Imulf -> I.fmulp + | Idivf -> I.fdivrp + | Ispecific Isubfrev -> I.fsubp + | Ispecific Idivfrev -> I.fdivp + | _ -> fatal_error "Emit_i386: instr_for_floatop_reversed_pop" + +let instr_for_floatarithmem = function + | Ifloatadd -> I.fadd + | Ifloatsub -> I.fsub + | Ifloatsubrev -> I.fsubr + | Ifloatmul -> I.fmul + | Ifloatdiv -> I.fdiv + | Ifloatdivrev -> I.fdivr + +let cond = function + | Isigned Ceq -> E | Isigned Cne -> NE + | Isigned Cle -> LE | Isigned Cgt -> G + | Isigned Clt -> L | Isigned Cge -> GE + | Iunsigned Ceq -> E | Iunsigned Cne -> NE + | Iunsigned Cle -> BE | Iunsigned Cgt -> A + | Iunsigned Clt -> B | Iunsigned Cge -> AE (* Output an = 0 or <> 0 test. *) let output_test_zero arg = match arg.loc with - Reg r -> ` testl {emit_reg arg}, {emit_reg arg}\n` - | _ -> ` cmpl $0, {emit_reg arg}\n` + | Reg.Reg _ -> I.test (reg arg) (reg arg) + | _ -> I.cmp (int 0) (reg arg) (* Deallocate the stack frame before a return or tail call *) let output_epilogue f = let n = frame_size() - 4 in if n > 0 then - begin - ` addl ${emit_int n}, %esp\n`; - cfi_adjust_cfa_offset (-n); - f (); - (* reset CFA back cause function body may continue *) - cfi_adjust_cfa_offset n - end + begin + I.add (int n) esp; + cfi_adjust_cfa_offset (-n); + f (); + (* reset CFA back cause function body may continue *) + cfi_adjust_cfa_offset n + end else f () @@ -334,82 +358,80 @@ let is_tos = function { loc = Reg _; typ = Float } -> true | _ -> false let emit_float_test cmp neg arg lbl = let actual_cmp = match (is_tos arg.(0), is_tos arg.(1)) with - (true, true) -> - (* both args on top of FP stack *) - ` fcompp\n`; - cmp + | (true, true) -> + (* both args on top of FP stack *) + I.fcompp (); + cmp | (true, false) -> - (* first arg on top of FP stack *) - ` fcompl {emit_reg arg.(1)}\n`; - cmp + (* first arg on top of FP stack *) + I.fcomp (reg arg.(1)); + cmp | (false, true) -> - (* second arg on top of FP stack *) - ` fcompl {emit_reg arg.(0)}\n`; - Cmm.swap_comparison cmp + (* second arg on top of FP stack *) + I.fcomp (reg arg.(0)); + Cmm.swap_comparison cmp | (false, false) -> - ` fldl {emit_reg arg.(0)}\n`; - ` fcompl {emit_reg arg.(1)}\n`; - cmp - in - ` fnstsw %ax\n`; - begin match actual_cmp with - Ceq -> + I.fld (reg arg.(0)); + I.fcomp (reg arg.(1)); + cmp + in + I.fnstsw ax; + match actual_cmp with + | Ceq -> if neg then begin - ` andb $68, %ah\n`; - ` xorb $64, %ah\n`; - ` jne ` + I.and_ (int 68) ah; + I.xor (int 64) ah; + I.jne lbl end else begin - ` andb $69, %ah\n`; - ` cmpb $64, %ah\n`; - ` je ` + I.and_ (int 69) ah; + I.cmp (int 64) ah; + I.je lbl end | Cne -> if neg then begin - ` andb $69, %ah\n`; - ` cmpb $64, %ah\n`; - ` je ` + I.and_ (int 69) ah; + I.cmp (int 64) ah; + I.je lbl end else begin - ` andb $68, %ah\n`; - ` xorb $64, %ah\n`; - ` jne ` + I.and_ (int 68) ah; + I.xor (int 64) ah; + I.jne lbl end | Cle -> - ` andb $69, %ah\n`; - ` decb %ah\n`; - ` cmpb $64, %ah\n`; + I.and_ (int 69) ah; + I.dec ah; + I.cmp (int 64) ah; if neg - then ` jae ` - else ` jb ` + then I.jae lbl + else I.jb lbl | Cge -> - ` andb $5, %ah\n`; + I.and_ (int 5) ah; if neg - then ` jne ` - else ` je ` + then I.jne lbl + else I.je lbl | Clt -> - ` andb $69, %ah\n`; - ` cmpb $1, %ah\n`; + I.and_ (int 69) ah; + I.cmp (int 1) ah; if neg - then ` jne ` - else ` je ` + then I.jne lbl + else I.je lbl | Cgt -> - ` andb $69, %ah\n`; + I.and_ (int 69) ah; if neg - then ` jne ` - else ` je ` - end; - `{emit_label lbl}\n` + then I.jne lbl + else I.je lbl (* Emit a Ifloatspecial instruction *) let emit_floatspecial = function - "atan" -> ` fld1; fpatan\n` - | "atan2" -> ` fpatan\n` - | "cos" -> ` fcos\n` - | "log" -> ` fldln2; fxch; fyl2x\n` - | "log10" -> ` fldlg2; fxch; fyl2x\n` - | "sin" -> ` fsin\n` - | "sqrt" -> ` fsqrt\n` - | "tan" -> ` fptan; fstp %st(0)\n` + | "atan" -> I.fld1 (); I.fpatan () + | "atan2" -> I.fpatan () + | "cos" -> I.fcos () + | "log" -> I.fldln2 (); I.fxch st1; I.fyl2x () + | "log10" -> I.fldlg2 (); I.fxch st1; I.fyl2x () + | "sin" -> I.fsin () + | "sqrt" -> I.fsqrt () + | "tan" -> I.fptan (); I.fstp st0 | _ -> assert false (* Floating-point constants *) @@ -426,9 +448,22 @@ let add_float_constant cst = float_constants := (repr, lbl) :: !float_constants; lbl -let emit_float_constant (cst, lbl) = - `{emit_label lbl}:`; - emit_float64_split_directive ".long" cst +let emit_float64_split_directive x = + let lo = Int64.logand x 0xFFFF_FFFFL + and hi = Int64.shift_right_logical x 32 in + D.long (Const (if Arch.big_endian then hi else lo)); + D.long (Const (if Arch.big_endian then lo else hi)) + +let emit_float_constant cst lbl = + _label (emit_label lbl); + emit_float64_split_directive cst + +let emit_global_label s = + let lbl = Compilenv.make_symbol (Some s) in + add_def_symbol lbl; + let lbl = emit_symbol lbl in + D.global lbl; + _label lbl (* Output the assembly code for an instruction *) @@ -436,406 +471,412 @@ let emit_float_constant (cst, lbl) = let function_name = ref "" (* Entry point for tail recursive calls *) let tailrec_entry_point = ref 0 -(* Label of trap for out-of-range accesses *) -let range_check_trap = ref 0 (* Record references to external C functions (for MacOSX) *) let external_symbols_direct = ref StringSet.empty let external_symbols_indirect = ref StringSet.empty let emit_instr fallthrough i = - emit_debug_info i.dbg; - match i.desc with - Lend -> () - | Lop(Imove | Ispill | Ireload) -> - let src = i.arg.(0) and dst = i.res.(0) in - if src.loc <> dst.loc then begin - if src.typ = Float then - if is_tos src then - ` fstpl {emit_reg dst}\n` - else if is_tos dst then - ` fldl {emit_reg src}\n` - else begin - ` fldl {emit_reg src}\n`; - ` fstpl {emit_reg dst}\n` - end - else - ` movl {emit_reg src}, {emit_reg dst}\n` - end - | Lop(Iconst_int n | Iconst_blockheader n) -> - if n = 0n then begin - match i.res.(0).loc with - Reg n -> ` xorl {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` - | _ -> ` movl $0, {emit_reg i.res.(0)}\n` - end else - ` movl ${emit_nativeint n}, {emit_reg i.res.(0)}\n` - | 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 *) - ` fldz\n fchs\n` - | 0x3FF0_0000_0000_0000L -> (* 1.0 *) - ` fld1\n` - | 0xBFF0_0000_0000_0000L -> (* -1.0 *) - ` fld1\n fchs\n` - | _ -> + emit_debug_info i.dbg; + match i.desc with + | Lend -> () + | Lop(Imove | Ispill | Ireload) -> + let src = i.arg.(0) and dst = i.res.(0) in + if src.loc <> dst.loc then begin + if src.typ = Float then + if is_tos src then + I.fstp (reg dst) + else if is_tos dst then + I.fld (reg src) + else begin + I.fld (reg src); + I.fstp (reg dst) + end + else + I.mov (reg src) (reg dst) + end + | Lop(Iconst_int n | Iconst_blockheader n) -> + if n = 0n then begin + match i.res.(0).loc with + | Reg _ -> I.xor (reg i.res.(0)) (reg i.res.(0)) + | _ -> I.mov (int 0) (reg i.res.(0)) + end else + I.mov (nat n) (reg i.res.(0)) + | Lop(Iconst_float f) -> + begin match Int64.bits_of_float f with + | 0x0000_0000_0000_0000L -> (* +0.0 *) + I.fldz () + | 0x8000_0000_0000_0000L -> (* -0.0 *) + I.fldz (); I.fchs () + | 0x3FF0_0000_0000_0000L -> (* 1.0 *) + I.fld1 () + | 0xBFF0_0000_0000_0000L -> (* -1.0 *) + I.fld1 (); I.fchs () + | _ -> let lbl = add_float_constant f in - ` fldl {emit_label lbl}\n` - end - | Lop(Iconst_symbol s) -> - ` movl ${emit_symbol s}, {emit_reg i.res.(0)}\n` - | Lop(Icall_ind) -> - ` call *{emit_reg i.arg.(0)}\n`; - record_frame i.live i.dbg - | Lop(Icall_imm s) -> - ` call {emit_symbol s}\n`; - record_frame i.live i.dbg - | Lop(Itailcall_ind) -> + I.fld (mem_sym REAL8 (emit_label lbl)) + end + | Lop(Iconst_symbol s) -> + add_used_symbol s; + I.mov (immsym s) (reg i.res.(0)) + | Lop(Icall_ind) -> + I.call (reg i.arg.(0)); + record_frame i.live i.dbg + | Lop(Icall_imm s) -> + add_used_symbol s; + emit_call s; + record_frame i.live i.dbg + | Lop(Itailcall_ind) -> + output_epilogue begin fun () -> + I.jmp (reg i.arg.(0)) + end + | Lop(Itailcall_imm s) -> + if s = !function_name then + I.jmp (label !tailrec_entry_point) + else begin output_epilogue begin fun () -> - ` jmp *{emit_reg i.arg.(0)}\n` + add_used_symbol s; + I.jmp (immsym s) end - | Lop(Itailcall_imm s) -> - if s = !function_name then - ` jmp {emit_label !tailrec_entry_point}\n` + end + | Lop(Iextcall(s, alloc)) -> + add_used_symbol s; + if alloc then begin + if system <> S_macosx then + I.mov (immsym s) eax else begin - output_epilogue begin fun () -> - ` jmp {emit_symbol s}\n` - end + external_symbols_indirect := + StringSet.add s !external_symbols_indirect; + I.mov (mem_sym DWORD (Printf.sprintf "L%s$non_lazy_ptr" + (emit_symbol s))) eax + end; + emit_call "caml_c_call"; + record_frame i.live i.dbg + end else begin + if system <> S_macosx then + emit_call s + else begin + external_symbols_direct := + StringSet.add s !external_symbols_direct; + I.call (sym (Printf.sprintf "L%s$stub" (emit_symbol s))) end - | Lop(Iextcall(s, alloc)) -> - if alloc then begin - if not macosx then - ` movl ${emit_symbol s}, %eax\n` + end + | Lop(Istackoffset n) -> + if n < 0 + then I.add (int (-n)) esp + else I.sub (int n) esp; + cfi_adjust_cfa_offset n; + stack_offset := !stack_offset + n + | Lop(Iload(chunk, addr)) -> + let dest = i.res.(0) in + begin match chunk with + | Word_int | Word_val | Thirtytwo_signed | Thirtytwo_unsigned -> + I.mov (addressing addr DWORD i 0) (reg dest) + | Byte_unsigned -> + I.movzx (addressing addr BYTE i 0) (reg dest) + | Byte_signed -> + I.movsx (addressing addr BYTE i 0) (reg dest) + | Sixteen_unsigned -> + I.movzx (addressing addr WORD i 0) (reg dest) + | Sixteen_signed -> + I.movsx (addressing addr WORD i 0) (reg dest) + | Single -> + I.fld (addressing addr REAL4 i 0) + | Double | Double_u -> + I.fld (addressing addr REAL8 i 0) + end + | Lop(Istore(chunk, addr, _)) -> + begin match chunk with + | Word_int | Word_val | Thirtytwo_signed | Thirtytwo_unsigned -> + I.mov (reg i.arg.(0)) (addressing addr DWORD i 1) + | Byte_unsigned | Byte_signed -> + I.mov (reg8 i.arg.(0)) (addressing addr BYTE i 1) + | Sixteen_unsigned | Sixteen_signed -> + I.mov (reg16 i.arg.(0)) (addressing addr WORD i 1) + | Single -> + if is_tos i.arg.(0) then + I.fstp (addressing addr REAL4 i 1) else begin - external_symbols_indirect := - StringSet.add s !external_symbols_indirect; - ` movl L{emit_symbol s}$non_lazy_ptr, %eax\n` - end; - ` call {emit_symbol "caml_c_call"}\n`; - record_frame i.live i.dbg - end else begin - if not macosx then - ` call {emit_symbol s}\n` + I.fld (reg i.arg.(0)); + I.fstp (addressing addr REAL4 i 1) + end + | Double | Double_u -> + if is_tos i.arg.(0) then + I.fstp (addressing addr REAL8 i 1) else begin - external_symbols_direct := - StringSet.add s !external_symbols_direct; - ` call L{emit_symbol s}$stub\n` + I.fld (reg i.arg.(0)); + I.fstp (addressing addr REAL8 i 1) end - end - | Lop(Istackoffset n) -> - if n < 0 - then ` addl ${emit_int(-n)}, %esp\n` - else ` subl ${emit_int(n)}, %esp\n`; - cfi_adjust_cfa_offset n; - stack_offset := !stack_offset + n - | Lop(Iload(chunk, addr)) -> - let dest = i.res.(0) in - begin match chunk with - | Word_int | Word_val | Thirtytwo_signed | Thirtytwo_unsigned -> - ` movl {emit_addressing addr i.arg 0}, {emit_reg dest}\n` - | Byte_unsigned -> - ` movzbl {emit_addressing addr i.arg 0}, {emit_reg dest}\n` - | Byte_signed -> - ` movsbl {emit_addressing addr i.arg 0}, {emit_reg dest}\n` - | Sixteen_unsigned -> - ` movzwl {emit_addressing addr i.arg 0}, {emit_reg dest}\n` - | Sixteen_signed -> - ` movswl {emit_addressing addr i.arg 0}, {emit_reg dest}\n` - | Single -> - ` flds {emit_addressing addr i.arg 0}\n` - | Double | Double_u -> - ` fldl {emit_addressing addr i.arg 0}\n` - end - | Lop(Istore(chunk, addr, _)) -> - begin match chunk with - | Word_int | Word_val | Thirtytwo_signed | Thirtytwo_unsigned -> - ` movl {emit_reg i.arg.(0)}, {emit_addressing addr i.arg 1}\n` - | Byte_unsigned | Byte_signed -> - ` movb {emit_reg8 i.arg.(0)}, {emit_addressing addr i.arg 1}\n` - | Sixteen_unsigned | Sixteen_signed -> - ` movw {emit_reg16 i.arg.(0)}, {emit_addressing addr i.arg 1}\n` - | Single -> - if is_tos i.arg.(0) then - ` fstps {emit_addressing addr i.arg 1}\n` - else begin - ` fldl {emit_reg i.arg.(0)}\n`; - ` fstps {emit_addressing addr i.arg 1}\n` - end - | Double | Double_u -> - if is_tos i.arg.(0) then - ` fstpl {emit_addressing addr i.arg 1}\n` - else begin - ` fldl {emit_reg i.arg.(0)}\n`; - ` fstpl {emit_addressing addr i.arg 1}\n` - end - end - | Lop(Ialloc n) -> - if !fastcode_flag then begin - let lbl_redo = new_label() in - `{emit_label lbl_redo}: movl {emit_symbol "caml_young_ptr"}, %eax\n`; - ` subl ${emit_int n}, %eax\n`; - ` movl %eax, {emit_symbol "caml_young_ptr"}\n`; - ` cmpl {emit_symbol "caml_young_limit"}, %eax\n`; - let lbl_call_gc = new_label() in - let lbl_frame = record_frame_label i.live Debuginfo.none in - ` jb {emit_label lbl_call_gc}\n`; - ` leal 4(%eax), {emit_reg i.res.(0)}\n`; - call_gc_sites := - { gc_lbl = lbl_call_gc; - gc_return_lbl = lbl_redo; - gc_frame = lbl_frame } :: !call_gc_sites - end else begin - begin match n with - 8 -> ` call {emit_symbol "caml_alloc1"}\n` - | 12 -> ` call {emit_symbol "caml_alloc2"}\n` - | 16 -> ` call {emit_symbol "caml_alloc3"}\n` - | _ -> ` movl ${emit_int n}, %eax\n`; - ` call {emit_symbol "caml_allocN"}\n` - end; - `{record_frame i.live Debuginfo.none} leal 4(%eax), {emit_reg i.res.(0)}\n` - end - | Lop(Iintop(Icomp cmp)) -> - ` cmpl {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`; - let b = name_for_cond_branch cmp in - ` set{emit_string b} %al\n`; - ` movzbl %al, {emit_reg i.res.(0)}\n` - | Lop(Iintop_imm(Icomp cmp, n)) -> - ` cmpl ${emit_int n}, {emit_reg i.arg.(0)}\n`; - let b = name_for_cond_branch cmp in - ` set{emit_string b} %al\n`; - ` movzbl %al, {emit_reg i.res.(0)}\n` - | Lop(Iintop Icheckbound) -> - let lbl = bound_error_label i.dbg in - ` cmpl {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`; - ` jbe {emit_label lbl}\n` - | Lop(Iintop_imm(Icheckbound, n)) -> - let lbl = bound_error_label i.dbg in - ` cmpl ${emit_int n}, {emit_reg i.arg.(0)}\n`; - ` jbe {emit_label lbl}\n` - | Lop(Iintop(Idiv | Imod)) -> - ` cltd\n`; - ` idivl {emit_reg i.arg.(1)}\n` - | Lop(Iintop(Ilsl | Ilsr | Iasr as op)) -> - (* We have i.arg.(0) = i.res.(0) and i.arg.(1) = %ecx *) - ` {emit_string(instr_for_intop op)} %cl, {emit_reg i.res.(0)}\n` - | Lop(Iintop Imulh) -> - ` imull {emit_reg i.arg.(1)}\n` - | Lop(Iintop op) -> - (* We have i.arg.(0) = i.res.(0) *) - ` {emit_string(instr_for_intop op)} {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n` - | Lop(Iintop_imm(Iadd, n)) when i.arg.(0).loc <> i.res.(0).loc -> - ` leal {emit_int n}({emit_reg i.arg.(0)}), {emit_reg i.res.(0)}\n` - | Lop(Iintop_imm(Iadd, 1) | Iintop_imm(Isub, -1)) -> - ` incl {emit_reg i.res.(0)}\n` - | Lop(Iintop_imm(Iadd, -1) | Iintop_imm(Isub, 1)) -> - ` decl {emit_reg i.res.(0)}\n` - | Lop(Iintop_imm(op, n)) -> - (* We have i.arg.(0) = i.res.(0) *) - ` {emit_string(instr_for_intop op)} ${emit_int n}, {emit_reg i.res.(0)}\n` - | Lop(Inegf | Iabsf as floatop) -> - if not (is_tos i.arg.(0)) then - ` fldl {emit_reg i.arg.(0)}\n`; - ` {emit_string(instr_for_floatop floatop)}\n` - | Lop(Iaddf | Isubf | Imulf | Idivf | Ispecific(Isubfrev | Idivfrev) - as floatop) -> - begin match (is_tos i.arg.(0), is_tos i.arg.(1)) with - (true, true) -> + end + | Lop(Ialloc n) -> + if !fastcode_flag then begin + let lbl_redo = new_label() in + def_label lbl_redo; + I.mov (sym32 "caml_young_ptr") eax; + I.sub (int n) eax; + I.mov eax (sym32 "caml_young_ptr"); + I.cmp (sym32 "caml_young_limit") eax; + let lbl_call_gc = new_label() in + let lbl_frame = record_frame_label i.live Debuginfo.none in + I.jb (label lbl_call_gc); + I.lea (mem32 NONE 4 RAX) (reg i.res.(0)); + call_gc_sites := + { gc_lbl = lbl_call_gc; + gc_return_lbl = lbl_redo; + gc_frame = lbl_frame } :: !call_gc_sites + end else begin + begin match n with + 8 -> emit_call "caml_alloc1" + | 12 -> emit_call "caml_alloc2" + | 16 -> emit_call "caml_alloc3" + | _ -> + I.mov (int n) eax; + emit_call "caml_allocN" + end; + record_frame i.live Debuginfo.none; + I.lea (mem32 NONE 4 RAX) (reg i.res.(0)) + end + | Lop(Iintop(Icomp cmp)) -> + I.cmp (reg i.arg.(1)) (reg i.arg.(0)); + I.set (cond cmp) al; + I.movzx al (reg i.res.(0)); + | Lop(Iintop_imm(Icomp cmp, n)) -> + I.cmp (int n) (reg i.arg.(0)); + I.set (cond cmp) al; + I.movzx al (reg i.res.(0)) + | Lop(Iintop Icheckbound) -> + let lbl = bound_error_label i.dbg in + I.cmp (reg i.arg.(1)) (reg i.arg.(0)); + I.jbe (label lbl) + | Lop(Iintop_imm(Icheckbound, n)) -> + let lbl = bound_error_label i.dbg in + I.cmp (int n) (reg i.arg.(0)); + I.jbe (label lbl) + | Lop(Iintop(Idiv | Imod)) -> + I.cdq (); + I.idiv (reg i.arg.(1)) + | Lop(Iintop(Ilsl | Ilsr | Iasr as op)) -> + (* We have i.arg.(0) = i.res.(0) and i.arg.(1) = %ecx *) + instr_for_intop op cl (reg i.res.(0)) + | Lop(Iintop Imulh) -> + I.imul (reg i.arg.(1)) None + | Lop(Iintop op) -> + (* We have i.arg.(0) = i.res.(0) *) + instr_for_intop op (reg i.arg.(1)) (reg i.res.(0)) + | Lop(Iintop_imm(Iadd, n)) when i.arg.(0).loc <> i.res.(0).loc -> + I.lea (mem32 NONE n (reg32 i.arg.(0))) (reg i.res.(0)) + | Lop(Iintop_imm(Iadd, 1) | Iintop_imm(Isub, -1)) -> + I.inc (reg i.res.(0)) + | Lop(Iintop_imm(Iadd, -1) | Iintop_imm(Isub, 1)) -> + I.dec (reg i.res.(0)) + | Lop(Iintop_imm(op, n)) -> + (* We have i.arg.(0) = i.res.(0) *) + instr_for_intop op (int n) (reg i.res.(0)) + | Lop(Inegf | Iabsf as floatop) -> + if not (is_tos i.arg.(0)) then + I.fld (reg i.arg.(0)); + unary_instr_for_floatop floatop + | Lop(Iaddf | Isubf | Imulf | Idivf | Ispecific(Isubfrev | Idivfrev) + as floatop) -> + begin match (is_tos i.arg.(0), is_tos i.arg.(1)) with + (true, true) -> (* both operands on top of FP stack *) - ` {emit_string(instr_for_floatop_pop floatop)} %st, %st(1)\n` - | (true, false) -> + instr_for_floatop_reversed_pop floatop st0 st1 + | (true, false) -> (* first operand on stack *) - ` {emit_string(instr_for_floatop floatop)} {emit_reg i.arg.(1)}\n` - | (false, true) -> + instr_for_floatop floatop (reg i.arg.(1)) + | (false, true) -> (* second operand on stack *) - ` {emit_string(instr_for_floatop_reversed floatop)} {emit_reg i.arg.(0)}\n` - | (false, false) -> + instr_for_floatop_reversed floatop (reg i.arg.(0)) + | (false, false) -> (* both operands in memory *) - ` fldl {emit_reg i.arg.(0)}\n`; - ` {emit_string(instr_for_floatop floatop)} {emit_reg i.arg.(1)}\n` - end - | Lop(Ifloatofint) -> - begin match i.arg.(0).loc with - Stack s -> - ` fildl {emit_reg i.arg.(0)}\n` - | _ -> - ` pushl {emit_reg i.arg.(0)}\n`; - ` fildl (%esp)\n`; - ` addl $4, %esp\n` - end - | Lop(Iintoffloat) -> - if not (is_tos i.arg.(0)) then - ` fldl {emit_reg i.arg.(0)}\n`; - stack_offset := !stack_offset - 8; - ` subl $8, %esp\n`; - cfi_adjust_cfa_offset 8; - ` fnstcw 4(%esp)\n`; - ` movw 4(%esp), %ax\n`; - ` movb $12, %ah\n`; - ` movw %ax, 0(%esp)\n`; - ` fldcw 0(%esp)\n`; - begin match i.res.(0).loc with - Stack s -> - ` fistpl {emit_reg i.res.(0)}\n` + I.fld (reg i.arg.(0)); + instr_for_floatop floatop (reg i.arg.(1)) + end + | Lop(Ifloatofint) -> + begin match i.arg.(0).loc with + | Stack _ -> + I.fild (reg i.arg.(0)) + | _ -> + I.push (reg i.arg.(0)); + I.fild (mem32 DWORD 0 RSP); + I.add (int 4) esp + end + | Lop(Iintoffloat) -> + if not (is_tos i.arg.(0)) then + I.fld (reg i.arg.(0)); + stack_offset := !stack_offset - 8; + I.sub (int 8) esp; + cfi_adjust_cfa_offset 8; + I.fnstcw (mem32 NONE 4 RSP); + I.mov (mem32 WORD 4 RSP) ax; + I.mov (int 12) ah; + I.mov ax (mem32 WORD 0 RSP); + I.fldcw (mem32 NONE 0 RSP); + begin match i.res.(0).loc with + | Stack _ -> + I.fistp (reg i.res.(0)) + | _ -> + I.fistp (mem32 DWORD 0 RSP); + I.mov (mem32 DWORD 0 RSP) (reg i.res.(0)) + end; + I.fldcw (mem32 NONE 4 RSP); + I.add (int 8) esp; + cfi_adjust_cfa_offset (-8); + stack_offset := !stack_offset + 8 + | Lop(Ispecific(Ilea addr)) -> + I.lea (addressing addr DWORD i 0) (reg i.res.(0)) + | Lop(Ispecific(Istore_int(n, addr, _))) -> + I.mov (nat n) (addressing addr DWORD i 0) + | Lop(Ispecific(Istore_symbol(s, addr, _))) -> + add_used_symbol s; + I.mov (immsym s) (addressing addr DWORD i 0) + | Lop(Ispecific(Ioffset_loc(n, addr))) -> + I.add (int n) (addressing addr DWORD i 0) + | Lop(Ispecific(Ipush)) -> + (* Push arguments in reverse order *) + for n = Array.length i.arg - 1 downto 0 do + let r = i.arg.(n) in + match r with + {loc = Reg _; typ = Float} -> + I.sub (int 8) esp; + cfi_adjust_cfa_offset 8; + I.fstp (mem32 REAL8 0 RSP); + stack_offset := !stack_offset + 8 + | {loc = Stack sl; typ = Float} -> + let ofs = slot_offset sl 1 in + I.push (mem32 DWORD (ofs + 4) RSP); + I.push (mem32 DWORD (ofs + 4) RSP); + cfi_adjust_cfa_offset 8; + stack_offset := !stack_offset + 8 | _ -> - ` fistpl (%esp)\n`; - ` movl (%esp), {emit_reg i.res.(0)}\n` - end; - ` fldcw 4(%esp)\n`; - ` addl $8, %esp\n`; - cfi_adjust_cfa_offset (-8); - 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, _))) -> - ` movl ${emit_nativeint n}, {emit_addressing addr i.arg 0}\n` - | 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` - | Lop(Ispecific(Ipush)) -> - (* Push arguments in reverse order *) - for n = Array.length i.arg - 1 downto 0 do - let r = i.arg.(n) in - match r with - {loc = Reg _; typ = Float} -> - ` subl $8, %esp\n`; - cfi_adjust_cfa_offset 8; - ` fstpl 0(%esp)\n`; - stack_offset := !stack_offset + 8 - | {loc = Stack sl; typ = Float} -> - let ofs = slot_offset sl 1 in - ` pushl {emit_int(ofs + 4)}(%esp)\n`; - ` pushl {emit_int(ofs + 4)}(%esp)\n`; - cfi_adjust_cfa_offset 8; - stack_offset := !stack_offset + 8 - | _ -> - ` pushl {emit_reg r}\n`; - cfi_adjust_cfa_offset 4; - stack_offset := !stack_offset + 4 - done - | Lop(Ispecific(Ipush_int n)) -> - ` pushl ${emit_nativeint n}\n`; - cfi_adjust_cfa_offset 4; - stack_offset := !stack_offset + 4 - | Lop(Ispecific(Ipush_symbol s)) -> - ` pushl ${emit_symbol s}\n`; - cfi_adjust_cfa_offset 4; - stack_offset := !stack_offset + 4 - | Lop(Ispecific(Ipush_load addr)) -> - ` pushl {emit_addressing addr i.arg 0}\n`; - cfi_adjust_cfa_offset 4; - stack_offset := !stack_offset + 4 - | Lop(Ispecific(Ipush_load_float addr)) -> - ` pushl {emit_addressing (offset_addressing addr 4) i.arg 0}\n`; - ` pushl {emit_addressing addr i.arg 0}\n`; - cfi_adjust_cfa_offset 8; - stack_offset := !stack_offset + 8 - | Lop(Ispecific(Ifloatarithmem(double, op, addr))) -> - if not (is_tos i.arg.(0)) then - ` fldl {emit_reg i.arg.(0)}\n`; - ` {emit_string(instr_for_floatarithmem double op)} {emit_addressing addr i.arg 1}\n` - | Lop(Ispecific(Ifloatspecial s)) -> - (* Push args on float stack if necessary *) - for k = 0 to Array.length i.arg - 1 do - if not (is_tos i.arg.(k)) then ` fldl {emit_reg i.arg.(k)}\n` - done; - (* Fix-up for binary instrs whose args were swapped *) - if Array.length i.arg = 2 && is_tos i.arg.(1) then - ` fxch %st(1)\n`; - emit_floatspecial s - | Lreloadretaddr -> - () - | Lreturn -> - output_epilogue begin fun () -> - ` ret\n` - end - | Llabel lbl -> - `{emit_Llabel fallthrough lbl}:\n` - | Lbranch lbl -> - ` jmp {emit_label lbl}\n` - | Lcondbranch(tst, lbl) -> - begin match tst with - Itruetest -> - output_test_zero i.arg.(0); - ` jne {emit_label lbl}\n` - | Ifalsetest -> - output_test_zero i.arg.(0); - ` je {emit_label lbl}\n` - | Iinttest cmp -> - ` cmpl {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`; - let b = name_for_cond_branch cmp in - ` j{emit_string b} {emit_label lbl}\n` - | Iinttest_imm((Isigned Ceq | Isigned Cne | - Iunsigned Ceq | Iunsigned Cne) as cmp, 0) -> - output_test_zero i.arg.(0); - let b = name_for_cond_branch cmp in - ` j{emit_string b} {emit_label lbl}\n` - | Iinttest_imm(cmp, n) -> - ` cmpl ${emit_int n}, {emit_reg i.arg.(0)}\n`; - let b = name_for_cond_branch cmp in - ` j{emit_string b} {emit_label lbl}\n` - | Ifloattest(cmp, neg) -> - emit_float_test cmp neg i.arg lbl - | Ioddtest -> - ` testl $1, {emit_reg i.arg.(0)}\n`; - ` jne {emit_label lbl}\n` - | Ieventest -> - ` testl $1, {emit_reg i.arg.(0)}\n`; - ` je {emit_label lbl}\n` - end - | Lcondbranch3(lbl0, lbl1, lbl2) -> - ` cmpl $1, {emit_reg i.arg.(0)}\n`; - begin match lbl0 with - None -> () - | Some lbl -> ` jb {emit_label lbl}\n` - end; - begin match lbl1 with - None -> () - | Some lbl -> ` je {emit_label lbl}\n` - end; - begin match lbl2 with - None -> () - | Some lbl -> ` jg {emit_label lbl}\n` - end - | Lswitch jumptbl -> - let lbl = new_label() in - ` jmp *{emit_label lbl}(, {emit_reg i.arg.(0)}, 4)\n`; - ` .data\n`; - `{emit_label lbl}:`; - for i = 0 to Array.length jumptbl - 1 do - ` .long {emit_label jumptbl.(i)}\n` - done; - ` .text\n` - | Lsetuptrap lbl -> - ` call {emit_label lbl}\n` - | Lpushtrap -> - if trap_frame_size > 8 then - ` subl ${emit_int (trap_frame_size - 8)}, %esp\n`; - ` pushl {emit_symbol "caml_exception_pointer"}\n`; - cfi_adjust_cfa_offset trap_frame_size; - ` movl %esp, {emit_symbol "caml_exception_pointer"}\n`; - stack_offset := !stack_offset + trap_frame_size - | Lpoptrap -> - ` popl {emit_symbol "caml_exception_pointer"}\n`; - ` addl ${emit_int (trap_frame_size - 4)}, %esp\n`; - cfi_adjust_cfa_offset (-trap_frame_size); - stack_offset := !stack_offset - trap_frame_size - | Lraise k -> - begin match !Clflags.debug, k with - | true, Lambda.Raise_regular -> - ` call {emit_symbol "caml_raise_exn"}\n`; + I.push (reg r); + cfi_adjust_cfa_offset 4; + stack_offset := !stack_offset + 4 + done + | Lop(Ispecific(Ipush_int n)) -> + I.push (nat n); + cfi_adjust_cfa_offset 4; + stack_offset := !stack_offset + 4 + | Lop(Ispecific(Ipush_symbol s)) -> + add_used_symbol s; + I.push (immsym s); + cfi_adjust_cfa_offset 4; + stack_offset := !stack_offset + 4 + | Lop(Ispecific(Ipush_load addr)) -> + I.push (addressing addr DWORD i 0); + cfi_adjust_cfa_offset 4; + stack_offset := !stack_offset + 4 + | Lop(Ispecific(Ipush_load_float addr)) -> + I.push (addressing (offset_addressing addr 4) DWORD i 0); + I.push (addressing addr DWORD i 0); + cfi_adjust_cfa_offset 8; + stack_offset := !stack_offset + 8 + | Lop(Ispecific(Ifloatarithmem(double, op, addr))) -> + if not (is_tos i.arg.(0)) then + I.fld (reg i.arg.(0)); + instr_for_floatarithmem op + (addressing addr + (if double then REAL8 else REAL4) i 1) + | Lop(Ispecific(Ifloatspecial s)) -> + (* Push args on float stack if necessary *) + for k = 0 to Array.length i.arg - 1 do + if not (is_tos i.arg.(k)) then I.fld (reg i.arg.(k)) + done; + (* Fix-up for binary instrs whose args were swapped *) + if Array.length i.arg = 2 && is_tos i.arg.(1) then + I.fxch st1; + emit_floatspecial s + | Lreloadretaddr -> + () + | Lreturn -> + output_epilogue begin fun () -> + I.ret () + end + | Llabel lbl -> + emit_Llabel fallthrough lbl + | Lbranch lbl -> + I.jmp (label lbl) + | Lcondbranch(tst, lbl) -> + let lbl = label lbl in + begin match tst with + | Itruetest -> + output_test_zero i.arg.(0); + I.jne lbl; + | Ifalsetest -> + output_test_zero i.arg.(0); + I.je lbl + | Iinttest cmp -> + I.cmp (reg i.arg.(1)) (reg i.arg.(0)); + I.j (cond cmp) lbl + | Iinttest_imm((Isigned Ceq | Isigned Cne | + Iunsigned Ceq | Iunsigned Cne) as cmp, 0) -> + output_test_zero i.arg.(0); + I.j (cond cmp) lbl + | Iinttest_imm(cmp, n) -> + I.cmp (int n) (reg i.arg.(0)); + I.j (cond cmp) lbl + | Ifloattest(cmp, neg) -> + emit_float_test cmp neg i.arg lbl + | Ioddtest -> + I.test (int 1) (reg i.arg.(0)); + I.jne lbl + | Ieventest -> + I.test (int 1) (reg i.arg.(0)); + I.je lbl + end + | Lcondbranch3(lbl0, lbl1, lbl2) -> + I.cmp (int 1) (reg i.arg.(0)); + begin match lbl0 with + None -> () + | Some lbl -> I.jb (label lbl) + end; + begin match lbl1 with + None -> () + | Some lbl -> I.je (label lbl) + end; + begin match lbl2 with + None -> () + | Some lbl -> I.jg (label lbl) + end + | Lswitch jumptbl -> + let lbl = new_label() in + I.jmp (mem32 NONE 0 (reg32 i.arg.(0)) ~scale:4 ~sym:(emit_label lbl)); + D.data (); + _label (emit_label lbl); + for i = 0 to Array.length jumptbl - 1 do + D.long (ConstLabel (emit_label jumptbl.(i))) + done; + D.text () + | Lsetuptrap lbl -> + I.call (label lbl) + | Lpushtrap -> + if trap_frame_size > 8 then + I.sub (int (trap_frame_size - 8)) esp; + I.push (sym32 "caml_exception_pointer"); + cfi_adjust_cfa_offset trap_frame_size; + I.mov esp (sym32 "caml_exception_pointer"); + stack_offset := !stack_offset + trap_frame_size + | Lpoptrap -> + I.pop (sym32 "caml_exception_pointer"); + I.add (int (trap_frame_size - 4)) esp; + cfi_adjust_cfa_offset (-trap_frame_size); + stack_offset := !stack_offset - trap_frame_size + | Lraise k -> + begin match !Clflags.debug, k with + | true, Lambda.Raise_regular -> + emit_call "caml_raise_exn"; record_frame Reg.Set.empty i.dbg - | true, Lambda.Raise_reraise -> - ` call {emit_symbol "caml_reraise_exn"}\n`; + | true, Lambda.Raise_reraise -> + emit_call "caml_reraise_exn"; record_frame Reg.Set.empty i.dbg - | false, _ - | true, Lambda.Raise_notrace -> - ` movl {emit_symbol "caml_exception_pointer"}, %esp\n`; - ` popl {emit_symbol "caml_exception_pointer"}\n`; + | false, _ + | true, Lambda.Raise_notrace -> + I.mov (sym32 "caml_exception_pointer") esp; + I.pop (sym32 "caml_exception_pointer"); if trap_frame_size > 8 then - ` addl ${emit_int (trap_frame_size - 8)}, %esp\n`; - ` ret\n` - end + I.add (int (trap_frame_size - 8)) esp; + I.ret () + end let rec emit_all fallthrough i = match i.desc with @@ -843,65 +884,52 @@ let rec emit_all fallthrough i = | _ -> emit_instr fallthrough i; emit_all - (Linearize.has_fallthrough i.desc) + (system = S_win32 || Linearize.has_fallthrough i.desc) i.next (* Emission of external symbol references (for MacOSX) *) let emit_external_symbol_direct s = - `L{emit_symbol s}$stub:\n`; - ` .indirect_symbol {emit_symbol s}\n`; - ` hlt ; hlt ; hlt ; hlt ; hlt\n` + _label (Printf.sprintf "L%s$stub" (emit_symbol s)); + D.indirect_symbol (emit_symbol s); + I.hlt (); I.hlt (); I.hlt (); I.hlt () ; I.hlt () let emit_external_symbol_indirect s = - `L{emit_symbol s}$non_lazy_ptr:\n`; - ` .indirect_symbol {emit_symbol s}\n`; - ` .long 0\n` + _label (Printf.sprintf "L%s$non_lazy_ptr" (emit_symbol s)); + D.indirect_symbol (emit_symbol s); + D.long (const 0) let emit_external_symbols () = - ` .section __IMPORT,__pointers,non_lazy_symbol_pointers\n`; + D.section [ "__IMPORT"; "__pointers"] None ["non_lazy_symbol_pointers" ]; StringSet.iter emit_external_symbol_indirect !external_symbols_indirect; external_symbols_indirect := StringSet.empty; - ` .section __IMPORT,__jump_table,symbol_stubs,self_modifying_code+pure_instructions,5\n`; + D.section [ "__IMPORT"; "__jump_table"] None + [ "symbol_stubs"; "self_modifying_code+pure_instructions"; "5" ]; StringSet.iter emit_external_symbol_direct !external_symbols_direct; external_symbols_direct := StringSet.empty; if !Clflags.gprofile then begin - `Lmcount$stub:\n`; - ` .indirect_symbol mcount\n`; - ` hlt ; hlt ; hlt ; hlt ; hlt\n` + _label "Lmcount$stub"; + D.indirect_symbol "mcount"; + I.hlt (); I.hlt (); I.hlt () ; I.hlt () ; I.hlt () end (* Emission of the profiling prelude *) +let call_mcount mcount = + I.push eax; + I.mov esp ebp; + I.push ecx; + I.push edx; + I.call (sym mcount); + I.pop edx; + I.pop ecx; + I.pop eax + let emit_profile () = - match Config.system with - "linux_elf" | "gnu" -> - ` pushl %eax\n`; - ` movl %esp, %ebp\n`; - ` pushl %ecx\n`; - ` pushl %edx\n`; - ` call {emit_symbol "mcount"}\n`; - ` popl %edx\n`; - ` popl %ecx\n`; - ` popl %eax\n` - | "bsd_elf" -> - ` pushl %eax\n`; - ` movl %esp, %ebp\n`; - ` pushl %ecx\n`; - ` pushl %edx\n`; - ` call .mcount\n`; - ` popl %edx\n`; - ` popl %ecx\n`; - ` popl %eax\n` - | "macosx" -> - ` pushl %eax\n`; - ` movl %esp, %ebp\n`; - ` pushl %ecx\n`; - ` pushl %edx\n`; - ` call Lmcount$stub\n`; - ` popl %edx\n`; - ` popl %ecx\n`; - ` popl %eax\n` + match system with + | S_linux_elf | S_gnu -> call_mcount "mcount" + | S_bsd_elf -> call_mcount ".mcount" + | S_macosx -> call_mcount "Lmcount$stub" | _ -> () (*unsupported yet*) (* Emission of a function declaration *) @@ -914,123 +942,152 @@ let fundecl fundecl = call_gc_sites := []; bound_error_sites := []; bound_error_call := 0; - ` .text\n`; - emit_align 16; - if macosx + D.text (); + add_def_symbol fundecl.fun_name; + D.align (if system = S_win32 then 4 else 16); + if system = S_macosx && not !Clflags.output_c_object && is_generic_function fundecl.fun_name then (* PR#4690 *) - ` .private_extern {emit_symbol fundecl.fun_name}\n` + D.private_extern (emit_symbol fundecl.fun_name) else - ` .globl {emit_symbol fundecl.fun_name}\n`; - `{emit_symbol fundecl.fun_name}:\n`; + D.global (emit_symbol fundecl.fun_name); + D.label (emit_symbol fundecl.fun_name); emit_debug_info fundecl.fun_dbg; cfi_startproc (); if !Clflags.gprofile then emit_profile(); let n = frame_size() - 4 in - if n > 0 then - begin - ` subl ${emit_int n}, %esp\n`; + if n > 0 then begin + I.sub (int n) esp; cfi_adjust_cfa_offset n; end; - `{emit_label !tailrec_entry_point}:\n`; + def_label !tailrec_entry_point; emit_all true fundecl.fun_body; List.iter emit_call_gc !call_gc_sites; emit_call_bound_errors (); cfi_endproc (); - begin match Config.system with - "linux_elf" | "bsd_elf" | "gnu" -> - ` .type {emit_symbol fundecl.fun_name},@function\n`; - ` .size {emit_symbol fundecl.fun_name},.-{emit_symbol fundecl.fun_name}\n` - | _ -> () end + begin match system with + | S_linux_elf | S_bsd_elf | S_gnu -> + D.type_ (emit_symbol fundecl.fun_name) "@function"; + D.size (emit_symbol fundecl.fun_name) + (ConstSub ( + ConstThis, + ConstLabel (emit_symbol fundecl.fun_name))) + | _ -> () + end (* Emission of data *) let emit_item = function - Cglobal_symbol s -> - ` .globl {emit_symbol s}\n`; - | Cdefine_symbol s -> - `{emit_symbol s}:\n` - | Cdefine_label lbl -> - `{emit_data_label lbl}:\n` - | Cint8 n -> - ` .byte {emit_int n}\n` - | Cint16 n -> - ` {emit_string word_dir} {emit_int n}\n` - | Cint32 n -> - ` .long {emit_nativeint n}\n` - | Cint n -> - ` .long {emit_nativeint n}\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 -> - ` .long {emit_symbol s}\n` - | Clabel_address lbl -> - ` .long {emit_data_label lbl}\n` - | Cstring s -> - if use_ascii_dir - then emit_string_directive " .ascii " s - else emit_bytes_directive " .byte " s - | Cskip n -> - if n > 0 then ` {emit_string skip_dir} {emit_int n}\n` - | Calign n -> - emit_align n + | Cglobal_symbol s -> D.global (emit_symbol s) + | Cdefine_symbol s -> add_def_symbol s; _label (emit_symbol s) + | Cdefine_label lbl -> _label (emit_data_label lbl) + | Cint8 n -> D.byte (const n) + | Cint16 n -> D.word (const n) + | Cint32 n -> D.long (const_nat n) + | Cint n -> D.long (const_nat n) + | Csingle f -> D.long (Const (Int64.of_int32 (Int32.bits_of_float f))) + | Cdouble f -> emit_float64_split_directive (Int64.bits_of_float f) + | Csymbol_address s -> add_used_symbol s; D.long (ConstLabel (emit_symbol s)) + | Clabel_address lbl -> D.long (ConstLabel (emit_data_label lbl)) + | Cstring s -> D.bytes s + | Cskip n -> if n > 0 then D.space n + | Calign n -> D.align n let data l = - ` .data\n`; + D.data (); List.iter emit_item l (* Beginning / end of an assembly file *) let begin_assembly() = + X86_proc.reset_asm_code (); reset_debug_info(); (* PR#5603 *) float_constants := []; - let lbl_begin = Compilenv.make_symbol (Some "data_begin") in - ` .data\n`; - ` .globl {emit_symbol lbl_begin}\n`; - `{emit_symbol lbl_begin}:\n`; - let lbl_begin = Compilenv.make_symbol (Some "code_begin") in - ` .text\n`; - ` .globl {emit_symbol lbl_begin}\n`; - `{emit_symbol lbl_begin}:\n`; - if macosx then ` nop\n` (* PR#4690 *) + if system = S_win32 then begin + D.mode386 (); + D.model "FLAT"; + D.extrn "_caml_young_ptr" DWORD; + D.extrn "_caml_young_limit" DWORD; + D.extrn "_caml_exception_pointer" DWORD; + D.extrn "_caml_extra_params" DWORD; + D.extrn "_caml_call_gc" PROC; + D.extrn "_caml_c_call" PROC; + D.extrn "_caml_allocN" PROC; + D.extrn "_caml_alloc1" PROC; + D.extrn "_caml_alloc2" PROC; + D.extrn "_caml_alloc3" PROC; + D.extrn "_caml_ml_array_bound_error" PROC; + D.extrn "_caml_raise_exn" PROC; + D.extrn "_caml_reraise_exn" PROC; + end; + + D.data (); + emit_global_label "data_begin"; + + D.text (); + emit_global_label "code_begin"; + if system = S_macosx then I.nop (); (* PR#4690 *) + () let end_assembly() = if !float_constants <> [] then begin - ` .data\n`; - List.iter emit_float_constant !float_constants + D.data (); + List.iter (fun (cst,lbl) -> emit_float_constant cst lbl) !float_constants end; - let lbl_end = Compilenv.make_symbol (Some "code_end") in - ` .text\n`; - if macosx then ` nop\n`; (* suppress "ld warning: atom sorting error" *) - ` .globl {emit_symbol lbl_end}\n`; - `{emit_symbol lbl_end}:\n`; - ` .data\n`; - let lbl_end = Compilenv.make_symbol (Some "data_end") in - ` .globl {emit_symbol lbl_end}\n`; - `{emit_symbol lbl_end}:\n`; - ` .long 0\n`; - let lbl = Compilenv.make_symbol (Some "frametable") in - ` .globl {emit_symbol lbl}\n`; - `{emit_symbol lbl}:\n`; + + D.text (); + if system = S_macosx then I.nop (); + (* suppress "ld warning: atom sorting error" *) + + emit_global_label "code_end"; + + D.data (); + emit_global_label "data_end"; + D.long (const 0); + + emit_global_label "frametable"; + emit_frames - { efa_label = (fun l -> ` .long {emit_label l}\n`); - efa_16 = (fun n -> ` {emit_string word_dir} {emit_int n}\n`); - efa_32 = (fun n -> ` .long {emit_int32 n}\n`); - efa_word = (fun n -> ` .long {emit_int n}\n`); - efa_align = emit_align; + { efa_label = (fun l -> D.long (ConstLabel (emit_label l))); + efa_16 = (fun n -> D.word (const n)); + efa_32 = (fun n -> D.long (const_32 n)); + efa_word = (fun n -> D.long (const n)); + efa_align = D.align; efa_label_rel = (fun lbl ofs -> - ` .long {emit_label lbl} - . + {emit_int32 ofs}\n`); - efa_def_label = (fun l -> `{emit_label l}:\n`); - efa_string = (fun s -> - let s = s ^ "\000" in - if use_ascii_dir - then emit_string_directive " .ascii " s - else emit_bytes_directive " .byte " s) }; - if macosx then emit_external_symbols (); - if Config.system = "linux_elf" then + D.long (ConstAdd ( + ConstSub(ConstLabel(emit_label lbl), + ConstThis), + const_32 ofs))); + efa_def_label = (fun l -> _label (emit_label l)); + efa_string = (fun s -> D.bytes (s ^ "\000")) + }; + + if system = S_macosx then emit_external_symbols (); + if system = S_linux_elf then (* Mark stack as non-executable, PR#4564 *) - `\n .section .note.GNU-stack,\"\",%progbits\n` + D.section [".note.GNU-stack"] (Some "") ["%progbits"]; + + if system = S_win32 then begin + D.comment "External functions"; + StringSet.iter + (fun s -> + if not (StringSet.mem s !symbols_defined) then + D.extrn (emit_symbol s) PROC) + !symbols_used; + symbols_used := StringSet.empty; + symbols_defined := StringSet.empty; + end; + + let asm = + if !Emitaux.create_asm_file then + Some + ( + (if X86_proc.masm then X86_masm.generate_asm + else X86_gas.generate_asm) !Emitaux.output_channel + ) + else + None + in + X86_proc.generate_code asm diff --git a/asmcomp/i386/proc.ml b/asmcomp/i386/proc.ml index 0b010d248f..1ae988b412 100644 --- a/asmcomp/i386/proc.ml +++ b/asmcomp/i386/proc.ml @@ -1,3 +1,4 @@ +# 2 "asmcomp/i386/proc.ml" (***********************************************************************) (* *) (* OCaml *) @@ -216,12 +217,6 @@ let contains_calls = ref false (* Calling the assembler *) let assemble_file infile outfile = - if masm then - Ccomp.command (Config.asm ^ - Filename.quote outfile ^ " " ^ Filename.quote infile ^ - (if !Clflags.verbose then "" else ">NUL")) - else - Ccomp.command (Config.asm ^ " -o " ^ - Filename.quote outfile ^ " " ^ Filename.quote infile) + X86_proc.assemble_file infile outfile let init () = () diff --git a/asmcomp/power/emit.mlp b/asmcomp/power/emit.mlp index 24255fa834..599e79e0a9 100644 --- a/asmcomp/power/emit.mlp +++ b/asmcomp/power/emit.mlp @@ -310,126 +310,87 @@ let defined_functions = ref StringSet.empty (* Label of glue code for calling the GC *) let call_gc_label = ref 0 -(* Fixup conditional branches that exceed hardware allowed range *) - -let load_store_size = function - Ibased(s, d) -> 2 - | Iindexed ofs -> if is_immediate ofs then 1 else 3 - | Iindexed2 -> 1 - -let instr_size = function - Lend -> 0 - | Lop(Imove | Ispill | Ireload) -> 1 - | Lop(Iconst_int n | Iconst_blockheader n) -> - if is_native_immediate n then 1 else 2 - | Lop(Iconst_float s) -> 2 - | Lop(Iconst_symbol s) -> 2 - | Lop(Icall_ind) -> 2 - | Lop(Icall_imm s) -> 1 - | Lop(Itailcall_ind) -> 5 - | Lop(Itailcall_imm s) -> if s = !function_name then 1 else 4 - | Lop(Iextcall(s, true)) -> 3 - | Lop(Iextcall(s, false)) -> if pic_externals then 4 else 1 - | Lop(Istackoffset n) -> 1 - | Lop(Iload(chunk, addr)) -> +module BR = Branch_relaxation.Make (struct + type distance = int + + module Cond_branch = struct + type t = Branch + + let all = [Branch] + + let max_displacement = function + (* 14-bit signed offset in words. *) + | Branch -> 8192 + + let classify_instr = function + | Lop (Ialloc _) + (* [Ialloc_far] does not need to be here, since its code sequence + never involves any conditional branches that might need relaxing. *) + | Lcondbranch _ + | Lcondbranch3 _ -> Some Branch + | _ -> None + end + + let offset_pc_at_branch = 1 + + let load_store_size = function + | Ibased(s, d) -> 2 + | Iindexed ofs -> if is_immediate ofs then 1 else 3 + | Iindexed2 -> 1 + + let instr_size = function + | Lend -> 0 + | Lop(Imove | Ispill | Ireload) -> 1 + | Lop(Iconst_int n | Iconst_blockheader n) -> + if is_native_immediate n then 1 else 2 + | Lop(Iconst_float s) -> 2 + | Lop(Iconst_symbol s) -> 2 + | Lop(Icall_ind) -> 2 + | Lop(Icall_imm s) -> 1 + | Lop(Itailcall_ind) -> 5 + | Lop(Itailcall_imm s) -> if s = !function_name then 1 else 4 + | Lop(Iextcall(s, true)) -> 3 + | Lop(Iextcall(s, false)) -> if pic_externals then 4 else 1 + | Lop(Istackoffset n) -> 1 + | Lop(Iload(chunk, addr)) -> if chunk = Byte_signed then load_store_size addr + 1 else 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 - | Lop(Iintop(Icomp cmp)) -> 4 - | Lop(Iintop op) -> 1 - | Lop(Iintop_imm(Icomp cmp, n)) -> 4 - | Lop(Iintop_imm(op, n)) -> 1 - | Lop(Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf) -> 1 - | Lop(Ifloatofint) -> 9 - | Lop(Iintoffloat) -> 4 - | Lop(Ispecific sop) -> 1 - | Lreloadretaddr -> 2 - | Lreturn -> 2 - | Llabel lbl -> 0 - | Lbranch lbl -> 1 - | Lcondbranch(tst, lbl) -> 2 - | Lcondbranch3(lbl0, lbl1, lbl2) -> + | Lop(Istore(chunk, addr, _)) -> load_store_size addr + | Lop(Ialloc n) -> 4 + | Lop(Ispecific(Ialloc_far n)) -> 5 + | Lop(Iintop Imod) -> 3 + | Lop(Iintop(Icomp cmp)) -> 4 + | Lop(Iintop op) -> 1 + | Lop(Iintop_imm(Icomp cmp, n)) -> 4 + | Lop(Iintop_imm(op, n)) -> 1 + | Lop(Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf) -> 1 + | Lop(Ifloatofint) -> 9 + | Lop(Iintoffloat) -> 4 + | Lop(Ispecific sop) -> 1 + | Lreloadretaddr -> 2 + | Lreturn -> 2 + | Llabel lbl -> 0 + | Lbranch lbl -> 1 + | Lcondbranch(tst, lbl) -> 2 + | Lcondbranch3(lbl0, lbl1, lbl2) -> 1 + (if lbl0 = None then 0 else 1) + (if lbl1 = None then 0 else 1) + (if lbl2 = None then 0 else 1) - | Lswitch jumptbl -> 8 - | Lsetuptrap lbl -> 1 - | Lpushtrap -> 4 - | Lpoptrap -> 2 - | Lraise _ -> 6 - -let label_map code = - let map = Hashtbl.create 37 in - let rec fill_map pc instr = - match instr.desc with - Lend -> (pc, map) - | Llabel lbl -> Hashtbl.add map lbl pc; fill_map pc instr.next - | op -> fill_map (pc + instr_size op) instr.next - in fill_map 0 code - -let max_branch_offset = 8180 -(* 14-bit signed offset in words. Remember to cut some slack - for multi-word instructions where the branch can be anywhere in - the middle. 12 words of slack is plenty. *) - -let branch_overflows map pc_branch lbl_dest = - let pc_dest = Hashtbl.find map lbl_dest in - let delta = pc_dest - (pc_branch + 1) in - delta <= -max_branch_offset || delta >= max_branch_offset - -let opt_branch_overflows map pc_branch opt_lbl_dest = - match opt_lbl_dest with - None -> false - | Some lbl_dest -> branch_overflows map pc_branch lbl_dest - -let fixup_branches codesize map code = - let expand_optbranch lbl n arg next = - match lbl with - None -> next - | Some l -> - instr_cons (Lcondbranch(Iinttest_imm(Isigned Ceq, n), l)) - arg [||] next in - let rec fixup did_fix pc instr = - match instr.desc with - Lend -> did_fix - | Lcondbranch(test, lbl) when branch_overflows map pc lbl -> - let lbl2 = new_label() in - let cont = - instr_cons (Lbranch lbl) [||] [||] - (instr_cons (Llabel lbl2) [||] [||] instr.next) in - instr.desc <- Lcondbranch(invert_test test, lbl2); - instr.next <- cont; - fixup true (pc + 2) instr.next - | Lcondbranch3(lbl0, lbl1, lbl2) - when opt_branch_overflows map pc lbl0 - || opt_branch_overflows map pc lbl1 - || opt_branch_overflows map pc lbl2 -> - let cont = - expand_optbranch lbl0 0 instr.arg - (expand_optbranch lbl1 1 instr.arg - (expand_optbranch lbl2 2 instr.arg instr.next)) in - instr.desc <- cont.desc; - instr.next <- cont.next; - fixup true pc instr - | Lop(Ialloc n) when codesize - pc >= max_branch_offset -> - instr.desc <- Lop(Ispecific(Ialloc_far n)); - fixup true (pc + 4) instr.next - | op -> - fixup did_fix (pc + instr_size op) instr.next - in fixup false 0 code - -(* Iterate branch expansion till all conditional branches are OK *) - -let rec branch_normalization code = - let (codesize, map) = label_map code in - if codesize >= max_branch_offset && fixup_branches codesize map code - then branch_normalization code - else () + | Lswitch jumptbl -> 8 + | Lsetuptrap lbl -> 1 + | Lpushtrap -> 4 + | Lpoptrap -> 2 + | Lraise _ -> 6 + + let relax_allocation ~num_words = Lop (Ispecific (Ialloc_far num_words)) + (* [classify_addr], above, never identifies these instructions as needing + relaxing. As such, these functions should never be called. *) + let relax_specific_op _ = assert false + let relax_intop_checkbound () = assert false + let relax_intop_imm_checkbound ~bound:_ = assert false +end) (* Output the assembly code for an instruction *) @@ -850,7 +811,10 @@ let fundecl fundecl = ` addi {emit_gpr 1}, {emit_gpr 1}, {emit_int(-n)}\n` end; `{emit_label !tailrec_entry_point}:\n`; - branch_normalization fundecl.fun_body; + (* On this target, there is at most one "out of line" code block per + function: a single "call GC" point. It comes immediately after the + function's body. *) + BR.relax fundecl.fun_body ~max_out_of_line_code_offset:0; emit_all fundecl.fun_body; (* Emit the glue code to call the GC *) if !call_gc_label > 0 then begin diff --git a/asmcomp/x86_ast.mli b/asmcomp/x86_ast.mli new file mode 100644 index 0000000000..36b10ae225 --- /dev/null +++ b/asmcomp/x86_ast.mli @@ -0,0 +1,216 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Fabrice Le Fessant, 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. *) +(* *) +(***********************************************************************) + +(** Structured representation of Intel assembly language (32 and 64 bit). *) + +type condition = + | L | GE (* signed comparisons: less/greater *) + | LE | G + | B | AE (* unsigned comparisons: below/above *) + | BE | A + | E | NE (* equal *) + | O | NO (* overflow *) + | S | NS (* sign *) + | P | NP (* parity *) + +type rounding = + | RoundUp + | RoundDown + | RoundNearest + | RoundTruncate + +type constant = + | Const of int64 + | ConstThis + | ConstLabel of string + | ConstAdd of constant * constant + | ConstSub of constant * constant + +(* data_type is used mainly on memory addressing to specify + the size of the addressed memory chunk. It is directly + used by the MASM emitter and indirectly by the GAS emitter + to infer the instruction suffix. *) + +type data_type = + | NONE + | REAL4 | REAL8 (* floating point values *) + | BYTE | WORD | DWORD | QWORD | OWORD (* integer values *) + | NEAR | PROC + +type reg64 = + | RAX | RBX | RCX | RDX | RSP | RBP | RSI | RDI + | R8 | R9 | R10 | R11 | R12 | R13 | R14 | R15 + +type reg8h = + | AH | BH | CH | DH + + +type registerf = XMM of int | TOS | ST of int + +type arch = X64 | X86 + +type addr = + { + arch: arch; + typ: data_type; + idx: reg64; + scale: int; + base: reg64 option; + sym: string option; + displ: int; + } + (** Addressing modes: + displ + sym + base + idx * scale + (if scale = 0, idx is ignored and base must be None) + *) + +type arg = + | Imm of int64 + (** Operand is an immediate constant integer *) + + | Sym of string + (** Address of a symbol (absolute address except for call/jmp target + where it is interpreted as a relative displacement *) + + | Reg8L of reg64 + | Reg8H of reg8h + | Reg16 of reg64 + | Reg32 of reg64 + | Reg64 of reg64 + | Regf of registerf + + | Mem of addr + | Mem64_RIP of data_type * string * int + +type instruction = + | ADD of arg * arg + | ADDSD of arg * arg + | AND of arg * arg + | ANDPD of arg * arg + | BSWAP of arg + | CALL of arg + | CDQ + | CMOV of condition * arg * arg + | CMP of arg * arg + | COMISD of arg * arg + | CQO + | CVTSD2SI of arg * arg + | CVTSD2SS of arg * arg + | CVTSI2SD of arg * arg + | CVTSS2SD of arg * arg + | CVTTSD2SI of arg * arg + | DEC of arg + | DIVSD of arg * arg + | FABS + | FADD of arg + | FADDP of arg * arg + | FCHS + | FCOMP of arg + | FCOMPP + | FCOS + | FDIV of arg + | FDIVP of arg * arg + | FDIVR of arg + | FDIVRP of arg * arg + | FILD of arg + | FISTP of arg + | FLD of arg + | FLD1 + | FLDCW of arg + | FLDLG2 + | FLDLN2 + | FLDZ + | FMUL of arg + | FMULP of arg * arg + | FNSTCW of arg + | FNSTSW of arg + | FPATAN + | FPTAN + | FSIN + | FSQRT + | FSTP of arg + | FSUB of arg + | FSUBP of arg * arg + | FSUBR of arg + | FSUBRP of arg * arg + | FXCH of arg + | FYL2X + | HLT + | IDIV of arg + | IMUL of arg * arg option + | INC of arg + | J of condition * arg + | JMP of arg + | LEA of arg * arg + | LEAVE + | MOV of arg * arg + | MOVAPD of arg * arg + | MOVLPD of arg * arg + | MOVSD of arg * arg + | MOVSS of arg * arg + | MOVSX of arg * arg + | MOVSXD of arg * arg + | MOVZX of arg * arg + | MULSD of arg * arg + | NEG of arg + | NOP + | OR of arg * arg + | POP of arg + | PUSH of arg + | RET + | ROUNDSD of rounding * arg * arg + | SAL of arg * arg + | SAR of arg * arg + | SET of condition * arg + | SHR of arg * arg + | SQRTSD of arg * arg + | SUB of arg * arg + | SUBSD of arg * arg + | TEST of arg * arg + | UCOMISD of arg * arg + | XCHG of arg * arg + | XOR of arg * arg + | XORPD of arg * arg + +type asm_line = + | Ins of instruction + + | Align of bool * int + | Byte of constant + | Bytes of string + | Comment of string + | Global of string + | Long of constant + | NewLabel of string * data_type + | Quad of constant + | Section of string list * string option * string list + | Space of int + | Word of constant + + (* masm only (the gas emitter will fail on them) *) + | External of string * data_type + | Mode386 + | Model of string + + (* gas only (the masm emitter will fail on them) *) + | Cfi_adjust_cfa_offset of int + | Cfi_endproc + | Cfi_startproc + | File of int * string (* file_num * filename *) + | Indirect_symbol of string + | Loc of int * int (* file_num x line *) + | Private_extern of string + | Set of string * constant + | Size of string * constant + | Type of string * string + +type asm_program = asm_line list diff --git a/asmcomp/x86_dsl.ml b/asmcomp/x86_dsl.ml new file mode 100644 index 0000000000..eabb92a634 --- /dev/null +++ b/asmcomp/x86_dsl.ml @@ -0,0 +1,195 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Fabrice Le Fessant, projet Gallium, 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 Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(** Helpers for Intel code generators *) + +(* The DSL* modules expose functions to emit x86/x86_64 instructions + using a syntax close to AT&T (in particular, arguments are reversed compared + to the official Intel syntax). + + Some notes: + + - Unary floating point instructions such as fadd/fmul/fstp/fld/etc. + come with a single version supporting both the single and double + precision instructions. (As with Intel syntax.) + + - A legacy bug in GAS: + https://sourceware.org/binutils/docs-2.22/as/i386_002dBugs.html#i386_002dBugs + is not replicated here. It is managed by X86_gas. +*) + + +open X86_ast +open X86_proc + +let sym s = Sym s + +let nat n = Imm (Int64.of_nativeint n) +let int n = Imm (Int64.of_int n) + +let const_32 n = Const (Int64.of_int32 n) +let const_nat n = Const (Int64.of_nativeint n) +let const n = Const (Int64.of_int n) + +let al = Reg8L RAX +let ah = Reg8H AH +let cl = Reg8L RCX +let ax = Reg16 RAX +let rax = Reg64 RAX +let r10 = Reg64 R10 +let r11 = Reg64 R11 +let r14 = Reg64 R14 +let r15 = Reg64 R15 +let rsp = Reg64 RSP +let rbp = Reg64 RBP +let xmm15 = Regf (XMM 15) +let eax = Reg32 RAX +let ebx = Reg32 RBX +let ecx = Reg32 RCX +let edx = Reg32 RDX +let ebp = Reg32 RBP +let esp = Reg32 RSP +let st0 = Regf (ST 0) +let st1 = Regf (ST 1) + +let mem32 typ ?(scale = 1) ?base ?sym displ idx = + assert(scale >= 0); + Mem {arch = X86; typ; idx; scale; base; sym; displ} + +let mem64 typ ?(scale = 1) ?base ?sym displ idx = + assert(scale > 0); + Mem {arch = X64; typ; idx; scale; base; sym; displ} + +let mem64_rip typ ?(ofs = 0) s = + Mem64_RIP (typ, s, ofs) + +module D = struct + let section segment flags args = directive (Section (segment, flags, args)) + let align n = directive (Align (false, n)) + let byte n = directive (Byte n) + let bytes s = directive (Bytes s) + let cfi_adjust_cfa_offset n = directive (Cfi_adjust_cfa_offset n) + let cfi_endproc () = directive Cfi_endproc + let cfi_startproc () = directive Cfi_startproc + let comment s = directive (Comment s) + let data () = section [ ".data" ] None [] + let extrn s ptr = directive (External (s, ptr)) + let file num filename = directive (File (num, filename)) + let global s = directive (Global s) + let indirect_symbol s = directive (Indirect_symbol s) + let label ?(typ = NONE) s = directive (NewLabel (s, typ)) + let loc num loc = directive (Loc (num, loc)) + let long cst = directive (Long cst) + let mode386 () = directive Mode386 + let model name = directive (Model name) + let private_extern s = directive (Private_extern s) + let qword cst = directive (Quad cst) + let setvar (x, y) = directive (Set (x, y)) + let size name cst = directive (Size (name, cst)) + let space n = directive (Space n) + let text () = section [ ".text" ] None [] + let type_ name typ = directive (Type (name, typ)) + let word cst = directive (Word cst) +end + +module I = struct + let add x y = emit (ADD (x, y)) + let addsd x y = emit (ADDSD (x, y)) + let and_ x y= emit (AND (x, y)) + let andpd x y = emit (ANDPD (x, y)) + let bswap x = emit (BSWAP x) + let call x = emit (CALL x) + let cdq () = emit CDQ + let cmp x y = emit (CMP (x, y)) + let comisd x y = emit (COMISD (x, y)) + let cqo () = emit CQO + let cvtsd2ss x y = emit (CVTSD2SS (x, y)) + let cvtsi2sd x y = emit (CVTSI2SD (x, y)) + let cvtss2sd x y = emit (CVTSS2SD (x, y)) + let cvttsd2si x y = emit (CVTTSD2SI (x, y)) + let dec x = emit (DEC x) + let divsd x y = emit (DIVSD (x, y)) + let fabs () = emit FABS + let fadd x = emit (FADD x) + let faddp x y = emit (FADDP (x, y)) + let fchs () = emit FCHS + let fcomp x = emit (FCOMP x) + let fcompp () = emit FCOMPP + let fcos () = emit FCOS + let fdiv x = emit (FDIV x) + let fdivp x y = emit (FDIVP (x, y)) + let fdivr x = emit (FDIVR x) + let fdivrp x y = emit (FDIVRP (x, y)) + let fild x = emit (FILD x) + let fistp x = emit (FISTP x) + let fld x = emit (FLD x) + let fld1 () = emit FLD1 + let fldcw x = emit (FLDCW x) + let fldlg2 () = emit FLDLG2 + let fldln2 () = emit FLDLN2 + let fldz () = emit FLDZ + let fmul x = emit (FMUL x) + let fmulp x y = emit (FMULP (x, y)) + let fnstcw x = emit (FNSTCW x) + let fnstsw x = emit (FNSTSW x) + let fpatan () = emit FPATAN + let fptan () = emit FPTAN + let fsin () = emit FSIN + let fsqrt () = emit FSQRT + let fstp x = emit (FSTP x) + let fsub x = emit (FSUB x) + let fsubp x y = emit (FSUBP (x, y)) + let fsubr x = emit (FSUBR x) + let fsubrp x y = emit (FSUBRP (x, y)) + let fxch x = emit (FXCH x) + let fyl2x () = emit FYL2X + let hlt () = emit HLT + let idiv x = emit (IDIV x) + let imul x y = emit (IMUL (x, y)) + let inc x = emit (INC x) + let j cond x = emit (J (cond, x)) + let ja = j A + let jae = j AE + let jb = j B + let jbe = j BE + let je = j E + let jg = j G + let jmp x = emit (JMP x) + let jne = j NE + let jp = j P + let lea x y = emit (LEA (x, y)) + let mov x y = emit (MOV (x, y)) + let movapd x y = emit (MOVAPD (x, y)) + let movsd x y = emit (MOVSD (x, y)) + let movss x y = emit (MOVSS (x, y)) + let movsx x y = emit (MOVSX (x, y)) + let movsxd x y = emit (MOVSXD (x, y)) + let movzx x y = emit (MOVZX (x, y)) + let mulsd x y = emit (MULSD (x, y)) + let nop () = emit NOP + let or_ x y = emit (OR (x, y)) + let pop x = emit (POP x) + let push x = emit (PUSH x) + let ret () = emit RET + let sal x y = emit (SAL (x, y)) + let sar x y = emit (SAR (x, y)) + let set cond x = emit (SET (cond, x)) + let shr x y = emit (SHR (x, y)) + let sqrtsd x y = emit (SQRTSD (x, y)) + let sub x y = emit (SUB (x, y)) + let subsd x y = emit (SUBSD (x, y)) + let test x y= emit (TEST (x, y)) + let ucomisd x y = emit (UCOMISD (x, y)) + let xchg x y = emit (XCHG (x, y)) + let xor x y= emit (XOR (x, y)) + let xorpd x y = emit (XORPD (x, y)) +end diff --git a/asmcomp/x86_dsl.mli b/asmcomp/x86_dsl.mli new file mode 100644 index 0000000000..2f209e10b9 --- /dev/null +++ b/asmcomp/x86_dsl.mli @@ -0,0 +1,188 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Fabrice Le Fessant, 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. *) +(* *) +(***********************************************************************) + +(** Helpers for Intel code generators *) + +(* The DSL* modules expose functions to emit x86/x86_64 instructions + using a syntax close to the official Intel syntax, except that + source and destination operands are reversed as in the AT&T + syntax: + + mov src dst +*) + + +open X86_ast + +val sym: string -> arg +val nat: nativeint -> arg +val int: int -> arg +val const_32: int32 -> constant +val const_nat: nativeint -> constant +val const: int -> constant +val al: arg +val ah: arg +val cl: arg +val ax: arg +val rax: arg +val r10: arg +val r11: arg +val r14: arg +val r15: arg +val rsp: arg +val rbp: arg +val xmm15: arg +val eax: arg +val ebx: arg +val ecx: arg +val edx: arg +val ebp: arg +val esp: arg +val st0: arg +val st1: arg + +val mem32: + data_type -> ?scale:int -> ?base:reg64 -> ?sym:string -> + int -> reg64 -> arg + +val mem64: + data_type -> ?scale:int -> ?base:reg64 -> ?sym:string -> + int -> reg64 -> arg + +val mem64_rip: data_type -> ?ofs:int -> string -> arg + + +module D : sig + (** Directives *) + + val align: int -> unit + val byte: constant -> unit + val bytes: string -> unit + val cfi_adjust_cfa_offset: int -> unit + val cfi_endproc: unit -> unit + val cfi_startproc: unit -> unit + val comment: string -> unit + val data: unit -> unit + val extrn: string -> data_type -> unit + val file: int -> string -> unit + val global: string -> unit + val indirect_symbol: string -> unit + val label: ?typ:data_type -> string -> unit + val loc: int -> int -> unit + val long: constant -> unit + val mode386: unit -> unit + val model: string -> unit + val private_extern: string -> unit + val qword: constant -> unit + val section: string list -> string option -> string list -> unit + val setvar: string * constant -> unit + val size: string -> constant -> unit + val space: int -> unit + val text: unit -> unit + val type_: string -> string -> unit + val word: constant -> unit +end + +module I : sig + (* Instructions *) + + val add: arg -> arg -> unit + val addsd: arg -> arg -> unit + val and_: arg -> arg -> unit + val andpd: arg -> arg -> unit + val bswap: arg -> unit + val call: arg -> unit + val cdq: unit -> unit + val cmp: arg -> arg -> unit + val comisd: arg -> arg -> unit + val cqo: unit -> unit + val cvtsd2ss: arg -> arg -> unit + val cvtsi2sd: arg -> arg -> unit + val cvtss2sd: arg -> arg -> unit + val cvttsd2si: arg -> arg -> unit + val dec: arg -> unit + val divsd: arg -> arg -> unit + val fabs: unit -> unit + val fadd: arg -> unit + val faddp: arg -> arg -> unit + val fchs: unit -> unit + val fcomp: arg -> unit + val fcompp: unit -> unit + val fcos: unit -> unit + val fdiv: arg -> unit + val fdivp: arg -> arg -> unit + val fdivr: arg -> unit + val fdivrp: arg -> arg -> unit + val fild: arg -> unit + val fistp: arg -> unit + val fld1: unit -> unit + val fld: arg -> unit + val fldcw: arg -> unit + val fldlg2: unit -> unit + val fldln2: unit -> unit + val fldz: unit -> unit + val fmul: arg -> unit + val fmulp: arg -> arg -> unit + val fnstcw: arg -> unit + val fnstsw: arg -> unit + val fpatan: unit -> unit + val fptan: unit -> unit + val fsin: unit -> unit + val fsqrt: unit -> unit + val fstp: arg -> unit + val fsub: arg -> unit + val fsubp: arg -> arg -> unit + val fsubr: arg -> unit + val fsubrp: arg -> arg -> unit + val fxch: arg -> unit + val fyl2x: unit -> unit + val hlt: unit -> unit + val idiv: arg -> unit + val imul: arg -> arg option -> unit + val inc: arg -> unit + val j: condition -> arg -> unit + val ja: arg -> unit + val jae: arg -> unit + val jb: arg -> unit + val jbe: arg -> unit + val je: arg -> unit + val jg: arg -> unit + val jmp: arg -> unit + val jne: arg -> unit + val jp: arg -> unit + val lea: arg -> arg -> unit + val mov: arg -> arg -> unit + val movapd: arg -> arg -> unit + val movsd: arg -> arg -> unit + val movss: arg -> arg -> unit + val movsx: arg -> arg -> unit + val movsxd: arg -> arg -> unit + val movzx: arg -> arg -> unit + val mulsd: arg -> arg -> unit + val nop: unit -> unit + val or_: arg -> arg -> unit + val pop: arg -> unit + val push: arg -> unit + val ret: unit -> unit + val sal: arg -> arg -> unit + val sar: arg -> arg -> unit + val set: condition -> arg -> unit + val shr: arg -> arg -> unit + val sqrtsd: arg -> arg -> unit + val sub: arg -> arg -> unit + val subsd: arg -> arg -> unit + val test: arg -> arg -> unit + val ucomisd: arg -> arg -> unit + val xchg: arg -> arg -> unit + val xor: arg -> arg -> unit + val xorpd: arg -> arg -> unit +end diff --git a/asmcomp/x86_gas.ml b/asmcomp/x86_gas.ml new file mode 100644 index 0000000000..2ea01fe88f --- /dev/null +++ b/asmcomp/x86_gas.ml @@ -0,0 +1,303 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Fabrice Le Fessant, 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. *) +(* *) +(***********************************************************************) + +open X86_ast +open X86_proc + +let bprintf = Printf.bprintf + +let print_reg b f r = + Buffer.add_char b '%'; + Buffer.add_string b (f r) + +let opt_displ b displ = + if displ = 0 then () + else if displ > 0 then bprintf b "+%d" displ + else bprintf b "%d" displ + +let arg_mem b {arch; typ=_; idx; scale; base; sym; displ} = + let string_of_register = + match arch with + | X86 -> string_of_reg32 + | X64 -> string_of_reg64 + in + begin match sym with + | None -> + if displ <> 0 || scale = 0 then + Buffer.add_string b (string_of_int displ) + | Some s -> + Buffer.add_string b s; + opt_displ b displ + end; + if scale <> 0 then begin + Buffer.add_char b '('; + begin match base with + | None -> () + | Some base -> print_reg b string_of_register base + end; + if base != None || scale <> 1 then Buffer.add_char b ','; + print_reg b string_of_register idx; + if scale <> 1 then bprintf b ",%s" (string_of_int scale); + Buffer.add_char b ')' + end + +let arg b = function + | Sym x -> Buffer.add_char b '$'; Buffer.add_string b x + | Imm x -> bprintf b "$%Ld" x + | Reg8L x -> print_reg b string_of_reg8l x + | Reg8H x -> print_reg b string_of_reg8h x + | Reg16 x -> print_reg b string_of_reg16 x + | Reg32 x -> print_reg b string_of_reg32 x + | Reg64 x -> print_reg b string_of_reg64 x + | Regf x -> print_reg b string_of_registerf x + | Mem addr -> arg_mem b addr + | Mem64_RIP (_, s, displ) -> bprintf b "%s%a(%%rip)" s opt_displ displ + +let rec cst b = function + | ConstLabel _ | Const _ | ConstThis as c -> scst b c + | ConstAdd (c1, c2) -> bprintf b "%a + %a" scst c1 scst c2 + | ConstSub (c1, c2) -> bprintf b "%a - %a" scst c1 scst c2 + +and scst b = function + | ConstThis -> Buffer.add_string b "." + | ConstLabel l -> Buffer.add_string b l + | Const n when n <= 0x7FFF_FFFFL && n >= -0x8000_0000L -> + Buffer.add_string b (Int64.to_string n) + | Const n -> bprintf b "0x%Lx" n + | ConstAdd (c1, c2) -> bprintf b "(%a + %a)" scst c1 scst c2 + | ConstSub (c1, c2) -> bprintf b "(%a - %a)" scst c1 scst c2 + +let typeof = function + | Mem {typ; _} | Mem64_RIP (typ, _, _) -> typ + | Reg8L _ | Reg8H _ -> BYTE + | Reg16 _ -> WORD + | Reg32 _ -> DWORD + | Reg64 _ -> QWORD + | Imm _ | Sym _ -> NONE + | Regf _ -> assert false + +let suf arg = + match typeof arg with + | BYTE -> "b" + | WORD -> "w" + | DWORD | REAL8 -> "l" + | QWORD -> "q" + | REAL4 -> "s" + | NONE -> "" + | OWORD | NEAR | PROC -> assert false + +let i0 b s = bprintf b "\t%s" s +let i1 b s x = bprintf b "\t%s\t%a" s arg x +let i1_s b s x = bprintf b "\t%s%s\t%a" s (suf x) arg x +let i2 b s x y = bprintf b "\t%s\t%a, %a" s arg x arg y +let i2_s b s x y = bprintf b "\t%s%s\t%a, %a" s (suf y) arg x arg y +let i2_ss b s x y = bprintf b "\t%s%s%s\t%a, %a" s (suf x) (suf y) arg x arg y + +let i1_call_jmp b s = function + (* this is the encoding of jump labels: don't use * *) + | Mem {arch=X86; idx=_; scale=0; base=None; sym=Some _; _} as x -> + i1 b s x + | Reg32 _ | Reg64 _ | Mem _ | Mem64_RIP _ as x -> bprintf b "\t%s\t*%a" s arg x + | Sym x -> bprintf b "\t%s\t%s" s x + | _ -> assert false + +let print_instr b = function + | ADD (arg1, arg2) -> i2_s b "add" arg1 arg2 + | ADDSD (arg1, arg2) -> i2 b "addsd" arg1 arg2 + | AND (arg1, arg2) -> i2_s b "and" arg1 arg2 + | ANDPD (arg1, arg2) -> i2 b "andpd" arg1 arg2 + | BSWAP arg -> i1 b "bswap" arg + | CALL arg -> i1_call_jmp b "call" arg + | CDQ -> i0 b "cltd" + | CMOV (c, arg1, arg2) -> i2 b ("cmov" ^ string_of_condition c) arg1 arg2 + | CMP (arg1, arg2) -> i2_s b "cmp" arg1 arg2 + | COMISD (arg1, arg2) -> i2 b "comisd" arg1 arg2 + | CQO -> i0 b "cqto" + | CVTSD2SI (arg1, arg2) -> i2 b "cvtsd2si" arg1 arg2 + | CVTSD2SS (arg1, arg2) -> i2 b "cvtsd2ss" arg1 arg2 + | CVTSI2SD (arg1, arg2) -> i2 b ("cvtsi2sd" ^ suf arg1) arg1 arg2 + | CVTSS2SD (arg1, arg2) -> i2 b "cvtss2sd" arg1 arg2 + | CVTTSD2SI (arg1, arg2) -> i2_s b "cvttsd2si" arg1 arg2 + | DEC arg -> i1_s b "dec" arg + | DIVSD (arg1, arg2) -> i2 b "divsd" arg1 arg2 + | FABS -> i0 b "fabs" + | FADD arg -> i1_s b "fadd" arg + | FADDP (arg1, arg2) -> i2 b "faddp" arg1 arg2 + | FCHS -> i0 b "fchs" + | FCOMP arg -> i1_s b "fcomp" arg + | FCOMPP -> i0 b "fcompp" + | FCOS -> i0 b "fcos" + | FDIV arg -> i1_s b "fdiv" arg + | FDIVP (Regf (ST 0), arg2) -> i2 b "fdivrp" (Regf (ST 0)) arg2 (* bug *) + | FDIVP (arg1, arg2) -> i2 b "fdivp" arg1 arg2 + | FDIVR arg -> i1_s b "fdivr" arg + | FDIVRP (Regf (ST 0), arg2) -> i2 b "fdivp" (Regf (ST 0)) arg2 (* bug *) + | FDIVRP (arg1, arg2) -> i2 b "fdivrp" arg1 arg2 + | FILD arg -> i1_s b "fild" arg + | FISTP arg -> i1_s b "fistp" arg + | FLD (Mem {typ=REAL4; _} as arg) -> i1 b "flds" arg + | FLD arg -> i1 b "fldl" arg + | FLD1 -> i0 b "fld1" + | FLDCW arg -> i1 b "fldcw" arg + | FLDLG2 -> i0 b "fldlg2" + | FLDLN2 -> i0 b "fldln2" + | FLDZ -> i0 b "fldz" + | FMUL arg -> i1_s b "fmul" arg + | FMULP (arg1, arg2) -> i2 b "fmulp" arg1 arg2 + | FNSTCW arg -> i1 b "fnstcw" arg + | FNSTSW arg -> i1 b "fnstsw" arg + | FPATAN -> i0 b "fpatan" + | FPTAN -> i0 b "fptan" + | FSIN -> i0 b "fsin" + | FSQRT -> i0 b "fsqrt" + | FSTP (Mem {typ=REAL4; _} as arg) -> i1 b "fstps" arg + | FSTP arg -> i1 b "fstpl" arg + | FSUB arg -> i1_s b "fsub" arg + | FSUBP (Regf (ST 0), arg2) -> i2 b "fsubrp" (Regf (ST 0)) arg2 (* bug *) + | FSUBP (arg1, arg2) -> i2 b "fsubp" arg1 arg2 + | FSUBR arg -> i1_s b "fsubr" arg + | FSUBRP (Regf (ST 0), arg2) -> i2 b "fsubp" (Regf (ST 0)) arg2 (* bug *) + | FSUBRP (arg1, arg2) -> i2 b "fsubrp" arg1 arg2 + | FXCH arg -> i1 b "fxch" arg + | FYL2X -> i0 b "fyl2x" + | HLT -> i0 b "hlt" + | IDIV arg -> i1_s b "idiv" arg + | IMUL (arg, None) -> i1_s b "imul" arg + | IMUL (arg1, Some arg2) -> i2_s b "imul" arg1 arg2 + | INC arg -> i1_s b "inc" arg + | J (c, arg) -> i1_call_jmp b ("j" ^ string_of_condition c) arg + | JMP arg -> i1_call_jmp b "jmp" arg + | LEA (arg1, arg2) -> i2_s b "lea" arg1 arg2 + | LEAVE -> i0 b "leave" + | MOV ((Imm n as arg1), (Reg64 _ as arg2)) + when not (n <= 0x7FFF_FFFFL && n >= -0x8000_0000L) -> + i2 b "movabsq" arg1 arg2 + | MOV ((Sym _ as arg1), (Reg64 _ as arg2)) when windows -> + i2 b "movabsq" arg1 arg2 + | MOV (arg1, arg2) -> i2_s b "mov" arg1 arg2 + | MOVAPD (arg1, arg2) -> i2 b "movapd" arg1 arg2 + | MOVLPD (arg1, arg2) -> i2 b "movlpd" arg1 arg2 + | MOVSD (arg1, arg2) -> i2 b "movsd" arg1 arg2 + | MOVSS (arg1, arg2) -> i2 b "movss" arg1 arg2 + | MOVSX (arg1, arg2) -> i2_ss b "movs" arg1 arg2 + | MOVSXD (arg1, arg2) -> i2 b "movslq" arg1 arg2 + | MOVZX (arg1, arg2) -> i2_ss b "movz" arg1 arg2 + | MULSD (arg1, arg2) -> i2 b "mulsd" arg1 arg2 + | NEG arg -> i1 b "neg" arg + | NOP -> i0 b "nop" + | OR (arg1, arg2) -> i2_s b "or" arg1 arg2 + | POP arg -> i1_s b "pop" arg + | PUSH arg -> i1_s b "push" arg + | RET -> i0 b "ret" + | ROUNDSD (r, arg1, arg2) -> i2 b (string_of_rounding r) arg1 arg2 + | SAL (arg1, arg2) -> i2_s b "sal" arg1 arg2 + | SAR (arg1, arg2) -> i2_s b "sar" arg1 arg2 + | SET (c, arg) -> i1 b ("set" ^ string_of_condition c) arg + | SHR (arg1, arg2) -> i2_s b "shr" arg1 arg2 + | SQRTSD (arg1, arg2) -> i2 b "sqrtsd" arg1 arg2 + | SUB (arg1, arg2) -> i2_s b "sub" arg1 arg2 + | SUBSD (arg1, arg2) -> i2 b "subsd" arg1 arg2 + | TEST (arg1, arg2) -> i2_s b "test" arg1 arg2 + | UCOMISD (arg1, arg2) -> i2 b "ucomisd" arg1 arg2 + | XCHG (arg1, arg2) -> i2 b "xchg" arg1 arg2 + | XOR (arg1, arg2) -> i2_s b "xor" arg1 arg2 + | XORPD (arg1, arg2) -> i2 b "xorpd" arg1 arg2 + +(* bug: + https://sourceware.org/binutils/docs-2.22/as/i386_002dBugs.html#i386_002dBugs + + The AT&T syntax has a bug for fsub/fdiv/fsubr/fdivr instructions when + the source register is %st and the destination is %st(i). In those + case, AT&T use fsub (resp. fsubr) in place of fsubr (resp. fsub), + and idem for fdiv/fdivr. + + Concretely, AT&T syntax interpretation of: + + fsub %st, %st(3) + + should normally be: + + %st(3) := %st(3) - %st + + but it should actually be interpreted as: + + %st(3) := %st - %st(3) + + which means the FSUBR instruction should be used. +*) + + +let print_line b = function + | Ins instr -> print_instr b instr + + | Align (_data,n) -> + (* MacOSX assembler interprets the integer n as a 2^n alignment *) + let n = if system = S_macosx then Misc.log2 n else n in + bprintf b "\t.align\t%d" n + | Byte n -> bprintf b "\t.byte\t%a" cst n + | Bytes s -> + if system = S_solaris then buf_bytes_directive b ".byte" s + else bprintf b "\t.ascii\t\"%s\"" (string_of_string_literal s) + | Comment s -> bprintf b "\t\t\t\t/* %s */" s + | Global s -> bprintf b "\t.globl\t%s" s; + | Long n -> bprintf b "\t.long\t%a" cst n + | NewLabel (s, _) -> bprintf b "%s:" s + | Quad n -> bprintf b "\t.quad\t%a" cst n + | Section ([".data" ], _, _) -> bprintf b "\t.data" + | Section ([".text" ], _, _) -> bprintf b "\t.text" + | Section (name, flags, args) -> + bprintf b "\t.section %s" (String.concat "," name); + begin match flags with + | None -> () + | Some flags -> bprintf b ",%S" flags + end; + begin match args with + | [] -> () + | _ -> bprintf b ",%s" (String.concat "," args) + end + | Space n -> + if system = S_solaris then bprintf b "\t.zero\t%d" n + else bprintf b "\t.space\t%d" n + | Word n -> + if system = S_solaris then bprintf b "\t.value\t%a" cst n + else bprintf b "\t.word\t%a" cst n + + (* gas only *) + | Cfi_adjust_cfa_offset n -> bprintf b "\t.cfi_adjust_cfa_offset %d" n + | Cfi_endproc -> bprintf b "\t.cfi_endproc" + | Cfi_startproc -> bprintf b "\t.cfi_startproc" + | File (file_num, file_name) -> + bprintf b "\t.file\t%d\t\"%s\"" + file_num (X86_proc.string_of_string_literal file_name) + | Indirect_symbol s -> bprintf b "\t.indirect_symbol %s" s + | Loc (file_num, line) -> bprintf b "\t.loc\t%d\t%d" file_num line + | Private_extern s -> bprintf b "\t.private_extern %s" s + | Set (arg1, arg2) -> bprintf b "\t.set %s, %a" arg1 cst arg2 + | Size (s, c) -> bprintf b "\t.size %s,%a" s cst c + | Type (s, typ) -> bprintf b "\t.type %s,%s" s typ + + (* masm only *) + | External _ + | Mode386 + | Model _ + -> assert false + +let generate_asm oc lines = + let b = Buffer.create 10000 in + List.iter + (fun i -> + Buffer.clear b; + print_line b i; + Buffer.add_char b '\n'; + Buffer.output_buffer oc b; + ) + lines diff --git a/asmcomp/x86_gas.mli b/asmcomp/x86_gas.mli new file mode 100644 index 0000000000..b25cc8f336 --- /dev/null +++ b/asmcomp/x86_gas.mli @@ -0,0 +1,15 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Fabrice Le Fessant, 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. *) +(* *) +(***********************************************************************) + +(** Emit assembly instructions for gas. *) + +val generate_asm: out_channel -> X86_ast.asm_line list -> unit diff --git a/asmcomp/x86_masm.ml b/asmcomp/x86_masm.ml new file mode 100644 index 0000000000..40f0ba06df --- /dev/null +++ b/asmcomp/x86_masm.ml @@ -0,0 +1,258 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Fabrice Le Fessant, 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. *) +(* *) +(***********************************************************************) + +open X86_ast +open X86_proc + +let bprintf = Printf.bprintf + +let string_of_datatype = function + | QWORD -> "QWORD" + | OWORD -> "OWORD" + | NONE -> assert false + | REAL4 -> "REAL4" + | REAL8 -> "REAL8" + | BYTE -> "BYTE" + | WORD -> "WORD" + | DWORD -> "DWORD" + | NEAR -> "NEAR" + | PROC -> "PROC" + + +let string_of_datatype_ptr = function + | QWORD -> "QWORD PTR " + | OWORD -> "OWORD PTR " + | NONE -> "" + | REAL4 -> "REAL4 PTR " + | REAL8 -> "REAL8 PTR " + | BYTE -> "BYTE PTR " + | WORD -> "WORD PTR " + | DWORD -> "DWORD PTR " + | NEAR -> "NEAR PTR " + | PROC -> "PROC PTR " + +let arg_mem b {arch; typ; idx; scale; base; sym; displ} = + let string_of_register = + match arch with + | X86 -> string_of_reg32 + | X64 -> string_of_reg64 + in + Buffer.add_string b (string_of_datatype_ptr typ); + Buffer.add_char b '['; + begin match sym with + | None -> () + | Some s -> Buffer.add_string b s + end; + if scale <> 0 then begin + if sym <> None then Buffer.add_char b '+'; + Buffer.add_string b (string_of_register idx); + if scale <> 1 then bprintf b "*%d" scale; + end; + begin match base with + | None -> () + | Some r -> + assert(scale > 0); + Buffer.add_char b '+'; + Buffer.add_string b (string_of_register r); + end; + begin if displ > 0 then bprintf b "+%d" displ + else if displ < 0 then bprintf b "%d" displ + end; + Buffer.add_char b ']' + +let arg b = function + | Sym s -> bprintf b "OFFSET %s" s + | Imm n when n <= 0x7FFF_FFFFL && n >= -0x8000_0000L -> bprintf b "%Ld" n + | Imm int -> bprintf b "0%LxH" int (* force ml64 to use mov reg, imm64 *) + | Reg8L x -> Buffer.add_string b (string_of_reg8l x) + | Reg8H x -> Buffer.add_string b (string_of_reg8h x) + | Reg16 x -> Buffer.add_string b (string_of_reg16 x) + | Reg32 x -> Buffer.add_string b (string_of_reg32 x) + | Reg64 x -> Buffer.add_string b (string_of_reg64 x) + | Regf x -> Buffer.add_string b (string_of_registerf x) + + (* We don't need to specify RIP on Win64, since EXTERN will provide + the list of external symbols that need this addressing mode, and + MASM will automatically use RIP addressing when needed. *) + | Mem64_RIP (typ, s, displ) -> + bprintf b "%s%s" (string_of_datatype_ptr typ) s; + if displ > 0 then bprintf b "+%d" displ + else if displ < 0 then bprintf b "%d" displ + | Mem addr -> arg_mem b addr + +let rec cst b = function + | ConstLabel _ | Const _ | ConstThis as c -> scst b c + | ConstAdd (c1, c2) -> bprintf b "%a + %a" scst c1 scst c2 + | ConstSub (c1, c2) -> bprintf b "%a - %a" scst c1 scst c2 + +and scst b = function + | ConstThis -> Buffer.add_string b "THIS BYTE" + | ConstLabel l -> Buffer.add_string b l + | Const n when n <= 0x7FFF_FFFFL && n >= -0x8000_0000L -> + Buffer.add_string b (Int64.to_string n) + | Const n -> bprintf b "0%LxH" n + | ConstAdd (c1, c2) -> bprintf b "(%a + %a)" scst c1 scst c2 + | ConstSub (c1, c2) -> bprintf b "(%a - %a)" scst c1 scst c2 + +let i0 b s = bprintf b "\t%s" s +let i1 b s x = bprintf b "\t%s\t%a" s arg x +let i2 b s x y = bprintf b "\t%s\t%a, %a" s arg y arg x + +let i1_call_jmp b s = function + | Sym x -> bprintf b "\t%s\t%s" s x + | x -> i1 b s x + +let print_instr b = function + | ADD (arg1, arg2) -> i2 b "add" arg1 arg2 + | ADDSD (arg1, arg2) -> i2 b "addsd" arg1 arg2 + | AND (arg1, arg2) -> i2 b "and" arg1 arg2 + | ANDPD (arg1, arg2) -> i2 b "andpd" arg1 arg2 + | BSWAP arg -> i1 b "bswap" arg + | CALL arg -> i1_call_jmp b "call" arg + | CDQ -> i0 b "cdq" + | CMOV (c, arg1, arg2) -> i2 b ("cmov" ^ string_of_condition c) arg1 arg2 + | CMP (arg1, arg2) -> i2 b "cmp" arg1 arg2 + | COMISD (arg1, arg2) -> i2 b "comisd" arg1 arg2 + | CQO -> i0 b "cqo" + | CVTSD2SI (arg1, arg2) -> i2 b "cvtsd2si" arg1 arg2 + | CVTSD2SS (arg1, arg2) -> i2 b "cvtsd2ss" arg1 arg2 + | CVTSI2SD (arg1, arg2) -> i2 b "cvtsi2sd" arg1 arg2 + | CVTSS2SD (arg1, arg2) -> i2 b "cvtss2sd" arg1 arg2 + | CVTTSD2SI (arg1, arg2) -> i2 b "cvttsd2si" arg1 arg2 + | DEC arg -> i1 b "dec" arg + | DIVSD (arg1, arg2) -> i2 b "divsd" arg1 arg2 + | FABS -> i0 b "fabs" + | FADD arg -> i1 b "fadd" arg + | FADDP (arg1, arg2) -> i2 b "faddp" arg1 arg2 + | FCHS -> i0 b "fchs" + | FCOMP arg -> i1 b "fcomp" arg + | FCOMPP -> i0 b "fcompp" + | FCOS -> i0 b "fcos" + | FDIV arg -> i1 b "fdiv" arg + | FDIVP (arg1, arg2) -> i2 b "fdivp" arg1 arg2 + | FDIVR arg -> i1 b "fdivr" arg + | FDIVRP (arg1, arg2) -> i2 b "fdivrp" arg1 arg2 + | FILD arg -> i1 b "fild" arg + | FISTP arg -> i1 b "fistp" arg + | FLD arg -> i1 b "fld" arg + | FLD1 -> i0 b "fld1" + | FLDCW arg -> i1 b "fldcw" arg + | FLDLG2 -> i0 b "fldlg2" + | FLDLN2 -> i0 b "fldln2" + | FLDZ -> i0 b "fldz" + | FMUL arg -> i1 b "fmul" arg + | FMULP (arg1, arg2) -> i2 b "fmulp" arg1 arg2 + | FNSTCW arg -> i1 b "fnstcw" arg + | FNSTSW arg -> i1 b "fnstsw" arg + | FPATAN -> i0 b "fpatan" + | FPTAN -> i0 b "fptan" + | FSIN -> i0 b "fsin" + | FSQRT -> i0 b "fsqrt" + | FSTP arg -> i1 b "fstp" arg + | FSUB arg -> i1 b "fsub" arg + | FSUBP (arg1, arg2) -> i2 b "fsubp" arg1 arg2 + | FSUBR arg -> i1 b "fsubr" arg + | FSUBRP (arg1, arg2) -> i2 b "fsubrp" arg1 arg2 + | FXCH arg -> i1 b "fxch" arg + | FYL2X -> i0 b "fyl2x" + | HLT -> assert false + | IDIV arg -> i1 b "idiv" arg + | IMUL (arg, None) -> i1 b "imul" arg + | IMUL (arg1, Some arg2) -> i2 b "imul" arg1 arg2 + | INC arg -> i1 b "inc" arg + | J (c, arg) -> i1_call_jmp b ("j" ^ string_of_condition c) arg + | JMP arg -> i1_call_jmp b "jmp" arg + | LEA (arg1, arg2) -> i2 b "lea" arg1 arg2 + | LEAVE -> i0 b "leave" + | MOV (Imm n as arg1, Reg64 r) when + n >= 0x8000_0000L && n <= 0xFFFF_FFFFL -> + (* Work-around a bug in ml64. Use a mov to the corresponding + 32-bit lower register when the constant fits in 32-bit. + The associated higher 32-bit register will be zeroed. *) + i2 b "mov" arg1 (Reg32 r) + | MOV (arg1, arg2) -> i2 b "mov" arg1 arg2 + | MOVAPD (arg1, arg2) -> i2 b "movapd" arg1 arg2 + | MOVLPD (arg1, arg2) -> i2 b "movlpd" arg1 arg2 + | MOVSD (arg1, arg2) -> i2 b "movsd" arg1 arg2 + | MOVSS (arg1, arg2) -> i2 b "movss" arg1 arg2 + | MOVSX (arg1, arg2) -> i2 b "movsx" arg1 arg2 + | MOVSXD (arg1, arg2) -> i2 b "movsxd" arg1 arg2 + | MOVZX (arg1, arg2) -> i2 b "movzx" arg1 arg2 + | MULSD (arg1, arg2) -> i2 b "mulsd" arg1 arg2 + | NEG arg -> i1 b "neg" arg + | NOP -> i0 b "nop" + | OR (arg1, arg2) -> i2 b "or" arg1 arg2 + | POP arg -> i1 b "pop" arg + | PUSH arg -> i1 b "push" arg + | RET -> i0 b "ret" + | ROUNDSD (r, arg1, arg2) -> i2 b (string_of_rounding r) arg1 arg2 + | SAL (arg1, arg2) -> i2 b "sal" arg1 arg2 + | SAR (arg1, arg2) -> i2 b "sar" arg1 arg2 + | SET (c, arg) -> i1 b ("set" ^ string_of_condition c) arg + | SHR (arg1, arg2) -> i2 b "shr" arg1 arg2 + | SQRTSD (arg1, arg2) -> i2 b "sqrtsd" arg1 arg2 + | SUB (arg1, arg2) -> i2 b "sub" arg1 arg2 + | SUBSD (arg1, arg2) -> i2 b "subsd" arg1 arg2 + | TEST (arg1, arg2) -> i2 b "test" arg1 arg2 + | UCOMISD (arg1, arg2) -> i2 b "ucomisd" arg1 arg2 + | XCHG (arg1, arg2) -> i2 b "xchg" arg1 arg2 + | XOR (arg1, arg2) -> i2 b "xor" arg1 arg2 + | XORPD (arg1, arg2) -> i2 b "xorpd" arg1 arg2 + + +let print_line b = function + | Ins instr -> print_instr b instr + + | Align (_data,n) -> bprintf b "\tALIGN\t%d" n + | Byte n -> bprintf b "\tBYTE\t%a" cst n + | Bytes s -> buf_bytes_directive b "BYTE" s + | Comment s -> bprintf b " ; %s " s + | Global s -> bprintf b "\tPUBLIC\t%s" s + | Long n -> bprintf b "\tDWORD\t%a" cst n + | NewLabel (s, NONE) -> bprintf b "%s:" s + | NewLabel (s, ptr) -> bprintf b "%s LABEL %s" s (string_of_datatype ptr) + | Quad n -> bprintf b "\tQWORD\t%a" cst n + | Section ([".data"], None, []) -> bprintf b "\t.DATA" + | Section ([".text"], None, []) -> bprintf b "\t.CODE" + | Section _ -> assert false + | Space n -> bprintf b "\tBYTE\t%d DUP (?)" n + | Word n -> bprintf b "\tWORD\t%a" cst n + + (* windows only *) + | External (s, ptr) -> bprintf b "\tEXTRN\t%s: %s" s (string_of_datatype ptr) + | Mode386 -> bprintf b "\t.386" + | Model name -> bprintf b "\t.MODEL %s" name (* name = FLAT *) + + (* gas only *) + | Cfi_adjust_cfa_offset _ + | Cfi_endproc + | Cfi_startproc + | File _ + | Indirect_symbol _ + | Loc _ + | Private_extern _ + | Set _ + | Size _ + | Type _ + -> assert false + +let generate_asm oc lines = + let b = Buffer.create 10000 in + List.iter + (fun i -> + Buffer.clear b; + print_line b i; + Buffer.add_char b '\n'; + Buffer.output_buffer oc b + ) + lines; + output_string oc "\tEND\n" diff --git a/asmcomp/x86_masm.mli b/asmcomp/x86_masm.mli new file mode 100644 index 0000000000..1b3a6e066d --- /dev/null +++ b/asmcomp/x86_masm.mli @@ -0,0 +1,15 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Fabrice Le Fessant, 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. *) +(* *) +(***********************************************************************) + +(** Emit assembly instructions for MASM (Intel syntax). *) + +val generate_asm: out_channel -> X86_ast.asm_line list -> unit diff --git a/asmcomp/x86_proc.ml b/asmcomp/x86_proc.ml new file mode 100644 index 0000000000..70b92b2fe5 --- /dev/null +++ b/asmcomp/x86_proc.ml @@ -0,0 +1,273 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Fabrice Le Fessant, 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. *) +(* *) +(***********************************************************************) + +open X86_ast + +type system = + (* 32 bits and 64 bits *) + | S_macosx + | S_gnu + | S_cygwin + + (* 32 bits only *) + | S_solaris + | S_win32 + | S_linux_elf + | S_bsd_elf + | S_beos + | S_mingw + + (* 64 bits only *) + | S_win64 + | S_linux + | S_mingw64 + + | S_unknown + + +let system = match Config.system with + | "macosx" -> S_macosx + | "solaris" -> S_solaris + | "win32" -> S_win32 + | "linux_elf" -> S_linux_elf + | "bsd_elf" -> S_bsd_elf + | "beos" -> S_beos + | "gnu" -> S_gnu + | "cygwin" -> S_cygwin + | "mingw" -> S_mingw + | "mingw64" -> S_mingw64 + | "win64" -> S_win64 + | "linux" -> S_linux + + | _ -> S_unknown + +let windows = + match system with + | S_mingw64 | S_cygwin | S_win64 -> true + | _ -> false + +let string_of_string_literal s = + let b = Buffer.create (String.length s + 2) in + let last_was_escape = ref false in + for i = 0 to String.length s - 1 do + let c = s.[i] in + if c >= '0' && c <= '9' then + if !last_was_escape + then Printf.bprintf b "\\%o" (Char.code c) + else Buffer.add_char b c + else if c >= ' ' && c <= '~' && c <> '"' (* '"' *) && c <> '\\' then begin + Buffer.add_char b c; + last_was_escape := false + end else begin + Printf.bprintf b "\\%o" (Char.code c); + last_was_escape := true + end + done; + Buffer.contents b + +let string_of_symbol prefix s = + let spec = ref false in + for i = 0 to String.length s - 1 do + match String.unsafe_get s i with + | 'A'..'Z' | 'a'..'z' | '0'..'9' | '_' -> () + | _ -> spec := true; + done; + if not !spec then if prefix = "" then s else prefix ^ s + else + let b = Buffer.create (String.length s + 10) in + Buffer.add_string b prefix; + String.iter + (function + | ('A'..'Z' | 'a'..'z' | '0'..'9' | '_') as c -> Buffer.add_char b c + | c -> Printf.bprintf b "$%02x" (Char.code c) + ) + s; + Buffer.contents b + +let buf_bytes_directive b directive s = + let pos = ref 0 in + for i = 0 to String.length s - 1 do + if !pos = 0 + then begin + if i > 0 then Buffer.add_char b '\n'; + Buffer.add_char b '\t'; + Buffer.add_string b directive; + Buffer.add_char b '\t'; + end + else Buffer.add_char b ','; + Printf.bprintf b "%d" (Char.code s.[i]); + incr pos; + if !pos >= 16 then begin pos := 0 end + done + +let string_of_reg64 = function + | RAX -> "rax" + | RBX -> "rbx" + | RDI -> "rdi" + | RSI -> "rsi" + | RDX -> "rdx" + | RCX -> "rcx" + | RBP -> "rbp" + | RSP -> "rsp" + | R8 -> "r8" + | R9 -> "r9" + | R10 -> "r10" + | R11 -> "r11" + | R12 -> "r12" + | R13 -> "r13" + | R14 -> "r14" + | R15 -> "r15" + +let string_of_reg8l = function + | RAX -> "al" + | RBX -> "bl" + | RCX -> "cl" + | RDX -> "dl" + | RSP -> "spl" + | RBP -> "bpl" + | RSI -> "sil" + | RDI -> "dil" + | R8 -> "r8b" + | R9 -> "r9b" + | R10 -> "r10b" + | R11 -> "r11b" + | R12 -> "r12b" + | R13 -> "r13b" + | R14 -> "r14b" + | R15 -> "r15b" + +let string_of_reg8h = function + | AH -> "ah" + | BH -> "bh" + | CH -> "ch" + | DH -> "dh" + +let string_of_reg16 = function + | RAX -> "ax" + | RBX -> "bx" + | RCX -> "cx" + | RDX -> "dx" + | RSP -> "sp" + | RBP -> "bp" + | RSI -> "si" + | RDI -> "di" + | R8 -> "r8w" + | R9 -> "r9w" + | R10 -> "r10w" + | R11 -> "r11w" + | R12 -> "r12w" + | R13 -> "r13w" + | R14 -> "r14w" + | R15 -> "r15w" + +let string_of_reg32 = function + | RAX -> "eax" + | RBX -> "ebx" + | RCX -> "ecx" + | RDX -> "edx" + | RSP -> "esp" + | RBP -> "ebp" + | RSI -> "esi" + | RDI -> "edi" + | R8 -> "r8d" + | R9 -> "r9d" + | R10 -> "r10d" + | R11 -> "r11d" + | R12 -> "r12d" + | R13 -> "r13d" + | R14 -> "r14d" + | R15 -> "r15d" + +let string_of_registerf = function + | XMM n -> Printf.sprintf "xmm%d" n + | TOS -> Printf.sprintf "tos" + | ST n -> Printf.sprintf "st(%d)" n + +let string_of_condition = function + | E -> "e" + | AE -> "ae" + | A -> "a" + | GE -> "ge" + | G -> "g" + | NE -> "ne" + | B -> "b" + | BE -> "be" + | L -> "l" + | LE -> "le" + | NP -> "np" + | P -> "p" + | NS -> "ns" + | S -> "s" + | NO -> "no" + | O -> "o" + +let string_of_rounding = function + | RoundDown -> "roundsd.down" + | RoundUp -> "roundsd.up" + | RoundTruncate -> "roundsd.trunc" + | RoundNearest -> "roundsd.near" + + +(* These hooks can be used to insert optimization passes on + the assembly code. *) +let assembler_passes = ref ([] : (asm_program -> asm_program) list) + +let internal_assembler = ref None +let register_internal_assembler f = internal_assembler := Some f + +(* Which asm conventions to use *) +let masm = + match system with + | S_win32 | S_win64 -> true + | _ -> false + +(* Shall we use an external assembler command ? + If [binary_content] contains some data, we can directly + save it. Otherwise, we have to ask an external command. +*) +let binary_content = ref None + +let compile infile outfile = + if masm then + Ccomp.command (Config.asm ^ + Filename.quote outfile ^ " " ^ Filename.quote infile ^ + (if !Clflags.verbose then "" else ">NUL")) + else + Ccomp.command (Config.asm ^ " -o " ^ + Filename.quote outfile ^ " " ^ Filename.quote infile) + +let assemble_file infile outfile = + match !binary_content with + | None -> compile infile outfile + | Some content -> content outfile; binary_content := None; 0 + +let asm_code = ref [] + +let directive dir = asm_code := dir :: !asm_code +let emit ins = directive (Ins ins) + +let reset_asm_code () = asm_code := [] + +let generate_code asm = + let instrs = List.rev !asm_code in + let instrs = + List.fold_left (fun instrs pass -> pass instrs) instrs !assembler_passes + in + begin match asm with + | Some f -> f instrs + | None -> () + end; + begin match !internal_assembler with + | Some f -> binary_content := Some (f instrs) + | None -> binary_content := None + end + diff --git a/asmcomp/x86_proc.mli b/asmcomp/x86_proc.mli new file mode 100644 index 0000000000..40f49af5f8 --- /dev/null +++ b/asmcomp/x86_proc.mli @@ -0,0 +1,87 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Fabrice Le Fessant, 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. *) +(* *) +(***********************************************************************) + + +(** Definitions shared between the 32 and 64 bit Intel backends. *) + +open X86_ast + +(** Helpers for textual emitters *) + +val string_of_reg8l: reg64 -> string +val string_of_reg8h: reg8h -> string +val string_of_reg16: reg64 -> string +val string_of_reg32: reg64 -> string +val string_of_reg64: reg64 -> string +val string_of_registerf: registerf -> string +val string_of_string_literal: string -> string +val string_of_condition: condition -> string +val string_of_symbol: (*prefix*) string -> string -> string +val string_of_rounding: rounding -> string +val buf_bytes_directive: Buffer.t -> (*directive*) string -> (*data*)string -> unit + + +(** Buffer of assembly code *) + +val emit: instruction -> unit +val directive: asm_line -> unit +val reset_asm_code: unit -> unit + +(** Code emission *) + +val generate_code: (X86_ast.asm_line list -> unit) option -> unit + (** Post-process the stream of instructions. Dump it (using + the provided syntax emitter) in a file (if provided) and + compile it with an internal assembler (if registered + through [register_internal_assembler]). *) + +val assemble_file: (*infile*) string -> (*outfile*) string -> (*retcode*) int +(** Generate an object file corresponding to the last call to + [generate_code]. An internal assembler is used if available (and + the input file is ignored). Otherwise, the source asm file with an + external assembler. *) + +(** System detection *) + +type system = + (* 32 bits and 64 bits *) + | S_macosx + | S_gnu + | S_cygwin + + (* 32 bits only *) + | S_solaris + | S_win32 + | S_linux_elf + | S_bsd_elf + | S_beos + | S_mingw + + (* 64 bits only *) + | S_win64 + | S_linux + | S_mingw64 + + | S_unknown + +val system: system +val masm: bool +val windows:bool + +(** Support for plumbing a binary code emitter *) + +val register_internal_assembler: (asm_program -> string -> unit) -> unit + + +(** Hooks for rewriting the assembly code *) + +val assembler_passes: (asm_program -> asm_program) list ref diff --git a/asmrun/.depend b/asmrun/.depend index 1088ad8ed0..090d19cd4f 100644 --- a/asmrun/.depend +++ b/asmrun/.depend @@ -1,753 +1,1113 @@ -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 \ +alloc.o: alloc.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/custom.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/major_gc.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/stacks.h \ + ../byterun/caml/memory.h +array.o: array.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h +backtrace.o: backtrace.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/backtrace.h ../byterun/caml/exec.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h stack.h +callback.o: callback.c ../byterun/caml/callback.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/misc.h ../byterun/caml/fail.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/mlvalues.h +compact.o: compact.c ../byterun/caml/address_class.h \ + ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/finalise.h ../byterun/caml/roots.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/freelist.h ../byterun/caml/gc.h \ + ../byterun/caml/gc_ctrl.h ../byterun/caml/major_gc.h \ + ../byterun/caml/memory.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/roots.h ../byterun/caml/weak.h +compare.o: compare.c ../byterun/caml/custom.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/misc.h \ + ../byterun/caml/fail.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h +custom.o: custom.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/custom.h ../byterun/caml/fail.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/mlvalues.h +debugger.o: debugger.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/config.h ../byterun/caml/debugger.h \ + ../byterun/caml/misc.h +dynlink.o: dynlink.c ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/alloc.h ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/dynlink.h \ + ../byterun/caml/fail.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/misc.h ../byterun/caml/osdeps.h ../byterun/caml/prims.h \ + ../byterun/caml/signals.h +extern.o: extern.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/custom.h ../byterun/caml/fail.h ../byterun/caml/gc.h \ + ../byterun/caml/intext.h ../byterun/caml/io.h ../byterun/caml/io.h \ + ../byterun/caml/md5.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/reverse.h +fail.o: fail.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h ../byterun/caml/io.h ../byterun/caml/gc.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/printexc.h \ + ../byterun/caml/signals.h stack.h ../byterun/caml/roots.h \ + ../byterun/caml/memory.h ../byterun/caml/callback.h +finalise.o: finalise.c ../byterun/caml/callback.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/misc.h ../byterun/caml/fail.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/roots.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/signals.h +floats.o: floats.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/misc.h \ + ../byterun/caml/reverse.h ../byterun/caml/stacks.h \ + ../byterun/caml/memory.h +freelist.o: freelist.c ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/freelist.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/gc.h ../byterun/caml/gc_ctrl.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/major_gc.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h +gc_ctrl.o: gc_ctrl.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/compact.h ../byterun/caml/custom.h \ + ../byterun/caml/finalise.h ../byterun/caml/roots.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/freelist.h ../byterun/caml/gc.h \ + ../byterun/caml/gc_ctrl.h ../byterun/caml/major_gc.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/misc.h \ + ../byterun/caml/mlvalues.h stack.h +globroots.o: globroots.c ../byterun/caml/memory.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/gc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/misc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/roots.h ../byterun/caml/memory.h \ + ../byterun/caml/globroots.h ../byterun/caml/roots.h +hash.o: hash.c ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/misc.h ../byterun/caml/custom.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/hash.h +intern.o: intern.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/callback.h ../byterun/caml/custom.h \ + ../byterun/caml/fail.h ../byterun/caml/gc.h ../byterun/caml/intext.h \ + ../byterun/caml/io.h ../byterun/caml/io.h ../byterun/caml/md5.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/misc.h \ + ../byterun/caml/reverse.h +ints.o: ints.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/custom.h ../byterun/caml/fail.h \ + ../byterun/caml/intext.h ../byterun/caml/io.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/misc.h \ + ../byterun/caml/mlvalues.h +io.o: io.c ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/alloc.h \ + ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/custom.h \ + ../byterun/caml/fail.h ../byterun/caml/io.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/misc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/signals.h \ + ../byterun/caml/sys.h +lexing.o: lexing.c ../byterun/caml/fail.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/stacks.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h +main.o: main.c ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/misc.h ../byterun/caml/sys.h +major_gc.o: major_gc.c ../byterun/caml/compact.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/misc.h ../byterun/caml/custom.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/fail.h ../byterun/caml/finalise.h \ + ../byterun/caml/roots.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/freelist.h ../byterun/caml/gc.h \ + ../byterun/caml/gc_ctrl.h ../byterun/caml/major_gc.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/roots.h ../byterun/caml/weak.h +md5.o: md5.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h ../byterun/caml/md5.h ../byterun/caml/io.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/io.h \ + ../byterun/caml/reverse.h +memory.o: memory.c ../byterun/caml/address_class.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h ../byterun/caml/freelist.h ../byterun/caml/gc.h \ + ../byterun/caml/gc_ctrl.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/major_gc.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/misc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/signals.h +meta.o: meta.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/config.h ../byterun/caml/fail.h \ + ../byterun/caml/fix_code.h ../byterun/caml/interp.h \ + ../byterun/caml/intext.h ../byterun/caml/io.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/prims.h ../byterun/caml/stacks.h \ + ../byterun/caml/memory.h +minor_gc.o: minor_gc.c ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/fail.h ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/finalise.h \ + ../byterun/caml/roots.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/gc.h ../byterun/caml/gc_ctrl.h \ + ../byterun/caml/major_gc.h ../byterun/caml/memory.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/misc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/roots.h \ + ../byterun/caml/signals.h ../byterun/caml/weak.h +misc.o: misc.c ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/misc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h +natdynlink.o: natdynlink.c ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/misc.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h stack.h ../byterun/caml/callback.h \ + ../byterun/caml/alloc.h ../byterun/caml/intext.h ../byterun/caml/io.h \ + ../byterun/caml/osdeps.h ../byterun/caml/fail.h \ + ../byterun/caml/signals.h +obj.o: obj.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h ../byterun/caml/gc.h ../byterun/caml/interp.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/prims.h +parsing.o: parsing.c ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/misc.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/alloc.h +printexc.o: printexc.c ../byterun/caml/backtrace.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/misc.h ../byterun/caml/exec.h \ + ../byterun/caml/callback.h ../byterun/caml/debugger.h \ + ../byterun/caml/fail.h ../byterun/caml/misc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/printexc.h +roots.o: roots.c ../byterun/caml/finalise.h ../byterun/caml/roots.h \ + ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/globroots.h \ + ../byterun/caml/memory.h ../byterun/caml/major_gc.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/misc.h \ + ../byterun/caml/mlvalues.h stack.h ../byterun/caml/roots.h +signals.o: signals.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/callback.h ../byterun/caml/config.h \ + ../byterun/caml/fail.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/roots.h ../byterun/caml/memory.h \ + ../byterun/caml/signals.h ../byterun/caml/signals_machdep.h \ + ../byterun/caml/sys.h +signals_asm.o: signals_asm.c ../byterun/caml/fail.h \ + ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/osdeps.h \ + ../byterun/caml/signals.h ../byterun/caml/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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 \ +startup.o: startup.c ../byterun/caml/callback.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/misc.h ../byterun/caml/backtrace.h \ + ../byterun/caml/exec.h ../byterun/caml/custom.h \ + ../byterun/caml/debugger.h ../byterun/caml/fail.h \ + ../byterun/caml/freelist.h ../byterun/caml/gc.h \ + ../byterun/caml/gc_ctrl.h ../byterun/caml/intext.h ../byterun/caml/io.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/osdeps.h ../byterun/caml/printexc.h stack.h \ + ../byterun/caml/startup_aux.h ../byterun/caml/sys.h +startup_aux.o: startup_aux.c ../byterun/caml/backtrace.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/misc.h ../byterun/caml/exec.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/startup_aux.h +str.o: str.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/misc.h +sys.o: sys.c ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/alloc.h \ + ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/debugger.h \ + ../byterun/caml/fail.h ../byterun/caml/instruct.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/osdeps.h \ + ../byterun/caml/signals.h ../byterun/caml/stacks.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/sys.h ../byterun/caml/gc_ctrl.h +terminfo.o: terminfo.c ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/alloc.h ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/fail.h ../byterun/caml/io.h \ + ../byterun/caml/mlvalues.h +unix.o: unix.c ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/memory.h \ + ../byterun/caml/config.h ../byterun/caml/gc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/misc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/misc.h ../byterun/caml/osdeps.h +weak.o: weak.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/major_gc.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/mlvalues.h +alloc.d.o: alloc.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/custom.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/major_gc.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/stacks.h \ + ../byterun/caml/memory.h +array.d.o: array.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h +backtrace.d.o: backtrace.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/backtrace.h ../byterun/caml/exec.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h stack.h +callback.d.o: callback.c ../byterun/caml/callback.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/misc.h ../byterun/caml/fail.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/mlvalues.h +compact.d.o: compact.c ../byterun/caml/address_class.h \ + ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/finalise.h ../byterun/caml/roots.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/freelist.h ../byterun/caml/gc.h \ + ../byterun/caml/gc_ctrl.h ../byterun/caml/major_gc.h \ + ../byterun/caml/memory.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/roots.h ../byterun/caml/weak.h +compare.d.o: compare.c ../byterun/caml/custom.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/misc.h \ + ../byterun/caml/fail.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h +custom.d.o: custom.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/custom.h ../byterun/caml/fail.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/mlvalues.h +debugger.d.o: debugger.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/config.h ../byterun/caml/debugger.h \ + ../byterun/caml/misc.h +dynlink.d.o: dynlink.c ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/alloc.h ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/dynlink.h \ + ../byterun/caml/fail.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/misc.h ../byterun/caml/osdeps.h ../byterun/caml/prims.h \ + ../byterun/caml/signals.h +extern.d.o: extern.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/custom.h ../byterun/caml/fail.h ../byterun/caml/gc.h \ + ../byterun/caml/intext.h ../byterun/caml/io.h ../byterun/caml/io.h \ + ../byterun/caml/md5.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/reverse.h +fail.d.o: fail.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h ../byterun/caml/io.h ../byterun/caml/gc.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/printexc.h \ + ../byterun/caml/signals.h stack.h ../byterun/caml/roots.h \ + ../byterun/caml/memory.h ../byterun/caml/callback.h +finalise.d.o: finalise.c ../byterun/caml/callback.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/misc.h ../byterun/caml/fail.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/roots.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/signals.h +floats.d.o: floats.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/misc.h \ + ../byterun/caml/reverse.h ../byterun/caml/stacks.h \ + ../byterun/caml/memory.h +freelist.d.o: freelist.c ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/freelist.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/gc.h ../byterun/caml/gc_ctrl.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/major_gc.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h +gc_ctrl.d.o: gc_ctrl.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/compact.h ../byterun/caml/custom.h \ + ../byterun/caml/finalise.h ../byterun/caml/roots.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/freelist.h ../byterun/caml/gc.h \ + ../byterun/caml/gc_ctrl.h ../byterun/caml/major_gc.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/misc.h \ + ../byterun/caml/mlvalues.h stack.h +globroots.d.o: globroots.c ../byterun/caml/memory.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/gc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/misc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/roots.h ../byterun/caml/memory.h \ + ../byterun/caml/globroots.h ../byterun/caml/roots.h +hash.d.o: hash.c ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/misc.h ../byterun/caml/custom.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/hash.h +intern.d.o: intern.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/callback.h ../byterun/caml/custom.h \ + ../byterun/caml/fail.h ../byterun/caml/gc.h ../byterun/caml/intext.h \ + ../byterun/caml/io.h ../byterun/caml/io.h ../byterun/caml/md5.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/misc.h \ + ../byterun/caml/reverse.h +ints.d.o: ints.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/custom.h ../byterun/caml/fail.h \ + ../byterun/caml/intext.h ../byterun/caml/io.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/misc.h \ + ../byterun/caml/mlvalues.h +io.d.o: io.c ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/alloc.h \ + ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/custom.h \ + ../byterun/caml/fail.h ../byterun/caml/io.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/misc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/signals.h \ + ../byterun/caml/sys.h +lexing.d.o: lexing.c ../byterun/caml/fail.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/stacks.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h +main.d.o: main.c ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/misc.h ../byterun/caml/sys.h +major_gc.d.o: major_gc.c ../byterun/caml/compact.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/misc.h ../byterun/caml/custom.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/fail.h ../byterun/caml/finalise.h \ + ../byterun/caml/roots.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/freelist.h ../byterun/caml/gc.h \ + ../byterun/caml/gc_ctrl.h ../byterun/caml/major_gc.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/roots.h ../byterun/caml/weak.h +md5.d.o: md5.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h ../byterun/caml/md5.h ../byterun/caml/io.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/io.h \ + ../byterun/caml/reverse.h +memory.d.o: memory.c ../byterun/caml/address_class.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h ../byterun/caml/freelist.h ../byterun/caml/gc.h \ + ../byterun/caml/gc_ctrl.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/major_gc.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/misc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/signals.h +meta.d.o: meta.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/config.h ../byterun/caml/fail.h \ + ../byterun/caml/fix_code.h ../byterun/caml/interp.h \ + ../byterun/caml/intext.h ../byterun/caml/io.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/prims.h ../byterun/caml/stacks.h \ + ../byterun/caml/memory.h +minor_gc.d.o: minor_gc.c ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/fail.h ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/finalise.h \ + ../byterun/caml/roots.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/gc.h ../byterun/caml/gc_ctrl.h \ + ../byterun/caml/major_gc.h ../byterun/caml/memory.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/misc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/roots.h \ + ../byterun/caml/signals.h ../byterun/caml/weak.h +misc.d.o: misc.c ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/misc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h +natdynlink.d.o: natdynlink.c ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/misc.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h stack.h ../byterun/caml/callback.h \ + ../byterun/caml/alloc.h ../byterun/caml/intext.h ../byterun/caml/io.h \ + ../byterun/caml/osdeps.h ../byterun/caml/fail.h \ + ../byterun/caml/signals.h +obj.d.o: obj.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h ../byterun/caml/gc.h ../byterun/caml/interp.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/prims.h +parsing.d.o: parsing.c ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/misc.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/alloc.h +printexc.d.o: printexc.c ../byterun/caml/backtrace.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/misc.h ../byterun/caml/exec.h \ + ../byterun/caml/callback.h ../byterun/caml/debugger.h \ + ../byterun/caml/fail.h ../byterun/caml/misc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/printexc.h +roots.d.o: roots.c ../byterun/caml/finalise.h ../byterun/caml/roots.h \ + ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/globroots.h \ + ../byterun/caml/memory.h ../byterun/caml/major_gc.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/misc.h \ + ../byterun/caml/mlvalues.h stack.h ../byterun/caml/roots.h +signals.d.o: signals.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/callback.h ../byterun/caml/config.h \ + ../byterun/caml/fail.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/roots.h ../byterun/caml/memory.h \ + ../byterun/caml/signals.h ../byterun/caml/signals_machdep.h \ + ../byterun/caml/sys.h +signals_asm.d.o: signals_asm.c ../byterun/caml/fail.h \ + ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/osdeps.h \ + ../byterun/caml/signals.h ../byterun/caml/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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 \ +startup.d.o: startup.c ../byterun/caml/callback.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/misc.h ../byterun/caml/backtrace.h \ + ../byterun/caml/exec.h ../byterun/caml/custom.h \ + ../byterun/caml/debugger.h ../byterun/caml/fail.h \ + ../byterun/caml/freelist.h ../byterun/caml/gc.h \ + ../byterun/caml/gc_ctrl.h ../byterun/caml/intext.h ../byterun/caml/io.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/osdeps.h ../byterun/caml/printexc.h stack.h \ + ../byterun/caml/startup_aux.h ../byterun/caml/sys.h +startup_aux.d.o: startup_aux.c ../byterun/caml/backtrace.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/misc.h ../byterun/caml/exec.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/startup_aux.h +str.d.o: str.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/misc.h +sys.d.o: sys.c ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/alloc.h \ + ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/debugger.h \ + ../byterun/caml/fail.h ../byterun/caml/instruct.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/osdeps.h \ + ../byterun/caml/signals.h ../byterun/caml/stacks.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/sys.h ../byterun/caml/gc_ctrl.h +terminfo.d.o: terminfo.c ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/alloc.h ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/fail.h ../byterun/caml/io.h \ + ../byterun/caml/mlvalues.h +unix.d.o: unix.c ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/memory.h \ + ../byterun/caml/config.h ../byterun/caml/gc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/misc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/misc.h ../byterun/caml/osdeps.h +weak.d.o: weak.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/major_gc.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/mlvalues.h +alloc.p.o: alloc.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/custom.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/major_gc.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/stacks.h \ + ../byterun/caml/memory.h +array.p.o: array.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h +backtrace.p.o: backtrace.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/backtrace.h ../byterun/caml/exec.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h stack.h +callback.p.o: callback.c ../byterun/caml/callback.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/misc.h ../byterun/caml/fail.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/mlvalues.h +compact.p.o: compact.c ../byterun/caml/address_class.h \ + ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/finalise.h ../byterun/caml/roots.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/freelist.h ../byterun/caml/gc.h \ + ../byterun/caml/gc_ctrl.h ../byterun/caml/major_gc.h \ + ../byterun/caml/memory.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/roots.h ../byterun/caml/weak.h +compare.p.o: compare.c ../byterun/caml/custom.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/misc.h \ + ../byterun/caml/fail.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h +custom.p.o: custom.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/custom.h ../byterun/caml/fail.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/mlvalues.h +debugger.p.o: debugger.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/config.h ../byterun/caml/debugger.h \ + ../byterun/caml/misc.h +dynlink.p.o: dynlink.c ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/alloc.h ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/dynlink.h \ + ../byterun/caml/fail.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/misc.h ../byterun/caml/osdeps.h ../byterun/caml/prims.h \ + ../byterun/caml/signals.h +extern.p.o: extern.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/custom.h ../byterun/caml/fail.h ../byterun/caml/gc.h \ + ../byterun/caml/intext.h ../byterun/caml/io.h ../byterun/caml/io.h \ + ../byterun/caml/md5.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/reverse.h +fail.p.o: fail.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h ../byterun/caml/io.h ../byterun/caml/gc.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/printexc.h \ + ../byterun/caml/signals.h stack.h ../byterun/caml/roots.h \ + ../byterun/caml/memory.h ../byterun/caml/callback.h +finalise.p.o: finalise.c ../byterun/caml/callback.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/misc.h ../byterun/caml/fail.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/roots.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/signals.h +floats.p.o: floats.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/misc.h \ + ../byterun/caml/reverse.h ../byterun/caml/stacks.h \ + ../byterun/caml/memory.h +freelist.p.o: freelist.c ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/freelist.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/gc.h ../byterun/caml/gc_ctrl.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/major_gc.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h +gc_ctrl.p.o: gc_ctrl.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/compact.h ../byterun/caml/custom.h \ + ../byterun/caml/finalise.h ../byterun/caml/roots.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/freelist.h ../byterun/caml/gc.h \ + ../byterun/caml/gc_ctrl.h ../byterun/caml/major_gc.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/misc.h \ + ../byterun/caml/mlvalues.h stack.h +globroots.p.o: globroots.c ../byterun/caml/memory.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/gc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/misc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/roots.h ../byterun/caml/memory.h \ + ../byterun/caml/globroots.h ../byterun/caml/roots.h +hash.p.o: hash.c ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/misc.h ../byterun/caml/custom.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/hash.h +intern.p.o: intern.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/callback.h ../byterun/caml/custom.h \ + ../byterun/caml/fail.h ../byterun/caml/gc.h ../byterun/caml/intext.h \ + ../byterun/caml/io.h ../byterun/caml/io.h ../byterun/caml/md5.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/misc.h \ + ../byterun/caml/reverse.h +ints.p.o: ints.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/custom.h ../byterun/caml/fail.h \ + ../byterun/caml/intext.h ../byterun/caml/io.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/misc.h \ + ../byterun/caml/mlvalues.h +io.p.o: io.c ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/alloc.h \ + ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/custom.h \ + ../byterun/caml/fail.h ../byterun/caml/io.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/misc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/signals.h \ + ../byterun/caml/sys.h +lexing.p.o: lexing.c ../byterun/caml/fail.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/stacks.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h +main.p.o: main.c ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/misc.h ../byterun/caml/sys.h +major_gc.p.o: major_gc.c ../byterun/caml/compact.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/misc.h ../byterun/caml/custom.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/fail.h ../byterun/caml/finalise.h \ + ../byterun/caml/roots.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/freelist.h ../byterun/caml/gc.h \ + ../byterun/caml/gc_ctrl.h ../byterun/caml/major_gc.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/roots.h ../byterun/caml/weak.h +md5.p.o: md5.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h ../byterun/caml/md5.h ../byterun/caml/io.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/io.h \ + ../byterun/caml/reverse.h +memory.p.o: memory.c ../byterun/caml/address_class.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h ../byterun/caml/freelist.h ../byterun/caml/gc.h \ + ../byterun/caml/gc_ctrl.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/major_gc.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/misc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/signals.h +meta.p.o: meta.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/config.h ../byterun/caml/fail.h \ + ../byterun/caml/fix_code.h ../byterun/caml/interp.h \ + ../byterun/caml/intext.h ../byterun/caml/io.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/prims.h ../byterun/caml/stacks.h \ + ../byterun/caml/memory.h +minor_gc.p.o: minor_gc.c ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/fail.h ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/finalise.h \ + ../byterun/caml/roots.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/gc.h ../byterun/caml/gc_ctrl.h \ + ../byterun/caml/major_gc.h ../byterun/caml/memory.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/misc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/roots.h \ + ../byterun/caml/signals.h ../byterun/caml/weak.h +misc.p.o: misc.c ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/misc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h +natdynlink.p.o: natdynlink.c ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/misc.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h stack.h ../byterun/caml/callback.h \ + ../byterun/caml/alloc.h ../byterun/caml/intext.h ../byterun/caml/io.h \ + ../byterun/caml/osdeps.h ../byterun/caml/fail.h \ + ../byterun/caml/signals.h +obj.p.o: obj.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h ../byterun/caml/gc.h ../byterun/caml/interp.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/prims.h +parsing.p.o: parsing.c ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/misc.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/alloc.h +printexc.p.o: printexc.c ../byterun/caml/backtrace.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/misc.h ../byterun/caml/exec.h \ + ../byterun/caml/callback.h ../byterun/caml/debugger.h \ + ../byterun/caml/fail.h ../byterun/caml/misc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/printexc.h +roots.p.o: roots.c ../byterun/caml/finalise.h ../byterun/caml/roots.h \ + ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/globroots.h \ + ../byterun/caml/memory.h ../byterun/caml/major_gc.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/misc.h \ + ../byterun/caml/mlvalues.h stack.h ../byterun/caml/roots.h +signals.p.o: signals.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/callback.h ../byterun/caml/config.h \ + ../byterun/caml/fail.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/roots.h ../byterun/caml/memory.h \ + ../byterun/caml/signals.h ../byterun/caml/signals_machdep.h \ + ../byterun/caml/sys.h +signals_asm.p.o: signals_asm.c ../byterun/caml/fail.h \ + ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/osdeps.h \ + ../byterun/caml/signals.h ../byterun/caml/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 -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 -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 -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 -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 -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 +startup.p.o: startup.c ../byterun/caml/callback.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/misc.h ../byterun/caml/backtrace.h \ + ../byterun/caml/exec.h ../byterun/caml/custom.h \ + ../byterun/caml/debugger.h ../byterun/caml/fail.h \ + ../byterun/caml/freelist.h ../byterun/caml/gc.h \ + ../byterun/caml/gc_ctrl.h ../byterun/caml/intext.h ../byterun/caml/io.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/osdeps.h ../byterun/caml/printexc.h stack.h \ + ../byterun/caml/startup_aux.h ../byterun/caml/sys.h +startup_aux.p.o: startup_aux.c ../byterun/caml/backtrace.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/misc.h ../byterun/caml/exec.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/startup_aux.h +str.p.o: str.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/misc.h +sys.p.o: sys.c ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/alloc.h \ + ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/debugger.h \ + ../byterun/caml/fail.h ../byterun/caml/instruct.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/osdeps.h \ + ../byterun/caml/signals.h ../byterun/caml/stacks.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/sys.h ../byterun/caml/gc_ctrl.h +terminfo.p.o: terminfo.c ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/alloc.h ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/fail.h ../byterun/caml/io.h \ + ../byterun/caml/mlvalues.h +unix.p.o: unix.c ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/memory.h \ + ../byterun/caml/config.h ../byterun/caml/gc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/misc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/misc.h ../byterun/caml/osdeps.h +weak.p.o: weak.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/major_gc.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/mlvalues.h diff --git a/asmrun/.ignore b/asmrun/.ignore index a7a9d33563..60bc139ed9 100644 --- a/asmrun/.ignore +++ b/asmrun/.ignore @@ -2,39 +2,40 @@ *.d.c libasmrun.a libasmrunp.a -main.c -misc.c -freelist.c -major_gc.c -minor_gc.c -memory.c +.depend.nt alloc.c array.c +callback.c +compact.c compare.c -ints.c -floats.c -str.c -io.c +custom.c +debugger.c +dynlink.c extern.c -intern.c -hash.c -sys.c -parsing.c +finalise.c +floats.c +freelist.c gc_ctrl.c -terminfo.c +globroots.c +hash.c +intern.c +ints.c +io.c +lexing.c +main.c +major_gc.c md5.c +memory.c +meta.c +minor_gc.c +misc.c obj.c -lexing.c +parsing.c printexc.c -callback.c -weak.c -compact.c -finalise.c -custom.c -meta.c -globroots.c -unix.c -dynlink.c signals.c -debugger.c -.depend.nt +startup_aux.c +str.c +sys.c +terminfo.c +unix.c +weak.c diff --git a/asmrun/Makefile b/asmrun/Makefile index 63ff80c687..e53628b4f9 100644 --- a/asmrun/Makefile +++ b/asmrun/Makefile @@ -16,11 +16,13 @@ include ../config/Makefile CC=$(NATIVECC) FLAGS=-I../byterun -DCAML_NAME_SPACE -DNATIVE_CODE \ -DTARGET_$(ARCH) -DSYS_$(SYSTEM) $(IFLEXDIR) -CFLAGS=$(FLAGS) -O $(NATIVECCCOMPOPTS) +CFLAGS=$(FLAGS) $(NATIVECCCOMPOPTS) DFLAGS=$(FLAGS) -g -DDEBUG $(NATIVECCCOMPOPTS) PFLAGS=$(FLAGS) -pg -O -DPROFILING $(NATIVECCPROFOPTS) +PICFLAGS=$(FLAGS) -O $(SHAREDCCCOMPOPTS) $(NATIVECCCOMPOPTS) -COBJS=startup.o main.o fail.o roots.o globroots.o signals.o signals_asm.o \ +COBJS=startup_aux.o startup.o \ + main.o fail.o roots.o globroots.o signals.o signals_asm.o \ misc.o freelist.o major_gc.o minor_gc.o memory.o alloc.o compare.o ints.o \ floats.o str.o array.o io.o extern.o intern.o hash.o sys.o parsing.o \ gc_ctrl.o terminfo.o md5.o obj.o lexing.o printexc.o callback.o weak.o \ @@ -32,12 +34,13 @@ ASMOBJS=$(ARCH).o OBJS=$(COBJS) $(ASMOBJS) DOBJS=$(COBJS:.o=.d.o) $(ASMOBJS) POBJS=$(COBJS:.o=.p.o) $(ASMOBJS:.o=.p.o) +PICOBJS=$(COBJS:.o=.pic.o) $(ASMOBJS:.o=.pic.o) -all: libasmrun.a all-$(RUNTIMED) all-$(PROFILING) +all: libasmrun.a all-$(RUNTIMED) all-$(PROFILING) all-$(SHARED) libasmrun.a: $(OBJS) rm -f libasmrun.a - ar rc libasmrun.a $(OBJS) + $(ARCMD) rc libasmrun.a $(OBJS) $(RANLIB) libasmrun.a all-noruntimed: @@ -48,7 +51,7 @@ all-runtimed: libasmrund.a libasmrund.a: $(DOBJS) rm -f libasmrund.a - ar rc libasmrund.a $(DOBJS) + $(ARCMD) rc libasmrund.a $(DOBJS) $(RANLIB) libasmrund.a all-noprof: @@ -57,16 +60,29 @@ all-prof: libasmrunp.a libasmrunp.a: $(POBJS) rm -f libasmrunp.a - ar rc libasmrunp.a $(POBJS) + $(ARCMD) rc libasmrunp.a $(POBJS) $(RANLIB) libasmrunp.a +all-noshared: + +all-shared: libasmrun_pic.a libasmrun_shared.so + +libasmrun_pic.a: $(PICOBJS) + rm -f libasmrun_pic.a + ar rc libasmrun_pic.a $(PICOBJS) + $(RANLIB) libasmrun_pic.a + +libasmrun_shared.so: $(PICOBJS) + $(MKDLL) -o libasmrun_shared.so $(PICOBJS) $(NATIVECCLIBS) + INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR) -install: install-default install-$(RUNTIMED) install-$(PROFILING) +install: install-default install-$(RUNTIMED) install-$(PROFILING) install-$(SHARED) install-default: cp libasmrun.a $(INSTALL_LIBDIR)/libasmrun.a cd $(INSTALL_LIBDIR); $(RANLIB) libasmrun.a +.PHONY: install-default install-noruntimed: .PHONY: install-noruntimed @@ -79,10 +95,21 @@ install-runtimed: install-noprof: rm -f $(INSTALL_LIBDIR)/libasmrunp.a ln -s libasmrun.a $(INSTALL_LIBDIR)/libasmrunp.a +.PHONY: install-noprof install-prof: cp libasmrunp.a $(INSTALL_LIBDIR)/libasmrunp.a cd $(INSTALL_LIBDIR); $(RANLIB) libasmrunp.a +.PHONY: install-prof + +install-noshared: +.PHONY: install-noshared + +install-shared: + cp libasmrun_pic.a $(INSTALL_LIBDIR)/libasmrun_pic.a + cd $(INSTALL_LIBDIR); $(RANLIB) libasmrunp.a + cp libasmrun_shared.so $(INSTALL_LIBDIR)/libasmrun_shared.so +.PHONY: install-prof power-bsd_elf.S: power-elf.S cp power-elf.S power-bsd_elf.S @@ -93,8 +120,13 @@ power.o: power-$(SYSTEM).o power.p.o: power-$(SYSTEM).o cp power-$(SYSTEM).o power.p.o +power.pic.o: power-$(SYSTEM).pic.o + cp power-$(SYSTEM).pic.o power.pic.o + main.c: ../byterun/main.c ln -s ../byterun/main.c main.c +startup_aux.c: ../byterun/startup_aux.c + ln -s ../byterun/startup_aux.c startup_aux.c misc.c: ../byterun/misc.c ln -s ../byterun/misc.c misc.c freelist.c: ../byterun/freelist.c @@ -173,40 +205,43 @@ LINKEDFILES=misc.c freelist.c major_gc.c minor_gc.c memory.c alloc.c array.c \ clean:: rm -f $(LINKEDFILES) -.SUFFIXES: .S .d.o .p.o - -.S.o: - $(ASPP) -DSYS_$(SYSTEM) -DMODEL_$(MODEL) -o $*.o $*.S || \ +%.o: %.S + $(ASPP) -DSYS_$(SYSTEM) -DMODEL_$(MODEL) -o $@ $< || \ { echo "If your assembler produced syntax errors, it is probably";\ echo "unhappy with the preprocessor. Check your assembler, or";\ echo "try producing $*.o by hand.";\ exit 2; } -.S.p.o: - $(ASPP) -DSYS_$(SYSTEM) -DMODEL_$(MODEL) $(ASPPPROFFLAGS) -o $*.p.o $*.S +%.p.o: %.S + $(ASPP) -DSYS_$(SYSTEM) -DMODEL_$(MODEL) $(ASPPPROFFLAGS) -o $@ $< + +%.pic.o: %.S + $(ASPP) -DSYS_$(SYSTEM) -DMODEL_$(MODEL) $(SHAREDCCCOMPOPTS) -o $@ $< + +%.d.o: %.c + $(CC) -c $(DFLAGS) -o $@ $< + +%.p.o: %.c + $(CC) -c $(PFLAGS) -o $@ $< -.c.d.o: - ln -s -f $*.c $*.d.c - $(CC) -c $(DFLAGS) $*.d.c - rm -f $*.d.c +%.pic.o: %.c + $(CC) -c $(PICFLAGS) -o $@ $< -.c.p.o: - ln -s -f $*.c $*.p.c - $(CC) -c $(PFLAGS) $*.p.c - rm -f $*.p.c +%.o: %.s + $(ASPP) -DSYS_$(SYSTEM) -o $@ $< -.s.o: - $(ASPP) -DSYS_$(SYSTEM) -o $*.o $*.s +%.p.o: %.s + $(ASPP) -DSYS_$(SYSTEM) $(ASPPPROFFLAGS) -o $@ $< -.s.p.o: - $(ASPP) -DSYS_$(SYSTEM) $(ASPPPROFFLAGS) -o $*.p.o $*.s +%.pic.o: %.s + $(ASPP) -DSYS_$(SYSTEM) $(SHAREDCCCOMPOPTS) -o $@ $< clean:: rm -f *.o *.a *~ depend: $(COBJS:.o=.c) ${LINKEDFILES} - -gcc -MM $(FLAGS) *.c > .depend - gcc -MM $(FLAGS) -DDEBUG *.c | sed -e 's/\.o/.d.o/' >> .depend - gcc -MM $(FLAGS) -DDEBUG *.c | sed -e 's/\.o/.p.o/' >> .depend + $(CC) -MM $(FLAGS) *.c > .depend + $(CC) -MM $(FLAGS) -DDEBUG *.c | sed -e 's/\.o/.d.o/' >> .depend + $(CC) -MM $(FLAGS) *.c | sed -e 's/\.o/.p.o/' >> .depend include .depend diff --git a/asmrun/Makefile.nt b/asmrun/Makefile.nt index 77c2002d4f..2e994d298d 100644 --- a/asmrun/Makefile.nt +++ b/asmrun/Makefile.nt @@ -17,7 +17,8 @@ CC=$(NATIVECC) CFLAGS=-I../byterun -DNATIVE_CODE -DTARGET_$(ARCH) -DSYS_$(SYSTEM) \ $(NATIVECCCOMPOPTS) -COBJS=startup.$(O) main.$(O) fail.$(O) roots.$(O) signals.$(O) signals_asm.$(O)\ +COBJS=startup_aux.$(O) startup.$(O) \ + main.$(O) fail.$(O) roots.$(O) signals.$(O) signals_asm.$(O)\ misc.$(O) freelist.$(O) major_gc.$(O) minor_gc.$(O) memory.$(O) alloc.$(O) \ compare.$(O) ints.$(O) floats.$(O) str.$(O) array.$(O) io.$(O) extern.$(O) \ intern.$(O) hash.$(O) sys.$(O) parsing.$(O) gc_ctrl.$(O) terminfo.$(O) \ @@ -29,7 +30,7 @@ LINKEDFILES=misc.c freelist.c major_gc.c minor_gc.c memory.c alloc.c array.c \ compare.c ints.c floats.c str.c io.c extern.c intern.c hash.c sys.c \ parsing.c gc_ctrl.c terminfo.c md5.c obj.c lexing.c printexc.c callback.c \ weak.c compact.c meta.c finalise.c custom.c main.c globroots.c \ - dynlink.c signals.c debugger.c + dynlink.c signals.c debugger.c startup_aux.c ifeq ($(TOOLCHAIN),mingw) ASMOBJS=$(ARCH).o @@ -68,9 +69,7 @@ $(LINKEDFILES): %.c: ../byterun/%.c win32.$(O): ../byterun/win32.c $(CC) -c $(NATIVECCCOMPOPTS) -DNATIVE_CODE $(IFLEXDIR) ../byterun/win32.c -.SUFFIXES: .c .$(O) - -.c.$(O): +%.$(O): %.c $(CC) $(CFLAGS) -c $< clean:: diff --git a/asmrun/amd64.S b/asmrun/amd64.S index d2e007529d..be38848ec2 100644 --- a/asmrun/amd64.S +++ b/asmrun/amd64.S @@ -471,7 +471,7 @@ FUNCTION(G(caml_start_program)) /* Save callee-save registers */ PUSH_CALLEE_SAVE_REGS /* Initial entry point is G(caml_program) */ - leaq GCALL(caml_program)(%rip), %r12 + LEA_VAR(caml_program, %r12) /* Common code for caml_start_program and caml_callback* */ LBL(caml_start_program): /* Build a callback link */ @@ -636,7 +636,7 @@ CFI_STARTPROC movq C_ARG_1, %rdi /* closure -- no op with Unix conventions */ movq C_ARG_2, %rax /* first argument */ movq C_ARG_3, %rbx /* second argument */ - leaq GCALL(caml_apply2)(%rip), %r12 /* code pointer */ + LEA_VAR(caml_apply2, %r12) /* code pointer */ jmp LBL(caml_start_program) CFI_ENDPROC @@ -649,13 +649,13 @@ CFI_STARTPROC movq C_ARG_3, %rbx /* second argument */ movq C_ARG_1, %rsi /* closure */ movq C_ARG_4, %rdi /* third argument */ - leaq GCALL(caml_apply3)(%rip), %r12 /* code pointer */ + LEA_VAR(caml_apply3, %r12) /* code pointer */ jmp LBL(caml_start_program) CFI_ENDPROC FUNCTION(G(caml_ml_array_bound_error)) CFI_STARTPROC - leaq GCALL(caml_array_bound_error)(%rip), %rax + LEA_VAR(caml_array_bound_error, %rax) jmp LBL(caml_c_call) CFI_ENDPROC diff --git a/asmrun/backtrace.c b/asmrun/backtrace.c index 5eb8600cd2..6b28db0df5 100644 --- a/asmrun/backtrace.c +++ b/asmrun/backtrace.c @@ -17,11 +17,11 @@ #include <stdlib.h> #include <string.h> -#include "alloc.h" -#include "backtrace.h" -#include "memory.h" -#include "misc.h" -#include "mlvalues.h" +#include "caml/alloc.h" +#include "caml/backtrace.h" +#include "caml/memory.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" #include "stack.h" int caml_backtrace_active = 0; @@ -51,6 +51,7 @@ CAMLprim value caml_record_backtrace(value vflag) caml_backtrace_active = flag; caml_backtrace_pos = 0; if (flag) { + caml_backtrace_last_exn = Val_unit; caml_register_global_root(&caml_backtrace_last_exn); } else { caml_remove_global_root(&caml_backtrace_last_exn); @@ -74,13 +75,11 @@ frame_descr * caml_next_frame_descriptor(uintnat * pc, char ** sp) frame_descr * d; uintnat h; - if (caml_frame_descriptors == NULL) caml_init_frame_descriptors(); - while (1) { h = Hash_retaddr(*pc); while (1) { d = caml_frame_descriptors[h]; - if (d == 0) return NULL; /* can happen if some code compiled without -g */ + if (d == NULL) return NULL; /* happens if some code compiled without -g */ if (d->retaddr == *pc) break; h = (h+1) & caml_frame_descriptors_mask; } @@ -204,17 +203,8 @@ CAMLprim value caml_get_current_callstack(value max_frames_value) { /* Extract location information for the given frame descriptor */ -struct loc_info { - int loc_valid; - int loc_is_raise; - char * loc_filename; - int loc_lnum; - int loc_startchr; - int loc_endchr; -}; - -static void extract_location_info(frame_descr * d, - /*out*/ struct loc_info * li) +CAMLexport void extract_location_info(frame_descr * d, + /*out*/ struct caml_loc_info * li) { uintnat infoptr; uint32_t info1, info2; @@ -260,7 +250,7 @@ static void extract_location_info(frame_descr * d, useless. We kept it to keep code identical to the byterun/ implementation. */ -static void print_location(struct loc_info * li, int index) +static void print_location(struct caml_loc_info * li, int index) { char * info; @@ -293,7 +283,7 @@ static void print_location(struct loc_info * li, int index) void caml_print_exception_backtrace(void) { int i; - struct loc_info li; + struct caml_loc_info li; for (i = 0; i < caml_backtrace_pos; i++) { extract_location_info((frame_descr *) (caml_backtrace_buffer[i]), &li); @@ -306,7 +296,7 @@ void caml_print_exception_backtrace(void) CAMLprim value caml_convert_raw_backtrace_slot(value backtrace_slot) { CAMLparam1(backtrace_slot); CAMLlocal2(p, fname); - struct loc_info li; + struct caml_loc_info li; extract_location_info(Descrptr_Val(backtrace_slot), &li); @@ -366,6 +356,16 @@ CAMLprim value caml_get_exception_raw_backtrace(value unit) CAMLreturn(res); } +CAMLprim value caml_add_debug_info(code_t start, value size, value events) +{ + return Val_unit; +} + +CAMLprim value caml_remove_debug_info(code_t start) +{ + return Val_unit; +} + /* 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 diff --git a/asmrun/fail.c b/asmrun/fail.c index cb2c1cbd77..aa1b4945db 100644 --- a/asmrun/fail.c +++ b/asmrun/fail.c @@ -15,17 +15,17 @@ #include <stdio.h> #include <signal.h> -#include "alloc.h" -#include "fail.h" -#include "io.h" -#include "gc.h" -#include "memory.h" -#include "mlvalues.h" -#include "printexc.h" -#include "signals.h" +#include "caml/alloc.h" +#include "caml/fail.h" +#include "caml/io.h" +#include "caml/gc.h" +#include "caml/memory.h" +#include "caml/mlvalues.h" +#include "caml/printexc.h" +#include "caml/signals.h" #include "stack.h" -#include "roots.h" -#include "callback.h" +#include "caml/roots.h" +#include "caml/callback.h" /* The globals holding predefined exceptions */ @@ -47,7 +47,7 @@ extern caml_generated_constant /* Exception raising */ -extern void caml_raise_exception (value bucket) Noreturn; +Noreturn extern void caml_raise_exception (value bucket); char * caml_exception_pointer = NULL; diff --git a/asmrun/i386.S b/asmrun/i386.S index 347e967c14..e55969ee97 100644 --- a/asmrun/i386.S +++ b/asmrun/i386.S @@ -19,7 +19,7 @@ /* Linux/BSD with ELF binaries and Solaris do not prefix identifiers with _. Linux/BSD with a.out binaries and NextStep do. */ -#if defined(SYS_solaris) +#if (defined(SYS_solaris) && !defined(__GNUC__)) #define CONCAT(a,b) a/**/b #else #define CONCAT(a,b) a##b diff --git a/asmrun/natdynlink.c b/asmrun/natdynlink.c index 86c4f3e6f3..82e8795fc8 100644 --- a/asmrun/natdynlink.c +++ b/asmrun/natdynlink.c @@ -11,15 +11,16 @@ /* */ /***********************************************************************/ -#include "misc.h" -#include "mlvalues.h" -#include "memory.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" +#include "caml/memory.h" #include "stack.h" -#include "callback.h" -#include "alloc.h" -#include "intext.h" -#include "osdeps.h" -#include "fail.h" +#include "caml/callback.h" +#include "caml/alloc.h" +#include "caml/intext.h" +#include "caml/osdeps.h" +#include "caml/fail.h" +#include "caml/signals.h" #include <stdio.h> #include <string.h> @@ -51,10 +52,15 @@ CAMLprim value caml_natdynlink_open(value filename, value global) CAMLlocal1 (res); void *sym; void *handle; + char *p; /* TODO: dlclose in case of error... */ - handle = caml_dlopen(String_val(filename), 1, Int_val(global)); + p = caml_strdup(String_val(filename)); + caml_enter_blocking_section(); + handle = caml_dlopen(p, 1, Int_val(global)); + caml_leave_blocking_section(); + caml_stat_free(p); if (NULL == handle) CAMLreturn(caml_copy_string(caml_dlerror())); @@ -117,10 +123,15 @@ CAMLprim value caml_natdynlink_run_toplevel(value filename, value symbol) CAMLparam2 (filename, symbol); CAMLlocal2 (res, v); void *handle; + char *p; /* TODO: dlclose in case of error... */ - handle = caml_dlopen(String_val(filename), 1, 1); + p = caml_strdup(String_val(filename)); + caml_enter_blocking_section(); + handle = caml_dlopen(p, 1, 1); + caml_leave_blocking_section(); + caml_stat_free(p); if (NULL == handle) { res = caml_alloc(1,1); diff --git a/asmrun/roots.c b/asmrun/roots.c index 93e7a655cd..d889c52069 100644 --- a/asmrun/roots.c +++ b/asmrun/roots.c @@ -13,15 +13,15 @@ /* To walk the memory roots for garbage collection */ -#include "finalise.h" -#include "globroots.h" -#include "memory.h" -#include "major_gc.h" -#include "minor_gc.h" -#include "misc.h" -#include "mlvalues.h" +#include "caml/finalise.h" +#include "caml/globroots.h" +#include "caml/memory.h" +#include "caml/major_gc.h" +#include "caml/minor_gc.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" #include "stack.h" -#include "roots.h" +#include "caml/roots.h" #include <string.h> #include <stdio.h> @@ -32,9 +32,8 @@ struct caml__roots_block *caml_local_roots = NULL; void (*caml_scan_roots_hook) (scanning_action) = NULL; /* The hashtable of frame descriptors */ - frame_descr ** caml_frame_descriptors = NULL; -int caml_frame_descriptors_mask; +int caml_frame_descriptors_mask = 0; /* Linked-list */ @@ -56,52 +55,43 @@ static link *cons(void *data, link *tl) { /* Linked-list of frametables */ static link *frametables = NULL; +static intnat num_descr = 0; -void caml_register_frametable(intnat *table) { - frametables = cons(table,frametables); +static int count_descriptors(link *list) { + intnat num_descr = 0; + link *lnk; + iter_list(list,lnk) { + num_descr += *((intnat*) lnk->data); + } + return num_descr; +} - if (NULL != caml_frame_descriptors) { - caml_stat_free(caml_frame_descriptors); - caml_frame_descriptors = NULL; - /* force caml_init_frame_descriptors to be called */ +static link* frametables_list_tail(link *list) { + link *lnk, *tail = NULL; + iter_list(list,lnk) { + tail = lnk; } + return tail; } -void caml_init_frame_descriptors(void) -{ - intnat num_descr, tblsize, i, j, len; +static frame_descr * next_frame_descr(frame_descr * d) { + uintnat nextd; + nextd = + ((uintnat)d + + sizeof(char *) + sizeof(short) + sizeof(short) + + sizeof(short) * d->num_live + sizeof(frame_descr *) - 1) + & -sizeof(frame_descr *); + if (d->frame_size & 1) nextd += 8; + return((frame_descr *) nextd); +} + +static void fill_hashtable(link *frametables) { + intnat len, j; intnat * tbl; frame_descr * d; - uintnat nextd; uintnat h; - link *lnk; - - static int inited = 0; + link *lnk = NULL; - if (!inited) { - for (i = 0; caml_frametable[i] != 0; i++) - caml_register_frametable(caml_frametable[i]); - inited = 1; - } - - /* Count the frame descriptors */ - num_descr = 0; - iter_list(frametables,lnk) { - num_descr += *((intnat*) lnk->data); - } - - /* The size of the hashtable is a power of 2 greater or equal to - 2 times the number of descriptors */ - tblsize = 4; - while (tblsize < 2 * num_descr) tblsize *= 2; - - /* Allocate the hash table */ - caml_frame_descriptors = - (frame_descr **) caml_stat_alloc(tblsize * sizeof(frame_descr *)); - for (i = 0; i < tblsize; i++) caml_frame_descriptors[i] = NULL; - caml_frame_descriptors_mask = tblsize - 1; - - /* Fill the hash table */ iter_list(frametables,lnk) { tbl = (intnat*) lnk->data; len = *tbl; @@ -112,14 +102,112 @@ void caml_init_frame_descriptors(void) h = (h+1) & caml_frame_descriptors_mask; } caml_frame_descriptors[h] = d; - nextd = - ((uintnat)d + - sizeof(char *) + sizeof(short) + sizeof(short) + - sizeof(short) * d->num_live + sizeof(frame_descr *) - 1) - & -sizeof(frame_descr *); - if (d->frame_size & 1) nextd += 8; - d = (frame_descr *) nextd; + d = next_frame_descr(d); + } + } +} + +static void init_frame_descriptors(link *new_frametables) +{ + intnat tblsize, increase, i; + link *tail = NULL; + + Assert(new_frametables); + + tail = frametables_list_tail(new_frametables); + increase = count_descriptors(new_frametables); + tblsize = caml_frame_descriptors_mask + 1; + + /* Reallocate the caml_frame_descriptor table if it is too small */ + if(tblsize < (num_descr + increase) * 2) { + + /* Merge both lists */ + tail->next = frametables; + frametables = NULL; + + /* [num_descr] can be less than [num_descr + increase] if frame + tables where unregistered */ + num_descr = count_descriptors(new_frametables); + + tblsize = 4; + while (tblsize < 2 * num_descr) tblsize *= 2; + + caml_frame_descriptors_mask = tblsize - 1; + if(caml_frame_descriptors) caml_stat_free(caml_frame_descriptors); + caml_frame_descriptors = + (frame_descr **) caml_stat_alloc(tblsize * sizeof(frame_descr *)); + for (i = 0; i < tblsize; i++) caml_frame_descriptors[i] = NULL; + } else { + num_descr += increase; + } + + fill_hashtable(new_frametables); + tail->next = frametables; +} + +void caml_init_frame_descriptors(void) { + intnat i; + link *new_frametables = NULL; + for (i = 0; caml_frametable[i] != 0; i++) + new_frametables = cons(caml_frametable[i],new_frametables); + init_frame_descriptors(new_frametables); +} + +void caml_register_frametable(intnat *table) { + link *new_frametables = cons(table,NULL); + init_frame_descriptors(new_frametables); +} + +static void remove_entry(frame_descr * d) { + uintnat i; + uintnat r; + uintnat j; + + i = Hash_retaddr(d->retaddr); + while (caml_frame_descriptors[i] != d) { + i = (i+1) & caml_frame_descriptors_mask; + } + + r1: + j = i; + caml_frame_descriptors[i] = NULL; + r2: + i = (i+1) & caml_frame_descriptors_mask; + // r3 + if(caml_frame_descriptors[i] == NULL) return; + r = Hash_retaddr(caml_frame_descriptors[i]->retaddr); + /* If r is between i and j (cyclically), i.e. if + caml_frame_descriptors[i]->retaddr don't need to be moved */ + if(( ( j < r ) && ( r <= i ) ) || + ( ( i < j ) && ( j < r ) ) || /* i cycled, r not */ + ( ( r <= i ) && ( i < j ) ) ) { /* i and r cycled */ + goto r2; + } + // r4 + caml_frame_descriptors[j] = caml_frame_descriptors[i]; + goto r1; +} + +void caml_unregister_frametable(intnat *table) { + intnat len, j; + link *lnk; + link *previous = frametables; + frame_descr * d; + + len = *table; + d = (frame_descr *)(table + 1); + for (j = 0; j < len; j++) { + remove_entry(d); + d = next_frame_descr(d); + } + + iter_list(frametables,lnk) { + if(lnk->data == table) { + previous->next = lnk->next; + caml_stat_free(lnk); + break; } + previous = lnk; } } @@ -177,7 +265,6 @@ void caml_oldify_local_roots (void) } /* The stack and local roots */ - if (caml_frame_descriptors == NULL) caml_init_frame_descriptors(); sp = caml_bottom_of_stack; retaddr = caml_last_return_address; regs = caml_gc_regs; @@ -272,7 +359,6 @@ void caml_do_roots (scanning_action f) } /* The stack and local roots */ - if (caml_frame_descriptors == NULL) caml_init_frame_descriptors(); caml_do_local_roots(f, caml_bottom_of_stack, caml_last_return_address, caml_gc_regs, caml_local_roots); /* Global C roots */ diff --git a/asmrun/signals_asm.c b/asmrun/signals_asm.c index df76c50102..cd66e708bd 100644 --- a/asmrun/signals_asm.c +++ b/asmrun/signals_asm.c @@ -19,11 +19,11 @@ #include <signal.h> #include <errno.h> #include <stdio.h> -#include "fail.h" -#include "memory.h" -#include "osdeps.h" -#include "signals.h" -#include "signals_machdep.h" +#include "caml/fail.h" +#include "caml/memory.h" +#include "caml/osdeps.h" +#include "caml/signals.h" +#include "caml/signals_machdep.h" #include "signals_osdep.h" #include "stack.h" @@ -47,6 +47,8 @@ extern void caml_win32_overflow_detection(); extern char * caml_code_area_start, * caml_code_area_end; extern char caml_system__code_begin, caml_system__code_end; +/* Do not use the macro from address_class.h here. */ +#undef Is_in_code_area #define Is_in_code_area(pc) \ ( ((char *)(pc) >= caml_code_area_start && \ (char *)(pc) <= caml_code_area_end) \ @@ -224,7 +226,7 @@ DECLARE_SIGNAL_HANDLER(segv_handler) /* Raise a Stack_overflow exception straight from this signal handler */ #if defined(CONTEXT_YOUNG_PTR) && defined(CONTEXT_EXCEPTION_POINTER) caml_exception_pointer = (char *) CONTEXT_EXCEPTION_POINTER; - caml_young_ptr = (char *) CONTEXT_YOUNG_PTR; + caml_young_ptr = (value *) CONTEXT_YOUNG_PTR; #endif caml_raise_stack_overflow(); #endif diff --git a/asmrun/signals_osdep.h b/asmrun/signals_osdep.h index f3b4642d2d..627e3b727e 100644 --- a/asmrun/signals_osdep.h +++ b/asmrun/signals_osdep.h @@ -66,18 +66,7 @@ #elif defined(TARGET_arm) && (defined(SYS_linux_eabi) \ || defined(SYS_linux_eabihf)) - #if defined(__ANDROID__) - // The Android NDK does not have sys/ucontext.h yet. - typedef struct ucontext { - uint32_t uc_flags; - struct ucontext *uc_link; - stack_t uc_stack; - struct sigcontext uc_mcontext; - // Other fields omitted... - } ucontext_t; - #else - #include <sys/ucontext.h> - #endif + #include <sys/ucontext.h> #define DECLARE_SIGNAL_HANDLER(name) \ static void name(int sig, siginfo_t * info, ucontext_t * context) @@ -163,14 +152,24 @@ #elif defined(TARGET_i386) && defined(SYS_bsd_elf) - #define DECLARE_SIGNAL_HANDLER(name) \ - static void name(int sig, siginfo_t * info, struct sigcontext * context) + #if defined (__NetBSD__) + #include <ucontext.h> + #define DECLARE_SIGNAL_HANDLER(name) \ + static void name(int sig, siginfo_t * info, ucontext_t * context) + #else + #define DECLARE_SIGNAL_HANDLER(name) \ + static void name(int sig, siginfo_t * info, struct sigcontext * context) + #endif #define SET_SIGACT(sigact,name) \ sigact.sa_sigaction = (void (*)(int,siginfo_t *,void *)) (name); \ sigact.sa_flags = SA_SIGINFO - #define CONTEXT_PC (context->sc_eip) + #if defined (__NetBSD__) + #define CONTEXT_PC (_UC_MACHINE_PC(context)) + #else + #define CONTEXT_PC (context->sc_eip) + #endif #define CONTEXT_FAULTING_ADDRESS ((char *) info->si_addr) /****************** I386, BSD */ diff --git a/asmrun/stack.h b/asmrun/stack.h index 92b3c28a35..3a44f91f8c 100644 --- a/asmrun/stack.h +++ b/asmrun/stack.h @@ -78,6 +78,15 @@ typedef struct { unsigned short live_ofs[1]; } frame_descr; +struct caml_loc_info { + int loc_valid; + int loc_is_raise; + char * loc_filename; + int loc_lnum; + int loc_startchr; + int loc_endchr; +}; + /* Hash table of frame descriptors */ extern frame_descr ** caml_frame_descriptors; @@ -88,8 +97,13 @@ extern int caml_frame_descriptors_mask; extern void caml_init_frame_descriptors(void); extern void caml_register_frametable(intnat *); +extern void caml_unregister_frametable(intnat *); extern void caml_register_dyn_global(void *); +CAMLextern void extract_location_info(frame_descr * d, + /*out*/ struct caml_loc_info * li); + + extern uintnat caml_stack_usage (void); extern uintnat (*caml_stack_usage_hook)(void); diff --git a/asmrun/startup.c b/asmrun/startup.c index 9a00f2d7d5..30b7f90ccf 100644 --- a/asmrun/startup.c +++ b/asmrun/startup.c @@ -15,24 +15,25 @@ #include <stdio.h> #include <stdlib.h> -#include "callback.h" -#include "backtrace.h" -#include "custom.h" -#include "debugger.h" -#include "fail.h" -#include "freelist.h" -#include "gc.h" -#include "gc_ctrl.h" -#include "intext.h" -#include "memory.h" -#include "misc.h" -#include "mlvalues.h" -#include "osdeps.h" -#include "printexc.h" +#include "caml/callback.h" +#include "caml/backtrace.h" +#include "caml/custom.h" +#include "caml/debugger.h" +#include "caml/fail.h" +#include "caml/freelist.h" +#include "caml/gc.h" +#include "caml/gc_ctrl.h" +#include "caml/intext.h" +#include "caml/memory.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" +#include "caml/osdeps.h" +#include "caml/printexc.h" #include "stack.h" -#include "sys.h" +#include "caml/startup_aux.h" +#include "caml/sys.h" #ifdef HAS_UI -#include "ui.h" +#include "caml/ui.h" #endif extern int caml_parser_trace; @@ -43,18 +44,13 @@ char * caml_code_area_start, * caml_code_area_end; struct segment { char * begin; char * end; }; -static void init_atoms(void) +static void init_static(void) { extern struct segment caml_data_segments[], caml_code_segments[]; int i; struct code_fragment * cf; - for (i = 0; i < 256; i++) { - caml_atom_table[i] = Make_header(0, i, Caml_white); - } - if (caml_page_table_add(In_static_data, - caml_atom_table, caml_atom_table + 256) != 0) - caml_fatal_error("Fatal error: not enough memory for initial page table"); + caml_init_atom_table (); for (i = 0; caml_data_segments[i].begin != 0; i++) { /* PR#5509: we must include the zero word at end of data segment, @@ -82,63 +78,6 @@ static void init_atoms(void) caml_ext_table_add(&caml_code_fragments_table, cf); } -/* Configuration parameters and flags */ - -static uintnat percent_free_init = Percent_free_def; -static uintnat max_percent_free_init = Max_percent_free_def; -static uintnat minor_heap_init = Minor_heap_def; -static uintnat heap_chunk_init = Heap_chunk_def; -static uintnat heap_size_init = Init_heap_def; -static uintnat max_stack_init = Max_stack_def; - -/* Parse the CAMLRUNPARAM variable */ -/* The option letter for each runtime option is the first letter of the - last word of the ML name of the option (see [stdlib/gc.mli]). - Except for l (maximum stack size) and h (initial heap size). -*/ -/* Note: option l is irrelevant to the native-code runtime. */ - -/* If you change these functions, see also their copy in byterun/startup.c */ - -static void scanmult (char *opt, uintnat *var) -{ - char mult = ' '; - int val; - sscanf (opt, "=%u%c", &val, &mult); - sscanf (opt, "=0x%x%c", &val, &mult); - switch (mult) { - case 'k': *var = (uintnat) val * 1024; break; - case 'M': *var = (uintnat) val * 1024 * 1024; break; - case 'G': *var = (uintnat) val * 1024 * 1024 * 1024; break; - default: *var = (uintnat) val; break; - } -} - -static void parse_camlrunparam(void) -{ - char *opt = getenv ("OCAMLRUNPARAM"); - uintnat p; - - if (opt == NULL) opt = getenv ("CAMLRUNPARAM"); - - if (opt != NULL){ - while (*opt != '\0'){ - switch (*opt++){ - case 's': scanmult (opt, &minor_heap_init); break; - case 'i': scanmult (opt, &heap_chunk_init); break; - case 'h': scanmult (opt, &heap_size_init); break; - case 'l': scanmult (opt, &max_stack_init); break; - case 'o': scanmult (opt, &percent_free_init); break; - case 'O': scanmult (opt, &max_percent_free_init); break; - case 'v': scanmult (opt, &caml_verb_gc); break; - case 'b': caml_record_backtrace(Val_true); break; - case 'p': caml_parser_trace = 1; break; - case 'a': scanmult (opt, &p); caml_set_allocation_policy (p); break; - } - } - } -} - /* These are termination hooks used by the systhreads library */ struct longjmp_buffer caml_termination_jmpbuf; void (*caml_termination_hook)(void *) = NULL; @@ -162,6 +101,7 @@ void caml_main(char **argv) value res; char tos; + caml_init_frame_descriptors(); caml_init_ieee_floats(); #ifdef _MSC_VER caml_install_invalid_parameter_handler(); @@ -171,10 +111,11 @@ void caml_main(char **argv) caml_verb_gc = 63; #endif caml_top_of_stack = &tos; - parse_camlrunparam(); - caml_init_gc (minor_heap_init, heap_size_init, heap_chunk_init, - percent_free_init, max_percent_free_init); - init_atoms(); + caml_parse_ocamlrunparam(); + caml_init_gc (caml_init_minor_heap_wsz, caml_init_heap_wsz, + caml_init_heap_chunk_sz, caml_init_percent_free, + caml_init_max_percent_free); + init_static(); caml_init_signals(); caml_debugger_init (); /* force debugger.o stub to be linked */ exe_name = argv[0]; diff --git a/boot/ocamlc b/boot/ocamlc Binary files differindex 51c6883b22..5775fc43f7 100755 --- a/boot/ocamlc +++ b/boot/ocamlc diff --git a/boot/ocamldep b/boot/ocamldep Binary files differindex 90534fe30f..98083c596f 100755 --- a/boot/ocamldep +++ b/boot/ocamldep diff --git a/boot/ocamllex b/boot/ocamllex Binary files differindex 4a839a9fcf..043c76967f 100755 --- a/boot/ocamllex +++ b/boot/ocamllex diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml index e08a7c3e02..82cb50a369 100644 --- a/bytecomp/bytegen.ml +++ b/bytecomp/bytegen.ml @@ -128,6 +128,7 @@ type rhs_kind = | RHS_block of int | RHS_floatblock of int | RHS_nonrec + | RHS_function of int * int ;; let rec check_recordwith_updates id e = @@ -139,8 +140,8 @@ let rec check_recordwith_updates id e = ;; let rec size_of_lambda = function - | Lfunction(kind, params, body) as funct -> - RHS_block (1 + IdentSet.cardinal(free_variables funct)) + | Lfunction{kind; params; body} as funct -> + RHS_function (1 + IdentSet.cardinal(free_variables funct), List.length params) | Llet (Strict, id, Lprim (Pduprecord (kind, size), _), body) when check_recordwith_updates id body -> begin match kind with @@ -367,6 +368,8 @@ let comp_primitive p args = let const_name = match c with | Big_endian -> "big_endian" | Word_size -> "word_size" + | Int_size -> "int_size" + | Max_wosize -> "max_wosize" | Ostype_unix -> "ostype_unix" | Ostype_win32 -> "ostype_win32" | Ostype_cygwin -> "ostype_cygwin" in @@ -449,7 +452,7 @@ let rec comp_expr env exp sz cont = end | Lconst cst -> Kconst cst :: cont - | Lapply(func, args, loc) -> + | Lapply(func, args, info) -> let nargs = List.length args in if is_tailcall cont then begin comp_args env args sz @@ -489,7 +492,7 @@ let rec comp_expr env exp sz cont = comp_args env args' (sz + 3) (getmethod :: Kapply nargs :: cont1) end - | Lfunction(kind, params, body) -> (* assume kind = Curried *) + | Lfunction{kind; params; body} -> (* assume kind = Curried *) let lbl = new_label() in let fv = IdentSet.elements(free_variables exp) in let to_compile = @@ -504,7 +507,7 @@ let rec comp_expr env exp sz cont = (add_pop 1 cont)) | Lletrec(decl, body) -> let ndecl = List.length decl in - if List.for_all (function (_, Lfunction(_,_,_)) -> true | _ -> false) + if List.for_all (function (_, Lfunction _) -> true | _ -> false) decl then begin (* let rec of functions *) let fv = @@ -512,7 +515,7 @@ let rec comp_expr env exp sz cont = let rec_idents = List.map (fun (id, lam) -> id) decl in let rec comp_fun pos = function [] -> [] - | (id, Lfunction(kind, params, body)) :: rem -> + | (id, Lfunction{kind; params; body}) :: rem -> let lbl = new_label() in let to_compile = { params = params; body = body; label = lbl; free_vars = fv; @@ -538,19 +541,25 @@ let rec comp_expr env exp sz cont = Kconst(Const_base(Const_int blocksize)) :: Kccall("caml_alloc_dummy", 1) :: Kpush :: comp_init (add_var id (sz+1) new_env) (sz+1) rem + | (id, exp, RHS_function (blocksize,arity)) :: rem -> + Kconst(Const_base(Const_int arity)) :: + Kpush :: + Kconst(Const_base(Const_int blocksize)) :: + Kccall("caml_alloc_dummy_function", 2) :: Kpush :: + comp_init (add_var id (sz+1) new_env) (sz+1) rem | (id, exp, RHS_nonrec) :: rem -> Kconst(Const_base(Const_int 0)) :: Kpush :: comp_init (add_var id (sz+1) new_env) (sz+1) rem and comp_nonrec new_env sz i = function | [] -> comp_rec new_env sz ndecl decl_size - | (id, exp, (RHS_block _ | RHS_floatblock _)) :: rem -> + | (id, exp, (RHS_block _ | RHS_floatblock _ | RHS_function _)) :: rem -> comp_nonrec new_env sz (i-1) rem | (id, exp, RHS_nonrec) :: rem -> comp_expr new_env exp sz (Kassign (i-1) :: comp_nonrec new_env sz (i-1) rem) and comp_rec new_env sz i = function | [] -> comp_expr new_env body sz (add_pop ndecl cont) - | (id, exp, (RHS_block _ | RHS_floatblock _)) :: rem -> + | (id, exp, (RHS_block _ | RHS_floatblock _ | RHS_function _)) :: rem -> comp_expr new_env exp sz (Kpush :: Kacc i :: Kccall("caml_update_dummy", 2) :: comp_rec new_env sz (i-1) rem) @@ -565,7 +574,7 @@ let rec comp_expr env exp sz cont = comp_expr env arg sz (add_const_unit cont) | Lprim(Pdirapply loc, [func;arg]) | Lprim(Prevapply loc, [arg;func]) -> - let exp = Lapply(func, [arg], loc) in + let exp = Lapply(func, [arg], mk_apply_info loc) in comp_expr env exp sz cont | Lprim(Pnot, [arg]) -> let newcont = diff --git a/bytecomp/bytelink.ml b/bytecomp/bytelink.ml index c0f8f6a935..422dbd552b 100644 --- a/bytecomp/bytelink.ml +++ b/bytecomp/bytelink.ml @@ -42,7 +42,7 @@ let lib_ccobjs = ref [] let lib_ccopts = ref [] let lib_dllibs = ref [] -let add_ccobjs l = +let add_ccobjs origin l = if not !Clflags.no_auto_link then begin if String.length !Clflags.use_runtime = 0 @@ -50,7 +50,8 @@ let add_ccobjs l = then begin if l.lib_custom then Clflags.custom_runtime := true; lib_ccobjs := l.lib_ccobjs @ !lib_ccobjs; - lib_ccopts := l.lib_ccopts @ !lib_ccopts; + let replace_origin = Misc.replace_substring ~before:"$CAMLORIGIN" ~after:origin in + lib_ccopts := List.map replace_origin l.lib_ccopts @ !lib_ccopts; end; lib_dllibs := l.lib_dllibs @ !lib_dllibs end @@ -132,7 +133,7 @@ let scan_file obj_name tolink = seek_in ic pos_toc; let toc = (input_value ic : library) in close_in ic; - add_ccobjs toc; + add_ccobjs (Filename.dirname file_name) toc; let required = List.fold_right (fun compunit reqd -> @@ -196,7 +197,7 @@ let clear_crc_interfaces () = (* Record compilation events *) -let debug_info = ref ([] : (int * LongString.t) list) +let debug_info = ref ([] : (int * Instruct.debug_event list * string list) list) (* Link in a compilation unit *) @@ -207,8 +208,14 @@ let link_compunit ppf output_fun currpos_fun inchan file_name compunit = Symtable.ls_patch_object code_block compunit.cu_reloc; if !Clflags.debug && compunit.cu_debug > 0 then begin seek_in inchan compunit.cu_debug; - let buffer = LongString.input_bytes inchan compunit.cu_debugsize in - debug_info := (currpos_fun(), buffer) :: !debug_info + let debug_event_list : Instruct.debug_event list = input_value inchan in + let debug_dirs : string list = input_value inchan in + let file_path = Filename.dirname (Location.absolute_path file_name) in + let debug_dirs = + if List.mem file_path debug_dirs + then debug_dirs + else file_path :: debug_dirs in + debug_info := (currpos_fun(), debug_event_list, debug_dirs) :: !debug_info end; Array.iter output_fun code_block; if !Clflags.link_everything then @@ -263,9 +270,10 @@ let link_file ppf output_fun currpos_fun = function let output_debug_info oc = output_binary_int oc (List.length !debug_info); List.iter - (fun (ofs, evl) -> + (fun (ofs, evl, debug_dirs) -> output_binary_int oc ofs; - Array.iter (output_bytes oc) evl) + output_value oc evl; + output_value oc debug_dirs) !debug_info; debug_info := [] @@ -309,7 +317,7 @@ let link_bytecode ppf tolink exec_name standalone = Bytesections.init_record outchan; (* The path to the bytecode interpreter (in use_runtime mode) *) if String.length !Clflags.use_runtime > 0 then begin - output_string outchan (make_absolute !Clflags.use_runtime); + output_string outchan ("#!" ^ (make_absolute !Clflags.use_runtime)); output_char outchan '\n'; Bytesections.record outchan "RNTM" end; @@ -572,22 +580,36 @@ let link ppf objfiles output_name = raise x end else begin let basename = Filename.chop_extension output_name in - let c_file = basename ^ ".c" - and obj_file = basename ^ Config.ext_obj in + let c_file = + if !Clflags.output_complete_object + then Filename.temp_file "camlobj" ".c" + else basename ^ ".c" + and obj_file = + if !Clflags.output_complete_object + then Filename.temp_file "camlobj" Config.ext_obj + else basename ^ Config.ext_obj + in if Sys.file_exists c_file then raise(Error(File_exists c_file)); let temps = ref [] in try link_bytecode_as_c ppf tolink c_file; if not (Filename.check_suffix output_name ".c") then begin temps := c_file :: !temps; - if Ccomp.compile_file c_file <> 0 then raise(Error Custom_runtime); - if not (Filename.check_suffix output_name Config.ext_obj) then begin + if Ccomp.compile_file ~output_name:(Some obj_file) c_file <> 0 then + raise(Error Custom_runtime); + if not (Filename.check_suffix output_name Config.ext_obj) || + !Clflags.output_complete_object then begin temps := obj_file :: !temps; + let mode, c_libs = + if Filename.check_suffix output_name Config.ext_obj + then Ccomp.Partial, "" + else Ccomp.MainDll, Config.bytecomp_c_libraries + in if not ( let runtime_lib = "-lcamlrun" ^ !Clflags.runtime_variant in - Ccomp.call_linker Ccomp.MainDll output_name + Ccomp.call_linker mode output_name ([obj_file] @ List.rev !Clflags.ccobjs @ [runtime_lib]) - Config.bytecomp_c_libraries + c_libs ) then raise (Error Custom_runtime); end end; diff --git a/bytecomp/bytepackager.ml b/bytecomp/bytepackager.ml index 05ebac9aad..d8493ab322 100644 --- a/bytecomp/bytepackager.ml +++ b/bytecomp/bytepackager.ml @@ -96,7 +96,7 @@ type pack_member = let read_member_info file = ( let name = - String.capitalize(Filename.basename(chop_extensions file)) in + String.capitalize_ascii(Filename.basename(chop_extensions file)) in let kind = if Filename.check_suffix file ".cmo" then begin let ic = open_in_bin file in @@ -261,7 +261,7 @@ let package_files ppf initial_env files targetfile = files in let prefix = chop_extensions targetfile in let targetcmi = prefix ^ ".cmi" in - let targetname = String.capitalize(Filename.basename prefix) in + let targetname = String.capitalize_ascii(Filename.basename prefix) in try let coercion = Typemod.package_units initial_env files targetcmi targetname in diff --git a/bytecomp/emitcode.ml b/bytecomp/emitcode.ml index e9a977656d..81e00b7bef 100644 --- a/bytecomp/emitcode.ml +++ b/bytecomp/emitcode.ml @@ -409,8 +409,9 @@ let to_memory init_code fun_code = LongString.unsafe_blit_to_bytes !out_buffer 0 code 0 !out_position; let reloc = List.rev !reloc_info and code_size = !out_position in + let events = !events in init(); - (code, code_size, reloc) + (code, code_size, reloc, events) (* Emission to a file for a packed library *) diff --git a/bytecomp/emitcode.mli b/bytecomp/emitcode.mli index e2fdb81551..f9dea1cf4a 100644 --- a/bytecomp/emitcode.mli +++ b/bytecomp/emitcode.mli @@ -22,14 +22,15 @@ val to_file: out_channel -> string -> string -> instruction list -> unit path of cmo file being written list of instructions to emit *) val to_memory: instruction list -> instruction list -> - bytes * int * (reloc_info * int) list + bytes * int * (reloc_info * int) list * debug_event list (* Arguments: initialization code (terminated by STOP) function code Results: block of relocatable bytecode size of this block - relocation information *) + relocation information + debug events *) val to_packed_file: out_channel -> instruction list -> (reloc_info * int) list (* Arguments: diff --git a/bytecomp/lambda.ml b/bytecomp/lambda.ml index 5d9fb593fa..7783368828 100644 --- a/bytecomp/lambda.ml +++ b/bytecomp/lambda.ml @@ -17,6 +17,8 @@ open Asttypes type compile_time_constant = | Big_endian | Word_size + | Int_size + | Max_wosize | Ostype_unix | Ostype_win32 | Ostype_cygwin @@ -159,6 +161,18 @@ type structured_constant = | Const_float_array of string list | Const_immstring of string +type apply_info = { + apply_loc : Location.t; + apply_should_be_tailcall : bool; (* true if [@tailcall] was specified *) +} + +let mk_apply_info ?(tailcall=false) loc = + {apply_loc=loc; + apply_should_be_tailcall=tailcall; } + +let no_apply_info = + {apply_loc=Location.none; apply_should_be_tailcall=false;} + type function_kind = Curried | Tupled type let_kind = Strict | Alias | StrictOpt | Variable @@ -170,8 +184,8 @@ type shared_code = (int * int) list type lambda = Lvar of Ident.t | Lconst of structured_constant - | Lapply of lambda * lambda list * Location.t - | Lfunction of function_kind * Ident.t list * lambda + | Lapply of lambda * lambda list * apply_info + | Lfunction of lfunction | Llet of let_kind * Ident.t * lambda * lambda | Lletrec of (Ident.t * lambda) list * lambda | Lprim of primitive * lambda list @@ -189,6 +203,11 @@ type lambda = | Levent of lambda * lambda_event | Lifused of Ident.t * lambda +and lfunction = + { kind: function_kind; + params: Ident.t list; + body: lambda } + and lambda_switch = { sw_numconsts: int; sw_consts: (int * lambda) list; @@ -238,8 +257,8 @@ let make_key e = (* 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) + | Lapply (e,es,info) -> + Lapply (tr_rec env e,tr_recs env es,{info with apply_loc=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 @@ -322,7 +341,7 @@ let iter f = function | Lconst _ -> () | Lapply(fn, args, _) -> f fn; List.iter f args - | Lfunction(kind, params, body) -> + | Lfunction{kind; params; body} -> f body | Llet(str, id, arg, body) -> f arg; f body @@ -376,7 +395,7 @@ let free_ids get l = iter free l; fv := List.fold_right IdentSet.add (get l) !fv; match l with - Lfunction(kind, params, body) -> + Lfunction{kind; params; body} -> List.iter (fun param -> fv := IdentSet.remove param !fv) params | Llet(str, id, arg, body) -> fv := IdentSet.remove id !fv @@ -468,7 +487,7 @@ let subst_lambda s lam = begin try Ident.find_same id s with Not_found -> l end | Lconst sc as l -> l | Lapply(fn, args, loc) -> Lapply(subst fn, List.map subst args, loc) - | Lfunction(kind, params, body) -> Lfunction(kind, params, subst body) + | Lfunction{kind; params; body} -> Lfunction{kind; params; body = subst body} | Llet(str, id, arg, body) -> Llet(str, id, subst arg, subst body) | Lletrec(decl, body) -> Lletrec(List.map subst_decl decl, subst body) | Lprim(p, args) -> Lprim(p, List.map subst args) @@ -539,10 +558,9 @@ let lam_of_loc kind loc = | Loc_FILE -> Lconst (Const_immstring file) | Loc_MODULE -> let filename = Filename.basename file in - let module_name = - try String.capitalize (Filename.chop_extension filename) - with Invalid_argument _ -> "//"^filename^"//" - in Lconst (Const_immstring module_name) + let name = Env.get_unit_name () in + let module_name = if name = "" then "//"^filename^"//" else name in + Lconst (Const_immstring module_name) | Loc_LOC -> let loc = Printf.sprintf "File %S, line %d, characters %d-%d" file lnum cnum enum in diff --git a/bytecomp/lambda.mli b/bytecomp/lambda.mli index 0e038d93d3..eba9593d7f 100644 --- a/bytecomp/lambda.mli +++ b/bytecomp/lambda.mli @@ -17,6 +17,8 @@ open Asttypes type compile_time_constant = | Big_endian | Word_size + | Int_size + | Max_wosize | Ostype_unix | Ostype_win32 | Ostype_cygwin @@ -159,6 +161,18 @@ type structured_constant = | Const_float_array of string list | Const_immstring of string +type apply_info = { + apply_loc : Location.t; + apply_should_be_tailcall : bool; (* true if [@tailcall] was specified *) +} + +val no_apply_info : apply_info +(** Default [apply_info]: no location, no tailcall *) + +val mk_apply_info : ?tailcall:bool -> Location.t -> apply_info +(** Build apply_info + @param tailcall if true, the application should be in tail position; default false *) + type function_kind = Curried | Tupled type let_kind = Strict | Alias | StrictOpt | Variable @@ -179,8 +193,8 @@ type shared_code = (int * int) list (* stack size -> code label *) type lambda = Lvar of Ident.t | Lconst of structured_constant - | Lapply of lambda * lambda list * Location.t - | Lfunction of function_kind * Ident.t list * lambda + | Lapply of lambda * lambda list * apply_info + | Lfunction of lfunction | Llet of let_kind * Ident.t * lambda * lambda | Lletrec of (Ident.t * lambda) list * lambda | Lprim of primitive * lambda list @@ -200,6 +214,11 @@ type lambda = | Levent of lambda * lambda_event | Lifused of Ident.t * lambda +and lfunction = + { kind: function_kind; + params: Ident.t list; + body: lambda } + and lambda_switch = { sw_numconsts: int; (* Number of integer cases *) sw_consts: (int * lambda) list; (* Integer cases *) diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml index cba32391e9..1bdeef8ea7 100644 --- a/bytecomp/matching.ml +++ b/bytecomp/matching.ml @@ -1526,7 +1526,7 @@ let inline_lazy_force_cond arg loc = (* ... if (tag == Obj.lazy_tag) then Lazy.force varg else ... *) Lprim(Pintcomp Ceq, [Lvar tag; Lconst(Const_base(Const_int Obj.lazy_tag))]), - Lapply(force_fun, [varg], loc), + Lapply(force_fun, [varg], mk_apply_info loc), (* ... arg *) varg)))) @@ -1544,7 +1544,7 @@ let inline_lazy_force_switch arg loc = sw_blocks = [ (Obj.forward_tag, Lprim(Pfield 0, [varg])); (Obj.lazy_tag, - Lapply(force_fun, [varg], loc)) ]; + Lapply(force_fun, [varg], mk_apply_info loc)) ]; sw_failaction = Some varg } )))) let inline_lazy_force arg loc = @@ -2055,10 +2055,10 @@ let as_interval_canfail fail low high l = 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 ()) ; + eprintf "STORE [%s] %i %s\n" tag i (string_of_lam act) ; *) i in @@ -2095,7 +2095,7 @@ let as_interval_canfail fail low high l = nofail_rec i i index rem in let init_rec = function - | [] -> [] + | [] -> [low,high,0] | (i,act_i)::rem -> let index = do_store "INIT" act_i in if index=0 then @@ -2246,20 +2246,20 @@ let mk_failaction_neg partial ctx def = match partial with | Partial -> begin match def with | (_,idef)::_ -> - Some (Lstaticraise (idef,[])),[],jumps_singleton idef ctx - | _ -> + Some (Lstaticraise (idef,[])),jumps_singleton idef ctx + | [] -> (* Act as Total, this means If no appropriate default matrix exists, then this switch cannot fail *) - None, [], jumps_empty + None, jumps_empty end | Total -> - None, [], jumps_empty + None, jumps_empty (* Conforme a l'article et plus simple qu'avant *) -and mk_failaction_pos partial seen ctx defs = +let mk_failaction_pos partial seen ctx defs = if dbg then begin prerr_endline "**POS**" ; pretty_def defs ; @@ -2286,19 +2286,35 @@ and mk_failaction_pos partial seen ctx defs = | [] -> scan_def env to_test rem | _ -> scan_def ((List.map fst now,idef)::env) later rem in - scan_def - [] - (List.map - (fun pat -> pat, ctx_lub pat ctx) - (complete_pats_constrs seen)) - defs - + let fail_pats = complete_pats_constrs seen in + if List.length fail_pats < 32 then begin + let fail,jmps = + scan_def + [] + (List.map + (fun pat -> pat, ctx_lub pat ctx) + fail_pats) + defs in + if dbg then begin + eprintf "POSITIVE JUMPS [%i]:\n" (List.length fail_pats); + pretty_jumps jmps + end ; + None,fail,jmps + end else begin (* Two many non-matched constructors -> reduced information *) + if dbg then eprintf "POS->NEG!!!\n%!" ; + let fail,jumps = mk_failaction_neg partial ctx defs in + if dbg then + eprintf "FAIL: %s\n" + (match fail with + | None -> "<none>" + | Some lam -> string_of_lam lam) ; + fail,[],jumps + end let combine_constant arg cst partial ctx def (const_lambda_list, total, pats) = - let fail, to_add, local_jumps = + let fail, local_jumps = mk_failaction_neg partial ctx def in - let const_lambda_list = to_add@const_lambda_list in let lambda1 = match cst with | Const_int _ -> @@ -2379,9 +2395,8 @@ 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 extensions *) - let fail, to_add, local_jumps = + let fail, local_jumps = mk_failaction_neg partial ctx def in - let tag_lambda_list = to_add@tag_lambda_list in let lambda1 = let consts, nonconsts = split_extension_cases tag_lambda_list in let default, consts, nonconsts = @@ -2424,42 +2439,52 @@ let combine_constructor arg ex_pat cstr partial ctx def let ncases = List.length tag_lambda_list and nconstrs = cstr.cstr_consts + cstr.cstr_nonconsts in let sig_complete = ncases = nconstrs in - let fails,local_jumps = - if sig_complete then [],jumps_empty + let fail_opt,fails,local_jumps = + if sig_complete then None,[],jumps_empty else mk_failaction_pos partial pats ctx def in let tag_lambda_list = fails @ tag_lambda_list in let (consts, nonconsts) = split_cases tag_lambda_list in let lambda1 = - match same_actions tag_lambda_list with - | Some act -> act + match fail_opt,same_actions tag_lambda_list with + | None,Some act -> act (* Identical actions, no failure *) | _ -> match (cstr.cstr_consts, cstr.cstr_nonconsts, consts, nonconsts) with | (1, 1, [0, act1], [0, act2]) -> + (* Typically, match on lists, will avoid isint primitive in that case *) Lifthenelse(arg, act2, act1) - | (n,_,_,[]) -> - call_switcher None arg 0 (n-1) consts + | (n,0,_,[]) -> (* The type defines constant constructors only *) + call_switcher fail_opt arg 0 (n-1) consts | (n, _, _, _) -> - match same_actions nonconsts with - | None -> + let act0 = + (* = Some act when all non-const constructors match to act *) + match fail_opt,nonconsts with + | Some a,[] -> Some a + | Some _,_ -> + if List.length nonconsts = cstr.cstr_nonconsts then + same_actions nonconsts + else None + | None,_ -> same_actions nonconsts in + match act0 with + | Some act -> + Lifthenelse + (Lprim (Pisint, [arg]), + call_switcher + fail_opt arg + 0 (n-1) consts, + act) (* Emit a switch, as bytecode implements this sophisticated instruction *) + | None -> let sw = {sw_numconsts = cstr.cstr_consts; sw_consts = consts; sw_numblocks = cstr.cstr_nonconsts; sw_blocks = nonconsts; - sw_failaction = None} in + sw_failaction = fail_opt} 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 - None arg - 0 (n-1) consts, - act) in + hs (Lswitch (arg,sw)) in lambda1, jumps_union local_jumps total1 end @@ -2494,14 +2519,13 @@ let combine_variant row arg partial ctx def (tag_lambda_list, total1, pats) = Lifthenelse(Lprim (Pisint, [arg]), if_int, if_block) in let sig_complete = List.length tag_lambda_list = !num_constr and one_action = same_actions tag_lambda_list in - let fail, to_add, local_jumps = + let fail, local_jumps = if sig_complete || (match partial with Total -> true | _ -> false) then - None, [], jumps_empty + None, jumps_empty else mk_failaction_neg partial ctx def in - let tag_lambda_list = to_add@tag_lambda_list in let (consts, nonconsts) = split_cases tag_lambda_list in let lambda1 = match fail, one_action with | None, Some act -> act @@ -2533,8 +2557,7 @@ let combine_variant row arg partial ctx def (tag_lambda_list, total1, pats) = let combine_array arg kind partial ctx def (len_lambda_list, total1, pats) = - let fail, to_add, local_jumps = mk_failaction_neg partial ctx def in - let len_lambda_list = to_add @ len_lambda_list in + let fail, local_jumps = mk_failaction_neg partial ctx def in let lambda1 = let newvar = Ident.create "len" in let switch = @@ -2637,8 +2660,8 @@ let compile_test compile_fun partial divide combine ctx to_match = match c_div with | [],_,_ -> begin match mk_failaction_neg partial ctx to_match.default with - | None,_,_ -> raise Unused - | Some l,_,total -> l,total + | None,_ -> raise Unused + | Some l,total -> l,total end | _ -> combine ctx to_match.default c_div diff --git a/bytecomp/meta.ml b/bytecomp/meta.ml index f7711ff15e..42c978a325 100644 --- a/bytecomp/meta.ml +++ b/bytecomp/meta.ml @@ -23,3 +23,7 @@ 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 = "caml_get_section_table" +external add_debug_info : bytes -> int -> Instruct.debug_event list array -> unit + = "caml_add_debug_info" +external remove_debug_info : bytes -> unit + = "caml_remove_debug_info" diff --git a/bytecomp/meta.mli b/bytecomp/meta.mli index cb3565dcc8..9147dade4a 100644 --- a/bytecomp/meta.mli +++ b/bytecomp/meta.mli @@ -25,3 +25,7 @@ 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 = "caml_get_section_table" +external add_debug_info : bytes -> int -> Instruct.debug_event list array -> unit + = "caml_add_debug_info" +external remove_debug_info : bytes -> unit + = "caml_remove_debug_info" diff --git a/bytecomp/printlambda.ml b/bytecomp/printlambda.ml index 1b9085edd5..591822f3b8 100644 --- a/bytecomp/printlambda.ml +++ b/bytecomp/printlambda.ml @@ -40,6 +40,12 @@ let rec struct_const ppf = function List.iter (fun f -> fprintf ppf "@ %s" f) fl in fprintf ppf "@[<1>[|@[%s%a@]|]@]" f1 floats fl +let array_kind = function + | Pgenarray -> "gen" + | Paddrarray -> "addr" + | Pintarray -> "int" + | Pfloatarray -> "float" + let boxed_integer_name = function | Pnativeint -> "nativeint" | Pint32 -> "int32" @@ -158,16 +164,18 @@ let primitive ppf = function | Pstringsetu -> fprintf ppf "string.unsafe_set" | Pstringrefs -> fprintf ppf "string.get" | Pstringsets -> fprintf ppf "string.set" - | Parraylength _ -> fprintf ppf "array.length" - | Pmakearray _ -> fprintf ppf "makearray " - | Parrayrefu _ -> fprintf ppf "array.unsafe_get" - | Parraysetu _ -> fprintf ppf "array.unsafe_set" - | Parrayrefs _ -> fprintf ppf "array.get" - | Parraysets _ -> fprintf ppf "array.set" + | Parraylength k -> fprintf ppf "array.length[%s]" (array_kind k) + | Pmakearray k -> fprintf ppf "makearray[%s]" (array_kind k) + | Parrayrefu k -> fprintf ppf "array.unsafe_get[%s]" (array_kind k) + | Parraysetu k -> fprintf ppf "array.unsafe_set[%s]" (array_kind k) + | Parrayrefs k -> fprintf ppf "array.get[%s]" (array_kind k) + | Parraysets k -> fprintf ppf "array.set[%s]" (array_kind k) | Pctconst c -> let const_name = match c with | Big_endian -> "big_endian" | Word_size -> "word_size" + | Int_size -> "int_size" + | Max_wosize -> "max_wosize" | Ostype_unix -> "ostype_unix" | Ostype_win32 -> "ostype_win32" | Ostype_cygwin -> "ostype_cygwin" in @@ -246,11 +254,15 @@ let rec lam ppf = function Ident.print ppf id | Lconst cst -> struct_const ppf cst + | Lapply(lfun, largs, info) when info.apply_should_be_tailcall -> + let lams ppf largs = + List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in + fprintf ppf "@[<2>(apply@ %a%a @@tailcall)@]" lam lfun lams largs | Lapply(lfun, largs, _) -> let lams ppf largs = List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in fprintf ppf "@[<2>(apply@ %a%a)@]" lam lfun lams largs - | Lfunction(kind, params, body) -> + | Lfunction{kind; params; body} -> let pr_params ppf params = match kind with | Curried -> diff --git a/bytecomp/simplif.ml b/bytecomp/simplif.ml index fd3d21c173..953abe7407 100644 --- a/bytecomp/simplif.ml +++ b/bytecomp/simplif.ml @@ -24,9 +24,9 @@ let rec eliminate_ref id = function Lvar v as lam -> if Ident.same v id then raise Real_reference else lam | Lconst cst as lam -> lam - | Lapply(e1, el, loc) -> - Lapply(eliminate_ref id e1, List.map (eliminate_ref id) el, loc) - | Lfunction(kind, params, body) as lam -> + | Lapply(e1, el, info) -> + Lapply(eliminate_ref id e1, List.map (eliminate_ref id) el, info) + | Lfunction{kind; params; body} as lam -> if IdentSet.mem id (free_variables lam) then raise Real_reference else lam @@ -107,7 +107,7 @@ let simplify_exits lam = let rec count = function | (Lvar _| Lconst _) -> () | Lapply(l1, ll, _) -> count l1; List.iter count ll - | Lfunction(kind, params, l) -> count l + | Lfunction{kind; params; body = l} -> count l | Llet(str, v, l1, l2) -> count l2; count l1 | Lletrec(bindings, body) -> @@ -193,8 +193,9 @@ let simplify_exits lam = let rec simplif = function | (Lvar _|Lconst _) as l -> l - | Lapply(l1, ll, loc) -> Lapply(simplif l1, List.map simplif ll, loc) - | Lfunction(kind, params, l) -> Lfunction(kind, params, simplif l) + | Lapply(l1, ll, info) -> Lapply(simplif l1, List.map simplif ll, info) + | Lfunction{kind; params; body = l} -> + Lfunction{kind; params; body = simplif l} | Llet(kind, v, l1, l2) -> Llet(kind, v, simplif l1, simplif l2) | Lletrec(bindings, body) -> Lletrec(List.map (fun (v, l) -> (v, simplif l)) bindings, simplif body) @@ -202,16 +203,16 @@ let simplify_exits lam = let ll = List.map simplif ll in match p, ll with (* Simplify %revapply, for n-ary functions with n > 1 *) - | Prevapply loc, [x; Lapply(f, args, _)] - | Prevapply loc, [x; Levent (Lapply(f, args, _),_)] -> - Lapply(f, args@[x], loc) - | Prevapply loc, [x; f] -> Lapply(f, [x], loc) + | Prevapply loc, [x; Lapply(f, args, info)] + | Prevapply loc, [x; Levent (Lapply(f, args, info),_)] -> + Lapply(f, args@[x], {info with apply_loc=loc}) + | Prevapply loc, [x; f] -> Lapply(f, [x], mk_apply_info loc) (* Simplify %apply, for n-ary functions with n > 1 *) - | Pdirapply loc, [Lapply(f, args, _); x] - | Pdirapply loc, [Levent (Lapply(f, args, _),_); x] -> - Lapply(f, args@[x], loc) - | Pdirapply loc, [f; x] -> Lapply(f, [x], loc) + | Pdirapply loc, [Lapply(f, args, info); x] + | Pdirapply loc, [Levent (Lapply(f, args, info),_); x] -> + Lapply(f, args@[x], {info with apply_loc=loc}) + | Pdirapply loc, [f; x] -> Lapply(f, [x], mk_apply_info loc) | _ -> Lprim(p, ll) end @@ -338,15 +339,15 @@ let simplify_lets lam = | Lconst cst -> () | Lvar v -> use_var bv v 1 - | Lapply(Lfunction(Curried, params, body), args, _) + | Lapply(Lfunction{kind = Curried; params; body}, args, _) when optimize && List.length params = List.length args -> count bv (beta_reduce params body args) - | Lapply(Lfunction(Tupled, params, body), [Lprim(Pmakeblock _, args)], _) + | Lapply(Lfunction{kind = Tupled; params; body}, [Lprim(Pmakeblock _, args)], _) when optimize && List.length params = List.length args -> count bv (beta_reduce params body args) | Lapply(l1, ll, _) -> count bv l1; List.iter (count bv) ll - | Lfunction(kind, params, l) -> + | Lfunction{kind; params; body = l} -> count Tbl.empty l | Llet(str, v, Lvar w, l2) when optimize -> (* v will be replaced by w in l2, so each occurrence of v in l2 @@ -430,14 +431,22 @@ let simplify_lets lam = l end | Lconst cst as l -> l - | Lapply(Lfunction(Curried, params, body), args, _) + | Lapply(Lfunction{kind = Curried; params; body}, args, _) when optimize && List.length params = List.length args -> simplif (beta_reduce params body args) - | Lapply(Lfunction(Tupled, params, body), [Lprim(Pmakeblock _, args)], _) + | Lapply(Lfunction{kind = Tupled; params; body}, + [Lprim(Pmakeblock _, args)], _) when optimize && List.length params = List.length args -> simplif (beta_reduce params body args) | Lapply(l1, ll, loc) -> Lapply(simplif l1, List.map simplif ll, loc) - | Lfunction(kind, params, l) -> Lfunction(kind, params, simplif l) + | Lfunction{kind; params; body = l} -> + begin match simplif l with + Lfunction{kind=Curried; params=params'; body} + when kind = Curried && optimize -> + Lfunction{kind; params = params @ params'; body} + | body -> + Lfunction{kind; params; body} + end | Llet(str, v, Lvar w, l2) when optimize -> Hashtbl.add subst v (simplif (Lvar w)); simplif l2 @@ -516,10 +525,16 @@ let rec emit_tail_infos is_tail lambda = match lambda with | Lvar _ -> () | Lconst _ -> () - | Lapply (func, l, loc) -> + | Lapply (func, l, ({apply_loc=loc} as info)) -> + if info.apply_should_be_tailcall + && not is_tail + && Warnings.is_active Warnings.Expect_tailcall + then Location.prerr_warning loc Warnings.Expect_tailcall; + emit_tail_infos false func; list_emit_tail_infos false l; - Stypes.record (Stypes.An_call (loc, call_kind l)) - | Lfunction (_, _, lam) -> + if !Clflags.annotations then + Stypes.record (Stypes.An_call (loc, call_kind l)); + | Lfunction {body = lam} -> emit_tail_infos true lam | Llet (_, _, lam, body) -> emit_tail_infos false lam; @@ -574,7 +589,8 @@ let rec emit_tail_infos is_tail lambda = emit_tail_infos false meth; emit_tail_infos false obj; list_emit_tail_infos false args; - Stypes.record (Stypes.An_call (loc, call_kind (obj :: args))) + if !Clflags.annotations then + Stypes.record (Stypes.An_call (loc, call_kind (obj :: args))); | Levent (lam, _) -> emit_tail_infos is_tail lam | Lifused (_, lam) -> @@ -589,5 +605,6 @@ and list_emit_tail_infos is_tail = let simplify_lambda lam = let res = simplify_lets (simplify_exits lam) in - if !Clflags.annotations then emit_tail_infos true res; + if !Clflags.annotations || Warnings.is_active Warnings.Expect_tailcall + then emit_tail_infos true res; res diff --git a/bytecomp/switch.ml b/bytecomp/switch.ml index da9a48f1a9..4e49520dcb 100644 --- a/bytecomp/switch.ml +++ b/bytecomp/switch.ml @@ -832,8 +832,9 @@ let do_zyva (low,high) arg cases actions = if !ok_inter <> old_ok then Hashtbl.clear t ; let s = {cases=cases ; actions=actions} in + (* - Printf.eprintf "ZYVA: %b\n" !ok_inter ; + Printf.eprintf "ZYVA: %b [low=%i,high=%i]\n" !ok_inter low high ; pcases stderr cases ; prerr_endline "" ; *) @@ -857,11 +858,13 @@ let abstract_shared actions = !handlers,actions let zyva lh arg cases actions = + assert (Array.length cases > 0) ; 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 = + assert (Array.length cases > 0) ; let actions = actions.act_get_shared () in let hs,actions = abstract_shared actions in let old_ok = !ok_inter in diff --git a/bytecomp/symtable.ml b/bytecomp/symtable.ml index 1cc3a5314d..a0ce27373e 100644 --- a/bytecomp/symtable.ml +++ b/bytecomp/symtable.ml @@ -81,7 +81,9 @@ let num_of_prim name = try find_numtable !c_prim_table name with Not_found -> - if !Clflags.custom_runtime then + if !Clflags.custom_runtime || Config.host <> Config.target + || !Clflags.no_check_prims + then enter_numtable c_prim_table name else begin let symb = diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml index 0fb68457b0..f172e9a9ac 100644 --- a/bytecomp/translclass.ml +++ b/bytecomp/translclass.ml @@ -26,10 +26,10 @@ exception Error of Location.t * error let lfunction params body = if params = [] then body else match body with - Lfunction (Curried, params', body') -> - Lfunction (Curried, params @ params', body') + | Lfunction {kind = Curried; params = params'; body = body'} -> + Lfunction {kind = Curried; params = params @ params'; body = body'} | _ -> - Lfunction (Curried, params, body) + Lfunction {kind = Curried; params; body} let lapply func args loc = match func with @@ -38,7 +38,7 @@ let lapply func args loc = | _ -> Lapply(func, args, loc) -let mkappl (func, args) = Lapply (func, args, Location.none);; +let mkappl (func, args) = Lapply (func, args, no_apply_info);; let lsequence l1 l2 = if l2 = lambda_unit then l1 else Lsequence(l1, l2) @@ -167,13 +167,13 @@ let rec build_object_init cl_table obj params inh_init obj_init cl = (inh_init, let build params rem = let param = name_pattern "param" pat in - Lfunction (Curried, param::params, - Matching.for_function - pat.pat_loc None (Lvar param) [pat, rem] partial) + Lfunction {kind = Curried; params = param::params; + body = Matching.for_function + pat.pat_loc None (Lvar param) [pat, rem] partial} in begin match obj_init with - Lfunction (Curried, params, rem) -> build params rem - | rem -> build [] rem + Lfunction {kind = Curried; params; body = rem} -> build params rem + | rem -> build [] rem end) | Tcl_apply (cl, oexprs) -> let (inh_init, obj_init) = @@ -411,14 +411,14 @@ let rec transl_class_rebind obj_init cl vf = let path, obj_init = transl_class_rebind obj_init cl vf in let build params rem = let param = name_pattern "param" pat in - Lfunction (Curried, param::params, - Matching.for_function - pat.pat_loc None (Lvar param) [pat, rem] partial) + Lfunction {kind = Curried; params = param::params; + body = Matching.for_function + pat.pat_loc None (Lvar param) [pat, rem] partial} in (path, match obj_init with - Lfunction (Curried, params, rem) -> build params rem - | rem -> build [] rem) + Lfunction {kind = Curried; params; body} -> build params body + | rem -> build [] rem) | Tcl_apply (cl, oexprs) -> let path, obj_init = transl_class_rebind obj_init cl vf in (path, transl_apply obj_init oexprs Location.none) @@ -449,7 +449,7 @@ let transl_class_rebind ids cl vf = try let obj_init = Ident.create "obj_init" and self = Ident.create "self" in - let obj_init0 = lapply (Lvar obj_init) [Lvar self] Location.none in + let obj_init0 = lapply (Lvar obj_init) [Lvar self] no_apply_info in let path, obj_init' = transl_class_rebind_0 self obj_init0 cl vf in if not (Translcore.check_recursive_lambda ids obj_init') then raise(Error(cl.cl_loc, Illegal_class_expr)); @@ -490,7 +490,7 @@ let rec module_path = function let const_path local = function Lvar id -> not (List.mem id local) | Lconst _ -> true - | Lfunction (Curried, _, body) -> + | Lfunction {kind = Curried; body} -> let fv = free_variables body in List.for_all (fun x -> not (IdentSet.mem x fv)) local | p -> module_path p @@ -530,7 +530,7 @@ let rec builtin_meths self env env2 body = | Lsend(Cached, met, arg, [_;_], _) -> let s, args = conv arg in ("send_"^s, met :: args) - | Lfunction (Curried, [x], body) -> + | Lfunction {kind = Curried; params = [x]; body} -> let rec enter self = function | Lprim(Parraysetu _, [Lvar s; Lvar n; Lvar x']) when Ident.same x x' && List.mem s self -> @@ -638,7 +638,7 @@ let transl_class ids cl_id pub_meths cl vflag = in let new_ids_meths = ref [] in let msubst arr = function - Lfunction (Curried, self :: args, body) -> + Lfunction {kind = Curried; params = self :: args; body} -> let env = Ident.create "env" in let body' = if new_ids = [] then body else @@ -710,7 +710,8 @@ let transl_class ids cl_id pub_meths cl vflag = let concrete = (vflag = Concrete) and lclass lam = - let cl_init = llets (Lfunction(Curried, [cla], cl_init)) in + let cl_init = llets (Lfunction{kind = Curried; + params = [cla]; body = cl_init}) in Llet(Strict, class_init, cl_init, lam (free_variables cl_init)) and lbody fv = if List.for_all (fun id -> not (IdentSet.mem id fv)) ids then @@ -727,7 +728,8 @@ let transl_class ids cl_id pub_meths cl vflag = Lvar class_init; Lvar env_init; lambda_unit])))) and lbody_virt lenvs = Lprim(Pmakeblock(0, Immutable), - [lambda_unit; Lfunction(Curried,[cla], cl_init); lambda_unit; lenvs]) + [lambda_unit; Lfunction{kind = Curried; params = [cla]; body = cl_init}; + lambda_unit; lenvs]) in (* Still easy: a class defined at toplevel *) if top && concrete then lclass lbody else @@ -769,7 +771,8 @@ let transl_class ids cl_id pub_meths cl vflag = List.map (fun (_,p) -> Lprim(Pfield 1, [transl_normal_path p])) inh_paths in let lclass lam = Llet(Strict, class_init, - Lfunction(Curried, [cla], def_ids cla cl_init), lam) + Lfunction{kind = Curried; params = [cla]; + body = def_ids cla cl_init}, lam) and lcache lam = if inh_keys = [] then Llet(Alias, cached, Lvar tables, lam) else Llet(Strict, cached, @@ -785,7 +788,8 @@ let transl_class ids cl_id pub_meths cl vflag = Lsequence(mkappl (oo_prim "init_class", [Lvar cla]), lset cached 0 (Lvar env_init)))) and lclass_virt () = - lset cached 0 (Lfunction(Curried, [cla], def_ids cla cl_init)) + lset cached 0 (Lfunction{kind = Curried; + params = [cla]; body = def_ids cla cl_init}) in llets ( lcache ( diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml index 5e07978305..e7f5a3ae0a 100644 --- a/bytecomp/translcore.ml +++ b/bytecomp/translcore.ml @@ -154,6 +154,8 @@ let primitives_table = create_hashtable 57 [ "%boolnot", Pnot; "%big_endian", Pctconst Big_endian; "%word_size", Pctconst Word_size; + "%int_size", Pctconst Int_size; + "%max_wosize", Pctconst Max_wosize; "%ostype_unix", Pctconst Ostype_unix; "%ostype_win32", Pctconst Ostype_win32; "%ostype_cygwin", Pctconst Ostype_cygwin; @@ -314,6 +316,21 @@ let primitives_table = create_hashtable 57 [ "%int_as_pointer", Pint_as_pointer; ] +let index_primitives_table = + let make_ba_ref n="%caml_ba_opt_ref_"^(string_of_int n), + fun () -> Pbigarrayref(!Clflags.fast, n, Pbigarray_unknown, Pbigarray_unknown_layout) + and make_ba_set n="%caml_ba_opt_set_"^(string_of_int n), + fun () -> Pbigarrayset(!Clflags.fast, n, Pbigarray_unknown, Pbigarray_unknown_layout) in + create_hashtable 10 [ + "%array_opt_get", ( fun () -> if !Clflags.fast then Parrayrefu Pgenarray else Parrayrefs Pgenarray ); + "%array_opt_set", ( fun () -> if !Clflags.fast then Parraysetu Pgenarray else Parraysets Pgenarray ); + "%string_opt_get", ( fun () -> if !Clflags.fast then Pstringrefu else Pstringrefs ); + "%string_opt_set", ( fun () -> if !Clflags.fast then Pstringsetu else Pstringsets ); + make_ba_ref 1; make_ba_set 1; + make_ba_ref 2; make_ba_set 2; + make_ba_ref 3; make_ba_set 3; +] + let prim_makearray = { prim_name = "caml_make_vect"; prim_arity = 2; prim_alloc = true; prim_native_name = ""; prim_native_float = false } @@ -331,105 +348,109 @@ let find_primitive loc prim_name = | "%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 = - let prim_name = prim.prim_name in + | name -> + try Hashtbl.find index_primitives_table name @@ () with + | Not_found -> Hashtbl.find primitives_table name + +let specialize_comparison table env ty = + let (gencomp, intcomp, floatcomp, stringcomp, + nativeintcomp, int32comp, int64comp, _) = table in + match () with + | () when is_base_type env ty Predef.path_int + || is_base_type env ty Predef.path_char + || not (maybe_pointer_type env ty) -> intcomp + | () when is_base_type env ty Predef.path_float -> floatcomp + | () when is_base_type env ty Predef.path_string -> stringcomp + | () when is_base_type env ty Predef.path_nativeint -> nativeintcomp + | () when is_base_type env ty Predef.path_int32 -> int32comp + | () when is_base_type env ty Predef.path_int64 -> int64comp + | () -> gencomp + +(* Specialize a primitive from available type information, + raise Not_found if primitive is unknown *) + +let specialize_primitive loc p env ty ~has_constant_constructor = try - let (gencomp, intcomp, floatcomp, stringcomp, - nativeintcomp, int32comp, int64comp, - simplify_constant_constructor) = - Hashtbl.find comparisons_table prim_name in - begin match args with - [arg1; {exp_desc = Texp_construct(_, {cstr_tag = Cstr_constant _}, _)}] - when simplify_constant_constructor -> - intcomp - | [{exp_desc = Texp_construct(_, {cstr_tag = Cstr_constant _}, _)}; arg2] - when simplify_constant_constructor -> - intcomp - | [arg1; {exp_desc = Texp_variant(_, None)}] - when simplify_constant_constructor -> - intcomp - | [{exp_desc = Texp_variant(_, None)}; exp2] - when simplify_constant_constructor -> - intcomp - | [arg1; arg2] when has_base_type arg1 Predef.path_int - || has_base_type arg1 Predef.path_char -> - intcomp - | [arg1; arg2] when has_base_type arg1 Predef.path_float -> - floatcomp - | [arg1; arg2] when has_base_type arg1 Predef.path_string -> - stringcomp - | [arg1; arg2] when has_base_type arg1 Predef.path_nativeint -> - nativeintcomp - | [arg1; arg2] when has_base_type arg1 Predef.path_int32 -> - int32comp - | [arg1; arg2] when has_base_type arg1 Predef.path_int64 -> - int64comp - | _ -> - gencomp - end + let table = Hashtbl.find comparisons_table p.prim_name in + let (gencomp, intcomp, _, _, _, _, _, simplify_constant_constructor) = + table in + if has_constant_constructor && simplify_constant_constructor then + intcomp + else + match is_function_type env ty with + | Some (lhs,rhs) -> specialize_comparison table env lhs + | None -> gencomp with Not_found -> - try - let p = find_primitive loc prim_name in + let p = find_primitive loc p.prim_name in (* Try strength reduction based on the type of the argument *) - begin match (p, args) with - (Psetfield(n, _), [arg1; arg2]) -> Psetfield(n, maybe_pointer arg2) - | (Parraylength Pgenarray, [arg]) -> Parraylength(array_kind arg) - | (Parrayrefu Pgenarray, arg1 :: _) -> Parrayrefu(array_kind arg1) - | (Parraysetu Pgenarray, arg1 :: _) -> Parraysetu(array_kind arg1) - | (Parrayrefs Pgenarray, arg1 :: _) -> Parrayrefs(array_kind arg1) - | (Parraysets Pgenarray, arg1 :: _) -> Parraysets(array_kind arg1) - | (Pbigarrayref(unsafe, n, Pbigarray_unknown, Pbigarray_unknown_layout), - arg1 :: _) -> - let (k, l) = bigarray_kind_and_layout arg1 in - Pbigarrayref(unsafe, n, k, l) - | (Pbigarrayset(unsafe, n, Pbigarray_unknown, Pbigarray_unknown_layout), - arg1 :: _) -> - let (k, l) = bigarray_kind_and_layout arg1 in - Pbigarrayset(unsafe, n, k, l) - | _ -> p - end - with Not_found -> - if String.length prim_name > 0 && prim_name.[0] = '%' then - raise(Error(loc, Unknown_builtin_primitive prim_name)); - Pccall prim - - -(* Eta-expand a primitive without knowing the types of its arguments *) - -let transl_primitive loc p = + let params = match is_function_type env ty with + | None -> [] + | Some (p1, rhs) -> match is_function_type env rhs with + | None -> [p1] + | Some (p2, _) -> [p1;p2] + in + match (p, params) with + (Psetfield(n, _), [p1; p2]) -> Psetfield(n, maybe_pointer_type env p2) + | (Parraylength Pgenarray, [p]) -> Parraylength(array_type_kind env p) + | (Parrayrefu Pgenarray, p1 :: _) -> Parrayrefu(array_type_kind env p1) + | (Parraysetu Pgenarray, p1 :: _) -> Parraysetu(array_type_kind env p1) + | (Parrayrefs Pgenarray, p1 :: _) -> Parrayrefs(array_type_kind env p1) + | (Parraysets Pgenarray, p1 :: _) -> Parraysets(array_type_kind env p1) + | (Pbigarrayref(unsafe, n, Pbigarray_unknown, Pbigarray_unknown_layout), + p1 :: _) -> + let (k, l) = bigarray_type_kind_and_layout env p1 in + Pbigarrayref(unsafe, n, k, l) + | (Pbigarrayset(unsafe, n, Pbigarray_unknown, Pbigarray_unknown_layout), + p1 :: _) -> + let (k, l) = bigarray_type_kind_and_layout env p1 in + Pbigarrayset(unsafe, n, k, l) + | _ -> p + +(* Eta-expand a primitive *) + +let transl_primitive loc p env ty = let prim = - try - let (gencomp, _, _, _, _, _, _, _) = - Hashtbl.find comparisons_table p.prim_name in - gencomp - with Not_found -> - try - find_primitive loc p.prim_name - with Not_found -> - Pccall p in + try specialize_primitive loc p env ty ~has_constant_constructor:false + with Not_found -> Pccall p + in match prim with | Plazyforce -> let parm = Ident.create "prim" in - Lfunction(Curried, [parm], - Matching.inline_lazy_force (Lvar parm) Location.none) + Lfunction{kind = Curried; params = [parm]; + body = 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])) + Lfunction{kind = Curried; params = [param]; + body = 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 let params = make_params p.prim_arity in - Lfunction(Curried, params, - Lprim(prim, List.map (fun id -> Lvar id) params)) + Lfunction{ kind = Curried; params; + body = Lprim(prim, List.map (fun id -> Lvar id) params) } + +let transl_primitive_application loc prim env ty args = + let prim_name = prim.prim_name in + try + let has_constant_constructor = match args with + [_; {exp_desc = Texp_construct(_, {cstr_tag = Cstr_constant _}, _)}] + | [{exp_desc = Texp_construct(_, {cstr_tag = Cstr_constant _}, _)}; _] + | [_; {exp_desc = Texp_variant(_, None)}] + | [{exp_desc = Texp_variant(_, None)}; _] -> true + | _ -> false + in + specialize_primitive loc prim env ty ~has_constant_constructor + with Not_found -> + if String.length prim_name > 0 && prim_name.[0] = '%' then + raise(Error(loc, Unknown_builtin_primitive prim_name)); + Pccall prim + (* To check the well-formedness of r.h.s. of "let rec" definitions *) @@ -451,7 +472,7 @@ let check_recursive_lambda idlist lam = and check idlist = function | Lvar _ -> true - | Lfunction(kind, params, body) -> true + | Lfunction{kind; params; body} -> true | Llet (_, _, _, _) as lam when check_recursive_recordwith idlist lam -> true | Llet(str, id, arg, body) -> @@ -520,6 +541,11 @@ let rec name_pattern default = function | _ -> name_pattern default rem (* Push the default values under the functional abstractions *) +(* Also push bindings of module patterns, since this sound *) + +type binding = + | Bind_value of value_binding list + | Bind_module of Ident.t * string loc * module_expr let rec push_defaults loc bindings cases partial = match cases with @@ -532,13 +558,25 @@ let rec push_defaults loc bindings cases partial = 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 (Bind_value binds :: bindings) + [{c_lhs=pat;c_guard=None;c_rhs=e2}] + partial + | [{c_lhs=pat; c_guard=None; + c_rhs={exp_attributes=[{txt="#modulepat"},_]; + exp_desc = Texp_letmodule + (id, name, mexpr, ({exp_desc = Texp_function _} as e2))}}] -> + push_defaults loc (Bind_module (id, name, mexpr) :: bindings) + [{c_lhs=pat;c_guard=None;c_rhs=e2}] + partial | [case] -> let exp = List.fold_left (fun exp binds -> - {exp with exp_desc = Texp_let(Nonrecursive, binds, exp)}) + {exp with exp_desc = + match binds with + | Bind_value binds -> Texp_let(Nonrecursive, binds, exp) + | Bind_module (id, name, mexpr) -> + Texp_letmodule (id, name, mexpr, exp)}) case.c_rhs bindings in [{case with c_rhs=exp}] @@ -625,6 +663,9 @@ let rec cut n l = let try_ids = Hashtbl.create 8 +let has_tailcall_attribute e = + List.exists (fun ({txt},_) -> txt="tailcall") e.exp_attributes + let rec transl_exp e = let eval_once = (* Whether classes for immediate objects must be cached *) @@ -642,16 +683,16 @@ and transl_exp0 e = if public_send || p.prim_name = "%sendself" then let kind = if public_send then Public else Self in let obj = Ident.create "obj" and meth = Ident.create "meth" in - Lfunction(Curried, [obj; meth], Lsend(kind, Lvar meth, Lvar obj, [], - e.exp_loc)) + Lfunction{kind = Curried; params = [obj; meth]; + body = Lsend(kind, Lvar meth, Lvar obj, [], e.exp_loc)} else if p.prim_name = "%sendcache" then let obj = Ident.create "obj" and meth = Ident.create "meth" in let cache = Ident.create "cache" and pos = Ident.create "pos" in - Lfunction(Curried, [obj; meth; cache; pos], - Lsend(Cached, Lvar meth, Lvar obj, [Lvar cache; Lvar pos], - e.exp_loc)) + Lfunction{kind = Curried; params = [obj; meth; cache; pos]; + body = Lsend(Cached, Lvar meth, Lvar obj, + [Lvar cache; Lvar pos], e.exp_loc)} else - transl_primitive e.exp_loc p + transl_primitive e.exp_loc p e.exp_env e.exp_type | Texp_ident(path, _, {val_kind = Val_anc _}) -> raise(Error(e.exp_loc, Free_super_var)) | Texp_ident(path, _, {val_kind = Val_reg | Val_self _}) -> @@ -668,16 +709,18 @@ and transl_exp0 e = let pl = push_defaults e.exp_loc [] pat_expr_list partial in transl_function e.exp_loc !Clflags.native_code repr partial pl) in - Lfunction(kind, params, body) - | Texp_apply({exp_desc = Texp_ident(path, _, {val_kind = Val_prim p})}, - oargs) + Lfunction{kind; params; body} + | Texp_apply({ exp_desc = Texp_ident(path, _, {val_kind = Val_prim p}); + exp_type = prim_type } as funct, oargs) when List.length oargs >= p.prim_arity && List.for_all (fun (_, arg,_) -> arg <> None) oargs -> let args, args' = cut p.prim_arity oargs in let wrap f = if args' = [] then event_after e f - else event_after e (transl_apply f args' e.exp_loc) + else + let should_be_tailcall = has_tailcall_attribute funct in + event_after e (transl_apply ~should_be_tailcall f args' e.exp_loc) in let wrap0 f = if args' = [] then f else wrap f in @@ -695,7 +738,8 @@ and transl_exp0 e = wrap (Lsend(Cached, meth, obj, [cache; pos], e.exp_loc)) | _ -> assert false else begin - let prim = transl_prim e.exp_loc p args in + let prim = transl_primitive_application + e.exp_loc p e.exp_env prim_type args in match (prim, args) with (Praise k, [arg1]) -> let targ = List.hd argl in @@ -724,7 +768,8 @@ and transl_exp0 e = end end | Texp_apply(funct, oargs) -> - event_after e (transl_apply (transl_exp funct) oargs e.exp_loc) + let should_be_tailcall = has_tailcall_attribute funct in + event_after e (transl_apply ~should_be_tailcall (transl_exp funct) oargs e.exp_loc) | 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) -> @@ -842,7 +887,7 @@ and transl_exp0 e = event_after e lam | Texp_new (cl, {Location.loc=loc}, _) -> Lapply(Lprim(Pfield 0, [transl_path ~loc e.exp_env cl]), - [lambda_unit], Location.none) + [lambda_unit], no_apply_info) | Texp_instvar(path_self, path, _) -> Lprim(Parrayrefu Paddrarray, [transl_normal_path path_self; transl_normal_path path]) @@ -852,7 +897,7 @@ and transl_exp0 e = let cpy = Ident.create "copy" in Llet(Strict, cpy, Lapply(Translobj.oo_prim "copy", [transl_normal_path path_self], - Location.none), + no_apply_info), List.fold_right (fun (path, _, expr) rem -> Lsequence(transl_setinstvar (Lvar cpy) path expr, rem)) @@ -914,7 +959,8 @@ and transl_exp0 e = end (* other cases compile to a lazy block holding a function *) | _ -> - let fn = Lfunction (Curried, [Ident.create "param"], transl_exp e) in + let fn = Lfunction {kind = Curried; params = [Ident.create "param"]; + body = transl_exp e} in Lprim(Pmakeblock(Config.lazy_tag, Mutable), [fn]) end | Texp_object (cs, meths) -> @@ -962,17 +1008,17 @@ and transl_tupled_cases patl_expr_list = List.map (fun (patl, guard, expr) -> (patl, transl_guard guard expr)) patl_expr_list -and transl_apply lam sargs loc = +and transl_apply ?(should_be_tailcall=false) lam sargs loc = let lapply funct args = match funct with Lsend(k, lmet, lobj, largs, loc) -> Lsend(k, lmet, lobj, largs @ args, loc) | Levent(Lsend(k, lmet, lobj, largs, loc), _) -> Lsend(k, lmet, lobj, largs @ args, loc) - | Lapply(lexp, largs, _) -> - Lapply(lexp, largs @ args, loc) + | Lapply(lexp, largs, info) -> + Lapply(lexp, largs @ args, {info with apply_loc=loc}) | lexp -> - Lapply(lexp, args, loc) + Lapply(lexp, args, mk_apply_info ~tailcall:should_be_tailcall loc) in let rec build_apply lam args = function (None, optional) :: l -> @@ -995,12 +1041,12 @@ and transl_apply lam sargs loc = and id_arg = Ident.create "param" in let body = match build_apply handle ((Lvar id_arg, optional)::args') l with - Lfunction(Curried, ids, lam) -> - Lfunction(Curried, id_arg::ids, lam) - | Levent(Lfunction(Curried, ids, lam), _) -> - Lfunction(Curried, id_arg::ids, lam) + Lfunction{kind = Curried; params = ids; body = lam} -> + Lfunction{kind = Curried; params = id_arg::ids; body = lam} + | Levent(Lfunction{kind = Curried; params = ids; body = lam}, _) -> + Lfunction{kind = Curried; params = id_arg::ids; body = lam} | lam -> - Lfunction(Curried, [id_arg], lam) + Lfunction{kind = Curried; params = [id_arg]; body = lam} in List.fold_left (fun body (id, lam) -> Llet(Strict, id, lam, body)) diff --git a/bytecomp/translcore.mli b/bytecomp/translcore.mli index 70f700fcee..75ba9fcf02 100644 --- a/bytecomp/translcore.mli +++ b/bytecomp/translcore.mli @@ -18,10 +18,12 @@ open Typedtree open Lambda val transl_exp: expression -> lambda -val transl_apply: lambda -> (label * expression option * optional) list +val transl_apply: ?should_be_tailcall:bool + -> lambda -> (arg_label * expression option * optional) list -> Location.t -> lambda val transl_let: rec_flag -> value_binding list -> lambda -> lambda -val transl_primitive: Location.t -> Primitive.description -> lambda +val transl_primitive: Location.t -> Primitive.description -> Env.t + -> Types.type_expr -> lambda val check_recursive_lambda: Ident.t list -> lambda -> bool diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml index 89be6f5da1..4ff70b7be4 100644 --- a/bytecomp/translmod.ml +++ b/bytecomp/translmod.ml @@ -92,12 +92,14 @@ let rec apply_coercion strict restr arg = | Tcoerce_functor(cc_arg, cc_res) -> let param = Ident.create "funarg" in name_lambda strict arg (fun id -> - Lfunction(Curried, [param], - apply_coercion Strict cc_res - (Lapply(Lvar id, [apply_coercion Alias cc_arg (Lvar param)], - Location.none)))) - | Tcoerce_primitive p -> - transl_primitive Location.none p + Lfunction{kind = Curried; params = [param]; + body = apply_coercion + Strict cc_res + (Lapply(Lvar id, + [apply_coercion Alias cc_arg (Lvar param)], + no_apply_info))}) + | Tcoerce_primitive { pc_loc; pc_desc; pc_env; pc_type; } -> + transl_primitive pc_loc pc_desc pc_env pc_type | Tcoerce_alias (path, cc) -> name_lambda strict arg (fun id -> apply_coercion Alias cc (transl_normal_path path)) @@ -121,7 +123,7 @@ and wrap_id_pos_list id_pos_list get_field lam = (lam, Ident.empty) id_pos_list in if s == Ident.empty then lam else subst_lambda s lam - + (* Compose two coercions apply_coercion c1 (apply_coercion c2 e) behaves like @@ -279,7 +281,8 @@ let eval_rec_bindings bindings cont = | (id, None, rhs) :: rem -> bind_inits rem | (id, Some(loc, shape), rhs) :: rem -> - Llet(Strict, id, Lapply(mod_prim "init_mod", [loc; shape], Location.none), + Llet(Strict, id, + Lapply(mod_prim "init_mod", [loc; shape], no_apply_info), bind_inits rem) and bind_strict = function [] -> @@ -294,8 +297,7 @@ let eval_rec_bindings bindings cont = | (id, None, rhs) :: rem -> patch_forwards rem | (id, Some(loc, shape), rhs) :: rem -> - Lsequence(Lapply(mod_prim "update_mod", [shape; Lvar id; rhs], - Location.none), + Lsequence(Lapply(mod_prim "update_mod", [shape; Lvar id; rhs], no_apply_info), patch_forwards rem) in bind_inits bindings @@ -323,6 +325,17 @@ let rec bound_value_identifiers = function | Sig_class(id, decl, _) :: rem -> id :: bound_value_identifiers rem | _ :: rem -> bound_value_identifiers rem + +(* Code to translate class entries in a structure *) + +let transl_class_bindings cl_list = + let ids = List.map (fun (ci, _) -> ci.ci_id_class) cl_list in + (ids, + List.map + (fun ({ci_id_class=id; ci_expr=cl; ci_virt=vf}, meths) -> + (id, transl_class ids id meths cl vf)) + cl_list) + (* Compile a module expression *) let rec transl_module cc rootpath mexp = @@ -340,14 +353,14 @@ let rec transl_module cc rootpath mexp = oo_wrap mexp.mod_env true (function | Tcoerce_none -> - Lfunction(Curried, [param], - transl_module Tcoerce_none bodypath body) + Lfunction{kind = Curried; params = [param]; + body = transl_module Tcoerce_none bodypath body} | Tcoerce_functor(ccarg, ccres) -> let param' = Ident.create "funarg" in - Lfunction(Curried, [param'], - Llet(Alias, param, - apply_coercion Alias ccarg (Lvar param'), - transl_module ccres bodypath body)) + Lfunction{kind = Curried; params = [param']; + body = Llet(Alias, param, + apply_coercion Alias ccarg (Lvar param'), + transl_module ccres bodypath body)} | _ -> fatal_error "Translmod.transl_module") cc @@ -355,7 +368,7 @@ let rec transl_module cc rootpath mexp = oo_wrap mexp.mod_env true (apply_coercion Strict cc) (Lapply(transl_module Tcoerce_none None funct, - [transl_module ccarg None arg], mexp.mod_loc)) + [transl_module ccarg None arg], mk_apply_info mexp.mod_loc)) | Tmod_constraint(arg, mty, _, ccarg) -> transl_module (compose_coercions cc ccarg) rootpath arg | Tmod_unpack(arg, _) -> @@ -384,7 +397,9 @@ and transl_structure fields cc rootpath = function List.map (fun (pos, cc) -> match cc with - Tcoerce_primitive p -> transl_primitive Location.none p + Tcoerce_primitive p -> + transl_primitive p.pc_loc + p.pc_desc p.pc_env p.pc_type | _ -> apply_coercion Strict cc (get_field pos)) pos_cc_list)) and id_pos_list = @@ -405,7 +420,7 @@ and transl_structure fields cc rootpath = function | Tstr_primitive descr -> record_primitive descr.val_val; transl_structure fields cc rootpath rem - | Tstr_type(decls) -> + | Tstr_type(_, decls) -> transl_structure fields cc rootpath rem | Tstr_typext(tyext) -> let ids = List.map (fun ext -> ext.ext_id) tyext.tyext_constructors in @@ -431,13 +446,8 @@ and transl_structure fields cc rootpath = function bindings (transl_structure ext_fields cc rootpath rem) | Tstr_class cl_list -> - let ids = List.map (fun (ci,_,_) -> ci.ci_id_class) cl_list in - Lletrec(List.map - (fun (ci, meths, vf) -> - let id = ci.ci_id_class in - let cl = ci.ci_expr in - (id, transl_class ids id meths cl vf )) - cl_list, + let (ids, class_bindings) = transl_class_bindings cl_list in + Lletrec(class_bindings, transl_structure (List.rev_append ids fields) cc rootpath rem) | Tstr_include incl -> let ids = bound_value_identifiers incl.incl_type in @@ -490,7 +500,7 @@ let rec defined_idents = function | Tstr_value(rec_flag, pat_expr_list) -> let_bound_idents pat_expr_list @ defined_idents rem | Tstr_primitive desc -> defined_idents rem - | Tstr_type decls -> defined_idents rem + | Tstr_type (_, decls) -> defined_idents rem | Tstr_typext tyext -> List.map (fun ext -> ext.ext_id) tyext.tyext_constructors @ defined_idents rem @@ -501,7 +511,7 @@ let rec defined_idents = function | Tstr_modtype _ -> defined_idents rem | Tstr_open _ -> defined_idents rem | Tstr_class cl_list -> - List.map (fun (ci, _, _) -> ci.ci_id_class) cl_list @ defined_idents rem + List.map (fun (ci, _) -> ci.ci_id_class) cl_list @ defined_idents rem | Tstr_class_type cl_list -> defined_idents rem | Tstr_include incl -> bound_value_identifiers incl.incl_type @ defined_idents rem @@ -516,7 +526,7 @@ let rec more_idents = function | Tstr_eval (expr, _attrs) -> more_idents rem | Tstr_value(rec_flag, pat_expr_list) -> more_idents rem | Tstr_primitive _ -> more_idents rem - | Tstr_type decls -> more_idents rem + | Tstr_type (_, decls) -> more_idents rem | Tstr_typext tyext -> more_idents rem | Tstr_exception _ -> more_idents rem | Tstr_recmodule decls -> more_idents rem @@ -538,7 +548,7 @@ and all_idents = function | Tstr_value(rec_flag, pat_expr_list) -> let_bound_idents pat_expr_list @ all_idents rem | Tstr_primitive _ -> all_idents rem - | Tstr_type decls -> all_idents rem + | Tstr_type (_, decls) -> all_idents rem | Tstr_typext tyext -> List.map (fun ext -> ext.ext_id) tyext.tyext_constructors @ all_idents rem @@ -548,7 +558,7 @@ and all_idents = function | Tstr_modtype _ -> all_idents rem | Tstr_open _ -> all_idents rem | Tstr_class cl_list -> - List.map (fun (ci, _, _) -> ci.ci_id_class) cl_list @ all_idents rem + List.map (fun (ci, _) -> ci.ci_id_class) cl_list @ all_idents rem | Tstr_class_type cl_list -> all_idents rem | Tstr_include incl -> bound_value_identifiers incl.incl_type @ all_idents rem @@ -596,7 +606,7 @@ let transl_store_structure glob map prims str = | Tstr_primitive descr -> record_primitive descr.val_val; transl_store rootpath subst rem - | Tstr_type(decls) -> + | Tstr_type(_, decls) -> transl_store rootpath subst rem | Tstr_typext(tyext) -> let ids = List.map (fun ext -> ext.ext_id) tyext.tyext_constructors in @@ -646,15 +656,8 @@ let transl_store_structure glob map prims str = (Lsequence(store_idents ids, transl_store rootpath (add_idents true ids subst) rem)) | Tstr_class cl_list -> - let ids = List.map (fun (ci, _, _) -> ci.ci_id_class) cl_list in - let lam = - Lletrec(List.map - (fun (ci, meths, vf) -> - let id = ci.ci_id_class in - let cl = ci.ci_expr in - (id, transl_class ids id meths cl vf)) - cl_list, - store_idents ids) in + let (ids, class_bindings) = transl_class_bindings cl_list in + let lam = Lletrec(class_bindings, store_idents ids) in Lsequence(subst_lambda subst lam, transl_store rootpath (add_idents false ids subst) rem) | Tstr_include incl -> @@ -703,7 +706,8 @@ let transl_store_structure glob map prims str = and store_primitive (pos, prim) cont = Lsequence(Lprim(Psetfield(pos, false), [Lprim(Pgetglobal glob, []); - transl_primitive Location.none prim]), + transl_primitive Location.none + prim.pc_desc prim.pc_env prim.pc_type]), cont) in List.fold_right store_primitive prims @@ -796,13 +800,13 @@ let toploop_getvalue id = Lapply(Lprim(Pfield toploop_getvalue_pos, [Lprim(Pgetglobal toploop_ident, [])]), [Lconst(Const_base(Const_string (toplevel_name id, None)))], - Location.none) + no_apply_info) let toploop_setvalue id lam = Lapply(Lprim(Pfield toploop_setvalue_pos, [Lprim(Pgetglobal toploop_ident, [])]), [Lconst(Const_base(Const_string (toplevel_name id, None))); lam], - Location.none) + no_apply_info) let toploop_setvalue_id id = toploop_setvalue id (Lvar id) @@ -846,17 +850,9 @@ let transl_toplevel_item item = | Tstr_class cl_list -> (* we need to use unique names for the classes because there might be a value named identically *) - let ids = List.map (fun (ci, _, _) -> ci.ci_id_class) cl_list in + let (ids, class_bindings) = transl_class_bindings cl_list in List.iter set_toplevel_unique_name ids; - Lletrec(List.map - (fun (ci, meths, vf) -> - let id = ci.ci_id_class in - let cl = ci.ci_expr in - (id, transl_class ids id meths cl vf)) - cl_list, - make_sequence - (fun (ci, _, _) -> toploop_setvalue_id ci.ci_id_class) - cl_list) + Lletrec(class_bindings, make_sequence toploop_setvalue_id ids) | Tstr_include incl -> let ids = bound_value_identifiers incl.incl_type in let modl = incl.incl_mod in diff --git a/bytecomp/typeopt.ml b/bytecomp/typeopt.ml index eb8c9435e7..5a2b593d14 100644 --- a/bytecomp/typeopt.ml +++ b/bytecomp/typeopt.ml @@ -20,18 +20,26 @@ open Lambda let scrape env ty = (Ctype.repr (Ctype.expand_head_opt env (Ctype.correct_levels ty))).desc -let has_base_type exp base_ty_path = - match scrape exp.exp_env exp.exp_type with +let is_function_type env ty = + match scrape env ty with + | Tarrow (_, lhs, rhs, _) -> Some (lhs, rhs) + | _ -> None + +let is_base_type env ty base_ty_path = + match scrape env ty with | Tconstr(p, _, _) -> Path.same p base_ty_path | _ -> false -let maybe_pointer exp = - match scrape exp.exp_env exp.exp_type with +let has_base_type exp base_ty_path = + is_base_type exp.exp_env exp.exp_type base_ty_path + +let maybe_pointer_type env typ = + match scrape env typ with | Tconstr(p, args, abbrev) -> not (Path.same p Predef.path_int) && not (Path.same p Predef.path_char) && begin try - match Env.find_type p exp.exp_env with + match Env.find_type p env with | {type_kind = Type_variant []} -> true (* type exn *) | {type_kind = Type_variant cstrs} -> List.exists (fun c -> c.Types.cd_args <> Cstr_tuple []) cstrs @@ -43,6 +51,8 @@ let maybe_pointer exp = end | _ -> true +let maybe_pointer exp = maybe_pointer_type exp.exp_env exp.exp_type + let array_element_kind env ty = match scrape env ty with | Tvar _ | Tunivar _ -> @@ -78,7 +88,7 @@ let array_element_kind env ty = | _ -> Paddrarray -let array_kind_gen ty env = +let array_type_kind env ty = match scrape env ty with | Tconstr(p, [elt_ty], _) | Tpoly({desc = Tconstr(p, [elt_ty], _)}, _) when Path.same p Predef.path_array -> @@ -87,9 +97,9 @@ let array_kind_gen ty env = (* This can happen with e.g. Obj.field *) Pgenarray -let array_kind exp = array_kind_gen exp.exp_type exp.exp_env +let array_kind exp = array_type_kind exp.exp_env exp.exp_type -let array_pattern_kind pat = array_kind_gen pat.pat_type pat.pat_env +let array_pattern_kind pat = array_type_kind pat.pat_env pat.pat_type let bigarray_decode_type env ty tbl dfl = match scrape env ty with @@ -117,11 +127,11 @@ let layout_table = ["c_layout", Pbigarray_c_layout; "fortran_layout", Pbigarray_fortran_layout] -let bigarray_kind_and_layout exp = - match scrape exp.exp_env exp.exp_type with +let bigarray_type_kind_and_layout env typ = + match scrape env typ with | Tconstr(p, [caml_type; elt_type; layout_type], abbrev) -> - (bigarray_decode_type exp.exp_env elt_type kind_table Pbigarray_unknown, - bigarray_decode_type exp.exp_env layout_type layout_table + (bigarray_decode_type env elt_type kind_table Pbigarray_unknown, + bigarray_decode_type env layout_type layout_table Pbigarray_unknown_layout) | _ -> (Pbigarray_unknown, Pbigarray_unknown_layout) diff --git a/bytecomp/typeopt.mli b/bytecomp/typeopt.mli index a90df8aee6..2f52d92cc6 100644 --- a/bytecomp/typeopt.mli +++ b/bytecomp/typeopt.mli @@ -12,9 +12,16 @@ (* Auxiliaries for type-based optimizations, e.g. array kinds *) +val is_function_type : + Env.t -> Types.type_expr -> (Types.type_expr * Types.type_expr) option +val is_base_type : Env.t -> Types.type_expr -> Path.t -> bool val has_base_type : Typedtree.expression -> Path.t -> bool + +val maybe_pointer_type : Env.t -> Types.type_expr -> bool val maybe_pointer : Typedtree.expression -> bool + +val array_type_kind : Env.t -> Types.type_expr -> Lambda.array_kind val array_kind : Typedtree.expression -> Lambda.array_kind val array_pattern_kind : Typedtree.pattern -> Lambda.array_kind -val bigarray_kind_and_layout : - Typedtree.expression -> Lambda.bigarray_kind * Lambda.bigarray_layout +val bigarray_type_kind_and_layout : + Env.t -> Types.type_expr -> Lambda.bigarray_kind * Lambda.bigarray_layout diff --git a/byterun/.depend b/byterun/.depend index 743737d052..b1517cb4db 100644 --- a/byterun/.depend +++ b/byterun/.depend @@ -1,422 +1,751 @@ -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 -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 -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 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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 +alloc.o: alloc.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/custom.h caml/major_gc.h caml/freelist.h \ + caml/memory.h caml/gc.h caml/major_gc.h caml/minor_gc.h \ + caml/address_class.h caml/mlvalues.h caml/stacks.h caml/memory.h +array.o: array.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/fail.h caml/memory.h caml/gc.h caml/major_gc.h \ + caml/freelist.h caml/minor_gc.h caml/address_class.h caml/misc.h \ + caml/mlvalues.h +backtrace.o: backtrace.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/compatibility.h caml/mlvalues.h \ + caml/config.h caml/misc.h caml/alloc.h caml/mlvalues.h caml/custom.h \ + caml/io.h caml/instruct.h caml/intext.h caml/io.h caml/exec.h \ + caml/fix_code.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/startup.h caml/exec.h \ + caml/stacks.h caml/memory.h caml/sys.h caml/backtrace.h caml/fail.h +callback.o: callback.c caml/callback.h caml/compatibility.h \ + caml/mlvalues.h caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/misc.h caml/fail.h caml/memory.h caml/gc.h \ + caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ + caml/mlvalues.h caml/interp.h caml/instruct.h caml/fix_code.h \ + caml/stacks.h caml/memory.h +compact.o: compact.c caml/address_class.h caml/misc.h \ + caml/compatibility.h caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/mlvalues.h caml/config.h caml/finalise.h \ + caml/roots.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/freelist.h caml/gc.h \ + caml/gc_ctrl.h caml/major_gc.h caml/memory.h caml/mlvalues.h \ + caml/roots.h caml/weak.h +compare.o: compare.c caml/custom.h caml/compatibility.h caml/mlvalues.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h caml/misc.h \ + caml/fail.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/misc.h caml/mlvalues.h +custom.o: custom.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/custom.h caml/fail.h caml/memory.h caml/gc.h \ + caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ + caml/mlvalues.h +debugger.o: debugger.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/config.h caml/debugger.h caml/misc.h caml/fail.h \ + caml/fix_code.h caml/instruct.h caml/intext.h caml/io.h caml/io.h \ + caml/mlvalues.h caml/stacks.h caml/memory.h caml/gc.h caml/major_gc.h \ + caml/freelist.h caml/minor_gc.h caml/address_class.h caml/sys.h +dynlink.o: dynlink.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/compatibility.h caml/alloc.h caml/misc.h \ + caml/config.h caml/mlvalues.h caml/dynlink.h caml/fail.h \ + caml/mlvalues.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/misc.h caml/osdeps.h \ + caml/prims.h caml/signals.h +extern.o: extern.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/custom.h caml/fail.h caml/gc.h caml/intext.h \ + caml/io.h caml/io.h caml/md5.h caml/memory.h caml/gc.h caml/major_gc.h \ + caml/freelist.h caml/minor_gc.h caml/address_class.h caml/misc.h \ + caml/mlvalues.h caml/reverse.h +fail.o: fail.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/fail.h caml/io.h caml/gc.h caml/memory.h caml/gc.h \ + caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ + caml/misc.h caml/mlvalues.h caml/printexc.h caml/signals.h \ + caml/stacks.h caml/memory.h +finalise.o: finalise.c caml/callback.h caml/compatibility.h \ + caml/mlvalues.h caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/misc.h caml/fail.h caml/mlvalues.h \ + caml/roots.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/signals.h +fix_code.o: fix_code.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/compatibility.h caml/debugger.h caml/misc.h \ + caml/config.h caml/mlvalues.h caml/fix_code.h caml/instruct.h \ + caml/intext.h caml/io.h caml/md5.h caml/memory.h caml/gc.h \ + caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ + caml/misc.h caml/mlvalues.h caml/reverse.h +floats.o: floats.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/fail.h caml/memory.h caml/gc.h caml/major_gc.h \ + caml/freelist.h caml/minor_gc.h caml/address_class.h caml/mlvalues.h \ + caml/misc.h caml/reverse.h caml/stacks.h caml/memory.h +freelist.o: freelist.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/compatibility.h caml/freelist.h caml/misc.h \ + caml/config.h caml/mlvalues.h caml/gc.h caml/gc_ctrl.h caml/memory.h \ + caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/major_gc.h caml/misc.h caml/mlvalues.h +gc_ctrl.o: gc_ctrl.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/compact.h caml/custom.h caml/finalise.h \ + caml/roots.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/freelist.h caml/gc.h \ + caml/gc_ctrl.h caml/major_gc.h caml/minor_gc.h caml/misc.h \ + caml/mlvalues.h caml/stacks.h +globroots.o: globroots.c caml/memory.h caml/compatibility.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/gc.h caml/mlvalues.h \ + caml/misc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/misc.h caml/mlvalues.h caml/roots.h \ + caml/memory.h caml/globroots.h caml/roots.h +hash.o: hash.c caml/mlvalues.h caml/compatibility.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/misc.h caml/custom.h \ + caml/mlvalues.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/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 -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 -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 -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 -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 -main.o: main.c misc.h compatibility.h config.h ../config/m.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 -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 -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 -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 -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 -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 -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 -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 -prims.o: prims.c mlvalues.h compatibility.h config.h ../config/m.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 -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 -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 -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 -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 -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 -str.o: str.c alloc.h compatibility.h misc.h config.h ../config/m.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 -terminfo.o: terminfo.c config.h ../config/m.h ../config/s.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 -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 -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 -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 -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 -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 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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -main.d.o: main.c misc.h compatibility.h config.h ../config/m.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 -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 -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 -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 -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 -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 -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 -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 -prims.d.o: prims.c mlvalues.h compatibility.h config.h ../config/m.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 -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 -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 -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 -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 -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 -str.d.o: str.c alloc.h compatibility.h misc.h config.h ../config/m.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 -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 -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 -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 -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 -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 -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 -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 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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 +intern.o: intern.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/callback.h caml/custom.h caml/fail.h caml/gc.h \ + caml/intext.h caml/io.h caml/io.h caml/md5.h caml/memory.h caml/gc.h \ + caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ + caml/mlvalues.h caml/misc.h caml/reverse.h +interp.o: interp.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/backtrace.h caml/exec.h caml/callback.h \ + caml/debugger.h caml/fail.h caml/fix_code.h caml/instrtrace.h \ + caml/instruct.h caml/interp.h caml/major_gc.h caml/freelist.h \ + caml/memory.h caml/gc.h caml/major_gc.h caml/minor_gc.h \ + caml/address_class.h caml/misc.h caml/mlvalues.h caml/prims.h \ + caml/signals.h caml/stacks.h caml/memory.h caml/startup_aux.h \ + caml/jumptbl.h +ints.o: ints.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/custom.h caml/fail.h caml/intext.h caml/io.h \ + caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/misc.h caml/mlvalues.h +io.o: io.c caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/compatibility.h caml/alloc.h caml/misc.h caml/config.h \ + caml/mlvalues.h caml/custom.h caml/fail.h caml/io.h caml/memory.h \ + caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/misc.h caml/mlvalues.h caml/signals.h \ + caml/sys.h +lexing.o: lexing.c caml/fail.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/mlvalues.h caml/stacks.h caml/memory.h caml/gc.h \ + caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h +main.o: main.c caml/misc.h caml/compatibility.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h caml/misc.h \ + caml/sys.h +major_gc.o: major_gc.c caml/compact.h caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/compatibility.h caml/misc.h caml/custom.h \ + caml/mlvalues.h caml/config.h caml/fail.h caml/finalise.h caml/roots.h \ + caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/freelist.h caml/gc.h caml/gc_ctrl.h \ + caml/major_gc.h caml/misc.h caml/mlvalues.h caml/roots.h caml/weak.h +md5.o: md5.c caml/alloc.h caml/compatibility.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h caml/fail.h \ + caml/md5.h caml/io.h caml/memory.h caml/gc.h caml/major_gc.h \ + caml/freelist.h caml/minor_gc.h caml/address_class.h caml/mlvalues.h \ + caml/io.h caml/reverse.h +memory.o: memory.c caml/address_class.h caml/misc.h caml/compatibility.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/fail.h caml/freelist.h caml/gc.h caml/gc_ctrl.h \ + caml/major_gc.h caml/freelist.h caml/memory.h caml/gc.h caml/major_gc.h \ + caml/minor_gc.h caml/address_class.h caml/minor_gc.h caml/misc.h \ + caml/mlvalues.h caml/signals.h +meta.o: meta.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/config.h caml/fail.h caml/fix_code.h caml/interp.h \ + caml/intext.h caml/io.h caml/major_gc.h caml/freelist.h caml/memory.h \ + caml/gc.h caml/major_gc.h caml/minor_gc.h caml/address_class.h \ + caml/minor_gc.h caml/misc.h caml/mlvalues.h caml/prims.h caml/stacks.h \ + caml/memory.h +minor_gc.o: minor_gc.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/compatibility.h caml/fail.h caml/misc.h \ + caml/config.h caml/mlvalues.h caml/finalise.h caml/roots.h \ + caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/gc.h caml/gc_ctrl.h caml/major_gc.h \ + caml/memory.h caml/minor_gc.h caml/misc.h caml/mlvalues.h caml/roots.h \ + caml/signals.h caml/weak.h +misc.o: misc.c caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/compatibility.h caml/misc.h caml/config.h caml/memory.h caml/gc.h \ + caml/mlvalues.h caml/misc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h +obj.o: obj.c caml/alloc.h caml/compatibility.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h caml/fail.h \ + caml/gc.h caml/interp.h caml/major_gc.h caml/freelist.h caml/memory.h \ + caml/gc.h caml/major_gc.h caml/minor_gc.h caml/address_class.h \ + caml/minor_gc.h caml/misc.h caml/mlvalues.h caml/prims.h +parsing.o: parsing.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/compatibility.h caml/mlvalues.h \ + caml/config.h caml/misc.h caml/memory.h caml/gc.h caml/mlvalues.h \ + caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ + caml/alloc.h +prims.o: prims.c caml/mlvalues.h caml/compatibility.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/misc.h caml/prims.h +printexc.o: printexc.c caml/backtrace.h caml/mlvalues.h \ + caml/compatibility.h caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/misc.h caml/exec.h caml/callback.h \ + caml/debugger.h caml/fail.h caml/misc.h caml/mlvalues.h caml/printexc.h +roots.o: roots.c caml/finalise.h caml/roots.h caml/misc.h \ + caml/compatibility.h caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/memory.h caml/gc.h caml/mlvalues.h \ + caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ + caml/globroots.h caml/major_gc.h caml/memory.h caml/minor_gc.h \ + caml/misc.h caml/mlvalues.h caml/roots.h caml/stacks.h +signals.o: signals.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/callback.h caml/config.h caml/fail.h caml/memory.h \ + caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/misc.h caml/mlvalues.h caml/roots.h \ + caml/memory.h caml/signals.h caml/signals_machdep.h caml/sys.h +signals_byt.o: signals_byt.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/compatibility.h caml/memory.h caml/config.h \ + caml/gc.h caml/mlvalues.h caml/misc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/osdeps.h caml/signals.h \ + caml/signals_machdep.h +stacks.o: stacks.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/compatibility.h caml/fail.h caml/misc.h \ + caml/config.h caml/mlvalues.h caml/misc.h caml/mlvalues.h caml/stacks.h \ + caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h +startup.o: startup.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/compatibility.h caml/alloc.h caml/misc.h \ + caml/config.h caml/mlvalues.h caml/backtrace.h caml/exec.h \ + caml/callback.h caml/custom.h caml/debugger.h caml/dynlink.h \ + caml/exec.h caml/fail.h caml/fix_code.h caml/freelist.h caml/gc_ctrl.h \ + caml/instrtrace.h caml/interp.h caml/intext.h caml/io.h caml/io.h \ + caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/minor_gc.h caml/misc.h caml/mlvalues.h \ + caml/osdeps.h caml/prims.h caml/printexc.h caml/reverse.h \ + caml/signals.h caml/stacks.h caml/memory.h caml/sys.h caml/startup.h \ + caml/startup_aux.h caml/version.h +startup_aux.o: startup_aux.c caml/backtrace.h caml/mlvalues.h \ + caml/compatibility.h caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/misc.h caml/exec.h caml/memory.h caml/gc.h \ + caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ + caml/startup_aux.h +str.o: str.c caml/alloc.h caml/compatibility.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h caml/fail.h \ + caml/mlvalues.h caml/misc.h +sys.o: sys.c caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/compatibility.h caml/alloc.h caml/misc.h caml/config.h \ + caml/mlvalues.h caml/debugger.h caml/fail.h caml/instruct.h \ + caml/mlvalues.h caml/osdeps.h caml/signals.h caml/stacks.h \ + caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/sys.h caml/gc_ctrl.h +terminfo.o: terminfo.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/compatibility.h caml/alloc.h caml/misc.h \ + caml/config.h caml/mlvalues.h caml/fail.h caml/io.h caml/mlvalues.h +unix.o: unix.c caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/compatibility.h caml/memory.h caml/config.h caml/gc.h \ + caml/mlvalues.h caml/misc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/misc.h caml/osdeps.h +weak.o: weak.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/fail.h caml/major_gc.h caml/freelist.h \ + caml/memory.h caml/gc.h caml/major_gc.h caml/minor_gc.h \ + caml/address_class.h caml/mlvalues.h +win32.o: win32.c caml/address_class.h caml/misc.h caml/compatibility.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/fail.h caml/memory.h caml/gc.h caml/major_gc.h \ + caml/freelist.h caml/minor_gc.h caml/address_class.h caml/misc.h \ + caml/osdeps.h caml/signals.h caml/sys.h +alloc.d.o: alloc.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/custom.h caml/major_gc.h caml/freelist.h \ + caml/memory.h caml/gc.h caml/major_gc.h caml/minor_gc.h \ + caml/address_class.h caml/mlvalues.h caml/stacks.h caml/memory.h +array.d.o: array.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/fail.h caml/memory.h caml/gc.h caml/major_gc.h \ + caml/freelist.h caml/minor_gc.h caml/address_class.h caml/misc.h \ + caml/mlvalues.h +backtrace.d.o: backtrace.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/compatibility.h caml/mlvalues.h \ + caml/config.h caml/misc.h caml/alloc.h caml/mlvalues.h caml/custom.h \ + caml/io.h caml/instruct.h caml/intext.h caml/io.h caml/exec.h \ + caml/fix_code.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/startup.h caml/exec.h \ + caml/stacks.h caml/memory.h caml/sys.h caml/backtrace.h caml/fail.h +callback.d.o: callback.c caml/callback.h caml/compatibility.h \ + caml/mlvalues.h caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/misc.h caml/fail.h caml/memory.h caml/gc.h \ + caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ + caml/mlvalues.h caml/interp.h caml/instruct.h caml/fix_code.h \ + caml/stacks.h caml/memory.h +compact.d.o: compact.c caml/address_class.h caml/misc.h \ + caml/compatibility.h caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/mlvalues.h caml/config.h caml/finalise.h \ + caml/roots.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/freelist.h caml/gc.h \ + caml/gc_ctrl.h caml/major_gc.h caml/memory.h caml/mlvalues.h \ + caml/roots.h caml/weak.h +compare.d.o: compare.c caml/custom.h caml/compatibility.h caml/mlvalues.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h caml/misc.h \ + caml/fail.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/misc.h caml/mlvalues.h +custom.d.o: custom.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/custom.h caml/fail.h caml/memory.h caml/gc.h \ + caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ + caml/mlvalues.h +debugger.d.o: debugger.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/config.h caml/debugger.h caml/misc.h caml/fail.h \ + caml/fix_code.h caml/instruct.h caml/intext.h caml/io.h caml/io.h \ + caml/mlvalues.h caml/stacks.h caml/memory.h caml/gc.h caml/major_gc.h \ + caml/freelist.h caml/minor_gc.h caml/address_class.h caml/sys.h +dynlink.d.o: dynlink.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/compatibility.h caml/alloc.h caml/misc.h \ + caml/config.h caml/mlvalues.h caml/dynlink.h caml/fail.h \ + caml/mlvalues.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/misc.h caml/osdeps.h \ + caml/prims.h caml/signals.h +extern.d.o: extern.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/custom.h caml/fail.h caml/gc.h caml/intext.h \ + caml/io.h caml/io.h caml/md5.h caml/memory.h caml/gc.h caml/major_gc.h \ + caml/freelist.h caml/minor_gc.h caml/address_class.h caml/misc.h \ + caml/mlvalues.h caml/reverse.h +fail.d.o: fail.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/fail.h caml/io.h caml/gc.h caml/memory.h caml/gc.h \ + caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ + caml/misc.h caml/mlvalues.h caml/printexc.h caml/signals.h \ + caml/stacks.h caml/memory.h +finalise.d.o: finalise.c caml/callback.h caml/compatibility.h \ + caml/mlvalues.h caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/misc.h caml/fail.h caml/mlvalues.h \ + caml/roots.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/signals.h +fix_code.d.o: fix_code.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/compatibility.h caml/debugger.h caml/misc.h \ + caml/config.h caml/mlvalues.h caml/fix_code.h caml/instruct.h \ + caml/intext.h caml/io.h caml/md5.h caml/memory.h caml/gc.h \ + caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ + caml/misc.h caml/mlvalues.h caml/reverse.h +floats.d.o: floats.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/fail.h caml/memory.h caml/gc.h caml/major_gc.h \ + caml/freelist.h caml/minor_gc.h caml/address_class.h caml/mlvalues.h \ + caml/misc.h caml/reverse.h caml/stacks.h caml/memory.h +freelist.d.o: freelist.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/compatibility.h caml/freelist.h caml/misc.h \ + caml/config.h caml/mlvalues.h caml/gc.h caml/gc_ctrl.h caml/memory.h \ + caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/major_gc.h caml/misc.h caml/mlvalues.h +gc_ctrl.d.o: gc_ctrl.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/compact.h caml/custom.h caml/finalise.h \ + caml/roots.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/freelist.h caml/gc.h \ + caml/gc_ctrl.h caml/major_gc.h caml/minor_gc.h caml/misc.h \ + caml/mlvalues.h caml/stacks.h +globroots.d.o: globroots.c caml/memory.h caml/compatibility.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/gc.h caml/mlvalues.h \ + caml/misc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/misc.h caml/mlvalues.h caml/roots.h \ + caml/memory.h caml/globroots.h caml/roots.h +hash.d.o: hash.c caml/mlvalues.h caml/compatibility.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/misc.h caml/custom.h \ + caml/mlvalues.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/hash.h +instrtrace.d.o: instrtrace.c caml/instruct.h caml/misc.h \ + caml/compatibility.h caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/mlvalues.h caml/misc.h caml/opnames.h \ + caml/prims.h caml/stacks.h caml/mlvalues.h caml/memory.h caml/gc.h \ + caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ + caml/startup_aux.h +intern.d.o: intern.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/callback.h caml/custom.h caml/fail.h caml/gc.h \ + caml/intext.h caml/io.h caml/io.h caml/md5.h caml/memory.h caml/gc.h \ + caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ + caml/mlvalues.h caml/misc.h caml/reverse.h +interp.d.o: interp.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/backtrace.h caml/exec.h caml/callback.h \ + caml/debugger.h caml/fail.h caml/fix_code.h caml/instrtrace.h \ + caml/instruct.h caml/interp.h caml/major_gc.h caml/freelist.h \ + caml/memory.h caml/gc.h caml/major_gc.h caml/minor_gc.h \ + caml/address_class.h caml/misc.h caml/mlvalues.h caml/prims.h \ + caml/signals.h caml/stacks.h caml/memory.h caml/startup_aux.h +ints.d.o: ints.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/custom.h caml/fail.h caml/intext.h caml/io.h \ + caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/misc.h caml/mlvalues.h +io.d.o: io.c caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/compatibility.h caml/alloc.h caml/misc.h caml/config.h \ + caml/mlvalues.h caml/custom.h caml/fail.h caml/io.h caml/memory.h \ + caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/misc.h caml/mlvalues.h caml/signals.h \ + caml/sys.h +lexing.d.o: lexing.c caml/fail.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/mlvalues.h caml/stacks.h caml/memory.h caml/gc.h \ + caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h +main.d.o: main.c caml/misc.h caml/compatibility.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h caml/misc.h \ + caml/sys.h +major_gc.d.o: major_gc.c caml/compact.h caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/compatibility.h caml/misc.h caml/custom.h \ + caml/mlvalues.h caml/config.h caml/fail.h caml/finalise.h caml/roots.h \ + caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/freelist.h caml/gc.h caml/gc_ctrl.h \ + caml/major_gc.h caml/misc.h caml/mlvalues.h caml/roots.h caml/weak.h +md5.d.o: md5.c caml/alloc.h caml/compatibility.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h caml/fail.h \ + caml/md5.h caml/io.h caml/memory.h caml/gc.h caml/major_gc.h \ + caml/freelist.h caml/minor_gc.h caml/address_class.h caml/mlvalues.h \ + caml/io.h caml/reverse.h +memory.d.o: memory.c caml/address_class.h caml/misc.h caml/compatibility.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/fail.h caml/freelist.h caml/gc.h caml/gc_ctrl.h \ + caml/major_gc.h caml/freelist.h caml/memory.h caml/gc.h caml/major_gc.h \ + caml/minor_gc.h caml/address_class.h caml/minor_gc.h caml/misc.h \ + caml/mlvalues.h caml/signals.h +meta.d.o: meta.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/config.h caml/fail.h caml/fix_code.h caml/interp.h \ + caml/intext.h caml/io.h caml/major_gc.h caml/freelist.h caml/memory.h \ + caml/gc.h caml/major_gc.h caml/minor_gc.h caml/address_class.h \ + caml/minor_gc.h caml/misc.h caml/mlvalues.h caml/prims.h caml/stacks.h \ + caml/memory.h +minor_gc.d.o: minor_gc.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/compatibility.h caml/fail.h caml/misc.h \ + caml/config.h caml/mlvalues.h caml/finalise.h caml/roots.h \ + caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/gc.h caml/gc_ctrl.h caml/major_gc.h \ + caml/memory.h caml/minor_gc.h caml/misc.h caml/mlvalues.h caml/roots.h \ + caml/signals.h caml/weak.h +misc.d.o: misc.c caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/compatibility.h caml/misc.h caml/config.h caml/memory.h caml/gc.h \ + caml/mlvalues.h caml/misc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h +obj.d.o: obj.c caml/alloc.h caml/compatibility.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h caml/fail.h \ + caml/gc.h caml/interp.h caml/major_gc.h caml/freelist.h caml/memory.h \ + caml/gc.h caml/major_gc.h caml/minor_gc.h caml/address_class.h \ + caml/minor_gc.h caml/misc.h caml/mlvalues.h caml/prims.h +parsing.d.o: parsing.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/compatibility.h caml/mlvalues.h \ + caml/config.h caml/misc.h caml/memory.h caml/gc.h caml/mlvalues.h \ + caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ + caml/alloc.h +prims.d.o: prims.c caml/mlvalues.h caml/compatibility.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/misc.h caml/prims.h +printexc.d.o: printexc.c caml/backtrace.h caml/mlvalues.h \ + caml/compatibility.h caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/misc.h caml/exec.h caml/callback.h \ + caml/debugger.h caml/fail.h caml/misc.h caml/mlvalues.h caml/printexc.h +roots.d.o: roots.c caml/finalise.h caml/roots.h caml/misc.h \ + caml/compatibility.h caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/memory.h caml/gc.h caml/mlvalues.h \ + caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ + caml/globroots.h caml/major_gc.h caml/memory.h caml/minor_gc.h \ + caml/misc.h caml/mlvalues.h caml/roots.h caml/stacks.h +signals.d.o: signals.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/callback.h caml/config.h caml/fail.h caml/memory.h \ + caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/misc.h caml/mlvalues.h caml/roots.h \ + caml/memory.h caml/signals.h caml/signals_machdep.h caml/sys.h +signals_byt.d.o: signals_byt.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/compatibility.h caml/memory.h caml/config.h \ + caml/gc.h caml/mlvalues.h caml/misc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/osdeps.h caml/signals.h \ + caml/signals_machdep.h +stacks.d.o: stacks.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/compatibility.h caml/fail.h caml/misc.h \ + caml/config.h caml/mlvalues.h caml/misc.h caml/mlvalues.h caml/stacks.h \ + caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h +startup.d.o: startup.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/compatibility.h caml/alloc.h caml/misc.h \ + caml/config.h caml/mlvalues.h caml/backtrace.h caml/exec.h \ + caml/callback.h caml/custom.h caml/debugger.h caml/dynlink.h \ + caml/exec.h caml/fail.h caml/fix_code.h caml/freelist.h caml/gc_ctrl.h \ + caml/instrtrace.h caml/interp.h caml/intext.h caml/io.h caml/io.h \ + caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/minor_gc.h caml/misc.h caml/mlvalues.h \ + caml/osdeps.h caml/prims.h caml/printexc.h caml/reverse.h \ + caml/signals.h caml/stacks.h caml/memory.h caml/sys.h caml/startup.h \ + caml/startup_aux.h caml/version.h +startup_aux.d.o: startup_aux.c caml/backtrace.h caml/mlvalues.h \ + caml/compatibility.h caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/misc.h caml/exec.h caml/memory.h caml/gc.h \ + caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ + caml/startup_aux.h +str.d.o: str.c caml/alloc.h caml/compatibility.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h caml/fail.h \ + caml/mlvalues.h caml/misc.h +sys.d.o: sys.c caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/compatibility.h caml/alloc.h caml/misc.h caml/config.h \ + caml/mlvalues.h caml/debugger.h caml/fail.h caml/instruct.h \ + caml/mlvalues.h caml/osdeps.h caml/signals.h caml/stacks.h \ + caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/sys.h caml/gc_ctrl.h +terminfo.d.o: terminfo.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/compatibility.h caml/alloc.h caml/misc.h \ + caml/config.h caml/mlvalues.h caml/fail.h caml/io.h caml/mlvalues.h +unix.d.o: unix.c caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/compatibility.h caml/memory.h caml/config.h caml/gc.h \ + caml/mlvalues.h caml/misc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/misc.h caml/osdeps.h +weak.d.o: weak.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/fail.h caml/major_gc.h caml/freelist.h \ + caml/memory.h caml/gc.h caml/major_gc.h caml/minor_gc.h \ + caml/address_class.h caml/mlvalues.h +win32.d.o: win32.c caml/address_class.h caml/misc.h caml/compatibility.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/fail.h caml/memory.h caml/gc.h caml/major_gc.h \ + caml/freelist.h caml/minor_gc.h caml/address_class.h caml/misc.h \ + caml/osdeps.h caml/signals.h caml/sys.h +alloc.pic.o: alloc.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/custom.h caml/major_gc.h caml/freelist.h \ + caml/memory.h caml/gc.h caml/major_gc.h caml/minor_gc.h \ + caml/address_class.h caml/mlvalues.h caml/stacks.h caml/memory.h +array.pic.o: array.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/fail.h caml/memory.h caml/gc.h caml/major_gc.h \ + caml/freelist.h caml/minor_gc.h caml/address_class.h caml/misc.h \ + caml/mlvalues.h +backtrace.pic.o: backtrace.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/compatibility.h caml/mlvalues.h \ + caml/config.h caml/misc.h caml/alloc.h caml/mlvalues.h caml/custom.h \ + caml/io.h caml/instruct.h caml/intext.h caml/io.h caml/exec.h \ + caml/fix_code.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/startup.h caml/exec.h \ + caml/stacks.h caml/memory.h caml/sys.h caml/backtrace.h caml/fail.h +callback.pic.o: callback.c caml/callback.h caml/compatibility.h \ + caml/mlvalues.h caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/misc.h caml/fail.h caml/memory.h caml/gc.h \ + caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ + caml/mlvalues.h caml/interp.h caml/instruct.h caml/fix_code.h \ + caml/stacks.h caml/memory.h +compact.pic.o: compact.c caml/address_class.h caml/misc.h \ + caml/compatibility.h caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/mlvalues.h caml/config.h caml/finalise.h \ + caml/roots.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/freelist.h caml/gc.h \ + caml/gc_ctrl.h caml/major_gc.h caml/memory.h caml/mlvalues.h \ + caml/roots.h caml/weak.h +compare.pic.o: compare.c caml/custom.h caml/compatibility.h caml/mlvalues.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h caml/misc.h \ + caml/fail.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/misc.h caml/mlvalues.h +custom.pic.o: custom.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/custom.h caml/fail.h caml/memory.h caml/gc.h \ + caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ + caml/mlvalues.h +debugger.pic.o: debugger.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/config.h caml/debugger.h caml/misc.h caml/fail.h \ + caml/fix_code.h caml/instruct.h caml/intext.h caml/io.h caml/io.h \ + caml/mlvalues.h caml/stacks.h caml/memory.h caml/gc.h caml/major_gc.h \ + caml/freelist.h caml/minor_gc.h caml/address_class.h caml/sys.h +dynlink.pic.o: dynlink.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/compatibility.h caml/alloc.h caml/misc.h \ + caml/config.h caml/mlvalues.h caml/dynlink.h caml/fail.h \ + caml/mlvalues.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/misc.h caml/osdeps.h \ + caml/prims.h caml/signals.h +extern.pic.o: extern.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/custom.h caml/fail.h caml/gc.h caml/intext.h \ + caml/io.h caml/io.h caml/md5.h caml/memory.h caml/gc.h caml/major_gc.h \ + caml/freelist.h caml/minor_gc.h caml/address_class.h caml/misc.h \ + caml/mlvalues.h caml/reverse.h +fail.pic.o: fail.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/fail.h caml/io.h caml/gc.h caml/memory.h caml/gc.h \ + caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ + caml/misc.h caml/mlvalues.h caml/printexc.h caml/signals.h \ + caml/stacks.h caml/memory.h +finalise.pic.o: finalise.c caml/callback.h caml/compatibility.h \ + caml/mlvalues.h caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/misc.h caml/fail.h caml/mlvalues.h \ + caml/roots.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/signals.h +fix_code.pic.o: fix_code.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/compatibility.h caml/debugger.h caml/misc.h \ + caml/config.h caml/mlvalues.h caml/fix_code.h caml/instruct.h \ + caml/intext.h caml/io.h caml/md5.h caml/memory.h caml/gc.h \ + caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ + caml/misc.h caml/mlvalues.h caml/reverse.h +floats.pic.o: floats.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/fail.h caml/memory.h caml/gc.h caml/major_gc.h \ + caml/freelist.h caml/minor_gc.h caml/address_class.h caml/mlvalues.h \ + caml/misc.h caml/reverse.h caml/stacks.h caml/memory.h +freelist.pic.o: freelist.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/compatibility.h caml/freelist.h caml/misc.h \ + caml/config.h caml/mlvalues.h caml/gc.h caml/gc_ctrl.h caml/memory.h \ + caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/major_gc.h caml/misc.h caml/mlvalues.h +gc_ctrl.pic.o: gc_ctrl.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/compact.h caml/custom.h caml/finalise.h \ + caml/roots.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/freelist.h caml/gc.h \ + caml/gc_ctrl.h caml/major_gc.h caml/minor_gc.h caml/misc.h \ + caml/mlvalues.h caml/stacks.h +globroots.pic.o: globroots.c caml/memory.h caml/compatibility.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/gc.h caml/mlvalues.h \ + caml/misc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/misc.h caml/mlvalues.h caml/roots.h \ + caml/memory.h caml/globroots.h caml/roots.h +hash.pic.o: hash.c caml/mlvalues.h caml/compatibility.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/misc.h caml/custom.h \ + caml/mlvalues.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/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 -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 -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 -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 -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 -main.pic.o: main.c misc.h compatibility.h config.h ../config/m.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 -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 -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 -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 -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 -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 -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 -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 -prims.pic.o: prims.c mlvalues.h compatibility.h config.h ../config/m.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 -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 -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 -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 -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 -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 -str.pic.o: str.c alloc.h compatibility.h misc.h config.h ../config/m.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 -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 -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 -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 -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 +intern.pic.o: intern.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/callback.h caml/custom.h caml/fail.h caml/gc.h \ + caml/intext.h caml/io.h caml/io.h caml/md5.h caml/memory.h caml/gc.h \ + caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ + caml/mlvalues.h caml/misc.h caml/reverse.h +interp.pic.o: interp.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/backtrace.h caml/exec.h caml/callback.h \ + caml/debugger.h caml/fail.h caml/fix_code.h caml/instrtrace.h \ + caml/instruct.h caml/interp.h caml/major_gc.h caml/freelist.h \ + caml/memory.h caml/gc.h caml/major_gc.h caml/minor_gc.h \ + caml/address_class.h caml/misc.h caml/mlvalues.h caml/prims.h \ + caml/signals.h caml/stacks.h caml/memory.h caml/startup_aux.h \ + caml/jumptbl.h +ints.pic.o: ints.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/custom.h caml/fail.h caml/intext.h caml/io.h \ + caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/misc.h caml/mlvalues.h +io.pic.o: io.c caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/compatibility.h caml/alloc.h caml/misc.h caml/config.h \ + caml/mlvalues.h caml/custom.h caml/fail.h caml/io.h caml/memory.h \ + caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/misc.h caml/mlvalues.h caml/signals.h \ + caml/sys.h +lexing.pic.o: lexing.c caml/fail.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/mlvalues.h caml/stacks.h caml/memory.h caml/gc.h \ + caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h +main.pic.o: main.c caml/misc.h caml/compatibility.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h caml/misc.h \ + caml/sys.h +major_gc.pic.o: major_gc.c caml/compact.h caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/compatibility.h caml/misc.h caml/custom.h \ + caml/mlvalues.h caml/config.h caml/fail.h caml/finalise.h caml/roots.h \ + caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/freelist.h caml/gc.h caml/gc_ctrl.h \ + caml/major_gc.h caml/misc.h caml/mlvalues.h caml/roots.h caml/weak.h +md5.pic.o: md5.c caml/alloc.h caml/compatibility.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h caml/fail.h \ + caml/md5.h caml/io.h caml/memory.h caml/gc.h caml/major_gc.h \ + caml/freelist.h caml/minor_gc.h caml/address_class.h caml/mlvalues.h \ + caml/io.h caml/reverse.h +memory.pic.o: memory.c caml/address_class.h caml/misc.h caml/compatibility.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/fail.h caml/freelist.h caml/gc.h caml/gc_ctrl.h \ + caml/major_gc.h caml/freelist.h caml/memory.h caml/gc.h caml/major_gc.h \ + caml/minor_gc.h caml/address_class.h caml/minor_gc.h caml/misc.h \ + caml/mlvalues.h caml/signals.h +meta.pic.o: meta.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/config.h caml/fail.h caml/fix_code.h caml/interp.h \ + caml/intext.h caml/io.h caml/major_gc.h caml/freelist.h caml/memory.h \ + caml/gc.h caml/major_gc.h caml/minor_gc.h caml/address_class.h \ + caml/minor_gc.h caml/misc.h caml/mlvalues.h caml/prims.h caml/stacks.h \ + caml/memory.h +minor_gc.pic.o: minor_gc.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/compatibility.h caml/fail.h caml/misc.h \ + caml/config.h caml/mlvalues.h caml/finalise.h caml/roots.h \ + caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/gc.h caml/gc_ctrl.h caml/major_gc.h \ + caml/memory.h caml/minor_gc.h caml/misc.h caml/mlvalues.h caml/roots.h \ + caml/signals.h caml/weak.h +misc.pic.o: misc.c caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/compatibility.h caml/misc.h caml/config.h caml/memory.h caml/gc.h \ + caml/mlvalues.h caml/misc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h +obj.pic.o: obj.c caml/alloc.h caml/compatibility.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h caml/fail.h \ + caml/gc.h caml/interp.h caml/major_gc.h caml/freelist.h caml/memory.h \ + caml/gc.h caml/major_gc.h caml/minor_gc.h caml/address_class.h \ + caml/minor_gc.h caml/misc.h caml/mlvalues.h caml/prims.h +parsing.pic.o: parsing.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/compatibility.h caml/mlvalues.h \ + caml/config.h caml/misc.h caml/memory.h caml/gc.h caml/mlvalues.h \ + caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ + caml/alloc.h +prims.pic.o: prims.c caml/mlvalues.h caml/compatibility.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/misc.h caml/prims.h +printexc.pic.o: printexc.c caml/backtrace.h caml/mlvalues.h \ + caml/compatibility.h caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/misc.h caml/exec.h caml/callback.h \ + caml/debugger.h caml/fail.h caml/misc.h caml/mlvalues.h caml/printexc.h +roots.pic.o: roots.c caml/finalise.h caml/roots.h caml/misc.h \ + caml/compatibility.h caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/memory.h caml/gc.h caml/mlvalues.h \ + caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ + caml/globroots.h caml/major_gc.h caml/memory.h caml/minor_gc.h \ + caml/misc.h caml/mlvalues.h caml/roots.h caml/stacks.h +signals.pic.o: signals.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/callback.h caml/config.h caml/fail.h caml/memory.h \ + caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/misc.h caml/mlvalues.h caml/roots.h \ + caml/memory.h caml/signals.h caml/signals_machdep.h caml/sys.h +signals_byt.pic.o: signals_byt.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/compatibility.h caml/memory.h caml/config.h \ + caml/gc.h caml/mlvalues.h caml/misc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/osdeps.h caml/signals.h \ + caml/signals_machdep.h +stacks.pic.o: stacks.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/compatibility.h caml/fail.h caml/misc.h \ + caml/config.h caml/mlvalues.h caml/misc.h caml/mlvalues.h caml/stacks.h \ + caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h +startup.pic.o: startup.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/compatibility.h caml/alloc.h caml/misc.h \ + caml/config.h caml/mlvalues.h caml/backtrace.h caml/exec.h \ + caml/callback.h caml/custom.h caml/debugger.h caml/dynlink.h \ + caml/exec.h caml/fail.h caml/fix_code.h caml/freelist.h caml/gc_ctrl.h \ + caml/instrtrace.h caml/interp.h caml/intext.h caml/io.h caml/io.h \ + caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/minor_gc.h caml/misc.h caml/mlvalues.h \ + caml/osdeps.h caml/prims.h caml/printexc.h caml/reverse.h \ + caml/signals.h caml/stacks.h caml/memory.h caml/sys.h caml/startup.h \ + caml/startup_aux.h caml/version.h +startup_aux.pic.o: startup_aux.c caml/backtrace.h caml/mlvalues.h \ + caml/compatibility.h caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/misc.h caml/exec.h caml/memory.h caml/gc.h \ + caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ + caml/startup_aux.h +str.pic.o: str.c caml/alloc.h caml/compatibility.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h caml/fail.h \ + caml/mlvalues.h caml/misc.h +sys.pic.o: sys.c caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/compatibility.h caml/alloc.h caml/misc.h caml/config.h \ + caml/mlvalues.h caml/debugger.h caml/fail.h caml/instruct.h \ + caml/mlvalues.h caml/osdeps.h caml/signals.h caml/stacks.h \ + caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/sys.h caml/gc_ctrl.h +terminfo.pic.o: terminfo.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/compatibility.h caml/alloc.h caml/misc.h \ + caml/config.h caml/mlvalues.h caml/fail.h caml/io.h caml/mlvalues.h +unix.pic.o: unix.c caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/compatibility.h caml/memory.h caml/config.h caml/gc.h \ + caml/mlvalues.h caml/misc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/misc.h caml/osdeps.h +weak.pic.o: weak.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/fail.h caml/major_gc.h caml/freelist.h \ + caml/memory.h caml/gc.h caml/major_gc.h caml/minor_gc.h \ + caml/address_class.h caml/mlvalues.h +win32.pic.o: win32.c caml/address_class.h caml/misc.h caml/compatibility.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/fail.h caml/memory.h caml/gc.h caml/major_gc.h \ + caml/freelist.h caml/minor_gc.h caml/address_class.h caml/misc.h \ + caml/osdeps.h caml/signals.h caml/sys.h diff --git a/byterun/.ignore b/byterun/.ignore index 7b178a46d2..be5833e52d 100644 --- a/byterun/.ignore +++ b/byterun/.ignore @@ -1,8 +1,5 @@ -jumptbl.h primitives prims.c -opnames.h -version.h ocamlrun ocamlrun.exe ocamlrund diff --git a/byterun/Makefile b/byterun/Makefile index 816dd75e51..ae57e2a7aa 100644 --- a/byterun/Makefile +++ b/byterun/Makefile @@ -13,17 +13,14 @@ include Makefile.common -CFLAGS=-DCAML_NAME_SPACE -O $(BYTECCCOMPOPTS) $(IFLEXDIR) +CFLAGS=-DCAML_NAME_SPACE $(BYTECCCOMPOPTS) $(IFLEXDIR) DFLAGS=-DCAML_NAME_SPACE -g -DDEBUG $(BYTECCCOMPOPTS) $(IFLEXDIR) OBJS=$(COMMONOBJS) $(UNIX_OR_WIN32).o main.o DOBJS=$(OBJS:.o=.d.o) instrtrace.d.o PICOBJS=$(OBJS:.o=.pic.o) -SHARED_LIBS_TMP=$(SUPPORTS_SHARED_LIBRARIES:%false=) -SHARED_LIBS_DEPS=$(SHARED_LIBS_TMP:%true=libcamlrun_shared.so) - -all:: $(SHARED_LIBS_DEPS) +all:: all-$(SHARED) ocamlrun$(EXE): libcamlrun.a prims.o $(MKEXE) $(BYTECCLINKOPTS) -o ocamlrun$(EXE) \ @@ -34,42 +31,50 @@ ocamlrund$(EXE): libcamlrund.a prims.o prims.o libcamlrund.a $(BYTECCLIBS) libcamlrun.a: $(OBJS) - ar rc libcamlrun.a $(OBJS) + $(ARCMD) rc libcamlrun.a $(OBJS) $(RANLIB) libcamlrun.a libcamlrund.a: $(DOBJS) - ar rc libcamlrund.a $(DOBJS) + $(ARCMD) rc libcamlrund.a $(DOBJS) $(RANLIB) libcamlrund.a +all-noshared: +.PHONY: all-noshared + +all-shared: libcamlrun_pic.a libcamlrun_shared.so +.PHONY: all-shared + +libcamlrun_pic.a: $(PICOBJS) + ar rc libcamlrun_pic.a $(PICOBJS) + $(RANLIB) libcamlrun_pic.a + libcamlrun_shared.so: $(PICOBJS) $(MKDLL) -o libcamlrun_shared.so $(PICOBJS) $(BYTECCLIBS) -install:: - if test -f libcamlrun_shared.so; then \ - cp libcamlrun_shared.so $(INSTALL_LIBDIR)/libcamlrun_shared.so; fi +install:: install-$(SHARED) -clean:: - rm -f libcamlrun_shared.so +install-noshared: +.PHONY: install-noshared -.SUFFIXES: .d.o .pic.o +install-shared: + cp libcamlrun_shared.so $(INSTALL_LIBDIR)/libcamlrun_shared.so + cp libcamlrun_pic.a $(INSTALL_LIBDIR)/libcamlrun_pic.a + cd $(INSTALL_LIBDIR); $(RANLIB) libcamlrun_pic.a +.PHONY: install-shared -.c.d.o: - ln -s -f $*.c $*.d.c - $(CC) -c $(DFLAGS) $*.d.c - rm $*.d.c +clean:: + rm -f libcamlrun_shared.so libcamlrun_pic.a -.c.pic.o: - ln -s -f $*.c $*.pic.c - $(CC) -c $(CFLAGS) $(SHAREDCCCOMPOPTS) $*.pic.c - rm $*.pic.c +%.d.o: %.c + $(CC) -c $(DFLAGS) $< -o $@ -clean:: - rm -f *.pic.c *.d.c +%.pic.o: %.c + $(CC) -c $(CFLAGS) $(SHAREDCCCOMPOPTS) $< -o $@ -depend : prims.c opnames.h jumptbl.h version.h - -gcc -MM $(BYTECCCOMPOPTS) *.c > .depend - -gcc -MM $(BYTECCCOMPOPTS) -DDEBUG *.c | sed -e 's/\.o/.d.o/' >> .depend - -gcc -MM $(BYTECCCOMPOPTS) *.c | sed -e 's/\.o/.pic.o/' >> .depend +depend : prims.c caml/opnames.h caml/jumptbl.h caml/version.h + -$(CC) -MM $(BYTECCCOMPOPTS) *.c > .depend + -$(CC) -MM $(BYTECCCOMPOPTS) -DDEBUG *.c | sed -e 's/\.o/.d.o/' >> .depend + -$(CC) -MM $(BYTECCCOMPOPTS) *.c | sed -e 's/\.o/.pic.o/' >> .depend .PHONY: depend include .depend diff --git a/byterun/Makefile.common b/byterun/Makefile.common index b6bff21948..36e93325a7 100755..100644 --- a/byterun/Makefile.common +++ b/byterun/Makefile.common @@ -12,11 +12,13 @@ ######################################################################### include ../config/Makefile +CAMLRUN ?= ../boot/ocamlrun +CAMLYACC ?= ../boot/ocamlyacc CC=$(BYTECC) COMMONOBJS=\ - interp.o misc.o stacks.o fix_code.o startup.o \ + interp.o misc.o stacks.o fix_code.o startup_aux.o startup.o \ freelist.o major_gc.o minor_gc.o memory.o alloc.o roots.o globroots.o \ fail.o signals.o signals_byt.o printexc.o backtrace.o \ compare.o ints.o floats.o str.o array.o io.o extern.o intern.o \ @@ -31,7 +33,8 @@ PRIMS=\ dynlink.c backtrace.c PUBLIC_INCLUDES=\ - alloc.h callback.h config.h custom.h fail.h hash.h intext.h \ + address_class.h alloc.h callback.h config.h custom.h fail.h gc.h \ + hash.h intext.h \ memory.h misc.h mlvalues.h printexc.h signals.h compatibility.h \ version.h @@ -56,13 +59,13 @@ INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR) install:: - cp ocamlrun$(EXE) $(INSTALL_BINDIR)/ocamlrun$(EXE) + cp $(CAMLRUN)$(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 > $(INSTALL_LIBDIR)/caml/$$i; \ + sed -f ../tools/cleanup-header caml/$$i > $(INSTALL_LIBDIR)/caml/$$i; \ done cp ld.conf $(INSTALL_LIBDIR)/ld.conf .PHONY: install @@ -72,6 +75,10 @@ install:: install-$(RUNTIMED) install-noruntimed: .PHONY: install-noruntimed +# TODO: when cross-compiling, do not install ocamlrund +# it doesn't hurt to install it, but it's useless and might be confusing +# because it's an executable for the target machine, while we're installing +# binaries for the host. install-runtimed: cp ocamlrund$(EXE) $(INSTALL_BINDIR)/ocamlrund$(EXE) cp libcamlrund.$(A) $(INSTALL_LIBDIR)/libcamlrund.$(A) @@ -96,8 +103,8 @@ primitives : $(PRIMS) | sort | uniq > primitives prims.c : primitives - (echo '#include "mlvalues.h"'; \ - echo '#include "prims.h"'; \ + (echo '#include "caml/mlvalues.h"'; \ + echo '#include "caml/prims.h"'; \ sed -e 's/.*/extern value &();/' primitives; \ echo 'c_primitive caml_builtin_cprim[] = {'; \ sed -e 's/.*/ &,/' primitives; \ @@ -106,23 +113,23 @@ prims.c : primitives sed -e 's/.*/ "&",/' primitives; \ echo ' 0 };') > prims.c -opnames.h : instruct.h +caml/opnames.h : caml/instruct.h sed -e '/\/\*/d' \ -e '/^#/d' \ -e 's/enum /char * names_of_/' \ -e 's/{$$/[] = {/' \ - -e 's/\([[:upper:]][[:upper:]_0-9]*\)/"\1"/g' instruct.h > opnames.h + -e 's/\([[:upper:]][[:upper:]_0-9]*\)/"\1"/g' caml/instruct.h > caml/opnames.h -# jumptbl.h is required only if you have GCC 2.0 or later -jumptbl.h : instruct.h +# caml/jumptbl.h is required only if you have GCC 2.0 or later +caml/jumptbl.h : caml/instruct.h sed -n -e '/^ /s/ \([A-Z]\)/ \&\&lbl_\1/gp' \ - -e '/^}/q' instruct.h > jumptbl.h + -e '/^}/q' caml/instruct.h > caml/jumptbl.h -version.h : ../VERSION ../tools/make-version-header.sh - ../tools/make-version-header.sh ../VERSION > version.h +caml/version.h : ../VERSION ../tools/make-version-header.sh + ../tools/make-version-header.sh ../VERSION > caml/version.h clean :: rm -f ocamlrun$(EXE) ocamlrund$(EXE) *.$(O) *.$(A) *.$(SO) - rm -f primitives prims.c opnames.h jumptbl.h ld.conf - rm -f version.h + rm -f primitives prims.c caml/opnames.h caml/jumptbl.h ld.conf + rm -f caml/version.h .PHONY: clean diff --git a/byterun/Makefile.nt b/byterun/Makefile.nt index af28818842..257e364416 100644 --- a/byterun/Makefile.nt +++ b/byterun/Makefile.nt @@ -24,7 +24,7 @@ ocamlrun$(EXE): libcamlrun.$(A) prims.$(O) $(EXTRALIBS) libcamlrun.$(A) ocamlrund$(EXE): libcamlrund.$(A) prims.$(O) main.$(O) - $(MKEXE) -o ocamlrun$(EXE) $(BYTECCDBGCOMPOPTS) prims.$(O) \ + $(MKEXE) -o ocamlrund$(EXE) $(BYTECCDBGCOMPOPTS) prims.$(O) \ $(call SYSLIB,ws2_32) $(EXTRALIBS) libcamlrund.$(A) libcamlrun.$(A): $(OBJS) @@ -33,21 +33,22 @@ libcamlrun.$(A): $(OBJS) libcamlrund.$(A): $(DOBJS) $(call MKLIB,libcamlrund.$(A),$(DOBJS)) -.SUFFIXES: .$(O) .$(DBGO) - -.c.$(O): +%.$(O): %.c $(CC) $(CFLAGS) $(BYTECCCOMPOPTS) -c $< -.c.$(DBGO): - $(CC) $(CFLAGS) $(BYTECCDBGCOMPOPTS) -c $< - mv $*.$(O) $*.$(DBGO) +%.$(DBGO): %.c + $(CC) $(CFLAGS) $(BYTECCDBGCOMPOPTS) -c -o $@ $< .depend.nt: .depend rm -f .depend.win32 - echo "win32.o: win32.c fail.h compatibility.h \\" >> .depend.win32 - echo " misc.h config.h ../config/m.h ../config/s.h \\" >> .depend.win32 - echo " mlvalues.h memory.h gc.h major_gc.h \\" >> .depend.win32 - echo " freelist.h minor_gc.h osdeps.h signals.h" >> .depend.win32 + echo "win32.o: win32.c caml/fail.h caml/compatibility.h \\"\ + >> .depend.win32 + echo " caml/misc.h caml/config.h ../config/m.h ../config/s.h \\"\ + >> .depend.win32 + echo " caml/mlvalues.h caml/memory.h caml/gc.h caml/major_gc.h \\"\ + >> .depend.win32 + echo " caml/freelist.h caml/minor_gc.h caml/osdeps.h caml/signals.h"\ + >> .depend.win32 cat .depend >> .depend.win32 sed -e '/\.d\.o/q' -e 's/^\(.*\)\.o:/\1.$$(O) \1.$$(DBGO):/' \ .depend.win32 > .depend.nt diff --git a/byterun/alloc.c b/byterun/alloc.c index 1fc33b55a2..8afc5b7859 100644 --- a/byterun/alloc.c +++ b/byterun/alloc.c @@ -17,12 +17,12 @@ */ #include <string.h> -#include "alloc.h" -#include "custom.h" -#include "major_gc.h" -#include "memory.h" -#include "mlvalues.h" -#include "stacks.h" +#include "caml/alloc.h" +#include "caml/custom.h" +#include "caml/major_gc.h" +#include "caml/memory.h" +#include "caml/mlvalues.h" +#include "caml/stacks.h" #define Setup_for_gc #define Restore_after_gc @@ -62,11 +62,13 @@ CAMLexport value caml_alloc_small (mlsize_t wosize, tag_t tag) return result; } +/* [n] is a number of words (fields) */ CAMLexport value caml_alloc_tuple(mlsize_t n) { return caml_alloc(n, 0); } +/* [len] is a number of bytes (chars) */ CAMLexport value caml_alloc_string (mlsize_t len) { value result; @@ -85,6 +87,9 @@ CAMLexport value caml_alloc_string (mlsize_t len) return result; } +/* [len] is a number of words. + [mem] and [max] are relative (without unit). +*/ CAMLexport value caml_alloc_final (mlsize_t len, final_fun fun, mlsize_t mem, mlsize_t max) { @@ -145,6 +150,7 @@ CAMLexport int caml_convert_flag_list(value list, int *flags) /* For compiling let rec over values */ +/* [size] is a [value] representing number of words (fields) */ CAMLprim value caml_alloc_dummy(value size) { mlsize_t wosize = Int_val(size); @@ -153,6 +159,14 @@ CAMLprim value caml_alloc_dummy(value size) return caml_alloc (wosize, 0); } +/* [size] is a [value] representing number of words (fields) */ +CAMLprim value caml_alloc_dummy_function(value size,value arity) +{ + /* the arity argument is used by the js_of_ocaml runtime */ + return caml_alloc_dummy(size); +} + +/* [size] is a [value] representing number of floats. */ CAMLprim value caml_alloc_dummy_float (value size) { mlsize_t wosize = Int_val(size) * Double_wosize; @@ -184,3 +198,7 @@ CAMLprim value caml_update_dummy(value dummy, value newval) } return Val_unit; } + + + + diff --git a/byterun/array.c b/byterun/array.c index ba6fd701bc..03fecbfdf9 100644 --- a/byterun/array.c +++ b/byterun/array.c @@ -14,12 +14,13 @@ /* Operations on arrays */ #include <string.h> -#include "alloc.h" -#include "fail.h" -#include "memory.h" -#include "misc.h" -#include "mlvalues.h" +#include "caml/alloc.h" +#include "caml/fail.h" +#include "caml/memory.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" +/* returns number of elements (either fields or floats) */ CAMLexport mlsize_t caml_array_length(value array) { if (Tag_val(array) == Double_array_tag) @@ -135,6 +136,7 @@ CAMLprim value caml_array_unsafe_set(value array, value index, value newval) return caml_array_unsafe_set_addr(array, index, newval); } +/* [len] is a [value] representing number of floats */ CAMLprim value caml_make_float_vect(value len) { mlsize_t wosize = Long_val(len) * Double_wosize; @@ -156,6 +158,7 @@ CAMLprim value caml_make_float_vect(value len) return result; } +/* [len] is a [value] representing number of words or floats */ CAMLprim value caml_make_vect(value len, value init) { CAMLparam2 (len, init); diff --git a/byterun/backtrace.c b/byterun/backtrace.c index 6ed56c840b..82a3eed30c 100644 --- a/byterun/backtrace.c +++ b/byterun/backtrace.c @@ -18,29 +18,31 @@ #include <stdlib.h> #include <string.h> -#include "config.h" +#include "caml/config.h" #ifdef HAS_UNISTD #include <unistd.h> #endif -#include "mlvalues.h" -#include "alloc.h" -#include "io.h" -#include "instruct.h" -#include "intext.h" -#include "exec.h" -#include "fix_code.h" -#include "memory.h" -#include "startup.h" -#include "stacks.h" -#include "sys.h" -#include "backtrace.h" -#include "fail.h" +#include "caml/mlvalues.h" +#include "caml/alloc.h" +#include "caml/custom.h" +#include "caml/io.h" +#include "caml/instruct.h" +#include "caml/intext.h" +#include "caml/exec.h" +#include "caml/fix_code.h" +#include "caml/memory.h" +#include "caml/startup.h" +#include "caml/stacks.h" +#include "caml/sys.h" +#include "caml/backtrace.h" +#include "caml/fail.h" CAMLexport int caml_backtrace_active = 0; CAMLexport int caml_backtrace_pos = 0; CAMLexport code_t * caml_backtrace_buffer = NULL; CAMLexport value caml_backtrace_last_exn = Val_unit; +CAMLexport value caml_debug_info = Val_emptylist; CAMLexport char * caml_cds_file = NULL; #define BACKTRACE_BUFFER_SIZE 1024 @@ -63,6 +65,174 @@ enum { POS_CNUM = 3 }; +/* Runtime representation of the debug information, optimized + for quick lookup */ +struct ev_info { + code_t ev_pc; + char *ev_filename; + int ev_lnum; + int ev_startchr; + int ev_endchr; +}; + +struct debug_info { + code_t start; + code_t end; + mlsize_t num_events; + struct ev_info *events; + int already_read; +}; + +#define Debug_info_val(v) ((struct debug_info *) Data_custom_val(v)) + +static void caml_finalize_debug_info(value di) { + free(Debug_info_val(di)->events); + Debug_info_val(di)->events = NULL; +} + +static struct custom_operations caml_debug_info_ops = { + "_debug", + caml_finalize_debug_info, + custom_compare_default, + custom_hash_default, + custom_serialize_default, + custom_deserialize_default, + custom_compare_ext_default +}; + +static value caml_alloc_debug_info() { + return caml_alloc_custom(&caml_debug_info_ops, sizeof (struct debug_info), 0, 1); +} + +static struct debug_info *find_debug_info(code_t pc) { + value dis = caml_debug_info; + while (dis != Val_emptylist) { + struct debug_info *di = Debug_info_val(Field(dis, 0)); + if (pc >= di->start && pc < di->end) + return di; + dis = Field(dis, 1); + } + + return NULL; +} + +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; +} + +struct ev_info *process_debug_events(code_t code_start, value events_heap, mlsize_t *num_events) { + CAMLparam1(events_heap); + CAMLlocal3(l, ev, ev_start); + mlsize_t i, j; + struct ev_info *events; + + /* Compute the size of the required event buffer. */ + *num_events = 0; + for (i = 0; i < caml_array_length(events_heap); i++) + for (l = Field(events_heap, i); l != Val_int(0); l = Field(l, 1)) + (*num_events)++; + + events = malloc(*num_events * sizeof(struct ev_info)); + if(events == NULL) + caml_fatal_error ("caml_add_debug_info: out of memory"); + + j = 0; + for (i = 0; i < caml_array_length(events_heap); i++) { + for (l = Field(events_heap, i); l != Val_int(0); l = Field(l, 1)) { + ev = Field(l, 0); + + events[j].ev_pc = (code_t)((char*)code_start + Long_val(Field(ev, EV_POS))); + + ev_start = Field(Field(ev, EV_LOC), LOC_START); + + { + uintnat fnsz = caml_string_length(Field(ev_start, POS_FNAME)) + 1; + events[j].ev_filename = (char*)malloc(fnsz); + if(events[j].ev_filename == NULL) + caml_fatal_error ("caml_add_debug_info: out of memory"); + 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 == *num_events); + + qsort(events, *num_events, sizeof(struct ev_info), cmp_ev_info); + + CAMLreturnT(struct ev_info *, events); +} + +/* Processes a (Instruct.debug_event list array) into a form suitable + for quick lookup and registers it for the (code_start,code_size) pc range. */ +CAMLprim value caml_add_debug_info(code_t code_start, value code_size, value events_heap) +{ + CAMLparam1(events_heap); + CAMLlocal1(debug_info); + + /* build the OCaml-side debug_info value */ + debug_info = caml_alloc_debug_info(); + Debug_info_val(debug_info)->start = code_start; + Debug_info_val(debug_info)->end = (code_t)((char*) code_start + Long_val(code_size)); + if (events_heap == Val_unit) { + Debug_info_val(debug_info)->events = NULL; + Debug_info_val(debug_info)->num_events = 0; + Debug_info_val(debug_info)->already_read = 0; + } else { + Debug_info_val(debug_info)->events = + process_debug_events(code_start, events_heap, &Debug_info_val(debug_info)->num_events); + Debug_info_val(debug_info)->already_read = 1; + } + + /* prepend it to the global caml_debug_info root (an OCaml list) */ + { + value cons = caml_alloc(2, 0); + Store_field(cons, 0, debug_info); + Store_field(cons, 1, caml_debug_info); + caml_debug_info = cons; + } + + CAMLreturn(Val_unit); +} + +CAMLprim value caml_remove_debug_info(code_t start) +{ + CAMLparam0(); + CAMLlocal2(dis, prev); + + dis = caml_debug_info; + while (dis != Val_emptylist) { + struct debug_info *di = Debug_info_val(Field(dis, 0)); + if (di->start == start) { + if (prev != Val_unit) { + Store_field(prev, 1, Field(dis, 1)); + } else { + caml_debug_info = Field(dis, 1); + } + break; + } + prev = dis; + dis = Field(dis, 1); + } + + CAMLreturn(Val_unit); +} + /* Start or stop the backtrace machinery */ CAMLprim value caml_record_backtrace(value vflag) @@ -73,6 +243,7 @@ CAMLprim value caml_record_backtrace(value vflag) caml_backtrace_active = flag; caml_backtrace_pos = 0; if (flag) { + caml_backtrace_last_exn = Val_unit; caml_register_global_root(&caml_backtrace_last_exn); } else { caml_remove_global_root(&caml_backtrace_last_exn); @@ -96,28 +267,30 @@ CAMLprim value caml_backtrace_status(value vunit) void caml_stash_backtrace(value exn, code_t pc, value * sp, int reraise) { - code_t end_code = (code_t) ((char *) caml_start_code + caml_code_size); if (pc != NULL) pc = pc - 1; if (exn != caml_backtrace_last_exn || !reraise) { caml_backtrace_pos = 0; 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; } + if (caml_backtrace_pos >= BACKTRACE_BUFFER_SIZE) return; - if (pc >= caml_start_code && pc < end_code){ - /* testing the code region is needed: PR#1554 */ + /* testing the code region is needed: PR#1554 */ + if (find_debug_info(pc) != NULL) caml_backtrace_buffer[caml_backtrace_pos++] = pc; - } + + /* Traverse the stack and put all values pointing into bytecode + into the backtrace buffer. */ for (/*nothing*/; sp < caml_trapsp; sp++) { code_t p = (code_t) *sp; - if (p >= caml_start_code && p < end_code) { - if (caml_backtrace_pos >= BACKTRACE_BUFFER_SIZE) break; + if (caml_backtrace_pos >= BACKTRACE_BUFFER_SIZE) break; + if (find_debug_info(p) != NULL) caml_backtrace_buffer[caml_backtrace_pos++] = p; - } } } @@ -133,20 +306,20 @@ void caml_stash_backtrace(value exn, code_t pc, value * sp, int reraise) #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 + updates *sp to point to the following one, and *trsp to the next trap frame, which we will skip when we reach it */ -code_t caml_next_frame_pointer(value ** sp, value ** trapsp) +code_t caml_next_frame_pointer(value ** sp, value ** trsp) { - code_t end_code = (code_t) ((char *) caml_start_code + caml_code_size); - while (*sp < caml_stack_high) { code_t *p = (code_t*) (*sp)++; - if(&Trap_pc(*trapsp) == p) { - *trapsp = Trap_link(*trapsp); + if(&Trap_pc(*trsp) == p) { + *trsp = Trap_link(*trsp); continue; } - if (*p >= caml_start_code && *p < end_code) return *p; + + if (find_debug_info(*p) != NULL) + return *p; } return NULL; } @@ -170,10 +343,10 @@ CAMLprim value caml_get_current_callstack(value max_frames_value) { /* first compute the size of the trace */ { value * sp = caml_extern_sp; - value * trapsp = caml_trapsp; + value * trsp = caml_trapsp; for (trace_size = 0; trace_size < max_frames; trace_size++) { - code_t p = caml_next_frame_pointer(&sp, &trapsp); + code_t p = caml_next_frame_pointer(&sp, &trsp); if (p == NULL) break; } } @@ -183,11 +356,11 @@ CAMLprim value caml_get_current_callstack(value max_frames_value) { /* then collect the trace */ { value * sp = caml_extern_sp; - value * trapsp = caml_trapsp; + value * trsp = caml_trapsp; uintnat trace_pos; for (trace_pos = 0; trace_pos < trace_size; trace_pos++) { - code_t p = caml_next_frame_pointer(&sp, &trapsp); + code_t p = caml_next_frame_pointer(&sp, &trsp); Assert(p != NULL); Field(trace, trace_pos) = Val_Codet(p); } @@ -202,145 +375,97 @@ CAMLprim value caml_get_current_callstack(value max_frames_value) { #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 uintnat n_events; -static struct ev_info *events = NULL; -static void read_debug_info(void) +void read_main_debug_info(struct debug_info *di) { CAMLparam0(); - CAMLlocal1(events_heap); - char * exec_name; - int fd; + CAMLlocal3(events, evl, l); + char *exec_name; + int fd, num_events, orig, i; + struct channel *chan; struct exec_trailer trail; - struct channel * chan; - uint32_t num_events, orig, i; - intnat j; - value evl, l, ev_start; - if(events != NULL) - CAMLreturn0; + Assert(di->already_read == 0); + di->already_read = 1; if (caml_cds_file != NULL) { exec_name = caml_cds_file; } else { exec_name = caml_exe_name; } + fd = caml_attempt_open(&exec_name, &trail, 1); if (fd < 0){ - read_debug_info_error = "executable program file not found"; - 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"; + caml_fatal_error ("executable program file not found"); CAMLreturn0; } - chan = caml_open_descriptor_in(fd); - num_events = caml_getword(chan); - 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_heap, i, evl); - } - caml_close_channel(chan); - 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; + caml_read_section_descriptors(fd, &trail); + if (caml_seek_optional_section(fd, &trail, "DBUG") != -1) { + chan = caml_open_descriptor_in(fd); + + num_events = caml_getword(chan); + events = 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); } - 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++; + /* Record event list */ + Store_field(events, i, evl); } - } - Assert(j == n_events); + caml_close_channel(chan); - qsort(events, n_events, sizeof(struct ev_info), cmp_ev_info); + di->events = process_debug_events(caml_start_code, events, &di->num_events); + } CAMLreturn0; } +CAMLexport void caml_init_debug_info() +{ + caml_register_global_root(&caml_debug_info); + caml_add_debug_info(caml_start_code, Val_long(caml_code_size), Val_unit); +} + /* Search the event index for the given PC. Return -1 if not found. */ -static intnat event_for_location(code_t pc) +static struct ev_info *event_for_location(code_t pc) { - uintnat low = 0, high = n_events; - Assert(pc >= caml_start_code && pc < caml_start_code + caml_code_size); - Assert(events != NULL); + uintnat low, high; + struct debug_info *di = find_debug_info(pc); + + if (di == NULL) + return NULL; + + if (!di->already_read) + read_main_debug_info(di); + + if (di->num_events == 0) + return NULL; + + low = 0; + high = di->num_events; while(low+1 < high) { uintnat m = (low+high)/2; - if(pc < events[m].ev_pc) high = m; + if(pc < di->events[m].ev_pc) high = m; else low = m; } - if(events[low].ev_pc == pc) - return low; + if(di->events[low].ev_pc == pc) + return &di->events[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; + if(di->events[low].ev_pc == pc + 1) + return &di->events[low]; + if(low+1 < di->num_events && di->events[low+1].ev_pc == pc + 1) + return &di->events[low+1]; + + return NULL; } /* Extract location information for the given PC */ @@ -357,18 +482,18 @@ struct loc_info { static void extract_location_info(code_t pc, /*out*/ struct loc_info * li) { - intnat ev = event_for_location(pc); + struct ev_info *event = event_for_location(pc); li->loc_is_raise = caml_is_instruction(*pc, RAISE) || caml_is_instruction(*pc, RERAISE); - if (ev == -1) { + if (event == NULL) { li->loc_valid = 0; return; } li->loc_valid = 1; - 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; + li->loc_filename = event->ev_filename; + li->loc_lnum = event->ev_lnum; + li->loc_startchr = event->ev_startchr; + li->loc_endchr = event->ev_endchr; } /* Print location information -- same behavior as in Printexc */ @@ -408,12 +533,11 @@ CAMLexport void caml_print_exception_backtrace(void) int i; struct loc_info li; - read_debug_info(); - if (events == NULL) { - fprintf(stderr, "(Cannot print stack backtrace: %s)\n", - read_debug_info_error); + if (caml_debug_info == Val_emptylist) { + fprintf(stderr, "(Cannot print stack backtrace: no debug information available)\n"); return; } + for (i = 0; i < caml_backtrace_pos; i++) { extract_location_info(caml_backtrace_buffer[i], &li); print_location(&li, i); @@ -427,9 +551,8 @@ CAMLprim value caml_convert_raw_backtrace_slot(value backtrace_slot) { CAMLlocal2(p, fname); struct loc_info li; - read_debug_info(); - if (events == NULL) - caml_failwith(read_debug_info_error); + if (caml_debug_info == Val_emptylist) + caml_failwith("No debug information available"); extract_location_info(Codet_Val(backtrace_slot), &li); @@ -479,8 +602,7 @@ CAMLprim value caml_get_exception_backtrace(value unit) CAMLparam0(); CAMLlocal4(arr, raw_slot, slot, res); - read_debug_info(); - if (events == NULL) { + if (caml_debug_info == Val_emptylist) { res = Val_int(0); /* None */ } else { arr = caml_alloc(caml_backtrace_pos, 0); diff --git a/byterun/callback.c b/byterun/callback.c index 5da37ec9a9..3010985162 100644 --- a/byterun/callback.c +++ b/byterun/callback.c @@ -14,19 +14,19 @@ /* Callbacks from C to OCaml */ #include <string.h> -#include "callback.h" -#include "fail.h" -#include "memory.h" -#include "mlvalues.h" +#include "caml/callback.h" +#include "caml/fail.h" +#include "caml/memory.h" +#include "caml/mlvalues.h" #ifndef NATIVE_CODE /* Bytecode callbacks */ -#include "interp.h" -#include "instruct.h" -#include "fix_code.h" -#include "stacks.h" +#include "caml/interp.h" +#include "caml/instruct.h" +#include "caml/fix_code.h" +#include "caml/stacks.h" CAMLexport int caml_callback_depth = 0; @@ -245,3 +245,14 @@ CAMLexport value * caml_named_value(char const *name) } return NULL; } + +CAMLexport void caml_iterate_named_values(caml_named_action f) +{ + int i; + for(i = 0; i < Named_value_size; i++){ + struct named_value * nv; + for (nv = named_value_table[i]; nv != NULL; nv = nv->next) { + f( &nv->val, nv->name ); + } + } +} diff --git a/byterun/caml/.ignore b/byterun/caml/.ignore new file mode 100644 index 0000000000..a4d2753904 --- /dev/null +++ b/byterun/caml/.ignore @@ -0,0 +1,3 @@ +jumptbl.h +opnames.h +version.h diff --git a/byterun/caml/address_class.h b/byterun/caml/address_class.h new file mode 100644 index 0000000000..2cf6c048a2 --- /dev/null +++ b/byterun/caml/address_class.h @@ -0,0 +1,82 @@ +/***********************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Damien Doligez, projet Para, 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. */ +/* */ +/***********************************************************************/ + +/* Classification of addresses for GC and runtime purposes. */ + +#ifndef CAML_ADDRESS_CLASS_H +#define CAML_ADDRESS_CLASS_H + +#include "misc.h" +#include "mlvalues.h" + +/* Use the following macros to test an address for the different classes + it might belong to. */ + +#define Is_young(val) \ + (Assert (Is_block (val)), \ + (addr)(val) < (addr)caml_young_end && (addr)(val) > (addr)caml_young_start) + +#define Is_in_heap(a) (Classify_addr(a) & In_heap) + +#define Is_in_heap_or_young(a) (Classify_addr(a) & (In_heap | In_young)) + +#define Is_in_value_area(a) \ + (Classify_addr(a) & (In_heap | In_young | In_static_data)) + +#define Is_in_code_area(pc) \ + ( ((char *)(pc) >= caml_code_area_start && \ + (char *)(pc) <= caml_code_area_end) \ + || (Classify_addr(pc) & In_code_area) ) + +#define Is_in_static_data(a) (Classify_addr(a) & In_static_data) + +/***********************************************************************/ +/* The rest of this file is private and may change without notice. */ + +extern value *caml_young_start, *caml_young_end; +extern char * caml_code_area_start, * caml_code_area_end; + +#define Not_in_heap 0 +#define In_heap 1 +#define In_young 2 +#define In_static_data 4 +#define In_code_area 8 + +#ifdef ARCH_SIXTYFOUR + +/* 64 bits: Represent page table as a sparse hash table */ +int caml_page_table_lookup(void * addr); +#define Classify_addr(a) (caml_page_table_lookup((void *)(a))) + +#else + +/* 32 bits: Represent page table as a 2-level array */ +#define Pagetable2_log 11 +#define Pagetable2_size (1 << Pagetable2_log) +#define Pagetable1_log (Page_log + Pagetable2_log) +#define Pagetable1_size (1 << (32 - Pagetable1_log)) +CAMLextern unsigned char * caml_page_table[Pagetable1_size]; + +#define Pagetable_index1(a) (((uintnat)(a)) >> Pagetable1_log) +#define Pagetable_index2(a) \ + ((((uintnat)(a)) >> Page_log) & (Pagetable2_size - 1)) +#define Classify_addr(a) \ + caml_page_table[Pagetable_index1(a)][Pagetable_index2(a)] + +#endif + +int caml_page_table_add(int kind, void * start, void * end); +int caml_page_table_remove(int kind, void * start, void * end); +int caml_page_table_initialize(mlsize_t bytesize); + +#endif /* CAML_ADDRESS_CLASS_H */ diff --git a/byterun/alloc.h b/byterun/caml/alloc.h index 2a640ebe6a..9fbca4d906 100644 --- a/byterun/alloc.h +++ b/byterun/caml/alloc.h @@ -25,10 +25,10 @@ extern "C" { #endif -CAMLextern value caml_alloc (mlsize_t, tag_t); -CAMLextern value caml_alloc_small (mlsize_t, tag_t); -CAMLextern value caml_alloc_tuple (mlsize_t); -CAMLextern value caml_alloc_string (mlsize_t); /* size in bytes */ +CAMLextern value caml_alloc (mlsize_t wosize, tag_t); +CAMLextern value caml_alloc_small (mlsize_t wosize, tag_t); +CAMLextern value caml_alloc_tuple (mlsize_t wosize); +CAMLextern value caml_alloc_string (mlsize_t len); /* len in bytes (chars) */ CAMLextern value caml_copy_string (char const *); CAMLextern value caml_copy_string_array (char const **); CAMLextern value caml_copy_double (double); @@ -40,7 +40,7 @@ CAMLextern value caml_alloc_array (value (*funct) (char const *), CAMLextern value caml_alloc_sprintf(const char * format, ...); typedef void (*final_fun)(value); -CAMLextern value caml_alloc_final (mlsize_t, /*size in words*/ +CAMLextern value caml_alloc_final (mlsize_t wosize, final_fun, /*finalization function*/ mlsize_t, /*resources consumed*/ mlsize_t /*max resources*/); diff --git a/byterun/backtrace.h b/byterun/caml/backtrace.h index ec49991935..f1c7092226 100644 --- a/byterun/backtrace.h +++ b/byterun/caml/backtrace.h @@ -15,6 +15,7 @@ #define CAML_BACKTRACE_H #include "mlvalues.h" +#include "exec.h" CAMLextern int caml_backtrace_active; CAMLextern int caml_backtrace_pos; @@ -27,5 +28,6 @@ CAMLprim value caml_record_backtrace(value vflag); extern void caml_stash_backtrace(value exn, code_t pc, value * sp, int reraise); #endif CAMLextern void caml_print_exception_backtrace(void); +CAMLexport void caml_init_debug_info(); #endif /* CAML_BACKTRACE_H */ diff --git a/byterun/callback.h b/byterun/caml/callback.h index ded0b9801c..ef50945cfc 100644 --- a/byterun/callback.h +++ b/byterun/caml/callback.h @@ -42,6 +42,8 @@ CAMLextern value caml_callbackN_exn (value closure, int narg, value args[]); #define Extract_exception(v) ((v) & ~3) CAMLextern value * caml_named_value (char const * name); +typedef void (*caml_named_action) (value*, char *); +CAMLextern void caml_iterate_named_values(caml_named_action f); CAMLextern void caml_main (char ** argv); CAMLextern void caml_startup (char ** argv); diff --git a/byterun/compact.h b/byterun/caml/compact.h index 2abac167f3..2abac167f3 100644 --- a/byterun/compact.h +++ b/byterun/caml/compact.h diff --git a/byterun/compare.h b/byterun/caml/compare.h index 41d6a0c9bb..41d6a0c9bb 100644 --- a/byterun/compare.h +++ b/byterun/caml/compare.h diff --git a/byterun/compatibility.h b/byterun/caml/compatibility.h index 11181176c2..a4e4b04cfa 100644 --- a/byterun/compatibility.h +++ b/byterun/caml/compatibility.h @@ -16,6 +16,10 @@ #ifndef CAML_COMPATIBILITY_H #define CAML_COMPATIBILITY_H +/* internal global variables renamed between 4.02.1 and 4.03.0 */ +#define caml_stat_top_heap_size Bsize_wsize(caml_stat_top_heap_wsz) +#define caml_stat_heap_size Bsize_wsize(caml_stat_heap_wsz) + #ifndef CAML_NAME_SPACE /* diff --git a/byterun/config.h b/byterun/caml/config.h index 6c86d1672a..63f0edd77c 100644 --- a/byterun/config.h +++ b/byterun/caml/config.h @@ -17,8 +17,8 @@ /* <include ../config/m.h> */ /* <include ../config/s.h> */ /* <private> */ -#include "../config/m.h" -#include "../config/s.h" +#include "../../config/m.h" +#include "../../config/s.h" /* </private> */ #ifndef CAML_NAME_SPACE @@ -115,14 +115,14 @@ typedef uint64_t uintnat; #endif -/* Do not change this definition. */ -#define Page_size (1 << Page_log) - /* Memory model parameters */ /* The size of a page for memory management (in bytes) is [1 << Page_log]. - It must be a multiple of [sizeof (value)] and >= 8 and <= 20. */ + [Page_size] must be a multiple of [sizeof (value)]. + [Page_log] must be be >= 8 and <= 20. + Do not change the definition of [Page_size]. */ #define Page_log 12 /* A page is 4 kilobytes. */ +#define Page_size (1 << Page_log) /* Initial size of stack (bytes). */ #define Stack_size (4096 * sizeof(value)) diff --git a/byterun/custom.h b/byterun/caml/custom.h index ff3cd89a37..70b4726989 100644 --- a/byterun/custom.h +++ b/byterun/caml/custom.h @@ -26,8 +26,8 @@ struct custom_operations { int (*compare)(value v1, value v2); intnat (*hash)(value v); void (*serialize)(value v, - /*out*/ uintnat * wsize_32 /*size in bytes*/, - /*out*/ uintnat * wsize_64 /*size in bytes*/); + /*out*/ uintnat * bsize_32 /*size in bytes*/, + /*out*/ uintnat * bsize_64 /*size in bytes*/); uintnat (*deserialize)(void * dst); int (*compare_ext)(value v1, value v2); }; diff --git a/byterun/debugger.h b/byterun/caml/debugger.h index e68ef756c1..e68ef756c1 100644 --- a/byterun/debugger.h +++ b/byterun/caml/debugger.h diff --git a/byterun/dynlink.h b/byterun/caml/dynlink.h index 74cfdb663e..74cfdb663e 100644 --- a/byterun/dynlink.h +++ b/byterun/caml/dynlink.h diff --git a/byterun/exec.h b/byterun/caml/exec.h index 7e084acd41..7e084acd41 100644 --- a/byterun/exec.h +++ b/byterun/caml/exec.h diff --git a/byterun/fail.h b/byterun/caml/fail.h index da72c7805a..43031ec491 100644 --- a/byterun/fail.h +++ b/byterun/caml/fail.h @@ -60,22 +60,21 @@ int caml_is_special_exception(value exn); extern "C" { #endif -CAMLextern void caml_raise (value bucket) Noreturn; -CAMLextern void caml_raise_constant (value tag) Noreturn; -CAMLextern void caml_raise_with_arg (value tag, value arg) Noreturn; -CAMLextern void caml_raise_with_args (value tag, int nargs, value arg[]) - Noreturn; -CAMLextern void caml_raise_with_string (value tag, char const * msg) Noreturn; -CAMLextern void caml_failwith (char const *) Noreturn; -CAMLextern void caml_invalid_argument (char const *) Noreturn; -CAMLextern void caml_raise_out_of_memory (void) Noreturn; -CAMLextern void caml_raise_stack_overflow (void) Noreturn; -CAMLextern void caml_raise_sys_error (value) Noreturn; -CAMLextern void caml_raise_end_of_file (void) Noreturn; -CAMLextern void caml_raise_zero_divide (void) Noreturn; -CAMLextern void caml_raise_not_found (void) Noreturn; -CAMLextern void caml_array_bound_error (void) Noreturn; -CAMLextern void caml_raise_sys_blocked_io (void) Noreturn; +Noreturn CAMLextern void caml_raise (value bucket); +Noreturn CAMLextern void caml_raise_constant (value tag); +Noreturn CAMLextern void caml_raise_with_arg (value tag, value arg); +Noreturn CAMLextern void caml_raise_with_args (value tag, int nargs, value arg[]); +Noreturn CAMLextern void caml_raise_with_string (value tag, char const * msg); +Noreturn CAMLextern void caml_failwith (char const *); +Noreturn CAMLextern void caml_invalid_argument (char const *); +Noreturn CAMLextern void caml_raise_out_of_memory (void); +Noreturn CAMLextern void caml_raise_stack_overflow (void); +Noreturn CAMLextern void caml_raise_sys_error (value); +Noreturn CAMLextern void caml_raise_end_of_file (void); +Noreturn CAMLextern void caml_raise_zero_divide (void); +Noreturn CAMLextern void caml_raise_not_found (void); +Noreturn CAMLextern void caml_array_bound_error (void); +Noreturn CAMLextern void caml_raise_sys_blocked_io (void); #ifdef __cplusplus } diff --git a/byterun/finalise.h b/byterun/caml/finalise.h index 96853f525b..96853f525b 100644 --- a/byterun/finalise.h +++ b/byterun/caml/finalise.h diff --git a/byterun/fix_code.h b/byterun/caml/fix_code.h index 419ad327a5..419ad327a5 100644 --- a/byterun/fix_code.h +++ b/byterun/caml/fix_code.h diff --git a/byterun/freelist.h b/byterun/caml/freelist.h index 146961faac..2e811d45a8 100644 --- a/byterun/freelist.h +++ b/byterun/caml/freelist.h @@ -20,14 +20,14 @@ #include "misc.h" #include "mlvalues.h" -extern asize_t caml_fl_cur_size; /* size in words */ +extern asize_t caml_fl_cur_wsz; -char *caml_fl_allocate (mlsize_t); +header_t *caml_fl_allocate (mlsize_t wo_sz); void caml_fl_init_merge (void); void caml_fl_reset (void); -char *caml_fl_merge_block (char *); -void caml_fl_add_blocks (char *); -void caml_make_free_blocks (value *, mlsize_t, int, int); +header_t *caml_fl_merge_block (value); +void caml_fl_add_blocks (value); +void caml_make_free_blocks (value *, mlsize_t wsz, int, int); void caml_set_allocation_policy (uintnat); diff --git a/byterun/gc.h b/byterun/caml/gc.h index 3cbf08a2da..3cbf08a2da 100644 --- a/byterun/gc.h +++ b/byterun/caml/gc.h diff --git a/byterun/gc_ctrl.h b/byterun/caml/gc_ctrl.h index de6933e8ab..459c685a22 100644 --- a/byterun/gc_ctrl.h +++ b/byterun/caml/gc_ctrl.h @@ -24,8 +24,8 @@ extern double extern intnat caml_stat_minor_collections, caml_stat_major_collections, - caml_stat_heap_size, - caml_stat_top_heap_size, + caml_stat_heap_wsz, + caml_stat_top_heap_wsz, caml_stat_compactions, caml_stat_heap_chunks; diff --git a/byterun/globroots.h b/byterun/caml/globroots.h index 1c3ebab289..1c3ebab289 100644 --- a/byterun/globroots.h +++ b/byterun/caml/globroots.h diff --git a/byterun/hash.h b/byterun/caml/hash.h index 65613975b8..d130068c48 100644 --- a/byterun/hash.h +++ b/byterun/caml/hash.h @@ -18,6 +18,10 @@ #include "mlvalues.h" +#ifdef __cplusplus +extern "C" { +#endif + 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); @@ -25,5 +29,9 @@ 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); - +#ifdef __cplusplus +extern "C" { #endif + + +#endif /* CAML_HASH_H */ diff --git a/byterun/instrtrace.h b/byterun/caml/instrtrace.h index 3020160811..3020160811 100644 --- a/byterun/instrtrace.h +++ b/byterun/caml/instrtrace.h diff --git a/byterun/instruct.h b/byterun/caml/instruct.h index f9cc80ee65..f9cc80ee65 100644 --- a/byterun/instruct.h +++ b/byterun/caml/instruct.h diff --git a/byterun/int64_emul.h b/byterun/caml/int64_emul.h index 2554df1814..2554df1814 100644 --- a/byterun/int64_emul.h +++ b/byterun/caml/int64_emul.h diff --git a/byterun/int64_format.h b/byterun/caml/int64_format.h index aa8f1abab5..aa8f1abab5 100644 --- a/byterun/int64_format.h +++ b/byterun/caml/int64_format.h diff --git a/byterun/int64_native.h b/byterun/caml/int64_native.h index b6716ada2a..b6716ada2a 100644 --- a/byterun/int64_native.h +++ b/byterun/caml/int64_native.h diff --git a/byterun/interp.h b/byterun/caml/interp.h index c8e2f89f8e..c8e2f89f8e 100644 --- a/byterun/interp.h +++ b/byterun/caml/interp.h diff --git a/byterun/intext.h b/byterun/caml/intext.h index 2c108a4ae0..2c108a4ae0 100644 --- a/byterun/intext.h +++ b/byterun/caml/intext.h diff --git a/byterun/io.h b/byterun/caml/io.h index 5a9c0374c3..f0bc69f967 100644 --- a/byterun/io.h +++ b/byterun/caml/io.h @@ -44,6 +44,7 @@ struct channel { int old_revealed; /* For Cash only */ int refcount; /* For flush_all and for Cash */ int flags; /* Bitfield */ + char * name; /* Optional name (to report fd leaks) */ char buff[IO_BUFFER_SIZE]; /* The buffer itself */ }; diff --git a/byterun/major_gc.h b/byterun/caml/major_gc.h index f473df94fd..047f16a4ea 100644 --- a/byterun/major_gc.h +++ b/byterun/caml/major_gc.h @@ -19,7 +19,7 @@ #include "misc.h" typedef struct { - void *block; /* address of the malloced block this chunk live in */ + void *block; /* address of the malloced block this chunk lives in */ asize_t alloc; /* in bytes, used for compaction */ asize_t size; /* in bytes */ char *next; @@ -35,7 +35,7 @@ extern int caml_gc_subphase; extern uintnat caml_allocated_words; extern double caml_extra_heap_resources; extern uintnat caml_dependent_size, caml_dependent_allocated; -extern uintnat caml_fl_size_at_phase_change; +extern uintnat caml_fl_wsz_at_phase_change; #define Phase_mark 0 #define Phase_sweep 1 @@ -50,7 +50,7 @@ extern uintnat total_heap_size; extern char *caml_gc_sweep_hp; void caml_init_major_heap (asize_t); /* size in bytes */ -asize_t caml_round_heap_chunk_size (asize_t); /* size in bytes */ +asize_t caml_round_heap_chunk_wsz (asize_t); void caml_darken (value, value *); intnat caml_major_collection_slice (intnat); void major_collection (void); diff --git a/byterun/md5.h b/byterun/caml/md5.h index f63667d56a..f63667d56a 100644 --- a/byterun/md5.h +++ b/byterun/caml/md5.h diff --git a/byterun/memory.h b/byterun/caml/memory.h index 9befa873c1..ac1866fafe 100644 --- a/byterun/memory.h +++ b/byterun/caml/memory.h @@ -33,10 +33,10 @@ extern "C" { #endif -CAMLextern value caml_alloc_shr (mlsize_t, tag_t); +CAMLextern value caml_alloc_shr (mlsize_t wosize, tag_t); CAMLextern void caml_adjust_gc_speed (mlsize_t, mlsize_t); -CAMLextern void caml_alloc_dependent_memory (mlsize_t); -CAMLextern void caml_free_dependent_memory (mlsize_t); +CAMLextern void caml_alloc_dependent_memory (mlsize_t bsz); +CAMLextern void caml_free_dependent_memory (mlsize_t bsz); CAMLextern void caml_modify (value *, value); CAMLextern void caml_initialize (value *, value); CAMLextern value caml_check_urgent_gc (value); @@ -51,45 +51,7 @@ color_t caml_allocation_color (void *hp); /* void caml_shrink_heap (char *); Only used in compact.c */ /* <private> */ - -#define Not_in_heap 0 -#define In_heap 1 -#define In_young 2 -#define In_static_data 4 -#define In_code_area 8 - -#ifdef ARCH_SIXTYFOUR - -/* 64 bits: Represent page table as a sparse hash table */ -int caml_page_table_lookup(void * addr); -#define Classify_addr(a) (caml_page_table_lookup((void *)(a))) - -#else - -/* 32 bits: Represent page table as a 2-level array */ -#define Pagetable2_log 11 -#define Pagetable2_size (1 << Pagetable2_log) -#define Pagetable1_log (Page_log + Pagetable2_log) -#define Pagetable1_size (1 << (32 - Pagetable1_log)) -CAMLextern unsigned char * caml_page_table[Pagetable1_size]; - -#define Pagetable_index1(a) (((uintnat)(a)) >> Pagetable1_log) -#define Pagetable_index2(a) \ - ((((uintnat)(a)) >> Page_log) & (Pagetable2_size - 1)) -#define Classify_addr(a) \ - caml_page_table[Pagetable_index1(a)][Pagetable_index2(a)] - -#endif - -#define Is_in_value_area(a) \ - (Classify_addr(a) & (In_heap | In_young | In_static_data)) -#define Is_in_heap(a) (Classify_addr(a) & In_heap) -#define Is_in_heap_or_young(a) (Classify_addr(a) & (In_heap | In_young)) - -int caml_page_table_add(int kind, void * start, void * end); -int caml_page_table_remove(int kind, void * start, void * end); -int caml_page_table_initialize(mlsize_t bytesize); - + #ifdef DEBUG #define DEBUG_clear(result, wosize) do{ \ uintnat caml__DEBUG_i; \ @@ -104,13 +66,13 @@ int caml_page_table_initialize(mlsize_t bytesize); #define Alloc_small(result, wosize, tag) do{ CAMLassert ((wosize) >= 1); \ CAMLassert ((tag_t) (tag) < 256); \ CAMLassert ((wosize) <= Max_young_wosize); \ - caml_young_ptr -= Bhsize_wosize (wosize); \ + caml_young_ptr -= Whsize_wosize (wosize); \ if (caml_young_ptr < caml_young_start){ \ - caml_young_ptr += Bhsize_wosize (wosize); \ + caml_young_ptr += Whsize_wosize (wosize); \ Setup_for_gc; \ caml_minor_collection (); \ Restore_after_gc; \ - caml_young_ptr -= Bhsize_wosize (wosize); \ + caml_young_ptr -= Whsize_wosize (wosize); \ } \ Hd_hp (caml_young_ptr) = Make_header ((wosize), (tag), Caml_black); \ (result) = Val_hp (caml_young_ptr); \ @@ -154,7 +116,9 @@ CAMLextern struct caml__roots_block *caml_local_roots; /* defined in roots.c */ Your function may raise an exception or return a [value] with the [CAMLreturn] macro. Its argument is simply the [value] returned by your function. Do NOT directly return a [value] with the [return] - keyword. If your function returns void, use [CAMLreturn0]. + keyword. If your function returns void, use [CAMLreturn0]. If you + un-register the local roots (i.e. undo the effects of the [CAMLparam*] + and [CAMLlocal] macros) without returning immediately, use [CAMLdrop]. All the identifiers beginning with "caml__" are reserved by OCaml. Do not use them for anything (local or global variables, struct or @@ -190,35 +154,48 @@ CAMLextern struct caml__roots_block *caml_local_roots; /* defined in roots.c */ #if defined(__GNUC__) && (__GNUC__ > 2 || (__GNUC__ == 2 && __GNUC_MINOR__ > 7)) - #define CAMLunused __attribute__ ((unused)) + #define CAMLunused_start __attribute__ ((unused)) +#elif _MSC_VER >= 1500 + #define CAMLunused_start __pragma( warning (push) ) \ + __pragma( warning (disable:4189 ) ) + #else - #define CAMLunused + #define CAMLunused_start #endif +#if defined _MSC_VER >= 1500 + #define CAMLunused_end __pragma( warning (pop)) +#else + #define CAMLunused_end +#endif + + #define CAMLxparam1(x) \ struct caml__roots_block caml__roots_##x; \ - CAMLunused int caml__dummy_##x = ( \ + CAMLunused_start int caml__dummy_##x = ( \ (caml__roots_##x.next = caml_local_roots), \ (caml_local_roots = &caml__roots_##x), \ (caml__roots_##x.nitems = 1), \ (caml__roots_##x.ntables = 1), \ (caml__roots_##x.tables [0] = &x), \ - 0) + 0) \ + CAMLunused_end #define CAMLxparam2(x, y) \ struct caml__roots_block caml__roots_##x; \ - CAMLunused int caml__dummy_##x = ( \ + CAMLunused_start int caml__dummy_##x = ( \ (caml__roots_##x.next = caml_local_roots), \ (caml_local_roots = &caml__roots_##x), \ (caml__roots_##x.nitems = 1), \ (caml__roots_##x.ntables = 2), \ (caml__roots_##x.tables [0] = &x), \ (caml__roots_##x.tables [1] = &y), \ - 0) + 0) \ + CAMLunused_end #define CAMLxparam3(x, y, z) \ struct caml__roots_block caml__roots_##x; \ - CAMLunused int caml__dummy_##x = ( \ + CAMLunused_start int caml__dummy_##x = ( \ (caml__roots_##x.next = caml_local_roots), \ (caml_local_roots = &caml__roots_##x), \ (caml__roots_##x.nitems = 1), \ @@ -226,11 +203,12 @@ CAMLextern struct caml__roots_block *caml_local_roots; /* defined in roots.c */ (caml__roots_##x.tables [0] = &x), \ (caml__roots_##x.tables [1] = &y), \ (caml__roots_##x.tables [2] = &z), \ - 0) + 0) \ + CAMLunused_end #define CAMLxparam4(x, y, z, t) \ struct caml__roots_block caml__roots_##x; \ - CAMLunused int caml__dummy_##x = ( \ + CAMLunused_start int caml__dummy_##x = ( \ (caml__roots_##x.next = caml_local_roots), \ (caml_local_roots = &caml__roots_##x), \ (caml__roots_##x.nitems = 1), \ @@ -239,11 +217,12 @@ CAMLextern struct caml__roots_block *caml_local_roots; /* defined in roots.c */ (caml__roots_##x.tables [1] = &y), \ (caml__roots_##x.tables [2] = &z), \ (caml__roots_##x.tables [3] = &t), \ - 0) + 0) \ + CAMLunused_end #define CAMLxparam5(x, y, z, t, u) \ struct caml__roots_block caml__roots_##x; \ - CAMLunused int caml__dummy_##x = ( \ + CAMLunused_start int caml__dummy_##x = ( \ (caml__roots_##x.next = caml_local_roots), \ (caml_local_roots = &caml__roots_##x), \ (caml__roots_##x.nitems = 1), \ @@ -253,17 +232,19 @@ CAMLextern struct caml__roots_block *caml_local_roots; /* defined in roots.c */ (caml__roots_##x.tables [2] = &z), \ (caml__roots_##x.tables [3] = &t), \ (caml__roots_##x.tables [4] = &u), \ - 0) + 0) \ + CAMLunused_end #define CAMLxparamN(x, size) \ struct caml__roots_block caml__roots_##x; \ - CAMLunused int caml__dummy_##x = ( \ + CAMLunused_start int caml__dummy_##x = ( \ (caml__roots_##x.next = caml_local_roots), \ (caml_local_roots = &caml__roots_##x), \ (caml__roots_##x.nitems = (size)), \ (caml__roots_##x.ntables = 1), \ (caml__roots_##x.tables[0] = &(x[0])), \ - 0) + 0) \ + CAMLunused_end #define CAMLlocal1(x) \ value x = Val_unit; \ @@ -294,15 +275,17 @@ CAMLextern struct caml__roots_block *caml_local_roots; /* defined in roots.c */ CAMLxparamN (x, (size)) +#define CAMLdrop caml_local_roots = caml__frame + #define CAMLreturn0 do{ \ - caml_local_roots = caml__frame; \ + CAMLdrop; \ return; \ }while (0) #define CAMLreturnT(type, result) do{ \ type caml__temp_result = (result); \ - caml_local_roots = caml__frame; \ - return (caml__temp_result); \ + CAMLdrop; \ + return caml__temp_result; \ }while(0) #define CAMLreturn(result) CAMLreturnT(value, result) diff --git a/byterun/minor_gc.h b/byterun/caml/minor_gc.h index 4727826d70..9077cab9ff 100644 --- a/byterun/minor_gc.h +++ b/byterun/caml/minor_gc.h @@ -15,11 +15,11 @@ #define CAML_MINOR_GC_H -#include "misc.h" +#include "address_class.h" -CAMLextern char *caml_young_start, *caml_young_ptr; -CAMLextern char *caml_young_end, *caml_young_limit; -extern asize_t caml_minor_heap_size; +CAMLextern value *caml_young_start, *caml_young_ptr; +CAMLextern value *caml_young_end, *caml_young_limit; +extern asize_t caml_minor_heap_wsz; extern int caml_in_minor_collection; struct caml_ref_table { @@ -33,14 +33,10 @@ struct caml_ref_table { }; CAMLextern struct caml_ref_table caml_ref_table, caml_weak_ref_table; -#define Is_young(val) \ - (Assert (Is_block (val)), \ - (addr)(val) < (addr)caml_young_end && (addr)(val) > (addr)caml_young_start) - extern void caml_set_minor_heap_size (asize_t); /* size in bytes */ extern void caml_empty_minor_heap (void); CAMLextern void caml_minor_collection (void); -CAMLextern void garbage_collection (void); /* def in asmrun/signals.c */ +CAMLextern void garbage_collection (void); /* def in asmrun/signals_asm.c */ extern void caml_realloc_ref_table (struct caml_ref_table *); extern void caml_alloc_table (struct caml_ref_table *, asize_t, asize_t); extern void caml_oldify_one (value, value *); diff --git a/byterun/misc.h b/byterun/caml/misc.h index f7b4fdc24a..c29ed9cedb 100644 --- a/byterun/misc.h +++ b/byterun/caml/misc.h @@ -41,6 +41,8 @@ typedef char * addr; #ifdef __GNUC__ /* Works only in GCC 2.5 and later */ #define Noreturn __attribute__ ((noreturn)) +#elif _MSC_VER >= 1500 + #define Noreturn __declspec(noreturn) #else #define Noreturn #endif @@ -59,20 +61,31 @@ typedef char * addr; #define CAMLweakdef #endif +#ifdef __cplusplus +extern "C" { +#endif + +/* GC timing hooks. These can be assigned by the user. The hook functions + must not allocate or change the heap in any way. */ +typedef void (*caml_timing_hook) (void); +extern caml_timing_hook caml_major_slice_begin_hook, caml_major_slice_end_hook; +extern caml_timing_hook caml_minor_gc_begin_hook, caml_minor_gc_end_hook; +extern caml_timing_hook caml_finalise_begin_hook, caml_finalise_end_hook; + /* Assertions */ #ifdef DEBUG #define CAMLassert(x) \ ((x) ? (void) 0 : caml_failed_assert ( #x , __FILE__, __LINE__)) -CAMLextern int caml_failed_assert (char *, char *, int) Noreturn; +Noreturn CAMLextern int caml_failed_assert (char *, char *, int); #else #define CAMLassert(x) ((void) 0) #endif -CAMLextern void caml_fatal_error (char *msg) Noreturn; -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; +Noreturn CAMLextern void caml_fatal_error (char *msg); +Noreturn 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); /* Safe string operations */ @@ -91,6 +104,7 @@ struct ext_table { extern void caml_ext_table_init(struct ext_table * tbl, int init_capa); extern int caml_ext_table_add(struct ext_table * tbl, void * data); +extern void caml_ext_table_remove(struct ext_table * tbl, void * data); extern void caml_ext_table_free(struct ext_table * tbl, int free_entries); /* GC flags and messages */ @@ -100,7 +114,7 @@ void caml_gc_message (int, char *, uintnat); /* Memory routines */ -char *caml_aligned_malloc (asize_t, int, void **); +char *caml_aligned_malloc (asize_t bsize, int, void **); #ifdef DEBUG #ifdef ARCH_SIXTYFOUR @@ -135,7 +149,10 @@ char *caml_aligned_malloc (asize_t, int, void **); #define Debug_uninit_stat 0xD7 -extern void caml_set_fields (char *, unsigned long, unsigned long); +/* Note: the first argument is in fact a [value] but we don't have this + type available yet because we can't include [mlvalues.h] in this file. +*/ +extern void caml_set_fields (intnat v, unsigned long, unsigned long); #endif /* DEBUG */ @@ -152,4 +169,8 @@ extern int caml_snprintf(char * buf, size_t size, const char * format, ...); /* </private> */ +#ifdef __cplusplus +} +#endif + #endif /* CAML_MISC_H */ diff --git a/byterun/mlvalues.h b/byterun/caml/mlvalues.h index a08948eb1b..3b94d010c6 100644 --- a/byterun/mlvalues.h +++ b/byterun/caml/mlvalues.h @@ -101,7 +101,7 @@ bits 63 10 9 8 7 0 #define Hd_op(op) (Hd_val (op)) /* Also an l-value. */ #define Hd_bp(bp) (Hd_val (bp)) /* Also an l-value. */ #define Hd_hp(hp) (* ((header_t *) (hp))) /* Also an l-value. */ -#define Hp_val(val) ((char *) (((header_t *) (val)) - 1)) +#define Hp_val(val) (((header_t *) (val)) - 1) #define Hp_op(op) (Hp_val (op)) #define Hp_bp(bp) (Hp_val (bp)) #define Val_op(op) ((value) (op)) @@ -296,10 +296,10 @@ CAMLextern header_t caml_atom_table[]; extern value caml_global_data; +CAMLextern value caml_set_oo_id(value obj); + #ifdef __cplusplus } #endif -CAMLextern value caml_set_oo_id(value obj); - #endif /* CAML_MLVALUES_H */ diff --git a/byterun/osdeps.h b/byterun/caml/osdeps.h index 8204205f74..8204205f74 100644 --- a/byterun/osdeps.h +++ b/byterun/caml/osdeps.h diff --git a/byterun/prims.h b/byterun/caml/prims.h index 7a99678104..7a99678104 100644 --- a/byterun/prims.h +++ b/byterun/caml/prims.h diff --git a/byterun/printexc.h b/byterun/caml/printexc.h index 748faa9c2f..b4413b08c7 100644 --- a/byterun/printexc.h +++ b/byterun/caml/printexc.h @@ -24,7 +24,7 @@ extern "C" { CAMLextern char * caml_format_exception (value); -void caml_fatal_uncaught_exception (value) Noreturn; +Noreturn void caml_fatal_uncaught_exception (value); #ifdef __cplusplus } diff --git a/byterun/reverse.h b/byterun/caml/reverse.h index 09d34a51f6..09d34a51f6 100644 --- a/byterun/reverse.h +++ b/byterun/caml/reverse.h diff --git a/byterun/roots.h b/byterun/caml/roots.h index ca6a5d2623..ca6a5d2623 100644 --- a/byterun/roots.h +++ b/byterun/caml/roots.h diff --git a/byterun/signals.h b/byterun/caml/signals.h index 584516660c..584516660c 100644 --- a/byterun/signals.h +++ b/byterun/caml/signals.h diff --git a/byterun/signals_machdep.h b/byterun/caml/signals_machdep.h index 4987e2f6a8..c00c798590 100644 --- a/byterun/signals_machdep.h +++ b/byterun/caml/signals_machdep.h @@ -16,7 +16,13 @@ #ifndef CAML_SIGNALS_MACHDEP_H #define CAML_SIGNALS_MACHDEP_H -#if defined(__GNUC__) && defined(__i386__) +#if defined(__GNUC__) && defined(__ATOMIC_SEQ_CST) && defined(__GCC_ATOMIC_LONG_LOCK_FREE) + +/* Use the "atomic" builtins of GCC and Clang */ +#define Read_and_clear(dst,src) \ + ((dst) = __atomic_exchange_n(&(src), 0, __ATOMIC_SEQ_CST)) + +#elif defined(__GNUC__) && (defined(__i386__) || (defined(__x86_64__) && defined(__ILP32__))) #define Read_and_clear(dst,src) \ asm("xorl %0, %0; xchgl %0, %1" \ diff --git a/byterun/stacks.h b/byterun/caml/stacks.h index c596f2550e..c596f2550e 100644 --- a/byterun/stacks.h +++ b/byterun/caml/stacks.h diff --git a/byterun/startup.h b/byterun/caml/startup.h index 3268d8875b..3268d8875b 100644 --- a/byterun/startup.h +++ b/byterun/caml/startup.h diff --git a/byterun/caml/startup_aux.h b/byterun/caml/startup_aux.h new file mode 100644 index 0000000000..f1de0e29af --- /dev/null +++ b/byterun/caml/startup_aux.h @@ -0,0 +1,26 @@ +/***********************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Damien Doligez, Jane Street Group, LLC */ +/* */ +/* Copyright 2015 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. */ +/* */ +/***********************************************************************/ + +#include "config.h" + +extern void caml_init_atom_table (void); + +extern uintnat caml_init_percent_free; +extern uintnat caml_init_max_percent_free; +extern uintnat caml_init_minor_heap_wsz; +extern uintnat caml_init_heap_chunk_sz; +extern uintnat caml_init_heap_wsz; +extern uintnat caml_init_max_stack_wsz; +extern uintnat caml_trace_level; + +extern void caml_parse_ocamlrunparam (void); diff --git a/byterun/sys.h b/byterun/caml/sys.h index 5eb18fc0e5..5eb18fc0e5 100644 --- a/byterun/sys.h +++ b/byterun/caml/sys.h diff --git a/byterun/ui.h b/byterun/caml/ui.h index 2958465038..2958465038 100644 --- a/byterun/ui.h +++ b/byterun/caml/ui.h diff --git a/byterun/weak.h b/byterun/caml/weak.h index 0cf4b8b2b4..0cf4b8b2b4 100644 --- a/byterun/weak.h +++ b/byterun/caml/weak.h diff --git a/byterun/compact.c b/byterun/compact.c index 0afbd9dc4f..77b9479f53 100644 --- a/byterun/compact.c +++ b/byterun/compact.c @@ -13,16 +13,17 @@ #include <string.h> -#include "config.h" -#include "finalise.h" -#include "freelist.h" -#include "gc.h" -#include "gc_ctrl.h" -#include "major_gc.h" -#include "memory.h" -#include "mlvalues.h" -#include "roots.h" -#include "weak.h" +#include "caml/address_class.h" +#include "caml/config.h" +#include "caml/finalise.h" +#include "caml/freelist.h" +#include "caml/gc.h" +#include "caml/gc_ctrl.h" +#include "caml/major_gc.h" +#include "caml/memory.h" +#include "caml/mlvalues.h" +#include "caml/roots.h" +#include "caml/weak.h" extern uintnat caml_percent_free; /* major_gc.c */ extern void caml_shrink_heap (char *); /* memory.c */ @@ -58,7 +59,7 @@ static void invert_pointer_at (word *p) /* Use Ecolor (q) == 0 instead of Is_block (q) because q could be an inverted pointer for an infix header (with Ecolor == 2). */ - if (Ecolor (q) == 0 && (Classify_addr (q) & In_heap)){ + if (Ecolor (q) == 0 && Is_in_heap (q)){ switch (Ecolor (Hd_val (q))){ case 0: case 3: /* Pointer or header: insert in inverted list. */ @@ -122,8 +123,8 @@ static void init_compact_allocate (void) compact_fl = caml_heap_start; } +/* [size] is a number of bytes and includes the header size */ static char *compact_allocate (mlsize_t size) - /* in bytes, including header */ { char *chunk, *adr; @@ -396,7 +397,7 @@ uintnat caml_percent_max; /* used in gc_ctrl.c and memory.c */ void caml_compact_heap (void) { - uintnat target_words, target_size, live; + uintnat target_wsz, live; do_compaction (); /* Compaction may fail to shrink the heap to a reasonable size @@ -413,28 +414,28 @@ void caml_compact_heap (void) See PR#5389 */ /* We compute: - freewords = caml_fl_cur_size (exact) + freewords = caml_fl_cur_wsz (exact) heapwords = Wsize_bsize (caml_heap_size) (exact) live = heapwords - freewords wanted = caml_percent_free * (live / 100 + 1) (same as in do_compaction) - target_words = live + wanted + target_wsz = live + wanted We add one page to make sure a small difference in counting sizes won't make [do_compaction] keep the second block (and break all sorts of invariants). - We recompact if target_size < heap_size / 2 + We recompact if target_wsz < heap_size / 2 */ - live = Wsize_bsize (caml_stat_heap_size) - caml_fl_cur_size; - target_words = live + caml_percent_free * (live / 100 + 1) + live = caml_stat_heap_wsz - caml_fl_cur_wsz; + target_wsz = live + caml_percent_free * (live / 100 + 1) + Wsize_bsize (Page_size); - target_size = caml_round_heap_chunk_size (Bsize_wsize (target_words)); - if (target_size < caml_stat_heap_size / 2){ + target_wsz = caml_round_heap_chunk_wsz (target_wsz); + if (target_wsz < caml_stat_heap_wsz / 2){ char *chunk; - caml_gc_message (0x10, "Recompacting heap (target=%luk)\n", - target_size / 1024); + caml_gc_message (0x10, "Recompacting heap (target=%luk words)\n", + target_wsz / 1024); - chunk = caml_alloc_for_heap (target_size); + chunk = caml_alloc_for_heap (Bsize_wsize (target_wsz)); if (chunk == NULL) return; /* PR#5757: we need to make the new blocks blue, or they won't be recognized as free by the recompaction. */ @@ -447,24 +448,24 @@ void caml_compact_heap (void) Chunk_next (chunk) = caml_heap_start; caml_heap_start = chunk; ++ caml_stat_heap_chunks; - caml_stat_heap_size += Chunk_size (chunk); - if (caml_stat_heap_size > caml_stat_top_heap_size){ - caml_stat_top_heap_size = caml_stat_heap_size; + caml_stat_heap_wsz += Wsize_bsize (Chunk_size (chunk)); + if (caml_stat_heap_wsz > caml_stat_top_heap_wsz){ + caml_stat_top_heap_wsz = caml_stat_heap_wsz; } do_compaction (); Assert (caml_stat_heap_chunks == 1); Assert (Chunk_next (caml_heap_start) == NULL); - Assert (caml_stat_heap_size == Chunk_size (chunk)); + Assert (caml_stat_heap_wsz == Wsize_bsize (Chunk_size (chunk))); } } void caml_compact_heap_maybe (void) { - /* Estimated free words in the heap: - FW = fl_size_at_change + 3 * (caml_fl_cur_size - - caml_fl_size_at_phase_change) - FW = 3 * caml_fl_cur_size - 2 * caml_fl_size_at_phase_change - Estimated live words: LW = caml_stat_heap_size - FW + /* Estimated free+garbage words in the heap: + FW = fl_size_at_phase_change + 3 * (caml_fl_cur_wsz + - caml_fl_wsz_at_phase_change) + FW = 3 * caml_fl_cur_wsz - 2 * caml_fl_wsz_at_phase_change + Estimated live words: LW = caml_stat_heap_wsz - FW Estimated free percentage: FP = 100 * FW / LW We compact the heap if FP > caml_percent_max */ @@ -472,19 +473,20 @@ void caml_compact_heap_maybe (void) Assert (caml_gc_phase == Phase_idle); if (caml_percent_max >= 1000000) return; if (caml_stat_major_collections < 3) return; + if (caml_stat_heap_wsz <= 2 * caml_round_heap_chunk_wsz (0)) return; - fw = 3.0 * caml_fl_cur_size - 2.0 * caml_fl_size_at_phase_change; - if (fw < 0) fw = caml_fl_cur_size; + fw = 3.0 * caml_fl_cur_wsz - 2.0 * caml_fl_wsz_at_phase_change; + if (fw < 0) fw = caml_fl_cur_wsz; - if (fw >= Wsize_bsize (caml_stat_heap_size)){ + if (fw >= caml_stat_heap_wsz){ fp = 1000000.0; }else{ - fp = 100.0 * fw / (Wsize_bsize (caml_stat_heap_size) - fw); + fp = 100.0 * fw / (caml_stat_heap_wsz - fw); if (fp > 1000000.0) fp = 1000000.0; } caml_gc_message (0x200, "FL size at phase change = %" - ARCH_INTNAT_PRINTF_FORMAT "u\n", - (uintnat) caml_fl_size_at_phase_change); + ARCH_INTNAT_PRINTF_FORMAT "u words\n", + (uintnat) caml_fl_wsz_at_phase_change); caml_gc_message (0x200, "Estimated overhead = %" ARCH_INTNAT_PRINTF_FORMAT "u%%\n", (uintnat) fp); @@ -493,8 +495,8 @@ void caml_compact_heap_maybe (void) caml_finish_major_cycle (); /* We just did a complete GC, so we can measure the overhead exactly. */ - fw = caml_fl_cur_size; - fp = 100.0 * fw / (Wsize_bsize (caml_stat_heap_size) - fw); + fw = caml_fl_cur_wsz; + fp = 100.0 * fw / (caml_stat_heap_wsz - fw); caml_gc_message (0x200, "Measured overhead: %" ARCH_INTNAT_PRINTF_FORMAT "u%%\n", (uintnat) fp); diff --git a/byterun/compare.c b/byterun/compare.c index 6593ed9a82..d2a741b3da 100644 --- a/byterun/compare.c +++ b/byterun/compare.c @@ -13,11 +13,11 @@ #include <string.h> #include <stdlib.h> -#include "custom.h" -#include "fail.h" -#include "memory.h" -#include "misc.h" -#include "mlvalues.h" +#include "caml/custom.h" +#include "caml/fail.h" +#include "caml/memory.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" /* Structural comparison on trees. */ @@ -205,11 +205,11 @@ static intnat compare_val(value v1, value v2, int total) } case Abstract_tag: compare_free_stack(); - caml_invalid_argument("equal: abstract value"); + caml_invalid_argument("compare: abstract value"); case Closure_tag: case Infix_tag: compare_free_stack(); - caml_invalid_argument("equal: functional value"); + caml_invalid_argument("compare: functional value"); case Object_tag: { intnat oid1 = Oid_val(v1); intnat oid2 = Oid_val(v2); @@ -227,7 +227,7 @@ static intnat compare_val(value v1, value v2, int total) } if (compare == NULL) { compare_free_stack(); - caml_invalid_argument("equal: abstract value"); + caml_invalid_argument("compare: abstract value"); } caml_compare_unordered = 0; res = compare(v1, v2); diff --git a/byterun/custom.c b/byterun/custom.c index e4f9eaf573..ec304eaf04 100644 --- a/byterun/custom.c +++ b/byterun/custom.c @@ -13,12 +13,13 @@ #include <string.h> -#include "alloc.h" -#include "custom.h" -#include "fail.h" -#include "memory.h" -#include "mlvalues.h" +#include "caml/alloc.h" +#include "caml/custom.h" +#include "caml/fail.h" +#include "caml/memory.h" +#include "caml/mlvalues.h" +/* [size] is a number of bytes */ CAMLexport value caml_alloc_custom(struct custom_operations * ops, uintnat size, mlsize_t mem, diff --git a/byterun/debugger.c b/byterun/debugger.c index 6024ed92fe..41a64b1c4e 100644 --- a/byterun/debugger.c +++ b/byterun/debugger.c @@ -19,10 +19,10 @@ #include <string.h> -#include "alloc.h" -#include "config.h" -#include "debugger.h" -#include "misc.h" +#include "caml/alloc.h" +#include "caml/config.h" +#include "caml/debugger.h" +#include "caml/misc.h" int caml_debugger_in_use = 0; uintnat caml_event_count; @@ -64,14 +64,14 @@ void caml_debugger_cleanup_fork(void) #include <process.h> #endif -#include "fail.h" -#include "fix_code.h" -#include "instruct.h" -#include "intext.h" -#include "io.h" -#include "mlvalues.h" -#include "stacks.h" -#include "sys.h" +#include "caml/fail.h" +#include "caml/fix_code.h" +#include "caml/instruct.h" +#include "caml/intext.h" +#include "caml/io.h" +#include "caml/mlvalues.h" +#include "caml/stacks.h" +#include "caml/sys.h" static int sock_domain; /* Socket domain for the debugger */ static union { /* Socket address for the debugger */ diff --git a/byterun/dynlink.c b/byterun/dynlink.c index 8b4498b9d2..1f822a9fb1 100644 --- a/byterun/dynlink.c +++ b/byterun/dynlink.c @@ -18,18 +18,19 @@ #include <string.h> #include <fcntl.h> #include <sys/stat.h> -#include "config.h" +#include "caml/config.h" #ifdef HAS_UNISTD #include <unistd.h> #endif -#include "alloc.h" -#include "dynlink.h" -#include "fail.h" -#include "mlvalues.h" -#include "memory.h" -#include "misc.h" -#include "osdeps.h" -#include "prims.h" +#include "caml/alloc.h" +#include "caml/dynlink.h" +#include "caml/fail.h" +#include "caml/mlvalues.h" +#include "caml/memory.h" +#include "caml/misc.h" +#include "caml/osdeps.h" +#include "caml/prims.h" +#include "caml/signals.h" #ifndef NATIVE_CODE @@ -119,7 +120,9 @@ static void open_shared_lib(char * name) realname = caml_search_dll_in_path(&caml_shared_libs_path, name); caml_gc_message(0x100, "Loading shared library %s\n", (uintnat) realname); + caml_enter_blocking_section(); handle = caml_dlopen(realname, 1, 1); + caml_leave_blocking_section(); if (handle == NULL) caml_fatal_error_arg2("Fatal error: cannot load shared library %s\n", name, "Reason: %s\n", caml_dlerror()); @@ -189,7 +192,7 @@ void caml_build_primitive_table_builtin(void) caml_ext_table_add(&caml_prim_name_table, strdup(caml_names_of_builtin_cprim[i])); #endif -} + } } #endif /* NATIVE_CODE */ @@ -202,10 +205,15 @@ CAMLprim value caml_dynlink_open_lib(value mode, value filename) { void * handle; value result; + char * p; caml_gc_message(0x100, "Opening shared library %s\n", (uintnat) String_val(filename)); - handle = caml_dlopen(String_val(filename), Int_val(mode), 1); + p = caml_strdup(String_val(filename)); + caml_enter_blocking_section(); + handle = caml_dlopen(p, Int_val(mode), 1); + caml_leave_blocking_section(); + caml_stat_free(p); if (handle == NULL) caml_failwith(caml_dlerror()); result = caml_alloc_small(1, Abstract_tag); Handle_val(result) = handle; diff --git a/byterun/extern.c b/byterun/extern.c index f1ebddef37..d6e1a6a682 100644 --- a/byterun/extern.c +++ b/byterun/extern.c @@ -13,20 +13,20 @@ /* Structured output */ -/* The interface of this file is "intext.h" */ +/* The interface of this file is "caml/intext.h" */ #include <string.h> -#include "alloc.h" -#include "custom.h" -#include "fail.h" -#include "gc.h" -#include "intext.h" -#include "io.h" -#include "md5.h" -#include "memory.h" -#include "misc.h" -#include "mlvalues.h" -#include "reverse.h" +#include "caml/alloc.h" +#include "caml/custom.h" +#include "caml/fail.h" +#include "caml/gc.h" +#include "caml/intext.h" +#include "caml/io.h" +#include "caml/md5.h" +#include "caml/memory.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" +#include "caml/reverse.h" static uintnat obj_counter; /* Number of objects emitted so far */ static uintnat size_32; /* Size in words of 32-bit block for struct. */ @@ -75,10 +75,10 @@ static struct extern_item * extern_stack_limit = extern_stack_init /* Forward declarations */ -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; +Noreturn 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); static struct code_fragment * extern_find_code(char *addr); static void extern_replay_trail(void); static void free_extern_output(void); @@ -489,8 +489,8 @@ static void extern_rec(value v) case Custom_tag: { uintnat sz_32, sz_64; char * ident = Custom_ops_val(v)->identifier; - void (*serialize)(value v, uintnat * wsize_32, - uintnat * wsize_64) + void (*serialize)(value v, uintnat * bsize_32, + uintnat * bsize_64) = Custom_ops_val(v)->serialize; if (serialize == NULL) extern_invalid_argument("output_value: abstract value (Custom)"); diff --git a/byterun/fail.c b/byterun/fail.c index 148e47a994..7943f9aee1 100644 --- a/byterun/fail.c +++ b/byterun/fail.c @@ -15,16 +15,16 @@ #include <stdio.h> #include <stdlib.h> -#include "alloc.h" -#include "fail.h" -#include "io.h" -#include "gc.h" -#include "memory.h" -#include "misc.h" -#include "mlvalues.h" -#include "printexc.h" -#include "signals.h" -#include "stacks.h" +#include "caml/alloc.h" +#include "caml/fail.h" +#include "caml/io.h" +#include "caml/gc.h" +#include "caml/memory.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" +#include "caml/printexc.h" +#include "caml/signals.h" +#include "caml/stacks.h" CAMLexport struct longjmp_buffer * caml_external_raise = NULL; value caml_exn_bucket; diff --git a/byterun/finalise.c b/byterun/finalise.c index 15b7a753e0..b0a2ade59b 100644 --- a/byterun/finalise.c +++ b/byterun/finalise.c @@ -13,11 +13,11 @@ /* Handling of finalised values. */ -#include "callback.h" -#include "fail.h" -#include "mlvalues.h" -#include "roots.h" -#include "signals.h" +#include "caml/callback.h" +#include "caml/fail.h" +#include "caml/mlvalues.h" +#include "caml/roots.h" +#include "caml/signals.h" struct final { value fun; @@ -41,6 +41,7 @@ struct to_do { static struct to_do *to_do_hd = NULL; static struct to_do *to_do_tl = NULL; +/* [size] is a number of elements for the [to_do.item] array */ static void alloc_to_do (int size) { struct to_do *result = malloc (sizeof (struct to_do) @@ -209,7 +210,10 @@ void caml_final_empty_young (void) /* Put (f,v) in the recent set. */ CAMLprim value caml_final_register (value f, value v) { - if (!(Is_block (v) && Is_in_heap_or_young(v))) { + if (!Is_block (v) + || !Is_in_heap_or_young(v) + || Tag_val (v) == Lazy_tag + || Tag_val (v) == Double_tag) { caml_invalid_argument ("Gc.finalise"); } Assert (old <= young); diff --git a/byterun/fix_code.c b/byterun/fix_code.c index 4fa027502a..e605290615 100644 --- a/byterun/fix_code.c +++ b/byterun/fix_code.c @@ -13,21 +13,21 @@ /* Handling of blocks of bytecode (endianness switch, threading). */ -#include "config.h" +#include "caml/config.h" #ifdef HAS_UNISTD #include <unistd.h> #endif -#include "debugger.h" -#include "fix_code.h" -#include "instruct.h" -#include "intext.h" -#include "md5.h" -#include "memory.h" -#include "misc.h" -#include "mlvalues.h" -#include "reverse.h" +#include "caml/debugger.h" +#include "caml/fix_code.h" +#include "caml/instruct.h" +#include "caml/intext.h" +#include "caml/md5.h" +#include "caml/memory.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" +#include "caml/reverse.h" code_t caml_start_code; asize_t caml_code_size; @@ -95,33 +95,44 @@ void caml_fixup_endianness(code_t code, asize_t len) char ** caml_instr_table; char * caml_instr_base; -void caml_thread_code (code_t code, asize_t len) +static int* opcode_nargs = NULL; +int* caml_init_opcode_nargs() { - code_t p; - int l [FIRST_UNIMPLEMENTED_OP]; - int i; + if( opcode_nargs == NULL ){ + int* l = (int*)caml_stat_alloc(sizeof(int) * FIRST_UNIMPLEMENTED_OP); + int i; - for (i = 0; i < FIRST_UNIMPLEMENTED_OP; i++) { - l [i] = 0; + for (i = 0; i < FIRST_UNIMPLEMENTED_OP; i++) { + l [i] = 0; + } + /* Instructions with one operand */ + l[PUSHACC] = l[ACC] = l[POP] = l[ASSIGN] = + l[PUSHENVACC] = l[ENVACC] = l[PUSH_RETADDR] = l[APPLY] = + l[APPTERM1] = l[APPTERM2] = l[APPTERM3] = l[RETURN] = + l[GRAB] = l[PUSHGETGLOBAL] = l[GETGLOBAL] = l[SETGLOBAL] = + l[PUSHATOM] = l[ATOM] = l[MAKEBLOCK1] = l[MAKEBLOCK2] = + l[MAKEBLOCK3] = l[MAKEFLOATBLOCK] = l[GETFIELD] = + l[GETFLOATFIELD] = l[SETFIELD] = l[SETFLOATFIELD] = + l[BRANCH] = l[BRANCHIF] = l[BRANCHIFNOT] = l[PUSHTRAP] = + l[C_CALL1] = l[C_CALL2] = l[C_CALL3] = l[C_CALL4] = l[C_CALL5] = + l[CONSTINT] = l[PUSHCONSTINT] = l[OFFSETINT] = + l[OFFSETREF] = l[OFFSETCLOSURE] = l[PUSHOFFSETCLOSURE] = 1; + + /* Instructions with two operands */ + l[APPTERM] = l[CLOSURE] = l[PUSHGETGLOBALFIELD] = + l[GETGLOBALFIELD] = l[MAKEBLOCK] = l[C_CALLN] = + l[BEQ] = l[BNEQ] = l[BLTINT] = l[BLEINT] = l[BGTINT] = l[BGEINT] = + l[BULTINT] = l[BUGEINT] = l[GETPUBMET] = 2; + + opcode_nargs = l; } - /* Instructions with one operand */ - l[PUSHACC] = l[ACC] = l[POP] = l[ASSIGN] = - l[PUSHENVACC] = l[ENVACC] = l[PUSH_RETADDR] = l[APPLY] = - l[APPTERM1] = l[APPTERM2] = l[APPTERM3] = l[RETURN] = - l[GRAB] = l[PUSHGETGLOBAL] = l[GETGLOBAL] = l[SETGLOBAL] = - l[PUSHATOM] = l[ATOM] = l[MAKEBLOCK1] = l[MAKEBLOCK2] = - l[MAKEBLOCK3] = l[MAKEFLOATBLOCK] = l[GETFIELD] = - l[GETFLOATFIELD] = l[SETFIELD] = l[SETFLOATFIELD] = - l[BRANCH] = l[BRANCHIF] = l[BRANCHIFNOT] = l[PUSHTRAP] = - l[C_CALL1] = l[C_CALL2] = l[C_CALL3] = l[C_CALL4] = l[C_CALL5] = - l[CONSTINT] = l[PUSHCONSTINT] = l[OFFSETINT] = - l[OFFSETREF] = l[OFFSETCLOSURE] = l[PUSHOFFSETCLOSURE] = 1; - - /* Instructions with two operands */ - l[APPTERM] = l[CLOSURE] = l[PUSHGETGLOBALFIELD] = - l[GETGLOBALFIELD] = l[MAKEBLOCK] = l[C_CALLN] = - l[BEQ] = l[BNEQ] = l[BLTINT] = l[BLEINT] = l[BGTINT] = l[BGEINT] = - l[BULTINT] = l[BUGEINT] = l[GETPUBMET] = 2; + return opcode_nargs; +} + +void caml_thread_code (code_t code, asize_t len) +{ + code_t p; + int* l = caml_init_opcode_nargs(); len /= sizeof(opcode_t); for (p = code; p < code + len; /*nothing*/) { opcode_t instr = *p; @@ -149,6 +160,13 @@ void caml_thread_code (code_t code, asize_t len) Assert(p == code + len); } +#else + +int* caml_init_opcode_nargs() +{ + return NULL; +} + #endif /* THREADED_CODE */ void caml_set_instruction(code_t pos, opcode_t instr) diff --git a/byterun/floats.c b/byterun/floats.c index d8fdd054bf..ce18c8fb7c 100644 --- a/byterun/floats.c +++ b/byterun/floats.c @@ -11,26 +11,30 @@ /* */ /***********************************************************************/ -/* The interface of this file is in "mlvalues.h" and "alloc.h" */ +/* The interface of this file is in "caml/mlvalues.h" and "caml/alloc.h" */ #include <math.h> #include <stdio.h> #include <stdlib.h> #include <string.h> -#include "alloc.h" -#include "fail.h" -#include "memory.h" -#include "mlvalues.h" -#include "misc.h" -#include "reverse.h" -#include "stacks.h" +#include "caml/alloc.h" +#include "caml/fail.h" +#include "caml/memory.h" +#include "caml/mlvalues.h" +#include "caml/misc.h" +#include "caml/reverse.h" +#include "caml/stacks.h" #ifdef _MSC_VER #include <float.h> +#ifndef isnan #define isnan _isnan +#endif +#ifndef isfinite #define isfinite _finite #endif +#endif #ifdef ARCH_ALIGN_DOUBLE @@ -150,6 +154,7 @@ CAMLprim value caml_float_of_string(value vs) error: if (buf != parse_buffer) caml_stat_free(buf); caml_failwith("float_of_string"); + return Val_unit; /* not reached */ } CAMLprim value caml_int_of_float(value f) @@ -452,7 +457,8 @@ enum { FP_normal, FP_subnormal, FP_zero, FP_infinite, FP_nan }; CAMLprim value caml_classify_float(value vd) { /* Cygwin 1.3 has problems with fpclassify (PR#1293), so don't use it */ -#if defined(fpclassify) && !defined(__CYGWIN32__) && !defined(__MINGW32__) + /* FIXME Cygwin 1.3 is ancient! Revisit this decision. */ +#if defined(fpclassify) && !defined(__CYGWIN__) && !defined(__MINGW32__) switch (fpclassify(Double_val(vd))) { case FP_NAN: return Val_int(FP_nan); diff --git a/byterun/freelist.c b/byterun/freelist.c index 1bbbc25f6a..3371b9a182 100644 --- a/byterun/freelist.c +++ b/byterun/freelist.c @@ -18,48 +18,48 @@ #include <string.h> -#include "config.h" -#include "freelist.h" -#include "gc.h" -#include "gc_ctrl.h" -#include "memory.h" -#include "major_gc.h" -#include "misc.h" -#include "mlvalues.h" +#include "caml/config.h" +#include "caml/freelist.h" +#include "caml/gc.h" +#include "caml/gc_ctrl.h" +#include "caml/memory.h" +#include "caml/major_gc.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" /* The free-list is kept sorted by increasing addresses. This makes the merging of adjacent free blocks possible. (See [caml_fl_merge_block].) */ -typedef struct { - char *next_bp; /* Pointer to the first byte of the next block. */ -} block; +/* A free list block is a [value] (integer representing a pointer to the + first word after the block's header). The end of the list is NULL. */ +#define Val_NULL ((value) NULL) /* The sentinel can be located anywhere in memory, but it must not be adjacent to any heap object. */ static struct { value filler1; /* Make sure the sentinel is never adjacent to any block. */ header_t h; - value first_bp; + value first_field; value filler2; /* Make sure the sentinel is never adjacent to any block. */ -} sentinel = {0, Make_header (0, 0, Caml_blue), 0, 0}; +} sentinel = {0, Make_header (0, 0, Caml_blue), Val_NULL, 0}; -#define Fl_head ((char *) (&(sentinel.first_bp))) -static char *fl_prev = Fl_head; /* Current allocation pointer. */ -static char *fl_last = NULL; /* Last block in the list. Only valid - just after [caml_fl_allocate] returns NULL. */ -char *caml_fl_merge = Fl_head; /* Current insertion pointer. Managed +#define Fl_head (Val_bp (&(sentinel.first_field))) +static value fl_prev = Fl_head; /* Current allocation pointer. */ +static value fl_last = Val_NULL; /* Last block in the list. Only valid + just after [caml_fl_allocate] returns NULL. */ +value caml_fl_merge = Fl_head; /* Current insertion pointer. Managed jointly with [sweep_slice]. */ -asize_t caml_fl_cur_size = 0; /* Number of words in the free list, +asize_t caml_fl_cur_wsz = 0; /* Number of words in the free list, including headers but not fragments. */ #define FLP_MAX 1000 -static char *flp [FLP_MAX]; +static value flp [FLP_MAX]; static int flp_size = 0; -static char *beyond = NULL; +static value beyond = Val_NULL; -#define Next(b) (((block *) (b))->next_bp) +#define Next(b) (Field (b, 0)) #define Policy_next_fit 0 #define Policy_first_fit 1 @@ -69,14 +69,14 @@ uintnat caml_allocation_policy = Policy_next_fit; #ifdef DEBUG static void fl_check (void) { - char *cur, *prev; + value cur, prev; int prev_found = 0, flp_found = 0, merge_found = 0; uintnat size_found = 0; int sz = 0; prev = Fl_head; cur = Next (prev); - while (cur != NULL){ + while (cur != Val_NULL){ size_found += Whsize_bp (cur); Assert (Is_in_heap (cur)); if (cur == fl_prev) prev_found = 1; @@ -86,7 +86,7 @@ static void fl_check (void) Assert (Next (flp[flp_found]) == cur); ++ flp_found; }else{ - Assert (beyond == NULL || cur >= Next (beyond)); + Assert (beyond == Val_NULL || cur >= Next (beyond)); } } if (cur == caml_fl_merge) merge_found = 1; @@ -96,36 +96,36 @@ static void fl_check (void) if (policy == Policy_next_fit) Assert (prev_found || fl_prev == Fl_head); if (policy == Policy_first_fit) Assert (flp_found == flp_size); Assert (merge_found || caml_fl_merge == Fl_head); - Assert (size_found == caml_fl_cur_size); + Assert (size_found == caml_fl_cur_wsz); } #endif /* [allocate_block] is called by [caml_fl_allocate]. Given a suitable free - block and the desired size, it allocates a new block from the free + block and the requested size, it allocates a new block from the free block. There are three cases: - 0. The free block has the desired size. Detach the block from the + 0. The free block has the requested size. Detach the block from the free-list and return it. - 1. The free block is 1 word longer than the desired size. Detach + 1. The free block is 1 word longer than the requested size. Detach the block from the free list. The remaining word cannot be linked: turn it into an empty block (header only), and return the rest. - 2. The free block is big enough. Split it in two and return the right + 2. The free block is large enough. Split it in two and return the right block. In all cases, the allocated block is right-justified in the free block: - it is located in the high-address words of the free block. This way, + it is located in the high-address words of the free block, so that the linking of the free-list does not change in case 2. */ -static char *allocate_block (mlsize_t wh_sz, int flpi, char *prev, char *cur) +static header_t *allocate_block (mlsize_t wh_sz, int flpi, value prev, value cur) { header_t h = Hd_bp (cur); Assert (Whsize_hd (h) >= wh_sz); if (Wosize_hd (h) < wh_sz + 1){ /* Cases 0 and 1. */ - caml_fl_cur_size -= Whsize_hd (h); + caml_fl_cur_wsz -= Whsize_hd (h); Next (prev) = Next (cur); - Assert (Is_in_heap (Next (prev)) || Next (prev) == NULL); + Assert (Is_in_heap (Next (prev)) || Next (prev) == Val_NULL); if (caml_fl_merge == cur) caml_fl_merge = prev; #ifdef DEBUG - fl_last = NULL; + fl_last = Val_NULL; #endif /* In case 1, the following creates the empty block correctly. In case 0, it gives an invalid header to the block. The function @@ -135,36 +135,37 @@ static char *allocate_block (mlsize_t wh_sz, int flpi, char *prev, char *cur) if (flpi + 1 < flp_size && flp[flpi + 1] == cur){ flp[flpi + 1] = prev; }else if (flpi == flp_size - 1){ - beyond = (prev == Fl_head) ? NULL : prev; + beyond = (prev == Fl_head) ? Val_NULL : prev; -- flp_size; } } }else{ /* Case 2. */ - caml_fl_cur_size -= wh_sz; + caml_fl_cur_wsz -= wh_sz; Hd_op (cur) = Make_header (Wosize_hd (h) - wh_sz, 0, Caml_blue); } if (policy == Policy_next_fit) fl_prev = prev; - return cur + Bosize_hd (h) - Bsize_wsize (wh_sz); + return (header_t *) &Field (cur, Wosize_hd (h) - wh_sz); } /* [caml_fl_allocate] does not set the header of the newly allocated block. The calling function must do it before any GC function gets called. [caml_fl_allocate] returns a head pointer. */ -char *caml_fl_allocate (mlsize_t wo_sz) +header_t *caml_fl_allocate (mlsize_t wo_sz) { - char *cur = NULL, *prev, *result; + value cur = Val_NULL, prev; + header_t *result; int i; mlsize_t sz, prevsz; Assert (sizeof (char *) == sizeof (value)); Assert (wo_sz >= 1); switch (policy){ case Policy_next_fit: - Assert (fl_prev != NULL); + Assert (fl_prev != Val_NULL); /* Search from [fl_prev] to the end of the list. */ prev = fl_prev; cur = Next (prev); - while (cur != NULL){ Assert (Is_in_heap (cur)); + while (cur != Val_NULL){ Assert (Is_in_heap (cur)); if (Wosize_bp (cur) >= wo_sz){ return allocate_block (Whsize_wosize (wo_sz), 0, prev, cur); } @@ -206,13 +207,13 @@ char *caml_fl_allocate (mlsize_t wo_sz) }else{ prev = Next (flp[flp_size - 1]); prevsz = Wosize_bp (prev); - if (beyond != NULL) prev = beyond; + if (beyond != Val_NULL) prev = beyond; } while (flp_size < FLP_MAX){ cur = Next (prev); - if (cur == NULL){ + if (cur == Val_NULL){ fl_last = prev; - beyond = (prev == Fl_head) ? NULL : prev; + beyond = (prev == Fl_head) ? Val_NULL : prev; return NULL; }else{ sz = Wosize_bp (cur); @@ -242,7 +243,7 @@ char *caml_fl_allocate (mlsize_t wo_sz) #if FREELIST_DEBUG fprintf (stderr, "FLP: table is full -- slow first-fit\n"); #endif - if (beyond != NULL){ + if (beyond != Val_NULL){ prev = beyond; }else{ prev = flp[flp_size - 1]; @@ -250,7 +251,7 @@ char *caml_fl_allocate (mlsize_t wo_sz) prevsz = Wosize_bp (Next (flp[FLP_MAX-1])); Assert (prevsz < wo_sz); cur = Next (prev); - while (cur != NULL){ + while (cur != Val_NULL){ Assert (Is_in_heap (cur)); sz = Wosize_bp (cur); if (sz < prevsz){ @@ -278,10 +279,10 @@ char *caml_fl_allocate (mlsize_t wo_sz) beyond = Next (flp[i]); -- flp_size; }else{ - beyond = NULL; + beyond = Val_NULL; } }else{ - char *buf [FLP_MAX]; + value buf [FLP_MAX]; int j = 0; mlsize_t oldsz = sz; @@ -304,19 +305,19 @@ char *caml_fl_allocate (mlsize_t wo_sz) #endif if (FLP_MAX >= flp_size + j - 1){ if (j != 1){ - memmove (&flp[i+j], &flp[i+1], sizeof (block *) * (flp_size-i-1)); + memmove (&flp[i+j], &flp[i+1], sizeof (value) * (flp_size-i-1)); } - if (j > 0) memmove (&flp[i], &buf[0], sizeof (block *) * j); + if (j > 0) memmove (&flp[i], &buf[0], sizeof (value) * j); flp_size += j - 1; }else{ if (FLP_MAX > i + j){ if (j != 1){ - memmove (&flp[i+j], &flp[i+1], sizeof (block *) * (FLP_MAX-i-j)); + memmove (&flp[i+j], &flp[i+1], sizeof (value) * (FLP_MAX-i-j)); } - if (j > 0) memmove (&flp[i], &buf[0], sizeof (block *) * j); + if (j > 0) memmove (&flp[i], &buf[0], sizeof (value) * j); }else{ if (i != FLP_MAX){ - memmove (&flp[i], &buf[0], sizeof (block *) * (FLP_MAX - i)); + memmove (&flp[i], &buf[0], sizeof (value) * (FLP_MAX - i)); } } flp_size = FLP_MAX - 1; @@ -335,7 +336,13 @@ char *caml_fl_allocate (mlsize_t wo_sz) return NULL; /* NOT REACHED */ } -static char *last_fragment; +/* Location of the last fragment seen by the sweeping code. + This is a pointer to the first word after the fragment, which is + the header of the next block. + Note that [last_fragment] doesn't point to the fragment itself, + but to the block after it. +*/ +static header_t *last_fragment; void caml_fl_init_merge (void) { @@ -346,21 +353,22 @@ void caml_fl_init_merge (void) #endif } -static void truncate_flp (char *changed) +static void truncate_flp (value changed) { if (changed == Fl_head){ flp_size = 0; - beyond = NULL; + beyond = Val_NULL; }else{ - while (flp_size > 0 && Next (flp[flp_size - 1]) >= changed) -- flp_size; - if (beyond >= changed) beyond = NULL; + while (flp_size > 0 && Next (flp[flp_size - 1]) >= changed) + -- flp_size; + if (beyond >= changed) beyond = Val_NULL; } } /* This is called by caml_compact_heap. */ void caml_fl_reset (void) { - Next (Fl_head) = NULL; + Next (Fl_head) = Val_NULL; switch (policy){ case Policy_next_fit: fl_prev = Fl_head; @@ -372,19 +380,20 @@ void caml_fl_reset (void) Assert (0); break; } - caml_fl_cur_size = 0; + caml_fl_cur_wsz = 0; caml_fl_init_merge (); } /* [caml_fl_merge_block] returns the head pointer of the next block after [bp], because merging blocks may change the size of [bp]. */ -char *caml_fl_merge_block (char *bp) +header_t *caml_fl_merge_block (value bp) { - char *prev, *cur, *adj; - header_t hd = Hd_bp (bp); + value prev, cur; + header_t *adj; + header_t hd = Hd_val (bp); mlsize_t prev_wosz; - caml_fl_cur_size += Whsize_hd (hd); + caml_fl_cur_wsz += Whsize_hd (hd); #ifdef DEBUG caml_set_fields (bp, 0, Debug_free_major); @@ -394,62 +403,62 @@ char *caml_fl_merge_block (char *bp) /* The sweep code makes sure that this is the right place to insert this block: */ Assert (prev < bp || prev == Fl_head); - Assert (cur > bp || cur == NULL); + Assert (cur > bp || cur == Val_NULL); if (policy == Policy_first_fit) truncate_flp (prev); /* If [last_fragment] and [bp] are adjacent, merge them. */ if (last_fragment == Hp_bp (bp)){ - mlsize_t bp_whsz = Whsize_bp (bp); + mlsize_t bp_whsz = Whsize_val (bp); if (bp_whsz <= Max_wosize){ hd = Make_header (bp_whsz, 0, Caml_white); - bp = last_fragment; - Hd_bp (bp) = hd; - caml_fl_cur_size += Whsize_wosize (0); + bp = (value) last_fragment; + Hd_val (bp) = hd; + caml_fl_cur_wsz += Whsize_wosize (0); } } /* If [bp] and [cur] are adjacent, remove [cur] from the free-list and merge them. */ - adj = bp + Bosize_hd (hd); - if (adj == Hp_bp (cur)){ - char *next_cur = Next (cur); - mlsize_t cur_whsz = Whsize_bp (cur); + adj = (header_t *) &Field (bp, Wosize_hd (hd)); + if (adj == Hp_val (cur)){ + value next_cur = Next (cur); + mlsize_t cur_whsz = Whsize_val (cur); if (Wosize_hd (hd) + cur_whsz <= Max_wosize){ Next (prev) = next_cur; if (policy == Policy_next_fit && fl_prev == cur) fl_prev = prev; hd = Make_header (Wosize_hd (hd) + cur_whsz, 0, Caml_blue); - Hd_bp (bp) = hd; - adj = bp + Bosize_hd (hd); + Hd_val (bp) = hd; + adj = (header_t *) &Field (bp, Wosize_hd (hd)); #ifdef DEBUG - fl_last = NULL; - Next (cur) = (char *) Debug_free_major; - Hd_bp (cur) = Debug_free_major; + fl_last = Val_NULL; + Next (cur) = (value) Debug_free_major; + Hd_val (cur) = Debug_free_major; #endif cur = next_cur; } } /* If [prev] and [bp] are adjacent merge them, else insert [bp] into the free-list if it is big enough. */ - prev_wosz = Wosize_bp (prev); - if (prev + Bsize_wsize (prev_wosz) == Hp_bp (bp) + prev_wosz = Wosize_val (prev); + if ((header_t *) &Field (prev, prev_wosz) == Hp_val (bp) && prev_wosz + Whsize_hd (hd) < Max_wosize){ - Hd_bp (prev) = Make_header (prev_wosz + Whsize_hd (hd), 0,Caml_blue); + Hd_val (prev) = Make_header (prev_wosz + Whsize_hd (hd), 0,Caml_blue); #ifdef DEBUG - Hd_bp (bp) = Debug_free_major; + Hd_val (bp) = Debug_free_major; #endif Assert (caml_fl_merge == prev); }else if (Wosize_hd (hd) != 0){ - Hd_bp (bp) = Bluehd_hd (hd); + Hd_val (bp) = Bluehd_hd (hd); Next (bp) = cur; Next (prev) = bp; caml_fl_merge = bp; }else{ /* This is a fragment. Leave it in white but remember it for eventual merging with the next block. */ - last_fragment = bp; - caml_fl_cur_size -= Whsize_wosize (0); + last_fragment = (header_t *) bp; + caml_fl_cur_wsz -= Whsize_wosize (0); } return adj; } @@ -457,46 +466,46 @@ char *caml_fl_merge_block (char *bp) /* This is a heap extension. We have to insert it in the right place in the free-list. [caml_fl_add_blocks] can only be called right after a call to - [caml_fl_allocate] that returned NULL. + [caml_fl_allocate] that returned Val_NULL. Most of the heap extensions are expected to be at the end of the free list. (This depends on the implementation of [malloc].) [bp] must point to a list of blocks chained by their field 0, - terminated by NULL, and field 1 of the first block must point to + terminated by Val_NULL, and field 1 of the first block must point to the last block. */ -void caml_fl_add_blocks (char *bp) +void caml_fl_add_blocks (value bp) { - Assert (fl_last != NULL); - Assert (Next (fl_last) == NULL); - caml_fl_cur_size += Whsize_bp (bp); + Assert (fl_last != Val_NULL); + Assert (Next (fl_last) == Val_NULL); + caml_fl_cur_wsz += Whsize_bp (bp); if (bp > fl_last){ Next (fl_last) = bp; - if (fl_last == caml_fl_merge && bp < caml_gc_sweep_hp){ - caml_fl_merge = (char *) Field (bp, 1); + if (fl_last == caml_fl_merge && (char *) bp < caml_gc_sweep_hp){ + caml_fl_merge = Field (bp, 1); } if (policy == Policy_first_fit && flp_size < FLP_MAX){ flp [flp_size++] = fl_last; } }else{ - char *cur, *prev; + value cur, prev; prev = Fl_head; cur = Next (prev); - while (cur != NULL && cur < bp){ Assert (prev < bp || prev == Fl_head); + while (cur != Val_NULL && cur < bp){ Assert (prev < bp || prev == Fl_head); /* XXX TODO: extend flp on the fly */ prev = cur; cur = Next (prev); } Assert (prev < bp || prev == Fl_head); - Assert (cur > bp || cur == NULL); + Assert (cur > bp || cur == Val_NULL); Next (Field (bp, 1)) = cur; Next (prev) = bp; /* When inserting blocks between [caml_fl_merge] and [caml_gc_sweep_hp], we must advance [caml_fl_merge] to the new block, so that [caml_fl_merge] is always the last free-list block before [caml_gc_sweep_hp]. */ - if (prev == caml_fl_merge && bp < caml_gc_sweep_hp){ - caml_fl_merge = (char *) Field (bp, 1); + if (prev == caml_fl_merge && (char *) bp < caml_gc_sweep_hp){ + caml_fl_merge = Field (bp, 1); } if (policy == Policy_first_fit) truncate_flp (bp); } @@ -523,7 +532,7 @@ void caml_make_free_blocks (value *p, mlsize_t size, int do_merge, int color) sz = size; } *(header_t *)p = Make_header (Wosize_whsize (sz), 0, color); - if (do_merge) caml_fl_merge_block (Bp_hp (p)); + if (do_merge) caml_fl_merge_block (Val_hp (p)); size -= sz; p += sz; } @@ -538,7 +547,7 @@ void caml_set_allocation_policy (uintnat p) break; case Policy_first_fit: flp_size = 0; - beyond = NULL; + beyond = Val_NULL; policy = p; break; default: diff --git a/byterun/gc_ctrl.c b/byterun/gc_ctrl.c index 1ab099da9e..f560480fbd 100644 --- a/byterun/gc_ctrl.c +++ b/byterun/gc_ctrl.c @@ -11,21 +11,21 @@ /* */ /***********************************************************************/ -#include "alloc.h" -#include "compact.h" -#include "custom.h" -#include "finalise.h" -#include "freelist.h" -#include "gc.h" -#include "gc_ctrl.h" -#include "major_gc.h" -#include "minor_gc.h" -#include "misc.h" -#include "mlvalues.h" +#include "caml/alloc.h" +#include "caml/compact.h" +#include "caml/custom.h" +#include "caml/finalise.h" +#include "caml/freelist.h" +#include "caml/gc.h" +#include "caml/gc_ctrl.h" +#include "caml/major_gc.h" +#include "caml/minor_gc.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" #ifdef NATIVE_CODE #include "stack.h" #else -#include "stacks.h" +#include "caml/stacks.h" #endif #ifndef NATIVE_CODE @@ -38,8 +38,8 @@ double caml_stat_minor_words = 0.0, intnat caml_stat_minor_collections = 0, caml_stat_major_collections = 0, - caml_stat_heap_size = 0, /* bytes */ - caml_stat_top_heap_size = 0, /* bytes */ + caml_stat_heap_wsz = 0, + caml_stat_top_heap_wsz = 0, caml_stat_compactions = 0, caml_stat_heap_chunks = 0; @@ -48,7 +48,7 @@ extern uintnat caml_percent_free; /* see major_gc.c */ extern uintnat caml_percent_max; /* see compact.c */ extern uintnat caml_allocation_policy; /* see freelist.c */ -#define Next(hp) ((hp) + Bhsize_hp (hp)) +#define Next(hp) ((hp) + Whsize_hp (hp)) #ifdef DEBUG @@ -77,7 +77,7 @@ static void check_head (value v) } } -static void check_block (char *hp) +static void check_block (header_t *hp) { mlsize_t i; value v = Val_hp (hp); @@ -127,9 +127,9 @@ static value heap_stats (int returnstats) free_words = 0, free_blocks = 0, largest_free = 0, fragments = 0, heap_chunks = 0; char *chunk = caml_heap_start, *chunk_end; - char *cur_hp; + header_t *cur_hp; #ifdef DEBUG - char *prev_hp; + header_t *prev_hp; #endif header_t cur_hd; @@ -143,19 +143,19 @@ static value heap_stats (int returnstats) #ifdef DEBUG prev_hp = NULL; #endif - cur_hp = chunk; - while (cur_hp < chunk_end){ + cur_hp = (header_t *) chunk; + while (cur_hp < (header_t *) chunk_end){ cur_hd = Hd_hp (cur_hp); - Assert (Next (cur_hp) <= chunk_end); + Assert (Next (cur_hp) <= (header_t *) chunk_end); switch (Color_hd (cur_hd)){ case Caml_white: if (Wosize_hd (cur_hd) == 0){ ++ fragments; Assert (prev_hp == NULL || Color_hp (prev_hp) != Caml_blue - || cur_hp == caml_gc_sweep_hp); + || cur_hp == (header_t *) caml_gc_sweep_hp); }else{ - if (caml_gc_phase == Phase_sweep && cur_hp >= caml_gc_sweep_hp){ + if (caml_gc_phase == Phase_sweep && cur_hp >= (header_t *) caml_gc_sweep_hp){ ++ free_blocks; free_words += Whsize_hd (cur_hd); if (Whsize_hd (cur_hd) > largest_free){ @@ -201,27 +201,26 @@ static value heap_stats (int returnstats) prev_hp = cur_hp; #endif cur_hp = Next (cur_hp); - } Assert (cur_hp == chunk_end); + } Assert (cur_hp == (header_t *) chunk_end); chunk = Chunk_next (chunk); } Assert (heap_chunks == caml_stat_heap_chunks); - Assert (live_words + free_words + fragments - == Wsize_bsize (caml_stat_heap_size)); + Assert (live_words + free_words + fragments == caml_stat_heap_wsz); if (returnstats){ CAMLlocal1 (res); /* get a copy of these before allocating anything... */ double minwords = caml_stat_minor_words - + (double) Wsize_bsize (caml_young_end - caml_young_ptr); + + (double) (caml_young_end - caml_young_ptr); double prowords = caml_stat_promoted_words; double majwords = caml_stat_major_words + (double) caml_allocated_words; intnat mincoll = caml_stat_minor_collections; intnat majcoll = caml_stat_major_collections; - intnat heap_words = Wsize_bsize (caml_stat_heap_size); + intnat heap_words = caml_stat_heap_wsz; intnat cpct = caml_stat_compactions; - intnat top_heap_words = Wsize_bsize (caml_stat_top_heap_size); + intnat top_heap_words = caml_stat_top_heap_wsz; res = caml_alloc_tuple (16); Store_field (res, 0, caml_copy_double (minwords)); @@ -266,13 +265,13 @@ CAMLprim value caml_gc_quick_stat(value v) /* get a copy of these before allocating anything... */ double minwords = caml_stat_minor_words - + (double) Wsize_bsize (caml_young_end - caml_young_ptr); + + (double) (caml_young_end - caml_young_ptr); double prowords = caml_stat_promoted_words; double majwords = caml_stat_major_words + (double) caml_allocated_words; intnat mincoll = caml_stat_minor_collections; intnat majcoll = caml_stat_major_collections; - intnat heap_words = caml_stat_heap_size / sizeof (value); - intnat top_heap_words = caml_stat_top_heap_size / sizeof (value); + intnat heap_words = caml_stat_heap_wsz; + intnat top_heap_words = caml_stat_top_heap_wsz; intnat cpct = caml_stat_compactions; intnat heap_chunks = caml_stat_heap_chunks; @@ -303,7 +302,7 @@ CAMLprim value caml_gc_counters(value v) /* get a copy of these before allocating anything... */ double minwords = caml_stat_minor_words - + (double) Wsize_bsize (caml_young_end - caml_young_ptr); + + (double) (caml_young_end - caml_young_ptr); double prowords = caml_stat_promoted_words; double majwords = caml_stat_major_words + (double) caml_allocated_words; @@ -320,7 +319,7 @@ CAMLprim value caml_gc_get(value v) CAMLlocal1 (res); res = caml_alloc_tuple (7); - Store_field (res, 0, Val_long (Wsize_bsize (caml_minor_heap_size))); /* s */ + Store_field (res, 0, Val_long (caml_minor_heap_wsz)); /* s */ 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 */ @@ -357,7 +356,7 @@ CAMLprim value caml_gc_set(value v) { uintnat newpf, newpm; asize_t newheapincr; - asize_t newminsize; + asize_t newminwsz; uintnat oldpolicy; caml_verb_gc = Long_val (Field (v, 3)); @@ -398,11 +397,11 @@ CAMLprim value caml_gc_set(value v) /* Minor heap size comes last because it will trigger a minor collection (thus invalidating [v]) and it can raise [Out_of_memory]. */ - newminsize = Bsize_wsize (norm_minsize (Long_val (Field (v, 0)))); - if (newminsize != caml_minor_heap_size){ - caml_gc_message (0x20, "New minor heap size: %luk bytes\n", - newminsize/1024); - caml_set_minor_heap_size (newminsize); + newminwsz = norm_minsize (Long_val (Field (v, 0))); + if (newminwsz != caml_minor_heap_wsz){ + caml_gc_message (0x20, "New minor heap size: %luk words\n", + newminwsz / 1024); + caml_set_minor_heap_size (Bsize_wsize (newminwsz)); } return Val_unit; } @@ -417,8 +416,7 @@ static void test_and_compact (void) { float fp; - fp = 100.0 * caml_fl_cur_size - / (Wsize_bsize (caml_stat_heap_size) - caml_fl_cur_size); + fp = 100.0 * caml_fl_cur_wsz / (caml_stat_heap_wsz - caml_fl_cur_wsz); if (fp > 999999.0) fp = 999999.0; caml_gc_message (0x200, "Estimated overhead (lower bound) = %" ARCH_INTNAT_PRINTF_FORMAT "u%%\n", @@ -480,6 +478,8 @@ uintnat caml_normalize_heap_increment (uintnat i) return ((i + Page_size - 1) >> Page_log) << Page_log; } +/* [minor_size] and [major_size] are numbers of words + [major_incr] is either a percentage or a number of words */ void caml_init_gc (uintnat minor_size, uintnat major_size, uintnat major_incr, uintnat percent_fr, uintnat percent_m) @@ -495,8 +495,8 @@ void caml_init_gc (uintnat minor_size, uintnat major_size, caml_percent_free = norm_pfree (percent_fr); caml_percent_max = norm_pmax (percent_m); caml_init_major_heap (major_heap_size); - caml_gc_message (0x20, "Initial minor heap size: %luk bytes\n", - caml_minor_heap_size / 1024); + caml_gc_message (0x20, "Initial minor heap size: %luk words\n", + caml_minor_heap_wsz / 1024); caml_gc_message (0x20, "Initial major heap size: %luk bytes\n", major_heap_size / 1024); caml_gc_message (0x20, "Initial space overhead: %lu%%\n", caml_percent_free); diff --git a/byterun/globroots.c b/byterun/globroots.c index d9111eefee..b2770e3c8a 100644 --- a/byterun/globroots.c +++ b/byterun/globroots.c @@ -13,11 +13,11 @@ /* Registration of global memory roots */ -#include "memory.h" -#include "misc.h" -#include "mlvalues.h" -#include "roots.h" -#include "globroots.h" +#include "caml/memory.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" +#include "caml/roots.h" +#include "caml/globroots.h" /* The sets of global memory roots are represented as skip lists (see William Pugh, "Skip lists: a probabilistic alternative to diff --git a/byterun/hash.c b/byterun/hash.c index 12912d3d2f..e6be1aee14 100644 --- a/byterun/hash.c +++ b/byterun/hash.c @@ -16,10 +16,10 @@ /* The interface of this file is in "mlvalues.h" (for [caml_hash_variant]) and in "hash.h" (for the other exported functions). */ -#include "mlvalues.h" -#include "custom.h" -#include "memory.h" -#include "hash.h" +#include "caml/mlvalues.h" +#include "caml/custom.h" +#include "caml/memory.h" +#include "caml/hash.h" /* The new implementation, based on MurmurHash 3, http://code.google.com/p/smhasher/ */ diff --git a/byterun/instrtrace.c b/byterun/instrtrace.c index 0a19fd2f13..cce707deac 100644 --- a/byterun/instrtrace.c +++ b/byterun/instrtrace.c @@ -19,12 +19,13 @@ #include <string.h> #include <ctype.h> -#include "instruct.h" -#include "misc.h" -#include "mlvalues.h" -#include "opnames.h" -#include "prims.h" -#include "stacks.h" +#include "caml/instruct.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" +#include "caml/opnames.h" +#include "caml/prims.h" +#include "caml/stacks.h" +#include "caml/startup_aux.h" extern code_t caml_start_code; @@ -32,8 +33,6 @@ intnat caml_icount = 0; void caml_stop_here () {} -int caml_trace_flag = 0; - void caml_disasm_instr(pc) code_t pc; { @@ -252,7 +251,7 @@ caml_trace_accu_sp_file (value accu, value * sp, code_t prog, int proglen, caml_trace_value_file (accu, prog, proglen, f); fprintf (f, "\n sp=%#" ARCH_INTNAT_PRINTF_FORMAT "x @%ld:", (intnat) sp, caml_stack_high - sp); - for (p = sp, i = 0; i < 12 + (1 << caml_trace_flag) && p < caml_stack_high; + for (p = sp, i = 0; i < 12 + (1 << caml_trace_level) && p < caml_stack_high; p++, i++) { fprintf (f, "\n[%ld] ", caml_stack_high - p); caml_trace_value_file (*p, prog, proglen, f); diff --git a/byterun/intern.c b/byterun/intern.c index 638ff7287a..58f0d5879b 100644 --- a/byterun/intern.c +++ b/byterun/intern.c @@ -13,22 +13,22 @@ /* Structured input, compact format */ -/* The interface of this file is "intext.h" */ +/* The interface of this file is "caml/intext.h" */ #include <string.h> #include <stdio.h> -#include "alloc.h" -#include "callback.h" -#include "custom.h" -#include "fail.h" -#include "gc.h" -#include "intext.h" -#include "io.h" -#include "md5.h" -#include "memory.h" -#include "mlvalues.h" -#include "misc.h" -#include "reverse.h" +#include "caml/alloc.h" +#include "caml/callback.h" +#include "caml/custom.h" +#include "caml/fail.h" +#include "caml/gc.h" +#include "caml/intext.h" +#include "caml/io.h" +#include "caml/md5.h" +#include "caml/memory.h" +#include "caml/mlvalues.h" +#include "caml/misc.h" +#include "caml/reverse.h" static unsigned char * intern_src; /* Reading pointer in block holding input data. */ @@ -66,7 +66,7 @@ static value intern_block; static char * intern_resolve_code_pointer(unsigned char digest[16], asize_t offset); -static void intern_bad_code_pointer(unsigned char digest[16]) Noreturn; +Noreturn static void intern_bad_code_pointer(unsigned char digest[16]); static void intern_free_stack(void); @@ -143,6 +143,7 @@ static void readfloat(double * dest, unsigned int code) #endif } +/* [len] is a number of floats */ static void readfloats(double * dest, mlsize_t len, unsigned int code) { mlsize_t i; @@ -679,6 +680,7 @@ CAMLexport value caml_input_value_from_malloc(char * data, intnat ofs) return obj; } +/* [len] is a number of bytes */ CAMLexport value caml_input_value_from_block(char * data, intnat len) { uint32_t magic; @@ -698,6 +700,9 @@ CAMLexport value caml_input_value_from_block(char * data, intnat len) return obj; } +/* [ofs] is a [value] that represents a number of bytes + result is a [value] that represents a number of bytes +*/ CAMLprim value caml_marshal_data_size(value buff, value ofs) { uint32_t magic; diff --git a/byterun/interp.c b/byterun/interp.c index e22b28b8bd..a3d9e7034e 100644 --- a/byterun/interp.c +++ b/byterun/interp.c @@ -13,22 +13,23 @@ /* The bytecode interpreter */ #include <stdio.h> -#include "alloc.h" -#include "backtrace.h" -#include "callback.h" -#include "debugger.h" -#include "fail.h" -#include "fix_code.h" -#include "instrtrace.h" -#include "instruct.h" -#include "interp.h" -#include "major_gc.h" -#include "memory.h" -#include "misc.h" -#include "mlvalues.h" -#include "prims.h" -#include "signals.h" -#include "stacks.h" +#include "caml/alloc.h" +#include "caml/backtrace.h" +#include "caml/callback.h" +#include "caml/debugger.h" +#include "caml/fail.h" +#include "caml/fix_code.h" +#include "caml/instrtrace.h" +#include "caml/instruct.h" +#include "caml/interp.h" +#include "caml/major_gc.h" +#include "caml/memory.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" +#include "caml/prims.h" +#include "caml/signals.h" +#include "caml/stacks.h" +#include "caml/startup_aux.h" /* Registers for the abstract machine: pc the code pointer @@ -220,7 +221,7 @@ value caml_interprete(code_t prog, asize_t prog_size) #ifdef THREADED_CODE static void * jumptable[] = { -# include "jumptbl.h" +# include "caml/jumptbl.h" }; #endif @@ -271,9 +272,9 @@ value caml_interprete(code_t prog, asize_t prog_size) #ifdef DEBUG caml_bcodcount++; if (caml_icount-- == 0) caml_stop_here (); - if (caml_trace_flag>1) printf("\n##%ld\n", caml_bcodcount); - if (caml_trace_flag) caml_disasm_instr(pc); - if (caml_trace_flag>1) { + if (caml_trace_level>1) printf("\n##%ld\n", caml_bcodcount); + if (caml_trace_level>0) caml_disasm_instr(pc); + if (caml_trace_level>1) { printf("env="); caml_trace_value_file(env,prog,prog_size,stdout); putchar('\n'); diff --git a/byterun/ints.c b/byterun/ints.c index 056e82aa37..fa7aaa3271 100644 --- a/byterun/ints.c +++ b/byterun/ints.c @@ -13,16 +13,17 @@ #include <stdio.h> #include <string.h> -#include "alloc.h" -#include "custom.h" -#include "fail.h" -#include "intext.h" -#include "memory.h" -#include "misc.h" -#include "mlvalues.h" +#include "caml/alloc.h" +#include "caml/custom.h" +#include "caml/fail.h" +#include "caml/intext.h" +#include "caml/memory.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" static char * parse_sign_and_base(char * p, /*out*/ int * base, + /*out*/ int * signedness, /*out*/ int * sign) { *sign = 1; @@ -30,15 +31,17 @@ static char * parse_sign_and_base(char * p, *sign = -1; p++; } - *base = 10; + *base = 10; *signedness = 1; if (*p == '0') { switch (p[1]) { case 'x': case 'X': - *base = 16; p += 2; break; + *base = 16; *signedness = 0; p += 2; break; case 'o': case 'O': - *base = 8; p += 2; break; + *base = 8; *signedness = 0; p += 2; break; case 'b': case 'B': - *base = 2; p += 2; break; + *base = 2; *signedness = 0; p += 2; break; + case 'u': case 'U': + *signedness = 0; p += 2; break; } } return p; @@ -56,42 +59,47 @@ static int parse_digit(char c) return -1; } -static intnat parse_intnat(value s, int nbits) +#define INT_ERRMSG "int_of_string" +#define INT32_ERRMSG "Int32.of_string" +#define INT64_ERRMSG "Int64.of_string" +#define INTNAT_ERRMSG "Nativeint.of_string" + +static intnat parse_intnat(value s, int nbits, const char *errmsg) { char * p; uintnat res, threshold; - int sign, base, d; + int sign, base, signedness, d; - p = parse_sign_and_base(String_val(s), &base, &sign); + p = parse_sign_and_base(String_val(s), &base, &signedness, &sign); threshold = ((uintnat) -1) / base; d = parse_digit(*p); - if (d < 0 || d >= base) caml_failwith("int_of_string"); + if (d < 0 || d >= base) caml_failwith(errmsg); for (p++, res = d; /*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 (res > threshold) caml_failwith("int_of_string"); + if (res > threshold) caml_failwith(errmsg); res = base * res + d; /* Detect overflow in addition (base * res) + d */ - if (res < (uintnat) d) caml_failwith("int_of_string"); + if (res < (uintnat) d) caml_failwith(errmsg); } if (p != String_val(s) + caml_string_length(s)){ - caml_failwith("int_of_string"); + caml_failwith(errmsg); } - if (base == 10) { + if (signedness) { /* Signed representation expected, allow -2^(nbits-1) to 2^(nbits-1) - 1 */ if (sign >= 0) { - if (res >= (uintnat)1 << (nbits - 1)) caml_failwith("int_of_string"); + if (res >= (uintnat)1 << (nbits - 1)) caml_failwith(errmsg); } else { - if (res > (uintnat)1 << (nbits - 1)) caml_failwith("int_of_string"); + if (res > (uintnat)1 << (nbits - 1)) caml_failwith(errmsg); } } else { /* Unsigned representation expected, allow 0 to 2^nbits - 1 and tolerate -(2^nbits - 1) to 0 */ if (nbits < sizeof(uintnat) * 8 && res >= (uintnat)1 << nbits) - caml_failwith("int_of_string"); + caml_failwith(errmsg); } return sign < 0 ? -((intnat) res) : (intnat) res; } @@ -119,7 +127,7 @@ CAMLprim value caml_int_compare(value v1, value v2) CAMLprim value caml_int_of_string(value s) { - return Val_long(parse_intnat(s, 8 * sizeof(value) - 1)); + return Val_long(parse_intnat(s, 8 * sizeof(value) - 1, INT_ERRMSG)); } #define FORMAT_BUFFER_SIZE 32 @@ -182,11 +190,11 @@ static intnat int32_hash(value v) return Int32_val(v); } -static void int32_serialize(value v, uintnat * wsize_32, - uintnat * wsize_64) +static void int32_serialize(value v, uintnat * bsize_32, + uintnat * bsize_64) { caml_serialize_int_4(Int32_val(v)); - *wsize_32 = *wsize_64 = 4; + *bsize_32 = *bsize_64 = 4; } static uintnat int32_deserialize(void * dst) @@ -308,7 +316,7 @@ CAMLprim value caml_int32_format(value fmt, value arg) CAMLprim value caml_int32_of_string(value s) { - return caml_copy_int32(parse_intnat(s, 32)); + return caml_copy_int32(parse_intnat(s, 32, INT32_ERRMSG)); } CAMLprim value caml_int32_bits_of_float(value vd) @@ -353,11 +361,11 @@ static intnat int64_hash(value v) return hi ^ lo; } -static void int64_serialize(value v, uintnat * wsize_32, - uintnat * wsize_64) +static void int64_serialize(value v, uintnat * bsize_32, + uintnat * bsize_64) { caml_serialize_int_8(Int64_val(v)); - *wsize_32 = *wsize_64 = 8; + *bsize_32 = *bsize_64 = 8; } static uintnat int64_deserialize(void * dst) @@ -525,12 +533,12 @@ CAMLprim value caml_int64_of_string(value s) { char * p; uint64_t res, threshold; - int sign, base, d; + int sign, base, signedness, d; - p = parse_sign_and_base(String_val(s), &base, &sign); + p = parse_sign_and_base(String_val(s), &base, &signedness, &sign); threshold = ((uint64_t) -1) / base; d = parse_digit(*p); - if (d < 0 || d >= base) caml_failwith("int_of_string"); + if (d < 0 || d >= base) caml_failwith(INT64_ERRMSG); res = d; for (p++; /*nothing*/; p++) { char c = *p; @@ -538,20 +546,20 @@ CAMLprim value caml_int64_of_string(value s) d = parse_digit(c); if (d < 0 || d >= base) break; /* Detect overflow in multiplication base * res */ - if (res > threshold) caml_failwith("int_of_string"); + if (res > threshold) caml_failwith(INT64_ERRMSG); res = base * res + d; /* Detect overflow in addition (base * res) + d */ - if (res < (uint64_t) d) caml_failwith("int_of_string"); + if (res < (uint64_t) d) caml_failwith(INT64_ERRMSG); } if (p != String_val(s) + caml_string_length(s)){ - caml_failwith("int_of_string"); + caml_failwith(INT64_ERRMSG); } - if (base == 10) { + if (signedness) { /* 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"); + if (res >= (uint64_t)1 << 63) caml_failwith(INT64_ERRMSG); } else { - if (res > (uint64_t)1 << 63) caml_failwith("int_of_string"); + if (res > (uint64_t)1 << 63) caml_failwith(INT64_ERRMSG); } } if (sign < 0) res = - res; @@ -599,8 +607,8 @@ static intnat nativeint_hash(value v) #endif } -static void nativeint_serialize(value v, uintnat * wsize_32, - uintnat * wsize_64) +static void nativeint_serialize(value v, uintnat * bsize_32, + uintnat * bsize_64) { intnat l = Nativeint_val(v); #ifdef ARCH_SIXTYFOUR @@ -615,8 +623,8 @@ static void nativeint_serialize(value v, uintnat * wsize_32, caml_serialize_int_1(1); caml_serialize_int_4(l); #endif - *wsize_32 = 4; - *wsize_64 = 8; + *bsize_32 = 4; + *bsize_64 = 8; } static uintnat nativeint_deserialize(void * dst) @@ -765,5 +773,5 @@ CAMLprim value caml_nativeint_format(value fmt, value arg) CAMLprim value caml_nativeint_of_string(value s) { - return caml_copy_nativeint(parse_intnat(s, 8 * sizeof(value))); + return caml_copy_nativeint(parse_intnat(s, 8 * sizeof(value), INTNAT_ERRMSG)); } diff --git a/byterun/io.c b/byterun/io.c index bedc0f03ad..952985c8b1 100644 --- a/byterun/io.c +++ b/byterun/io.c @@ -17,23 +17,24 @@ #include <fcntl.h> #include <limits.h> #include <string.h> +#include <stdio.h> #include <sys/types.h> -#include "config.h" +#include "caml/config.h" #ifdef HAS_UNISTD #include <unistd.h> #endif #ifdef __CYGWIN__ #include </usr/include/io.h> #endif -#include "alloc.h" -#include "custom.h" -#include "fail.h" -#include "io.h" -#include "memory.h" -#include "misc.h" -#include "mlvalues.h" -#include "signals.h" -#include "sys.h" +#include "caml/alloc.h" +#include "caml/custom.h" +#include "caml/fail.h" +#include "caml/io.h" +#include "caml/memory.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" +#include "caml/signals.h" +#include "caml/sys.h" #ifndef SEEK_SET #define SEEK_SET 0 @@ -51,6 +52,30 @@ CAMLexport void (*caml_channel_mutex_unlock_exn) (void) = NULL; /* List of opened channels */ CAMLexport struct channel * caml_all_opened_channels = NULL; +/* Runtime warnings */ +static int caml_runtime_warnings = 1; +static int caml_runtime_warnings_first = 1; + +static int runtime_warnings() { + if (!caml_runtime_warnings) return 0; + if (caml_runtime_warnings_first) { + fprintf(stderr, "[ocaml] (use Sys.enable_runtime_warnings to control these warnings)\n"); + caml_runtime_warnings_first = 0; + } + return 1; +} + +CAMLprim value caml_ml_enable_runtime_warnings(value vbool) +{ + caml_runtime_warnings = Bool_val(vbool); + return Val_unit; +} + +CAMLprim value caml_ml_runtime_warnings_enabled(value vbool) +{ + return Val_bool(caml_runtime_warnings); +} + /* Basic functions over type struct channel *. These functions can be called directly from C. No locking is performed. */ @@ -75,6 +100,7 @@ CAMLexport struct channel * caml_open_descriptor_in(int fd) channel->flags = 0; channel->next = caml_all_opened_channels; channel->prev = NULL; + channel->name = NULL; if (caml_all_opened_channels != NULL) caml_all_opened_channels->prev = channel; caml_all_opened_channels = channel; @@ -109,6 +135,7 @@ CAMLexport void caml_close_channel(struct channel *channel) if (channel->refcount > 0) return; if (caml_channel_mutex_free != NULL) (*caml_channel_mutex_free)(channel); unlink_channel(channel); + caml_stat_free(channel->name); caml_stat_free(channel); } @@ -420,13 +447,22 @@ CAMLexport intnat caml_input_scan_line(struct channel *channel) /* OCaml entry points for the I/O functions. Wrap struct channel * objects into a heap-allocated object. Perform locking and unlocking around the I/O operations. */ + /* FIXME CAMLexport, but not in io.h exported for Cash ? */ CAMLexport void caml_finalize_channel(value vchan) { struct channel * chan = Channel(vchan); if (--chan->refcount > 0) return; if (caml_channel_mutex_free != NULL) (*caml_channel_mutex_free)(chan); + + if (chan->fd != -1 && chan->name && runtime_warnings()) + fprintf(stderr, + "[ocaml] channel opened on file '%s' dies without being closed\n", + chan->name + ); + unlink_channel(chan); + caml_stat_free(chan->name); caml_stat_free(chan); } @@ -472,6 +508,17 @@ CAMLprim value caml_ml_open_descriptor_out(value fd) return caml_alloc_channel(caml_open_descriptor_out(Int_val(fd))); } +CAMLprim value caml_ml_set_channel_name(value vchannel, value vname) +{ + struct channel * channel = Channel(vchannel); + caml_stat_free(channel->name); + if (caml_string_length(vname) > 0) + channel->name = caml_strdup(String_val(vname)); + else + channel->name = NULL; + return Val_unit; +} + #define Pair_tag 0 CAMLprim value caml_ml_out_channels_list (value unit) diff --git a/byterun/lexing.c b/byterun/lexing.c index 22ef6acde3..eac302e31a 100644 --- a/byterun/lexing.c +++ b/byterun/lexing.c @@ -13,9 +13,9 @@ /* The table-driven automaton for lexers generated by camllex. */ -#include "fail.h" -#include "mlvalues.h" -#include "stacks.h" +#include "caml/fail.h" +#include "caml/mlvalues.h" +#include "caml/stacks.h" struct lexer_buffer { value refill_buff; diff --git a/byterun/main.c b/byterun/main.c index b51c31c5c0..1ad20280e3 100644 --- a/byterun/main.c +++ b/byterun/main.c @@ -14,9 +14,9 @@ /* Main entry point (can be overridden by a user-provided main() function that calls caml_main() later). */ -#include "misc.h" -#include "mlvalues.h" -#include "sys.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" +#include "caml/sys.h" CAMLextern void caml_main (char **); diff --git a/byterun/major_gc.c b/byterun/major_gc.c index a44c8d90ad..41eb4215db 100644 --- a/byterun/major_gc.c +++ b/byterun/major_gc.c @@ -13,19 +13,19 @@ #include <limits.h> -#include "compact.h" -#include "custom.h" -#include "config.h" -#include "fail.h" -#include "finalise.h" -#include "freelist.h" -#include "gc.h" -#include "gc_ctrl.h" -#include "major_gc.h" -#include "misc.h" -#include "mlvalues.h" -#include "roots.h" -#include "weak.h" +#include "caml/compact.h" +#include "caml/custom.h" +#include "caml/config.h" +#include "caml/fail.h" +#include "caml/finalise.h" +#include "caml/freelist.h" +#include "caml/gc.h" +#include "caml/gc_ctrl.h" +#include "caml/major_gc.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" +#include "caml/roots.h" +#include "caml/weak.h" #if defined (NATIVE_CODE) && defined (NO_NAKED_POINTERS) #define NATIVE_CODE_AND_NO_NAKED_POINTERS @@ -46,7 +46,7 @@ static int heap_is_pure; /* The heap is pure if the only gray objects uintnat caml_allocated_words; uintnat caml_dependent_size, caml_dependent_allocated; double caml_extra_heap_resources; -uintnat caml_fl_size_at_phase_change = 0; +uintnat caml_fl_wsz_at_phase_change = 0; extern char *caml_fl_merge; /* Defined in freelist.c. */ @@ -59,12 +59,14 @@ static value *weak_prev; static unsigned long major_gc_counter = 0; #endif +void (*caml_major_gc_hook)(void) = NULL; + static void realloc_gray_vals (void) { value *new; Assert (gray_vals_cur == gray_vals_end); - if (gray_vals_size < caml_stat_heap_size / 128){ + if (gray_vals_size < caml_stat_heap_wsz / 32){ caml_gc_message (0x08, "Growing gray_vals to %" ARCH_INTNAT_PRINTF_FORMAT "uk bytes\n", (intnat) gray_vals_size * sizeof (value) / 512); @@ -90,13 +92,6 @@ 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 @@ -107,6 +102,15 @@ void caml_darken (value v, value *p /* not used */) h = Hd_val (v); t = Tag_hd (h); } +#ifdef NATIVE_CODE_AND_NO_NAKED_POINTERS + /* 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 (h)); +#endif CAMLassert (!Is_blue_hd (h)); if (Is_white_hd (h)){ if (t < No_scan_tag){ @@ -145,6 +149,7 @@ static void mark_slice (intnat work) int marking_closure = 0; #endif + if (caml_major_slice_begin_hook != NULL) (*caml_major_slice_begin_hook) (); caml_gc_message (0x40, "Marking %ld words\n", work); caml_gc_message (0x40, "Subphase = %ld\n", caml_gc_subphase); gray_vals_ptr = gray_vals_cur; @@ -169,8 +174,6 @@ static void mark_slice (intnat work) 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 @@ -189,6 +192,10 @@ static void mark_slice (intnat work) child -= Infix_offset_val(child); hd = Hd_val(child); } +#ifdef NATIVE_CODE_AND_NO_NAKED_POINTERS + /* See [caml_darken] for a description of this assertion. */ + CAMLassert (Is_in_heap (child) || Is_black_hd (hd)); +#endif if (Is_white_hd (hd)){ Hd_val (child) = Grayhd_hd (hd); *gray_vals_ptr++ = child; @@ -306,7 +313,8 @@ static void mark_slice (intnat work) caml_gc_sweep_hp = chunk; limit = chunk + Chunk_size (chunk); work = 0; - caml_fl_size_at_phase_change = caml_fl_cur_size; + caml_fl_wsz_at_phase_change = caml_fl_cur_wsz; + if (caml_major_gc_hook) (*caml_major_gc_hook)(); } break; default: Assert (0); @@ -314,6 +322,7 @@ static void mark_slice (intnat work) } } gray_vals_cur = gray_vals_ptr; + if (caml_major_slice_end_hook != NULL) (*caml_major_slice_end_hook) (); } static void sweep_slice (intnat work) @@ -321,6 +330,7 @@ static void sweep_slice (intnat work) char *hp; header_t hd; + if (caml_major_slice_begin_hook != NULL) (*caml_major_slice_begin_hook) (); caml_gc_message (0x40, "Sweeping %ld words\n", work); while (work > 0){ if (caml_gc_sweep_hp < limit){ @@ -334,7 +344,7 @@ static void sweep_slice (intnat work) void (*final_fun)(value) = Custom_ops_val(Val_hp(hp))->finalize; if (final_fun != NULL) final_fun(Val_hp(hp)); } - caml_gc_sweep_hp = caml_fl_merge_block (Bp_hp (hp)); + caml_gc_sweep_hp = (char *) caml_fl_merge_block (Val_hp (hp)); break; case Caml_blue: /* Only the blocks of the free-list are blue. See [freelist.c]. */ @@ -359,6 +369,7 @@ static void sweep_slice (intnat work) } } } + if (caml_major_slice_end_hook != NULL) (*caml_major_slice_end_hook) (); } /* The main entry point for the GC. Called after each minor GC. @@ -371,7 +382,7 @@ intnat caml_major_collection_slice (intnat howmuch) intnat computed_work; /* Free memory at the start of the GC cycle (garbage + free list) (assumed): - FM = caml_stat_heap_size * caml_percent_free + FM = caml_stat_heap_wsz * caml_percent_free / (100 + caml_percent_free) Assuming steady state and enforcing a constant allocation rate, then @@ -383,15 +394,15 @@ intnat caml_major_collection_slice (intnat howmuch) Proportion of G consumed since the previous slice: PH = caml_allocated_words / G = caml_allocated_words * 3 * (100 + caml_percent_free) - / (2 * caml_stat_heap_size * caml_percent_free) + / (2 * caml_stat_heap_wsz * caml_percent_free) Proportion of extra-heap resources consumed since the previous slice: PE = caml_extra_heap_resources Proportion of total work to do in this slice: P = max (PH, PE) Amount of marking work for the GC cycle: - MW = caml_stat_heap_size * 100 / (100 + caml_percent_free) + MW = caml_stat_heap_wsz * 100 / (100 + caml_percent_free) Amount of sweeping work for the GC cycle: - SW = caml_stat_heap_size + SW = caml_stat_heap_wsz In order to finish marking with a non-empty free list, we will use 40% of the time for marking, and 60% for sweeping. @@ -405,10 +416,10 @@ intnat caml_major_collection_slice (intnat howmuch) Amount of marking work for a marking slice: MS = P * MW / (40/100) - MS = P * caml_stat_heap_size * 250 / (100 + caml_percent_free) + MS = P * caml_stat_heap_wsz * 250 / (100 + caml_percent_free) Amount of sweeping work for a sweeping slice: SS = P * SW / (60/100) - SS = P * caml_stat_heap_size * 5 / 3 + SS = P * caml_stat_heap_wsz * 5 / 3 This slice will either mark MS words or sweep SS words. */ @@ -416,7 +427,7 @@ intnat caml_major_collection_slice (intnat howmuch) if (caml_gc_phase == Phase_idle) start_cycle (); p = (double) caml_allocated_words * 3.0 * (100 + caml_percent_free) - / Wsize_bsize (caml_stat_heap_size) / caml_percent_free / 2.0; + / caml_stat_heap_wsz / caml_percent_free / 2.0; if (caml_dependent_size > 0){ dp = (double) caml_dependent_allocated * (100 + caml_percent_free) / caml_dependent_size / caml_percent_free; @@ -437,10 +448,10 @@ intnat caml_major_collection_slice (intnat howmuch) (uintnat) (p * 1000000)); if (caml_gc_phase == Phase_mark){ - computed_work = (intnat) (p * Wsize_bsize (caml_stat_heap_size) * 250 + computed_work = (intnat) (p * caml_stat_heap_wsz * 250 / (100 + caml_percent_free)); }else{ - computed_work = (intnat) (p * Wsize_bsize (caml_stat_heap_size) * 5 / 3); + computed_work = (intnat) (p * caml_stat_heap_wsz * 5 / 3); } caml_gc_message (0x40, "ordered work = %ld words\n", howmuch); caml_gc_message (0x40, "computed work = %ld words\n", computed_work); @@ -483,28 +494,31 @@ void caml_finish_major_cycle (void) /* Make sure the request is at least Heap_chunk_min and round it up to a multiple of the page size. + The argument and result are both numbers of words. */ static asize_t clip_heap_chunk_size (asize_t request) { - if (request < Bsize_wsize (Heap_chunk_min)){ - request = Bsize_wsize (Heap_chunk_min); + if (request < Heap_chunk_min){ + request = Heap_chunk_min; } - return ((request + Page_size - 1) >> Page_log) << Page_log; + return + Wsize_bsize (((Bsize_wsize (request) + Page_size - 1) >> Page_log) << Page_log); } /* Compute the heap increment, make sure the request is at least that big, then call clip_heap_chunk_size, then make sure the result is >= request. + The argument and result are both numbers of words. */ -asize_t caml_round_heap_chunk_size (asize_t request) +asize_t caml_round_heap_chunk_wsz (asize_t request) { asize_t result = request; uintnat incr; - /* Compute the heap increment as a byte size. */ + /* Compute the heap increment as a word size. */ if (caml_major_heap_increment > 1000){ - incr = Bsize_wsize (caml_major_heap_increment); + incr = caml_major_heap_increment; }else{ - incr = caml_stat_heap_size / 100 * caml_major_heap_increment; + incr = caml_stat_heap_wsz / 100 * caml_major_heap_increment; } if (result < incr){ @@ -519,26 +533,27 @@ asize_t caml_round_heap_chunk_size (asize_t request) return result; } +/* [heap_size] is a number of bytes */ void caml_init_major_heap (asize_t heap_size) { - caml_stat_heap_size = clip_heap_chunk_size (heap_size); - caml_stat_top_heap_size = caml_stat_heap_size; - Assert (caml_stat_heap_size % Page_size == 0); - caml_heap_start = (char *) caml_alloc_for_heap (caml_stat_heap_size); + caml_stat_heap_wsz = Wsize_bsize (clip_heap_chunk_size (heap_size)); + caml_stat_top_heap_wsz = caml_stat_heap_wsz; + Assert (Bsize_wsize (caml_stat_heap_wsz) % Page_size == 0); + caml_heap_start = (char *) caml_alloc_for_heap (Bsize_wsize (caml_stat_heap_wsz)); if (caml_heap_start == NULL) caml_fatal_error ("Fatal error: not enough memory for the initial heap.\n"); Chunk_next (caml_heap_start) = NULL; caml_stat_heap_chunks = 1; if (caml_page_table_add(In_heap, caml_heap_start, - caml_heap_start + caml_stat_heap_size) != 0) { + caml_heap_start + Bsize_wsize (caml_stat_heap_wsz)) != 0) { caml_fatal_error ("Fatal error: not enough memory " "for the initial page table.\n"); } caml_fl_init_merge (); caml_make_free_blocks ((value *) caml_heap_start, - Wsize_bsize (caml_stat_heap_size), 1, Caml_white); + caml_stat_heap_wsz, 1, Caml_white); caml_gc_phase = Phase_idle; gray_vals_size = 2048; gray_vals = (value *) malloc (gray_vals_size * sizeof (value)); diff --git a/byterun/md5.c b/byterun/md5.c index 2dc90a2040..7a996b6b9f 100644 --- a/byterun/md5.c +++ b/byterun/md5.c @@ -12,13 +12,13 @@ /***********************************************************************/ #include <string.h> -#include "alloc.h" -#include "fail.h" -#include "md5.h" -#include "memory.h" -#include "mlvalues.h" -#include "io.h" -#include "reverse.h" +#include "caml/alloc.h" +#include "caml/fail.h" +#include "caml/md5.h" +#include "caml/memory.h" +#include "caml/mlvalues.h" +#include "caml/io.h" +#include "caml/reverse.h" /* MD5 message digest */ @@ -33,18 +33,16 @@ CAMLprim value caml_md5_string(value str, value ofs, value len) return res; } -CAMLprim value caml_md5_chan(value vchan, value len) +CAMLexport value caml_md5_channel(struct channel *chan, intnat toread) { - CAMLparam2 (vchan, len); - struct channel * chan = Channel(vchan); + CAMLparam0(); struct MD5Context ctx; value res; - intnat toread, read; + intnat read; char buffer[4096]; Lock(chan); caml_MD5Init(&ctx); - toread = Long_val(len); if (toread < 0){ while (1){ read = caml_getblock (chan, buffer, sizeof(buffer)); @@ -66,6 +64,12 @@ CAMLprim value caml_md5_chan(value vchan, value len) CAMLreturn (res); } +CAMLprim value caml_md5_chan(value vchan, value len) +{ + CAMLparam2 (vchan, len); + CAMLreturn (caml_md5_channel(Channel(vchan), Long_val(len))); +} + CAMLexport void caml_md5_block(unsigned char digest[16], void * data, uintnat len) { diff --git a/byterun/memory.c b/byterun/memory.c index 54d91c96da..7e9d4ab209 100644 --- a/byterun/memory.c +++ b/byterun/memory.c @@ -13,17 +13,18 @@ #include <stdlib.h> #include <string.h> -#include "fail.h" -#include "freelist.h" -#include "gc.h" -#include "gc_ctrl.h" -#include "major_gc.h" -#include "memory.h" -#include "major_gc.h" -#include "minor_gc.h" -#include "misc.h" -#include "mlvalues.h" -#include "signals.h" +#include "caml/address_class.h" +#include "caml/fail.h" +#include "caml/freelist.h" +#include "caml/gc.h" +#include "caml/gc_ctrl.h" +#include "caml/major_gc.h" +#include "caml/memory.h" +#include "caml/major_gc.h" +#include "caml/minor_gc.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" +#include "caml/signals.h" extern uintnat caml_percent_free; /* major_gc.c */ @@ -218,7 +219,7 @@ int caml_page_table_remove(int kind, void * start, void * end) /* Allocate a block of the requested size, to be passed to [caml_add_to_heap] later. - [request] must be a multiple of [Page_size]. + [request] must be a multiple of [Page_size], it is a number of bytes. [caml_alloc_for_heap] returns NULL if the request cannot be satisfied. The returned pointer is a hp, but the header must be initialized by the caller. @@ -264,7 +265,7 @@ int caml_add_to_heap (char *m) #endif /* debug */ caml_gc_message (0x04, "Growing heap to %luk bytes\n", - (caml_stat_heap_size + Chunk_size (m)) / 1024); + (Bsize_wsize (caml_stat_heap_wsz) + Chunk_size (m)) / 1024); /* Register block in page table */ if (caml_page_table_add(In_heap, m, m + Chunk_size(m)) != 0) @@ -285,9 +286,9 @@ int caml_add_to_heap (char *m) ++ caml_stat_heap_chunks; } - caml_stat_heap_size += Chunk_size (m); - if (caml_stat_heap_size > caml_stat_top_heap_size){ - caml_stat_top_heap_size = caml_stat_heap_size; + caml_stat_heap_wsz += Wsize_bsize (Chunk_size (m)); + if (caml_stat_heap_wsz > caml_stat_top_heap_wsz){ + caml_stat_top_heap_wsz = caml_stat_heap_wsz; } return 0; } @@ -298,18 +299,20 @@ int caml_add_to_heap (char *m) field 0); the last block of the chain is pointed by field 1 of the first. There may be a fragment after the last block. The caller must insert the blocks into the free list. - The request must be less than or equal to Max_wosize. + [request] is a number of words and must be less than or equal + to [Max_wosize]. Return NULL when out of memory. */ -static char *expand_heap (mlsize_t request) +static value *expand_heap (mlsize_t request) { - char *mem, *hp, *prev; + /* these point to headers, but we do arithmetic on them, hence [value *]. */ + value *mem, *hp, *prev; asize_t over_request, malloc_request, remain; Assert (request <= Max_wosize); - over_request = request + request / 100 * caml_percent_free; - malloc_request = caml_round_heap_chunk_size (Bhsize_wosize (over_request)); - mem = caml_alloc_for_heap (malloc_request); + over_request = Whsize_wosize (request + request / 100 * caml_percent_free); + malloc_request = caml_round_heap_chunk_wsz (over_request); + mem = (value *) caml_alloc_for_heap (Bsize_wsize (malloc_request)); if (mem == NULL){ caml_gc_message (0x04, "No room for growing heap\n", 0); return NULL; @@ -317,33 +320,33 @@ static char *expand_heap (mlsize_t request) remain = malloc_request; prev = hp = mem; /* FIXME find a way to do this with a call to caml_make_free_blocks */ - while (Wosize_bhsize (remain) > Max_wosize){ + while (Wosize_whsize (remain) > Max_wosize){ Hd_hp (hp) = Make_header (Max_wosize, 0, Caml_blue); #ifdef DEBUG - caml_set_fields (Bp_hp (hp), 0, Debug_free_major); + caml_set_fields (Val_hp (hp), 0, Debug_free_major); #endif - hp += Bhsize_wosize (Max_wosize); - remain -= Bhsize_wosize (Max_wosize); - Field (Op_hp (mem), 1) = Field (Op_hp (prev), 0) = (value) Op_hp (hp); + hp += Whsize_wosize (Max_wosize); + remain -= Whsize_wosize (Max_wosize); + Field (Val_hp (mem), 1) = Field (Val_hp (prev), 0) = Val_hp (hp); prev = hp; } if (remain > 1){ - Hd_hp (hp) = Make_header (Wosize_bhsize (remain), 0, Caml_blue); + Hd_hp (hp) = Make_header (Wosize_whsize (remain), 0, Caml_blue); #ifdef DEBUG - caml_set_fields (Bp_hp (hp), 0, Debug_free_major); + caml_set_fields (Val_hp (hp), 0, Debug_free_major); #endif - Field (Op_hp (mem), 1) = Field (Op_hp (prev), 0) = (value) Op_hp (hp); - Field (Op_hp (hp), 0) = (value) NULL; + Field (Val_hp (mem), 1) = Field (Val_hp (prev), 0) = Val_hp (hp); + Field (Val_hp (hp), 0) = (value) NULL; }else{ - Field (Op_hp (prev), 0) = (value) NULL; + Field (Val_hp (prev), 0) = (value) NULL; if (remain == 1) Hd_hp (hp) = Make_header (0, 0, Caml_white); } Assert (Wosize_hp (mem) >= request); - if (caml_add_to_heap (mem) != 0){ - caml_free_for_heap (mem); + if (caml_add_to_heap ((char *) mem) != 0){ + caml_free_for_heap ((char *) mem); return NULL; } - return Bp_hp (mem); + return Op_hp (mem); } /* Remove the heap chunk [chunk] from the heap and give the memory back @@ -358,12 +361,13 @@ void caml_shrink_heap (char *chunk) want to shift the page table, it's too messy (see above). It will never happen anyway, because of the way compaction works. (see compact.c) + XXX FIXME this has become false with the fix to PR#5389 (see compact.c) */ if (chunk == caml_heap_start) return; - caml_stat_heap_size -= Chunk_size (chunk); - caml_gc_message (0x04, "Shrinking heap to %luk bytes\n", - (unsigned long) caml_stat_heap_size / 1024); + caml_stat_heap_wsz -= Wsize_bsize (Chunk_size (chunk)); + caml_gc_message (0x04, "Shrinking heap to %luk words\n", + (unsigned long) caml_stat_heap_wsz / 1024); #ifdef DEBUG { @@ -403,7 +407,8 @@ color_t caml_allocation_color (void *hp) CAMLexport value caml_alloc_shr (mlsize_t wosize, tag_t tag) { - char *hp, *new_block; + header_t *hp; + value *new_block; if (wosize > Max_wosize) caml_raise_out_of_memory (); hp = caml_fl_allocate (wosize); @@ -415,7 +420,7 @@ CAMLexport value caml_alloc_shr (mlsize_t wosize, tag_t tag) else caml_raise_out_of_memory (); } - caml_fl_add_blocks (new_block); + caml_fl_add_blocks ((value) new_block); hp = caml_fl_allocate (wosize); } @@ -433,7 +438,7 @@ CAMLexport value caml_alloc_shr (mlsize_t wosize, tag_t tag) } Assert (Hd_hp (hp) == Make_header (wosize, tag, caml_allocation_color (hp))); caml_allocated_words += Whsize_wosize (wosize); - if (caml_allocated_words > Wsize_bsize (caml_minor_heap_size)){ + if (caml_allocated_words > caml_minor_heap_wsz){ caml_urge_major_slice (); } #ifdef DEBUG @@ -489,8 +494,8 @@ CAMLexport void caml_adjust_gc_speed (mlsize_t res, mlsize_t max) caml_urge_major_slice (); } if (caml_extra_heap_resources - > (double) Wsize_bsize (caml_minor_heap_size) / 2.0 - / (double) Wsize_bsize (caml_stat_heap_size)) { + > (double) caml_minor_heap_wsz / 2.0 + / (double) caml_stat_heap_wsz) { caml_urge_major_slice (); } } @@ -569,6 +574,7 @@ CAMLexport CAMLweakdef void caml_modify (value *fp, value val) } } +/* [sz] is a number of bytes */ CAMLexport void * caml_stat_alloc (asize_t sz) { void * result = malloc (sz); @@ -586,6 +592,7 @@ CAMLexport void caml_stat_free (void * blk) free (blk); } +/* [sz] is a number of bytes */ CAMLexport void * caml_stat_resize (void * blk, asize_t sz) { void * result = realloc (blk, sz); diff --git a/byterun/meta.c b/byterun/meta.c index e5c6f941bd..32cd6dd717 100644 --- a/byterun/meta.c +++ b/byterun/meta.c @@ -14,19 +14,19 @@ /* Primitives for the toplevel */ #include <string.h> -#include "alloc.h" -#include "config.h" -#include "fail.h" -#include "fix_code.h" -#include "interp.h" -#include "intext.h" -#include "major_gc.h" -#include "memory.h" -#include "minor_gc.h" -#include "misc.h" -#include "mlvalues.h" -#include "prims.h" -#include "stacks.h" +#include "caml/alloc.h" +#include "caml/config.h" +#include "caml/fail.h" +#include "caml/fix_code.h" +#include "caml/interp.h" +#include "caml/intext.h" +#include "caml/major_gc.h" +#include "caml/memory.h" +#include "caml/minor_gc.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" +#include "caml/prims.h" +#include "caml/stacks.h" #ifndef NATIVE_CODE @@ -47,7 +47,14 @@ CAMLprim value caml_get_section_table(value unit) CAMLprim value caml_reify_bytecode(value prog, value len) { + struct code_fragment * cf = caml_stat_alloc(sizeof(struct code_fragment)); value clos; + + cf->code_start = (char *) prog; + cf->code_end = (char *) prog + Long_val(len); + cf->digest_computed = 0; + caml_ext_table_add(&caml_code_fragments_table, cf); + #ifdef ARCH_BIG_ENDIAN caml_fixup_endianness((code_t) prog, (asize_t) Long_val(len)); #endif @@ -60,6 +67,38 @@ CAMLprim value caml_reify_bytecode(value prog, value len) return clos; } +/* signal to the interpreter machinery that a bytecode is no more + needed (before freeing it) - this might be useful for a JIT + implementation */ + +CAMLprim value caml_static_release_bytecode(value prog, value len) +{ + struct code_fragment * cf = NULL, * cfi; + int i; + for (i = 0; i < caml_code_fragments_table.size; i++) { + cfi = (struct code_fragment *) caml_code_fragments_table.contents[i]; + if (cfi->code_start == (char *) prog && + cfi->code_end == (char *) prog + Long_val(len)) { + cf = cfi; + break; + } + } + + if (!cf) { + /* [cf] Not matched with a caml_reify_bytecode call; impossible. */ + Assert (0); + } else { + caml_ext_table_remove(&caml_code_fragments_table, cf); + } + +#ifndef NATIVE_CODE + caml_release_bytecode((code_t) prog, (asize_t) Long_val(len)); +#else + caml_failwith("Meta.static_release_bytecode impossible with native code"); +#endif + return Val_unit; +} + CAMLprim value caml_register_code_fragment(value prog, value len, value digest) { struct code_fragment * cf = caml_stat_alloc(sizeof(struct code_fragment)); diff --git a/byterun/minor_gc.c b/byterun/minor_gc.c index b15d1e4469..079e686683 100644 --- a/byterun/minor_gc.c +++ b/byterun/minor_gc.c @@ -12,24 +12,24 @@ /***********************************************************************/ #include <string.h> -#include "config.h" -#include "fail.h" -#include "finalise.h" -#include "gc.h" -#include "gc_ctrl.h" -#include "major_gc.h" -#include "memory.h" -#include "minor_gc.h" -#include "misc.h" -#include "mlvalues.h" -#include "roots.h" -#include "signals.h" -#include "weak.h" - -asize_t caml_minor_heap_size; +#include "caml/config.h" +#include "caml/fail.h" +#include "caml/finalise.h" +#include "caml/gc.h" +#include "caml/gc_ctrl.h" +#include "caml/major_gc.h" +#include "caml/memory.h" +#include "caml/minor_gc.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" +#include "caml/roots.h" +#include "caml/signals.h" +#include "caml/weak.h" + +asize_t caml_minor_heap_wsz; static void *caml_young_base = NULL; -CAMLexport char *caml_young_start = NULL, *caml_young_end = NULL; -CAMLexport char *caml_young_ptr = NULL, *caml_young_limit = NULL; +CAMLexport value *caml_young_start = NULL, *caml_young_end = NULL; +CAMLexport value *caml_young_ptr = NULL, *caml_young_limit = NULL; CAMLexport struct caml_ref_table caml_ref_table = { NULL, NULL, NULL, NULL, NULL, 0, 0}, @@ -41,6 +41,7 @@ int caml_in_minor_collection = 0; static unsigned long minor_gc_counter = 0; #endif +/* [sz] and [rsv] are numbers of entries */ void caml_alloc_table (struct caml_ref_table *tbl, asize_t sz, asize_t rsv) { value **new_table; @@ -71,7 +72,7 @@ static void clear_table (struct caml_ref_table *tbl) tbl->limit = tbl->threshold; } -/* size in bytes */ +/* [size] is a number of bytes */ void caml_set_minor_heap_size (asize_t size) { char *new_heap; @@ -92,11 +93,11 @@ void caml_set_minor_heap_size (asize_t size) free (caml_young_base); } caml_young_base = new_heap_base; - caml_young_start = new_heap; - caml_young_end = new_heap + size; + caml_young_start = (value *) new_heap; + caml_young_end = (value *) (new_heap + size); caml_young_limit = caml_young_start; caml_young_ptr = caml_young_end; - caml_minor_heap_size = size; + caml_minor_heap_wsz = Wsize_bsize (size); reset_table (&caml_ref_table); reset_table (&caml_weak_ref_table); @@ -116,7 +117,7 @@ void caml_oldify_one (value v, value *p) tail_call: if (Is_block (v) && Is_young (v)){ - Assert (Hp_val (v) >= caml_young_ptr); + Assert ((value *) Hp_val (v) >= caml_young_ptr); hd = Hd_val (v); if (hd == 0){ /* If already forwarded */ *p = Field (v, 0); /* then forward pointer is first field. */ @@ -226,8 +227,11 @@ void caml_oldify_mopup (void) void caml_empty_minor_heap (void) { value **r; + uintnat prev_alloc_words; if (caml_young_ptr != caml_young_end){ + if (caml_minor_gc_begin_hook != NULL) (*caml_minor_gc_begin_hook) (); + prev_alloc_words = caml_allocated_words; caml_in_minor_collection = 1; caml_gc_message (0x02, "<", 0); caml_oldify_local_roots(); @@ -245,19 +249,24 @@ void caml_empty_minor_heap (void) } } if (caml_young_ptr < caml_young_start) caml_young_ptr = caml_young_start; - caml_stat_minor_words += Wsize_bsize (caml_young_end - caml_young_ptr); + caml_stat_minor_words += caml_young_end - caml_young_ptr; caml_young_ptr = caml_young_end; caml_young_limit = caml_young_start; clear_table (&caml_ref_table); clear_table (&caml_weak_ref_table); caml_gc_message (0x02, ">", 0); caml_in_minor_collection = 0; + caml_stat_promoted_words += caml_allocated_words - prev_alloc_words; + ++ caml_stat_minor_collections; + caml_final_empty_young (); + if (caml_minor_gc_end_hook != NULL) (*caml_minor_gc_end_hook) (); + }else{ + caml_final_empty_young (); } - caml_final_empty_young (); #ifdef DEBUG { value *p; - for (p = (value *) caml_young_start; p < (value *) caml_young_end; ++p){ + for (p = caml_young_start; p < caml_young_end; ++p){ *p = Debug_free_minor; } ++ minor_gc_counter; @@ -271,16 +280,14 @@ void caml_empty_minor_heap (void) */ CAMLexport void caml_minor_collection (void) { - intnat prev_alloc_words = caml_allocated_words; - caml_empty_minor_heap (); - caml_stat_promoted_words += caml_allocated_words - prev_alloc_words; - ++ caml_stat_minor_collections; caml_major_collection_slice (0); caml_force_major_slice = 0; + if (caml_finalise_begin_hook != NULL) (*caml_finalise_begin_hook) (); caml_final_do_calls (); + if (caml_finalise_end_hook != NULL) (*caml_finalise_end_hook) (); caml_empty_minor_heap (); } @@ -298,7 +305,7 @@ void caml_realloc_ref_table (struct caml_ref_table *tbl) Assert (tbl->limit >= tbl->threshold); if (tbl->base == NULL){ - caml_alloc_table (tbl, caml_minor_heap_size / sizeof (value) / 8, 256); + caml_alloc_table (tbl, caml_minor_heap_wsz / 8, 256); }else if (tbl->limit == tbl->threshold){ caml_gc_message (0x08, "ref_table threshold crossed\n", 0); tbl->limit = tbl->end; diff --git a/byterun/misc.c b/byterun/misc.c index 1872a80acd..09b2d85dbb 100644 --- a/byterun/misc.c +++ b/byterun/misc.c @@ -14,9 +14,16 @@ #include <stdio.h> #include <string.h> #include <stdarg.h> -#include "config.h" -#include "misc.h" -#include "memory.h" +#include "caml/config.h" +#include "caml/misc.h" +#include "caml/memory.h" + +caml_timing_hook caml_major_slice_begin_hook = NULL; +caml_timing_hook caml_major_slice_end_hook = NULL; +caml_timing_hook caml_minor_gc_begin_hook = NULL; +caml_timing_hook caml_minor_gc_end_hook = NULL; +caml_timing_hook caml_finalise_begin_hook = NULL; +caml_timing_hook caml_finalise_end_hook = NULL; #ifdef DEBUG @@ -28,11 +35,11 @@ int caml_failed_assert (char * expr, char * file, int line) exit (100); } -void caml_set_fields (char *bp, unsigned long start, unsigned long filler) +void caml_set_fields (value v, unsigned long start, unsigned long filler) { mlsize_t i; - for (i = start; i < Wosize_bp (bp); i++){ - Field (Val_bp (bp), i) = (value) filler; + for (i = start; i < Wosize_val (v); i++){ + Field (v, i) = (value) filler; } } @@ -68,6 +75,7 @@ CAMLexport void caml_fatal_error_arg2 (char *fmt1, char *arg1, exit(2); } +/* [size] and [modulo] are numbers of bytes */ char *caml_aligned_malloc (asize_t size, int modulo, void **block) { char *raw_mem; @@ -115,6 +123,19 @@ int caml_ext_table_add(struct ext_table * tbl, void * data) return res; } +void caml_ext_table_remove(struct ext_table * tbl, void * data) +{ + int i; + for (i = 0; i < tbl->size; i++) { + if (tbl->contents[i] == data) { + caml_stat_free(tbl->contents[i]); + memmove(&tbl->contents[i], &tbl->contents[i + 1], + (tbl->size - i - 1) * sizeof(void *)); + tbl->size--; + } + } +} + void caml_ext_table_free(struct ext_table * tbl, int free_entries) { int i; diff --git a/byterun/obj.c b/byterun/obj.c index b045fee263..27b50d9a3d 100644 --- a/byterun/obj.c +++ b/byterun/obj.c @@ -14,17 +14,18 @@ /* Operations on objects */ #include <string.h> -#include "alloc.h" -#include "fail.h" -#include "gc.h" -#include "interp.h" -#include "major_gc.h" -#include "memory.h" -#include "minor_gc.h" -#include "misc.h" -#include "mlvalues.h" -#include "prims.h" - +#include "caml/alloc.h" +#include "caml/fail.h" +#include "caml/gc.h" +#include "caml/interp.h" +#include "caml/major_gc.h" +#include "caml/memory.h" +#include "caml/minor_gc.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" +#include "caml/prims.h" + +/* [size] is a value encoding a number of bytes */ CAMLprim value caml_static_alloc(value size) { return (value) caml_stat_alloc((asize_t) Long_val(size)); @@ -36,21 +37,6 @@ CAMLprim value caml_static_free(value blk) return Val_unit; } -/* signal to the interpreter machinery that a bytecode is no more - needed (before freeing it) - this might be useful for a JIT - implementation */ - -CAMLprim value caml_static_release_bytecode(value blk, value size) -{ -#ifndef NATIVE_CODE - caml_release_bytecode((code_t) blk, (asize_t) Long_val(size)); -#else - caml_failwith("Meta.static_release_bytecode impossible with native code"); -#endif - return Val_unit; -} - - CAMLprim value caml_static_resize(value blk, value new_size) { return (value) caml_stat_resize((char *) blk, (asize_t) Long_val(new_size)); @@ -80,6 +66,7 @@ CAMLprim value caml_obj_set_tag (value arg, value new_tag) return Val_unit; } +/* [size] is a value encoding a number of blocks */ CAMLprim value caml_obj_block(value tag, value size) { value res; @@ -127,6 +114,8 @@ CAMLprim value caml_obj_dup(value arg) Change the length field of the header. Make up a white object with the leftover part of the object: this is needed in the major heap and harmless in the minor heap. + + [newsize] is a value encoding a number of words. */ CAMLprim value caml_obj_truncate (value v, value newsize) { diff --git a/byterun/parsing.c b/byterun/parsing.c index a857e39221..bd51a41eeb 100644 --- a/byterun/parsing.c +++ b/byterun/parsing.c @@ -15,10 +15,10 @@ #include <stdio.h> #include <string.h> -#include "config.h" -#include "mlvalues.h" -#include "memory.h" -#include "alloc.h" +#include "caml/config.h" +#include "caml/mlvalues.h" +#include "caml/memory.h" +#include "caml/alloc.h" #define ERRCODE 256 diff --git a/byterun/printexc.c b/byterun/printexc.c index a371a71f69..7647b3a1fd 100644 --- a/byterun/printexc.c +++ b/byterun/printexc.c @@ -16,13 +16,13 @@ #include <stdio.h> #include <stdlib.h> #include <string.h> -#include "backtrace.h" -#include "callback.h" -#include "debugger.h" -#include "fail.h" -#include "misc.h" -#include "mlvalues.h" -#include "printexc.h" +#include "caml/backtrace.h" +#include "caml/callback.h" +#include "caml/debugger.h" +#include "caml/fail.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" +#include "caml/printexc.h" struct stringbuf { char * ptr; diff --git a/byterun/roots.c b/byterun/roots.c index 43afbedc6f..f812cd75af 100644 --- a/byterun/roots.c +++ b/byterun/roots.c @@ -13,15 +13,15 @@ /* To walk the memory roots for garbage collection */ -#include "finalise.h" -#include "globroots.h" -#include "major_gc.h" -#include "memory.h" -#include "minor_gc.h" -#include "misc.h" -#include "mlvalues.h" -#include "roots.h" -#include "stacks.h" +#include "caml/finalise.h" +#include "caml/globroots.h" +#include "caml/major_gc.h" +#include "caml/memory.h" +#include "caml/minor_gc.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" +#include "caml/roots.h" +#include "caml/stacks.h" CAMLexport struct caml__roots_block *caml_local_roots = NULL; diff --git a/byterun/signals.c b/byterun/signals.c index 10f452b49a..3d642f1993 100644 --- a/byterun/signals.c +++ b/byterun/signals.c @@ -15,17 +15,17 @@ #include <signal.h> #include <errno.h> -#include "alloc.h" -#include "callback.h" -#include "config.h" -#include "fail.h" -#include "memory.h" -#include "misc.h" -#include "mlvalues.h" -#include "roots.h" -#include "signals.h" -#include "signals_machdep.h" -#include "sys.h" +#include "caml/alloc.h" +#include "caml/callback.h" +#include "caml/config.h" +#include "caml/fail.h" +#include "caml/memory.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" +#include "caml/roots.h" +#include "caml/signals.h" +#include "caml/signals_machdep.h" +#include "caml/sys.h" #ifndef NSIG #define NSIG 64 diff --git a/byterun/signals_byt.c b/byterun/signals_byt.c index 9703afaa67..f227ffa3ae 100644 --- a/byterun/signals_byt.c +++ b/byterun/signals_byt.c @@ -15,11 +15,11 @@ #include <signal.h> #include <errno.h> -#include "config.h" -#include "memory.h" -#include "osdeps.h" -#include "signals.h" -#include "signals_machdep.h" +#include "caml/config.h" +#include "caml/memory.h" +#include "caml/osdeps.h" +#include "caml/signals.h" +#include "caml/signals_machdep.h" #ifndef NSIG #define NSIG 64 @@ -38,8 +38,7 @@ void caml_process_event(void) { void (*async_action)(void); - if (caml_force_major_slice) caml_minor_collection (); - /* FIXME should be [caml_check_urgent_gc] */ + caml_check_urgent_gc (Val_unit); caml_process_pending_signals(); async_action = caml_async_action_hook; if (async_action != NULL) { diff --git a/byterun/stacks.c b/byterun/stacks.c index bc2bdc46be..94bff0b9f6 100644 --- a/byterun/stacks.c +++ b/byterun/stacks.c @@ -14,11 +14,11 @@ /* To initialize and resize the stacks */ #include <string.h> -#include "config.h" -#include "fail.h" -#include "misc.h" -#include "mlvalues.h" -#include "stacks.h" +#include "caml/config.h" +#include "caml/fail.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" +#include "caml/stacks.h" CAMLexport value * caml_stack_low; CAMLexport value * caml_stack_high; diff --git a/byterun/startup.c b/byterun/startup.c index ab926efe24..c1df12e933 100644 --- a/byterun/startup.c +++ b/byterun/startup.c @@ -17,41 +17,42 @@ #include <stdlib.h> #include <string.h> #include <fcntl.h> -#include "config.h" +#include "caml/config.h" #ifdef HAS_UNISTD #include <unistd.h> #endif #ifdef _WIN32 #include <process.h> #endif -#include "alloc.h" -#include "backtrace.h" -#include "callback.h" -#include "custom.h" -#include "debugger.h" -#include "dynlink.h" -#include "exec.h" -#include "fail.h" -#include "fix_code.h" -#include "freelist.h" -#include "gc_ctrl.h" -#include "instrtrace.h" -#include "interp.h" -#include "intext.h" -#include "io.h" -#include "memory.h" -#include "minor_gc.h" -#include "misc.h" -#include "mlvalues.h" -#include "osdeps.h" -#include "prims.h" -#include "printexc.h" -#include "reverse.h" -#include "signals.h" -#include "stacks.h" -#include "sys.h" -#include "startup.h" -#include "version.h" +#include "caml/alloc.h" +#include "caml/backtrace.h" +#include "caml/callback.h" +#include "caml/custom.h" +#include "caml/debugger.h" +#include "caml/dynlink.h" +#include "caml/exec.h" +#include "caml/fail.h" +#include "caml/fix_code.h" +#include "caml/freelist.h" +#include "caml/gc_ctrl.h" +#include "caml/instrtrace.h" +#include "caml/interp.h" +#include "caml/intext.h" +#include "caml/io.h" +#include "caml/memory.h" +#include "caml/minor_gc.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" +#include "caml/osdeps.h" +#include "caml/prims.h" +#include "caml/printexc.h" +#include "caml/reverse.h" +#include "caml/signals.h" +#include "caml/stacks.h" +#include "caml/sys.h" +#include "caml/startup.h" +#include "caml/startup_aux.h" +#include "caml/version.h" #ifndef O_BINARY #define O_BINARY 0 @@ -61,22 +62,6 @@ #define SEEK_END 2 #endif -extern int caml_parser_trace; - -CAMLexport header_t caml_atom_table[256]; - -/* Initialize the atom table */ - -static void init_atoms(void) -{ - int i; - for(i = 0; i < 256; i++) caml_atom_table[i] = Make_header(0, i, Caml_white); - if (caml_page_table_add(In_static_data, - caml_atom_table, caml_atom_table + 256) != 0) { - caml_fatal_error("Fatal error: not enough memory for initial page table"); - } -} - /* Read the trailer of a bytecode file */ static void fixup_endianness_trailer(uint32_t * p) @@ -222,15 +207,6 @@ Algorithm: */ -/* Configuration parameters and flags */ - -static uintnat percent_free_init = Percent_free_def; -static uintnat max_percent_free_init = Max_percent_free_def; -static uintnat minor_heap_init = Minor_heap_def; -static uintnat heap_chunk_init = Heap_chunk_def; -static uintnat heap_size_init = Init_heap_def; -static uintnat max_stack_init = Max_stack_def; - /* Parse options on the command line */ static int parse_command_line(char **argv) @@ -239,11 +215,9 @@ static int parse_command_line(char **argv) for(i = 1; argv[i] != NULL && argv[i][0] == '-'; i++) { switch(argv[i][1]) { -#ifdef DEBUG case 't': - caml_trace_flag++; + ++ caml_trace_level; /* ignored unless DEBUG mode */ break; -#endif case 'v': if (!strcmp (argv[i], "-version")){ printf ("The OCaml runtime, version " OCAML_VERSION_STRING "\n"); @@ -276,57 +250,6 @@ static int parse_command_line(char **argv) return i; } -/* Parse the OCAMLRUNPARAM variable */ -/* The option letter for each runtime option is the first letter of the - last word of the ML name of the option (see [stdlib/gc.mli]). - Except for l (maximum stack size) and h (initial heap size). -*/ - -/* If you change these functions, see also their copy in asmrun/startup.c */ - -static void scanmult (char *opt, uintnat *var) -{ - char mult = ' '; - unsigned int val; - sscanf (opt, "=%u%c", &val, &mult); - sscanf (opt, "=0x%x%c", &val, &mult); - switch (mult) { - case 'k': *var = (uintnat) val * 1024; break; - case 'M': *var = (uintnat) val * 1024 * 1024; break; - case 'G': *var = (uintnat) val * 1024 * 1024 * 1024; break; - default: *var = (uintnat) val; break; - } -} - -static void parse_camlrunparam(void) -{ - char *opt = getenv ("OCAMLRUNPARAM"); - uintnat p; - - if (opt == NULL) opt = getenv ("CAMLRUNPARAM"); - - if (opt != NULL){ - while (*opt != '\0'){ - switch (*opt++){ - case 'a': scanmult (opt, &p); caml_set_allocation_policy (p); break; - case 'b': caml_record_backtrace(Val_true); break; - case 'h': scanmult (opt, &heap_size_init); break; - case 'i': scanmult (opt, &heap_chunk_init); break; - case 'l': scanmult (opt, &max_stack_init); break; - case 'o': scanmult (opt, &percent_free_init); break; - case 'O': scanmult (opt, &max_percent_free_init); break; - case 'p': caml_parser_trace = 1; break; - /* case 'R': see stdlib/hashtbl.mli */ - case 's': scanmult (opt, &minor_heap_init); break; -#ifdef DEBUG - case 't': caml_trace_flag = 1; break; -#endif - case 'v': scanmult (opt, &caml_verb_gc); break; - } - } - } -} - extern void caml_init_ieee_floats (void); #ifdef _WIN32 @@ -365,7 +288,7 @@ CAMLexport void caml_main(char **argv) #ifdef DEBUG caml_verb_gc = 0xBF; #endif - parse_camlrunparam(); + caml_parse_ocamlrunparam(); pos = 0; /* First, try argv[0] (when ocamlrun is called by a bytecode program) */ @@ -400,10 +323,11 @@ CAMLexport void caml_main(char **argv) /* Read the table of contents (section descriptors) */ caml_read_section_descriptors(fd, &trail); /* Initialize the abstract machine */ - caml_init_gc (minor_heap_init, heap_size_init, heap_chunk_init, - percent_free_init, max_percent_free_init); - caml_init_stack (max_stack_init); - init_atoms(); + caml_init_gc (caml_init_minor_heap_wsz, caml_init_heap_wsz, + caml_init_heap_chunk_sz, caml_init_percent_free, + caml_init_max_percent_free); + caml_init_stack (caml_init_max_stack_wsz); + caml_init_atom_table(); /* Initialize the interpreter */ caml_interprete(NULL, 0); /* Initialize the debugger, if needed */ @@ -411,6 +335,7 @@ CAMLexport void caml_main(char **argv) /* Load the code */ caml_code_size = caml_seek_section(fd, &trail, "CODE"); caml_load_code(fd, caml_code_size); + caml_init_debug_info(); /* Build the table of primitives */ shared_lib_path = read_section(fd, &trail, "DLPT"); shared_libs = read_section(fd, &trail, "DLLS"); @@ -475,16 +400,17 @@ CAMLexport void caml_startup_code( if (cds_file != NULL) { caml_cds_file = caml_strdup(cds_file); } - parse_camlrunparam(); + caml_parse_ocamlrunparam(); exe_name = argv[0]; if (caml_executable_name(proc_self_exe, sizeof(proc_self_exe)) == 0) exe_name = proc_self_exe; caml_external_raise = NULL; /* Initialize the abstract machine */ - caml_init_gc (minor_heap_init, heap_size_init, heap_chunk_init, - percent_free_init, max_percent_free_init); - caml_init_stack (max_stack_init); - init_atoms(); + caml_init_gc (caml_init_minor_heap_wsz, caml_init_heap_wsz, + caml_init_heap_chunk_sz, caml_init_percent_free, + caml_init_max_percent_free); + caml_init_stack (caml_init_max_stack_wsz); + caml_init_atom_table(); /* Initialize the interpreter */ caml_interprete(NULL, 0); /* Initialize the debugger, if needed */ @@ -493,6 +419,7 @@ CAMLexport void caml_startup_code( caml_start_code = code; caml_code_size = code_size; caml_init_code_fragments(); + caml_init_debug_info(); if (caml_debugger_in_use) { int len, i; len = code_size / sizeof(opcode_t); diff --git a/byterun/startup_aux.c b/byterun/startup_aux.c new file mode 100644 index 0000000000..8be8926aa9 --- /dev/null +++ b/byterun/startup_aux.c @@ -0,0 +1,93 @@ +/***********************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy and Damien Doligez, 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. */ +/* */ +/***********************************************************************/ + +/* Some runtime initialization functions that are common to bytecode + and native code. */ + +#include <stdio.h> +#include "caml/backtrace.h" +#include "caml/memory.h" +#include "caml/startup_aux.h" + + +/* Initialize the atom table */ + +CAMLexport header_t caml_atom_table[256]; +void caml_init_atom_table(void) +{ + int i; + for(i = 0; i < 256; i++) caml_atom_table[i] = Make_header(0, i, Caml_white); + if (caml_page_table_add(In_static_data, + caml_atom_table, caml_atom_table + 256) != 0) { + caml_fatal_error("Fatal error: not enough memory for initial page table"); + } +} + + +/* Parse the OCAMLRUNPARAM environment variable. */ + +uintnat caml_init_percent_free = Percent_free_def; +uintnat caml_init_max_percent_free = Max_percent_free_def; +uintnat caml_init_minor_heap_wsz = Minor_heap_def; +uintnat caml_init_heap_chunk_sz = Heap_chunk_def; +uintnat caml_init_heap_wsz = Init_heap_def; +uintnat caml_init_max_stack_wsz = Max_stack_def; +extern int caml_parser_trace; +uintnat caml_trace_level = 0; + + +static void scanmult (char *opt, uintnat *var) +{ + char mult = ' '; + unsigned int val = 1; + sscanf (opt, "=%u%c", &val, &mult); + sscanf (opt, "=0x%x%c", &val, &mult); + switch (mult) { + case 'k': *var = (uintnat) val * 1024; break; + case 'M': *var = (uintnat) val * (1024 * 1024); break; + case 'G': *var = (uintnat) val * (1024 * 1024 * 1024); break; + default: *var = (uintnat) val; break; + } +} + +void caml_parse_ocamlrunparam(void) +{ + char *opt = getenv ("OCAMLRUNPARAM"); + uintnat p; + + if (opt == NULL) opt = getenv ("CAMLRUNPARAM"); + + if (opt != NULL){ + while (*opt != '\0'){ + switch (*opt++){ + case 'a': scanmult (opt, &p); caml_set_allocation_policy (p); break; + case 'b': scanmult (opt, &p); caml_record_backtrace(Val_bool (p)); break; + case 'h': scanmult (opt, &caml_init_heap_wsz); break; + case 'i': scanmult (opt, &caml_init_heap_chunk_sz); break; + case 'l': scanmult (opt, &caml_init_max_stack_wsz); break; + case 'o': scanmult (opt, &caml_init_percent_free); break; + case 'O': scanmult (opt, &caml_init_max_percent_free); break; + case 'p': scanmult (opt, &p); caml_parser_trace = p; break; + case 'R': break; /* see stdlib/hashtbl.mli */ + case 's': scanmult (opt, &caml_init_minor_heap_wsz); break; + case 't': scanmult (opt, &caml_trace_level); break; + case 'v': scanmult (opt, &caml_verb_gc); break; + case 'W': scanmult (opt, &p); + caml_ml_enable_runtime_warnings(Val_bool (p)); break; + } + while (*opt != '\0'){ + if (*opt++ == ',') break; + } + } + } +} diff --git a/byterun/str.c b/byterun/str.c index 9c7baa1b1d..5ad4e29419 100644 --- a/byterun/str.c +++ b/byterun/str.c @@ -17,14 +17,12 @@ #include <ctype.h> #include <stdio.h> #include <stdarg.h> -#include "alloc.h" -#include "fail.h" -#include "mlvalues.h" -#include "misc.h" -#ifdef HAS_LOCALE -#include <locale.h> -#endif +#include "caml/alloc.h" +#include "caml/fail.h" +#include "caml/mlvalues.h" +#include "caml/misc.h" +/* returns a number of bytes (chars) */ CAMLexport mlsize_t caml_string_length(value s) { mlsize_t temp; @@ -33,6 +31,7 @@ CAMLexport mlsize_t caml_string_length(value s) return temp - Byte (s, temp); } +/* returns a value that represents a number of bytes (chars) */ CAMLprim value caml_ml_string_length(value s) { mlsize_t temp; @@ -41,6 +40,7 @@ CAMLprim value caml_ml_string_length(value s) return Val_long(temp - Byte (s, temp)); } +/* [len] is a value that represents a number of bytes (chars) */ CAMLprim value caml_create_string(value len) { mlsize_t size = Long_val(len); @@ -276,21 +276,6 @@ CAMLprim value caml_fill_string(value s, value offset, value len, value init) return Val_unit; } -CAMLprim value caml_is_printable(value chr) -{ - int c; - -#ifdef HAS_LOCALE - static int locale_is_set = 0; - if (! locale_is_set) { - setlocale(LC_CTYPE, ""); - locale_is_set = 1; - } -#endif - c = Int_val(chr); - return Val_bool(isprint(c)); -} - CAMLprim value caml_bitvect_test(value bv, value n) { int pos = Int_val(n); diff --git a/byterun/sys.c b/byterun/sys.c index cd49dd9203..97c576dd59 100644 --- a/byterun/sys.c +++ b/byterun/sys.c @@ -25,7 +25,7 @@ #if !_WIN32 #include <sys/wait.h> #endif -#include "config.h" +#include "caml/config.h" #ifdef HAS_UNISTD #include <unistd.h> #endif @@ -39,16 +39,16 @@ #ifdef HAS_GETTIMEOFDAY #include <sys/time.h> #endif -#include "alloc.h" -#include "debugger.h" -#include "fail.h" -#include "instruct.h" -#include "mlvalues.h" -#include "osdeps.h" -#include "signals.h" -#include "stacks.h" -#include "sys.h" -#include "gc_ctrl.h" +#include "caml/alloc.h" +#include "caml/debugger.h" +#include "caml/fail.h" +#include "caml/instruct.h" +#include "caml/mlvalues.h" +#include "caml/osdeps.h" +#include "caml/signals.h" +#include "caml/stacks.h" +#include "caml/sys.h" +#include "caml/gc_ctrl.h" static char * error_message(void) { @@ -97,7 +97,7 @@ 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) (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 = @@ -280,7 +280,7 @@ CAMLprim value caml_sys_getenv(value var) } char * caml_exe_name; -static char ** caml_main_argv; +char ** caml_main_argv; CAMLprim value caml_sys_get_argv(value unit) { @@ -412,11 +412,24 @@ CAMLprim value caml_sys_const_big_endian(value unit) #endif } +/* returns a value that represents a number of bits */ CAMLprim value caml_sys_const_word_size(value unit) { return Val_long(8 * sizeof(value)); } +/* returns a value that represents a number of bits */ +CAMLprim value caml_sys_const_int_size(value unit) +{ + return Val_long(8 * sizeof(value) - 1) ; +} + +/* returns a value that represents a number of words */ +CAMLprim value caml_sys_const_max_wosize(value unit) +{ + return Val_long(Max_wosize) ; +} + CAMLprim value caml_sys_const_ostype_unix(value unit) { return Val_long(0 == strcmp(OCAML_OS_TYPE,"Unix")); diff --git a/byterun/terminfo.c b/byterun/terminfo.c index 04086a3fbd..1d0fdc42d1 100644 --- a/byterun/terminfo.c +++ b/byterun/terminfo.c @@ -13,11 +13,11 @@ /* Read and output terminal commands */ -#include "config.h" -#include "alloc.h" -#include "fail.h" -#include "io.h" -#include "mlvalues.h" +#include "caml/config.h" +#include "caml/alloc.h" +#include "caml/fail.h" +#include "caml/io.h" +#include "caml/mlvalues.h" #define Uninitialised (Val_int(0)) #define Bad_term (Val_int(1)) diff --git a/byterun/unix.c b/byterun/unix.c index be2c39b158..38ddee0056 100644 --- a/byterun/unix.c +++ b/byterun/unix.c @@ -22,9 +22,9 @@ #include <sys/types.h> #include <sys/stat.h> #include <fcntl.h> -#include "config.h" +#include "caml/config.h" #ifdef SUPPORT_DYNAMIC_LINKING -#ifdef __CYGWIN32__ +#ifdef __CYGWIN__ #include "flexdll.h" #else #include <dlfcn.h> @@ -38,9 +38,9 @@ #else #include <sys/dir.h> #endif -#include "memory.h" -#include "misc.h" -#include "osdeps.h" +#include "caml/memory.h" +#include "caml/misc.h" +#include "caml/osdeps.h" #ifndef S_ISREG #define S_ISREG(mode) (((mode) & S_IFMT) == S_IFREG) @@ -86,7 +86,7 @@ char * caml_search_in_path(struct ext_table * path, char * name) return caml_strdup(name); } -#ifdef __CYGWIN32__ +#ifdef __CYGWIN__ /* Cygwin needs special treatment because of the implicit ".exe" at the end of executable file names */ @@ -137,7 +137,7 @@ char * caml_search_exe_in_path(char * name) caml_ext_table_init(&path, 8); tofree = caml_decompose_path(&path, getenv("PATH")); -#ifndef __CYGWIN32__ +#ifndef __CYGWIN__ res = caml_search_in_path(&path, name); #else res = cygwin_search_exe_in_path(&path, name); @@ -159,7 +159,7 @@ char * caml_search_dll_in_path(struct ext_table * path, char * name) } #ifdef SUPPORT_DYNAMIC_LINKING -#ifdef __CYGWIN32__ +#ifdef __CYGWIN__ /* Use flexdll */ void * caml_dlopen(char * libname, int for_execution, int global) diff --git a/byterun/weak.c b/byterun/weak.c index 756996710c..3614d11cf8 100644 --- a/byterun/weak.c +++ b/byterun/weak.c @@ -15,17 +15,18 @@ #include <string.h> -#include "alloc.h" -#include "fail.h" -#include "major_gc.h" -#include "memory.h" -#include "mlvalues.h" +#include "caml/alloc.h" +#include "caml/fail.h" +#include "caml/major_gc.h" +#include "caml/memory.h" +#include "caml/mlvalues.h" value caml_weak_list_head = 0; static value weak_dummy = 0; value caml_weak_none = (value) &weak_dummy; +/* [len] is a value that represents a number of words (fields) */ CAMLprim value caml_weak_create (value len) { mlsize_t size, i; diff --git a/byterun/win32.c b/byterun/win32.c index 67e9683211..f26caf8fd7 100644 --- a/byterun/win32.c +++ b/byterun/win32.c @@ -25,12 +25,13 @@ #include <errno.h> #include <string.h> #include <signal.h> -#include "fail.h" -#include "memory.h" -#include "misc.h" -#include "osdeps.h" -#include "signals.h" -#include "sys.h" +#include "caml/address_class.h" +#include "caml/fail.h" +#include "caml/memory.h" +#include "caml/misc.h" +#include "caml/osdeps.h" +#include "caml/signals.h" +#include "caml/sys.h" #include <flexdll.h> @@ -418,14 +419,8 @@ static void caml_reset_stack (void *faulting_address) caml_raise_stack_overflow(); } -extern char * caml_code_area_start, * caml_code_area_end; CAMLextern int caml_is_in_code(void *); -#define Is_in_code_area(pc) \ - ( ((char *)(pc) >= caml_code_area_start && \ - (char *)(pc) <= caml_code_area_end) \ - || (Classify_addr(pc) & In_code_area) ) - static LONG CALLBACK caml_UnhandledExceptionFilter (EXCEPTION_POINTERS* exn_info) { diff --git a/config/Makefile.mingw b/config/Makefile.mingw index c204980367..5b4658f71b 100644 --- a/config/Makefile.mingw +++ b/config/Makefile.mingw @@ -68,7 +68,7 @@ X11_INCLUDES= X11_LINK= BYTECCRPATH= SUPPORTS_SHARED_LIBRARIES=true -SHAREDCCCOMPOPTS= +SHAREDCCCOMPOPTS=-O MKSHAREDLIBRPATH= NATIVECCPROFOPTS= NATIVECCRPATH= diff --git a/config/Makefile.mingw64 b/config/Makefile.mingw64 index 0a3bdfbd09..19a9b94376 100644 --- a/config/Makefile.mingw64 +++ b/config/Makefile.mingw64 @@ -68,7 +68,7 @@ X11_INCLUDES= X11_LINK= BYTECCRPATH= SUPPORTS_SHARED_LIBRARIES=true -SHAREDCCCOMPOPTS= +SHAREDCCCOMPOPTS=-O MKSHAREDLIBRPATH= NATIVECCPROFOPTS= NATIVECCRPATH= diff --git a/config/Makefile.msvc b/config/Makefile.msvc index abe37bf324..4d399cf49b 100644 --- a/config/Makefile.msvc +++ b/config/Makefile.msvc @@ -60,7 +60,7 @@ X11_INCLUDES= X11_LINK= BYTECCRPATH= SUPPORTS_SHARED_LIBRARIES=true -SHAREDCCCOMPOPTS= +SHAREDCCCOMPOPTS=-Ox NATIVECCPROFOPTS= NATIVECCRPATH= ASM=ml -nologo -coff -Cp -c -Fo diff --git a/config/Makefile.msvc64 b/config/Makefile.msvc64 index c33ba1fb70..6a9650ba5e 100644 --- a/config/Makefile.msvc64 +++ b/config/Makefile.msvc64 @@ -60,7 +60,7 @@ X11_INCLUDES= X11_LINK= BYTECCRPATH= SUPPORTS_SHARED_LIBRARIES=true -SHAREDCCCOMPOPTS= +SHAREDCCCOMPOPTS=-Ox NATIVECCPROFOPTS= NATIVECCRPATH= ASM=ml64 -nologo -Cp -c -Fo diff --git a/config/auto-aux/nanosecond_stat.c b/config/auto-aux/nanosecond_stat.c new file mode 100644 index 0000000000..fc92e67b9c --- /dev/null +++ b/config/auto-aux/nanosecond_stat.c @@ -0,0 +1,28 @@ +/***********************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Jeremie Dimino, Jane Street Group, LLC */ +/* */ +/* Copyright 2015 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. */ +/* */ +/***********************************************************************/ + +#define _GNU_SOURCE +#include <sys/types.h> +#include <sys/stat.h> +#include <unistd.h> + +#include "../../otherlibs/unix/nanosecond_stat.h" + +int main() { + struct stat *buf; + double a, m, c; + a = (double)NSEC(buf, a); + m = (double)NSEC(buf, m); + c = (double)NSEC(buf, c); + return 0; +} diff --git a/config/auto-aux/searchpath b/config/auto-aux/searchpath index 79d7fcaebc..e229ac921b 100755 --- a/config/auto-aux/searchpath +++ b/config/auto-aux/searchpath @@ -15,9 +15,18 @@ # Find a program in the path +doprint=false +case $1 in + -p) shift; doprint=true;; + *) ;; +esac + IFS=':' for dir in $PATH; do if test -z "$dir"; then dir=.; fi - if test -f $dir/$1; then exit 0; fi + if test -f $dir/$1 -a -x $dir/$1; then + if $doprint; then echo "$dir/$1"; fi + exit 0 + fi done exit 1 @@ -13,9 +13,12 @@ # # ######################################################################### +echo Configuring OCaml version `head -1 VERSION` + configure_options="$*" prefix=/usr/local bindir='' +target_bindir='' libdir='' mandir='' manext=1 @@ -92,6 +95,8 @@ while : ; do prefix=$2; shift;; -bindir|--bindir) bindir=$2; shift;; + -target-bindir|--target-bindir) + target_bindir="$2"; shift;; -libdir|--libdir) libdir=$2; shift;; -mandir|--mandir) @@ -237,17 +242,23 @@ else fi inf "Configuring for target $target ..." +if [ x"$host" = x"$target" ]; then + cross_compiler=false +else + cross_compiler=true +fi + # Do we have gcc? if test -z "$ccoption"; then if sh ./searchpath "${TOOLPREF}gcc"; then cc="${TOOLPREF}gcc" else - if test x"$host" = x"$target"; then - cc="cc" - else + if $cross_compiler; then err "No cross-compiler found for ${target}.\n" \ "It should be named ${TOOLPREF}gcc and be in the PATH." + else + cc="cc" fi fi else @@ -375,10 +386,15 @@ case "$bytecc,$target" in *,powerpc-*-aix*) bytecccompopts="-D_XOPEN_SOURCE=500";; *gcc*,*-*-cygwin*) + case $target in + i686-*) flavor=cygwin;; + x86_64-*) flavor=cygwin64;; + *) err "unknown cygwin variant";; + esac bytecccompopts="-fno-defer-pop $gcc_warnings -U_WIN32" dllccompopts="-U_WIN32 -DCAML_DLL" if test $with_sharedlibs = yes; then - flexlink="flexlink -chain cygwin -merge-manifest -stack 16777216" + flexlink="flexlink -chain $flavor -merge-manifest -stack 16777216" flexdir=`$flexlink -where | dos2unix` if test -z "$flexdir"; then wrn "flexlink not found: native shared libraries won't be available." @@ -443,7 +459,7 @@ case $? in 1) err "The C compiler $cc is not ANSI-compliant.\n" \ "You need an ANSI C compiler to build OCaml.";; *) - if test x"$host" != x"$target"; then + if $cross_compiler; then wrn "Unable to compile the test program.\n" \ "This failure is expected for cross-compilation:\n" \ "we will assume the C compiler is ANSI-compliant." @@ -453,29 +469,43 @@ case $? in fi;; esac -# Determine which ocamlrun executable to use; for cross-compilation, a native -# "ocamlrun" executable must be available on the system. -if test x"$target" != x"$host"; then +# For cross-compilation, we need a host-based ocamlrun and ocamlyacc, +# and the user must specify the target BINDIR +if $cross_compiler; then if ! sh ./searchpath ocamlrun; then err "Cross-compilation requires an ocaml runtime environment\n" \ "(the ocamlrun binary). Moreover, its version must be the same\n" \ "as the one you're trying to build (`cut -f1 -d+ < ../../VERSION`)." else - ocaml_system_version=`ocamlrun -version | sed 's/[^0-9]*\([0-9.]\+\).*/\1/'` - ocaml_source_version=`sed -n '1 s/\([0-9\.]\+\).*/\1/ p' < ../../VERSION` + ocaml_system_version=`ocamlrun -version | sed 's/[^0-9]*\([0-9.]*\).*/\1/'` + ocaml_source_version=`sed -n '1 s/\([0-9\.]*\).*/\1/ p' < ../../VERSION` if test x"$ocaml_system_version" != x"$ocaml_source_version"; then err "While you have an ocaml runtime environment, its version\n" \ "($ocaml_system_version) doesn't match the version of these sources\n" \ "($ocaml_source_version)." else - CAMLRUN="ocamlrun" + echo "CAMLRUN=`./searchpath -p ocamlrun`" >> Makefile + fi + fi + + if ! sh ./searchpath ocamlyacc; then + err "Cross-compilation requires an ocamlyacc binary." + else + ocamlyacc 2>/dev/null + if test "$?" -ne 1; then + err "While you have an ocamlyacc binary, it cannot be executed successfully." + else + echo "CAMLYACC=`./searchpath -p ocamlyacc`" >> Makefile fi fi -else - CAMLRUN=`cd ../.. && pwd`/boot/ocamlrun -fi -echo "CAMLRUN=$CAMLRUN" >> Makefile + if [ -z "$target_bindir" ]; then + err "Cross-compilation requires -target-bindir." + else + echo "TARGET_BINDIR=$target_bindir" >> Makefile + fi +fi # cross-compiler + # Check the sizes of data types # OCaml needs a 32 or 64 bit architecture, a 32-bit integer type and @@ -825,14 +855,13 @@ esac # Some platforms exist both in 32-bit and 64-bit variants, not distinguished # by $target. Turn off native code compilation on platforms where 64-bit mode -# is not supported. (PR#4441) +# is not supported (PR#4441). +# Sometimes, it's 32-bit mode that is not supported (PR#6722). -if $arch64; then - case "$arch,$model" in - sparc,default|power,ppc) +case "$arch64,$arch,$model" in + true,sparc,*|true,power,ppc|false,amd64,*) arch=none; model=default; system=unknown;; - esac -fi +esac if test -z "$ccoption"; then nativecc="$bytecc" @@ -907,6 +936,8 @@ case "$arch,$system" in case "$nativecc" in gcc*) ;; *) cc_profile='-xpg';; esac;; amd64,linux) profiling='prof';; amd64,openbsd) profiling='prof';; + amd64,freebsd) profiling='prof';; + amd64,netbsd) profiling='prof';; amd64,gnu) profiling='prof';; arm,linux*) profiling='prof';; power,elf) profiling='prof';; @@ -948,7 +979,8 @@ if (SHELL=/bin/sh; export SHELL; (./sharpbang || ./sharpbang2) >/dev/null); then "under Cygwin" echo "SHARPBANGSCRIPTS=false" >> Makefile;; *-*-mingw*) - inf "We won't use it, though, because it's on the target platform it would be used and windows doesn't support it." + inf "We won't use it, though, because it's on the target platform " \ + "it would be used and windows doesn't support it." echo "SHARPBANGSCRIPTS=false" >> Makefile;; *) echo "SHARPBANGSCRIPTS=true" >> Makefile;; @@ -1284,6 +1316,15 @@ if sh ./hasgot pwrite; then echo "#define HAS_PWRITE" >> s.h fi +nanosecond_stat=none +for i in 1 2 3; do + if sh ./trycompile -DHAS_NANOSECOND_STAT=$i nanosecond_stat.c; then nanosecond_stat=$i; break; fi +done +if test $nanosecond_stat != "none"; then + inf "stat() supports nanosecond precision." + echo "#define HAS_NANOSECOND_STAT $nanosecond_stat" >> s.h +fi + nargs=none for i in 5 6; do if sh ./trycompile -DNUM_ARGS=${i} gethostbyname.c; then nargs=$i; break; fi @@ -1593,9 +1634,21 @@ if sh ./hasgot -DPACKAGE=ocaml -i bfd.h && \ inf "BFD library found." echo "#define HAS_LIBBFD" >> s.h echo "LIBBFD_LINK=-lbfd -ldl -liberty -lz" >> Makefile + echo LIBBFD_INCLUDE= >>Makefile +elif sh ./hasgot -DPACKAGE=ocaml -I/opt/local/include -i bfd.h && \ + sh ./hasgot -DPACKAGE=ocaml -L/opt/local/lib -lbfd -ldl \ + -liberty -lz -lintl bfd_openr +then + # MacOSX with binutils from MacPorts + inf "BFD library found." + echo "#define HAS_LIBBFD" >> s.h + echo "LIBBFD_LINK=-L/opt/local/lib -lbfd -ldl -liberty -lz -lintl" >> Makefile + echo LIBBFD_INCLUDE=-I/opt/local/include >>Makefile else - wrn "BFD library not found, 'objinfo' will be unable to display info on .cmxs files." + wrn "BFD library not found, 'objinfo' will be unable to display info" \ + " on .cmxs files." echo "LIBBFD_LINK=" >> Makefile + echo "LIBBFD_INCLUDE=" >> Makefile fi # Check whether assembler supports CFI directives @@ -1631,6 +1684,12 @@ if $no_naked_pointers; then echo "#define NO_NAKED_POINTERS" >> m.h fi +# Add Unix-style optimization flag +bytecccompopts="-O $bytecccompopts" +dllcccompopts="-O $dllcccompopts" +nativecccompopts="-O $nativecccompopts" +sharedcccompopts="-O $sharedcccompopts" + # Final twiddling of compiler options to work around known bugs nativeccprofopts="$nativecccompopts" @@ -1659,8 +1718,8 @@ SYSLIB=-l\$(1) #ml let syslib x = "-l"^x;; ### How to build a static library -MKLIB=ar rc \$(1) \$(2); ranlib \$(1) -#ml let mklib out files opts = Printf.sprintf "ar rc %s %s %s; ranlib %s" out opts files out;; +MKLIB=${TOOLPREF}ar rc \$(1) \$(2); ${TOOLPREF}ranlib \$(1) +#ml let mklib out files opts = Printf.sprintf "${TOOLPREF}ar rc %s %s %s; ${TOOLPREF}ranlib %s" out opts files out;; EOF echo "ARCH=$arch" >> Makefile echo "MODEL=$model" >> Makefile @@ -1701,6 +1760,11 @@ echo "MKEXEDEBUGFLAG=$mkexedebugflag" >> Makefile echo "MKDLL=$mksharedlib" >> Makefile echo "MKMAINDLL=$mkmaindll" >> Makefile echo "RUNTIMED=${debugruntime}" >>Makefile +if $shared_libraries_supported; then + echo "SHARED=shared" >>Makefile +else + echo "SHARED=noshared" >>Makefile +fi echo "WITH_DEBUGGER=${with_debugger}" >>Makefile echo "WITH_OCAMLDOC=${with_ocamldoc}" >>Makefile echo "WITH_OCAMLBUILD=${with_ocamlbuild}" >>Makefile diff --git a/debugger/Makefile.shared b/debugger/Makefile.shared index fed1d26dab..f3859c63d2 100644 --- a/debugger/Makefile.shared +++ b/debugger/Makefile.shared @@ -11,15 +11,15 @@ ######################################################################### include ../config/Makefile +CAMLRUN ?= ../boot/ocamlrun +CAMLYACC ?= ../boot/ocamlyacc -ROOTDIR=.. -CAMLC=$(ROOTDIR)/boot/ocamlrun $(ROOTDIR)/ocamlc -nostdlib -I $(ROOTDIR)/stdlib +CAMLC=$(CAMLRUN) ../ocamlc -nostdlib -I ../stdlib COMPFLAGS=-warn-error A -safe-string $(INCLUDES) LINKFLAGS=-linkall -I $(UNIXDIR) -CAMLYACC=../boot/ocamlyacc YACCFLAGS= -CAMLLEX=../boot/ocamlrun ../boot/ocamllex -CAMLDEP=../boot/ocamlrun ../tools/ocamldep +CAMLLEX=$(CAMLRUN) ../boot/ocamllex +CAMLDEP=$(CAMLRUN) ../tools/ocamldep DEPFLAGS=$(INCLUDES) INSTALL_BINDIR=$(DESTDIR)$(BINDIR) @@ -32,7 +32,7 @@ OTHEROBJS=\ $(UNIXDIR)/unix.cma \ ../utils/misc.cmo ../utils/config.cmo ../utils/tbl.cmo \ ../utils/clflags.cmo ../utils/consistbl.cmo ../utils/warnings.cmo \ - ../parsing/location.cmo ../parsing/longident.cmo \ + ../parsing/location.cmo ../parsing/longident.cmo ../parsing/docstrings.cmo \ ../parsing/ast_helper.cmo ../parsing/ast_mapper.cmo \ ../typing/ident.cmo ../typing/path.cmo ../typing/types.cmo \ ../typing/btype.cmo ../typing/primitive.cmo ../typing/typedtree.cmo \ diff --git a/debugger/command_line.ml b/debugger/command_line.ml index a4647110d6..9fa9ff9d8d 100644 --- a/debugger/command_line.ml +++ b/debugger/command_line.ml @@ -150,9 +150,9 @@ let convert_module mdle = match mdle with | Some m -> (* Strip .ml extension if any, and capitalize *) - String.capitalize(if Filename.check_suffix m ".ml" - then Filename.chop_suffix m ".ml" - else m) + String.capitalize_ascii(if Filename.check_suffix m ".ml" + then Filename.chop_suffix m ".ml" + else m) | None -> try (get_current_event ()).ev_module @@ -270,7 +270,7 @@ let instr_dir ppf lexbuf = let new_directory' = List.rev new_directory in match new_directory' with | mdl :: for_keyw :: tl - when (String.lowercase for_keyw) = "for" && (List.length tl) > 0 -> + when (String.lowercase_ascii for_keyw) = "for" && (List.length tl) > 0 -> List.iter (function x -> add_path_for mdl (expand_path x)) tl | _ -> List.iter (function x -> add_path (expand_path x)) new_directory' @@ -291,6 +291,11 @@ let instr_kill ppf lexbuf = show_no_point() end +let instr_pid ppf lexbuf = + eol lexbuf; + if not !loaded then error "The program is not being run."; + fprintf ppf "@[%d@]@." !current_checkpoint.c_pid + let instr_run ppf lexbuf = eol lexbuf; ensure_loaded (); @@ -514,6 +519,30 @@ let instr_print ppf lexbuf = print_command !max_printer_depth ppf lexbuf let instr_display ppf lexbuf = print_command 1 ppf lexbuf +let instr_address ppf lexbuf = + let exprs = expression_list_eol Lexer.lexeme lexbuf in + ensure_loaded (); + let env = + try + env_of_event !selected_event + with + | Envaux.Error msg -> + Envaux.report_error ppf msg; + raise Toplevel + in + let print_addr expr = + let (v, _ty) = + try Eval.expression !selected_event env expr + with Eval.Error msg -> + Eval.report_error ppf msg; + raise Toplevel + in + match Remote_value.pointer v with + | "" -> fprintf ppf "[not a remote value]@." + | s -> fprintf ppf "0x%s@." s + in + List.iter print_addr exprs + (* Loading of command files *) let extract_filename arg = @@ -610,8 +639,12 @@ let instr_break ppf lexbuf = let module_name = convert_module (module_of_longident mdle) in new_breakpoint (try + let ev = event_at_pos module_name 0 in + let ev_pos = + {Lexing.dummy_pos with + pos_fname = (Events.get_pos ev).pos_fname} in let buffer = - try get_buffer Lexing.dummy_pos module_name with + try get_buffer ev_pos module_name with | Not_found -> eprintf "No source file for %s.@." module_name; raise Toplevel @@ -987,6 +1020,12 @@ With no argument, reset the search path." }; { instr_name = "kill"; instr_prio = false; instr_action = instr_kill; instr_repeat = true; instr_help = "kill the program being debugged." }; + { instr_name = "pid"; instr_prio = false; + instr_action = instr_pid; instr_repeat = true; instr_help = +"print the process ID of the current active process." }; + { instr_name = "address"; instr_prio = false; + instr_action = instr_address; instr_repeat = true; instr_help = +"print the raw address of a value." }; { instr_name = "help"; instr_prio = false; instr_action = instr_help; instr_repeat = true; instr_help = "print list of commands." }; diff --git a/debugger/debugcom.ml b/debugger/debugcom.ml index ac91df799f..a7512898ae 100644 --- a/debugger/debugcom.ml +++ b/debugger/debugcom.ml @@ -213,14 +213,16 @@ module Remote_value = | Local obj -> Obj.is_block obj | Remote v -> Obj.is_block (Array.unsafe_get (Obj.magic v : Obj.t array) 0) - let tag = function - | Local obj -> Obj.tag obj - | Remote v -> - output_char !conn.io_out 'H'; - output_remote_value !conn.io_out v; - flush !conn.io_out; - let header = input_binary_int !conn.io_in in - header land 0xFF + let tag obj = + if not (is_block obj) then Obj.int_tag + else match obj with + | Local obj -> Obj.tag obj + | Remote v -> + output_char !conn.io_out 'H'; + output_remote_value !conn.io_out v; + flush !conn.io_out; + let header = input_binary_int !conn.io_in in + header land 0xFF let size = function | Local obj -> Obj.size obj @@ -291,4 +293,14 @@ module Remote_value = (* string equality -> equality of remote pointers *) | (_, _) -> false + let pointer rv = + match rv with + | Remote v -> + let bytes = ref [] in + String.iter (fun c -> bytes := c :: !bytes) v; + let obytes = if Sys.big_endian then List.rev !bytes else !bytes in + let to_hex c = Printf.sprintf "%02x" (Char.code c) in + String.concat "" (List.map to_hex obytes) + | Local _ -> "" + end diff --git a/debugger/debugcom.mli b/debugger/debugcom.mli index 3dce2abb41..c37ce6fc6f 100644 --- a/debugger/debugcom.mli +++ b/debugger/debugcom.mli @@ -105,4 +105,7 @@ module Remote_value : val accu : unit -> t val closure_code : t -> int + (* Returns a hexadecimal representation of the remote address, + or [""] if the value is local. *) + val pointer : t -> string end diff --git a/debugger/loadprinter.ml b/debugger/loadprinter.ml index 98e79d7963..16d6e9f2b4 100644 --- a/debugger/loadprinter.ml +++ b/debugger/loadprinter.ml @@ -70,7 +70,7 @@ let rec loadfiles ppf name = true with | Dynlink.Error (Dynlink.Unavailable_unit unit) -> - loadfiles ppf (String.uncapitalize unit ^ ".cmo") + loadfiles ppf (String.uncapitalize_ascii unit ^ ".cmo") && loadfiles ppf name | Not_found -> diff --git a/debugger/source.ml b/debugger/source.ml index aa9ec70831..fa2b3c7e46 100644 --- a/debugger/source.ml +++ b/debugger/source.ml @@ -21,6 +21,8 @@ let source_extensions = [".ml"] (*** Conversion function. ***) let source_of_module pos mdle = + let pos_fname = pos.Lexing.pos_fname in + if Sys.file_exists pos_fname then pos_fname else let is_submodule m m' = let len' = String.length m' in try diff --git a/debugger/time_travel.ml b/debugger/time_travel.ml index c55c754019..37bbe390dd 100644 --- a/debugger/time_travel.ml +++ b/debugger/time_travel.ml @@ -384,6 +384,7 @@ let forget_process fd pid = let checkpoint = List.find (function c -> c.c_pid = pid) (!current_checkpoint::!checkpoints) in + if pid > 0 then begin Printf.eprintf "Lost connection with process %d" pid; let kont = if checkpoint == !current_checkpoint then begin @@ -409,6 +410,7 @@ let forget_process fd pid = if checkpoint.c_parent.c_pid > 0 then wait_child checkpoint.c_parent.c_fd; kont () + end (* Try to recover when the current checkpoint is lost. *) let recover () = diff --git a/driver/compenv.ml b/driver/compenv.ml index 82704fd8f9..6f3567e882 100644 --- a/driver/compenv.ml +++ b/driver/compenv.ml @@ -56,26 +56,28 @@ let first_objfiles = ref [] let last_objfiles = ref [] (* Check validity of module name *) -let check_unit_name ppf filename name = +let is_unit_name name = try begin match name.[0] with | 'A'..'Z' -> () | _ -> - Location.print_warning (Location.in_file filename) ppf - (Warnings.Bad_module_name name); raise Exit; end; for i = 1 to String.length name - 1 do match name.[i] with | 'A'..'Z' | 'a'..'z' | '0'..'9' | '_' | '\'' -> () | _ -> - Location.print_warning (Location.in_file filename) ppf - (Warnings.Bad_module_name name); raise Exit; done; - with Exit -> () + true + with Exit -> false ;; +let check_unit_name ppf filename name = + if not (is_unit_name name) then + Location.print_warning (Location.in_file filename) ppf + (Warnings.Bad_module_name name);; + (* Compute name of module from output file name *) let module_of_filename ppf inputfile outputprefix = let basename = Filename.basename outputprefix in @@ -85,7 +87,7 @@ let module_of_filename ppf inputfile outputprefix = String.sub basename 0 pos with Not_found -> basename in - let name = String.capitalize name in + let name = String.capitalize_ascii name in check_unit_name ppf inputfile name; name ;; @@ -175,6 +177,7 @@ let read_OCAMLPARAM ppf position = | "verbose" -> set "verbose" [ verbose ] v | "nopervasives" -> set "nopervasives" [ nopervasives ] v | "slash" -> set "slash" [ force_slash ] v (* for ocamldep *) + | "keep-docs" -> set "keep-docs" [ Clflags.keep_docs ] v | "keep-locs" -> set "keep-locs" [ Clflags.keep_locs ] v | "compact" -> clear "compact" [ optimize_for_speed ] v @@ -265,6 +268,10 @@ let read_OCAMLPARAM ppf position = first_objfiles := v :: !first_objfiles end + | "pic" -> + if !native_code then + set "pic" [ pic_code ] v + | "can-discard" -> can_discard := v ::!can_discard diff --git a/driver/compenv.mli b/driver/compenv.mli index 85d588ef6e..59cd10124f 100644 --- a/driver/compenv.mli +++ b/driver/compenv.mli @@ -10,7 +10,6 @@ (* *) (***********************************************************************) -(* val check_unit_name : Format.formatter -> string -> string -> unit *) val module_of_filename : Format.formatter -> string -> string -> string val output_prefix : string -> string @@ -35,3 +34,10 @@ type readenv_position = Before_args | Before_compile | Before_link val readenv : Format.formatter -> readenv_position -> unit + +(* [is_unit_name name] returns true only if [name] can be used as a + correct module name *) +val is_unit_name : string -> bool +(* [check_unit_name ppf filename name] prints a warning in [filename] + on [ppf] if [name] should not be used as a module name. *) +val check_unit_name : Format.formatter -> string -> string -> unit diff --git a/driver/compile.ml b/driver/compile.ml index 3b5d2ae077..b18e611a00 100644 --- a/driver/compile.ml +++ b/driver/compile.ml @@ -60,51 +60,45 @@ let implementation ppf sourcefile outputprefix = 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 - let comp ast = - ast + try + let (typedtree, coercion) = + Pparse.parse_implementation ~tool_name ppf sourcefile ++ print_if ppf Clflags.dump_parsetree Printast.implementation ++ print_if ppf Clflags.dump_source Pprintast.structure ++ Typemod.type_implementation sourcefile outputprefix modulename env ++ print_if ppf Clflags.dump_typedtree - Printtyped.implementation_with_coercion - ++ (fun _ -> ()); - Warnings.check_fatal (); - Stypes.dump (Some (outputprefix ^ ".annot")) + Printtyped.implementation_with_coercion in - try comp (Pparse.parse_implementation ~tool_name ppf sourcefile) - with x -> - Stypes.dump (Some (outputprefix ^ ".annot")); - raise x - end else begin - let objfile = outputprefix ^ ".cmo" in - let oc = open_out_bin objfile in - let comp ast = - ast - ++ print_if ppf Clflags.dump_parsetree Printast.implementation - ++ print_if ppf Clflags.dump_source Pprintast.structure - ++ Typemod.type_implementation sourcefile outputprefix modulename env - ++ print_if ppf Clflags.dump_typedtree - Printtyped.implementation_with_coercion - ++ Translmod.transl_implementation modulename - ++ print_if ppf Clflags.dump_rawlambda Printlambda.lambda - ++ Simplif.simplify_lambda - ++ 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 objfile; + if !Clflags.print_types then begin Warnings.check_fatal (); - close_out oc; Stypes.dump (Some (outputprefix ^ ".annot")) - in - try comp (Pparse.parse_implementation ~tool_name ppf sourcefile) - with x -> - close_out oc; - remove_file objfile; - Stypes.dump (Some (outputprefix ^ ".annot")); - raise x - end + end else begin + let bytecode = + (typedtree, coercion) + ++ Translmod.transl_implementation modulename + ++ print_if ppf Clflags.dump_rawlambda Printlambda.lambda + ++ Simplif.simplify_lambda + ++ print_if ppf Clflags.dump_lambda Printlambda.lambda + ++ Bytegen.compile_implementation modulename + ++ print_if ppf Clflags.dump_instr Printinstr.instrlist + in + let objfile = outputprefix ^ ".cmo" in + let oc = open_out_bin objfile in + try + bytecode + ++ Emitcode.to_file oc modulename objfile; + Warnings.check_fatal (); + close_out oc; + Stypes.dump (Some (outputprefix ^ ".annot")) + with x -> + close_out oc; + remove_file objfile; + raise x + end + with x -> + Stypes.dump (Some (outputprefix ^ ".annot")); + raise x let c_file name = Location.input_name := name; - if Ccomp.compile_file name <> 0 then exit 2 + if Ccomp.compile_file ~output_name:!Clflags.output_name name <> 0 then exit 2 diff --git a/driver/compmisc.ml b/driver/compmisc.ml index a2bc4b83a5..608683bbca 100644 --- a/driver/compmisc.ml +++ b/driver/compmisc.ml @@ -13,12 +13,12 @@ open Compenv (* Initialize the search path. - The current directory is always searched first, + [dir] is always searched first (default: the current directory), then the directories specified with the -I option (in command-line order), then the standard library directory (unless the -nostdlib option is given). *) -let init_path native = +let init_path ?(dir="") native = let dirs = if !Clflags.use_threads then "+threads" :: !Clflags.include_dirs else if !Clflags.use_vmthreads && not native then @@ -30,7 +30,7 @@ let init_path native = in let exp_dirs = List.map (Misc.expand_directory Config.standard_library) dirs in - Config.load_path := "" :: + Config.load_path := dir :: List.rev_append exp_dirs (Clflags.std_include_dir ()); Env.reset_cache () diff --git a/driver/compmisc.mli b/driver/compmisc.mli index 032e9fe4aa..3087d544d2 100644 --- a/driver/compmisc.mli +++ b/driver/compmisc.mli @@ -10,5 +10,5 @@ (* *) (***********************************************************************) -val init_path : bool -> unit +val init_path : ?dir:string -> bool -> unit val initial_env : unit -> Env.t diff --git a/driver/main.ml b/driver/main.ml index f8358a0cbd..9835284989 100644 --- a/driver/main.ml +++ b/driver/main.ml @@ -15,7 +15,9 @@ open Clflags open Compenv let process_interface_file ppf name = - Compile.interface ppf name (output_prefix name) + let opref = output_prefix name in + Compile.interface ppf name opref; + if !make_package then objfiles := (opref ^ ".cmi") :: !objfiles let process_implementation_file ppf name = let opref = output_prefix name in @@ -24,16 +26,10 @@ let process_implementation_file ppf name = let process_file ppf name = if Filename.check_suffix name ".ml" - || Filename.check_suffix name ".mlt" then begin - let opref = output_prefix name in - Compile.implementation ppf name opref; - objfiles := (opref ^ ".cmo") :: !objfiles - end - else if Filename.check_suffix name !Config.interface_suffix then begin - let opref = output_prefix name in - Compile.interface ppf name opref; - if !make_package then objfiles := (opref ^ ".cmi") :: !objfiles - end + || Filename.check_suffix name ".mlt" then + process_implementation_file ppf name + else if Filename.check_suffix name !Config.interface_suffix then + process_interface_file ppf name else if Filename.check_suffix name ".cmo" || Filename.check_suffix name ".cma" then objfiles := name :: !objfiles @@ -83,6 +79,7 @@ module Options = Main_args.Make_bytecomp_options (struct let _compat_32 = set bytecode_compatible_32 let _config = show_config let _custom = set custom_runtime + let _no_check_prims = set no_check_prims let _dllib s = dllibs := Misc.rev_split_words s @ !dllibs let _dllpath s = dllpaths := !dllpaths @ [s] let _for_pack s = for_package := Some s @@ -92,6 +89,7 @@ module Options = Main_args.Make_bytecomp_options (struct let _impl = impl let _intf = intf let _intf_suffix s = Config.interface_suffix := s + let _keep_docs = set keep_docs let _keep_locs = set keep_locs let _labels = unset classic let _linkall = set link_everything @@ -106,6 +104,8 @@ module Options = Main_args.Make_bytecomp_options (struct 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 _output_complete_obj () = + output_c_object := true; output_complete_object := true; custom_runtime := true let _pack = set make_package let _pp s = preprocessor := Some s let _ppx s = first_ppx := s :: !first_ppx @@ -196,3 +196,7 @@ let main () = exit 2 let _ = main () + + + + diff --git a/driver/main_args.ml b/driver/main_args.ml index 7636abe030..7bf4c4945b 100644 --- a/driver/main_args.ml +++ b/driver/main_args.ml @@ -126,6 +126,10 @@ let mk_intf_suffix_2 f = "-intf_suffix", Arg.String f, "<string> (deprecated) same as -intf-suffix" ;; +let mk_keep_docs f = + "-keep-docs", Arg.Unit f, " Keep documentation strings in .cmi files" +;; + let mk_keep_locs f = "-keep-locs", Arg.Unit f, " Keep locations in .cmi files" ;; @@ -160,6 +164,10 @@ let mk_no_app_funct f = "-no-app-funct", Arg.Unit f, " Deactivate applicative functors" ;; +let mk_no_check_prims f = + "-no-check-prims", Arg.Unit f, " Do not check runtime for primitives" +;; + let mk_no_float_const_prop f = "-no-float-const-prop", Arg.Unit f, " Deactivate constant propagation for floating-point operations" @@ -214,7 +222,12 @@ 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" + "-output-obj", Arg.Unit f, " Output an object file instead of an executable" +;; + +let mk_output_complete_obj f = + "-output-complete-obj", Arg.Unit f, + " Output an object file, including runtime, instead of an executable" ;; let mk_p f = @@ -315,6 +328,10 @@ let mk_version f = "-version", Arg.Unit f, " Print version and exit" ;; +let mk__version f = + "--version", Arg.Unit f, " Print version and exit" +;; + let mk_vmthread f = "-vmthread", Arg.Unit f, " Generate code that supports the threads library with VM-level\n\ @@ -516,11 +533,13 @@ module type Compiler_options = sig val _impl : string -> unit val _intf : string -> unit val _intf_suffix : string -> unit + val _keep_docs : unit -> unit val _keep_locs : unit -> unit val _linkall : unit -> unit val _noautolink : unit -> unit val _o : string -> unit val _output_obj : unit -> unit + val _output_complete_obj : unit -> unit val _pack : unit -> unit val _pp : string -> unit val _principal : unit -> unit @@ -541,6 +560,7 @@ module type Bytecomp_options = sig include Compiler_options val _compat_32 : unit -> unit val _custom : unit -> unit + val _no_check_prims : unit -> unit val _dllib : string -> unit val _dllpath : string -> unit val _make_runtime : unit -> unit @@ -653,6 +673,7 @@ struct mk_intf F._intf; mk_intf_suffix F._intf_suffix; mk_intf_suffix_2 F._intf_suffix; + mk_keep_docs F._keep_docs; mk_keep_locs F._keep_locs; mk_labels F._labels; mk_linkall F._linkall; @@ -661,6 +682,7 @@ struct mk_modern F._labels; mk_no_alias_deps F._no_alias_deps; mk_no_app_funct F._no_app_funct; + mk_no_check_prims F._no_check_prims; mk_noassert F._noassert; mk_noautolink_byt F._noautolink; mk_nolabels F._nolabels; @@ -668,6 +690,7 @@ struct mk_o F._o; mk_open F._open; mk_output_obj F._output_obj; + mk_output_complete_obj F._output_complete_obj; mk_pack_byt F._pack; mk_pp F._pp; mk_ppx F._ppx; @@ -686,6 +709,7 @@ struct mk_v F._v; mk_verbose F._verbose; mk_version F._version; + mk__version F._version; mk_vmthread F._vmthread; mk_vnum F._vnum; mk_w F._w; @@ -732,6 +756,7 @@ struct mk_unsafe F._unsafe; mk_unsafe_string F._unsafe_string; mk_version F._version; + mk__version F._version; mk_vnum F._vnum; mk_w F._w; mk_warn_error F._warn_error; @@ -769,6 +794,7 @@ struct mk_inline F._inline; mk_intf F._intf; mk_intf_suffix F._intf_suffix; + mk_keep_docs F._keep_docs; mk_keep_locs F._keep_locs; mk_labels F._labels; mk_linkall F._linkall; @@ -783,6 +809,7 @@ struct mk_o F._o; mk_open F._open; mk_output_obj F._output_obj; + mk_output_complete_obj F._output_complete_obj; mk_p F._p; mk_pack_opt F._pack; mk_pp F._pp; @@ -802,6 +829,7 @@ struct mk_v F._v; mk_verbose F._verbose; mk_version F._version; + mk__version F._version; mk_vnum F._vnum; mk_w F._w; mk_warn_error F._warn_error; @@ -863,6 +891,7 @@ module Make_opttop_options (F : Opttop_options) = struct mk_unsafe F._unsafe; mk_unsafe_string F._unsafe_string; mk_version F._version; + mk__version F._version; mk_vnum F._vnum; mk_w F._w; mk_warn_error F._warn_error; @@ -921,6 +950,7 @@ struct mk_v F._v; mk_verbose F._verbose; mk_version F._version; + mk__version F._version; mk_vmthread F._vmthread; mk_vnum F._vnum; mk_w F._w; diff --git a/driver/main_args.mli b/driver/main_args.mli index 18ade80bae..ddee921d4b 100644 --- a/driver/main_args.mli +++ b/driver/main_args.mli @@ -62,11 +62,13 @@ module type Compiler_options = sig val _impl : string -> unit val _intf : string -> unit val _intf_suffix : string -> unit + val _keep_docs : unit -> unit val _keep_locs : unit -> unit val _linkall : unit -> unit val _noautolink : unit -> unit val _o : string -> unit val _output_obj : unit -> unit + val _output_complete_obj : unit -> unit val _pack : unit -> unit val _pp : string -> unit val _principal : unit -> unit @@ -88,6 +90,7 @@ module type Bytecomp_options = sig include Compiler_options val _compat_32 : unit -> unit val _custom : unit -> unit + val _no_check_prims : unit -> unit val _dllib : string -> unit val _dllpath : string -> unit val _make_runtime : unit -> unit diff --git a/driver/optcompile.ml b/driver/optcompile.ml index f0ef78d1cb..b4265c0bff 100644 --- a/driver/optcompile.ml +++ b/driver/optcompile.ml @@ -66,22 +66,16 @@ let implementation ppf sourcefile outputprefix = let cmxfile = outputprefix ^ ".cmx" in let objfile = outputprefix ^ ext_obj in let comp ast = - if !Clflags.print_types - then + let (typedtree, coercion) = ast ++ print_if ppf Clflags.dump_parsetree Printast.implementation ++ print_if ppf Clflags.dump_source Pprintast.structure ++ Typemod.type_implementation sourcefile outputprefix modulename env ++ print_if ppf Clflags.dump_typedtree - Printtyped.implementation_with_coercion - ++ (fun _ -> ()) - else begin - ast - ++ print_if ppf Clflags.dump_parsetree Printast.implementation - ++ print_if ppf Clflags.dump_source Pprintast.structure - ++ Typemod.type_implementation sourcefile outputprefix modulename env - ++ print_if ppf Clflags.dump_typedtree - Printtyped.implementation_with_coercion + Printtyped.implementation_with_coercion + in + if not !Clflags.print_types then begin + (typedtree, coercion) ++ Translmod.transl_store_implementation modulename +++ print_if ppf Clflags.dump_rawlambda Printlambda.lambda +++ Simplif.simplify_lambda @@ -100,4 +94,5 @@ let implementation ppf sourcefile outputprefix = raise x let c_file name = - if Ccomp.compile_file name <> 0 then exit 2 + let output_name = !Clflags.output_name in + if Ccomp.compile_file ~output_name name <> 0 then exit 2 diff --git a/driver/optmain.ml b/driver/optmain.ml index 947d43073a..84c27b7866 100644 --- a/driver/optmain.ml +++ b/driver/optmain.ml @@ -15,7 +15,9 @@ open Clflags open Compenv let process_interface_file ppf name = - Optcompile.interface ppf name (output_prefix name) + let opref = output_prefix name in + Optcompile.interface ppf name opref; + if !make_package then objfiles := (opref ^ ".cmi") :: !objfiles let process_implementation_file ppf name = let opref = output_prefix name in @@ -28,11 +30,8 @@ let process_file ppf name = if Filename.check_suffix name ".ml" || Filename.check_suffix name ".mlt" then process_implementation_file ppf name - else if Filename.check_suffix name !Config.interface_suffix then begin - let opref = output_prefix name in - Optcompile.interface ppf name opref; - if !make_package then objfiles := (opref ^ ".cmi") :: !objfiles - end + else if Filename.check_suffix name !Config.interface_suffix then + process_interface_file ppf name else if Filename.check_suffix name ".cmx" then objfiles := name :: !objfiles else if Filename.check_suffix name ".cmxa" then begin @@ -90,6 +89,7 @@ module Options = Main_args.Make_optcomp_options (struct let _inline n = inline_threshold := n * 8 let _intf = intf let _intf_suffix s = Config.interface_suffix := s + let _keep_docs = set keep_docs let _keep_locs = set keep_locs let _labels = clear classic let _linkall = set link_everything @@ -104,6 +104,8 @@ module Options = Main_args.Make_optcomp_options (struct let _o s = output_name := Some s let _open s = open_modules := s :: !open_modules let _output_obj = set output_c_object + let _output_complete_obj s = + set output_c_object s; set output_complete_object s let _p = set gprofile let _pack = set make_package let _pp s = preprocessor := Some s diff --git a/driver/pparse.ml b/driver/pparse.ml index 4b2553f272..b67c1805d3 100644 --- a/driver/pparse.ml +++ b/driver/pparse.ml @@ -20,10 +20,7 @@ exception Error of error (* Optionally preprocess a source file *) -let preprocess sourcefile = - match !Clflags.preprocessor with - None -> sourcefile - | Some pp -> +let call_external_preprocessor sourcefile pp = let tmpfile = Filename.temp_file "ocamlpp" "" in let comm = Printf.sprintf "%s %s > %s" pp (Filename.quote sourcefile) tmpfile @@ -34,6 +31,12 @@ let preprocess sourcefile = end; tmpfile +let preprocess sourcefile = + match !Clflags.preprocessor with + None -> sourcefile + | Some pp -> call_external_preprocessor sourcefile pp + + let remove_preprocessed inputfile = match !Clflags.preprocessor with None -> () @@ -124,7 +127,7 @@ let apply_rewriters ?restore ~tool_name magic ast = exception Outdated_version -let file ppf ~tool_name inputfile parse_fun ast_magic = +let open_and_check_magic inputfile ast_magic = let ic = open_in_bin inputfile in let is_ast_file = try @@ -138,6 +141,10 @@ let file ppf ~tool_name inputfile parse_fun ast_magic = Misc.fatal_error "OCaml and preprocessor have incompatible versions" | _ -> false in + (ic, is_ast_file) + +let file ppf ~tool_name inputfile parse_fun ast_magic = + let (ic, is_ast_file) = open_and_check_magic inputfile ast_magic in let ast = try if is_ast_file then begin @@ -159,6 +166,7 @@ let file ppf ~tool_name inputfile parse_fun ast_magic = close_in ic; apply_rewriters ~restore:false ~tool_name ast_magic ast + let report_error ppf = function | CannotRun cmd -> fprintf ppf "Error while running external preprocessor@.\ diff --git a/driver/pparse.mli b/driver/pparse.mli index bcff4e7815..6497698939 100644 --- a/driver/pparse.mli +++ b/driver/pparse.mli @@ -34,3 +34,8 @@ val report_error : formatter -> error -> unit val parse_implementation: formatter -> tool_name:string -> string -> Parsetree.structure val parse_interface: formatter -> tool_name:string -> string -> Parsetree.signature + +(* [call_external_preprocessor sourcefile pp] *) +val call_external_preprocessor : string -> string -> string +val open_and_check_magic : string -> string -> in_channel * bool +val read_ast : string -> string -> 'a diff --git a/emacs/caml-types.el b/emacs/caml-types.el index 4bc2266557..0af667bdd2 100644 --- a/emacs/caml-types.el +++ b/emacs/caml-types.el @@ -20,6 +20,18 @@ (require 'caml-emacs))) +(defvar caml-types-build-dirs '("_build" "_obuild") + "List of possible compilation directories created by build systems. +It is expected that the files under `caml-types-build-dir' preserve +the paths relative to the parent directory of `caml-types-build-dir'.") +(make-variable-buffer-local 'caml-types-build-dir) + +(defvar caml-annot-dir nil + "A directory, generally relative to the file location, containing the +.annot file. Intended to be set as a local variable in the .ml file. +See \"Specifying File Variables\" in the Emacs info manual.") +(make-variable-buffer-local 'caml-annot-dir) +(put 'caml-annot-dir 'safe-local-variable #'stringp) (defvar caml-types-location-re nil "Regexp to parse *.annot files. @@ -349,21 +361,36 @@ See `caml-types-location-re' for annotation file format. (defun caml-types-parent-dir (d) (file-name-directory (directory-file-name d))) (defun caml-types-locate-type-file (target-path) - (let ((sibling (concat (file-name-sans-extension target-path) ".annot"))) - (if (file-exists-p sibling) - sibling - (let ((project-dir (file-name-directory sibling)) - type-path) - (while (not (file-exists-p - (setq type-path - (expand-file-name - (file-relative-name sibling project-dir) - (expand-file-name "_build" project-dir))))) - (if (equal project-dir (caml-types-parent-dir project-dir)) - (error (concat "No annotation file. " - "You should compile with option \"-annot\"."))) - (setq project-dir (caml-types-parent-dir project-dir))) - type-path)))) + "Given the path to an OCaml file, this function tries to locate +and return the corresponding .annot file." + (let ((sibling (concat (file-name-sans-extension target-path) ".annot"))) + (if (file-exists-p sibling) + sibling + (let* ((dir (file-name-directory sibling))) + (if caml-annot-dir + ;; Use the relative path set by the user + (let* ((annot-dir (expand-file-name caml-annot-dir dir)) + (fname (file-name-nondirectory sibling)) + (path-fname (expand-file-name fname annot-dir))) + (if (file-exists-p path-fname) + path-fname + (error (concat "No annotation file in " caml-annot-dir + ". Compile with option \"-annot\".")))) + ;; Else, try to get the .annot from one of build dirs. + (let* ((is-build (regexp-opt caml-types-build-dirs)) + (project-dir (locate-dominating-file + dir + (lambda(d) (directory-files d nil is-build)))) + (annot + (if project-dir + (locate-file + (file-relative-name sibling project-dir) + (mapcar (lambda(d) (expand-file-name d project-dir)) + caml-types-build-dirs))))) + (if annot + annot + (error (concat "No annotation file. Compile with option " + "\"-annot\" or set `caml-annot-dir'."))))))))) (defun caml-types-date< (date1 date2) (or (< (car date1) (car date2)) diff --git a/lex/Makefile b/lex/Makefile index cb5df8b41c..3691cb2b3f 100644 --- a/lex/Makefile +++ b/lex/Makefile @@ -11,13 +11,17 @@ ######################################################################### # The lexer generator -CAMLC=../boot/ocamlrun ../boot/ocamlc -strict-sequence -nostdlib -I ../boot -CAMLOPT=../boot/ocamlrun ../ocamlopt -nostdlib -I ../stdlib +include ../config/Makefile +CAMLRUN ?= ../boot/ocamlrun +CAMLYACC ?= ../boot/ocamlyacc + +CAMLC=$(CAMLRUN) ../boot/ocamlc -strict-sequence -nostdlib -I ../boot +CAMLOPT=$(CAMLRUN) ../ocamlopt -nostdlib -I ../stdlib COMPFLAGS=-w +33..39 -warn-error A -bin-annot -safe-string -CAMLYACC=../boot/ocamlyacc +LINKFLAGS= YACCFLAGS=-v -CAMLLEX=../boot/ocamlrun ../boot/ocamllex -CAMLDEP=../boot/ocamlrun ../tools/ocamldep +CAMLLEX=$(CAMLRUN) ../boot/ocamllex +CAMLDEP=$(CAMLRUN) ../tools/ocamldep OBJS=cset.cmo syntax.cmo parser.cmo lexer.cmo table.cmo lexgen.cmo \ diff --git a/lex/Makefile.nt b/lex/Makefile.nt index 38c71f2e8a..6bd8560406 100644 --- a/lex/Makefile.nt +++ b/lex/Makefile.nt @@ -13,15 +13,16 @@ # The lexer generator include ../config/Makefile +CAMLRUN ?= ../boot/ocamlrun +CAMLYACC ?= ../boot/ocamlyacc -CAMLC=../boot/ocamlrun ../boot/ocamlc -I ../boot -CAMLOPT=../boot/ocamlrun ../ocamlopt -I ../stdlib +CAMLC=$(CAMLRUN) ../boot/ocamlc -I ../boot +CAMLOPT=$(CAMLRUN) ../ocamlopt -I ../stdlib COMPFLAGS=-warn-error A LINKFLAGS= -CAMLYACC=../boot/ocamlyacc YACCFLAGS=-v -CAMLLEX=../boot/ocamlrun ../boot/ocamllex -CAMLDEP=../boot/ocamlrun ../tools/ocamldep +CAMLLEX=$(CAMLRUN) ../boot/ocamllex +CAMLDEP=$(CAMLRUN) ../tools/ocamldep DEPFLAGS= OBJS=cset.cmo syntax.cmo parser.cmo lexer.cmo table.cmo lexgen.cmo \ diff --git a/lex/lexer.mll b/lex/lexer.mll index eebd7115ea..6424c34fd2 100644 --- a/lex/lexer.mll +++ b/lex/lexer.mll @@ -226,7 +226,8 @@ and string = parse | eof { raise(Lexical_error("unterminated string", "", 0, 0)) } | '\013'* '\010' as s - { warning lexbuf (Printf.sprintf "unescaped newline in string") ; + { if !comment_depth = 0 then + warning lexbuf (Printf.sprintf "unescaped newline in string") ; store_string_chars s; incr_loc lexbuf 0; string lexbuf } diff --git a/man/ocaml.m b/man/ocaml.m index 79f81df0a4..5c839ea61d 100644 --- a/man/ocaml.m +++ b/man/ocaml.m @@ -81,9 +81,9 @@ If the given directory starts with .BR + , it is taken relative to the standard library directory. For instance, -.B \-I\ +camlp4 +.B \-I\ +compiler-libs adds the subdirectory -.B camlp4 +.B compiler-libs of the standard library to the search path. .IP Directories can also be added to the search path once the toplevel diff --git a/man/ocamlc.m b/man/ocamlc.m index 090f1c686c..adb280927f 100644 --- a/man/ocamlc.m +++ b/man/ocamlc.m @@ -191,8 +191,12 @@ linking with this library automatically adds back the options as if they had been provided on the command line, unless the .B -noautolink -option is given. -.TP +option is given. Additionally, a substring +.B $CAMLORIGIN +inside a +.BR \ \-ccopt +options will be replaced by the full path to the .cma library, +excluding the filename. .B \-absname Show absolute filenames in error messages. .TP @@ -350,9 +354,9 @@ If the given directory starts with .BR + , it is taken relative to the standard library directory. For instance, -.B \-I\ +camlp4 +.B \-I\ +compiler-libs adds the subdirectory -.B camlp4 +.B compiler-libs of the standard library to the search path. .TP .BI \-impl \ filename @@ -370,6 +374,9 @@ Recognize file names ending with .I string as interface files (instead of the default .mli). .TP +.B \-keep-docs +Keep documentation strings in generated .cmi files. +.TP .B \-keep-locs Keep locations in generated .cmi files. .TP @@ -745,7 +752,7 @@ have type \ \ Non-returning statement. 22 -\ \ Camlp4 warning. +\ \ Preprocessor warning. 23 \ \ Useless record @@ -825,6 +832,21 @@ mutually recursive types. 45 \ \ Open statement shadows an already defined label or constructor. +46 +\ \ Error in environment variable. + +47 +\ \ Illegal attribute payload. + +48 +\ \ Implicit elimination of optional arguments. + +49 +\ \ Missing cmi file when looking up module alias. + +50 +\ \ Unexpected documentation comment. + The letters stand for the following sets of warnings. Any letter not mentioned here corresponds to the empty set. @@ -878,7 +900,7 @@ mentioned here corresponds to the empty set. .IP The default setting is -.BR \-w\ +a\-4\-6\-7\-9\-27\-29\-32..39\-41..42\-44\-45 . +.BR \-w\ +a\-4\-6\-7\-9\-27\-29\-32..39\-41\-42\-44\-45\-48\-50 . Note that warnings .BR 5 \ and \ 10 are not always triggered, depending on the internals of the type checker. @@ -907,7 +929,8 @@ compiling your program with later versions of OCaml when they add new warnings or modify existing warnings. The default setting is -.B \-warn\-error\ -a (all warnings are non-fatal). +.B \-warn\-error \-a +(all warnings are non-fatal). .TP .B \-warn\-help Show the description of all available warning numbers. diff --git a/man/ocamlopt.m b/man/ocamlopt.m index fb20ca99c8..a541e598d4 100644 --- a/man/ocamlopt.m +++ b/man/ocamlopt.m @@ -153,7 +153,12 @@ linking with this library automatically adds back the options as if they had been provided on the command line, unless the .B \-noautolink -option is given. +option is given. Additionally, a substring +.B $CAMLORIGIN +inside a +.BR \ \-ccopt +options will be replaced by the full path to the .cma library, +excluding the filename. .TP .B \-absname Show absolute filenames in error messages. @@ -260,9 +265,9 @@ If the given directory starts with .BR + , it is taken relative to the standard library directory. For instance, -.B \-I\ +camlp4 +.B \-I\ +compiler-libs adds the subdirectory -.B camlp4 +.B compiler-libs of the standard library to the search path. .TP .BI \-impl \ filename @@ -299,6 +304,9 @@ Recognize file names ending with as interface files (instead of the default .mli). .TP .B \-keep-locs +Keep documentation strings in generated .cmi files. +.TP +.B \-keep-locs Keep locations in generated .cmi files. .TP .B \-labels @@ -595,7 +603,8 @@ compiling your program with later versions of OCaml when they add new warnings or modify existing warnings. The default setting is -.B \-warn\-error\ -a (all warnings are non-fatal). +.B \-warn\-error \-a +(all warnings are non-fatal). .TP .B \-warn\-help Show the description of all available warning numbers. diff --git a/man/ocamlrun.m b/man/ocamlrun.m index ea467ea463..2882395e5a 100644 --- a/man/ocamlrun.m +++ b/man/ocamlrun.m @@ -108,11 +108,15 @@ default to the library directory specified when compiling OCaml. .B OCAMLRUNPARAM Set the runtime system options and garbage collection parameters. (If OCAMLRUNPARAM is not set, CAMLRUNPARAM will be used instead.) -This variable must be a sequence of parameter specifications. -A parameter specification is an option letter followed by an = +This variable must be a sequence of parameter specifications separated +by commas. +A parameter specification is a letter, optionally followed by an = sign, a decimal number (or a hexadecimal number prefixed by .BR 0x ), -and an optional multiplier. The options are documented below; the +and an optional multiplier. If the letter is followed by anything +else, the corresponding option is set to 1. Unknown letters +are ignored. +The options are documented below; the last six correspond to the fields of the .B control record documented in @@ -193,6 +197,9 @@ Calling of finalisation functions. Startup messages (loading the bytecode executable file, resolving shared libraries). +.BR 0x200 +Computation of compaction-triggering condition. + The multiplier is .BR k , .BR M ,\ or diff --git a/ocamlbuild/Makefile b/ocamlbuild/Makefile index b40d0eada1..d302d20687 100644 --- a/ocamlbuild/Makefile +++ b/ocamlbuild/Makefile @@ -11,13 +11,14 @@ ######################################################################### include ../config/Makefile +CAMLRUN ?= ../boot/ocamlrun +CAMLYACC ?= ../boot/ocamlyacc 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 +OCAMLC = $(CAMLRUN) $(ROOTDIR)/ocamlc -nostdlib -I $(ROOTDIR)/stdlib +OCAMLOPT = $(CAMLRUN) $(ROOTDIR)/ocamlopt -nostdlib -I $(ROOTDIR)/stdlib +OCAMLDEP = $(CAMLRUN) $(ROOTDIR)/tools/ocamldep +OCAMLLEX = $(CAMLRUN) $(ROOTDIR)/boot/ocamllex CP = cp COMPFLAGS= -warn-error A -w L -w R -w Z -I ../otherlibs/$(UNIXLIB) -safe-string LINKFLAGS= -I ../otherlibs/$(UNIXLIB) @@ -125,9 +126,11 @@ ocamlbuildlib.cmxa: ocamlbuild_pack.cmx $(EXTRA_CMX) # The packs -ocamlbuild_pack.cmo ocamlbuild_pack.cmi: $(PACK_CMO) +ocamlbuild_pack.cmo: $(PACK_CMO) $(OCAMLC) -pack $(PACK_CMO) -o ocamlbuild_pack.cmo +ocamlbuild_pack.cmi: ocamlbuild_pack.cmo + ocamlbuild_pack.cmx: $(PACK_CMX) $(OCAMLOPT) -pack $(PACK_CMX) -o ocamlbuild_pack.cmx @@ -135,13 +138,14 @@ ocamlbuild_pack.cmx: $(PACK_CMX) ocamlbuild_config.ml: ../config/Makefile (echo 'let bindir = "$(BINDIR)"'; \ - echo 'let libdir = "$(LIBDIR)"'; \ - echo 'let supports_shared_libraries = $(SUPPORTS_SHARED_LIBRARIES)';\ - echo 'let a = "$(A)"'; \ - echo 'let o = "$(O)"'; \ - echo 'let so = "$(SO)"'; \ - echo 'let exe = "$(EXE)"'; \ - ) > ocamlbuild_config.ml + echo 'let libdir = "$(LIBDIR)"'; \ + echo 'let supports_shared_libraries = $(SUPPORTS_SHARED_LIBRARIES)';\ + echo 'let a = "$(A)"'; \ + echo 'let o = "$(O)"'; \ + echo 'let so = "$(SO)"'; \ + echo 'let ext_dll = "$(EXT_DLL)"'; \ + echo 'let exe = "$(EXE)"'; \ + ) > ocamlbuild_config.ml clean:: rm -f ocamlbuild_config.ml beforedepend:: ocamlbuild_config.ml diff --git a/ocamlbuild/Makefile.noboot b/ocamlbuild/Makefile.noboot deleted file mode 100644 index 313e56891c..0000000000 --- a/ocamlbuild/Makefile.noboot +++ /dev/null @@ -1,227 +0,0 @@ -#(***********************************************************************) -#(* *) -#(* ocamlbuild *) -#(* *) -#(* Wojciech Meyer *) -#(* *) -#(* Copyright 2012 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 file removes the dependency on ocamlbuild itself, thus removes need -# for bootstrap. The base for this Makefile was ocamldoc Makefile. - -include ../config/Makefile - -# Various commands and dir -########################## - -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) - -# For installation -############## -MKDIR=mkdir -p -CP=cp -f -OCAMLBUILD=ocamlbuild -OCAMLBUILD_OPT=$(OCAMLBUILD).opt -OCAMLBUILD_LIBCMA=ocamlbuildlib.cma -OCAMLBUILD_LIBCMI=ocamlbuildlib.cmi -OCAMLBUILD_LIBCMXA=ocamlbuild.cmxa -OCAMLBUILD_LIBA=ocamlbuild.$(A) -INSTALL_LIBDIR=$(DESTDIR)$(OCAMLLIB)/ocamlbuild -INSTALL_CUSTOMDIR=$(INSTALL_LIBDIR)/custom -INSTALL_BINDIR=$(DESTDIR)$(OCAMLBIN) - -INSTALL_MLIS= -INSTALL_CMIS=$(INSTALL_MLIS:.mli=.cmi) - -# Compilation -############# -OCAMLSRCDIR=.. -INCLUDES_DEP= - -INCLUDES_NODEP= -I $(OCAMLSRCDIR)/stdlib \ - -I $(OCAMLSRCDIR)/otherlibs/str \ - -I $(OCAMLSRCDIR)/otherlibs/dynlink \ - -I $(OCAMLSRCDIR)/otherlibs/$(UNIXLIB) - -INCLUDES=$(INCLUDES_DEP) $(INCLUDES_NODEP) - -COMPFLAGS=$(INCLUDES) -warn-error A -safe-string -LINKFLAGS=$(INCLUDES) - -CMOFILES_PACK= \ - ocamlbuild_Myocamlbuild_config.cmo \ - discard_printf.cmo \ - my_std.cmo \ - bool.cmo \ - glob_ast.cmo \ - glob_lexer.cmo \ - glob.cmo \ - lexers.cmo \ - my_unix.cmo \ - tags.cmo \ - display.cmo \ - log.cmo \ - param_tags.cmo \ - shell.cmo \ - slurp.cmo \ - ocamlbuild_where.cmo \ - command.cmo \ - options.cmo \ - pathname.cmo \ - digest_cache.cmo \ - resource.cmo \ - rule.cmo \ - flags.cmo \ - solver.cmo \ - report.cmo \ - ocaml_arch.cmo \ - hygiene.cmo \ - configuration.cmo \ - tools.cmo \ - fda.cmo \ - plugin.cmo \ - ocaml_utils.cmo \ - ocaml_dependencies.cmo \ - ocaml_compiler.cmo \ - ocaml_tools.cmo \ - hooks.cmo \ - findlib.cmo \ - ocaml_specific.cmo \ - exit_codes.cmo \ - main.cmo - -BASE_CMOFILES= ocamlbuild_executor.cmo \ - ocamlbuild_unix_plugin.cmo - -INSTALL_LIBFILES = $(BASE_CMOFILES) \ - $(BASE_CMOFILES:.cmo=.cmi) \ - $(OCAMLBUILD_LIBCMA) \ - $(OCAMLBUILD).cmo \ - $(OCAMLBUILD)_pack.cmi - -INSTALL_BINFILES = $(OCAMLBUILD) - -CMXFILES= $(CMOFILES:.cmo=.cmx) - -CMXFILES_PACK= $(CMOFILES_PACK:.cmo=.cmx) -CMIFILES_PACK= $(CMOFILES_PACK:.cmo=.cmi) signatures.cmi - -EXECMOFILES_PACK= $(CMOFILES_PACK) -EXECMXFILES_PACK= $(EXECMOFILES_PACK:.cmo=.cmx) -EXECMIFILES_PACK= $(EXECMOFILES_PACK:.cmo=.cmi) - -LIBCMOFILES_PACK= $(CMOFILES_PACK) -LIBCMXFILES_PACK= $(LIBCMOFILES_PACK:.cmo=.cmx) -LIBCMIFILES_PACK= $(LIBCMOFILES_PACK:.cmo=.cmi) - -# Les cmo et cmx de la distrib OCAML -OCAMLCMOFILES= -OCAMLCMXFILES=$(OCAMLCMOFILES_PACK:.cmo=.cmx) - -all: exe lib -opt: $(OCAMLBUILD).native -exe: $(OCAMLBUILD) -lib: $(OCAMLBUILD_LIBCMA) - -opt.opt: exeopt libopt -exeopt: $(OCAMLBUILD_OPT) -libopt: $(OCAMLBUILD_LIBCMXA) $(OCAMLBUILD_LIBCMI) - -debug: - $(MAKE) OCAMLPP="" - -$(OCAMLBUILD)_pack.cmo: $(CMOFILES_PACK) $(CMIFILES_PACK) - $(OCAMLC) -pack -o $@ $(LINKFLAGS) $(OCAMLCMOFILES_PACK) $(EXECMOFILES_PACK) signatures.mli - -$(OCAMLBUILD)_pack.cmx: $(EXECMXFILES_PACK) - $(OCAMLOPT) -pack -o $@ $(LINKFLAGS) $(OCAMLCMOFILES_PACK) $(EXECMXFILES_PACK) - -$(OCAMLBUILD): $(OCAMLBUILD)_pack.cmo $(CMOFILES) $(OCAMLBUILD).cmo $(BASE_CMOFILES) - $(OCAMLC) -o $@ unix.cma $(LINKFLAGS) $(OCAMLBUILD)_pack.cmo $(CMOFILES) - -$(OCAMLBUILD).native: $(OCAMLBUILD)_pack.cmx $(CMXFILES) - $(OCAMLOPT) -o $@ $(LINKFLAGS) $(CMXFILES) - -$(OCAMLBUILD_LIBCMA): $(LIBCMOFILES_PACK) - $(OCAMLC) -a -o $@ $(LINKFLAGS) $(OCAMLSRCDIR)/tools/depend.cmo $(LIBCMOFILES_PACK) -$(OCAMLBUILD_LIBCMXA): $(LIBCMXFILES) - $(OCAMLOPT) -a -o $@ $(LINKFLAGS) $(OCAMLSRCDIR)/tools/depend.cmx $(LIBCMXFILES) - -# generic rules : -################# - -.SUFFIXES: .mll .mly .ml .mli .cmo .cmi .cmx .cmxs - -.ml.cmo: - $(OCAMLC) $(OCAMLPP) $(COMPFLAGS) -c $< - -.mli.cmi: - $(OCAMLC) $(OCAMLPP) $(COMPFLAGS) -c $< - -.ml.cmx: - $(OCAMLOPT) $(OCAMLPP) $(COMPFLAGS) -c $< - -.ml.cmxs: - $(OCAMLOPT) -shared -o $@ $(OCAMLPP) $(COMPFLAGS) $< - -.mll.ml: - $(OCAMLLEX) $< - -.mly.ml: - $(OCAMLYACC) -v $< - -.mly.mli: - $(OCAMLYACC) -v $< - -# Installation targets -###################### -install: dummy - 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_CUSTOMDIR); then : ; else $(MKDIR) $(INSTALL_CUSTOMDIR); fi - $(CP) $(OCAMLBUILD) $(INSTALL_BINDIR)/$(OCAMLBUILD)$(EXE) - $(CP) $(INSTALL_LIBFILES) $(INSTALL_LIBDIR) - $(CP) $(INSTALL_BINFILES) $(INSTALL_BINDIR) - -installopt: - if test -f $(OCAMLBUILD_OPT) ; then $(MAKE) installopt_really ; fi - -installopt_really: - if test -d $(INSTALL_BINDIR); then : ; else $(MKDIR) $(INSTALL_BINDIR); fi - if test -d $(INSTALL_LIBDIR); then : ; else $(MKDIR) $(INSTALL_LIBDIR); fi - $(CP) ocamlbuild.hva $(OCAMLBUILD_LIBA) $(OCAMLBUILD_LIBCMXA) $(INSTALL_LIBDIR) - $(CP) $(INSTALL_MLIS) $(INSTALL_CMIS) $(INSTALL_LIBDIR) - - -# backup, clean and depend : -############################ - -clean:: dummy - @rm -f *~ \#*\# - @rm -f $(OCAMLBUILD) $(OCAMLBUILD_OPT) *.cma *.cmxa *.cmo *.cmi *.cmx *.$(A) *.$(O) - @rm -f glob_lexer.ml lexers.ml - -depend:: - $(OCAMLDEP) $(INCLUDES_DEP) *.mli *.mll *.mly *.ml > .depend - -dummy: - -include .depend - -# Additional rules -glob_lexer.cmo: glob_lexer.cmi -lexers.cmo: lexers.cmi - -glob_lexer.cmx: glob_lexer.cmi -lexers.cmx: lexers.cmi diff --git a/ocamlbuild/command.ml b/ocamlbuild/command.ml index fc6e07cf43..79e2a1dc4a 100644 --- a/ocamlbuild/command.ml +++ b/ocamlbuild/command.ml @@ -125,7 +125,7 @@ let virtual_solver virtual_command = (* On Windows, we need to also check for the ".exe" version of the file. *) let file_or_exe_exists file = - sys_file_exists file || (Sys.os_type = "Win32" && sys_file_exists (file ^ ".exe")) + sys_file_exists file || ((Sys.win32 || Sys.cygwin) && sys_file_exists (file ^ ".exe")) let search_in_path cmd = (* Try to find [cmd] in path [path]. *) @@ -393,6 +393,9 @@ let pdep tags ptag deps = Param_tags.declare ptag (fun param -> dep (Param_tags.make ptag param :: tags) (deps param)) +let list_all_deps () = + !all_deps_of_tags + (* let to_string_for_digest x = let rec cmd_of_spec = diff --git a/ocamlbuild/command.mli b/ocamlbuild/command.mli index 18547a459c..a28c75190b 100644 --- a/ocamlbuild/command.mli +++ b/ocamlbuild/command.mli @@ -46,4 +46,6 @@ val dep : Tags.elt list -> pathname list -> unit val pdep : Tags.elt list -> Tags.elt -> (string -> pathname list) -> unit +val list_all_deps : unit -> (Tags.t * pathname list) list + val file_or_exe_exists: string -> bool diff --git a/ocamlbuild/configuration.ml b/ocamlbuild/configuration.ml index 6290e60a95..bc50a0105e 100644 --- a/ocamlbuild/configuration.ml +++ b/ocamlbuild/configuration.ml @@ -81,10 +81,11 @@ let tag_any tags = let check_tags_usage useful_tags = let check_tag (tag, loc) = if not (Tags.mem tag useful_tags) then - Log.eprintf "%aWarning: the tag %S is not used in any flag declaration, \ - so it will have no effect; it may be a typo. Otherwise use \ - `mark_tag_used` in your myocamlbuild.ml to disable \ - this warning." + + Log.eprintf "%aWarning: the tag %S is not used in any flag or dependency \ + declaration, so it will have no effect; it may be a typo. \ + Otherwise you can use `mark_tag_used` in your myocamlbuild.ml \ + to disable this warning." Loc.print_loc loc tag in let check_conf (_, values) = diff --git a/ocamlbuild/display.ml b/ocamlbuild/display.ml index 2e0b1e39ea..c295807e40 100644 --- a/ocamlbuild/display.ml +++ b/ocamlbuild/display.ml @@ -297,10 +297,10 @@ let update_tagline_from_tags ds = done | (tag, c) :: rest -> if Tags.mem tag tags then - Bytes.set tagline i (Char.uppercase c) + Bytes.set tagline i (Char.uppercase_ascii c) else if Tags.mem tag ds.ds_seen_tags then - Bytes.set tagline i (Char.lowercase c) + Bytes.set tagline i (Char.lowercase_ascii c) else Bytes.set tagline i '-'; loop (i + 1) rest diff --git a/ocamlbuild/findlib.ml b/ocamlbuild/findlib.ml index 18f4d2c956..7d4d78afd5 100644 --- a/ocamlbuild/findlib.ml +++ b/ocamlbuild/findlib.ml @@ -153,7 +153,7 @@ let add_atom a l = match a, l with | A "", _ -> l | _ -> a :: l -let compile_flags l = +let include_flags l = let pkgs = topological_closure l in let locations = List.fold_left begin fun acc p -> SSet.add p.location acc @@ -166,8 +166,8 @@ let compile_flags l = end flags (SSet.elements locations) in S (List.rev flags) -let compile_flags_byte = compile_flags -let compile_flags_native = compile_flags +let compile_flags_byte = include_flags +let compile_flags_native = include_flags let link_flags f l = let pkgs = topological_closure l in diff --git a/ocamlbuild/loc.ml b/ocamlbuild/loc.ml index 7a324c1618..c5ef9398d5 100644 --- a/ocamlbuild/loc.ml +++ b/ocamlbuild/loc.ml @@ -20,7 +20,7 @@ let print_loc ppf (source, start, end_) = if one_or_two then fprintf ppf " %d" start_num else fprintf ppf "s %d-%d" start_num end_num in fprintf ppf "%s %S, line%a, character%a:@." - (String.capitalize source) + (String.capitalize_ascii source) (file start) (print (line start = line end_)) (line start, line end_) diff --git a/ocamlbuild/main.ml b/ocamlbuild/main.ml index 07ca9c0652..d59a450b20 100644 --- a/ocamlbuild/main.ml +++ b/ocamlbuild/main.ml @@ -25,7 +25,6 @@ exception Exit_build_error of string exception Exit_silently let clean () = - Log.finish (); Shell.rm_rf !Options.build_dir; if !Options.make_links then begin let entry = @@ -34,6 +33,7 @@ let clean () = in Slurp.force (Resource.clean_up_links entry) end; + Log.finish (); raise Exit_silently ;; @@ -57,7 +57,7 @@ let show_documentation () = they should be marked as useful, to avoid the "unused tag" warning. *) let builtin_useful_tags = Tags.of_list [ - "include"; "traverse"; "not_hygienic"; + "include"; "traverse"; "not_hygienic"; "precious"; "pack"; "ocamlmklib"; "native"; "thread"; "nopervasives"; "use_menhir"; "ocamldep"; "thread"; @@ -67,6 +67,8 @@ let builtin_useful_tags = let proceed () = Hooks.call_hook Hooks.Before_options; Options.init (); + Options.include_dirs := List.map Pathname.normalize !Options.include_dirs; + Options.exclude_dirs := List.map Pathname.normalize !Options.exclude_dirs; if !Options.must_clean then clean (); Hooks.call_hook Hooks.After_options; let options_wd = Sys.getcwd () in @@ -74,7 +76,7 @@ let proceed () = (* If we are in the first run before launching the plugin, we should skip the user-visible operations (hygiene) that may need information from the plugin to run as the user expects it. - + Note that we don't need to disable the [Hooks] call as they are no-ops anyway, before any plugin has registered hooks. *) Plugin.we_need_a_plugin () && not !Options.just_plugin in @@ -91,6 +93,8 @@ let proceed () = <**/*.cmo>: ocaml, byte\n\ <**/*.cmi>: ocaml, byte, native\n\ <**/*.cmx>: ocaml, native\n\ + <**/*.mly>: infer\n\ + <**/.svn>|\".bzr\"|\".hg\"|\".git\"|\"_darcs\": -traverse\n\ "; List.iter @@ -201,7 +205,14 @@ let proceed () = raise Exit_silently end; - let all_tags = Tags.union builtin_useful_tags (Flags.get_used_tags ()) in + let all_tags = + let builtin = builtin_useful_tags in + let used_in_flags = Flags.get_used_tags () in + let used_in_deps = + List.fold_left (fun acc (tags, _deps) -> Tags.union acc tags) + Tags.empty (Command.list_all_deps ()) + in + Tags.union builtin (Tags.union used_in_flags used_in_deps) in Configuration.check_tags_usage all_tags; Digest_cache.init (); @@ -263,10 +274,10 @@ let proceed () = else () with - | Ocaml_dependencies.Circular_dependencies(seen, p) -> + | Ocaml_dependencies.Circular_dependencies(cycle, p) -> raise (Exit_build_error - (sbprintf "@[<2>Circular dependencies: %S already seen in@ %a@]@." p pp_l seen)) + (sbprintf "@[<2>Circular dependencies: %S already seen in@ %a@]@." p pp_l cycle)) ;; open Exit_codes;; diff --git a/ocamlbuild/my_unix.ml b/ocamlbuild/my_unix.ml index fa1c5d45f4..5bfbee01af 100644 --- a/ocamlbuild/my_unix.ml +++ b/ocamlbuild/my_unix.ml @@ -84,6 +84,12 @@ let rec readlink x = if sys_file_exists x then try let y = readlinkcmd x in + let y = + if Filename.is_relative y then + Filename.concat (Filename.dirname x) y + else + y + in if (lstat y).stat_file_kind = FK_dir then raise Link_to_directories_not_supported else y with Failure(_) -> raise Not_a_link else raise No_such_file diff --git a/ocamlbuild/ocaml_compiler.ml b/ocamlbuild/ocaml_compiler.ml index c270a7f637..7526598f72 100644 --- a/ocamlbuild/ocaml_compiler.ml +++ b/ocamlbuild/ocaml_compiler.ml @@ -156,7 +156,7 @@ let byte_compile_ocaml_interf mli cmi env build = let compile_ocaml_interf mli cmi env build = let mli = env mli and cmi = env cmi in prepare_compile build mli; - let tags = tags_of_pathname mli++"interf" in + let tags = tags_of_pathname mli++"interf" in let comp_c = if Tags.mem "native" tags then ocamlopt_c else ocamlc_c in comp_c tags mli cmi @@ -266,6 +266,9 @@ let byte_link = byte_link_gen ocamlc_link_prog let byte_output_obj = byte_link_gen ocamlc_link_prog (fun tags -> tags++"ocaml"++"link"++"byte"++"output_obj") +let byte_output_shared = byte_link_gen ocamlc_link_prog + (fun tags -> tags++"ocaml"++"link"++"byte"++"output_obj"++"output_shared") + let byte_library_link = byte_link_gen byte_lib_linker byte_lib_linker_tags let byte_debug_link_gen = @@ -286,6 +289,9 @@ let native_link x = native_link_gen ocamlopt_link_prog let native_output_obj x = native_link_gen ocamlopt_link_prog (fun tags -> tags++"ocaml"++"link"++"native"++"output_obj") x +let native_output_shared x = native_link_gen ocamlopt_link_prog + (fun tags -> tags++"ocaml"++"link"++"native"++"output_obj"++"output_shared") x + let native_library_link x = native_link_gen native_lib_linker native_lib_linker_tags x diff --git a/ocamlbuild/ocaml_compiler.mli b/ocamlbuild/ocaml_compiler.mli index 38206e5a44..0c951abd06 100644 --- a/ocamlbuild/ocaml_compiler.mli +++ b/ocamlbuild/ocaml_compiler.mli @@ -43,11 +43,13 @@ val link_gen : string -> string -> Rule.action val byte_link : string -> string -> Rule.action val byte_output_obj : string -> string -> Rule.action +val byte_output_shared : string -> string -> Rule.action val byte_library_link : string -> string -> Rule.action val byte_debug_link : string -> string -> Rule.action val byte_debug_library_link : string -> string -> Rule.action val native_link : string -> string -> Rule.action val native_output_obj : string -> string -> Rule.action +val native_output_shared : string -> string -> Rule.action val native_library_link : string -> string -> Rule.action val native_shared_library_link : ?tags:(string list) -> string -> string -> Rule.action val native_profile_link : string -> string -> Rule.action diff --git a/ocamlbuild/ocaml_dependencies.ml b/ocamlbuild/ocaml_dependencies.ml index de2c11fab4..f62eb7d45b 100644 --- a/ocamlbuild/ocaml_dependencies.ml +++ b/ocamlbuild/ocaml_dependencies.ml @@ -194,12 +194,51 @@ module Make (I : INPUT) = struct let dependencies_of x = try SMap.find x !*dependencies with Not_found -> Resources.empty in - let needed = ref [] in - let seen = ref [] in + let refine_cycle files starting_file = + (* We are looking for a cycle starting from [fn], included in + [files]; we'll simply use a DFS which builds a path until it + finds a circularity. + + Note that if there is at least one cycle going through [fn], + calling [dfs path fn] will return it no matter what [path] is + (it may just not be the shortest possible cycle). This means + that if [dfs path fn] returns [None], [fn] is a dead-end that + should never be explored again. + *) + let dead_ends = ref Resources.empty in + let rec dfs path fn = + let through_dep f = function + | Some _ as cycle -> cycle + | None -> + if List.mem f path + then (* we have found a cycle *) + Some (List.rev path) + else if not (Resources.mem f files) + then + (* the neighbor is not in the set of paths known to have a cycle *) + None + else + (* look for cycles going through this neighbor *) + dfs (f :: path) f + in + if Resources.mem fn !dead_ends then None + else match Resources.fold through_dep (dependencies_of fn) None with + | Some _ as cycle -> cycle + | None -> dead_ends := Resources.add fn !dead_ends; None + in + match dfs [] starting_file with + | None -> Resources.elements files + | Some cycle -> cycle + in + + let needed_in_order = ref [] in + let needed = ref Resources.empty in + let seen = ref Resources.empty in let rec aux fn = - if sys_file_exists fn && not (List.mem fn !needed) then begin - if List.mem fn !seen then raise (Circular_dependencies (!seen, fn)); - seen := fn :: !seen; + if sys_file_exists fn && not (Resources.mem fn !needed) then begin + if Resources.mem fn !seen then + raise (Circular_dependencies (refine_cycle !seen fn, fn)); + seen := Resources.add fn !seen; Resources.iter begin fun f -> if sys_file_exists f then if Filename.check_suffix f ".cmi" then @@ -210,11 +249,14 @@ module Make (I : INPUT) = struct else () else aux f end (dependencies_of fn); - needed := fn :: !needed + needed := Resources.add fn !needed; + needed_in_order := fn :: !needed_in_order end in List.iter aux fns; - mydprintf "caml_transitive_closure:@ %a ->@ %a" pp_l fns pp_l !needed; - List.rev !needed + mydprintf "caml_transitive_closure:@ %a ->@ %a" + pp_l fns pp_l !needed_in_order; + List.rev !needed_in_order + end diff --git a/ocamlbuild/ocaml_specific.ml b/ocamlbuild/ocaml_specific.ml index 79517a86a4..d332ff311d 100644 --- a/ocamlbuild/ocaml_specific.ml +++ b/ocamlbuild/ocaml_specific.ml @@ -61,7 +61,9 @@ let x_p_dll = "%.p"-.-ext_dll;; (* -output-obj targets *) let x_byte_c = "%.byte.c";; let x_byte_o = "%.byte"-.-ext_obj;; +let x_byte_so = "%.byte"-.-ext_dll;; let x_native_o = "%.native"-.-ext_obj;; +let x_native_so = "%.native"-.-ext_dll;; rule "target files" ~dep:"%.itarget" @@ -221,6 +223,15 @@ rule "ocaml: cmo* -> byte.c" ~dep:"%.cmo" (Ocaml_compiler.byte_output_obj "%.cmo" x_byte_c);; +rule "ocaml: cmo* -> byte.(so|dll|dylib)" + ~prod:x_byte_so + ~dep:"%.cmo" + ~doc:"The foo.byte.so target, or foo.byte.dll under Windows, \ + or foo.byte.dylib under Mac OS X will produce a shared library file + by passing the -output-obj and -cclib -shared options \ + to the OCaml compiler. See also foo.native.{so,dll,dylib}." + (Ocaml_compiler.byte_output_shared "%.cmo" x_byte_so);; + rule "ocaml: p.cmx* & p.o* -> p.native" ~prod:"%.p.native" ~deps:["%.p.cmx"; x_p_o] @@ -239,6 +250,11 @@ rule "ocaml: cmx* & o* -> native.(o|obj)" ~deps:["%.cmx"; x_o] (Ocaml_compiler.native_output_obj "%.cmx" x_native_o);; +rule "ocaml: cmx* & o* -> native.(so|dll|dylib)" + ~prod:x_native_so + ~deps:["%.cmx"; x_o] + (Ocaml_compiler.native_output_shared "%.cmx" x_native_so);; + rule "ocaml: mllib & d.cmo* -> d.cma" ~prod:"%.d.cma" ~dep:"%.mllib" @@ -472,9 +488,7 @@ rule "ocaml C stubs: c -> o" let c = env "%.c" in let o = env x_o in let comp = if Tags.mem "native" (tags_of_pathname c) then !Options.ocamlopt else !Options.ocamlc in - let cc = Cmd(S[comp; T(tags_of_pathname c++"c"++"compile"); A"-c"; Px c]) in - if Pathname.dirname o = Pathname.current_dir_name then cc - else Seq[cc; mv (Pathname.basename o) o] + Cmd(S[comp; T(tags_of_pathname c++"c"++"compile"); A"-c"; A"-o"; P o; Px c]) end;; rule "ocaml: ml & ml.depends & *cmi -> .inferred.mli" @@ -527,11 +541,22 @@ end;; flag ["ocaml"; "ocamlyacc"] (atomize !Options.ocaml_yaccflags);; flag ["ocaml"; "menhir"] (atomize !Options.ocaml_yaccflags);; flag ["ocaml"; "doc"] (atomize !Options.ocaml_docflags);; +flag ["ocaml"; "ocamllex"] (atomize !Options.ocaml_lexflags);; (* Tell menhir to explain conflicts *) flag [ "ocaml" ; "menhir" ; "explain" ] (S[A "--explain"]);; +flag [ "ocaml" ; "menhir" ; "infer" ] (S[A "--infer"]);; -flag ["ocaml"; "ocamllex"] (atomize !Options.ocaml_lexflags);; +(* Define two ocamlbuild flags [only_tokens] and [external_tokens(Foo)] + which correspond to menhir's [--only-tokens] and [--external-tokens Foo]. + When they are used, these flags should be passed both to [menhir] and to + [menhir --raw-depend]. *) +let () = + List.iter begin fun mode -> + flag [ mode; "only_tokens" ] (S[A "--only-tokens"]); + pflag [ mode ] "external_tokens" (fun name -> + S[A "--external-tokens"; A name]); + end [ "menhir"; "menhir_ocamldep" ];; (* Tell ocamllex to generate ml code *) flag [ "ocaml" ; "ocamllex" ; "generate_ml" ] (S[A "-ml"]);; @@ -558,6 +583,15 @@ let () = (* Ocamlfind will link the archives for us. *) flag ["ocaml"; "link"; "program"] & A"-linkpkg"; flag ["ocaml"; "link"; "toplevel"] & A"-linkpkg"; + flag ["ocaml"; "link"; "output_obj"] & A"-linkpkg"; + + (* "program" will make sure that -linkpkg is passed when compiling + whole-programs (.byte and .native); but it is occasionally + useful to pass -linkpkg when building archives for example + (.cma and .cmxa); the "linkpkg" flag allows user to request it + explicitly. *) + flag ["ocaml"; "link"; "linkpkg"] & A"-linkpkg"; + pflag ["ocaml"; "link"] "dontlink" (fun pkg -> S[A"-dontlink"; A pkg]); let all_tags = [ ["ocaml"; "byte"; "compile"]; @@ -568,6 +602,8 @@ let () = ["ocaml"; "doc"]; ["ocaml"; "mktop"]; ["ocaml"; "infer_interface"]; + (* PR#6794: ocamlbuild should pass -package flags when building C files *) + ["c"; "compile"]; ] in (* tags package(X), predicate(X) and syntax(X) *) @@ -576,7 +612,8 @@ let () = if not (List.mem "ocamldep" tags) then (* PR#6184: 'ocamlfind ocamldep' does not support -predicate *) pflag tags "predicate" (fun pkg -> S [A "-predicates"; A pkg]); - pflag tags "syntax" (fun pkg -> S [A "-syntax"; A pkg]) + if List.mem "ocaml" tags then + pflag tags "syntax" (fun pkg -> S [A "-syntax"; A pkg]) end all_tags end else begin try @@ -585,7 +622,9 @@ let () = flag ["ocaml"; "byte"; "compile"] (Findlib.compile_flags_byte pkgs); flag ["ocaml"; "native"; "compile"] (Findlib.compile_flags_native pkgs); flag ["ocaml"; "byte"; "link"] (Findlib.link_flags_byte pkgs); - flag ["ocaml"; "native"; "link"] (Findlib.link_flags_native pkgs) + flag ["ocaml"; "native"; "link"] (Findlib.link_flags_native pkgs); + (* PR#6794: ocamlbuild should pass -package flags when building C files *) + flag ["c"; "compile"] (Findlib.include_flags pkgs) with Findlib.Findlib_error e -> Findlib.report_error e end @@ -616,6 +655,8 @@ let () = (fun param -> S [A "-open"; A param]); pflag ["ocaml"; "compile"] "open" (fun param -> S [A "-open"; A param]); + pflag ["ocaml"; "link"] "runtime_variant" + (fun param -> S [A "-runtime-variant"; A param]); () let camlp4_flags camlp4s = @@ -666,8 +707,11 @@ flag ["ocaml"; "debug"; "pack"; "byte"] (A "-g");; flag ["ocaml"; "debug"; "compile"; "native"] (A "-g");; flag ["ocaml"; "debug"; "link"; "native"; "program"] (A "-g");; flag ["ocaml"; "debug"; "pack"; "native"] (A "-g");; +flag ["c"; "debug"; "compile"] (A "-g"); +flag ["c"; "debug"; "link"] (A "-g"); flag ["ocaml"; "link"; "native"; "output_obj"] (A"-output-obj");; flag ["ocaml"; "link"; "byte"; "output_obj"] (A"-output-obj");; +flag ["ocaml"; "link"; "output_shared"] & (S[A"-cclib"; A"-shared"]);; flag ["ocaml"; "dtypes"; "compile"] (A "-dtypes");; flag ["ocaml"; "annot"; "compile"] (A "-annot");; flag ["ocaml"; "annot"; "pack"] (A "-annot");; @@ -694,16 +738,21 @@ 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_docs";] (A "-keep-docs"); 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"); +flag ["ocaml"; "byte"; "compile"; "compat_32";] (A "-compat-32");; +flag ["ocaml";"compile";"native";"asm"] & S [A "-S"];; (* threads, with or without findlib *) flag ["ocaml"; "compile"; "thread"] (A "-thread");; flag ["ocaml"; "link"; "thread"] (A "-thread");; -if not !Options.use_ocamlfind then begin +if !Options.use_ocamlfind then + (* PR#6794: Needed as we pass -package when compiling C files *) + flag ["c"; "compile"; "thread"] (A "-thread") +else begin flag ["ocaml"; "doc"; "thread"] (S[A"-I"; A"+threads"]); flag ["ocaml"; "link"; "thread"; "native"; "program"] (A "threads.cmxa"); flag ["ocaml"; "link"; "thread"; "byte"; "program"] (A "threads.cma"); @@ -719,17 +768,17 @@ flag ["ocaml"; "ocamllex"; "quiet"] (A"-q");; let ocaml_warn_flag c = flag ~deprecated:true - ["ocaml"; "compile"; sprintf "warn_%c" (Char.uppercase c)] - (S[A"-w"; A (sprintf "%c" (Char.uppercase c))]); + ["ocaml"; "compile"; sprintf "warn_%c" (Char.uppercase_ascii c)] + (S[A"-w"; A (sprintf "%c" (Char.uppercase_ascii c))]); flag ~deprecated:true - ["ocaml"; "compile"; sprintf "warn_error_%c" (Char.uppercase c)] - (S[A"-warn-error"; A (sprintf "%c" (Char.uppercase c))]); + ["ocaml"; "compile"; sprintf "warn_error_%c" (Char.uppercase_ascii c)] + (S[A"-warn-error"; A (sprintf "%c" (Char.uppercase_ascii c))]); flag ~deprecated:true - ["ocaml"; "compile"; sprintf "warn_%c" (Char.lowercase c)] - (S[A"-w"; A (sprintf "%c" (Char.lowercase c))]); + ["ocaml"; "compile"; sprintf "warn_%c" (Char.lowercase_ascii c)] + (S[A"-w"; A (sprintf "%c" (Char.lowercase_ascii c))]); flag ~deprecated:true - ["ocaml"; "compile"; sprintf "warn_error_%c" (Char.lowercase c)] - (S[A"-warn-error"; A (sprintf "%c" (Char.lowercase c))]);; + ["ocaml"; "compile"; sprintf "warn_error_%c" (Char.lowercase_ascii c)] + (S[A"-warn-error"; A (sprintf "%c" (Char.lowercase_ascii c))]);; List.iter ocaml_warn_flag ['A'; 'C'; 'D'; 'E'; 'F'; 'K'; 'L'; 'M'; 'P'; 'R'; 'S'; 'U'; 'V'; 'X'; 'Y'; 'Z'];; diff --git a/ocamlbuild/ocaml_tools.ml b/ocamlbuild/ocaml_tools.ml index f4019c7ace..be6fed38e1 100644 --- a/ocamlbuild/ocaml_tools.ml +++ b/ocamlbuild/ocaml_tools.ml @@ -73,7 +73,7 @@ let menhir_modular menhir_base mlypack mlypack_depends env build = let tags = tags++"ocaml"++"parser"++"menhir" in Cmd(S[menhir ; A "--ocamlc"; Quote(S[!Options.ocamlc; T ocamlc_tags; ocaml_include_flags mlypack]); - T tags ; A "--infer" ; A "--base" ; Px menhir_base ; atomize_paths files]) + T tags ; A "--base" ; Px menhir_base ; atomize_paths files]) let ocamldep_command arg out env _build = let arg = env arg and out = env out in @@ -99,14 +99,14 @@ let infer_interface ml mli env build = let menhir mly env build = let mly = env mly in + let ml = Pathname.update_extension "ml" mly in let menhir = if !Options.ocamlyacc = N then V"MENHIR" else !Options.ocamlyacc in - let tags = tags_of_pathname mly in - let ocamlc_tags = tags++"ocaml"++"byte"++"compile" in - let menhir_tags = tags++"ocaml"++"parser"++"menhir" in + let ocamlc_tags = tags_of_pathname ml ++"ocaml"++"byte"++"compile" in + let menhir_tags = tags_of_pathname mly ++"ocaml"++"parser"++"menhir" in Ocaml_compiler.prepare_compile build mly; Cmd(S[menhir; A"--ocamlc"; Quote(S[!Options.ocamlc; T ocamlc_tags; ocaml_include_flags mly]); - T menhir_tags; A"--infer"; Px mly]) + T menhir_tags; Px mly]) let ocamldoc_c tags arg odoc = let tags = tags++"ocaml" in diff --git a/ocamlbuild/ocaml_utils.ml b/ocamlbuild/ocaml_utils.ml index 409f0a0694..5aedfb2c76 100644 --- a/ocamlbuild/ocaml_utils.ml +++ b/ocamlbuild/ocaml_utils.ml @@ -40,14 +40,14 @@ let pflag_and_dep tags ptag cmd_spec = (fun param -> flag_and_dep (Param_tags.make ptag param :: tags) (cmd_spec param)) -let module_name_of_filename f = String.capitalize (Pathname.remove_extensions f) +let module_name_of_filename f = String.capitalize_ascii (Pathname.remove_extensions f) let module_name_of_pathname x = module_name_of_filename (Pathname.to_string (Pathname.basename x)) let ignore_stdlib x = if !Options.nostdlib then false else - let x' = !*stdlib_dir/((String.uncapitalize x)-.-"cmi") in + let x' = !*stdlib_dir/((String.uncapitalize_ascii x)-.-"cmi") in Pathname.exists x' let non_dependencies = ref [] @@ -69,8 +69,8 @@ let expand_module = memo3 (fun include_dirs module_name exts -> let dirname = Pathname.dirname module_name in let basename = Pathname.basename module_name in - let module_name_cap = dirname/(String.capitalize basename) in - let module_name_uncap = dirname/(String.uncapitalize basename) in + let module_name_cap = dirname/(String.capitalize_ascii basename) in + let module_name_uncap = dirname/(String.uncapitalize_ascii basename) in List.fold_right begin fun include_dir -> List.fold_right begin fun ext acc -> include_dir/(module_name_uncap-.-ext) :: diff --git a/ocamlbuild/ocamlbuild_unix_plugin.ml b/ocamlbuild/ocamlbuild_unix_plugin.ml index 9966c4dc0f..2ed88b99d9 100644 --- a/ocamlbuild/ocamlbuild_unix_plugin.ml +++ b/ocamlbuild/ocamlbuild_unix_plugin.ml @@ -72,13 +72,22 @@ let execute_many = in Ocamlbuild_executor.execute ~exit +(* Ocamlbuild code assumes throughout that [readlink] will return a file name + relative to the current directory. Let's make it so. *) +let myunixreadlink x = + let y = Unix.readlink x in + if Filename.is_relative y then + Filename.concat (Filename.dirname x) y + else + y + let setup () = implem.is_degraded <- false; implem.stdout_isatty <- stdout_isatty; implem.gettimeofday <- Unix.gettimeofday; implem.report_error <- report_error; implem.execute_many <- execute_many; - implem.readlink <- Unix.readlink; + implem.readlink <- myunixreadlink; implem.run_and_open <- run_and_open; implem.at_exit_once <- at_exit_once; implem.is_link <- is_link; diff --git a/ocamlbuild/options.ml b/ocamlbuild/options.ml index 5193b9b904..32c518694d 100644 --- a/ocamlbuild/options.ml +++ b/ocamlbuild/options.ml @@ -77,7 +77,7 @@ let mk_virtual_solvers = List.iter begin fun cmd -> let solver () = A (find_tool cmd) - in Command.setup_virtual_command_solver (String.uppercase cmd) solver + in Command.setup_virtual_command_solver (String.uppercase_ascii cmd) solver end let () = @@ -101,7 +101,9 @@ let show_documentation = ref false let recursive = ref false let ext_lib = ref Ocamlbuild_config.a let ext_obj = ref Ocamlbuild_config.o -let ext_dll = ref Ocamlbuild_config.so +let ext_dll = + let s = Ocamlbuild_config.ext_dll in + ref (String.sub s 1 (String.length s - 1)) let exe = ref Ocamlbuild_config.exe let targets_internal = ref [] @@ -353,7 +355,7 @@ let init () = dir_reorder my_include_dirs include_dirs; dir_reorder my_exclude_dirs exclude_dirs; - ignore_list := List.map String.capitalize !ignore_list + ignore_list := List.map String.capitalize_ascii !ignore_list ;; (* The current heuristic: we know we are in an ocamlbuild project if diff --git a/ocamlbuild/signatures.mli b/ocamlbuild/signatures.mli index 0c323e2026..e7feaf2a6c 100644 --- a/ocamlbuild/signatures.mli +++ b/ocamlbuild/signatures.mli @@ -505,12 +505,15 @@ Given any list of package [l], [topological_closure l] returns a list of packages including [l] and their dependencies, in an order where any element may only depend on the previous ones. *) + val include_flags: package list -> command_spec + (** Return the list of include directories. *) + val compile_flags_byte: package list -> command_spec (** Return the flags to add when compiling in byte mode (include directories). *) val compile_flags_native: package list -> command_spec - (** Same as [link_flags_byte] but for native mode. *) + (** Same as [compile_flags_byte] but for native mode. *) val link_flags_byte: package list -> command_spec (** Return the flags to add when linking in byte mode. It includes: @@ -603,7 +606,7 @@ module type PLUGIN = sig target (or phony target), since it will be filled up by a digest of it dependencies. - The ~tags argument in deprecated, don't use it. - + Finally, the optional ~doc argument allows to give an informal explanation of the rule purpose and behavior, that will be displayed by [ocamlbuild -documentation]. For example, it is diff --git a/ocamlbuild/testsuite/internal.ml b/ocamlbuild/testsuite/internal.ml index d0071543f0..9b48af5273 100644 --- a/ocamlbuild/testsuite/internal.ml +++ b/ocamlbuild/testsuite/internal.ml @@ -160,6 +160,13 @@ let () = test "OutputObj" ~tree:[T.f "hello.ml" ~content:"print_endline \"Hello, World!\""] ~targets:("hello.byte.o",["hello.byte.c";"hello.native.o"]) ();; +let () = test "OutputShared" + ~options:[`no_ocamlfind] + ~description:"output_shared targets for native and bytecode (PR #6733)" + ~tree:[T.f "hello.ml" ~content:"print_endline \"Hello, World!\""; + T.f "_tags" ~content:"<*.so>: runtime_variant(_pic)"] + ~targets:("hello.byte.so",["hello.native.so"]) ();; + let () = test "StrictSequenceFlag" ~options:[`no_ocamlfind; `quiet] ~description:"strict_sequence tag" diff --git a/ocamldoc/.depend b/ocamldoc/.depend index b98bb57fe7..5a2df26c54 100644 --- a/ocamldoc/.depend +++ b/ocamldoc/.depend @@ -88,12 +88,14 @@ odoc_env.cmo : ../typing/types.cmi ../typing/printtyp.cmi \ odoc_env.cmx : ../typing/types.cmx ../typing/printtyp.cmx \ ../typing/predef.cmx ../typing/path.cmx odoc_name.cmx ../utils/misc.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_exception.cmo : ../typing/types.cmi odoc_types.cmi odoc_type.cmo \ + odoc_name.cmi +odoc_exception.cmx : ../typing/types.cmx odoc_types.cmx odoc_type.cmx \ + odoc_name.cmx +odoc_extension.cmo : ../typing/types.cmi odoc_types.cmi odoc_type.cmo \ + odoc_name.cmi ../parsing/asttypes.cmi +odoc_extension.cmx : ../typing/types.cmx odoc_types.cmx odoc_type.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 \ @@ -229,9 +231,9 @@ odoc_type.cmx : ../typing/types.cmx odoc_types.cmx odoc_name.cmx \ odoc_types.cmo : odoc_messages.cmo ../parsing/location.cmi odoc_types.cmi odoc_types.cmx : odoc_messages.cmx ../parsing/location.cmx odoc_types.cmi odoc_value.cmo : ../typing/types.cmi ../typing/printtyp.cmi odoc_types.cmi \ - odoc_parameter.cmo odoc_name.cmi + odoc_parameter.cmo odoc_name.cmi odoc_misc.cmi ../parsing/asttypes.cmi odoc_value.cmx : ../typing/types.cmx ../typing/printtyp.cmx odoc_types.cmx \ - odoc_parameter.cmx odoc_name.cmx + odoc_parameter.cmx odoc_name.cmx odoc_misc.cmx ../parsing/asttypes.cmi odoc_analyse.cmi : odoc_module.cmo odoc_global.cmi odoc_args.cmi : odoc_gen.cmi odoc_ast.cmi : ../typing/types.cmi ../typing/typedtree.cmi \ @@ -248,9 +250,10 @@ 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_extension.cmo odoc_exception.cmo odoc_class.cmo \ - ../parsing/location.cmi + ../parsing/location.cmi ../parsing/asttypes.cmi odoc_merge.cmi : odoc_types.cmi odoc_module.cmo -odoc_misc.cmi : ../typing/types.cmi odoc_types.cmi ../parsing/longident.cmi +odoc_misc.cmi : ../typing/types.cmi odoc_types.cmi ../parsing/longident.cmi \ + ../parsing/asttypes.cmi odoc_name.cmi : ../typing/path.cmi ../parsing/longident.cmi \ ../typing/ident.cmi odoc_parser.cmi : odoc_types.cmi diff --git a/ocamldoc/Makefile b/ocamldoc/Makefile index 7a487c6ca0..7c6d9885d7 100644 --- a/ocamldoc/Makefile +++ b/ocamldoc/Makefile @@ -11,16 +11,16 @@ #(***********************************************************************) include ../config/Makefile +CAMLRUN ?= ../boot/ocamlrun +CAMLYACC ?= ../boot/ocamlyacc # Various commands and dir ########################## 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 +OCAMLC = $(CAMLRUN) $(ROOTDIR)/ocamlc -nostdlib -I $(ROOTDIR)/stdlib +OCAMLOPT = $(CAMLRUN) $(ROOTDIR)/ocamlopt -nostdlib -I $(ROOTDIR)/stdlib +OCAMLDEP = $(CAMLRUN) $(ROOTDIR)/tools/ocamldep +OCAMLLEX = $(CAMLRUN) $(ROOTDIR)/boot/ocamllex OCAMLLIB = $(LIBDIR) OCAMLBIN = $(BINDIR) @@ -233,10 +233,10 @@ odoc_see_lexer.ml: odoc_see_lexer.mll $(OCAMLLEX) $< .mly.ml: - $(OCAMLYACC) -v $< + $(CAMLYACC) -v $< .mly.mli: - $(OCAMLYACC) -v $< + $(CAMLYACC) -v $< # Installation targets ###################### @@ -343,8 +343,8 @@ clean:: dummy @rm -f generators/*.cm[aiox] generators/*.$(A) generators/*.$(O) generators/*.cmx[as] depend:: - $(OCAMLYACC) odoc_text_parser.mly - $(OCAMLYACC) odoc_parser.mly + $(CAMLYACC) odoc_text_parser.mly + $(CAMLYACC) odoc_parser.mly $(OCAMLLEX) odoc_text_lexer.mll $(OCAMLLEX) odoc_lexer.mll $(OCAMLLEX) odoc_ocamlhtml.mll diff --git a/ocamldoc/Makefile.nt b/ocamldoc/Makefile.nt index 22cd36eb03..9c009596be 100644 --- a/ocamldoc/Makefile.nt +++ b/ocamldoc/Makefile.nt @@ -11,16 +11,16 @@ #(***********************************************************************) include ../config/Makefile +CAMLRUN ?= ../boot/ocamlrun +CAMLYACC ?= ../boot/ocamlyacc # Various commands and dir ########################## 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 +OCAMLC = $(CAMLRUN) $(ROOTDIR)/ocamlc -nostdlib -I $(ROOTDIR)/stdlib +OCAMLOPT = $(CAMLRUN) $(ROOTDIR)/ocamlopt -nostdlib -I $(ROOTDIR)/stdlib +OCAMLDEP = $(CAMLRUN) $(ROOTDIR)/tools/ocamldep +OCAMLLEX = $(CAMLRUN) $(ROOTDIR)/boot/ocamllex OCAMLLIB = $(LIBDIR) OCAMLBIN = $(BINDIR) @@ -202,10 +202,10 @@ odoc_see_lexer.ml: odoc_see_lexer.mll $(OCAMLLEX) $< .mly.ml: - $(OCAMLYACC) -v $< + $(CAMLYACC) -v $< .mly.mli: - $(OCAMLYACC) -v $< + $(CAMLYACC) -v $< # Installation targets ###################### @@ -240,8 +240,8 @@ clean:: dummy @rm -f generators/*.cm[aiox] generators/*.$(A) generators/*.$(O) generators/*.cmx[as] depend:: - $(OCAMLYACC) odoc_text_parser.mly - $(OCAMLYACC) odoc_parser.mly + $(CAMLYACC) odoc_text_parser.mly + $(CAMLYACC) odoc_parser.mly $(OCAMLLEX) odoc_text_lexer.mll $(OCAMLLEX) odoc_lexer.mll $(OCAMLLEX) odoc_ocamlhtml.mll diff --git a/ocamldoc/odoc_analyse.ml b/ocamldoc/odoc_analyse.ml index fd69b0a74d..a5ce18cba0 100644 --- a/ocamldoc/odoc_analyse.ml +++ b/ocamldoc/odoc_analyse.ml @@ -62,7 +62,7 @@ let tool_name = "ocamldoc" let process_implementation_file ppf sourcefile = init_path (); let prefixname = Filename.chop_extension sourcefile in - let modulename = String.capitalize(Filename.basename prefixname) in + let modulename = String.capitalize_ascii(Filename.basename prefixname) in Env.set_unit_name modulename; let inputfile = preprocess sourcefile in let env = initial_env () in @@ -95,7 +95,7 @@ let process_implementation_file ppf sourcefile = let process_interface_file ppf sourcefile = init_path (); let prefixname = Filename.chop_extension sourcefile in - let modulename = String.capitalize(Filename.basename prefixname) in + let modulename = String.capitalize_ascii(Filename.basename prefixname) in Env.set_unit_name modulename; let inputfile = preprocess sourcefile in let ast = @@ -205,7 +205,7 @@ let process_file ppf sourcefile = try Filename.chop_extension file with _ -> file in - String.capitalize (Filename.basename s) + String.capitalize_ascii (Filename.basename s) in let txt = try Odoc_text.Texter.text_of_string (Odoc_misc.input_file_as_string file) diff --git a/ocamldoc/odoc_ast.ml b/ocamldoc/odoc_ast.ml index ce71070efe..3ccdce5cb9 100644 --- a/ocamldoc/odoc_ast.ml +++ b/ocamldoc/odoc_ast.ml @@ -83,17 +83,17 @@ module Typedtree_search = end | Typedtree.Tstr_exception ext -> Hashtbl.add table (E (Name.from_ident ext.ext_id)) tt - | Typedtree.Tstr_type ident_type_decl_list -> + | Typedtree.Tstr_type (rf, ident_type_decl_list) -> List.iter (fun td -> Hashtbl.add table (T (Name.from_ident td.typ_id)) - (Typedtree.Tstr_type [td])) + (Typedtree.Tstr_type (rf, [td]))) ident_type_decl_list | Typedtree.Tstr_class info_list -> List.iter - (fun (ci, m, s) -> + (fun (ci, s) -> Hashtbl.add table (C (Name.from_ident ci.ci_id_class)) - (Typedtree.Tstr_class [ci, m, s])) + (Typedtree.Tstr_class [ci, s])) info_list | Typedtree.Tstr_class_type info_list -> List.iter @@ -145,12 +145,12 @@ module Typedtree_search = let search_type_declaration table name = match Hashtbl.find table (T name) with - | (Typedtree.Tstr_type [td]) -> td + | (Typedtree.Tstr_type (_, [td])) -> td | _ -> assert false let search_class_exp table name = match Hashtbl.find table (C name) with - | (Typedtree.Tstr_class [(ci, _, _ )]) -> + | (Typedtree.Tstr_class [(ci, _ )]) -> let ce = ci.ci_expr in ( try @@ -1179,10 +1179,9 @@ module Analyser = let new_env = Odoc_env.add_value env new_value.val_name in (0, new_env, [Element_value new_value]) - | Parsetree.Pstr_type name_typedecl_list -> + | Parsetree.Pstr_type (rf, name_typedecl_list) -> (* of (string * type_declaration) list *) - (* we start by extending the environment *) - let new_env = + let extended_env = List.fold_left (fun acc_env {Parsetree.ptype_name = { txt = name }} -> let complete_name = Name.concat current_module_name name in @@ -1191,6 +1190,11 @@ module Analyser = env name_typedecl_list in + let env = + match rf with + | Recursive -> extended_env + | Nonrecursive -> env + in let rec f ?(first=false) maybe_more_acc last_pos name_type_decl_list = match name_type_decl_list with [] -> (maybe_more_acc, []) @@ -1220,7 +1224,7 @@ module Analyser = get_comments_in_module last_pos loc_start in let kind = Sig.get_type_kind - new_env name_comment_list + env name_comment_list tt_type_decl.Types.type_kind in let new_end = loc_end + maybe_more in @@ -1232,7 +1236,7 @@ module Analyser = List.map2 (fun p v -> let (co, cn) = Types.Variance.get_upper v in - (Odoc_env.subst_type new_env p, co, cn)) + (Odoc_env.subst_type env p, co, cn)) tt_type_decl.Types.type_params tt_type_decl.Types.type_variance ; ty_kind = kind ; @@ -1241,7 +1245,7 @@ module Analyser = (match tt_type_decl.Types.type_manifest with None -> None | Some t -> - Some (Sig.manifest_structure new_env name_comment_list t)); + Some (Sig.manifest_structure env name_comment_list t)); ty_loc = { loc_impl = Some loc ; loc_inter = None } ; ty_code = ( @@ -1262,7 +1266,7 @@ module Analyser = (maybe_more3, ele_comments @ ((Element_type t) :: eles)) in let (maybe_more, eles) = f ~first: true 0 loc.Location.loc_start.Lexing.pos_cnum name_typedecl_list in - (maybe_more, new_env, eles) + (maybe_more, extended_env, eles) | Parsetree.Pstr_typext tyext -> (* we get the extension declaration in the typed tree *) @@ -1715,7 +1719,11 @@ module Analyser = } in match (p_module_expr.Parsetree.pmod_desc, tt_module_expr.Typedtree.mod_desc) with - (Parsetree.Pmod_ident longident, Typedtree.Tmod_ident (path, _)) -> + (Parsetree.Pmod_ident longident, Typedtree.Tmod_ident (path, _)) + | (Parsetree.Pmod_ident longident, + Typedtree.Tmod_constraint + ({Typedtree.mod_desc = Typedtree.Tmod_ident (path, _)}, _, _, _)) + -> let alias_name = Odoc_env.full_module_name env (Name.from_path path) in { m_base with m_kind = Module_alias { ma_name = alias_name ; ma_module = None ; } } @@ -1865,6 +1873,7 @@ module Analyser = (*DEBUG*) | Parsetree.Pmod_apply _ -> "Pmod_apply" (*DEBUG*) | Parsetree.Pmod_constraint _ -> "Pmod_constraint" (*DEBUG*) | Parsetree.Pmod_unpack _ -> "Pmod_unpack" + (*DEBUG*) | Parsetree.Pmod_extension _ -> "Pmod_extension" (*DEBUG*)in (*DEBUG*)let s_typed = (*DEBUG*) match typedtree with @@ -1899,7 +1908,7 @@ module Analyser = in prepare_file complete_source_file input_file; (* We create the t_module for this file. *) - let mod_name = String.capitalize (Filename.basename (Filename.chop_extension source_file)) in + let mod_name = String.capitalize_ascii (Filename.basename (Filename.chop_extension source_file)) in let (len,info_opt) = My_ir.first_special !file_name !file in (* we must complete the included modules *) diff --git a/ocamldoc/odoc_html.ml b/ocamldoc/odoc_html.ml index 0c5293ea12..28f49c4abd 100644 --- a/ocamldoc/odoc_html.ml +++ b/ocamldoc/odoc_html.ml @@ -307,7 +307,7 @@ class virtual text = method html_of_custom_text b s t = () method html_of_Target b ~target ~code = - if String.lowercase target = "html" then bs b code else () + if String.lowercase_ascii target = "html" then bs b code else () method html_of_Raw b s = bs b (self#escape s) @@ -2312,7 +2312,7 @@ class html = [] -> () | e :: _ -> let s = - match (Char.uppercase (Name.simple (name e)).[0]) with + match (Char.uppercase_ascii (Name.simple (name e)).[0]) with 'A'..'Z' as c -> String.make 1 c | _ -> "" in diff --git a/ocamldoc/odoc_info.mli b/ocamldoc/odoc_info.mli index d1b98e2245..451315543a 100644 --- a/ocamldoc/odoc_info.mli +++ b/ocamldoc/odoc_info.mli @@ -780,11 +780,11 @@ val create_index_lists : 'a list -> ('a -> string) -> 'a list list val remove_option : Types.type_expr -> Types.type_expr (** Return [true] if the given label is optional.*) -val is_optional : string -> bool +val is_optional : Asttypes.arg_label -> bool (** Return the label name for the given label, i.e. removes the beginning '?' if present.*) -val label_name : string -> string +val label_name : Asttypes.arg_label -> string (** Return the given name where the module name or part of it was removed, according to the list of modules diff --git a/ocamldoc/odoc_latex.ml b/ocamldoc/odoc_latex.ml index b2145d1bc9..2273a6d0ab 100644 --- a/ocamldoc/odoc_latex.ml +++ b/ocamldoc/odoc_latex.ml @@ -293,7 +293,7 @@ class text = method latex_of_custom_text fmt s t = () method latex_of_Target fmt ~target ~code = - if String.lowercase target = "latex" then + if String.lowercase_ascii target = "latex" then self#latex_of_Latex fmt code else () diff --git a/ocamldoc/odoc_man.ml b/ocamldoc/odoc_man.ml index 13733ba8e1..effe6c83b3 100644 --- a/ocamldoc/odoc_man.ml +++ b/ocamldoc/odoc_man.ml @@ -340,7 +340,7 @@ class man = method man_of_custom_text b s t = () method man_of_Target b ~target ~code = - if String.lowercase target = "man" then bs b code else () + if String.lowercase_ascii target = "man" then bs b code else () (** Print groff string to display code. *) method man_of_code b s = self#man_of_text b [ Code s ] diff --git a/ocamldoc/odoc_misc.ml b/ocamldoc/odoc_misc.ml index e938dbe679..0bc9ade459 100644 --- a/ocamldoc/odoc_misc.ml +++ b/ocamldoc/odoc_misc.ml @@ -454,7 +454,7 @@ let create_index_lists elements string_of_ele = match s with "" -> f current acc0 acc1 (acc2 @ [ele]) q | _ -> - let first = Char.uppercase s.[0] in + let first = Char.uppercase_ascii s.[0] in match first with 'A' .. 'Z' -> if current = first then diff --git a/ocamldoc/odoc_misc.mli b/ocamldoc/odoc_misc.mli index 5958be91db..dd5a7fcb9b 100644 --- a/ocamldoc/odoc_misc.mli +++ b/ocamldoc/odoc_misc.mli @@ -107,8 +107,8 @@ val search_string_backward : pat: string -> s: string -> int val remove_option : Types.type_expr -> Types.type_expr (** Return [true] if the given label is optional.*) -val is_optional : string -> bool +val is_optional : Asttypes.arg_label -> bool (** Return the label name for the given label, i.e. removes the beginning '?' if present.*) -val label_name : string -> string +val label_name : Asttypes.arg_label -> string diff --git a/ocamldoc/odoc_name.ml b/ocamldoc/odoc_name.ml index bdb1f58c48..9824101bea 100644 --- a/ocamldoc/odoc_name.ml +++ b/ocamldoc/odoc_name.ml @@ -28,6 +28,8 @@ let infix_chars = [ '|' ; ':' ; '~' ; '!' ; + '.' ; + '#' ; ] type t = string diff --git a/ocamldoc/odoc_ocamlhtml.mll b/ocamldoc/odoc_ocamlhtml.mll index 975229da84..9b3ad2da18 100644 --- a/ocamldoc/odoc_ocamlhtml.mll +++ b/ocamldoc/odoc_ocamlhtml.mll @@ -37,7 +37,6 @@ let base_escape_strings = [ let pre_escape_strings = [ (" ", " ") ; - ("\n", "<br>\n") ; ("\t", " ") ; ] diff --git a/ocamldoc/odoc_sig.ml b/ocamldoc/odoc_sig.ml index c2d3651184..f8ccb08f52 100644 --- a/ocamldoc/odoc_sig.ml +++ b/ocamldoc/odoc_sig.ml @@ -335,10 +335,10 @@ module Analyser = | Parsetree.Psig_include _ | Parsetree.Psig_class _ | Parsetree.Psig_class_type _ as tp -> take_item tp - | Parsetree.Psig_type types -> + | Parsetree.Psig_type (rf, types) -> (match List.filter (fun td -> not (Name.Set.mem td.Parsetree.ptype_name.txt erased)) types with | [] -> acc - | types -> take_item (Parsetree.Psig_type types)) + | types -> take_item (Parsetree.Psig_type (rf, types))) | Parsetree.Psig_module {Parsetree.pmd_name=name} | Parsetree.Psig_modtype {Parsetree.pmtd_name=name} as m -> if Name.Set.mem name.txt erased then acc else take_item m @@ -738,9 +738,8 @@ module Analyser = 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 -> - (* we start by extending the environment *) - let new_env = + | Parsetree.Psig_type (rf, name_type_decl_list) -> + let extended_env = List.fold_left (fun acc_env td -> let complete_name = Name.concat current_module_name td.Parsetree.ptype_name.txt in @@ -749,6 +748,11 @@ module Analyser = env name_type_decl_list in + let env = + match rf with + | Recursive -> extended_env + | Nonrecursive -> env + in let rec f ?(first=false) acc_maybe_more last_pos name_type_decl_list = match name_type_decl_list with [] -> @@ -784,7 +788,7 @@ module Analyser = raise (Failure (Odoc_messages.type_not_found current_module_name name.txt)) in (* get the type kind with the associated comments *) - let type_kind = get_type_kind new_env name_comment_list sig_type_decl.Types.type_kind in + let type_kind = get_type_kind env name_comment_list sig_type_decl.Types.type_kind in let loc_start = type_decl.Parsetree.ptype_loc.Location.loc_start.Lexing.pos_cnum in let new_end = type_decl.Parsetree.ptype_loc.Location.loc_end.Lexing.pos_cnum + maybe_more in (* associate the comments to each constructor and build the [Type.t_type] *) @@ -795,7 +799,7 @@ module Analyser = ty_parameters = List.map2 (fun p v -> let (co, cn) = Types.Variance.get_upper v in - (Odoc_env.subst_type new_env p,co, cn)) + (Odoc_env.subst_type env p,co, cn)) sig_type_decl.Types.type_params sig_type_decl.Types.type_variance; ty_kind = type_kind; @@ -830,7 +834,7 @@ module Analyser = (new_maybe_more, (ele_comments @ [Element_type new_type]) @ eles) in let (maybe_more, types) = f ~first: true 0 pos_start_ele name_type_decl_list in - (maybe_more, new_env, types) + (maybe_more, extended_env, types) | Parsetree.Psig_open _ -> (* A VOIR *) let ele_comments = match comment_opt with @@ -1520,7 +1524,7 @@ module Analyser = in prepare_file complete_source_file input_file; (* We create the t_module for this file. *) - let mod_name = String.capitalize + let mod_name = String.capitalize_ascii (Filename.basename (try Filename.chop_extension source_file with _ -> source_file)) in let (len,info_opt) = My_ir.first_special !file_name !file in diff --git a/ocamldoc/odoc_str.ml b/ocamldoc/odoc_str.ml index 1536640e58..281496bb31 100644 --- a/ocamldoc/odoc_str.ml +++ b/ocamldoc/odoc_str.ml @@ -148,8 +148,8 @@ let string_of_class_params c = Printf.bprintf b "%s%s%s%s -> " ( match label with - "" -> "" - | s -> s^":" + Asttypes.Nolabel -> "" + | s -> Printtyp.string_of_label s ^":" ) (if parent then "(" else "") (Odoc_print.string_of_type_expr diff --git a/ocamldoc/odoc_texi.ml b/ocamldoc/odoc_texi.ml index afa4d49f70..77489ec90b 100644 --- a/ocamldoc/odoc_texi.ml +++ b/ocamldoc/odoc_texi.ml @@ -311,7 +311,7 @@ class text = method texi_of_custom_text s t = "" method texi_of_Target ~target ~code = - if String.lowercase target = "texi" then code else "" + if String.lowercase_ascii target = "texi" then code else "" method texi_of_Verbatim s = s method texi_of_Raw s = self#escape s diff --git a/ocamldoc/odoc_text_lexer.mll b/ocamldoc/odoc_text_lexer.mll index c8dda36aa9..fd1735419c 100644 --- a/ocamldoc/odoc_text_lexer.mll +++ b/ocamldoc/odoc_text_lexer.mll @@ -846,6 +846,7 @@ rule main = parse else LBRACE } +| '\r' { main lexbuf } | _ { incr_cpts lexbuf ; diff --git a/ocamldoc/odoc_value.ml b/ocamldoc/odoc_value.ml index b35f2c6b52..7caedb3600 100644 --- a/ocamldoc/odoc_value.ml +++ b/ocamldoc/odoc_value.ml @@ -95,22 +95,16 @@ let parameter_list_from_arrows typ = so there is nothing to merge. With this dummy list we can merge the parameter names from the .ml and the type from the .mli file. *) let dummy_parameter_list typ = - let normal_name s = - match s with - "" -> s - | _ -> - match s.[0] with - '?' -> String.sub s 1 ((String.length s) - 1) - | _ -> s - in + let normal_name = Odoc_misc.label_name in Printtyp.mark_loops typ; let liste_param = parameter_list_from_arrows typ in let rec iter (label, t) = match t.Types.desc with | Types.Ttuple l -> - if label = "" then + let open Asttypes in + if label = Nolabel then Odoc_parameter.Tuple - (List.map (fun t2 -> iter ("", t2)) l, t) + (List.map (fun t2 -> iter (Nolabel, t2)) l, t) else (* if there is a label, then we don't want to decompose the tuple *) Odoc_parameter.Simple_name diff --git a/otherlibs/Makefile b/otherlibs/Makefile index 397497dd55..3ca2a487ff 100644 --- a/otherlibs/Makefile +++ b/otherlibs/Makefile @@ -13,10 +13,10 @@ # Common Makefile for otherlibs on the Unix ports -CAMLC=$(ROOTDIR)/boot/ocamlrun $(ROOTDIR)/ocamlc -nostdlib -I $(ROOTDIR)/stdlib -CAMLOPT=$(ROOTDIR)/boot/ocamlrun $(ROOTDIR)/ocamlopt -nostdlib \ +CAMLC=$(CAMLRUN) $(ROOTDIR)/ocamlc -nostdlib -I $(ROOTDIR)/stdlib +CAMLOPT=$(CAMLRUN) $(ROOTDIR)/ocamlopt -nostdlib \ -I $(ROOTDIR)/stdlib -CFLAGS=-I$(ROOTDIR)/byterun -O $(SHAREDCCCOMPOPTS) $(EXTRACFLAGS) +CFLAGS=-I$(ROOTDIR)/byterun $(SHAREDCCCOMPOPTS) $(EXTRACFLAGS) include ../Makefile.shared # Note .. is the current directory (this makefile is included from diff --git a/otherlibs/Makefile.shared b/otherlibs/Makefile.shared index 9bed5f7604..cb8bf1748c 100644 --- a/otherlibs/Makefile.shared +++ b/otherlibs/Makefile.shared @@ -15,10 +15,11 @@ ROOTDIR=../.. include $(ROOTDIR)/config/Makefile +CAMLRUN ?= $(ROOTDIR)/boot/ocamlrun +CAMLYACC ?= $(ROOTDIR)/boot/ocamlyacc # Compilation options CC=$(BYTECC) -CAMLRUN=$(ROOTDIR)/boot/ocamlrun COMPFLAGS=-w +33..39 -warn-error A -bin-annot -g -safe-string $(EXTRACAMLFLAGS) MKLIB=$(CAMLRUN) $(ROOTDIR)/tools/ocamlmklib diff --git a/otherlibs/bigarray/.depend b/otherlibs/bigarray/.depend index 889328a333..a1deb36497 100644 --- a/otherlibs/bigarray/.depend +++ b/otherlibs/bigarray/.depend @@ -1,21 +1,28 @@ -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 -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 -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 +bigarray_stubs.o: bigarray_stubs.c ../../byterun/caml/alloc.h \ + ../../byterun/caml/misc.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/mlvalues.h bigarray.h ../../byterun/caml/config.h \ + ../../byterun/caml/mlvalues.h ../../byterun/caml/custom.h \ + ../../byterun/caml/fail.h ../../byterun/caml/intext.h \ + ../../byterun/caml/io.h ../../byterun/caml/hash.h \ + ../../byterun/caml/memory.h ../../byterun/caml/gc.h \ + ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \ + ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \ + ../../byterun/caml/signals.h +mmap_unix.o: mmap_unix.c bigarray.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/mlvalues.h ../../byterun/caml/config.h \ + ../../byterun/caml/misc.h ../../byterun/caml/custom.h \ + ../../byterun/caml/mlvalues.h ../../byterun/caml/fail.h \ + ../../byterun/caml/io.h ../../byterun/caml/sys.h \ + ../../byterun/caml/signals.h +mmap_win32.o: mmap_win32.c bigarray.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/mlvalues.h ../../byterun/caml/config.h \ + ../../byterun/caml/misc.h ../../byterun/caml/alloc.h \ + ../../byterun/caml/mlvalues.h ../../byterun/caml/custom.h \ + ../../byterun/caml/fail.h ../../byterun/caml/sys.h \ + ../unix/unixsupport.h bigarray.cmi : bigarray.cmo : bigarray.cmi bigarray.cmx : bigarray.cmi diff --git a/otherlibs/bigarray/Makefile b/otherlibs/bigarray/Makefile index 3f8c52f20f..3bcc7a4022 100644 --- a/otherlibs/bigarray/Makefile +++ b/otherlibs/bigarray/Makefile @@ -21,7 +21,7 @@ HEADERS=bigarray.h include ../Makefile depend: - gcc -MM $(CFLAGS) *.c > .depend - ../../boot/ocamlrun ../../tools/ocamldep *.mli *.ml >> .depend + $(CC) -MM $(CFLAGS) *.c > .depend + $(CAMLRUN) ../../tools/ocamldep *.mli *.ml >> .depend include .depend diff --git a/otherlibs/bigarray/Makefile.nt b/otherlibs/bigarray/Makefile.nt index db5ed60586..baeaa7a160 100644 --- a/otherlibs/bigarray/Makefile.nt +++ b/otherlibs/bigarray/Makefile.nt @@ -21,7 +21,7 @@ HEADERS=bigarray.h include ../Makefile.nt depend: - gcc -MM $(CFLAGS) *.c > .depend - ../../boot/ocamlrun ../../tools/ocamldep *.mli *.ml >> .depend + $(CC) -MM $(CFLAGS) *.c > .depend + $(CAMLRUN) ../../tools/ocamldep *.mli *.ml >> .depend include .depend diff --git a/otherlibs/bigarray/bigarray.h b/otherlibs/bigarray/bigarray.h index c10e20cfb3..23bde23336 100644 --- a/otherlibs/bigarray/bigarray.h +++ b/otherlibs/bigarray/bigarray.h @@ -15,10 +15,10 @@ #define CAML_BIGARRAY_H #ifndef CAML_NAME_SPACE -#include "compatibility.h" +#include "caml/compatibility.h" #endif -#include "config.h" -#include "mlvalues.h" +#include "caml/config.h" +#include "caml/mlvalues.h" typedef signed char caml_ba_int8; typedef unsigned char caml_ba_uint8; @@ -106,10 +106,18 @@ struct caml_ba_array { #define CAMLBAextern CAMLextern #endif +#ifdef __cplusplus +extern "C" { +#endif + CAMLBAextern value caml_ba_alloc(int flags, int num_dims, void * data, intnat * dim); CAMLBAextern value caml_ba_alloc_dims(int flags, int num_dims, void * data, ... /*dimensions, with type intnat */); CAMLBAextern uintnat caml_ba_byte_size(struct caml_ba_array * b); +#ifdef __cplusplus +} #endif + +#endif /* CAML_BIGARRAY_H */ diff --git a/otherlibs/bigarray/bigarray.ml b/otherlibs/bigarray/bigarray.ml index 960c972416..7d348a5fa8 100644 --- a/otherlibs/bigarray/bigarray.ml +++ b/otherlibs/bigarray/bigarray.ml @@ -281,3 +281,23 @@ external get3: unit -> unit = "caml_ba_get_3" external set1: unit -> unit = "caml_ba_set_1" external set2: unit -> unit = "caml_ba_set_2" external set3: unit -> unit = "caml_ba_set_3" + +(* Index operators *) + +(* Array1 *) +external ( .{} ) : ('a, 'b, 'c) Array1.t -> int -> 'a = "%caml_ba_opt_ref_1" +external ( .{} <- ) : ('a, 'b, 'c) Array1.t -> int -> 'a -> unit = "%caml_ba_opt_set_1" + + +(* Array2 *) +external ( .{,} ) : ('a, 'b, 'c) Array2.t -> int->int -> 'a = "%caml_ba_opt_ref_2" +external ( .{,} <- ) : ('a, 'b, 'c) Array2.t -> int->int -> 'a -> unit = "%caml_ba_opt_set_2" + +(*Array3*) +external ( .{,,} ) : ('a, 'b, 'c) Array3.t -> int->int->int -> 'a = "%caml_ba_opt_ref_3" +external ( .{,,} <- ) : ('a, 'b, 'c) Array3.t -> int->int->int -> 'a -> unit = "%caml_ba_opt_set_3" + + +(*Genarray*) +external ( .{,..,} ) : ('a, 'b, 'c) Genarray.t -> int array -> 'a = "caml_ba_get_generic" +external ( .{,..,} <- ) : ('a, 'b, 'c) Genarray.t -> int array -> 'a -> unit = "caml_ba_set_generic" diff --git a/otherlibs/bigarray/bigarray.mli b/otherlibs/bigarray/bigarray.mli index b3016a7171..da044ab141 100644 --- a/otherlibs/bigarray/bigarray.mli +++ b/otherlibs/bigarray/bigarray.mli @@ -452,10 +452,24 @@ module Genarray : the initial call to [map_file]. Therefore, you should make sure no other process modifies the mapped file while you're accessing it, or a SIGBUS signal may be raised. This happens, for instance, if the - file is shrinked. *) + file is shrunk. + + This function raises [Sys_error] in the case of any errors from the + underlying system calls. [Invalid_argument] or [Failure] may be + raised in cases where argument validation fails. *) end +external ( .{,..,} ) : ('a, 'b, 'c) Genarray.t -> int array -> 'a = "caml_ba_get_generic" +(** Index operator for generic arrays. When the [Bigarray] module is open, + [ bigarray.{a,b,c,d,...} ] is desugared to [ (.{,..,} ) bigarray [|a,b,c,d,...|] ]. + *) + +external ( .{,..,} <- ) : ('a, 'b, 'c) Genarray.t -> int array -> 'a -> unit = "caml_ba_set_generic" +(** Indexed assignment operator for generic arrays. When the [Bigarray] module is open, + [ bigarray.{a,b,c,d,...} <- x ] is desugared to [ (.{,..,} ) bigarray [|a,b,c,d,...|] x ]. + *) + (** {6 One-dimensional arrays} *) (** One-dimensional arrays. The [Array1] structure provides operations @@ -537,6 +551,15 @@ module Array1 : sig end +external ( .{} ) : ('a, 'b, 'c) Array1.t -> int -> 'a = "%caml_ba_opt_ref_1" +(** Index operator for one-dimensional arrays. When the [Bigarray] module is open, + [ bigarray.{a} ] is desugared to [ (.{} ) bigarray a ]. + *) + +external ( .{} <- ) : ('a, 'b, 'c) Array1.t -> int -> 'a -> unit = "%caml_ba_opt_set_1" +(** Indexed assignment operator for one-dimensional arrays. When the [Bigarray] module is open, + [ bigarray.{a} <- x ] is desugared to [ (.{} ) bigarray x ]. + *) (** {6 Two-dimensional arrays} *) @@ -641,6 +664,17 @@ module Array2 : end +external ( .{,} ) : ('a, 'b, 'c) Array2.t -> int -> int -> 'a = "%caml_ba_opt_ref_2" +(** Index operator for bidimensional arrays. When the [Bigarray] module is open, + [ bigarray.{a,b} ] is desugared to [ (.{,} ) bigarray a b ]. + *) + +external ( .{,} <- ) : ('a, 'b, 'c) Array2.t -> int -> int -> 'a -> unit = "%caml_ba_opt_set_2" +(** Indexed assignment operator for bidimensionnal arrays. When the [Bigarray] module is open, + [ bigarray.{a,b} <- x ] is desugared to [ (.{,} ) bigarray a b x ]. + *) + + (** {6 Three-dimensional arrays} *) (** Three-dimensional arrays. The [Array3] structure provides operations @@ -769,6 +803,16 @@ module Array3 : end +external ( .{,,} ) : ('a, 'b, 'c) Array3.t -> int -> int -> int -> 'a = "%caml_ba_opt_ref_3" +(** Index operator for tridimensional arrays. When the [Bigarray] module is open, + [ bigarray.{a,b,c} ] is desugared to [ (.{,} ) bigarray a b c ]. + *) + +external ( .{,,} <- ) : ('a, 'b, 'c) Array3.t -> int -> int -> int -> 'a -> unit = "%caml_ba_opt_set_3" +(** Indexed assignment operator for tridimensionnal arrays. When the [Bigarray] module is open, + [ bigarray.{a,b,c} <- x ] is desugared to [ (.{,,} ) bigarray a b c x ]. + *) + (** {6 Coercions between generic big arrays and fixed-dimension big arrays} *) external genarray_of_array1 : diff --git a/otherlibs/bigarray/bigarray_stubs.c b/otherlibs/bigarray/bigarray_stubs.c index f2ccb92ba1..c8416f9d6a 100644 --- a/otherlibs/bigarray/bigarray_stubs.c +++ b/otherlibs/bigarray/bigarray_stubs.c @@ -14,14 +14,15 @@ #include <stddef.h> #include <stdarg.h> #include <string.h> -#include "alloc.h" +#include "caml/alloc.h" #include "bigarray.h" -#include "custom.h" -#include "fail.h" -#include "intext.h" -#include "hash.h" -#include "memory.h" -#include "mlvalues.h" +#include "caml/custom.h" +#include "caml/fail.h" +#include "caml/intext.h" +#include "caml/hash.h" +#include "caml/memory.h" +#include "caml/mlvalues.h" +#include "caml/signals.h" #define int8 caml_ba_int8 #define uint8 caml_ba_uint8 @@ -1120,12 +1121,19 @@ CAMLprim value caml_ba_sub(value vb, value vofs, value vlen) /* Copying a big array into another one */ +#define LEAVE_RUNTIME_OP_CUTOFF 4096 +#define is_mmapped(ba) ((ba)->flags & CAML_BA_MAPPED_FILE) + CAMLprim value caml_ba_blit(value vsrc, value vdst) { + CAMLparam2(vsrc, vdst); struct caml_ba_array * src = Caml_ba_array_val(vsrc); struct caml_ba_array * dst = Caml_ba_array_val(vdst); + void *src_data = src->data; + void *dst_data = dst->data; int i; intnat num_bytes; + int leave_runtime; /* Check same numbers of dimensions and same dimensions */ if (src->num_dims != dst->num_dims) goto blit_error; @@ -1135,19 +1143,44 @@ CAMLprim value caml_ba_blit(value vsrc, value vdst) num_bytes = caml_ba_num_elts(src) * caml_ba_element_size[src->flags & CAML_BA_KIND_MASK]; + leave_runtime = + ( + (num_bytes >= LEAVE_RUNTIME_OP_CUTOFF*sizeof(long)) + || is_mmapped(src) + || is_mmapped(dst) + ); /* Do the copying */ - memmove (dst->data, src->data, num_bytes); - return Val_unit; + if (leave_runtime) caml_enter_blocking_section(); + memmove (dst_data, src_data, num_bytes); + if (leave_runtime) caml_leave_blocking_section(); + CAMLreturn (Val_unit); blit_error: caml_invalid_argument("Bigarray.blit: dimension mismatch"); - return Val_unit; /* not reached */ + CAMLreturn (Val_unit); /* not reached */ } /* Filling a big array with a given value */ +#define FILL_GEN_LOOP(n_ops, loop) do{ \ + int leave_runtime = ((n_ops >= LEAVE_RUNTIME_OP_CUTOFF) || is_mmapped(b)); \ + if (leave_runtime) caml_enter_blocking_section(); \ + loop; \ + if (leave_runtime) caml_leave_blocking_section(); \ +}while(0) + +#define FILL_SCALAR_LOOP \ + FILL_GEN_LOOP(num_elts, \ + for (p = data; num_elts > 0; p++, num_elts--) *p = init) + +#define FILL_COMPLEX_LOOP \ + FILL_GEN_LOOP(num_elts + num_elts, \ + for (p = data; num_elts > 0; num_elts--) { *p++ = init0; *p++ = init1; }) + CAMLprim value caml_ba_fill(value vb, value vinit) { + CAMLparam1(vb); struct caml_ba_array * b = Caml_ba_array_val(vb); + void *data = b->data; intnat num_elts = caml_ba_num_elts(b); switch (b->flags & CAML_BA_KIND_MASK) { @@ -1156,13 +1189,13 @@ CAMLprim value caml_ba_fill(value vb, value vinit) case CAML_BA_FLOAT32: { float init = Double_val(vinit); float * p; - for (p = b->data; num_elts > 0; p++, num_elts--) *p = init; + FILL_SCALAR_LOOP; break; } case CAML_BA_FLOAT64: { double init = Double_val(vinit); double * p; - for (p = b->data; num_elts > 0; p++, num_elts--) *p = init; + FILL_SCALAR_LOOP; break; } case CAML_BA_CHAR: @@ -1170,56 +1203,56 @@ CAMLprim value caml_ba_fill(value vb, value vinit) case CAML_BA_UINT8: { int init = Int_val(vinit); unsigned char * p; - for (p = b->data; num_elts > 0; p++, num_elts--) *p = init; + FILL_SCALAR_LOOP; break; } case CAML_BA_SINT16: case CAML_BA_UINT16: { int init = Int_val(vinit); int16 * p; - for (p = b->data; num_elts > 0; p++, num_elts--) *p = init; + FILL_SCALAR_LOOP; break; } case CAML_BA_INT32: { int32_t init = Int32_val(vinit); int32_t * p; - for (p = b->data; num_elts > 0; p++, num_elts--) *p = init; + FILL_SCALAR_LOOP; break; } case CAML_BA_INT64: { int64_t init = Int64_val(vinit); int64_t * p; - for (p = b->data; num_elts > 0; p++, num_elts--) *p = init; + FILL_SCALAR_LOOP; break; } case CAML_BA_NATIVE_INT: { intnat init = Nativeint_val(vinit); intnat * p; - for (p = b->data; num_elts > 0; p++, num_elts--) *p = init; + FILL_SCALAR_LOOP; break; } case CAML_BA_CAML_INT: { intnat init = Long_val(vinit); intnat * p; - for (p = b->data; num_elts > 0; p++, num_elts--) *p = init; + FILL_SCALAR_LOOP; break; } case CAML_BA_COMPLEX32: { float init0 = Double_field(vinit, 0); float init1 = Double_field(vinit, 1); float * p; - for (p = b->data; num_elts > 0; num_elts--) { *p++ = init0; *p++ = init1; } + FILL_COMPLEX_LOOP; break; } case CAML_BA_COMPLEX64: { double init0 = Double_field(vinit, 0); double init1 = Double_field(vinit, 1); double * p; - for (p = b->data; num_elts > 0; num_elts--) { *p++ = init0; *p++ = init1; } + FILL_COMPLEX_LOOP; break; } } - return Val_unit; + CAMLreturn (Val_unit); } /* Reshape an array: change dimensions and number of dimensions, preserving diff --git a/otherlibs/bigarray/mmap_unix.c b/otherlibs/bigarray/mmap_unix.c index cdcfe3ce32..027b1e5cf5 100644 --- a/otherlibs/bigarray/mmap_unix.c +++ b/otherlibs/bigarray/mmap_unix.c @@ -18,12 +18,12 @@ #include <stddef.h> #include <string.h> #include "bigarray.h" -#include "custom.h" -#include "fail.h" -#include "io.h" -#include "mlvalues.h" -#include "sys.h" -#include "signals.h" +#include "caml/custom.h" +#include "caml/fail.h" +#include "caml/io.h" +#include "caml/mlvalues.h" +#include "caml/sys.h" +#include "caml/signals.h" extern int caml_ba_element_size[]; /* from bigarray_stubs.c */ diff --git a/otherlibs/bigarray/mmap_win32.c b/otherlibs/bigarray/mmap_win32.c index cd9da4af38..5d7ec6bb88 100644 --- a/otherlibs/bigarray/mmap_win32.c +++ b/otherlibs/bigarray/mmap_win32.c @@ -15,11 +15,11 @@ #include <stdio.h> #include <string.h> #include "bigarray.h" -#include "alloc.h" -#include "custom.h" -#include "fail.h" -#include "mlvalues.h" -#include "sys.h" +#include "caml/alloc.h" +#include "caml/custom.h" +#include "caml/fail.h" +#include "caml/mlvalues.h" +#include "caml/sys.h" #include "unixsupport.h" extern int caml_ba_element_size[]; /* from bigarray_stubs.c */ diff --git a/otherlibs/dynlink/Makefile b/otherlibs/dynlink/Makefile index 6284a5283e..acff7a7a68 100644 --- a/otherlibs/dynlink/Makefile +++ b/otherlibs/dynlink/Makefile @@ -13,15 +13,18 @@ # Makefile for the dynamic link library +# FIXME reduce redundancy by including ../Makefile + include ../../config/Makefile +CAMLRUN ?= ../../boot/ocamlrun +CAMLYACC ?= ../../boot/ocamlyacc ROOTDIR = ../.. -OCAMLRUN = $(ROOTDIR)/boot/ocamlrun -OCAMLC = $(OCAMLRUN) $(ROOTDIR)/ocamlc -nostdlib -I $(ROOTDIR)/stdlib -OCAMLOPT = $(OCAMLRUN) $(ROOTDIR)/ocamlopt -nostdlib -I $(ROOTDIR)/stdlib +OCAMLC = $(CAMLRUN) $(ROOTDIR)/ocamlc -nostdlib -I $(ROOTDIR)/stdlib +OCAMLOPT = $(CAMLRUN) $(ROOTDIR)/ocamlopt -nostdlib -I $(ROOTDIR)/stdlib INCLUDES=-I ../../utils -I ../../typing -I ../../bytecomp -I ../../asmcomp -COMPFLAGS=-w +33..39 -warn-error A -bin-annot -safe-string \ +COMPFLAGS=-w +33..39 -warn-error A -bin-annot -g -safe-string \ -I ../../stdlib $(INCLUDES) OBJS=dynlinkaux.cmo dynlink.cmo @@ -32,7 +35,7 @@ COMPILEROBJS=\ ../../utils/terminfo.cmo ../../utils/warnings.cmo \ ../../parsing/asttypes.cmi \ ../../parsing/location.cmo ../../parsing/longident.cmo \ - ../../parsing/ast_helper.cmo \ + ../../parsing/docstrings.cmo ../../parsing/ast_helper.cmo \ ../../parsing/ast_mapper.cmo \ ../../typing/ident.cmo ../../typing/path.cmo \ ../../typing/primitive.cmo ../../typing/types.cmo \ @@ -69,7 +72,7 @@ dynlink.cmx: dynlink.cmi natdynlink.ml rm -f dynlink.mlopt extract_crc: dynlink.cma extract_crc.cmo - $(OCAMLC) $(COMPFLAGS) -o extract_crc dynlink.cma extract_crc.cmo + $(OCAMLC) -o extract_crc dynlink.cma extract_crc.cmo INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR) diff --git a/otherlibs/dynlink/dynlink.ml b/otherlibs/dynlink/dynlink.ml index 47409ad361..a9ae6e74d1 100644 --- a/otherlibs/dynlink/dynlink.ml +++ b/otherlibs/dynlink/dynlink.ml @@ -237,6 +237,13 @@ let load_compunit ic file_name file_digest compunit = Unit name is needed for .cma files, which produce several code fragments.*) let digest = Digest.string (file_digest ^ compunit.cu_name) in register_code_fragment code code_size digest; + let events = + if compunit.cu_debug = 0 then [| |] + else begin + seek_in ic compunit.cu_debug; + [| input_value ic |] + end in + Meta.add_debug_info code code_size events; begin try ignore((Meta.reify_bytecode code code_size) ()) with exn -> diff --git a/otherlibs/dynlink/extract_crc.ml b/otherlibs/dynlink/extract_crc.ml index 4a6a310a95..d312aea711 100644 --- a/otherlibs/dynlink/extract_crc.ml +++ b/otherlibs/dynlink/extract_crc.ml @@ -20,7 +20,7 @@ let print_crc unit = try let crc = Dynlink.digest_interface unit (!load_path @ ["."]) in if !first then first := false else print_string ";\n"; - print_string " \""; print_string (String.capitalize unit); + print_string " \""; print_string (String.capitalize_ascii unit); print_string "\",\n \""; for i = 0 to String.length crc - 1 do Printf.printf "\\%03d" (Char.code crc.[i]) diff --git a/otherlibs/graph/.depend b/otherlibs/graph/.depend index ab9faa619a..7c37d0e1b5 100644 --- a/otherlibs/graph/.depend +++ b/otherlibs/graph/.depend @@ -2,102 +2,117 @@ 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 \ - + ../../byterun/caml/mlvalues.h ../../byterun/caml/compatibility.h \ + ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \ + ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \ + ../../byterun/caml/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 + ../../byterun/caml/mlvalues.h ../../byterun/caml/compatibility.h \ + ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \ + ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \ + ../../byterun/caml/misc.h ../../byterun/caml/alloc.h \ + ../../byterun/caml/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 + ../../byterun/caml/mlvalues.h ../../byterun/caml/compatibility.h \ + ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \ + ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \ + ../../byterun/caml/misc.h image.h ../../byterun/caml/alloc.h \ + ../../byterun/caml/mlvalues.h ../../byterun/caml/memory.h \ + ../../byterun/caml/gc.h ../../byterun/caml/major_gc.h \ + ../../byterun/caml/freelist.h ../../byterun/caml/minor_gc.h \ + ../../byterun/caml/address_class.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 + ../../byterun/caml/mlvalues.h ../../byterun/caml/compatibility.h \ + ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \ + ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \ + ../../byterun/caml/misc.h ../../byterun/caml/alloc.h \ + ../../byterun/caml/mlvalues.h ../../byterun/caml/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 + ../../byterun/caml/mlvalues.h ../../byterun/caml/compatibility.h \ + ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \ + ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \ + ../../byterun/caml/misc.h ../../byterun/caml/memory.h \ + ../../byterun/caml/gc.h ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \ + ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.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 + ../../byterun/caml/mlvalues.h ../../byterun/caml/compatibility.h \ + ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \ + ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \ + ../../byterun/caml/misc.h image.h ../../byterun/caml/alloc.h \ + ../../byterun/caml/mlvalues.h ../../byterun/caml/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 + ../../byterun/caml/mlvalues.h ../../byterun/caml/compatibility.h \ + ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \ + ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \ + ../../byterun/caml/misc.h image.h ../../byterun/caml/memory.h \ + ../../byterun/caml/gc.h ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \ + ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.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 + ../../byterun/caml/mlvalues.h ../../byterun/caml/compatibility.h \ + ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \ + ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \ + ../../byterun/caml/misc.h ../../byterun/caml/alloc.h \ + ../../byterun/caml/mlvalues.h ../../byterun/caml/callback.h \ + ../../byterun/caml/fail.h ../../byterun/caml/memory.h \ + ../../byterun/caml/gc.h ../../byterun/caml/major_gc.h \ + ../../byterun/caml/freelist.h ../../byterun/caml/minor_gc.h \ + ../../byterun/caml/address_class.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 + ../../byterun/caml/mlvalues.h ../../byterun/caml/compatibility.h \ + ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \ + ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \ + ../../byterun/caml/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 + ../../byterun/caml/mlvalues.h ../../byterun/caml/compatibility.h \ + ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \ + ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \ + ../../byterun/caml/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 + ../../byterun/caml/mlvalues.h ../../byterun/caml/compatibility.h \ + ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \ + ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \ + ../../byterun/caml/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 + ../../byterun/caml/mlvalues.h ../../byterun/caml/compatibility.h \ + ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \ + ../../byterun/caml/../../config/s.h ../../byterun/caml/misc.h \ + ../../byterun/caml/misc.h ../../byterun/caml/alloc.h \ + ../../byterun/caml/mlvalues.h graphics.cmi : graphicsX11.cmi : graphics.cmo : graphics.cmi diff --git a/otherlibs/graph/Makefile b/otherlibs/graph/Makefile index 9586f1c4bb..850e02513e 100644 --- a/otherlibs/graph/Makefile +++ b/otherlibs/graph/Makefile @@ -26,7 +26,7 @@ EXTRACFLAGS=$(X11_INCLUDES) include ../Makefile depend: - gcc -MM $(CFLAGS) *.c | sed -e 's, /[^ ]*\.h,,g' > .depend - ../../boot/ocamlrun ../../tools/ocamldep *.mli *.ml >> .depend + $(CC) -MM $(CFLAGS) *.c | sed -e 's, /[^ ]*\.h,,g' > .depend + $(CAMLRUN) ../../tools/ocamldep *.mli *.ml >> .depend include .depend diff --git a/otherlibs/graph/draw.c b/otherlibs/graph/draw.c index dc65787542..195860fa9f 100644 --- a/otherlibs/graph/draw.c +++ b/otherlibs/graph/draw.c @@ -12,7 +12,7 @@ /***********************************************************************/ #include "libgraph.h" -#include <alloc.h> +#include <caml/alloc.h> value caml_gr_plot(value vx, value vy) { diff --git a/otherlibs/graph/dump_img.c b/otherlibs/graph/dump_img.c index 4ba5c066ca..26f816076c 100644 --- a/otherlibs/graph/dump_img.c +++ b/otherlibs/graph/dump_img.c @@ -13,8 +13,8 @@ #include "libgraph.h" #include "image.h" -#include <alloc.h> -#include <memory.h> +#include <caml/alloc.h> +#include <caml/memory.h> value caml_gr_dump_image(value image) { diff --git a/otherlibs/graph/events.c b/otherlibs/graph/events.c index 94bd8bc478..a8fe119baa 100644 --- a/otherlibs/graph/events.c +++ b/otherlibs/graph/events.c @@ -13,8 +13,8 @@ #include <signal.h> #include "libgraph.h" -#include <alloc.h> -#include <signals.h> +#include <caml/alloc.h> +#include <caml/signals.h> #include <sys/types.h> #include <sys/time.h> #ifdef HAS_SYS_SELECT_H diff --git a/otherlibs/graph/fill.c b/otherlibs/graph/fill.c index 1e2965f179..8dc2f8777d 100644 --- a/otherlibs/graph/fill.c +++ b/otherlibs/graph/fill.c @@ -12,7 +12,7 @@ /***********************************************************************/ #include "libgraph.h" -#include <memory.h> +#include <caml/memory.h> value caml_gr_fill_rect(value vx, value vy, value vw, value vh) { diff --git a/otherlibs/graph/image.c b/otherlibs/graph/image.c index 31693bbd3e..12588bf71c 100644 --- a/otherlibs/graph/image.c +++ b/otherlibs/graph/image.c @@ -13,8 +13,8 @@ #include "libgraph.h" #include "image.h" -#include <alloc.h> -#include <custom.h> +#include <caml/alloc.h> +#include <caml/custom.h> static void caml_gr_free_image(value im) { diff --git a/otherlibs/graph/libgraph.h b/otherlibs/graph/libgraph.h index 71204e3133..178943da46 100644 --- a/otherlibs/graph/libgraph.h +++ b/otherlibs/graph/libgraph.h @@ -14,8 +14,8 @@ #include <stdio.h> #include <X11/Xlib.h> #include <X11/Xutil.h> -#include <mlvalues.h> -#include <misc.h> +#include <caml/mlvalues.h> +#include <caml/misc.h> struct canvas { int w, h; /* Dimensions of the drawable */ @@ -74,7 +74,7 @@ extern int caml_gr_bits_per_pixel; #endif #endif -extern void caml_gr_fail(char *fmt, char *arg) Noreturn; +Noreturn extern void caml_gr_fail(char *fmt, char *arg); 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/make_img.c b/otherlibs/graph/make_img.c index 932d4605d9..b9c4bfca22 100644 --- a/otherlibs/graph/make_img.c +++ b/otherlibs/graph/make_img.c @@ -13,7 +13,7 @@ #include "libgraph.h" #include "image.h" -#include <memory.h> +#include <caml/memory.h> value caml_gr_make_image(value m) { diff --git a/otherlibs/graph/open.c b/otherlibs/graph/open.c index 14a00eafd4..e8d26acfa9 100644 --- a/otherlibs/graph/open.c +++ b/otherlibs/graph/open.c @@ -15,10 +15,10 @@ #include <fcntl.h> #include <signal.h> #include "libgraph.h" -#include <alloc.h> -#include <callback.h> -#include <fail.h> -#include <memory.h> +#include <caml/alloc.h> +#include <caml/callback.h> +#include <caml/fail.h> +#include <caml/memory.h> #ifdef HAS_UNISTD #include <unistd.h> #endif diff --git a/otherlibs/graph/text.c b/otherlibs/graph/text.c index 8ac422d58d..7450df89d7 100644 --- a/otherlibs/graph/text.c +++ b/otherlibs/graph/text.c @@ -12,7 +12,7 @@ /***********************************************************************/ #include "libgraph.h" -#include <alloc.h> +#include <caml/alloc.h> XFontStruct * caml_gr_font = NULL; diff --git a/otherlibs/num/.depend b/otherlibs/num/.depend index 51b180f5d8..ce7cc9b8cf 100644 --- a/otherlibs/num/.depend +++ b/otherlibs/num/.depend @@ -1,21 +1,23 @@ -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 +bng.o: bng.c bng.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/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 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 +nat_stubs.o: nat_stubs.c ../../byterun/caml/alloc.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/misc.h \ + ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \ + ../../byterun/caml/../../config/s.h ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/config.h ../../byterun/caml/custom.h \ + ../../byterun/caml/intext.h ../../byterun/caml/io.h \ + ../../byterun/caml/fail.h ../../byterun/caml/hash.h \ + ../../byterun/caml/memory.h ../../byterun/caml/gc.h \ + ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \ + ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \ + ../../byterun/caml/mlvalues.h bng.h nat.h arith_flags.cmi : arith_status.cmi : big_int.cmi : nat.cmi diff --git a/otherlibs/num/Makefile b/otherlibs/num/Makefile index e5bcb97cad..e08e02943f 100644 --- a/otherlibs/num/Makefile +++ b/otherlibs/num/Makefile @@ -31,7 +31,7 @@ bng.$(O): bng.h bng_digit.c \ bng_amd64.c bng_ia32.c bng_ppc.c bng_sparc.c depend: - gcc -MM $(CFLAGS) *.c > .depend - ../../boot/ocamlrun ../../tools/ocamldep *.mli *.ml >> .depend + $(CC) -MM $(CFLAGS) *.c > .depend + $(CAMLRUN) ../../tools/ocamldep *.mli *.ml >> .depend include .depend diff --git a/otherlibs/num/big_int.ml b/otherlibs/num/big_int.ml index 847d158324..4811cbd8ee 100644 --- a/otherlibs/num/big_int.ml +++ b/otherlibs/num/big_int.ml @@ -41,6 +41,15 @@ let unit_big_int = let num_digits_big_int bi = num_digits_nat (bi.abs_value) 0 (length_nat bi.abs_value) +(* Number of bits in a big_int *) +let num_bits_big_int bi = + let nd = num_digits_nat (bi.abs_value) 0 (length_nat bi.abs_value) in + (* nd = 1 if bi = 0 *) + let lz = num_leading_zero_bits_in_digit bi.abs_value (nd - 1) in + (* lz = length_of_digit if bi = 0 *) + nd * length_of_digit - lz + (* = 0 if bi = 0 *) + (* Opposite of a big_int *) let minus_big_int bi = { sign = - bi.sign; @@ -593,13 +602,6 @@ let base_power_big_int base n bi = then zero_big_int else create_big_int (bi.sign) res -(* Coercion with float type *) - -let float_of_big_int bi = - float_of_string (string_of_big_int bi) - -(* XL: suppression de big_int_of_float et nat_of_float. *) - (* Other functions needed *) (* Integer part of the square root of a big_int *) @@ -836,3 +838,42 @@ let xor_big_int a b = then zero_big_int else { sign = 1; abs_value = res } end + +(* Coercion with float type *) + +(* Consider a real number [r] such that + - the integral part of [r] is the bigint [x] + - 2^54 <= |x| < 2^63 + - the fractional part of [r] is 0 if [exact = true], + nonzero if [exact = false]. + Then, the following function returns [r] correctly rounded to + the nearest double-precision floating-point number. + This is an instance of the "round to odd" technique formalized in + "When double rounding is odd" by S. Boldo and G. Melquiond. + The claim above is lemma Fappli_IEEE_extra.round_odd_fix + from the CompCert Coq development. *) + +let round_big_int_to_float x exact = + assert (let n = num_bits_big_int x in 55 <= n && n <= 63); + let m = int64_of_big_int x in + (* Unless the fractional part is exactly 0, round m to an odd integer *) + let m = if exact then m else Int64.logor m 1L in + (* Then convert m to float, with the normal rounding mode. *) + Int64.to_float m + +let float_of_big_int x = + let n = num_bits_big_int x in + if n <= 63 then + Int64.to_float (int64_of_big_int x) + else begin + let n = n - 55 in + (* Extract top 55 bits of x *) + let top = shift_right_towards_zero_big_int x n in + (* Check if the other bits are all zero *) + let exact = eq_big_int x (shift_left_big_int top n) in + (* Round to float and apply exponent *) + ldexp (round_big_int_to_float top exact) n + end + +(* XL: suppression de big_int_of_float et nat_of_float. *) + diff --git a/otherlibs/num/big_int.mli b/otherlibs/num/big_int.mli index 738730a79a..57fb07792e 100644 --- a/otherlibs/num/big_int.mli +++ b/otherlibs/num/big_int.mli @@ -99,6 +99,11 @@ val min_big_int : big_int -> big_int -> big_int val num_digits_big_int : big_int -> int (** Return the number of machine words used to store the given big integer. *) +val num_bits_big_int : big_int -> int + (** Return the number of significant bits in the absolute + value of the given big integer. [num_bits_big_int a] + returns 0 if [a] is 0; otherwise it returns a positive + integer [n] such that [2^(n-1) <= |a| < 2^n]. *) (** {6 Conversions to and from strings} *) @@ -189,3 +194,4 @@ 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 : bytes -> int -> int -> bool val approx_big_int: int -> big_int -> string +val round_big_int_to_float: big_int -> bool -> float diff --git a/otherlibs/num/bng.c b/otherlibs/num/bng.c index 0483ef51f5..585e434e2c 100644 --- a/otherlibs/num/bng.c +++ b/otherlibs/num/bng.c @@ -14,7 +14,7 @@ /* $Id$ */ #include "bng.h" -#include "config.h" +#include "caml/config.h" #if defined(__GNUC__) && BNG_ASM_LEVEL > 0 #if defined(BNG_ARCH_ia32) diff --git a/otherlibs/num/bng.h b/otherlibs/num/bng.h index 19f2e2b9cf..527bee6abe 100644 --- a/otherlibs/num/bng.h +++ b/otherlibs/num/bng.h @@ -14,7 +14,7 @@ /* $Id$ */ #include <string.h> -#include "config.h" +#include "caml/config.h" typedef uintnat bngdigit; typedef bngdigit * bng; diff --git a/otherlibs/num/nat.ml b/otherlibs/num/nat.ml index 90cb471c1b..5ea5fda751 100644 --- a/otherlibs/num/nat.ml +++ b/otherlibs/num/nat.ml @@ -318,6 +318,12 @@ let digits = "0123456789ABCDEF" A la fin de la boucle i-1 est la plus grande puissance de la base qui tient sur un seul digit et j est la plus grande puissance de la base qui tient sur un int. + + This function returns [(pmax, pint)] where: + [pmax] is the index of the digit of [power_base] that contains the + the maximum power of [base] that fits in a digit. This is also one + less than the exponent of that power. + [pint] is the exponent of the maximum power of [base] that fits in an [int]. *) let make_power_base base power_base = let i = ref 0 @@ -329,7 +335,7 @@ let make_power_base base power_base = power_base (pred !i) 1 power_base 0) done; - while !j <= !i && is_digit_int power_base !j do incr j done; + while !j < !i - 1 && is_digit_int power_base !j do incr j done; (!i - 2, !j) (* diff --git a/otherlibs/num/nat_stubs.c b/otherlibs/num/nat_stubs.c index d718a05383..22614e1317 100644 --- a/otherlibs/num/nat_stubs.c +++ b/otherlibs/num/nat_stubs.c @@ -13,14 +13,14 @@ /* $Id$ */ -#include "alloc.h" -#include "config.h" -#include "custom.h" -#include "intext.h" -#include "fail.h" -#include "hash.h" -#include "memory.h" -#include "mlvalues.h" +#include "caml/alloc.h" +#include "caml/config.h" +#include "caml/custom.h" +#include "caml/intext.h" +#include "caml/fail.h" +#include "caml/hash.h" +#include "caml/memory.h" +#include "caml/mlvalues.h" #include "bng.h" #include "nat.h" diff --git a/otherlibs/num/num.ml b/otherlibs/num/num.ml index 67499e2674..924e9eab6c 100644 --- a/otherlibs/num/num.ml +++ b/otherlibs/num/num.ml @@ -160,57 +160,71 @@ let floor_num = function | Big_int bi as n -> n | Ratio r -> num_of_big_int (floor_ratio r) -(* The function [quo_num] is equivalent to - - let quo_num x y = floor_num (div_num x y);; +(* Coercion with ratio type *) +let ratio_of_num = function + Int i -> ratio_of_int i +| Big_int bi -> ratio_of_big_int bi +| Ratio r -> r +;; - However, this definition is vastly inefficient (cf PR #3473): - we define here a better way of computing the same thing. - *) -let quo_num n1 n2 = - match n1 with - | Int i1 -> - begin match n2 with - | Int i2 -> Int (i1 / i2) - | Big_int bi2 -> num_of_big_int (div_big_int (big_int_of_int i1) bi2) - | Ratio r2 -> num_of_big_int (floor_ratio (div_int_ratio i1 r2)) end +(* Euclidean division and remainder. The specification is: - | Big_int bi1 -> - begin match n2 with - | Int i2 -> num_of_big_int (div_big_int bi1 (big_int_of_int i2)) - | Big_int bi2 -> num_of_big_int (div_big_int bi1 bi2) - | Ratio r2 -> num_of_big_int (floor_ratio (div_big_int_ratio bi1 r2)) end + a = b * quo_num a b + mod_num a b + quo_num a b is an integer (Z) + 0 <= mod_num a b < |b| - | Ratio r1 -> - begin match n2 with - | Int i2 -> num_of_big_int (floor_ratio (div_ratio_int r1 i2)) - | Big_int bi2 -> num_of_big_int (floor_ratio (div_ratio_big_int r1 bi2)) - | Ratio r2 -> num_of_big_int (floor_ratio (div_ratio r1 r2)) end -;; +A correct but slow implementation is: -(* The function [mod_num] is equivalent to: + quo_num a b = + if b >= 0 then floor_num (div_num a b) + else minus_num (floor_num (div_num a (minus_num b))) - let mod_num x y = sub_num x (mult_num y (quo_num x y));; + mod_num a b = + sub_num a (mult_num b (quo_num a b)) - However, as for [quo_num] above, this definition is inefficient: + However, this definition is vastly inefficient (cf PR #3473): we define here a better way of computing the same thing. - *) -let mod_num n1 n2 = - match n1 with - | Int i1 -> - begin match n2 with - | Int i2 -> Int (i1 mod i2) - | Big_int bi2 -> num_of_big_int (mod_big_int (big_int_of_int i1) bi2) - | Ratio _r2 -> sub_num n1 (mult_num n2 (quo_num n1 n2)) end - | Big_int bi1 -> - begin match n2 with - | Int i2 -> num_of_big_int (mod_big_int bi1 (big_int_of_int i2)) - | Big_int bi2 -> num_of_big_int (mod_big_int bi1 bi2) - | Ratio _r2 -> sub_num n1 (mult_num n2 (quo_num n1 n2)) end + PR#6753: the previous implementation was based on + quo_num a b = floor_num (div_num a b) + which is incorrect for negative b. +*) - | Ratio _r1 -> sub_num n1 (mult_num n2 (quo_num n1 n2)) -;; +let quo_num n1 n2 = + match n1, n2 with + | Int i1, Int i2 -> + let q = i1 / i2 and r = i1 mod i2 in + Int (if r >= 0 then q else if i2 > 0 then q - 1 else q + 1) + | Int i1, Big_int bi2 -> + num_of_big_int (div_big_int (big_int_of_int i1) bi2) + | Int i1, Ratio r2 -> + num_of_big_int (report_sign_ratio r2 + (floor_ratio (div_int_ratio i1 (abs_ratio r2)))) + | Big_int bi1, Int i2 -> + num_of_big_int (div_big_int bi1 (big_int_of_int i2)) + | Big_int bi1, Big_int bi2 -> + num_of_big_int (div_big_int bi1 bi2) + | Big_int bi1, Ratio r2 -> + num_of_big_int (report_sign_ratio r2 + (floor_ratio (div_big_int_ratio bi1 (abs_ratio r2)))) + | Ratio r1, _ -> + let r2 = ratio_of_num n2 in + num_of_big_int (report_sign_ratio r2 + (floor_ratio (div_ratio r1 (abs_ratio r2)))) + +let mod_num n1 n2 = + match n1, n2 with + | Int i1, Int i2 -> + let r = i1 mod i2 in + Int (if r >= 0 then r else if i2 > 0 then r + i2 else r - i2) + | Int i1, Big_int bi2 -> + num_of_big_int (mod_big_int (big_int_of_int i1) bi2) + | Big_int bi1, Int i2 -> + num_of_big_int (mod_big_int bi1 (big_int_of_int i2)) + | Big_int bi1, Big_int bi2 -> + num_of_big_int (mod_big_int bi1 bi2) + | _, _ -> + sub_num n1 (mult_num n2 (quo_num n1 n2)) let power_num_int a b = match (a,b) with ((Int i), n) -> @@ -368,13 +382,6 @@ let big_int_of_num = function | Big_int bi -> bi | Ratio r -> big_int_of_ratio r -(* Coercion with ratio type *) -let ratio_of_num = function - Int i -> ratio_of_int i -| Big_int bi -> ratio_of_big_int bi -| Ratio r -> r -;; - let string_of_big_int_for_num bi = if !approx_printing_flag then approx_big_int !floating_precision bi diff --git a/otherlibs/num/ratio.ml b/otherlibs/num/ratio.ml index 5bb04b6474..3dbbbc985d 100644 --- a/otherlibs/num/ratio.ml +++ b/otherlibs/num/ratio.ml @@ -561,7 +561,49 @@ let ratio_of_string s = (* Coercion with type float *) let float_of_ratio r = - float_of_string (float_of_rational_string r) + let p = r.numerator and q = r.denominator in + (* Special cases 0/0, 0/q and p/0 *) + if sign_big_int q = 0 then begin + match sign_big_int p with + | 0 -> nan + | 1 -> infinity + | -1 -> neg_infinity + | _ -> assert false + end + else if sign_big_int p = 0 then 0.0 + else begin + let np = num_bits_big_int p and nq = num_bits_big_int q in + if np <= 53 && nq <= 53 then + (* p and q convert to floats exactly; use FP division to get the + correctly-rounded result. *) + Int64.to_float (int64_of_big_int p) + /. Int64.to_float (int64_of_big_int q) + else begin + let ap = abs_big_int p in + (* |p| is in [2^(np-1), 2^np) + q is in [2^(nq-1), 2^nq) + hence |p|/q is in (2^(np-nq-1), 2^(np-nq+1)). + We define n such that |p|/q*2^n is in [2^54, 2^56). + >= 2^54 so that the round to odd technique applies. + < 2^56 so that the integral part is representable as an int64. *) + let n = 55 - (np - nq) in + (* Scaling |p|/q by 2^n *) + let (p', q') = + if n >= 0 + then (shift_left_big_int ap n, q) + else (ap, shift_left_big_int q (-n)) in + (* Euclidean division of p' by q' *) + let (quo, rem) = quomod_big_int p' q' in + (* quo is the integral part of |p|/q*2^n + rem/q' is the fractional part. *) + (* Round quo to float *) + let f = round_big_int_to_float quo (sign_big_int rem = 0) in + (* Apply exponent *) + let f = ldexp f (-n) in + (* Apply sign *) + if sign_big_int p < 0 then -. f else f + end + end (* XL: suppression de ratio_of_float *) diff --git a/otherlibs/str/.depend b/otherlibs/str/.depend index 5be8377c2d..148cb312b5 100644 --- a/otherlibs/str/.depend +++ b/otherlibs/str/.depend @@ -1,9 +1,11 @@ -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 +strstubs.o: strstubs.c ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/misc.h ../../byterun/caml/alloc.h \ + ../../byterun/caml/mlvalues.h ../../byterun/caml/memory.h \ + ../../byterun/caml/gc.h ../../byterun/caml/major_gc.h \ + ../../byterun/caml/freelist.h ../../byterun/caml/minor_gc.h \ + ../../byterun/caml/address_class.h ../../byterun/caml/fail.h str.cmi : str.cmo : str.cmi str.cmx : str.cmi diff --git a/otherlibs/str/Makefile b/otherlibs/str/Makefile index 509be62a5c..93b2bf9539 100644 --- a/otherlibs/str/Makefile +++ b/otherlibs/str/Makefile @@ -27,7 +27,7 @@ str.cmo: str.cmi str.cmx: str.cmi depend: - gcc -MM $(CFLAGS) *.c > .depend - ../../boot/ocamlrun ../../tools/ocamldep *.mli *.ml >> .depend + $(CC) -MM $(CFLAGS) *.c > .depend + $(CAMLRUN) ../../tools/ocamldep *.mli *.ml >> .depend include .depend diff --git a/otherlibs/str/str.ml b/otherlibs/str/str.ml index ffaea89ba4..1bf2440b26 100644 --- a/otherlibs/str/str.ml +++ b/otherlibs/str/str.ml @@ -11,6 +11,10 @@ (* *) (***********************************************************************) +(* In this module, [@ocaml.warnerror "-3"] is used in several places + that use deprecated functions to preserve legacy behavior. + It overrides -w @3 given on the command line. *) + (** String utilities *) let string_before s n = String.sub s 0 n @@ -88,9 +92,9 @@ module Charset = r let fold_case s = - let r = make_empty() in - iter (fun c -> add r (Char.lowercase c); add r (Char.uppercase c)) s; - r + (let r = make_empty() in + iter (fun c -> add r (Char.lowercase c); add r (Char.uppercase c)) s; + r)[@ocaml.warnerror "-3"] end @@ -211,9 +215,9 @@ let charclass_of_regexp fold_case re = (* The case fold table: maps characters to their lowercase equivalent *) let fold_case_table = - 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 + (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)[@ocaml.warnerror "-3"] module StringMap = Map.Make(struct type t = string let compare (x:t) y = compare x y end) @@ -269,7 +273,7 @@ let compile fold_case re = let rec emit_code = function Char c -> if fold_case then - emit_instr op_CHARNORM (Char.code (Char.lowercase c)) + emit_instr op_CHARNORM (Char.code (Char.lowercase c))[@ocaml.warnerror "-3"] else emit_instr op_CHAR (Char.code c) | String s -> @@ -277,7 +281,7 @@ let compile fold_case re = 0 -> () | 1 -> if fold_case then - emit_instr op_CHARNORM (Char.code (Char.lowercase s.[0])) + emit_instr op_CHARNORM (Char.code (Char.lowercase s.[0]))[@ocaml.warnerror "-3"] else emit_instr op_CHAR (Char.code s.[0]) | _ -> @@ -290,7 +294,7 @@ let compile fold_case re = emit_code (String (string_after s (i+1))) with Not_found -> if fold_case then - emit_instr op_STRINGNORM (cpool_index (String.lowercase s)) + emit_instr op_STRINGNORM (cpool_index (String.lowercase s))[@ocaml.warnerror "-3"] else emit_instr op_STRING (cpool_index s) end diff --git a/otherlibs/str/strstubs.c b/otherlibs/str/strstubs.c index 9de349a9db..6c928704b1 100644 --- a/otherlibs/str/strstubs.c +++ b/otherlibs/str/strstubs.c @@ -13,10 +13,10 @@ #include <string.h> #include <ctype.h> -#include <mlvalues.h> -#include <alloc.h> -#include <memory.h> -#include <fail.h> +#include <caml/mlvalues.h> +#include <caml/alloc.h> +#include <caml/memory.h> +#include <caml/fail.h> /* The backtracking NFA interpreter */ diff --git a/otherlibs/systhreads/.depend b/otherlibs/systhreads/.depend index 85add2e592..03da2d853d 100644 --- a/otherlibs/systhreads/.depend +++ b/otherlibs/systhreads/.depend @@ -1,14 +1,16 @@ -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 +st_stubs.o: st_stubs.c ../../byterun/caml/alloc.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/misc.h \ + ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \ + ../../byterun/caml/../../config/s.h ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/backtrace.h ../../byterun/caml/exec.h \ + ../../byterun/caml/callback.h ../../byterun/caml/custom.h \ + ../../byterun/caml/fail.h ../../byterun/caml/io.h \ + ../../byterun/caml/memory.h ../../byterun/caml/gc.h \ + ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \ + ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \ + ../../byterun/caml/printexc.h ../../byterun/caml/roots.h \ + ../../byterun/caml/signals.h ../../byterun/caml/stacks.h \ + ../../byterun/caml/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 f24af23b67..942a7b7869 100644 --- a/otherlibs/systhreads/Makefile +++ b/otherlibs/systhreads/Makefile @@ -12,13 +12,15 @@ ######################################################################### include ../../config/Makefile +CAMLRUN ?= ../../boot/ocamlrun +CAMLYACC ?= ../../boot/ocamlyacc ROOTDIR=../.. -CAMLC=$(ROOTDIR)/boot/ocamlrun $(ROOTDIR)/ocamlc -nostdlib \ +CAMLC=$(CAMLRUN) $(ROOTDIR)/ocamlc -nostdlib \ -I $(ROOTDIR)/stdlib -I $(ROOTDIR)/otherlibs/unix -CAMLOPT=$(ROOTDIR)/boot/ocamlrun $(ROOTDIR)/ocamlopt -nostdlib \ +CAMLOPT=$(CAMLRUN) $(ROOTDIR)/ocamlopt -nostdlib \ -I $(ROOTDIR)/stdlib -I $(ROOTDIR)/otherlibs/unix -MKLIB=../../boot/ocamlrun ../../tools/ocamlmklib +MKLIB=$(CAMLRUN) ../../tools/ocamlmklib COMPFLAGS=-w +33..39 -warn-error A -g -bin-annot -safe-string BYTECODE_C_OBJS=st_stubs_b.o @@ -34,7 +36,7 @@ libthreads.a: $(BYTECODE_C_OBJS) $(MKLIB) -o threads $(BYTECODE_C_OBJS) $(PTHREAD_LINK) st_stubs_b.o: st_stubs.c st_posix.h - $(BYTECC) -O -I../../byterun $(BYTECCCOMPOPTS) $(SHAREDCCCOMPOPTS) \ + $(BYTECC) -I../../byterun $(BYTECCCOMPOPTS) $(SHAREDCCCOMPOPTS) \ -c st_stubs.c mv st_stubs.o st_stubs_b.o @@ -44,7 +46,7 @@ libthreadsnat.a: $(NATIVECODE_C_OBJS) $(AR) rc libthreadsnat.a $(NATIVECODE_C_OBJS) st_stubs_n.o: st_stubs.c st_posix.h - $(NATIVECC) -O -I../../asmrun -I../../byterun $(NATIVECCCOMPOPTS) \ + $(NATIVECC) -I../../asmrun -I../../byterun $(NATIVECCCOMPOPTS) \ $(SHAREDCCCOMPOPTS) -DNATIVE_CODE -DTARGET_$(ARCH) \ -DSYS_$(SYSTEM) -c st_stubs.c mv st_stubs.o st_stubs_n.o @@ -106,7 +108,7 @@ installopt: $(CAMLOPT) -c $(COMPFLAGS) $< depend: $(GENFILES) - -gcc -MM -I../../byterun *.c > .depend - ../../boot/ocamlrun ../../tools/ocamldep *.mli *.ml >> .depend + -$(CC) -MM -I../../byterun *.c > .depend + $(CAMLRUN) ../../tools/ocamldep *.mli *.ml >> .depend include .depend diff --git a/otherlibs/systhreads/Makefile.nt b/otherlibs/systhreads/Makefile.nt index 341176146f..22fb1c7179 100644 --- a/otherlibs/systhreads/Makefile.nt +++ b/otherlibs/systhreads/Makefile.nt @@ -12,12 +12,14 @@ ######################################################################### include ../../config/Makefile +CAMLRUN ?= ../../boot/ocamlrun +CAMLYACC ?= ../../boot/ocamlyacc # Compilation options -CAMLC=../../boot/ocamlrun ../../ocamlc -I ../../stdlib -I ../win32unix -CAMLOPT=../../boot/ocamlrun ../../ocamlopt -I ../../stdlib -I ../win32unix +CAMLC=$(CAMLRUN) ../../ocamlc -I ../../stdlib -I ../win32unix +CAMLOPT=$(CAMLRUN) ../../ocamlopt -I ../../stdlib -I ../win32unix COMPFLAGS=-w +33 -warn-error A -g -MKLIB=../../boot/ocamlrun ../../tools/ocamlmklib +MKLIB=$(CAMLRUN) ../../tools/ocamlmklib CFLAGS=-I../../byterun $(EXTRACFLAGS) CAMLOBJS=thread.cmo mutex.cmo condition.cmo event.cmo threadUnix.cmo @@ -32,7 +34,7 @@ all: lib$(LIBNAME).$(A) $(LIBNAME).cma $(CMIFILES) allopt: lib$(LIBNAME).$(A) $(LIBNAME).cmxa $(LIBNAME).cmxs $(CMIFILES) $(LIBNAME).cma: $(CAMLOBJS) - $(MKLIB) -o $(LIBNAME) -ocamlc "../../boot/ocamlrun ../../ocamlc" \ + $(MKLIB) -o $(LIBNAME) -ocamlc "$(CAMLRUN) ../../ocamlc" \ -linkall $(CAMLOBJS) $(LINKOPTS) lib$(LIBNAME).$(A): $(COBJS) @@ -46,7 +48,7 @@ st_stubs_b.$(O): st_stubs.c st_win32.h $(LIBNAME).cmxa: $(CAMLOBJS:.cmo=.cmx) $(MKLIB) -o $(LIBNAME)nat \ - -ocamlopt "../../boot/ocamlrun ../../ocamlopt" -linkall \ + -ocamlopt "$(CAMLRUN) ../../ocamlopt" -linkall \ $(CAMLOBJS:.cmo=.cmx) $(LINKOPTS) mv $(LIBNAME)nat.cmxa $(LIBNAME).cmxa mv $(LIBNAME)nat.$(A) $(LIBNAME).$(A) diff --git a/otherlibs/systhreads/st_posix.h b/otherlibs/systhreads/st_posix.h index e0bc65e41d..6771948ac0 100644 --- a/otherlibs/systhreads/st_posix.h +++ b/otherlibs/systhreads/st_posix.h @@ -78,9 +78,10 @@ static void st_thread_exit(void) pthread_exit(NULL); } -static void st_thread_kill(st_thread_id thr) +static void st_thread_join(st_thread_id thr) { - pthread_cancel(thr); + pthread_join(thr, NULL); + /* best effort: ignore errors */ } /* Scheduling hints */ @@ -312,6 +313,9 @@ static void st_check_error(int retcode, char * msg) raise_sys_error(str); } +/* Variable used to stop the "tick" thread */ +static volatile int caml_tick_thread_stop = 0; + /* The tick thread: posts a SIGPREEMPTION signal periodically */ static void * caml_thread_tick(void * arg) @@ -322,9 +326,7 @@ static void * caml_thread_tick(void * arg) /* Block all signals so that we don't try to execute an OCaml signal handler*/ sigfillset(&mask); pthread_sigmask(SIG_BLOCK, &mask, NULL); - /* Allow async cancellation */ - pthread_setcanceltype(PTHREAD_CANCEL_ASYNCHRONOUS, NULL); - while(1) { + while(! caml_tick_thread_stop) { /* select() seems to be the most efficient way to suspend the thread for sub-second intervals */ timeout.tv_sec = 0; @@ -335,11 +337,20 @@ static void * caml_thread_tick(void * arg) caml_record_signal(). */ caml_record_signal(SIGPREEMPTION); } - return NULL; /* prevents compiler warning */ + return NULL; } /* "At fork" processing */ +#if defined(__ANDROID__) +/* Android's libc does not include declaration of pthread_atfork; + however, it implements it since API level 10 (Gingerbread). + The reason for the omission is that Android (GUI) applications + are not supposed to fork at all, however this workaround is still + included in case OCaml is used for an Android CLI utility. */ +int pthread_atfork(void (*prepare)(void), void (*parent)(void), void (*child)(void)); +#endif + static int st_atfork(void (*fn)(void)) { return pthread_atfork(NULL, NULL, fn); diff --git a/otherlibs/systhreads/st_stubs.c b/otherlibs/systhreads/st_stubs.c index dd99c7369a..02ff512c76 100644 --- a/otherlibs/systhreads/st_stubs.c +++ b/otherlibs/systhreads/st_stubs.c @@ -11,24 +11,24 @@ /* */ /***********************************************************************/ -#include "alloc.h" -#include "backtrace.h" -#include "callback.h" -#include "custom.h" -#include "fail.h" -#include "io.h" -#include "memory.h" -#include "misc.h" -#include "mlvalues.h" -#include "printexc.h" -#include "roots.h" -#include "signals.h" +#include "caml/alloc.h" +#include "caml/backtrace.h" +#include "caml/callback.h" +#include "caml/custom.h" +#include "caml/fail.h" +#include "caml/io.h" +#include "caml/memory.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" +#include "caml/printexc.h" +#include "caml/roots.h" +#include "caml/signals.h" #ifdef NATIVE_CODE #include "stack.h" #else -#include "stacks.h" +#include "caml/stacks.h" #endif -#include "sys.h" +#include "caml/sys.h" #include "threads.h" /* Initial size of bytecode stack when a thread is created (4 Ko) */ @@ -95,10 +95,10 @@ static caml_thread_t curr_thread = NULL; /* The master lock protecting the OCaml runtime system */ static st_masterlock caml_master_lock; -/* Whether the ``tick'' thread is already running */ +/* Whether the "tick" thread is already running */ static int caml_tick_thread_running = 0; -/* The thread identifier of the ``tick'' thread */ +/* The thread identifier of the "tick" thread */ static st_thread_id caml_tick_thread_id; /* The key used for storing the thread descriptor in the specific data @@ -444,7 +444,12 @@ CAMLprim value caml_thread_initialize(value unit) /* ML */ CAMLprim value caml_thread_cleanup(value unit) /* ML */ { - if (caml_tick_thread_running) st_thread_kill(caml_tick_thread_id); + if (caml_tick_thread_running){ + caml_tick_thread_stop = 1; + st_thread_join(caml_tick_thread_id); + caml_tick_thread_stop = 0; + caml_tick_thread_running = 0; + } return Val_unit; } diff --git a/otherlibs/systhreads/st_win32.h b/otherlibs/systhreads/st_win32.h index cd04b319ce..9cc7bb8886 100644 --- a/otherlibs/systhreads/st_win32.h +++ b/otherlibs/systhreads/st_win32.h @@ -84,11 +84,10 @@ static void st_thread_exit(void) ExitThread(0); } -static void st_thread_kill(st_thread_id thr) +static void st_thread_join(st_thread_id thr) { - TRACE1("st_thread_kill", thr); - TerminateThread(thr, 0); - CloseHandle(thr); + TRACE1("st_thread_join", h); + WaitForSingleObject(thr, INFINITE); } /* Scheduling hints */ @@ -383,18 +382,21 @@ static void st_check_error(DWORD retcode, char * msg) raise_sys_error(str); } +/* Variable used to stop the "tick" thread */ +static volatile int caml_tick_thread_stop = 0; + /* The tick thread: posts a SIGPREEMPTION signal periodically */ static DWORD WINAPI caml_thread_tick(void * arg) { - while(1) { + while(! caml_tick_thread_stop) { Sleep(Thread_timeout); /* The preemption signal should never cause a callback, so don't go through caml_handle_signal(), just record signal delivery via caml_record_signal(). */ caml_record_signal(SIGPREEMPTION); } - return 0; /* prevents compiler warning */ + return 0; } /* "At fork" processing -- none under Win32 */ diff --git a/otherlibs/systhreads/thread.ml b/otherlibs/systhreads/thread.ml index c7988b5641..359d271b87 100644 --- a/otherlibs/systhreads/thread.ml +++ b/otherlibs/systhreads/thread.ml @@ -22,8 +22,8 @@ external thread_uncaught_exception : exn -> unit = "caml_thread_uncaught_exception" external yield : unit -> unit = "caml_thread_yield" -external self : unit -> t = "caml_thread_self" -external id : t -> int = "caml_thread_id" +external self : unit -> t = "caml_thread_self" "noalloc" +external id : t -> int = "caml_thread_id" "noalloc" external join : t -> unit = "caml_thread_join" external exit : unit -> unit = "caml_thread_exit" diff --git a/otherlibs/systhreads/threads.h b/otherlibs/systhreads/threads.h index 6a97b25103..616138da60 100644 --- a/otherlibs/systhreads/threads.h +++ b/otherlibs/systhreads/threads.h @@ -14,6 +14,10 @@ #ifndef CAML_THREADS_H #define CAML_THREADS_H +#ifdef __cplusplus +extern "C" { +#endif + CAMLextern void caml_enter_blocking_section (void); CAMLextern void caml_leave_blocking_section (void); #define caml_acquire_runtime_system caml_leave_blocking_section @@ -55,4 +59,8 @@ CAMLextern int caml_c_thread_unregister(void); Both functions return 1 on success, 0 on error. */ +#ifdef __cplusplus +} +#endif + #endif /* CAML_THREADS_H */ diff --git a/otherlibs/threads/.depend b/otherlibs/threads/.depend index 3a6c7f02b6..d6bda8ae41 100644 --- a/otherlibs/threads/.depend +++ b/otherlibs/threads/.depend @@ -1,32 +1,38 @@ -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 +scheduler.o: scheduler.c ../../byterun/caml/alloc.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/misc.h \ + ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \ + ../../byterun/caml/../../config/s.h ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/backtrace.h ../../byterun/caml/exec.h \ + ../../byterun/caml/callback.h ../../byterun/caml/config.h \ + ../../byterun/caml/fail.h ../../byterun/caml/io.h \ + ../../byterun/caml/memory.h ../../byterun/caml/gc.h \ + ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \ + ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \ + ../../byterun/caml/misc.h ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/printexc.h ../../byterun/caml/roots.h \ + ../../byterun/caml/memory.h ../../byterun/caml/signals.h \ + ../../byterun/caml/stacks.h ../../byterun/caml/sys.h condition.cmi : mutex.cmi event.cmi : +marshal.cmi : mutex.cmi : -thread.cmi : unix.cmo -threadUnix.cmi : unix.cmo +pervasives.cmi : +thread.cmi : unix.cmi +threadUnix.cmi : unix.cmi +unix.cmi : 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 : -marshal.cmx : +marshal.cmo : marshal.cmi +marshal.cmx : marshal.cmi mutex.cmo : thread.cmi mutex.cmi mutex.cmx : thread.cmx mutex.cmi -pervasives.cmo : unix.cmo -pervasives.cmx : unix.cmx -thread.cmo : unix.cmo thread.cmi +pervasives.cmo : unix.cmi pervasives.cmi +pervasives.cmx : unix.cmx pervasives.cmi +thread.cmo : unix.cmi thread.cmi thread.cmx : unix.cmx thread.cmi -threadUnix.cmo : unix.cmo thread.cmi threadUnix.cmi +threadUnix.cmo : unix.cmi thread.cmi threadUnix.cmi threadUnix.cmx : unix.cmx thread.cmx threadUnix.cmi -unix.cmo : -unix.cmx : +unix.cmo : unix.cmi +unix.cmx : unix.cmi diff --git a/otherlibs/threads/Makefile b/otherlibs/threads/Makefile index 4b78333364..b7851d0b71 100644 --- a/otherlibs/threads/Makefile +++ b/otherlibs/threads/Makefile @@ -11,15 +11,19 @@ # # ######################################################################### +# FIXME reduce redundancy by including ../Makefile + include ../../config/Makefile +CAMLRUN ?= ../../boot/ocamlrun +CAMLYACC ?= ../../boot/ocamlyacc CC=$(BYTECC) -CFLAGS=-I../../byterun -O $(BYTECCCOMPOPTS) $(SHAREDCCCOMPOPTS) -g +CFLAGS=-I../../byterun $(BYTECCCOMPOPTS) $(SHAREDCCCOMPOPTS) -g ROOTDIR=../.. -CAMLC=$(ROOTDIR)/boot/ocamlrun $(ROOTDIR)/ocamlc -nostdlib \ +CAMLC=$(CAMLRUN) $(ROOTDIR)/ocamlc -nostdlib \ -I $(ROOTDIR)/stdlib -I $(ROOTDIR)/otherlibs/unix -MKLIB=../../boot/ocamlrun ../../tools/ocamlmklib -COMPFLAGS=-w +33..39 -warn-error A -bin-annot -safe-string +MKLIB=$(CAMLRUN) ../../tools/ocamlmklib +COMPFLAGS=-w +33..39 -warn-error A -bin-annot -g -safe-string C_OBJS=scheduler.o @@ -29,7 +33,7 @@ LIB=../../stdlib LIB_OBJS=$(LIB)/camlinternalFormatBasics.cmo pervasives.cmo \ $(LIB)/array.cmo $(LIB)/list.cmo $(LIB)/char.cmo $(LIB)/bytes.cmo \ - $(LIB)/string.cmo $(LIB)/sys.cmo $(LIB)/sort.cmo $(LIB)/marshal.cmo \ + $(LIB)/string.cmo $(LIB)/sys.cmo $(LIB)/sort.cmo marshal.cmo \ $(LIB)/obj.cmo $(LIB)/int32.cmo $(LIB)/int64.cmo \ $(LIB)/nativeint.cmo $(LIB)/lexing.cmo $(LIB)/parsing.cmo \ $(LIB)/set.cmo $(LIB)/map.cmo $(LIB)/stack.cmo $(LIB)/queue.cmo \ @@ -121,7 +125,7 @@ installopt: $(CAMLC) -c $(COMPFLAGS) $< depend: - gcc -MM $(CFLAGS) *.c > .depend - ../../boot/ocamlrun ../../tools/ocamldep *.mli *.ml >> .depend + $(CC) -MM $(CFLAGS) *.c > .depend + $(CAMLRUN) ../../tools/ocamldep *.mli *.ml >> .depend include .depend diff --git a/otherlibs/threads/pervasives.ml b/otherlibs/threads/pervasives.ml index e6f1cc16b9..19d03637b7 100644 --- a/otherlibs/threads/pervasives.ml +++ b/otherlibs/threads/pervasives.ml @@ -210,6 +210,10 @@ external ( := ) : 'a ref -> 'a -> unit = "%setfield0" external incr : int ref -> unit = "%incr" external decr : int ref -> unit = "%decr" +(* Result type *) + +type ('a,'b) result = Ok of 'a | Error of 'b + (* String conversion functions *) external format_int : string -> int -> string = "caml_format_int" @@ -250,6 +254,15 @@ let rec ( @ ) l1 l2 = [] -> l2 | hd :: tl -> hd :: (tl @ l2) + +(* Array index operators *) +external ( .() ) : 'a array -> int -> 'a = "%array_opt_get" +external ( .() <- ) : 'a array -> int -> 'a -> unit = "%array_opt_set" + +(* String index operators *) +external ( .[] ) : string -> int -> char = "%string_opt_get" +external ( .[] <- ) : bytes -> int -> char -> unit = "%string_opt_set" + (* I/O operations *) type in_channel @@ -289,8 +302,13 @@ type open_flag = external open_desc : string -> open_flag list -> int -> int = "caml_sys_open" +external set_out_channel_name: out_channel -> string -> unit = + "caml_ml_set_channel_name" + let open_out_gen mode perm name = - open_descriptor_out(open_desc name mode perm) + let c = open_descriptor_out(open_desc name mode perm) in + set_out_channel_name c name; + c let open_out name = open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_text] 0o666 name @@ -395,8 +413,13 @@ external set_binary_mode_out : out_channel -> bool -> unit (* General input functions *) +external set_in_channel_name: in_channel -> string -> unit = + "caml_ml_set_channel_name" + let open_in_gen mode perm name = - open_descriptor_in(open_desc name mode perm) + let c = open_descriptor_in(open_desc name mode perm) in + set_in_channel_name c name; + c let open_in name = open_in_gen [Open_rdonly; Open_text] 0 name diff --git a/otherlibs/threads/scheduler.c b/otherlibs/threads/scheduler.c index 45ef854db9..585a89030e 100644 --- a/otherlibs/threads/scheduler.c +++ b/otherlibs/threads/scheduler.c @@ -17,20 +17,20 @@ #include <stdlib.h> #include <stdio.h> -#include "alloc.h" -#include "backtrace.h" -#include "callback.h" -#include "config.h" -#include "fail.h" -#include "io.h" -#include "memory.h" -#include "misc.h" -#include "mlvalues.h" -#include "printexc.h" -#include "roots.h" -#include "signals.h" -#include "stacks.h" -#include "sys.h" +#include "caml/alloc.h" +#include "caml/backtrace.h" +#include "caml/callback.h" +#include "caml/config.h" +#include "caml/fail.h" +#include "caml/io.h" +#include "caml/memory.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" +#include "caml/printexc.h" +#include "caml/roots.h" +#include "caml/signals.h" +#include "caml/stacks.h" +#include "caml/sys.h" #if ! (defined(HAS_SELECT) && \ defined(HAS_SETITIMER) && \ diff --git a/otherlibs/threads/thread.ml b/otherlibs/threads/thread.ml index 6ef9997d8c..6ed0a4bdda 100644 --- a/otherlibs/threads/thread.ml +++ b/otherlibs/threads/thread.ml @@ -64,11 +64,10 @@ external thread_join : t -> unit = "thread_join" external thread_delay : float -> unit = "thread_delay" external thread_wait_pid : int -> resumption_status = "thread_wait_pid" external thread_wakeup : t -> unit = "thread_wakeup" -external thread_self : unit -> t = "thread_self" +external thread_self : unit -> t = "thread_self" "noalloc" external thread_kill : t -> unit = "thread_kill" external thread_uncaught_exception : exn -> unit = "thread_uncaught_exception" - -external id : t -> int = "thread_id" +external thread_id : t -> int = "thread_id" "noalloc" (* In sleep() below, we rely on the fact that signals are detected only at function applications and beginning of loops, @@ -82,6 +81,7 @@ let wakeup pid = thread_wakeup pid let self () = thread_self() let kill pid = thread_kill pid let exit () = thread_kill(thread_self()) +let id t = thread_id t let select_aux arg = thread_select arg diff --git a/otherlibs/threads/thread.mli b/otherlibs/threads/thread.mli index e026a21409..6055d62ab0 100644 --- a/otherlibs/threads/thread.mli +++ b/otherlibs/threads/thread.mli @@ -35,7 +35,7 @@ val create : ('a -> 'b) -> 'a -> t val self : unit -> t (** Return the thread currently executing. *) -external id : t -> int = "thread_id" +val id : t -> int (** Return the identifier of the given thread. A thread identifier is an integer that identifies uniquely the thread. It can be used to build data structures indexed by threads. *) diff --git a/otherlibs/unix/.depend b/otherlibs/unix/.depend index 85eee1b853..f03f792ae4 100644 --- a/otherlibs/unix/.depend +++ b/otherlibs/unix/.depend @@ -1,503 +1,645 @@ -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 \ +accept.o: accept.c ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/misc.h ../../byterun/caml/alloc.h \ + ../../byterun/caml/mlvalues.h ../../byterun/caml/fail.h \ + ../../byterun/caml/memory.h ../../byterun/caml/gc.h \ + ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \ + ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \ + ../../byterun/caml/signals.h unixsupport.h socketaddr.h \ + ../../byterun/caml/misc.h +access.o: access.c ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/misc.h ../../byterun/caml/alloc.h \ + ../../byterun/caml/mlvalues.h ../../byterun/caml/memory.h \ + ../../byterun/caml/gc.h ../../byterun/caml/major_gc.h \ + ../../byterun/caml/freelist.h ../../byterun/caml/minor_gc.h \ + ../../byterun/caml/address_class.h ../../byterun/caml/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/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 -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 -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 -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 -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 -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 -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 -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 -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 \ +addrofstr.o: addrofstr.c ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/misc.h ../../byterun/caml/memory.h \ + ../../byterun/caml/gc.h ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \ + ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \ + ../../byterun/caml/fail.h unixsupport.h socketaddr.h \ + ../../byterun/caml/misc.h +alarm.o: alarm.c ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/misc.h unixsupport.h +bind.o: bind.c ../../byterun/caml/fail.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/misc.h \ + ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \ + ../../byterun/caml/../../config/s.h ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/mlvalues.h unixsupport.h socketaddr.h \ + ../../byterun/caml/misc.h +chdir.o: chdir.c ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/misc.h ../../byterun/caml/memory.h \ + ../../byterun/caml/gc.h ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \ + ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \ + ../../byterun/caml/signals.h unixsupport.h +chmod.o: chmod.c ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/misc.h ../../byterun/caml/memory.h \ + ../../byterun/caml/gc.h ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \ + ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \ + ../../byterun/caml/signals.h unixsupport.h +chown.o: chown.c ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/misc.h ../../byterun/caml/memory.h \ + ../../byterun/caml/gc.h ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \ + ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \ + ../../byterun/caml/signals.h unixsupport.h +chroot.o: chroot.c ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/misc.h ../../byterun/caml/memory.h \ + ../../byterun/caml/gc.h ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \ + ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \ + ../../byterun/caml/signals.h unixsupport.h +close.o: close.c ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/misc.h ../../byterun/caml/signals.h \ + ../../byterun/caml/mlvalues.h unixsupport.h +closedir.o: closedir.c ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/misc.h ../../byterun/caml/memory.h \ + ../../byterun/caml/gc.h ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \ + ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \ + ../../byterun/caml/signals.h unixsupport.h +connect.o: connect.c ../../byterun/caml/fail.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/misc.h \ + ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \ + ../../byterun/caml/../../config/s.h ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/mlvalues.h ../../byterun/caml/signals.h \ + unixsupport.h socketaddr.h ../../byterun/caml/misc.h +cst2constr.o: cst2constr.c ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/misc.h ../../byterun/caml/fail.h \ + ../../byterun/caml/mlvalues.h cst2constr.h +cstringv.o: cstringv.c ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/misc.h ../../byterun/caml/memory.h \ + ../../byterun/caml/gc.h ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \ + ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 \ +dup.o: dup.c ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/misc.h unixsupport.h +dup2.o: dup2.c ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/misc.h unixsupport.h +envir.o: envir.c ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/misc.h ../../byterun/caml/alloc.h \ + ../../byterun/caml/mlvalues.h +errmsg.o: errmsg.c ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/misc.h ../../byterun/caml/alloc.h \ + ../../byterun/caml/mlvalues.h +execv.o: execv.c ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/misc.h ../../byterun/caml/memory.h \ + ../../byterun/caml/gc.h ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \ + ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.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 -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 -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 -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/misc.h ../../byterun/signals.h \ +execve.o: execve.c ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/misc.h ../../byterun/caml/memory.h \ + ../../byterun/caml/gc.h ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \ + ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 -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 +execvp.o: execvp.c ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/misc.h ../../byterun/caml/memory.h \ + ../../byterun/caml/gc.h ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \ + ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \ + unixsupport.h +exit.o: exit.c ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/misc.h unixsupport.h +fchmod.o: fchmod.c ../../byterun/caml/fail.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/misc.h \ + ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \ + ../../byterun/caml/../../config/s.h ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/mlvalues.h ../../byterun/caml/signals.h \ + unixsupport.h +fchown.o: fchown.c ../../byterun/caml/fail.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/misc.h \ + ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \ + ../../byterun/caml/../../config/s.h ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/mlvalues.h ../../byterun/caml/signals.h \ + unixsupport.h +fcntl.o: fcntl.c ../../byterun/caml/fail.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/misc.h \ + ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \ + ../../byterun/caml/../../config/s.h ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/mlvalues.h unixsupport.h +fork.o: fork.c ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/misc.h ../../byterun/caml/debugger.h \ + ../../byterun/caml/mlvalues.h unixsupport.h +ftruncate.o: ftruncate.c ../../byterun/caml/fail.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/misc.h \ + ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \ + ../../byterun/caml/../../config/s.h ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/mlvalues.h ../../byterun/caml/io.h \ + ../../byterun/caml/signals.h unixsupport.h +getaddrinfo.o: getaddrinfo.c ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/misc.h ../../byterun/caml/alloc.h \ + ../../byterun/caml/mlvalues.h ../../byterun/caml/fail.h \ + ../../byterun/caml/memory.h ../../byterun/caml/gc.h \ + ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \ + ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \ + ../../byterun/caml/misc.h ../../byterun/caml/signals.h unixsupport.h \ + cst2constr.h socketaddr.h +getcwd.o: getcwd.c ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/misc.h ../../byterun/caml/alloc.h \ + ../../byterun/caml/mlvalues.h ../../byterun/caml/fail.h unixsupport.h +getegid.o: getegid.c ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/misc.h unixsupport.h +geteuid.o: geteuid.c ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/misc.h unixsupport.h +getgid.o: getgid.c ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/misc.h unixsupport.h +getgr.o: getgr.c ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/misc.h ../../byterun/caml/fail.h \ + ../../byterun/caml/mlvalues.h ../../byterun/caml/alloc.h \ + ../../byterun/caml/memory.h ../../byterun/caml/gc.h \ + ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \ + ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \ + unixsupport.h +getgroups.o: getgroups.c ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/misc.h ../../byterun/caml/alloc.h \ + ../../byterun/caml/mlvalues.h ../../byterun/caml/fail.h unixsupport.h +gethost.o: gethost.c ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/misc.h ../../byterun/caml/alloc.h \ + ../../byterun/caml/mlvalues.h ../../byterun/caml/fail.h \ + ../../byterun/caml/memory.h ../../byterun/caml/gc.h \ + ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \ + ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \ + ../../byterun/caml/signals.h unixsupport.h socketaddr.h \ + ../../byterun/caml/misc.h +gethostname.o: gethostname.c ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/misc.h ../../byterun/caml/alloc.h \ + ../../byterun/caml/mlvalues.h ../../byterun/caml/fail.h unixsupport.h +getlogin.o: getlogin.c ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/misc.h ../../byterun/caml/alloc.h \ + ../../byterun/caml/mlvalues.h unixsupport.h +getnameinfo.o: getnameinfo.c ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/misc.h ../../byterun/caml/alloc.h \ + ../../byterun/caml/mlvalues.h ../../byterun/caml/fail.h \ + ../../byterun/caml/memory.h ../../byterun/caml/gc.h \ + ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \ + ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \ + ../../byterun/caml/signals.h unixsupport.h socketaddr.h \ + ../../byterun/caml/misc.h +getpeername.o: getpeername.c ../../byterun/caml/fail.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/misc.h \ + ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \ + ../../byterun/caml/../../config/s.h ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/mlvalues.h unixsupport.h socketaddr.h \ + ../../byterun/caml/misc.h +getpid.o: getpid.c ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/misc.h unixsupport.h +getppid.o: getppid.c ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/misc.h unixsupport.h +getproto.o: getproto.c ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/misc.h ../../byterun/caml/alloc.h \ + ../../byterun/caml/mlvalues.h ../../byterun/caml/fail.h \ + ../../byterun/caml/memory.h ../../byterun/caml/gc.h \ + ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \ + ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \ + unixsupport.h +getpw.o: getpw.c ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/misc.h ../../byterun/caml/alloc.h \ + ../../byterun/caml/mlvalues.h ../../byterun/caml/memory.h \ + ../../byterun/caml/gc.h ../../byterun/caml/major_gc.h \ + ../../byterun/caml/freelist.h ../../byterun/caml/minor_gc.h \ + ../../byterun/caml/address_class.h ../../byterun/caml/fail.h \ + unixsupport.h +getserv.o: getserv.c ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/misc.h ../../byterun/caml/alloc.h \ + ../../byterun/caml/mlvalues.h ../../byterun/caml/fail.h \ + ../../byterun/caml/memory.h ../../byterun/caml/gc.h \ + ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \ + ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \ + unixsupport.h +getsockname.o: getsockname.c ../../byterun/caml/fail.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/misc.h \ + ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \ + ../../byterun/caml/../../config/s.h ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/mlvalues.h unixsupport.h socketaddr.h \ + ../../byterun/caml/misc.h +gettimeofday.o: gettimeofday.c ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/misc.h ../../byterun/caml/alloc.h \ + ../../byterun/caml/mlvalues.h ../../byterun/caml/fail.h unixsupport.h +getuid.o: getuid.c ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/misc.h unixsupport.h +gmtime.o: gmtime.c ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/misc.h ../../byterun/caml/alloc.h \ + ../../byterun/caml/mlvalues.h ../../byterun/caml/fail.h \ + ../../byterun/caml/memory.h ../../byterun/caml/gc.h \ + ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \ + ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \ + unixsupport.h +initgroups.o: initgroups.c ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/misc.h ../../byterun/caml/alloc.h \ + ../../byterun/caml/mlvalues.h ../../byterun/caml/fail.h unixsupport.h +isatty.o: isatty.c ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/misc.h unixsupport.h +itimer.o: itimer.c ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/misc.h ../../byterun/caml/alloc.h \ + ../../byterun/caml/mlvalues.h ../../byterun/caml/fail.h \ + ../../byterun/caml/memory.h ../../byterun/caml/gc.h \ + ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \ + ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \ + unixsupport.h +kill.o: kill.c ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/misc.h ../../byterun/caml/fail.h \ + ../../byterun/caml/mlvalues.h unixsupport.h \ + ../../byterun/caml/signals.h +link.o: link.c ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/misc.h ../../byterun/caml/memory.h \ + ../../byterun/caml/gc.h ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \ + ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \ + ../../byterun/caml/signals.h unixsupport.h +listen.o: listen.c ../../byterun/caml/fail.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/misc.h \ + ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \ + ../../byterun/caml/../../config/s.h ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/mlvalues.h unixsupport.h +lockf.o: lockf.c ../../byterun/caml/fail.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/misc.h \ + ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \ + ../../byterun/caml/../../config/s.h ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/mlvalues.h ../../byterun/caml/signals.h \ + unixsupport.h +lseek.o: lseek.c ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/misc.h ../../byterun/caml/alloc.h \ + ../../byterun/caml/mlvalues.h ../../byterun/caml/io.h \ + ../../byterun/caml/signals.h unixsupport.h +mkdir.o: mkdir.c ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/misc.h ../../byterun/caml/memory.h \ + ../../byterun/caml/gc.h ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \ + ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \ + ../../byterun/caml/signals.h unixsupport.h +mkfifo.o: mkfifo.c ../../byterun/caml/fail.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/misc.h \ + ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \ + ../../byterun/caml/../../config/s.h ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/mlvalues.h ../../byterun/caml/memory.h \ + ../../byterun/caml/gc.h ../../byterun/caml/major_gc.h \ + ../../byterun/caml/freelist.h ../../byterun/caml/minor_gc.h \ + ../../byterun/caml/address_class.h ../../byterun/caml/signals.h \ + unixsupport.h +nice.o: nice.c ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/misc.h unixsupport.h +open.o: open.c ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/misc.h ../../byterun/caml/alloc.h \ + ../../byterun/caml/mlvalues.h ../../byterun/caml/memory.h \ + ../../byterun/caml/gc.h ../../byterun/caml/major_gc.h \ + ../../byterun/caml/freelist.h ../../byterun/caml/minor_gc.h \ + ../../byterun/caml/address_class.h ../../byterun/caml/misc.h \ + ../../byterun/caml/signals.h unixsupport.h +opendir.o: opendir.c ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/misc.h ../../byterun/caml/memory.h \ + ../../byterun/caml/gc.h ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \ + ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \ + ../../byterun/caml/alloc.h ../../byterun/caml/signals.h unixsupport.h +pipe.o: pipe.c ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/misc.h ../../byterun/caml/alloc.h \ + ../../byterun/caml/mlvalues.h unixsupport.h +putenv.o: putenv.c ../../byterun/caml/fail.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/misc.h \ + ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \ + ../../byterun/caml/../../config/s.h ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/memory.h ../../byterun/caml/gc.h \ + ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \ + ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \ + ../../byterun/caml/mlvalues.h unixsupport.h +read.o: read.c ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/misc.h ../../byterun/caml/memory.h \ + ../../byterun/caml/gc.h ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \ + ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \ + ../../byterun/caml/signals.h unixsupport.h +readdir.o: readdir.c ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/misc.h ../../byterun/caml/fail.h \ + ../../byterun/caml/mlvalues.h ../../byterun/caml/alloc.h \ + ../../byterun/caml/signals.h unixsupport.h +readlink.o: readlink.c ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/misc.h ../../byterun/caml/memory.h \ + ../../byterun/caml/gc.h ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \ + ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \ + ../../byterun/caml/alloc.h ../../byterun/caml/fail.h \ + ../../byterun/caml/signals.h unixsupport.h +rename.o: rename.c ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/misc.h ../../byterun/caml/memory.h \ + ../../byterun/caml/gc.h ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \ + ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \ + ../../byterun/caml/signals.h unixsupport.h +rewinddir.o: rewinddir.c ../../byterun/caml/fail.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/misc.h \ + ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \ + ../../byterun/caml/../../config/s.h ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/mlvalues.h unixsupport.h +rmdir.o: rmdir.c ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/misc.h ../../byterun/caml/memory.h \ + ../../byterun/caml/gc.h ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \ + ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \ + ../../byterun/caml/signals.h unixsupport.h +select.o: select.c ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/misc.h ../../byterun/caml/alloc.h \ + ../../byterun/caml/mlvalues.h ../../byterun/caml/fail.h \ + ../../byterun/caml/memory.h ../../byterun/caml/gc.h \ + ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \ + ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \ + ../../byterun/caml/signals.h unixsupport.h +sendrecv.o: sendrecv.c ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/misc.h ../../byterun/caml/alloc.h \ + ../../byterun/caml/mlvalues.h ../../byterun/caml/fail.h \ + ../../byterun/caml/memory.h ../../byterun/caml/gc.h \ + ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \ + ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \ + ../../byterun/caml/signals.h unixsupport.h socketaddr.h \ + ../../byterun/caml/misc.h +setgid.o: setgid.c ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/misc.h unixsupport.h +setgroups.o: setgroups.c ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/misc.h ../../byterun/caml/alloc.h \ + ../../byterun/caml/mlvalues.h ../../byterun/caml/fail.h \ + ../../byterun/caml/memory.h ../../byterun/caml/gc.h \ + ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \ + ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \ + unixsupport.h +setsid.o: setsid.c ../../byterun/caml/fail.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/misc.h \ + ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \ + ../../byterun/caml/../../config/s.h ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/mlvalues.h unixsupport.h +setuid.o: setuid.c ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/misc.h unixsupport.h +shutdown.o: shutdown.c ../../byterun/caml/fail.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/misc.h \ + ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \ + ../../byterun/caml/../../config/s.h ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/mlvalues.h unixsupport.h +signals.o: signals.c ../../byterun/caml/alloc.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/misc.h \ + ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \ + ../../byterun/caml/../../config/s.h ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/fail.h ../../byterun/caml/memory.h \ + ../../byterun/caml/gc.h ../../byterun/caml/major_gc.h \ + ../../byterun/caml/freelist.h ../../byterun/caml/minor_gc.h \ + ../../byterun/caml/address_class.h ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/signals.h unixsupport.h +sleep.o: sleep.c ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/misc.h ../../byterun/caml/signals.h \ + ../../byterun/caml/mlvalues.h unixsupport.h +socket.o: socket.c ../../byterun/caml/fail.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/misc.h \ + ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \ + ../../byterun/caml/../../config/s.h ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/mlvalues.h unixsupport.h +socketaddr.o: socketaddr.c ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/misc.h ../../byterun/caml/alloc.h \ + ../../byterun/caml/mlvalues.h ../../byterun/caml/memory.h \ + ../../byterun/caml/gc.h ../../byterun/caml/major_gc.h \ + ../../byterun/caml/freelist.h ../../byterun/caml/minor_gc.h \ + ../../byterun/caml/address_class.h unixsupport.h socketaddr.h \ + ../../byterun/caml/misc.h +socketpair.o: socketpair.c ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/misc.h ../../byterun/caml/alloc.h \ + ../../byterun/caml/mlvalues.h ../../byterun/caml/fail.h unixsupport.h +sockopt.o: sockopt.c ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/misc.h ../../byterun/caml/memory.h \ + ../../byterun/caml/gc.h ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \ + ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \ + ../../byterun/caml/alloc.h ../../byterun/caml/fail.h unixsupport.h \ + socketaddr.h ../../byterun/caml/misc.h +stat.o: stat.c ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/misc.h ../../byterun/caml/memory.h \ + ../../byterun/caml/gc.h ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \ + ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \ + ../../byterun/caml/alloc.h ../../byterun/caml/signals.h \ + ../../byterun/caml/io.h unixsupport.h cst2constr.h nanosecond_stat.h +strofaddr.o: strofaddr.c ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/misc.h ../../byterun/caml/alloc.h \ + ../../byterun/caml/mlvalues.h ../../byterun/caml/fail.h unixsupport.h \ + socketaddr.h ../../byterun/caml/misc.h +symlink.o: symlink.c ../../byterun/caml/fail.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/misc.h \ + ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \ + ../../byterun/caml/../../config/s.h ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/mlvalues.h ../../byterun/caml/memory.h \ + ../../byterun/caml/gc.h ../../byterun/caml/major_gc.h \ + ../../byterun/caml/freelist.h ../../byterun/caml/minor_gc.h \ + ../../byterun/caml/address_class.h ../../byterun/caml/signals.h \ + unixsupport.h +termios.o: termios.c ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/misc.h ../../byterun/caml/alloc.h \ + ../../byterun/caml/mlvalues.h ../../byterun/caml/fail.h unixsupport.h +time.o: time.c ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/misc.h ../../byterun/caml/alloc.h \ + ../../byterun/caml/mlvalues.h unixsupport.h +times.o: times.c ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/misc.h ../../byterun/caml/alloc.h \ + ../../byterun/caml/mlvalues.h ../../byterun/caml/memory.h \ + ../../byterun/caml/gc.h ../../byterun/caml/major_gc.h \ + ../../byterun/caml/freelist.h ../../byterun/caml/minor_gc.h \ + ../../byterun/caml/address_class.h unixsupport.h +truncate.o: truncate.c ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/misc.h ../../byterun/caml/memory.h \ + ../../byterun/caml/gc.h ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \ + ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \ + ../../byterun/caml/fail.h ../../byterun/caml/signals.h \ + ../../byterun/caml/io.h unixsupport.h +umask.o: umask.c ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/misc.h unixsupport.h +unixsupport.o: unixsupport.c ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/misc.h ../../byterun/caml/alloc.h \ + ../../byterun/caml/mlvalues.h ../../byterun/caml/callback.h \ + ../../byterun/caml/memory.h ../../byterun/caml/gc.h \ + ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \ + ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \ + ../../byterun/caml/fail.h unixsupport.h cst2constr.h +unlink.o: unlink.c ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/misc.h ../../byterun/caml/memory.h \ + ../../byterun/caml/gc.h ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \ + ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \ + ../../byterun/caml/signals.h unixsupport.h +utimes.o: utimes.c ../../byterun/caml/fail.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/misc.h \ + ../../byterun/caml/config.h ../../byterun/caml/../../config/m.h \ + ../../byterun/caml/../../config/s.h ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/mlvalues.h ../../byterun/caml/memory.h \ + ../../byterun/caml/gc.h ../../byterun/caml/major_gc.h \ + ../../byterun/caml/freelist.h ../../byterun/caml/minor_gc.h \ + ../../byterun/caml/address_class.h ../../byterun/caml/signals.h \ + unixsupport.h +wait.o: wait.c ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/misc.h ../../byterun/caml/alloc.h \ + ../../byterun/caml/mlvalues.h ../../byterun/caml/fail.h \ + ../../byterun/caml/memory.h ../../byterun/caml/gc.h \ + ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \ + ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \ + ../../byterun/caml/signals.h unixsupport.h +write.o: write.c ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/compatibility.h ../../byterun/caml/config.h \ + ../../byterun/caml/../../config/m.h ../../byterun/caml/../../config/s.h \ + ../../byterun/caml/misc.h ../../byterun/caml/memory.h \ + ../../byterun/caml/gc.h ../../byterun/caml/mlvalues.h \ + ../../byterun/caml/major_gc.h ../../byterun/caml/freelist.h \ + ../../byterun/caml/minor_gc.h ../../byterun/caml/address_class.h \ + ../../byterun/caml/signals.h unixsupport.h unix.cmi : unixLabels.cmi : unix.cmi unix.cmo : unix.cmi diff --git a/otherlibs/unix/Makefile b/otherlibs/unix/Makefile index 5f4d72b835..faebd3f5c8 100644 --- a/otherlibs/unix/Makefile +++ b/otherlibs/unix/Makefile @@ -41,7 +41,7 @@ HEADERS=unixsupport.h socketaddr.h include ../Makefile depend: - gcc -MM $(CFLAGS) *.c > .depend - ../../boot/ocamlrun ../../tools/ocamldep *.mli *.ml >> .depend + $(CC) -MM $(CFLAGS) *.c > .depend + $(CAMLRUN) ../../tools/ocamldep *.mli *.ml >> .depend include .depend diff --git a/otherlibs/unix/accept.c b/otherlibs/unix/accept.c index 183b8e869e..3fd019188f 100644 --- a/otherlibs/unix/accept.c +++ b/otherlibs/unix/accept.c @@ -11,11 +11,11 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> -#include <alloc.h> -#include <fail.h> -#include <memory.h> -#include <signals.h> +#include <caml/mlvalues.h> +#include <caml/alloc.h> +#include <caml/fail.h> +#include <caml/memory.h> +#include <caml/signals.h> #include "unixsupport.h" #ifdef HAS_SOCKETS diff --git a/otherlibs/unix/access.c b/otherlibs/unix/access.c index 7df4f9c5f5..28c26b820d 100644 --- a/otherlibs/unix/access.c +++ b/otherlibs/unix/access.c @@ -11,10 +11,10 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> -#include <alloc.h> -#include <memory.h> -#include <signals.h> +#include <caml/mlvalues.h> +#include <caml/alloc.h> +#include <caml/memory.h> +#include <caml/signals.h> #include "unixsupport.h" #ifdef HAS_UNISTD diff --git a/otherlibs/unix/addrofstr.c b/otherlibs/unix/addrofstr.c index a2830ba593..207e1cd990 100644 --- a/otherlibs/unix/addrofstr.c +++ b/otherlibs/unix/addrofstr.c @@ -11,9 +11,9 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> -#include <memory.h> -#include <fail.h> +#include <caml/mlvalues.h> +#include <caml/memory.h> +#include <caml/fail.h> #include "unixsupport.h" #ifdef HAS_SOCKETS diff --git a/otherlibs/unix/alarm.c b/otherlibs/unix/alarm.c index 30472765ff..eb92a68293 100644 --- a/otherlibs/unix/alarm.c +++ b/otherlibs/unix/alarm.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> +#include <caml/mlvalues.h> #include "unixsupport.h" CAMLprim value unix_alarm(value t) diff --git a/otherlibs/unix/bind.c b/otherlibs/unix/bind.c index e3d0046c14..4ea75c21f9 100644 --- a/otherlibs/unix/bind.c +++ b/otherlibs/unix/bind.c @@ -11,8 +11,8 @@ /* */ /***********************************************************************/ -#include <fail.h> -#include <mlvalues.h> +#include <caml/fail.h> +#include <caml/mlvalues.h> #include "unixsupport.h" #ifdef HAS_SOCKETS diff --git a/otherlibs/unix/chdir.c b/otherlibs/unix/chdir.c index 0d5326a0dc..247321119f 100644 --- a/otherlibs/unix/chdir.c +++ b/otherlibs/unix/chdir.c @@ -11,9 +11,9 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> -#include <memory.h> -#include <signals.h> +#include <caml/mlvalues.h> +#include <caml/memory.h> +#include <caml/signals.h> #include "unixsupport.h" CAMLprim value unix_chdir(value path) diff --git a/otherlibs/unix/chmod.c b/otherlibs/unix/chmod.c index 90dd6024f4..2d3f30fe60 100644 --- a/otherlibs/unix/chmod.c +++ b/otherlibs/unix/chmod.c @@ -13,9 +13,9 @@ #include <sys/types.h> #include <sys/stat.h> -#include <mlvalues.h> -#include <memory.h> -#include <signals.h> +#include <caml/mlvalues.h> +#include <caml/memory.h> +#include <caml/signals.h> #include "unixsupport.h" CAMLprim value unix_chmod(value path, value perm) diff --git a/otherlibs/unix/chown.c b/otherlibs/unix/chown.c index 697f447714..6c9e896a4e 100644 --- a/otherlibs/unix/chown.c +++ b/otherlibs/unix/chown.c @@ -11,9 +11,9 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> -#include <memory.h> -#include <signals.h> +#include <caml/mlvalues.h> +#include <caml/memory.h> +#include <caml/signals.h> #include "unixsupport.h" CAMLprim value unix_chown(value path, value uid, value gid) diff --git a/otherlibs/unix/chroot.c b/otherlibs/unix/chroot.c index b41c09ff00..c30a0da9cd 100644 --- a/otherlibs/unix/chroot.c +++ b/otherlibs/unix/chroot.c @@ -11,9 +11,9 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> -#include <memory.h> -#include <signals.h> +#include <caml/mlvalues.h> +#include <caml/memory.h> +#include <caml/signals.h> #include "unixsupport.h" CAMLprim value unix_chroot(value path) diff --git a/otherlibs/unix/close.c b/otherlibs/unix/close.c index 8a56c413b9..aff8911f79 100644 --- a/otherlibs/unix/close.c +++ b/otherlibs/unix/close.c @@ -11,8 +11,8 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> -#include <signals.h> +#include <caml/mlvalues.h> +#include <caml/signals.h> #include "unixsupport.h" CAMLprim value unix_close(value fd) diff --git a/otherlibs/unix/closedir.c b/otherlibs/unix/closedir.c index 4196acd4e1..5e8008d5dc 100644 --- a/otherlibs/unix/closedir.c +++ b/otherlibs/unix/closedir.c @@ -11,9 +11,9 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> -#include <memory.h> -#include <signals.h> +#include <caml/mlvalues.h> +#include <caml/memory.h> +#include <caml/signals.h> #include "unixsupport.h" #include <errno.h> #include <sys/types.h> diff --git a/otherlibs/unix/connect.c b/otherlibs/unix/connect.c index ed8b12c3f2..b4b3e19c33 100644 --- a/otherlibs/unix/connect.c +++ b/otherlibs/unix/connect.c @@ -11,9 +11,9 @@ /* */ /***********************************************************************/ -#include <fail.h> -#include <mlvalues.h> -#include <signals.h> +#include <caml/fail.h> +#include <caml/mlvalues.h> +#include <caml/signals.h> #include "unixsupport.h" #ifdef HAS_SOCKETS diff --git a/otherlibs/unix/cst2constr.c b/otherlibs/unix/cst2constr.c index f27cace7b5..87721ce36f 100644 --- a/otherlibs/unix/cst2constr.c +++ b/otherlibs/unix/cst2constr.c @@ -11,8 +11,8 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> -#include <fail.h> +#include <caml/mlvalues.h> +#include <caml/fail.h> #include "cst2constr.h" value cst_to_constr(int n, int *tbl, int size, int deflt) diff --git a/otherlibs/unix/cstringv.c b/otherlibs/unix/cstringv.c index d85411007a..0e61491853 100644 --- a/otherlibs/unix/cstringv.c +++ b/otherlibs/unix/cstringv.c @@ -11,8 +11,8 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> -#include <memory.h> +#include <caml/mlvalues.h> +#include <caml/memory.h> #include "unixsupport.h" char ** cstringvect(value arg) diff --git a/otherlibs/unix/dup.c b/otherlibs/unix/dup.c index 36e3efac59..c6e9dcf2d0 100644 --- a/otherlibs/unix/dup.c +++ b/otherlibs/unix/dup.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> +#include <caml/mlvalues.h> #include "unixsupport.h" CAMLprim value unix_dup(value fd) diff --git a/otherlibs/unix/dup2.c b/otherlibs/unix/dup2.c index c501802234..fd9ea3d257 100644 --- a/otherlibs/unix/dup2.c +++ b/otherlibs/unix/dup2.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> +#include <caml/mlvalues.h> #include "unixsupport.h" #ifdef HAS_DUP2 diff --git a/otherlibs/unix/envir.c b/otherlibs/unix/envir.c index 4b1893342d..366608b634 100644 --- a/otherlibs/unix/envir.c +++ b/otherlibs/unix/envir.c @@ -11,8 +11,8 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> -#include <alloc.h> +#include <caml/mlvalues.h> +#include <caml/alloc.h> #ifndef _WIN32 extern char ** environ; diff --git a/otherlibs/unix/errmsg.c b/otherlibs/unix/errmsg.c index 5df3e1e736..0f610e9d81 100644 --- a/otherlibs/unix/errmsg.c +++ b/otherlibs/unix/errmsg.c @@ -13,8 +13,8 @@ #include <errno.h> #include <string.h> -#include <mlvalues.h> -#include <alloc.h> +#include <caml/mlvalues.h> +#include <caml/alloc.h> extern int error_table[]; diff --git a/otherlibs/unix/execv.c b/otherlibs/unix/execv.c index ee59fa48ec..9a77548917 100644 --- a/otherlibs/unix/execv.c +++ b/otherlibs/unix/execv.c @@ -11,8 +11,8 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> -#include <memory.h> +#include <caml/mlvalues.h> +#include <caml/memory.h> #include "unixsupport.h" extern char ** cstringvect(); diff --git a/otherlibs/unix/execve.c b/otherlibs/unix/execve.c index 62b2d2c9a2..92171c2d37 100644 --- a/otherlibs/unix/execve.c +++ b/otherlibs/unix/execve.c @@ -11,8 +11,8 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> -#include <memory.h> +#include <caml/mlvalues.h> +#include <caml/memory.h> #include "unixsupport.h" extern char ** cstringvect(); diff --git a/otherlibs/unix/execvp.c b/otherlibs/unix/execvp.c index 8e28fa067d..ce6900abf1 100644 --- a/otherlibs/unix/execvp.c +++ b/otherlibs/unix/execvp.c @@ -11,8 +11,8 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> -#include <memory.h> +#include <caml/mlvalues.h> +#include <caml/memory.h> #include "unixsupport.h" extern char ** cstringvect(); diff --git a/otherlibs/unix/exit.c b/otherlibs/unix/exit.c index 94f5fb5e98..cfc4e16c6a 100644 --- a/otherlibs/unix/exit.c +++ b/otherlibs/unix/exit.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> +#include <caml/mlvalues.h> #include "unixsupport.h" CAMLprim value unix_exit(value n) diff --git a/otherlibs/unix/fchmod.c b/otherlibs/unix/fchmod.c index 711097eb47..11578ff261 100644 --- a/otherlibs/unix/fchmod.c +++ b/otherlibs/unix/fchmod.c @@ -13,9 +13,9 @@ #include <sys/types.h> #include <sys/stat.h> -#include <fail.h> -#include <mlvalues.h> -#include <signals.h> +#include <caml/fail.h> +#include <caml/mlvalues.h> +#include <caml/signals.h> #include "unixsupport.h" #ifdef HAS_FCHMOD diff --git a/otherlibs/unix/fchown.c b/otherlibs/unix/fchown.c index 2a6746ca64..24872ec8ee 100644 --- a/otherlibs/unix/fchown.c +++ b/otherlibs/unix/fchown.c @@ -11,9 +11,9 @@ /* */ /***********************************************************************/ -#include <fail.h> -#include <mlvalues.h> -#include <signals.h> +#include <caml/fail.h> +#include <caml/mlvalues.h> +#include <caml/signals.h> #include "unixsupport.h" #ifdef HAS_FCHMOD diff --git a/otherlibs/unix/fcntl.c b/otherlibs/unix/fcntl.c index 886c12de9f..c89e9a6f16 100644 --- a/otherlibs/unix/fcntl.c +++ b/otherlibs/unix/fcntl.c @@ -11,8 +11,8 @@ /* */ /***********************************************************************/ -#include <fail.h> -#include <mlvalues.h> +#include <caml/fail.h> +#include <caml/mlvalues.h> #include "unixsupport.h" #ifdef HAS_UNISTD #include <unistd.h> diff --git a/otherlibs/unix/fork.c b/otherlibs/unix/fork.c index b21d80c60e..ac0d6772cc 100644 --- a/otherlibs/unix/fork.c +++ b/otherlibs/unix/fork.c @@ -11,8 +11,8 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> -#include <debugger.h> +#include <caml/mlvalues.h> +#include <caml/debugger.h> #include "unixsupport.h" CAMLprim value unix_fork(value unit) diff --git a/otherlibs/unix/ftruncate.c b/otherlibs/unix/ftruncate.c index ec494ba525..08a4a775ed 100644 --- a/otherlibs/unix/ftruncate.c +++ b/otherlibs/unix/ftruncate.c @@ -12,10 +12,10 @@ /***********************************************************************/ #include <sys/types.h> -#include <fail.h> -#include <mlvalues.h> -#include <io.h> -#include <signals.h> +#include <caml/fail.h> +#include <caml/mlvalues.h> +#include <caml/io.h> +#include <caml/signals.h> #include "unixsupport.h" #ifdef HAS_UNISTD #include <unistd.h> diff --git a/otherlibs/unix/getaddrinfo.c b/otherlibs/unix/getaddrinfo.c index 28d8903a3c..2817934331 100644 --- a/otherlibs/unix/getaddrinfo.c +++ b/otherlibs/unix/getaddrinfo.c @@ -12,12 +12,12 @@ /***********************************************************************/ #include <string.h> -#include <mlvalues.h> -#include <alloc.h> -#include <fail.h> -#include <memory.h> -#include <misc.h> -#include <signals.h> +#include <caml/mlvalues.h> +#include <caml/alloc.h> +#include <caml/fail.h> +#include <caml/memory.h> +#include <caml/misc.h> +#include <caml/signals.h> #include "unixsupport.h" #include "cst2constr.h" diff --git a/otherlibs/unix/getcwd.c b/otherlibs/unix/getcwd.c index 8d1b8e50a3..043c96b6f6 100644 --- a/otherlibs/unix/getcwd.c +++ b/otherlibs/unix/getcwd.c @@ -11,9 +11,9 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> -#include <alloc.h> -#include <fail.h> +#include <caml/mlvalues.h> +#include <caml/alloc.h> +#include <caml/fail.h> #include "unixsupport.h" #if !defined (_WIN32) && !macintosh diff --git a/otherlibs/unix/getegid.c b/otherlibs/unix/getegid.c index b1977ec910..c0ab2b398a 100644 --- a/otherlibs/unix/getegid.c +++ b/otherlibs/unix/getegid.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> +#include <caml/mlvalues.h> #include "unixsupport.h" CAMLprim value unix_getegid(value unit) diff --git a/otherlibs/unix/geteuid.c b/otherlibs/unix/geteuid.c index 9bf8971462..095d3fe16c 100644 --- a/otherlibs/unix/geteuid.c +++ b/otherlibs/unix/geteuid.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> +#include <caml/mlvalues.h> #include "unixsupport.h" CAMLprim value unix_geteuid(value unit) diff --git a/otherlibs/unix/getgid.c b/otherlibs/unix/getgid.c index 8cfe3ddba6..8a4991a532 100644 --- a/otherlibs/unix/getgid.c +++ b/otherlibs/unix/getgid.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> +#include <caml/mlvalues.h> #include "unixsupport.h" CAMLprim value unix_getgid(value unit) diff --git a/otherlibs/unix/getgr.c b/otherlibs/unix/getgr.c index d1e610d858..14338ccffc 100644 --- a/otherlibs/unix/getgr.c +++ b/otherlibs/unix/getgr.c @@ -11,10 +11,10 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> -#include <fail.h> -#include <alloc.h> -#include <memory.h> +#include <caml/mlvalues.h> +#include <caml/fail.h> +#include <caml/alloc.h> +#include <caml/memory.h> #include "unixsupport.h" #include <stdio.h> #include <grp.h> diff --git a/otherlibs/unix/getgroups.c b/otherlibs/unix/getgroups.c index 6d420b5e07..84cd45406a 100644 --- a/otherlibs/unix/getgroups.c +++ b/otherlibs/unix/getgroups.c @@ -11,9 +11,9 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> -#include <alloc.h> -#include <fail.h> +#include <caml/mlvalues.h> +#include <caml/alloc.h> +#include <caml/fail.h> #ifdef HAS_GETGROUPS diff --git a/otherlibs/unix/gethost.c b/otherlibs/unix/gethost.c index 8d5bb03f5b..d5220415cc 100644 --- a/otherlibs/unix/gethost.c +++ b/otherlibs/unix/gethost.c @@ -12,11 +12,11 @@ /***********************************************************************/ #include <string.h> -#include <mlvalues.h> -#include <alloc.h> -#include <fail.h> -#include <memory.h> -#include <signals.h> +#include <caml/mlvalues.h> +#include <caml/alloc.h> +#include <caml/fail.h> +#include <caml/memory.h> +#include <caml/signals.h> #include "unixsupport.h" #ifdef HAS_SOCKETS diff --git a/otherlibs/unix/gethostname.c b/otherlibs/unix/gethostname.c index 77b183cb33..a3aba5748b 100644 --- a/otherlibs/unix/gethostname.c +++ b/otherlibs/unix/gethostname.c @@ -11,9 +11,9 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> -#include <alloc.h> -#include <fail.h> +#include <caml/mlvalues.h> +#include <caml/alloc.h> +#include <caml/fail.h> #ifndef _WIN32 #include <sys/param.h> #endif diff --git a/otherlibs/unix/getlogin.c b/otherlibs/unix/getlogin.c index 27a508e02d..7f40e442f0 100644 --- a/otherlibs/unix/getlogin.c +++ b/otherlibs/unix/getlogin.c @@ -11,8 +11,8 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> -#include <alloc.h> +#include <caml/mlvalues.h> +#include <caml/alloc.h> #include "unixsupport.h" #include <errno.h> diff --git a/otherlibs/unix/getnameinfo.c b/otherlibs/unix/getnameinfo.c index d7dddb3fe4..d4663957ba 100644 --- a/otherlibs/unix/getnameinfo.c +++ b/otherlibs/unix/getnameinfo.c @@ -12,11 +12,11 @@ /***********************************************************************/ #include <string.h> -#include <mlvalues.h> -#include <alloc.h> -#include <fail.h> -#include <memory.h> -#include <signals.h> +#include <caml/mlvalues.h> +#include <caml/alloc.h> +#include <caml/fail.h> +#include <caml/memory.h> +#include <caml/signals.h> #include "unixsupport.h" #if defined(HAS_SOCKETS) && defined(HAS_IPV6) diff --git a/otherlibs/unix/getpeername.c b/otherlibs/unix/getpeername.c index 9692202c5a..183b210d3a 100644 --- a/otherlibs/unix/getpeername.c +++ b/otherlibs/unix/getpeername.c @@ -11,8 +11,8 @@ /* */ /***********************************************************************/ -#include <fail.h> -#include <mlvalues.h> +#include <caml/fail.h> +#include <caml/mlvalues.h> #include "unixsupport.h" #ifdef HAS_SOCKETS diff --git a/otherlibs/unix/getpid.c b/otherlibs/unix/getpid.c index cf4c3f90c7..4cf46e4c07 100644 --- a/otherlibs/unix/getpid.c +++ b/otherlibs/unix/getpid.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> +#include <caml/mlvalues.h> #include "unixsupport.h" CAMLprim value unix_getpid(value unit) diff --git a/otherlibs/unix/getppid.c b/otherlibs/unix/getppid.c index 616393b4a9..8c30a77a1b 100644 --- a/otherlibs/unix/getppid.c +++ b/otherlibs/unix/getppid.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> +#include <caml/mlvalues.h> #include "unixsupport.h" CAMLprim value unix_getppid(value unit) diff --git a/otherlibs/unix/getproto.c b/otherlibs/unix/getproto.c index 291a71da5c..b89cbba411 100644 --- a/otherlibs/unix/getproto.c +++ b/otherlibs/unix/getproto.c @@ -11,10 +11,10 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> -#include <alloc.h> -#include <fail.h> -#include <memory.h> +#include <caml/mlvalues.h> +#include <caml/alloc.h> +#include <caml/fail.h> +#include <caml/memory.h> #include "unixsupport.h" #ifdef HAS_SOCKETS diff --git a/otherlibs/unix/getpw.c b/otherlibs/unix/getpw.c index 0061ca8032..82fb4d8fdf 100644 --- a/otherlibs/unix/getpw.c +++ b/otherlibs/unix/getpw.c @@ -11,10 +11,10 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> -#include <alloc.h> -#include <memory.h> -#include <fail.h> +#include <caml/mlvalues.h> +#include <caml/alloc.h> +#include <caml/memory.h> +#include <caml/fail.h> #include "unixsupport.h" #include <pwd.h> diff --git a/otherlibs/unix/getserv.c b/otherlibs/unix/getserv.c index de91cbe05f..deb5f14729 100644 --- a/otherlibs/unix/getserv.c +++ b/otherlibs/unix/getserv.c @@ -11,10 +11,10 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> -#include <alloc.h> -#include <fail.h> -#include <memory.h> +#include <caml/mlvalues.h> +#include <caml/alloc.h> +#include <caml/fail.h> +#include <caml/memory.h> #include "unixsupport.h" #ifdef HAS_SOCKETS diff --git a/otherlibs/unix/getsockname.c b/otherlibs/unix/getsockname.c index 69e20cccc9..b28cfd1454 100644 --- a/otherlibs/unix/getsockname.c +++ b/otherlibs/unix/getsockname.c @@ -11,8 +11,8 @@ /* */ /***********************************************************************/ -#include <fail.h> -#include <mlvalues.h> +#include <caml/fail.h> +#include <caml/mlvalues.h> #include "unixsupport.h" #ifdef HAS_SOCKETS diff --git a/otherlibs/unix/gettimeofday.c b/otherlibs/unix/gettimeofday.c index f6a8615ed5..9cbfbeaa07 100644 --- a/otherlibs/unix/gettimeofday.c +++ b/otherlibs/unix/gettimeofday.c @@ -11,9 +11,9 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> -#include <alloc.h> -#include <fail.h> +#include <caml/mlvalues.h> +#include <caml/alloc.h> +#include <caml/fail.h> #include "unixsupport.h" #ifdef HAS_GETTIMEOFDAY diff --git a/otherlibs/unix/getuid.c b/otherlibs/unix/getuid.c index f51722a57d..7d0ce399b9 100644 --- a/otherlibs/unix/getuid.c +++ b/otherlibs/unix/getuid.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> +#include <caml/mlvalues.h> #include "unixsupport.h" CAMLprim value unix_getuid(value unit) diff --git a/otherlibs/unix/gmtime.c b/otherlibs/unix/gmtime.c index c8f6ac11e2..566f174f85 100644 --- a/otherlibs/unix/gmtime.c +++ b/otherlibs/unix/gmtime.c @@ -11,10 +11,10 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> -#include <alloc.h> -#include <fail.h> -#include <memory.h> +#include <caml/mlvalues.h> +#include <caml/alloc.h> +#include <caml/fail.h> +#include <caml/memory.h> #include "unixsupport.h" #include <time.h> #include <errno.h> diff --git a/otherlibs/unix/initgroups.c b/otherlibs/unix/initgroups.c index e9541e5a48..ca3ed4c99e 100644 --- a/otherlibs/unix/initgroups.c +++ b/otherlibs/unix/initgroups.c @@ -11,9 +11,9 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> -#include <alloc.h> -#include <fail.h> +#include <caml/mlvalues.h> +#include <caml/alloc.h> +#include <caml/fail.h> #ifdef HAS_INITGROUPS diff --git a/otherlibs/unix/isatty.c b/otherlibs/unix/isatty.c index 800afc4629..935c39d45e 100644 --- a/otherlibs/unix/isatty.c +++ b/otherlibs/unix/isatty.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> +#include <caml/mlvalues.h> #include "unixsupport.h" CAMLprim value unix_isatty(value fd) diff --git a/otherlibs/unix/itimer.c b/otherlibs/unix/itimer.c index 537c2d9ed8..f1950264c3 100644 --- a/otherlibs/unix/itimer.c +++ b/otherlibs/unix/itimer.c @@ -11,10 +11,10 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> -#include <alloc.h> -#include <fail.h> -#include <memory.h> +#include <caml/mlvalues.h> +#include <caml/alloc.h> +#include <caml/fail.h> +#include <caml/memory.h> #include "unixsupport.h" #ifdef HAS_SETITIMER diff --git a/otherlibs/unix/kill.c b/otherlibs/unix/kill.c index b3f7d88789..c0f74d48d4 100644 --- a/otherlibs/unix/kill.c +++ b/otherlibs/unix/kill.c @@ -11,11 +11,11 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> -#include <fail.h> +#include <caml/mlvalues.h> +#include <caml/fail.h> #include "unixsupport.h" #include <signal.h> -#include <signals.h> +#include <caml/signals.h> CAMLprim value unix_kill(value pid, value signal) { diff --git a/otherlibs/unix/link.c b/otherlibs/unix/link.c index c71118a596..0ec42f5fe9 100644 --- a/otherlibs/unix/link.c +++ b/otherlibs/unix/link.c @@ -11,9 +11,9 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> -#include <memory.h> -#include <signals.h> +#include <caml/mlvalues.h> +#include <caml/memory.h> +#include <caml/signals.h> #include "unixsupport.h" CAMLprim value unix_link(value path1, value path2) diff --git a/otherlibs/unix/listen.c b/otherlibs/unix/listen.c index 26b0185bdf..38efc9fde5 100644 --- a/otherlibs/unix/listen.c +++ b/otherlibs/unix/listen.c @@ -11,8 +11,8 @@ /* */ /***********************************************************************/ -#include <fail.h> -#include <mlvalues.h> +#include <caml/fail.h> +#include <caml/mlvalues.h> #include "unixsupport.h" #ifdef HAS_SOCKETS diff --git a/otherlibs/unix/lockf.c b/otherlibs/unix/lockf.c index 813a4f7f60..aeaf451313 100644 --- a/otherlibs/unix/lockf.c +++ b/otherlibs/unix/lockf.c @@ -13,9 +13,9 @@ #include <errno.h> #include <fcntl.h> -#include <fail.h> -#include <mlvalues.h> -#include <signals.h> +#include <caml/fail.h> +#include <caml/mlvalues.h> +#include <caml/signals.h> #include "unixsupport.h" #if defined(F_GETLK) && defined(F_SETLK) && defined(F_SETLKW) diff --git a/otherlibs/unix/lseek.c b/otherlibs/unix/lseek.c index 826d84f21c..5a7b7770af 100644 --- a/otherlibs/unix/lseek.c +++ b/otherlibs/unix/lseek.c @@ -13,10 +13,10 @@ #include <errno.h> #include <sys/types.h> -#include <mlvalues.h> -#include <alloc.h> -#include <io.h> -#include <signals.h> +#include <caml/mlvalues.h> +#include <caml/alloc.h> +#include <caml/io.h> +#include <caml/signals.h> #include "unixsupport.h" #ifdef HAS_UNISTD diff --git a/otherlibs/unix/mkdir.c b/otherlibs/unix/mkdir.c index d72a066c51..6b9c76e6f0 100644 --- a/otherlibs/unix/mkdir.c +++ b/otherlibs/unix/mkdir.c @@ -13,9 +13,9 @@ #include <sys/types.h> #include <sys/stat.h> -#include <mlvalues.h> -#include <memory.h> -#include <signals.h> +#include <caml/mlvalues.h> +#include <caml/memory.h> +#include <caml/signals.h> #include "unixsupport.h" CAMLprim value unix_mkdir(value path, value perm) diff --git a/otherlibs/unix/mkfifo.c b/otherlibs/unix/mkfifo.c index a00bcf2d04..074813856d 100644 --- a/otherlibs/unix/mkfifo.c +++ b/otherlibs/unix/mkfifo.c @@ -13,10 +13,10 @@ #include <sys/types.h> #include <sys/stat.h> -#include <fail.h> -#include <mlvalues.h> -#include <memory.h> -#include <signals.h> +#include <caml/fail.h> +#include <caml/mlvalues.h> +#include <caml/memory.h> +#include <caml/signals.h> #include "unixsupport.h" #ifdef HAS_MKFIFO diff --git a/otherlibs/unix/nanosecond_stat.h b/otherlibs/unix/nanosecond_stat.h new file mode 100644 index 0000000000..c1a648ef12 --- /dev/null +++ b/otherlibs/unix/nanosecond_stat.h @@ -0,0 +1,25 @@ +/***********************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Jeremie Dimino, Jane Street Group, LLC */ +/* */ +/* Copyright 2015 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. */ +/* */ +/***********************************************************************/ + +/* This file is used by the configure test program nanosecond_stat.c + and stat.c in this directory */ + +#if HAS_NANOSECOND_STAT == 1 +# define NSEC(buf, field) buf->st_##field##tim.tv_nsec +#elif HAS_NANOSECOND_STAT == 2 +# define NSEC(buf, field) buf->st_##field##timespec.tv_nsec +#elif HAS_NANOSECOND_STAT == 3 +# define NSEC(buf, field) buf->st_##field##timensec +#else +# define NSEC(buf, field) 0 +#endif diff --git a/otherlibs/unix/nice.c b/otherlibs/unix/nice.c index d0956a1685..e8f4f2b0a7 100644 --- a/otherlibs/unix/nice.c +++ b/otherlibs/unix/nice.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> +#include <caml/mlvalues.h> #include "unixsupport.h" #include <errno.h> #ifdef HAS_UNISTD diff --git a/otherlibs/unix/open.c b/otherlibs/unix/open.c index 32c332f232..1bad2c5b91 100644 --- a/otherlibs/unix/open.c +++ b/otherlibs/unix/open.c @@ -11,11 +11,11 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> -#include <alloc.h> -#include <memory.h> -#include <misc.h> -#include <signals.h> +#include <caml/mlvalues.h> +#include <caml/alloc.h> +#include <caml/memory.h> +#include <caml/misc.h> +#include <caml/signals.h> #include "unixsupport.h" #include <string.h> #ifdef HAS_UNISTD diff --git a/otherlibs/unix/opendir.c b/otherlibs/unix/opendir.c index 9cb6829cd1..bdf031b35f 100644 --- a/otherlibs/unix/opendir.c +++ b/otherlibs/unix/opendir.c @@ -11,10 +11,10 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> -#include <memory.h> -#include <alloc.h> -#include <signals.h> +#include <caml/mlvalues.h> +#include <caml/memory.h> +#include <caml/alloc.h> +#include <caml/signals.h> #include "unixsupport.h" #include <sys/types.h> #ifdef HAS_DIRENT diff --git a/otherlibs/unix/pipe.c b/otherlibs/unix/pipe.c index 7c6b1438a8..5f8f23dadf 100644 --- a/otherlibs/unix/pipe.c +++ b/otherlibs/unix/pipe.c @@ -11,8 +11,8 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> -#include <alloc.h> +#include <caml/mlvalues.h> +#include <caml/alloc.h> #include "unixsupport.h" CAMLprim value unix_pipe(value unit) diff --git a/otherlibs/unix/putenv.c b/otherlibs/unix/putenv.c index 28ad962f8d..ccb8f1abef 100644 --- a/otherlibs/unix/putenv.c +++ b/otherlibs/unix/putenv.c @@ -14,9 +14,9 @@ #include <stdlib.h> #include <string.h> -#include <fail.h> -#include <memory.h> -#include <mlvalues.h> +#include <caml/fail.h> +#include <caml/memory.h> +#include <caml/mlvalues.h> #include "unixsupport.h" diff --git a/otherlibs/unix/read.c b/otherlibs/unix/read.c index 3bbd0b47fd..14305d37cf 100644 --- a/otherlibs/unix/read.c +++ b/otherlibs/unix/read.c @@ -12,9 +12,9 @@ /***********************************************************************/ #include <string.h> -#include <mlvalues.h> -#include <memory.h> -#include <signals.h> +#include <caml/mlvalues.h> +#include <caml/memory.h> +#include <caml/signals.h> #include "unixsupport.h" CAMLprim value unix_read(value fd, value buf, value ofs, value len) diff --git a/otherlibs/unix/readdir.c b/otherlibs/unix/readdir.c index e6daf5f61c..4c309268ac 100644 --- a/otherlibs/unix/readdir.c +++ b/otherlibs/unix/readdir.c @@ -11,10 +11,10 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> -#include <fail.h> -#include <alloc.h> -#include <signals.h> +#include <caml/mlvalues.h> +#include <caml/fail.h> +#include <caml/alloc.h> +#include <caml/signals.h> #include "unixsupport.h" #include <errno.h> #include <sys/types.h> diff --git a/otherlibs/unix/readlink.c b/otherlibs/unix/readlink.c index 5706ba0350..836718d1dc 100644 --- a/otherlibs/unix/readlink.c +++ b/otherlibs/unix/readlink.c @@ -11,11 +11,11 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> -#include <memory.h> -#include <alloc.h> -#include <fail.h> -#include <signals.h> +#include <caml/mlvalues.h> +#include <caml/memory.h> +#include <caml/alloc.h> +#include <caml/fail.h> +#include <caml/signals.h> #ifdef HAS_SYMLINK diff --git a/otherlibs/unix/rename.c b/otherlibs/unix/rename.c index 78da709485..78e0846cd2 100644 --- a/otherlibs/unix/rename.c +++ b/otherlibs/unix/rename.c @@ -12,9 +12,9 @@ /***********************************************************************/ #include <stdio.h> -#include <mlvalues.h> -#include <memory.h> -#include <signals.h> +#include <caml/mlvalues.h> +#include <caml/memory.h> +#include <caml/signals.h> #include "unixsupport.h" CAMLprim value unix_rename(value path1, value path2) diff --git a/otherlibs/unix/rewinddir.c b/otherlibs/unix/rewinddir.c index 17cc639f6f..c37713231e 100644 --- a/otherlibs/unix/rewinddir.c +++ b/otherlibs/unix/rewinddir.c @@ -11,8 +11,8 @@ /* */ /***********************************************************************/ -#include <fail.h> -#include <mlvalues.h> +#include <caml/fail.h> +#include <caml/mlvalues.h> #include "unixsupport.h" #include <errno.h> #include <sys/types.h> diff --git a/otherlibs/unix/rmdir.c b/otherlibs/unix/rmdir.c index 12d521a72c..20359ce6cb 100644 --- a/otherlibs/unix/rmdir.c +++ b/otherlibs/unix/rmdir.c @@ -11,9 +11,9 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> -#include <memory.h> -#include <signals.h> +#include <caml/mlvalues.h> +#include <caml/memory.h> +#include <caml/signals.h> #include "unixsupport.h" CAMLprim value unix_rmdir(value path) diff --git a/otherlibs/unix/select.c b/otherlibs/unix/select.c index 12d8cc55a0..23c480249d 100644 --- a/otherlibs/unix/select.c +++ b/otherlibs/unix/select.c @@ -11,11 +11,11 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> -#include <alloc.h> -#include <fail.h> -#include <memory.h> -#include <signals.h> +#include <caml/mlvalues.h> +#include <caml/alloc.h> +#include <caml/fail.h> +#include <caml/memory.h> +#include <caml/signals.h> #include "unixsupport.h" #ifdef HAS_SELECT diff --git a/otherlibs/unix/sendrecv.c b/otherlibs/unix/sendrecv.c index 679dde3c7c..7d251a4375 100644 --- a/otherlibs/unix/sendrecv.c +++ b/otherlibs/unix/sendrecv.c @@ -12,11 +12,11 @@ /***********************************************************************/ #include <string.h> -#include <mlvalues.h> -#include <alloc.h> -#include <fail.h> -#include <memory.h> -#include <signals.h> +#include <caml/mlvalues.h> +#include <caml/alloc.h> +#include <caml/fail.h> +#include <caml/memory.h> +#include <caml/signals.h> #include "unixsupport.h" #ifdef HAS_SOCKETS diff --git a/otherlibs/unix/setgid.c b/otherlibs/unix/setgid.c index 8e635aa481..b7204745b7 100644 --- a/otherlibs/unix/setgid.c +++ b/otherlibs/unix/setgid.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> +#include <caml/mlvalues.h> #include "unixsupport.h" CAMLprim value unix_setgid(value gid) diff --git a/otherlibs/unix/setgroups.c b/otherlibs/unix/setgroups.c index 2279a6b368..7284b735cb 100644 --- a/otherlibs/unix/setgroups.c +++ b/otherlibs/unix/setgroups.c @@ -11,10 +11,10 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> -#include <alloc.h> -#include <fail.h> -#include <memory.h> +#include <caml/mlvalues.h> +#include <caml/alloc.h> +#include <caml/fail.h> +#include <caml/memory.h> #ifdef HAS_SETGROUPS diff --git a/otherlibs/unix/setsid.c b/otherlibs/unix/setsid.c index 252b85c4bb..92814eba59 100644 --- a/otherlibs/unix/setsid.c +++ b/otherlibs/unix/setsid.c @@ -11,8 +11,8 @@ /* */ /***********************************************************************/ -#include <fail.h> -#include <mlvalues.h> +#include <caml/fail.h> +#include <caml/mlvalues.h> #include "unixsupport.h" #ifdef HAS_UNISTD #include <unistd.h> diff --git a/otherlibs/unix/setuid.c b/otherlibs/unix/setuid.c index 8a2a8074b8..c8a9c622a6 100644 --- a/otherlibs/unix/setuid.c +++ b/otherlibs/unix/setuid.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> +#include <caml/mlvalues.h> #include "unixsupport.h" CAMLprim value unix_setuid(value uid) diff --git a/otherlibs/unix/shutdown.c b/otherlibs/unix/shutdown.c index c428afbd8e..1ceafd6ec8 100644 --- a/otherlibs/unix/shutdown.c +++ b/otherlibs/unix/shutdown.c @@ -11,8 +11,8 @@ /* */ /***********************************************************************/ -#include <fail.h> -#include <mlvalues.h> +#include <caml/fail.h> +#include <caml/mlvalues.h> #include "unixsupport.h" #ifdef HAS_SOCKETS diff --git a/otherlibs/unix/signals.c b/otherlibs/unix/signals.c index d4d97ef07a..d30a70db82 100644 --- a/otherlibs/unix/signals.c +++ b/otherlibs/unix/signals.c @@ -14,11 +14,11 @@ #include <errno.h> #include <signal.h> -#include <alloc.h> -#include <fail.h> -#include <memory.h> -#include <mlvalues.h> -#include <signals.h> +#include <caml/alloc.h> +#include <caml/fail.h> +#include <caml/memory.h> +#include <caml/mlvalues.h> +#include <caml/signals.h> #include "unixsupport.h" #ifndef NSIG diff --git a/otherlibs/unix/sleep.c b/otherlibs/unix/sleep.c index 58affd394d..a39c5f829d 100644 --- a/otherlibs/unix/sleep.c +++ b/otherlibs/unix/sleep.c @@ -11,8 +11,8 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> -#include <signals.h> +#include <caml/mlvalues.h> +#include <caml/signals.h> #include "unixsupport.h" CAMLprim value unix_sleep(value t) diff --git a/otherlibs/unix/socket.c b/otherlibs/unix/socket.c index 9e23231a90..9cf3ed3a8b 100644 --- a/otherlibs/unix/socket.c +++ b/otherlibs/unix/socket.c @@ -11,8 +11,8 @@ /* */ /***********************************************************************/ -#include <fail.h> -#include <mlvalues.h> +#include <caml/fail.h> +#include <caml/mlvalues.h> #include "unixsupport.h" #ifdef HAS_SOCKETS diff --git a/otherlibs/unix/socketaddr.c b/otherlibs/unix/socketaddr.c index 24babcaba2..2eca8fc5b8 100644 --- a/otherlibs/unix/socketaddr.c +++ b/otherlibs/unix/socketaddr.c @@ -12,9 +12,9 @@ /***********************************************************************/ #include <string.h> -#include <mlvalues.h> -#include <alloc.h> -#include <memory.h> +#include <caml/mlvalues.h> +#include <caml/alloc.h> +#include <caml/memory.h> #include <errno.h> #include "unixsupport.h" @@ -23,6 +23,7 @@ #include "socketaddr.h" #ifdef _WIN32 +#undef EAFNOSUPPORT #define EAFNOSUPPORT WSAEAFNOSUPPORT #endif diff --git a/otherlibs/unix/socketaddr.h b/otherlibs/unix/socketaddr.h index cf25e2f99c..0077daeaad 100644 --- a/otherlibs/unix/socketaddr.h +++ b/otherlibs/unix/socketaddr.h @@ -11,7 +11,10 @@ /* */ /***********************************************************************/ -#include "misc.h" +#ifndef CAML_SOCKETADDR_H +#define CAML_SOCKETADDR_H + +#include "caml/misc.h" #include <sys/types.h> #include <sys/socket.h> #include <sys/un.h> @@ -33,6 +36,10 @@ typedef socklen_t socklen_param_type; typedef int socklen_param_type; #endif +#ifdef __cplusplus +extern "C" { +#endif + extern void get_sockaddr (value mladdr, union sock_addr_union * addr /*out*/, socklen_param_type * addr_len /*out*/); @@ -45,3 +52,9 @@ CAMLexport value alloc_inet_addr (struct in_addr * inaddr); CAMLexport value alloc_inet6_addr (struct in6_addr * inaddr); #define GET_INET6_ADDR(v) (*((struct in6_addr *) (v))) #endif + +#ifdef __cplusplus +} +#endif + +#endif /* CAML_SOCKETADDR_H */ diff --git a/otherlibs/unix/socketpair.c b/otherlibs/unix/socketpair.c index 301ebf8612..4f85f9a6b7 100644 --- a/otherlibs/unix/socketpair.c +++ b/otherlibs/unix/socketpair.c @@ -11,9 +11,9 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> -#include <alloc.h> -#include <fail.h> +#include <caml/mlvalues.h> +#include <caml/alloc.h> +#include <caml/fail.h> #include "unixsupport.h" #ifdef HAS_SOCKETS diff --git a/otherlibs/unix/sockopt.c b/otherlibs/unix/sockopt.c index b6167ebf77..8137e42c97 100644 --- a/otherlibs/unix/sockopt.c +++ b/otherlibs/unix/sockopt.c @@ -11,10 +11,10 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> -#include <memory.h> -#include <alloc.h> -#include <fail.h> +#include <caml/mlvalues.h> +#include <caml/memory.h> +#include <caml/alloc.h> +#include <caml/fail.h> #include "unixsupport.h" #ifdef HAS_SOCKETS @@ -194,6 +194,7 @@ unix_getsockopt_aux(char * name, switch (ty) { case TYPE_BOOL: + return Val_bool(optval.i); case TYPE_INT: return Val_int(optval.i); case TYPE_LINGER: diff --git a/otherlibs/unix/stat.c b/otherlibs/unix/stat.c index f6d8c06d3d..f938645a93 100644 --- a/otherlibs/unix/stat.c +++ b/otherlibs/unix/stat.c @@ -12,15 +12,15 @@ /***********************************************************************/ #include <errno.h> -#include <mlvalues.h> -#include <memory.h> -#include <alloc.h> -#include <signals.h> -#include "unixsupport.h" -#include "cst2constr.h" #include <sys/types.h> #include <sys/stat.h> -#include <io.h> +#include <caml/mlvalues.h> +#include <caml/memory.h> +#include <caml/alloc.h> +#include <caml/signals.h> +#include <caml/io.h> +#include "unixsupport.h" +#include "cst2constr.h" #ifndef S_IFLNK #define S_IFLNK 0 @@ -48,9 +48,11 @@ static value stat_aux(int use_64, struct stat *buf) CAMLparam0(); CAMLlocal5(atime, mtime, ctime, offset, v); - atime = copy_double((double) buf->st_atime); - mtime = copy_double((double) buf->st_mtime); - ctime = copy_double((double) buf->st_ctime); + #include "nanosecond_stat.h" + atime = caml_copy_double((double) buf->st_atime + (NSEC(buf, a) / 1000000000.0)); + mtime = caml_copy_double((double) buf->st_mtime + (NSEC(buf, m) / 1000000000.0)); + ctime = caml_copy_double((double) buf->st_ctime + (NSEC(buf, c) / 1000000000.0)); + #undef NSEC offset = use_64 ? Val_file_offset(buf->st_size) : Val_int (buf->st_size); v = alloc_small(12, 0); Field (v, 0) = Val_int (buf->st_dev); diff --git a/otherlibs/unix/strofaddr.c b/otherlibs/unix/strofaddr.c index 5381bc3174..c4ea6bad04 100644 --- a/otherlibs/unix/strofaddr.c +++ b/otherlibs/unix/strofaddr.c @@ -11,9 +11,9 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> -#include <alloc.h> -#include <fail.h> +#include <caml/mlvalues.h> +#include <caml/alloc.h> +#include <caml/fail.h> #include "unixsupport.h" #ifdef HAS_SOCKETS diff --git a/otherlibs/unix/symlink.c b/otherlibs/unix/symlink.c index d1dbf37c5b..dbbd26655e 100644 --- a/otherlibs/unix/symlink.c +++ b/otherlibs/unix/symlink.c @@ -11,10 +11,10 @@ /* */ /***********************************************************************/ -#include <fail.h> -#include <mlvalues.h> -#include <memory.h> -#include <signals.h> +#include <caml/fail.h> +#include <caml/mlvalues.h> +#include <caml/memory.h> +#include <caml/signals.h> #include "unixsupport.h" #ifdef HAS_SYMLINK diff --git a/otherlibs/unix/termios.c b/otherlibs/unix/termios.c index 9dd168aeb7..40173737dd 100644 --- a/otherlibs/unix/termios.c +++ b/otherlibs/unix/termios.c @@ -11,9 +11,9 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> -#include <alloc.h> -#include <fail.h> +#include <caml/mlvalues.h> +#include <caml/alloc.h> +#include <caml/fail.h> #include "unixsupport.h" #ifdef HAS_TERMIOS @@ -90,17 +90,22 @@ static long terminal_io_descr[] = { #undef cflags #undef lflags -struct speedtable_entry ; - static struct { speed_t speed; int baud; } speedtable[] = { + + /* standard speeds */ + {B0, 0}, {B50, 50}, {B75, 75}, {B110, 110}, {B134, 134}, {B150, 150}, +#ifdef B200 + /* Shouldn't need to be ifdef'd but I'm not sure it's available everywhere. */ + {B200, 200}, +#endif {B300, 300}, {B600, 600}, {B1200, 1200}, @@ -110,6 +115,8 @@ static struct { {B9600, 9600}, {B19200, 19200}, {B38400, 38400}, + + /* usual extensions */ #ifdef B57600 {B57600, 57600}, #endif @@ -119,7 +126,66 @@ static struct { #ifdef B230400 {B230400, 230400}, #endif - {B0, 0} + + /* Linux extensions */ +#ifdef B460800 + {B460800, 460800}, +#endif +#ifdef B500000 + {B500000, 500000}, +#endif +#ifdef B576000 + {B576000, 576000}, +#endif +#ifdef B921600 + {B921600, 921600}, +#endif +#ifdef B1000000 + {B1000000, 1000000}, +#endif +#ifdef B1152000 + {B1152000, 1152000}, +#endif +#ifdef B1500000 + {B1500000, 1500000}, +#endif +#ifdef B2000000 + {B2000000, 2000000}, +#endif +#ifdef B2500000 + {B2500000, 2500000}, +#endif +#ifdef B3000000 + {B3000000, 3000000}, +#endif +#ifdef B3500000 + {B3500000, 3500000}, +#endif +#ifdef B4000000 + {B4000000, 4000000}, +#endif + + /* MacOS extensions */ +#ifdef B7200 + {B7200, 7200}, +#endif +#ifdef B14400 + {B14400, 14400}, +#endif +#ifdef B28800 + {B28800, 28800}, +#endif +#ifdef B76800 + {B76800, 76800}, +#endif + + /* Cygwin extensions (in addition to the Linux ones) */ +#ifdef B128000 + {B128000, 128000}, +#endif +#ifdef B256000 + {B256000, 256000}, +#endif }; #define NSPEEDS (sizeof(speedtable) / sizeof(speedtable[0])) diff --git a/otherlibs/unix/time.c b/otherlibs/unix/time.c index 042a1f60c9..495adb660b 100644 --- a/otherlibs/unix/time.c +++ b/otherlibs/unix/time.c @@ -12,8 +12,8 @@ /***********************************************************************/ #include <time.h> -#include <mlvalues.h> -#include <alloc.h> +#include <caml/mlvalues.h> +#include <caml/alloc.h> #include "unixsupport.h" CAMLprim value unix_time(value unit) diff --git a/otherlibs/unix/times.c b/otherlibs/unix/times.c index 8ab6006d41..8760ad2ab2 100644 --- a/otherlibs/unix/times.c +++ b/otherlibs/unix/times.c @@ -11,9 +11,9 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> -#include <alloc.h> -#include <memory.h> +#include <caml/mlvalues.h> +#include <caml/alloc.h> +#include <caml/memory.h> #include "unixsupport.h" #include <time.h> #include <sys/types.h> diff --git a/otherlibs/unix/truncate.c b/otherlibs/unix/truncate.c index 520320ebbc..62683fcf88 100644 --- a/otherlibs/unix/truncate.c +++ b/otherlibs/unix/truncate.c @@ -12,11 +12,11 @@ /***********************************************************************/ #include <sys/types.h> -#include <mlvalues.h> -#include <memory.h> -#include <fail.h> -#include <signals.h> -#include <io.h> +#include <caml/mlvalues.h> +#include <caml/memory.h> +#include <caml/fail.h> +#include <caml/signals.h> +#include <caml/io.h> #include "unixsupport.h" #ifdef HAS_UNISTD #include <unistd.h> diff --git a/otherlibs/unix/umask.c b/otherlibs/unix/umask.c index 311e4ed926..9b88f105c5 100644 --- a/otherlibs/unix/umask.c +++ b/otherlibs/unix/umask.c @@ -13,7 +13,7 @@ #include <sys/types.h> #include <sys/stat.h> -#include <mlvalues.h> +#include <caml/mlvalues.h> #include "unixsupport.h" CAMLprim value unix_umask(value perm) diff --git a/otherlibs/unix/unixsupport.c b/otherlibs/unix/unixsupport.c index f1df3fc72c..6c7171fdd6 100644 --- a/otherlibs/unix/unixsupport.c +++ b/otherlibs/unix/unixsupport.c @@ -11,11 +11,11 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> -#include <alloc.h> -#include <callback.h> -#include <memory.h> -#include <fail.h> +#include <caml/mlvalues.h> +#include <caml/alloc.h> +#include <caml/callback.h> +#include <caml/memory.h> +#include <caml/fail.h> #include "unixsupport.h" #include "cst2constr.h" #include <errno.h> diff --git a/otherlibs/unix/unixsupport.h b/otherlibs/unix/unixsupport.h index a8065d973a..1499780590 100644 --- a/otherlibs/unix/unixsupport.h +++ b/otherlibs/unix/unixsupport.h @@ -11,17 +11,30 @@ /* */ /***********************************************************************/ +#ifndef CAML_UNIXSUPPORT_H +#define CAML_UNIXSUPPORT_H + #ifdef HAS_UNISTD #include <unistd.h> #endif +#ifdef __cplusplus +extern "C" { +#endif + #define Nothing ((value) 0) extern value unix_error_of_code (int errcode); extern int code_of_unix_error (value error); -extern void unix_error (int errcode, char * cmdname, value arg) Noreturn; -extern void uerror (char * cmdname, value arg) Noreturn; +Noreturn extern void unix_error (int errcode, char * cmdname, value arg); +Noreturn extern void uerror (char * cmdname, value arg); #define UNIX_BUFFER_SIZE 65536 #define DIR_Val(v) *((DIR **) &Field(v, 0)) + +#ifdef __cplusplus +} +#endif + +#endif /* CAML_UNIXSUPPORT_H */ diff --git a/otherlibs/unix/unlink.c b/otherlibs/unix/unlink.c index ae63f69a13..687c69c26a 100644 --- a/otherlibs/unix/unlink.c +++ b/otherlibs/unix/unlink.c @@ -11,9 +11,9 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> -#include <memory.h> -#include <signals.h> +#include <caml/mlvalues.h> +#include <caml/memory.h> +#include <caml/signals.h> #include "unixsupport.h" CAMLprim value unix_unlink(value path) diff --git a/otherlibs/unix/utimes.c b/otherlibs/unix/utimes.c index 0c3b77d1be..bf2ae2fb26 100644 --- a/otherlibs/unix/utimes.c +++ b/otherlibs/unix/utimes.c @@ -11,10 +11,10 @@ /* */ /***********************************************************************/ -#include <fail.h> -#include <mlvalues.h> -#include <memory.h> -#include <signals.h> +#include <caml/fail.h> +#include <caml/mlvalues.h> +#include <caml/memory.h> +#include <caml/signals.h> #include "unixsupport.h" #ifdef HAS_UTIME diff --git a/otherlibs/unix/wait.c b/otherlibs/unix/wait.c index 81f3683909..a8eb42b78e 100644 --- a/otherlibs/unix/wait.c +++ b/otherlibs/unix/wait.c @@ -11,11 +11,11 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> -#include <alloc.h> -#include <fail.h> -#include <memory.h> -#include <signals.h> +#include <caml/mlvalues.h> +#include <caml/alloc.h> +#include <caml/fail.h> +#include <caml/memory.h> +#include <caml/signals.h> #include "unixsupport.h" #include <sys/types.h> diff --git a/otherlibs/unix/write.c b/otherlibs/unix/write.c index d6fe40932d..d6842d9f87 100644 --- a/otherlibs/unix/write.c +++ b/otherlibs/unix/write.c @@ -13,9 +13,9 @@ #include <errno.h> #include <string.h> -#include <mlvalues.h> -#include <memory.h> -#include <signals.h> +#include <caml/mlvalues.h> +#include <caml/memory.h> +#include <caml/signals.h> #include "unixsupport.h" #ifndef EAGAIN diff --git a/otherlibs/win32graph/dib.c b/otherlibs/win32graph/dib.c index 100beba39e..26fccf7f18 100644 --- a/otherlibs/win32graph/dib.c +++ b/otherlibs/win32graph/dib.c @@ -42,9 +42,9 @@ #include <windows.h> -#include <memory.h> +#include <caml/memory.h> #include <string.h> -#include <io.h> +#include <caml/io.h> #include <stdio.h> // Size of window extra bytes (we store a handle to a PALINFO structure). diff --git a/otherlibs/win32graph/draw.c b/otherlibs/win32graph/draw.c index 11426734b0..99e1c5c7e8 100644 --- a/otherlibs/win32graph/draw.c +++ b/otherlibs/win32graph/draw.c @@ -12,12 +12,12 @@ /***********************************************************************/ #include <math.h> -#include "mlvalues.h" -#include "alloc.h" -#include "fail.h" +#include "caml/mlvalues.h" +#include "caml/alloc.h" +#include "caml/fail.h" #include "libgraph.h" -#include "custom.h" -#include "memory.h" +#include "caml/custom.h" +#include "caml/memory.h" HDC gcMetaFile; int grdisplay_mode; diff --git a/otherlibs/win32graph/events.c b/otherlibs/win32graph/events.c index 81242729e5..837e53ac14 100755 --- a/otherlibs/win32graph/events.c +++ b/otherlibs/win32graph/events.c @@ -11,8 +11,8 @@ /* */ /***********************************************************************/ -#include "mlvalues.h" -#include "alloc.h" +#include "caml/mlvalues.h" +#include "caml/alloc.h" #include "libgraph.h" #include <windows.h> diff --git a/otherlibs/win32graph/open.c b/otherlibs/win32graph/open.c index ded2e28ae0..e9d10cad00 100644 --- a/otherlibs/win32graph/open.c +++ b/otherlibs/win32graph/open.c @@ -13,10 +13,10 @@ #include <fcntl.h> #include <signal.h> -#include "mlvalues.h" -#include "fail.h" +#include "caml/mlvalues.h" +#include "caml/fail.h" #include "libgraph.h" -#include "callback.h" +#include "caml/callback.h" #include <windows.h> static value gr_reset(void); @@ -112,7 +112,7 @@ int DoRegisterClass(void) WNDCLASS wc; memset(&wc,0,sizeof(WNDCLASS)); - wc.style = CS_HREDRAW|CS_VREDRAW |CS_DBLCLKS|CS_OWNDC ; + wc.style = CS_HREDRAW|CS_VREDRAW|CS_OWNDC ; wc.lpfnWndProc = (WNDPROC)GraphicsWndProc; wc.hInstance = hInst; wc.hbrBackground = (HBRUSH)(COLOR_WINDOW+1); diff --git a/otherlibs/win32unix/accept.c b/otherlibs/win32unix/accept.c index f2e14467aa..f705f0f090 100644 --- a/otherlibs/win32unix/accept.c +++ b/otherlibs/win32unix/accept.c @@ -11,10 +11,10 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> -#include <alloc.h> -#include <memory.h> -#include <signals.h> +#include <caml/mlvalues.h> +#include <caml/alloc.h> +#include <caml/memory.h> +#include <caml/signals.h> #include "unixsupport.h" #include <mswsock.h> // for SO_OPENTYPE and SO_SYNCHRONOUS_NONALERT #include "socketaddr.h" diff --git a/otherlibs/win32unix/bind.c b/otherlibs/win32unix/bind.c index bc09230893..4b1d3def6b 100644 --- a/otherlibs/win32unix/bind.c +++ b/otherlibs/win32unix/bind.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> +#include <caml/mlvalues.h> #include "unixsupport.h" #include "socketaddr.h" diff --git a/otherlibs/win32unix/channels.c b/otherlibs/win32unix/channels.c index 1e7e823acf..b6350e1742 100644 --- a/otherlibs/win32unix/channels.c +++ b/otherlibs/win32unix/channels.c @@ -11,10 +11,10 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> -#include <alloc.h> -#include <io.h> -#include <memory.h> +#include <caml/mlvalues.h> +#include <caml/alloc.h> +#include <caml/io.h> +#include <caml/memory.h> #include "unixsupport.h" #include <fcntl.h> diff --git a/otherlibs/win32unix/close.c b/otherlibs/win32unix/close.c index 20b131b05c..7f8da29dac 100644 --- a/otherlibs/win32unix/close.c +++ b/otherlibs/win32unix/close.c @@ -11,9 +11,9 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> +#include <caml/mlvalues.h> #include "unixsupport.h" -#include <io.h> +#include <caml/io.h> extern int _close(int); diff --git a/otherlibs/win32unix/close_on.c b/otherlibs/win32unix/close_on.c index 9ba342ed0e..7a316abcae 100644 --- a/otherlibs/win32unix/close_on.c +++ b/otherlibs/win32unix/close_on.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> +#include <caml/mlvalues.h> #include "unixsupport.h" #include <windows.h> diff --git a/otherlibs/win32unix/connect.c b/otherlibs/win32unix/connect.c index 190eb742a2..37cdbdaa87 100644 --- a/otherlibs/win32unix/connect.c +++ b/otherlibs/win32unix/connect.c @@ -11,8 +11,8 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> -#include <signals.h> +#include <caml/mlvalues.h> +#include <caml/signals.h> #include "unixsupport.h" #include "socketaddr.h" diff --git a/otherlibs/win32unix/createprocess.c b/otherlibs/win32unix/createprocess.c index 3858a39b8a..791acbb50d 100644 --- a/otherlibs/win32unix/createprocess.c +++ b/otherlibs/win32unix/createprocess.c @@ -11,10 +11,10 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> +#include <caml/mlvalues.h> #include "unixsupport.h" #include <windows.h> -#include <osdeps.h> +#include <caml/osdeps.h> static int win_has_console(void); diff --git a/otherlibs/win32unix/dup.c b/otherlibs/win32unix/dup.c index 76cbdf670e..5db19e3073 100644 --- a/otherlibs/win32unix/dup.c +++ b/otherlibs/win32unix/dup.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> +#include <caml/mlvalues.h> #include "unixsupport.h" CAMLprim value unix_dup(value fd) diff --git a/otherlibs/win32unix/dup2.c b/otherlibs/win32unix/dup2.c index 5f19710c37..5184207798 100644 --- a/otherlibs/win32unix/dup2.c +++ b/otherlibs/win32unix/dup2.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> +#include <caml/mlvalues.h> #include "unixsupport.h" extern int _dup2(int, int); diff --git a/otherlibs/win32unix/errmsg.c b/otherlibs/win32unix/errmsg.c index c3bc19c6b0..6107abc395 100644 --- a/otherlibs/win32unix/errmsg.c +++ b/otherlibs/win32unix/errmsg.c @@ -14,8 +14,8 @@ #include <stdio.h> #include <errno.h> #include <string.h> -#include <mlvalues.h> -#include <alloc.h> +#include <caml/mlvalues.h> +#include <caml/alloc.h> #include "unixsupport.h" extern int error_table[]; diff --git a/otherlibs/win32unix/getpeername.c b/otherlibs/win32unix/getpeername.c index ad6674bf6b..3467e03fd2 100644 --- a/otherlibs/win32unix/getpeername.c +++ b/otherlibs/win32unix/getpeername.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> +#include <caml/mlvalues.h> #include "unixsupport.h" #include "socketaddr.h" diff --git a/otherlibs/win32unix/getpid.c b/otherlibs/win32unix/getpid.c index 65c8828a19..06d95356ee 100644 --- a/otherlibs/win32unix/getpid.c +++ b/otherlibs/win32unix/getpid.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> +#include <caml/mlvalues.h> #include "unixsupport.h" extern value val_process_id; diff --git a/otherlibs/win32unix/getsockname.c b/otherlibs/win32unix/getsockname.c index 1e28f4b221..21e9d0630d 100644 --- a/otherlibs/win32unix/getsockname.c +++ b/otherlibs/win32unix/getsockname.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> +#include <caml/mlvalues.h> #include "unixsupport.h" #include "socketaddr.h" diff --git a/otherlibs/win32unix/gettimeofday.c b/otherlibs/win32unix/gettimeofday.c index 573821fd75..34f00f3ec2 100644 --- a/otherlibs/win32unix/gettimeofday.c +++ b/otherlibs/win32unix/gettimeofday.c @@ -11,44 +11,20 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> -#include <alloc.h> +#include <caml/mlvalues.h> +#include <caml/alloc.h> #include <time.h> #include "unixsupport.h" -#ifdef HAS_MKTIME -static double initial_time = 0; /* 0 means uninitialized */ -#else -static time_t initial_time = 0; /* 0 means uninitialized */ -#endif -static DWORD initial_tickcount; +/* Unix epoch as a Windows timestamp in hundreds of ns */ +#define epoch_ft 116444736000000000.0; CAMLprim value unix_gettimeofday(value unit) { - DWORD tickcount = GetTickCount(); - SYSTEMTIME st; - struct tm tm; - if (initial_time == 0 || tickcount < initial_tickcount) { - initial_tickcount = tickcount; -#ifdef HAS_MKTIME - GetLocalTime(&st); - tm.tm_sec = st.wSecond; - tm.tm_min = st.wMinute; - tm.tm_hour = st.wHour; - tm.tm_mday = st.wDay; - tm.tm_mon = st.wMonth - 1; - tm.tm_year = st.wYear - 1900; - tm.tm_wday = 0; - tm.tm_yday = 0; - tm.tm_isdst = -1; - initial_time = ((double) mktime(&tm) + (double) st.wMilliseconds * 1e-3); -#else - initial_time = time(NULL); -#endif - return copy_double((double) initial_time); - } else { - return copy_double((double) initial_time + - (double) (tickcount - initial_tickcount) * 1e-3); - } + FILETIME ft; + double tm; + GetSystemTimeAsFileTime(&ft); + tm = *(uint64_t *)&ft - epoch_ft; /* shift to Epoch-relative time */ + return copy_double(tm * 1e-7); /* tm is in 100ns */ } diff --git a/otherlibs/win32unix/link.c b/otherlibs/win32unix/link.c index 97748ba2cc..93d21508a2 100644 --- a/otherlibs/win32unix/link.c +++ b/otherlibs/win32unix/link.c @@ -11,8 +11,8 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> -#include <fail.h> +#include <caml/mlvalues.h> +#include <caml/fail.h> #include "unixsupport.h" #include <windows.h> diff --git a/otherlibs/win32unix/listen.c b/otherlibs/win32unix/listen.c index 9602a3736f..767db61d79 100644 --- a/otherlibs/win32unix/listen.c +++ b/otherlibs/win32unix/listen.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> +#include <caml/mlvalues.h> #include "unixsupport.h" CAMLprim value unix_listen(sock, backlog) diff --git a/otherlibs/win32unix/lockf.c b/otherlibs/win32unix/lockf.c index 6e6ca0ad63..9c705a6788 100644 --- a/otherlibs/win32unix/lockf.c +++ b/otherlibs/win32unix/lockf.c @@ -15,12 +15,12 @@ #include <errno.h> #include <fcntl.h> -#include <mlvalues.h> -#include <memory.h> -#include <fail.h> +#include <caml/mlvalues.h> +#include <caml/memory.h> +#include <caml/fail.h> #include "unixsupport.h" #include <stdio.h> -#include <signals.h> +#include <caml/signals.h> #ifndef INVALID_SET_FILE_POINTER #define INVALID_SET_FILE_POINTER (-1) diff --git a/otherlibs/win32unix/lseek.c b/otherlibs/win32unix/lseek.c index 5306331c63..6c30a62ae9 100644 --- a/otherlibs/win32unix/lseek.c +++ b/otherlibs/win32unix/lseek.c @@ -11,8 +11,8 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> -#include <alloc.h> +#include <caml/mlvalues.h> +#include <caml/alloc.h> #include "unixsupport.h" #ifdef HAS_UNISTD diff --git a/otherlibs/win32unix/mkdir.c b/otherlibs/win32unix/mkdir.c index 998b32baf4..21bca10ce4 100644 --- a/otherlibs/win32unix/mkdir.c +++ b/otherlibs/win32unix/mkdir.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> +#include <caml/mlvalues.h> #include "unixsupport.h" CAMLprim value unix_mkdir(path, perm) diff --git a/otherlibs/win32unix/nonblock.c b/otherlibs/win32unix/nonblock.c index a9aaeca5c7..4001beca6c 100755 --- a/otherlibs/win32unix/nonblock.c +++ b/otherlibs/win32unix/nonblock.c @@ -11,8 +11,8 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> -#include <signals.h> +#include <caml/mlvalues.h> +#include <caml/signals.h> #include "unixsupport.h" CAMLprim value unix_set_nonblock(socket) diff --git a/otherlibs/win32unix/open.c b/otherlibs/win32unix/open.c index afb8d0fb9f..f9e9df21ad 100644 --- a/otherlibs/win32unix/open.c +++ b/otherlibs/win32unix/open.c @@ -11,8 +11,8 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> -#include <alloc.h> +#include <caml/mlvalues.h> +#include <caml/alloc.h> #include "unixsupport.h" #include <fcntl.h> diff --git a/otherlibs/win32unix/pipe.c b/otherlibs/win32unix/pipe.c index fe553778ad..88debb023a 100644 --- a/otherlibs/win32unix/pipe.c +++ b/otherlibs/win32unix/pipe.c @@ -11,9 +11,9 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> -#include <memory.h> -#include <alloc.h> +#include <caml/mlvalues.h> +#include <caml/memory.h> +#include <caml/alloc.h> #include "unixsupport.h" #include <fcntl.h> diff --git a/otherlibs/win32unix/read.c b/otherlibs/win32unix/read.c index e7a2b38d7a..d65683cc60 100644 --- a/otherlibs/win32unix/read.c +++ b/otherlibs/win32unix/read.c @@ -12,9 +12,9 @@ /***********************************************************************/ #include <string.h> -#include <mlvalues.h> -#include <memory.h> -#include <signals.h> +#include <caml/mlvalues.h> +#include <caml/memory.h> +#include <caml/signals.h> #include "unixsupport.h" CAMLprim value unix_read(value fd, value buf, value ofs, value vlen) diff --git a/otherlibs/win32unix/rename.c b/otherlibs/win32unix/rename.c index b8c0f3edc5..ad46ead246 100644 --- a/otherlibs/win32unix/rename.c +++ b/otherlibs/win32unix/rename.c @@ -12,7 +12,7 @@ /***********************************************************************/ #include <stdio.h> -#include <mlvalues.h> +#include <caml/mlvalues.h> #include "unixsupport.h" CAMLprim value unix_rename(value path1, value path2) diff --git a/otherlibs/win32unix/select.c b/otherlibs/win32unix/select.c index d4afe49866..0e21db897e 100644 --- a/otherlibs/win32unix/select.c +++ b/otherlibs/win32unix/select.c @@ -11,11 +11,11 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> -#include <alloc.h> -#include <memory.h> -#include <fail.h> -#include <signals.h> +#include <caml/mlvalues.h> +#include <caml/alloc.h> +#include <caml/memory.h> +#include <caml/fail.h> +#include <caml/signals.h> #include "winworker.h" #include <stdio.h> #include "windbug.h" diff --git a/otherlibs/win32unix/sendrecv.c b/otherlibs/win32unix/sendrecv.c index 32532553fc..5957f6ed8f 100644 --- a/otherlibs/win32unix/sendrecv.c +++ b/otherlibs/win32unix/sendrecv.c @@ -11,10 +11,10 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> -#include <alloc.h> -#include <memory.h> -#include <signals.h> +#include <caml/mlvalues.h> +#include <caml/alloc.h> +#include <caml/memory.h> +#include <caml/signals.h> #include "unixsupport.h" #include "socketaddr.h" diff --git a/otherlibs/win32unix/shutdown.c b/otherlibs/win32unix/shutdown.c index 2d5707a353..9602311161 100644 --- a/otherlibs/win32unix/shutdown.c +++ b/otherlibs/win32unix/shutdown.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> +#include <caml/mlvalues.h> #include "unixsupport.h" static int shutdown_command_table[] = { diff --git a/otherlibs/win32unix/sleep.c b/otherlibs/win32unix/sleep.c index 28e60e40a3..6d630d2057 100644 --- a/otherlibs/win32unix/sleep.c +++ b/otherlibs/win32unix/sleep.c @@ -11,8 +11,8 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> -#include <signals.h> +#include <caml/mlvalues.h> +#include <caml/signals.h> #include "unixsupport.h" CAMLprim value unix_sleep(t) diff --git a/otherlibs/win32unix/socket.c b/otherlibs/win32unix/socket.c index ad8165b291..9385e82e7e 100644 --- a/otherlibs/win32unix/socket.c +++ b/otherlibs/win32unix/socket.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> +#include <caml/mlvalues.h> #include "unixsupport.h" #include <mswsock.h> // for SO_OPENTYPE and SO_SYNCHRONOUS_NONALERT diff --git a/otherlibs/win32unix/socketaddr.h b/otherlibs/win32unix/socketaddr.h index fde691ec6e..f3b6caf0fd 100644 --- a/otherlibs/win32unix/socketaddr.h +++ b/otherlibs/win32unix/socketaddr.h @@ -11,7 +11,10 @@ /* */ /***********************************************************************/ -#include "misc.h" +#ifndef CAML_SOCKETADDR_H +#define CAML_SOCKETADDR_H + +#include "caml/misc.h" union sock_addr_union { struct sockaddr s_gen; @@ -29,6 +32,10 @@ typedef socklen_t socklen_param_type; typedef int socklen_param_type; #endif +#ifdef __cplusplus +extern "C" { +#endif + extern void get_sockaddr (value mladdr, union sock_addr_union * addr /*out*/, socklen_param_type * addr_len /*out*/); @@ -41,3 +48,9 @@ CAMLprim value alloc_inet_addr (struct in_addr * inaddr); CAMLexport value alloc_inet6_addr (struct in6_addr * inaddr); #define GET_INET6_ADDR(v) (*((struct in6_addr *) (v))) #endif + +#ifdef __cplusplus +} +#endif + +#endif /* CAML_SOCKETADDR_H */ diff --git a/otherlibs/win32unix/sockopt.c b/otherlibs/win32unix/sockopt.c index eefa9a3097..aebc517a0d 100644 --- a/otherlibs/win32unix/sockopt.c +++ b/otherlibs/win32unix/sockopt.c @@ -12,10 +12,10 @@ /***********************************************************************/ #include <errno.h> -#include <mlvalues.h> -#include <memory.h> -#include <alloc.h> -#include <fail.h> +#include <caml/mlvalues.h> +#include <caml/memory.h> +#include <caml/alloc.h> +#include <caml/fail.h> #include "unixsupport.h" #include "socketaddr.h" diff --git a/otherlibs/win32unix/startup.c b/otherlibs/win32unix/startup.c index 65aedc6a81..be66c8a822 100644 --- a/otherlibs/win32unix/startup.c +++ b/otherlibs/win32unix/startup.c @@ -14,7 +14,7 @@ #include <stdio.h> #include <fcntl.h> #include <stdlib.h> -#include <mlvalues.h> +#include <caml/mlvalues.h> #include "winworker.h" #include "windbug.h" diff --git a/otherlibs/win32unix/stat.c b/otherlibs/win32unix/stat.c index 56b45d0370..46fc9841b1 100644 --- a/otherlibs/win32unix/stat.c +++ b/otherlibs/win32unix/stat.c @@ -12,9 +12,9 @@ /***********************************************************************/ #include <errno.h> -#include <mlvalues.h> -#include <memory.h> -#include <alloc.h> +#include <caml/mlvalues.h> +#include <caml/memory.h> +#include <caml/alloc.h> #include "unixsupport.h" #include "cst2constr.h" #define _INTEGRAL_MAX_BITS 64 diff --git a/otherlibs/win32unix/system.c b/otherlibs/win32unix/system.c index 13d5658e61..202dcd0813 100644 --- a/otherlibs/win32unix/system.c +++ b/otherlibs/win32unix/system.c @@ -11,10 +11,10 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> -#include <memory.h> -#include <alloc.h> -#include <signals.h> +#include <caml/mlvalues.h> +#include <caml/memory.h> +#include <caml/alloc.h> +#include <caml/signals.h> #include "unixsupport.h" #include <process.h> #include <stdio.h> diff --git a/otherlibs/win32unix/times.c b/otherlibs/win32unix/times.c index e6b5ab0ab6..e97d3a5c28 100644 --- a/otherlibs/win32unix/times.c +++ b/otherlibs/win32unix/times.c @@ -11,8 +11,8 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> -#include <alloc.h> +#include <caml/mlvalues.h> +#include <caml/alloc.h> #include "unixsupport.h" #include <windows.h> diff --git a/otherlibs/win32unix/unixsupport.c b/otherlibs/win32unix/unixsupport.c index f954dfc967..85f220c329 100644 --- a/otherlibs/win32unix/unixsupport.c +++ b/otherlibs/win32unix/unixsupport.c @@ -12,12 +12,12 @@ /***********************************************************************/ #include <stddef.h> -#include <mlvalues.h> -#include <callback.h> -#include <alloc.h> -#include <memory.h> -#include <fail.h> -#include <custom.h> +#include <caml/mlvalues.h> +#include <caml/callback.h> +#include <caml/alloc.h> +#include <caml/memory.h> +#include <caml/fail.h> +#include <caml/custom.h> #include "unixsupport.h" #include "cst2constr.h" #include <errno.h> @@ -170,44 +170,80 @@ void win32_maperr(DWORD errcode) } /* Windows socket errors */ - +#undef EWOULDBLOCK #define EWOULDBLOCK -WSAEWOULDBLOCK +#undef EINPROGRESS #define EINPROGRESS -WSAEINPROGRESS +#undef EALREADY #define EALREADY -WSAEALREADY +#undef ENOTSOCK #define ENOTSOCK -WSAENOTSOCK +#undef EDESTADDRREQ #define EDESTADDRREQ -WSAEDESTADDRREQ +#undef EMSGSIZE #define EMSGSIZE -WSAEMSGSIZE +#undef EPROTOTYPE #define EPROTOTYPE -WSAEPROTOTYPE +#undef ENOPROTOOPT #define ENOPROTOOPT -WSAENOPROTOOPT +#undef EPROTONOSUPPORT #define EPROTONOSUPPORT -WSAEPROTONOSUPPORT +#undef ESOCKTNOSUPPORT #define ESOCKTNOSUPPORT -WSAESOCKTNOSUPPORT +#undef EOPNOTSUPP #define EOPNOTSUPP -WSAEOPNOTSUPP +#undef EPFNOSUPPORT #define EPFNOSUPPORT -WSAEPFNOSUPPORT +#undef EAFNOSUPPORT #define EAFNOSUPPORT -WSAEAFNOSUPPORT +#undef EADDRINUSE #define EADDRINUSE -WSAEADDRINUSE +#undef EADDRNOTAVAIL #define EADDRNOTAVAIL -WSAEADDRNOTAVAIL +#undef ENETDOWN #define ENETDOWN -WSAENETDOWN +#undef ENETUNREACH #define ENETUNREACH -WSAENETUNREACH +#undef ENETRESET #define ENETRESET -WSAENETRESET +#undef ECONNABORTED #define ECONNABORTED -WSAECONNABORTED +#undef ECONNRESET #define ECONNRESET -WSAECONNRESET +#undef ENOBUFS #define ENOBUFS -WSAENOBUFS +#undef EISCONN #define EISCONN -WSAEISCONN +#undef ENOTCONN #define ENOTCONN -WSAENOTCONN +#undef ESHUTDOWN #define ESHUTDOWN -WSAESHUTDOWN +#undef ETOOMANYREFS #define ETOOMANYREFS -WSAETOOMANYREFS +#undef ETIMEDOUT #define ETIMEDOUT -WSAETIMEDOUT +#undef ECONNREFUSED #define ECONNREFUSED -WSAECONNREFUSED +#undef ELOOP #define ELOOP -WSAELOOP +#undef EHOSTDOWN #define EHOSTDOWN -WSAEHOSTDOWN +#undef EHOSTUNREACH #define EHOSTUNREACH -WSAEHOSTUNREACH +#undef EPROCLIM #define EPROCLIM -WSAEPROCLIM +#undef EUSERS #define EUSERS -WSAEUSERS +#undef EDQUOT #define EDQUOT -WSAEDQUOT +#undef ESTALE #define ESTALE -WSAESTALE +#undef EREMOTE #define EREMOTE -WSAEREMOTE +#undef EOVERFLOW #define EOVERFLOW -ERROR_ARITHMETIC_OVERFLOW +#undef EACCESS #define EACCESS EACCES int error_table[] = { diff --git a/otherlibs/win32unix/unixsupport.h b/otherlibs/win32unix/unixsupport.h index b8f8acad5c..b8efb27806 100644 --- a/otherlibs/win32unix/unixsupport.h +++ b/otherlibs/win32unix/unixsupport.h @@ -11,6 +11,9 @@ /* */ /***********************************************************************/ +#ifndef CAML_UNIXSUPPORT_H +#define CAML_UNIXSUPPORT_H + #define WIN32_LEAN_AND_MEAN #include <wtypes.h> #include <winbase.h> @@ -24,6 +27,10 @@ #include <wspiapi.h> #endif +#ifdef __cplusplus +extern "C" { +#endif + struct filedescr { union { HANDLE handle; @@ -62,3 +69,9 @@ extern value unix_freeze_buffer (value); #define FLAGS_FD_IS_BLOCKING (1<<0) #define UNIX_BUFFER_SIZE 65536 + +#ifdef __cplusplus +} +#endif + +#endif /* CAML_UNIXSUPPORT_H */ diff --git a/otherlibs/win32unix/windir.c b/otherlibs/win32unix/windir.c index 7a08e510ad..ef952aa902 100644 --- a/otherlibs/win32unix/windir.c +++ b/otherlibs/win32unix/windir.c @@ -11,11 +11,11 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> -#include <memory.h> +#include <caml/mlvalues.h> +#include <caml/memory.h> #include <errno.h> -#include <alloc.h> -#include <fail.h> +#include <caml/alloc.h> +#include <caml/fail.h> #include "unixsupport.h" CAMLprim value win_findfirst(name) diff --git a/otherlibs/win32unix/winwait.c b/otherlibs/win32unix/winwait.c index 0436072f1c..510a16fea1 100644 --- a/otherlibs/win32unix/winwait.c +++ b/otherlibs/win32unix/winwait.c @@ -11,10 +11,10 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> -#include <alloc.h> -#include <memory.h> -#include <signals.h> +#include <caml/mlvalues.h> +#include <caml/alloc.h> +#include <caml/memory.h> +#include <caml/signals.h> #include "unixsupport.h" #include <windows.h> #include <sys/types.h> diff --git a/otherlibs/win32unix/winworker.c b/otherlibs/win32unix/winworker.c index f8ef33e1f0..bcd5947aec 100644 --- a/otherlibs/win32unix/winworker.c +++ b/otherlibs/win32unix/winworker.c @@ -11,10 +11,10 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> -#include <alloc.h> -#include <memory.h> -#include <signals.h> +#include <caml/mlvalues.h> +#include <caml/alloc.h> +#include <caml/memory.h> +#include <caml/signals.h> #include "winworker.h" #include "winlist.h" #include "windbug.h" diff --git a/otherlibs/win32unix/write.c b/otherlibs/win32unix/write.c index 65f82ccb5d..dc0ae91b7d 100644 --- a/otherlibs/win32unix/write.c +++ b/otherlibs/win32unix/write.c @@ -13,9 +13,9 @@ #include <errno.h> #include <string.h> -#include <mlvalues.h> -#include <memory.h> -#include <signals.h> +#include <caml/mlvalues.h> +#include <caml/memory.h> +#include <caml/signals.h> #include "unixsupport.h" CAMLprim value unix_write(value fd, value buf, value vofs, value vlen) diff --git a/parsing/ast_helper.ml b/parsing/ast_helper.ml index f53cb29288..db3b029a86 100644 --- a/parsing/ast_helper.ml +++ b/parsing/ast_helper.ml @@ -14,6 +14,7 @@ open Asttypes open Parsetree +open Docstrings type lid = Longident.t loc type str = string loc @@ -157,7 +158,7 @@ module Sig = struct let mk ?(loc = !default_loc) d = {psig_desc = d; psig_loc = loc} let value ?loc a = mk ?loc (Psig_value a) - let type_ ?loc a = mk ?loc (Psig_type a) + let type_ ?loc rec_flag a = mk ?loc (Psig_type (rec_flag, 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) @@ -169,6 +170,10 @@ module Sig = struct let class_type ?loc a = mk ?loc (Psig_class_type a) let extension ?loc ?(attrs = []) a = mk ?loc (Psig_extension (a, attrs)) let attribute ?loc a = mk ?loc (Psig_attribute a) + let text txt = + List.map + (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) + txt end module Str = struct @@ -177,7 +182,7 @@ module Str = struct let eval ?loc ?(attrs = []) a = mk ?loc (Pstr_eval (a, attrs)) 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_ ?loc rec_flag a = mk ?loc (Pstr_type (rec_flag, a)) let type_extension ?loc a = mk ?loc (Pstr_typext a) let exception_ ?loc a = mk ?loc (Pstr_exception a) let module_ ?loc a = mk ?loc (Pstr_module a) @@ -189,6 +194,10 @@ module Str = struct 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) + let text txt = + List.map + (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) + txt end module Cl = struct @@ -225,13 +234,13 @@ module Cty = struct end module Ctf = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = + let mk ?(loc = !default_loc) ?(attrs = []) + ?(docs = empty_docs) d = { pctf_desc = d; pctf_loc = loc; - pctf_attributes = attrs; + pctf_attributes = add_docs_attrs docs attrs; } - let attr d a = {d with pctf_attributes = d.pctf_attributes @ [a]} let inherit_ ?loc ?attrs a = mk ?loc ?attrs (Pctf_inherit a) let val_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pctf_val (a, b, c, d)) @@ -239,16 +248,23 @@ module Ctf = struct 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) + let text txt = + List.map + (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) + txt + + let attr d a = {d with pctf_attributes = d.pctf_attributes @ [a]} + end module Cf = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = + let mk ?(loc = !default_loc) ?(attrs = []) + ?(docs = empty_docs) d = { pcf_desc = d; pcf_loc = loc; - pcf_attributes = attrs; + pcf_attributes = add_docs_attrs docs attrs; } - let attr d a = {d with pcf_attributes = d.pcf_attributes @ [a]} let inherit_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_inherit (a, b, c)) let val_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_val (a, b, c)) @@ -257,96 +273,117 @@ module Cf = struct 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 text txt = + List.map + (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) + txt let virtual_ ct = Cfk_virtual ct let concrete o e = Cfk_concrete (o, e) + + let attr d a = {d with pcf_attributes = d.pcf_attributes @ [a]} + end module Val = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(prim = []) name typ = + let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) + ?(prim = []) name typ = { pval_name = name; pval_type = typ; - pval_attributes = attrs; + pval_attributes = add_docs_attrs docs attrs; pval_loc = loc; pval_prim = prim; } end module Md = struct - let mk ?(loc = !default_loc) ?(attrs = []) name typ = + let mk ?(loc = !default_loc) ?(attrs = []) + ?(docs = empty_docs) ?(text = []) name typ = { pmd_name = name; pmd_type = typ; - pmd_attributes = attrs; + pmd_attributes = + add_text_attrs text (add_docs_attrs docs attrs); pmd_loc = loc; } end module Mtd = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?typ name = + let mk ?(loc = !default_loc) ?(attrs = []) + ?(docs = empty_docs) ?(text = []) ?typ name = { pmtd_name = name; pmtd_type = typ; - pmtd_attributes = attrs; + pmtd_attributes = + add_text_attrs text (add_docs_attrs docs attrs); pmtd_loc = loc; } end module Mb = struct - let mk ?(loc = !default_loc) ?(attrs = []) name expr = + let mk ?(loc = !default_loc) ?(attrs = []) + ?(docs = empty_docs) ?(text = []) name expr = { pmb_name = name; pmb_expr = expr; - pmb_attributes = attrs; + pmb_attributes = + add_text_attrs text (add_docs_attrs docs attrs); pmb_loc = loc; } end module Opn = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(override = Fresh) lid = + let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) + ?(override = Fresh) lid = { popen_lid = lid; popen_override = override; popen_loc = loc; - popen_attributes = attrs; + popen_attributes = add_docs_attrs docs attrs; } end module Incl = struct - let mk ?(loc = !default_loc) ?(attrs = []) mexpr = + let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) mexpr = { pincl_mod = mexpr; pincl_loc = loc; - pincl_attributes = attrs; + pincl_attributes = add_docs_attrs docs attrs; } + end module Vb = struct - let mk ?(loc = !default_loc) ?(attrs = []) pat expr = + let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) + ?(text = []) pat expr = { pvb_pat = pat; pvb_expr = expr; - pvb_attributes = attrs; + pvb_attributes = + add_text_attrs text (add_docs_attrs docs 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 = []) + ?(docs = empty_docs) ?(text = []) + ?(virt = Concrete) ?(params = []) name expr = { pci_virt = virt; pci_params = params; pci_name = name; pci_expr = expr; - pci_attributes = attrs; + pci_attributes = + add_text_attrs text (add_docs_attrs docs attrs); pci_loc = loc; } end module Type = struct let mk ?(loc = !default_loc) ?(attrs = []) + ?(docs = empty_docs) ?(text = []) ?(params = []) ?(cstrs = []) ?(kind = Ptype_abstract) @@ -360,65 +397,73 @@ module Type = struct ptype_kind = kind; ptype_private = priv; ptype_manifest = manifest; - ptype_attributes = attrs; + ptype_attributes = + add_text_attrs text (add_docs_attrs docs attrs); ptype_loc = loc; } - let constructor ?(loc = !default_loc) ?(attrs = []) ?(args = Pcstr_tuple []) ?res name = + let constructor ?(loc = !default_loc) ?(attrs = []) ?(info = empty_info) + ?(args = Pcstr_tuple []) ?res name = { pcd_name = name; pcd_args = args; pcd_res = res; pcd_loc = loc; - pcd_attributes = attrs; + pcd_attributes = add_info_attrs info attrs; } - let field ?(loc = !default_loc) ?(attrs = []) ?(mut = Immutable) name typ = + let field ?(loc = !default_loc) ?(attrs = []) ?(info = empty_info) + ?(mut = Immutable) name typ = { pld_name = name; pld_mutable = mut; pld_type = typ; pld_loc = loc; - pld_attributes = attrs; + pld_attributes = add_info_attrs info attrs; } + end (** Type extensions *) module Te = struct - let mk ?(attrs = []) ?(params = []) ?(priv = Public) path constructors = + let mk ?(attrs = []) ?(docs = empty_docs) + ?(params = []) ?(priv = Public) path constructors = { ptyext_path = path; ptyext_params = params; ptyext_constructors = constructors; ptyext_private = priv; - ptyext_attributes = attrs; + ptyext_attributes = add_docs_attrs docs attrs; } - let constructor ?(loc = !default_loc) ?(attrs = []) name kind = + let constructor ?(loc = !default_loc) ?(attrs = []) + ?(docs = empty_docs) ?(info = empty_info) name kind = { pext_name = name; pext_kind = kind; pext_loc = loc; - pext_attributes = attrs; + pext_attributes = add_docs_attrs docs (add_info_attrs info attrs); } - let decl ?(loc = !default_loc) ?(attrs = []) ?(args = Pcstr_tuple []) ?res name = + let decl ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) + ?(info = empty_info) ?(args = Pcstr_tuple []) ?res name = { pext_name = name; pext_kind = Pext_decl(args, res); pext_loc = loc; - pext_attributes = attrs; + pext_attributes = add_docs_attrs docs (add_info_attrs info attrs); } - let rebind ?(loc = !default_loc) ?(attrs = []) name lid = + let rebind ?(loc = !default_loc) ?(attrs = []) + ?(docs = empty_docs) ?(info = empty_info) name lid = { pext_name = name; pext_kind = Pext_rebind lid; pext_loc = loc; - pext_attributes = attrs; + pext_attributes = add_docs_attrs docs (add_info_attrs info attrs); } -end +end module Csig = struct let mk self fields = @@ -435,3 +480,4 @@ module Cstr = struct pcstr_fields = fields; } end + diff --git a/parsing/ast_helper.mli b/parsing/ast_helper.mli index 847d428f61..2bdfd13c39 100644 --- a/parsing/ast_helper.mli +++ b/parsing/ast_helper.mli @@ -14,6 +14,7 @@ open Parsetree open Asttypes +open Docstrings type lid = Longident.t loc type str = string loc @@ -24,6 +25,7 @@ type attrs = attribute list val default_loc: loc ref (** Default value for all optional location arguments. *) + val with_default_loc: loc -> (unit -> 'a) -> 'a (** Set the [default_loc] within the scope of the execution of the provided function. *) @@ -38,7 +40,7 @@ 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 + val arrow: ?loc:loc -> ?attrs:attrs -> arg_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 @@ -93,11 +95,11 @@ module Exp: 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 + val fun_: ?loc:loc -> ?attrs:attrs -> arg_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 + -> (arg_label * expression) list -> expression val match_: ?loc:loc -> ?attrs:attrs -> expression -> case list -> expression val try_: ?loc:loc -> ?attrs:attrs -> expression -> case list -> expression @@ -146,27 +148,38 @@ module Exp: (** Value declarations *) module Val: sig - val mk: ?loc:loc -> ?attrs:attrs -> ?prim:string list -> str -> core_type -> value_description + val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> + ?prim:string list -> str -> core_type -> value_description end (** Type declarations *) module Type: sig - 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 + val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> + ?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 -> ?info:info -> + ?args:constructor_arguments -> ?res:core_type -> str -> constructor_declaration + val field: ?loc:loc -> ?attrs:attrs -> ?info:info -> + ?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 mk: ?attrs:attrs -> ?docs:docs -> + ?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 constructor: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info -> + 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 + val decl: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info -> + ?args:constructor_arguments -> ?res:core_type -> str -> extension_constructor + val rebind: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info -> + str -> lid -> extension_constructor end (** {2 Module language} *) @@ -209,7 +222,7 @@ module Sig: val mk: ?loc:loc -> signature_item_desc -> signature_item val value: ?loc:loc -> value_description -> signature_item - val type_: ?loc:loc -> type_declaration list -> signature_item + val type_: ?loc:loc -> rec_flag -> type_declaration list -> 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 @@ -221,6 +234,7 @@ module Sig: val class_type: ?loc:loc -> class_type_declaration list -> signature_item val extension: ?loc:loc -> ?attrs:attrs -> extension -> signature_item val attribute: ?loc:loc -> attribute -> signature_item + val text: text -> signature_item list end (** Structure items *) @@ -231,7 +245,7 @@ module Str: val eval: ?loc:loc -> ?attrs:attributes -> expression -> structure_item 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 type_: ?loc:loc -> rec_flag -> type_declaration list -> 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 @@ -243,43 +257,49 @@ module Str: val include_: ?loc:loc -> include_declaration -> structure_item val extension: ?loc:loc -> ?attrs:attrs -> extension -> structure_item val attribute: ?loc:loc -> attribute -> structure_item + val text: text -> structure_item list end (** Module declarations *) module Md: sig - val mk: ?loc:loc -> ?attrs:attrs -> str -> module_type -> module_declaration + val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> + str -> module_type -> module_declaration end (** Module type declarations *) module Mtd: sig - val mk: ?loc:loc -> ?attrs:attrs -> ?typ:module_type -> str -> module_type_declaration + val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> + ?typ:module_type -> str -> module_type_declaration end (** Module bindings *) module Mb: sig - val mk: ?loc:loc -> ?attrs:attrs -> str -> module_expr -> module_binding + val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> + str -> module_expr -> module_binding end (* Opens *) module Opn: sig - val mk: ?loc: loc -> ?attrs:attrs -> ?override:override_flag -> lid -> open_description + val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> + ?override:override_flag -> lid -> open_description end (* Includes *) module Incl: sig - val mk: ?loc: loc -> ?attrs:attrs -> 'a -> 'a include_infos + val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> 'a -> 'a include_infos end (** Value bindings *) module Vb: sig - val mk: ?loc: loc -> ?attrs:attrs -> pattern -> expression -> value_binding + val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> + pattern -> expression -> value_binding end @@ -293,14 +313,15 @@ module Cty: val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> class_type val signature: ?loc:loc -> ?attrs:attrs -> class_signature -> class_type - val arrow: ?loc:loc -> ?attrs:attrs -> label -> core_type -> class_type -> class_type + val arrow: ?loc:loc -> ?attrs:attrs -> arg_label -> core_type -> class_type -> class_type val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_type end (** Class type fields *) module Ctf: sig - val mk: ?loc:loc -> ?attrs:attrs -> class_type_field_desc -> class_type_field + val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> + class_type_field_desc -> class_type_field val attr: class_type_field -> attribute -> class_type_field val inherit_: ?loc:loc -> ?attrs:attrs -> class_type -> class_type_field @@ -309,6 +330,7 @@ module Ctf: 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 + val text: text -> class_type_field list end (** Class expressions *) @@ -319,9 +341,12 @@ module Cl: val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> class_expr val structure: ?loc:loc -> ?attrs:attrs -> class_structure -> class_expr - val fun_: ?loc:loc -> ?attrs:attrs -> label -> expression option -> pattern -> class_expr -> class_expr - val apply: ?loc:loc -> ?attrs:attrs -> class_expr -> (label * expression) list -> class_expr - val let_: ?loc:loc -> ?attrs:attrs -> rec_flag -> value_binding list -> class_expr -> class_expr + val fun_: ?loc:loc -> ?attrs:attrs -> arg_label -> expression option -> pattern -> + class_expr -> class_expr + val apply: + ?loc:loc -> ?attrs:attrs -> class_expr -> (arg_label * expression) list -> class_expr + val let_: + ?loc:loc -> ?attrs:attrs -> rec_flag -> value_binding list -> class_expr -> class_expr val constraint_: ?loc:loc -> ?attrs:attrs -> class_expr -> class_type -> class_expr val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_expr end @@ -329,7 +354,7 @@ module Cl: (** Class fields *) module Cf: sig - val mk: ?loc:loc -> ?attrs:attrs -> class_field_desc -> class_field + val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> class_field_desc -> class_field val attr: class_field -> attribute -> class_field val inherit_: ?loc:loc -> ?attrs:attrs -> override_flag -> class_expr -> string option -> class_field @@ -339,15 +364,19 @@ module Cf: 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 text: text -> class_field list val virtual_: core_type -> class_field_kind val concrete: override_flag -> expression -> class_field_kind + end (** Classes *) module Ci: sig - val mk: ?loc:loc -> ?attrs:attrs -> ?virt:virtual_flag -> ?params:(core_type * variance) list -> str -> 'a -> 'a class_infos + val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> + ?virt:virtual_flag -> ?params:(core_type * variance) list -> + str -> 'a -> 'a class_infos end (** Class signatures *) diff --git a/parsing/ast_mapper.ml b/parsing/ast_mapper.ml index aa9fdbfca3..945375525b 100644 --- a/parsing/ast_mapper.ml +++ b/parsing/ast_mapper.ml @@ -179,6 +179,7 @@ module CT = struct let map sub {pcty_loc = loc; pcty_desc = desc; pcty_attributes = attrs} = let open Cty in let loc = sub.location sub loc in + let attrs = sub.attributes sub attrs in match desc with | Pcty_constr (lid, tys) -> constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tys) @@ -191,6 +192,7 @@ module CT = struct = let open Ctf in let loc = sub.location sub loc in + let attrs = sub.attributes sub attrs in match desc with | Pctf_inherit ct -> inherit_ ~loc ~attrs (sub.class_type sub ct) | Pctf_val (s, m, v, t) -> val_ ~loc ~attrs s m v (sub.typ sub t) @@ -241,7 +243,7 @@ module MT = struct let loc = sub.location sub loc in 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_type (rf, l) -> type_ ~loc rf (List.map (sub.type_declaration sub) l) | 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) @@ -289,7 +291,7 @@ module M = struct eval ~loc ~attrs:(sub.attributes sub attrs) (sub.expr sub x) | 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_type (rf, l) -> type_ ~loc rf (List.map (sub.type_declaration sub) l) | 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) @@ -415,6 +417,7 @@ module CE = struct let map sub {pcl_loc = loc; pcl_desc = desc; pcl_attributes = attrs} = let open Cl in let loc = sub.location sub loc in + let attrs = sub.attributes sub attrs in match desc with | Pcl_constr (lid, tys) -> constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tys) @@ -442,6 +445,7 @@ module CE = struct let map_field sub {pcf_desc = desc; pcf_loc = loc; pcf_attributes = attrs} = let open Cf in let loc = sub.location sub loc in + let attrs = sub.attributes sub attrs in match desc with | Pcf_inherit (o, ce, s) -> inherit_ ~loc ~attrs o (sub.class_expr sub ce) s | Pcf_val (s, m, k) -> val_ ~loc ~attrs (map_loc sub s) m (map_kind sub k) @@ -793,17 +797,6 @@ let ppx_context = PpxContext.make let apply_lazy ~source ~target mapper = - let ic = open_in_bin source in - 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: 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 = @@ -844,16 +837,32 @@ let apply_lazy ~source ~target mapper = psig_loc = Location.none}] | None -> raise exn in - let ast = - if magic = Config.ast_impl_magic_number - then Obj.magic (implem (Obj.magic ast)) - else Obj.magic (iface (Obj.magic ast)) + + let ic = open_in_bin source in + let magic = + really_input_string ic (String.length Config.ast_impl_magic_number) in - let oc = open_out_bin target in - output_string oc magic; - output_value oc !Location.input_name; - output_value oc ast; - close_out oc + + let rewrite transform = + Location.input_name := input_value ic; + let ast = input_value ic in + close_in ic; + let ast = transform ast in + let oc = open_out_bin target in + output_string oc magic; + output_value oc !Location.input_name; + output_value oc ast; + close_out oc + and fail () = + close_in ic; + failwith "Ast_mapper: OCaml version mismatch or malformed input"; + in + + if magic = Config.ast_impl_magic_number then + rewrite (implem : structure -> structure) + else if magic = Config.ast_intf_magic_number then + rewrite (iface : signature -> signature) + else fail () let drop_ppx_context_str ~restore = function | {pstr_desc = Pstr_attribute({Location.txt = "ocaml.ppx.context"}, a)} diff --git a/parsing/asttypes.mli b/parsing/asttypes.mli index b212a2b9a7..a0d6361623 100644 --- a/parsing/asttypes.mli +++ b/parsing/asttypes.mli @@ -37,6 +37,11 @@ type closed_flag = Closed | Open type label = string +type arg_label = + Nolabel + | Labelled of string (* label:T -> ... *) + | Optional of string (* ?label:T -> ... *) + type 'a loc = 'a Location.loc = { txt : 'a; loc : Location.t; diff --git a/parsing/docstrings.ml b/parsing/docstrings.ml new file mode 100644 index 0000000000..389f6cf75c --- /dev/null +++ b/parsing/docstrings.ml @@ -0,0 +1,344 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Leo White *) +(* *) +(* Copyright 1996 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. *) +(* *) +(***********************************************************************) + +open Location + +(* Docstrings *) + +(* A docstring is "attached" if it has been inserted in the AST. This + is used for generating unexpected docstring warnings. *) +type ds_attached = + | Unattached (* Not yet attached anything.*) + | Info (* Attached to a field or constructor. *) + | Docs (* Attached to an item or as floating text. *) + +(* A docstring is "associated" with an item if there are no blank lines between + them. This is used for generating docstring ambiguity warnings. *) +type ds_associated = + | Zero (* Not associated with an item *) + | One (* Associated with one item *) + | Many (* Associated with multiple items (ambiguity) *) + +type docstring = + { ds_body: string; + ds_loc: Location.t; + mutable ds_attached: ds_attached; + mutable ds_associated: ds_associated; } + +(* List of docstrings *) + +let docstrings : docstring list ref = ref [] + +(* Warn for unused and ambiguous docstrings *) + +let warn_bad_docstrings () = + if Warnings.is_active (Warnings.Bad_docstring true) then begin + List.iter + (fun ds -> + match ds.ds_attached with + | Info -> () + | Unattached -> + prerr_warning ds.ds_loc (Warnings.Bad_docstring true) + | Docs -> + match ds.ds_associated with + | Zero | One -> () + | Many -> + prerr_warning ds.ds_loc (Warnings.Bad_docstring false)) + (List.rev !docstrings) +end + +(* Docstring constructors and descturctors *) + +let docstring body loc = + let ds = + { ds_body = body; + ds_loc = loc; + ds_attached = Unattached; + ds_associated = Zero; } + in + docstrings := ds :: !docstrings; + ds + +let docstring_body ds = ds.ds_body + +let docstring_loc ds = ds.ds_loc + +(* Docstrings attached to items *) + +type docs = + { docs_pre: docstring option; + docs_post: docstring option; } + +let empty_docs = { docs_pre = None; docs_post = None } + +let doc_loc = {txt = "ocaml.doc"; loc = Location.none} + +let docs_attr ds = + let open Asttypes in + let open Parsetree in + let exp = + { pexp_desc = Pexp_constant (Const_string(ds.ds_body, None)); + pexp_loc = ds.ds_loc; + pexp_attributes = []; } + in + let item = + { pstr_desc = Pstr_eval (exp, []); pstr_loc = exp.pexp_loc } + in + (doc_loc, PStr [item]) + +let add_docs_attrs docs attrs = + let attrs = + match docs.docs_pre with + | None -> attrs + | Some ds -> docs_attr ds :: attrs + in + let attrs = + match docs.docs_post with + | None -> attrs + | Some ds -> attrs @ [docs_attr ds] + in + attrs + +(* Docstrings attached to consturctors or fields *) + +type info = docstring option + +let empty_info = None + +let info_attr = docs_attr + +let add_info_attrs info attrs = + let attrs = + match info with + | None -> attrs + | Some ds -> attrs @ [info_attr ds] + in + attrs + +(* Docstrings not attached to a specifc item *) + +type text = docstring list + +let empty_text = [] + +let text_loc = {txt = "ocaml.text"; loc = Location.none} + +let text_attr ds = + let open Asttypes in + let open Parsetree in + let exp = + { pexp_desc = Pexp_constant (Const_string(ds.ds_body, None)); + pexp_loc = ds.ds_loc; + pexp_attributes = []; } + in + let item = + { pstr_desc = Pstr_eval (exp, []); pstr_loc = exp.pexp_loc } + in + (text_loc, PStr [item]) + +let add_text_attrs dsl attrs = + (List.map text_attr dsl) @ attrs + +(* Find the first non-info docstring in a list, attach it and return it *) +let get_docstring ~info dsl = + let rec loop = function + | [] -> None + | {ds_attached = Info; _} :: rest -> loop rest + | ds :: rest -> + ds.ds_attached <- if info then Info else Docs; + Some ds + in + loop dsl + +(* Find all the non-info docstrings in a list, attach them and return them *) +let get_docstrings dsl = + let rec loop acc = function + | [] -> List.rev acc + | {ds_attached = Info; _} :: rest -> loop acc rest + | ds :: rest -> + ds.ds_attached <- Docs; + loop (ds :: acc) rest + in + loop [] dsl + +(* "Associate" all the docstrings in a list *) +let associate_docstrings dsl = + List.iter + (fun ds -> + match ds.ds_associated with + | Zero -> ds.ds_associated <- One + | (One | Many) -> ds.ds_associated <- Many) + dsl + +(* Map from positions to pre docstrings *) + +let pre_table : (Lexing.position, docstring list) Hashtbl.t = + Hashtbl.create 50 + +let set_pre_docstrings pos dsl = + if dsl <> [] then Hashtbl.add pre_table pos dsl + +let get_pre_docs pos = + try + let dsl = Hashtbl.find pre_table pos in + associate_docstrings dsl; + get_docstring ~info:false dsl + with Not_found -> None + +let mark_pre_docs pos = + try + let dsl = Hashtbl.find pre_table pos in + associate_docstrings dsl + with Not_found -> () + +(* Map from positions to post docstrings *) + +let post_table : (Lexing.position, docstring list) Hashtbl.t = + Hashtbl.create 50 + +let set_post_docstrings pos dsl = + if dsl <> [] then Hashtbl.add post_table pos dsl + +let get_post_docs pos = + try + let dsl = Hashtbl.find post_table pos in + associate_docstrings dsl; + get_docstring ~info:false dsl + with Not_found -> None + +let mark_post_docs pos = + try + let dsl = Hashtbl.find post_table pos in + associate_docstrings dsl + with Not_found -> () + +let get_info pos = + try + let dsl = Hashtbl.find post_table pos in + get_docstring ~info:true dsl + with Not_found -> None + +(* Map from positions to floating docstrings *) + +let floating_table : (Lexing.position, docstring list) Hashtbl.t = + Hashtbl.create 50 + +let set_floating_docstrings pos dsl = + if dsl <> [] then Hashtbl.add floating_table pos dsl + +let get_text pos = + try + let dsl = Hashtbl.find floating_table pos in + get_docstrings dsl + with Not_found -> [] + +(* Maps from positions to extra docstrings *) + +let pre_extra_table : (Lexing.position, docstring list) Hashtbl.t = + Hashtbl.create 50 + +let set_pre_extra_docstrings pos dsl = + if dsl <> [] then Hashtbl.add pre_extra_table pos dsl + +let get_pre_extra_text pos = + try + let dsl = Hashtbl.find pre_extra_table pos in + get_docstrings dsl + with Not_found -> [] + +let post_extra_table : (Lexing.position, docstring list) Hashtbl.t = + Hashtbl.create 50 + +let set_post_extra_docstrings pos dsl = + if dsl <> [] then Hashtbl.add post_extra_table pos dsl + +let get_post_extra_text pos = + try + let dsl = Hashtbl.find post_extra_table pos in + get_docstrings dsl + with Not_found -> [] + +(* Docstrings from parser actions *) + +let symbol_docs () = + { docs_pre = get_pre_docs (Parsing.symbol_start_pos ()); + docs_post = get_post_docs (Parsing.symbol_end_pos ()); } + +let symbol_docs_lazy () = + let p1 = Parsing.symbol_start_pos () in + let p2 = Parsing.symbol_end_pos () in + lazy { docs_pre = get_pre_docs p1; + docs_post = get_post_docs p2; } + +let rhs_docs pos1 pos2 = + { docs_pre = get_pre_docs (Parsing.rhs_start_pos pos1); + docs_post = get_post_docs (Parsing.rhs_end_pos pos2); } + +let rhs_docs_lazy pos1 pos2 = + let p1 = Parsing.rhs_start_pos pos1 in + let p2 = Parsing.rhs_end_pos pos2 in + lazy { docs_pre = get_pre_docs p1; + docs_post = get_post_docs p2; } + +let mark_symbol_docs () = + mark_pre_docs (Parsing.symbol_start_pos ()); + mark_post_docs (Parsing.symbol_end_pos ()) + +let mark_rhs_docs pos1 pos2 = + mark_pre_docs (Parsing.rhs_start_pos pos1); + mark_post_docs (Parsing.rhs_end_pos pos2) + +let symbol_info () = + get_info (Parsing.symbol_end_pos ()) + +let rhs_info pos = + get_info (Parsing.rhs_end_pos pos) + +let symbol_text () = + get_text (Parsing.symbol_start_pos ()) + +let symbol_text_lazy () = + let pos = Parsing.symbol_start_pos () in + lazy (get_text pos) + +let rhs_text pos = + get_text (Parsing.rhs_start_pos pos) + +let rhs_text_lazy pos = + let pos = Parsing.rhs_start_pos pos in + lazy (get_text pos) + +let symbol_pre_extra_text () = + get_pre_extra_text (Parsing.symbol_start_pos ()) + +let symbol_post_extra_text () = + get_post_extra_text (Parsing.symbol_end_pos ()) + +let rhs_pre_extra_text pos = + get_pre_extra_text (Parsing.rhs_start_pos pos) + +let rhs_post_extra_text pos = + get_post_extra_text (Parsing.rhs_end_pos pos) + + +(* (Re)Initialise all comment state *) + +let init () = + docstrings := []; + Hashtbl.reset pre_table; + Hashtbl.reset post_table; + Hashtbl.reset floating_table; + Hashtbl.reset pre_extra_table; + Hashtbl.reset post_extra_table + + + diff --git a/parsing/docstrings.mli b/parsing/docstrings.mli new file mode 100644 index 0000000000..e873785012 --- /dev/null +++ b/parsing/docstrings.mli @@ -0,0 +1,148 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Leo White *) +(* *) +(* Copyright 1996 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. *) +(* *) +(***********************************************************************) + +(** (Re)Initialise all docstring state *) +val init : unit -> unit + +(** Emit warnings for unattached and ambiguous docstrings *) +val warn_bad_docstrings : unit -> unit + +(** {3 Docstrings} *) + +(** Documentation comments *) +type docstring + +(** Create a docstring *) +val docstring : string -> Location.t -> docstring + +(** Get the text of a docstring *) +val docstring_body : docstring -> string + +(** Get the location of a docstring *) +val docstring_loc : docstring -> Location.t + +(** {3 Set functions} + + These functions are used by the lexer to associate docstrings to + the locations of tokens. *) + +(** Docstrings immediately preceding a token *) +val set_pre_docstrings : Lexing.position -> docstring list -> unit + +(** Docstrings immediately following a token *) +val set_post_docstrings : Lexing.position -> docstring list -> unit + +(** Docstrings not immediately adjacent to a token *) +val set_floating_docstrings : Lexing.position -> docstring list -> unit + +(** Docstrings immediately following the token which precedes this one *) +val set_pre_extra_docstrings : Lexing.position -> docstring list -> unit + +(** Docstrings immediately preceding the token which follows this one *) +val set_post_extra_docstrings : Lexing.position -> docstring list -> unit + +(** {3 Items} + + The {!docs} type represents documentation attached to an item. *) + +type docs = + { docs_pre: docstring option; + docs_post: docstring option; } + +val empty_docs : docs + +val docs_attr : docstring -> Parsetree.attribute + +(** Convert item documentation to attributes and add them to an + attribute list *) +val add_docs_attrs : docs -> Parsetree.attributes -> Parsetree.attributes + +(** Fetch the item documentation for the current symbol. This also + marks this documentation (for ambiguity warnings). *) +val symbol_docs : unit -> docs +val symbol_docs_lazy : unit -> docs Lazy.t + +(** Fetch the item documentation for the symbols between two + positions. This also marks this documentation (for ambiguity + warnings). *) +val rhs_docs : int -> int -> docs +val rhs_docs_lazy : int -> int -> docs Lazy.t + +(** Mark the item documentation for the current symbol (for ambiguity + warnings). *) +val mark_symbol_docs : unit -> unit + +(** Mark as associated the item documentation for the symbols between + two positions (for ambiguity warnings) *) +val mark_rhs_docs : int -> int -> unit + +(** {3 Fields and constructors} + + The {!info} type represents documentation attached to a field or + constructor. *) + +type info = docstring option + +val empty_info : info + +val info_attr : docstring -> Parsetree.attribute + +(** Convert field info to attributes and add them to an + attribute list *) +val add_info_attrs : info -> Parsetree.attributes -> Parsetree.attributes + +(** Fetch the field info for the current symbol. *) +val symbol_info : unit -> info + +(** Fetch the field info following the symbol at a given position. *) +val rhs_info : int -> info + +(** {3 Unattached comments} + + The {!text} type represents documentation which is not attached to + anything. *) + +type text = docstring list + +val empty_text : text + +val text_attr : docstring -> Parsetree.attribute + +(** Convert text to attributes and add them to an attribute list *) +val add_text_attrs : text -> Parsetree.attributes -> Parsetree.attributes + +(** Fetch the text preceding the current symbol. *) +val symbol_text : unit -> text +val symbol_text_lazy : unit -> text Lazy.t + +(** Fetch the text preceding the symbol at the given position. *) +val rhs_text : int -> text +val rhs_text_lazy : int -> text Lazy.t + +(** {3 Extra text} + + There may be additional text attached to the delimiters of a block + (e.g. [struct] and [end]). This is fetched by the following + functions, which are applied to the contents of the block rather + than the delimiters. *) + +(** Fetch additional text preceding the current symbol *) +val symbol_pre_extra_text : unit -> text + +(** Fetch additional text following the current symbol *) +val symbol_post_extra_text : unit -> text + +(** Fetch additional text preceding the symbol at the given position *) +val rhs_pre_extra_text : int -> text + +(** Fetch additional text following the symbol at the given position *) +val rhs_post_extra_text : int -> text diff --git a/parsing/lexer.mli b/parsing/lexer.mli index 9898e97198..2cad4f7f79 100644 --- a/parsing/lexer.mli +++ b/parsing/lexer.mli @@ -24,6 +24,7 @@ type error = | Unterminated_string_in_comment of Location.t * Location.t | Keyword_as_label of string | Literal_overflow of string + | Invalid_literal of string ;; exception Error of error * Location.t @@ -49,10 +50,7 @@ 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. +changes its behavior to accept backslash-newline as a token-separating blank. *) val set_preprocessor : diff --git a/parsing/lexer.mll b/parsing/lexer.mll index 237b44764c..e77f0847e6 100644 --- a/parsing/lexer.mll +++ b/parsing/lexer.mll @@ -25,6 +25,7 @@ type error = | Unterminated_string_in_comment of Location.t * Location.t | Keyword_as_label of string | Literal_overflow of string + | Invalid_literal of string ;; exception Error of error * Location.t;; @@ -63,6 +64,7 @@ let keyword_table = "module", MODULE; "mutable", MUTABLE; "new", NEW; + "nonrec", NONREC; "object", OBJECT; "of", OF; "open", OPEN; @@ -132,6 +134,16 @@ let is_in_string = ref false let in_string () = !is_in_string let print_warnings = ref true +let with_comment_buffer comment lexbuf = + let start_loc = Location.curr lexbuf in + comment_start_loc := [start_loc]; + reset_string_buffer (); + let end_loc = comment lexbuf in + let s = get_stored_string () in + reset_string_buffer (); + let loc = { start_loc with Location.loc_end = end_loc.Location.loc_end } in + s, loc + (* To translate escape sequences *) let char_for_backslash = function @@ -218,6 +230,8 @@ let update_loc lexbuf file line absolute chars = let preprocessor = ref None +let escaped_newlines = ref false + (* Warn about Latin-1 characters used in idents *) let warn_latin1 lexbuf = @@ -225,6 +239,17 @@ let warn_latin1 lexbuf = (Warnings.Deprecated "ISO-Latin1 characters in identifiers") ;; +let comment_list = ref [] + +let add_comment com = + comment_list := com :: !comment_list + +let add_docstring_comment ds = + let com = (Docstrings.docstring_body ds, Docstrings.docstring_loc ds) in + add_comment com + +let comments () = List.rev !comment_list + (* Error report *) open Format @@ -247,6 +272,8 @@ let report_error ppf = function | Literal_overflow ty -> fprintf ppf "Integer literal exceeds the range of representable \ integers of type %s" ty + | Invalid_literal s -> + fprintf ppf "Invalid literal %s" s let () = Location.register_error_of_exn @@ -287,19 +314,14 @@ let float_literal = rule token = parse | "\\" newline { - match !preprocessor with - | None -> + if not !escaped_newlines then raise (Error(Illegal_character (Lexing.lexeme_char lexbuf 0), - Location.curr lexbuf)) - | Some _ -> - update_loc lexbuf None 1 false 0; - token lexbuf } + Location.curr lexbuf)); + update_loc lexbuf None 1 false 0; + token lexbuf } | newline { update_loc lexbuf None 1 false 0; - match !preprocessor with - | None -> token lexbuf - | Some _ -> EOL - } + EOL } | blank + { token lexbuf } | "_" @@ -349,6 +371,8 @@ rule token = parse NATIVEINT (cvt_nativeint_literal (Lexing.lexeme lexbuf)) with Failure _ -> raise (Error(Literal_overflow "nativeint", Location.curr lexbuf)) } + | (float_literal | int_literal) identchar+ + { raise (Error(Invalid_literal (Lexing.lexeme lexbuf), Location.curr lexbuf)) } | "\"" { reset_string_buffer(); is_in_string := true; @@ -386,26 +410,27 @@ rule token = parse raise (Error(Illegal_escape esc, Location.curr lexbuf)) } | "(*" - { let start_loc = Location.curr lexbuf in - comment_start_loc := [start_loc]; - reset_string_buffer (); - let end_loc = comment lexbuf in - let s = get_stored_string () in - reset_string_buffer (); - COMMENT (s, { start_loc with - Location.loc_end = end_loc.Location.loc_end }) - } + { let s, loc = with_comment_buffer comment lexbuf in + COMMENT (s, loc) } + | "(**" + { let s, loc = with_comment_buffer comment lexbuf in + DOCSTRING (Docstrings.docstring s loc) } + | "(**" ('*'+) as stars + { let s, loc = + with_comment_buffer + (fun lexbuf -> + store_string ("*" ^ stars); + comment lexbuf) + lexbuf + in + COMMENT (s, loc) } | "(*)" - { let loc = Location.curr lexbuf in - if !print_warnings then - Location.prerr_warning loc Warnings.Comment_start; - comment_start_loc := [loc]; - reset_string_buffer (); - let end_loc = comment lexbuf in - let s = get_stored_string () in - reset_string_buffer (); - COMMENT (s, { loc with Location.loc_end = end_loc.Location.loc_end }) - } + { if !print_warnings then + Location.prerr_warning (Location.curr lexbuf) Warnings.Comment_start; + let s, loc = with_comment_buffer comment lexbuf in + COMMENT (s, loc) } + | "(*" ('*'*) as stars "*)" + { COMMENT (stars, Location.curr lexbuf) } | "*)" { let loc = Location.curr lexbuf in Location.prerr_warning loc Warnings.Comment_not_end; @@ -483,6 +508,8 @@ rule token = parse | '%' { PERCENT } | ['*' '/' '%'] symbolchar * { INFIXOP3(Lexing.lexeme lexbuf) } + | '#' (symbolchar | '#') + + { SHARPOP(Lexing.lexeme lexbuf) } | eof { EOF } | _ { raise (Error(Illegal_character (Lexing.lexeme_char lexbuf 0), @@ -654,24 +681,98 @@ and skip_sharp_bang = parse | None -> token lexbuf | Some (_init, preprocess) -> preprocess token lexbuf - let last_comments = ref [] - let rec token lexbuf = - match token_with_comments lexbuf with - COMMENT (s, comment_loc) -> - last_comments := (s, comment_loc) :: !last_comments; - token lexbuf - | tok -> tok - let comments () = List.rev !last_comments + type newline_state = + | NoLine (* There have been no blank lines yet. *) + | NewLine + (* There have been no blank lines, and the previous + token was a newline. *) + | BlankLine (* There have been blank lines. *) + + type doc_state = + | Initial (* There have been no docstrings yet *) + | After of docstring list + (* There have been docstrings, none of which were + preceeded by a blank line *) + | Before of docstring list * docstring list * docstring list + (* There have been docstrings, some of which were + preceeded by a blank line *) + + and docstring = Docstrings.docstring + + let token lexbuf = + let post_pos = lexeme_end_p lexbuf in + let attach lines docs pre_pos = + let open Docstrings in + match docs, lines with + | Initial, _ -> () + | After a, (NoLine | NewLine) -> + set_post_docstrings post_pos (List.rev a); + set_pre_docstrings pre_pos a; + | After a, BlankLine -> + set_post_docstrings post_pos (List.rev a); + set_pre_extra_docstrings pre_pos (List.rev a) + | Before(a, f, b), (NoLine | NewLine) -> + set_post_docstrings post_pos (List.rev a); + set_post_extra_docstrings post_pos + (List.rev_append f (List.rev b)); + set_floating_docstrings pre_pos (List.rev f); + set_pre_extra_docstrings pre_pos (List.rev a); + set_pre_docstrings pre_pos b + | Before(a, f, b), BlankLine -> + set_post_docstrings post_pos (List.rev a); + set_post_extra_docstrings post_pos + (List.rev_append f (List.rev b)); + set_floating_docstrings pre_pos + (List.rev_append f (List.rev b)); + set_pre_extra_docstrings pre_pos (List.rev a) + in + let rec loop lines docs lexbuf = + match token_with_comments lexbuf with + | COMMENT (s, loc) -> + add_comment (s, loc); + let lines' = + match lines with + | NoLine -> NoLine + | NewLine -> NoLine + | BlankLine -> BlankLine + in + loop lines' docs lexbuf + | EOL -> + let lines' = + match lines with + | NoLine -> NewLine + | NewLine -> BlankLine + | BlankLine -> BlankLine + in + loop lines' docs lexbuf + | DOCSTRING doc -> + add_docstring_comment doc; + let docs' = + match docs, lines with + | Initial, (NoLine | NewLine) -> After [doc] + | Initial, BlankLine -> Before([], [], [doc]) + | After a, (NoLine | NewLine) -> After (doc :: a) + | After a, BlankLine -> Before (a, [], [doc]) + | Before(a, f, b), (NoLine | NewLine) -> Before(a, f, doc :: b) + | Before(a, f, b), BlankLine -> Before(a, b @ f, [doc]) + in + loop NoLine docs' lexbuf + | tok -> + attach lines docs (lexeme_start_p lexbuf); + tok + in + loop NoLine Initial lexbuf let init () = is_in_string := false; - last_comments := []; comment_start_loc := []; + comment_list := []; match !preprocessor with | None -> () | Some (init, _preprocess) -> init () let set_preprocessor init preprocess = + escaped_newlines := true; preprocessor := Some (init, preprocess) } diff --git a/parsing/location.ml b/parsing/location.ml index 174377eecb..a4910bdc2f 100644 --- a/parsing/location.ml +++ b/parsing/location.ml @@ -72,6 +72,22 @@ let status = ref Terminfo.Uninitialised let num_loc_lines = ref 0 (* number of lines already printed after input *) +let print_updating_num_loc_lines ppf f arg = + let open Format in + let out_functions = pp_get_formatter_out_functions ppf () in + let out_string str start len = + let rec count i c = + if i = start + len then c + else if String.get str i = '\n' then count (succ i) (succ c) + else count (succ i) c in + num_loc_lines := !num_loc_lines + count start 0 ; + out_functions.out_string str start len in + pp_set_formatter_out_functions ppf + { out_functions with out_string } ; + f ppf arg ; + pp_print_flush ppf (); + pp_set_formatter_out_functions ppf out_functions + (* Highlight the locations using standout mode. *) let highlight_terminfo ppf num_lines lb locs = @@ -261,20 +277,21 @@ let print_error ppf loc = let print_error_cur_file ppf = print_error ppf (in_file !input_name);; -let print_warning loc ppf w = +let default_warning_printer loc ppf w = if Warnings.is_active w then begin - let printw ppf w = - let n = Warnings.print ppf w in - num_loc_lines := !num_loc_lines + n - in print ppf loc; - fprintf ppf "Warning %a@." printw w; - pp_print_flush ppf (); - incr num_loc_lines; + fprintf ppf "Warning %a@." Warnings.print w end ;; -let prerr_warning loc w = print_warning loc err_formatter w;; +let warning_printer = ref default_warning_printer ;; + +let print_warning loc ppf w = + print_updating_num_loc_lines ppf (!warning_printer loc) w +;; + +let formatter_for_warnings = ref err_formatter;; +let prerr_warning loc w = print_warning loc !formatter_for_warnings w;; let echo_eof () = print_newline (); @@ -317,7 +334,7 @@ let error_of_exn exn = in loop !error_of_exn -let rec report_error ppf ({loc; msg; sub; if_highlight} as err) = +let rec default_error_reporter ppf ({loc; msg; sub; if_highlight} as err) = let highlighted = if if_highlight <> "" then let rec collect_locs locs {loc; sub; if_highlight; _} = @@ -333,10 +350,16 @@ 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) + List.iter (fun err -> Format.fprintf ppf "@\n@[<2>%a@]" default_error_reporter err) sub end +let error_reporter = ref default_error_reporter + +let report_error ppf err = + print_updating_num_loc_lines ppf !error_reporter err +;; + let error_of_printer loc print x = let buf = Buffer.create 64 in let ppf = Format.formatter_of_buffer buf in diff --git a/parsing/location.mli b/parsing/location.mli index 1a7feeb4da..77b754f731 100644 --- a/parsing/location.mli +++ b/parsing/location.mli @@ -29,11 +29,14 @@ type t = { val none : t (** An arbitrary value of type [t]; describes an empty ghost range. *) -val in_file : string -> t;; + +val in_file : string -> t (** Return an empty ghost range located in a given file. *) + val init : Lexing.lexbuf -> string -> unit (** Set the file name and line number of the [lexbuf] to be the start of the named file. *) + val curr : Lexing.lexbuf -> t (** Get the location of the current token from the [lexbuf]. *) @@ -52,10 +55,17 @@ val print_loc: formatter -> t -> unit val print_error: formatter -> t -> unit val print_error_cur_file: formatter -> unit val print_warning: t -> formatter -> Warnings.t -> unit +val formatter_for_warnings : formatter ref val prerr_warning: t -> Warnings.t -> unit val echo_eof: unit -> unit val reset: unit -> unit +val warning_printer : (t -> formatter -> Warnings.t -> unit) ref +(** Hook for intercepting warnings. *) + +val default_warning_printer : t -> formatter -> Warnings.t -> unit +(** Original warning printer for use in hooks. *) + val highlight_locations: formatter -> t list -> bool type 'a loc = { @@ -115,5 +125,11 @@ val register_error_of_exn: (exn -> error option) -> unit val report_error: formatter -> error -> unit +val error_reporter : (formatter -> error -> unit) ref +(** Hook for intercepting error reports. *) + +val default_error_reporter : formatter -> error -> unit +(** Original error reporter for use in hooks. *) + val report_exception: formatter -> exn -> unit (* Reraise the exception if it is unknown. *) diff --git a/parsing/parse.ml b/parsing/parse.ml index 2f4926ff88..0941bf803b 100644 --- a/parsing/parse.ml +++ b/parsing/parse.ml @@ -34,9 +34,11 @@ let maybe_skip_phrase lexbuf = let wrap parsing_fun lexbuf = try + Docstrings.init (); Lexer.init (); let ast = parsing_fun Lexer.token lexbuf in Parsing.clear_parser(); + Docstrings.warn_bad_docstrings (); ast with | Lexer.Error(Lexer.Illegal_character _, _) as err diff --git a/parsing/parser.mly b/parsing/parser.mly index 7366fd747f..458d75195c 100644 --- a/parsing/parser.mly +++ b/parsing/parser.mly @@ -18,6 +18,7 @@ open Asttypes open Longident open Parsetree open Ast_helper +open Docstrings let mktyp d = Typ.mk ~loc:(symbol_rloc()) d let mkpat d = Pat.mk ~loc:(symbol_rloc()) d @@ -28,13 +29,12 @@ let mkmod d = Mod.mk ~loc:(symbol_rloc()) d let mkstr d = Str.mk ~loc:(symbol_rloc()) d let mkclass d = Cl.mk ~loc:(symbol_rloc()) d let mkcty d = Cty.mk ~loc:(symbol_rloc()) d -let mkctf d = Ctf.mk ~loc:(symbol_rloc()) d -let mkcf d = Cf.mk ~loc:(symbol_rloc()) d +let mkctf ?attrs ?docs d = + Ctf.mk ~loc:(symbol_rloc()) ?attrs ?docs d +let mkcf ?attrs ?docs d = + Cf.mk ~loc:(symbol_rloc()) ?attrs ?docs d let mkrhs rhs pos = mkloc rhs (rhs_loc pos) -let mkoption d = - let loc = {d.ptyp_loc with loc_ghost = true} in - Typ.mk ~loc (Ptyp_constr(mkloc (Ldot (Lident "*predef*", "option")) loc,[d])) let reloc_pat x = { x with ppat_loc = symbol_rloc () };; let reloc_exp x = { x with pexp_loc = symbol_rloc () };; @@ -73,7 +73,7 @@ let ghunit () = ghexp (Pexp_construct (mknoloc (Lident "()"), None)) let mkinfix arg1 name arg2 = - mkexp(Pexp_apply(mkoperator name 2, ["", arg1; "", arg2])) + mkexp(Pexp_apply(mkoperator name 2, [Nolabel, arg1; Nolabel, arg2])) let neg_float_string f = if String.length f > 0 && f.[0] = '-' @@ -93,7 +93,7 @@ let mkuminus name arg = | ("-" | "-."), Pexp_constant(Const_float f) -> mkexp(Pexp_constant(Const_float(neg_float_string f))) | _ -> - mkexp(Pexp_apply(mkoperator ("~" ^ name) 1, ["", arg])) + mkexp(Pexp_apply(mkoperator ("~" ^ name) 1, [Nolabel, arg])) let mkuplus name arg = let desc = arg.pexp_desc in @@ -104,7 +104,7 @@ let mkuplus name arg = | "+", Pexp_constant(Const_nativeint _) | ("+" | "+."), Pexp_constant(Const_float _) -> mkexp desc | _ -> - mkexp(Pexp_apply(mkoperator ("~" ^ name) 1, ["", arg])) + mkexp(Pexp_apply(mkoperator ("~" ^ name) 1, [Nolabel, arg])) let mkexp_cons consloc args loc = Exp.mk ~loc (Pexp_construct(mkloc (Lident "::") consloc, Some args)) @@ -149,8 +149,9 @@ let mkexp_constraint e (t1, t2) = | _, Some t -> ghexp(Pexp_coerce(e, t1, t)) | None, None -> assert false -let array_function str name = - ghloc (Ldot(Lident str, (if !Clflags.fast then "unsafe_" ^ name else name))) +let array_function par assign= + let op = if assign then par^"<-" else par in + ghloc ( Lident op ) let syntax_error () = raise Syntaxerr.Escape_error @@ -165,46 +166,54 @@ let expecting pos nonterm = let not_expecting pos nonterm = raise Syntaxerr.(Error(Not_expecting(rhs_loc pos, nonterm))) -let bigarray_function str name = - ghloc (Ldot(Ldot(Lident "Bigarray", str), name)) +let bigarray_function order assign = + let op = + match order with + | 1 -> ".{}" + | 2 -> ".{,}" + | 3 -> ".{,,}" + | _ -> ".{,..,}" + in + let op= if assign then op^"<-" else op in + ghloc ( Lident op ) let bigarray_untuplify = function { pexp_desc = Pexp_tuple explist; pexp_loc = _ } -> explist | exp -> [exp] let bigarray_get arr arg = - let get = if !Clflags.fast then "unsafe_get" else "get" in + let get order = bigarray_function order false in match bigarray_untuplify arg with [c1] -> - mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array1" get)), - ["", arr; "", c1])) + mkexp(Pexp_apply(ghexp(Pexp_ident(get 1)), + [Nolabel, arr; Nolabel, c1])) | [c1;c2] -> - mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array2" get)), - ["", arr; "", c1; "", c2])) + mkexp(Pexp_apply(ghexp(Pexp_ident(get 2)), + [Nolabel, arr; Nolabel, c1; Nolabel, c2])) | [c1;c2;c3] -> - mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array3" get)), - ["", arr; "", c1; "", c2; "", c3])) + mkexp(Pexp_apply(ghexp(Pexp_ident(get 3)), + [Nolabel, arr; Nolabel, c1; Nolabel, c2; Nolabel, c3])) | coords -> - mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Genarray" "get")), - ["", arr; "", ghexp(Pexp_array coords)])) + mkexp(Pexp_apply(ghexp(Pexp_ident(get 0)), + [Nolabel, arr; Nolabel, ghexp(Pexp_array coords)])) let bigarray_set arr arg newval = - let set = if !Clflags.fast then "unsafe_set" else "set" in + let set order = bigarray_function order true in match bigarray_untuplify arg with [c1] -> - mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array1" set)), - ["", arr; "", c1; "", newval])) + mkexp(Pexp_apply(ghexp(Pexp_ident(set 1)), + [Nolabel, arr; Nolabel, c1; Nolabel, newval])) | [c1;c2] -> - mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array2" set)), - ["", arr; "", c1; "", c2; "", newval])) + mkexp(Pexp_apply(ghexp(Pexp_ident(set 2)), + [Nolabel, arr; Nolabel, c1; Nolabel, c2; Nolabel, newval])) | [c1;c2;c3] -> - mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array3" set)), - ["", arr; "", c1; "", c2; "", c3; "", newval])) + mkexp(Pexp_apply(ghexp(Pexp_ident(set 3)), + [Nolabel, arr; Nolabel, c1; Nolabel, c2; Nolabel, c3; Nolabel, newval])) | coords -> - mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Genarray" "set")), - ["", arr; - "", ghexp(Pexp_array coords); - "", newval])) + mkexp(Pexp_apply(ghexp(Pexp_ident(set 0)), + [Nolabel, arr; + Nolabel, ghexp(Pexp_array coords); + Nolabel, newval])) let lapply p1 p2 = if !Clflags.applicative_functors @@ -265,12 +274,13 @@ let varify_constructors var_names t = in loop t +let mk_newtypes newtypes exp = + List.fold_right (fun newtype exp -> mkexp (Pexp_newtype (newtype, exp))) + newtypes exp + let wrap_type_annotation newtypes core_type body = let exp = mkexp(Pexp_constraint(body,core_type)) in - let exp = - List.fold_right (fun newtype exp -> mkexp (Pexp_newtype (newtype, exp))) - newtypes exp - in + let exp = mk_newtypes newtypes exp in (exp, ghtyp(Ptyp_poly(newtypes,varify_constructors newtypes core_type))) let wrap_exp_attrs body (ext, attrs) = @@ -283,11 +293,108 @@ 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 +let text_str pos = Str.text (rhs_text pos) +let text_sig pos = Sig.text (rhs_text pos) +let text_cstr pos = Cf.text (rhs_text pos) +let text_csig pos = Ctf.text (rhs_text pos) +let text_def pos = [Ptop_def (Str.text (rhs_text pos))] + +let extra_text text pos items = + let pre_extras = rhs_pre_extra_text pos in + let post_extras = rhs_post_extra_text pos in + text pre_extras @ items @ text post_extras + +let extra_str pos items = extra_text Str.text pos items +let extra_sig pos items = extra_text Sig.text pos items +let extra_cstr pos items = extra_text Cf.text pos items +let extra_csig pos items = extra_text Ctf.text pos items +let extra_def pos items = + extra_text (fun txt -> [Ptop_def (Str.text txt)]) pos items + +type let_binding = + { lb_pattern: pattern; + lb_expression: expression; + lb_attributes: attributes; + lb_docs: docs Lazy.t; + lb_text: text Lazy.t; + lb_loc: Location.t; } + +type let_bindings = + { lbs_bindings: let_binding list; + lbs_rec: rec_flag; + lbs_extension: string Asttypes.loc option; + lbs_attributes: attributes; + lbs_loc: Location.t } + +let mklb (p, e) attrs = + { lb_pattern = p; + lb_expression = e; + lb_attributes = attrs; + lb_docs = symbol_docs_lazy (); + lb_text = symbol_text_lazy (); + lb_loc = symbol_rloc (); } + +let mklbs (ext, attrs) rf lb = + { lbs_bindings = [lb]; + lbs_rec = rf; + lbs_extension = ext ; + lbs_attributes = attrs; + lbs_loc = symbol_rloc (); } + +let addlb lbs lb = + { lbs with lbs_bindings = lb :: lbs.lbs_bindings } + +let val_of_let_bindings lbs = + let str = + match lbs.lbs_bindings with + | [ {lb_pattern = { ppat_desc = Ppat_any; ppat_loc = _ }; _} as lb ] -> + let exp = wrap_exp_attrs lb.lb_expression + (None, lbs.lbs_attributes) in + mkstr (Pstr_eval (exp, lb.lb_attributes)) + | bindings -> + if lbs.lbs_attributes <> [] then + raise Syntaxerr.(Error(Not_expecting(lbs.lbs_loc, "attributes"))); + let bindings = + List.map + (fun lb -> + Vb.mk ~loc:lb.lb_loc ~attrs:lb.lb_attributes + ~docs:(Lazy.force lb.lb_docs) + ~text:(Lazy.force lb.lb_text) + lb.lb_pattern lb.lb_expression) + bindings + in + mkstr(Pstr_value(lbs.lbs_rec, List.rev bindings)) + in + match lbs.lbs_extension with + | None -> str + | Some id -> ghstr (Pstr_extension((id, PStr [str]), [])) + +let expr_of_let_bindings lbs body = + let bindings = + List.map + (fun lb -> + if lb.lb_attributes <> [] then + raise Syntaxerr.(Error(Not_expecting(lb.lb_loc, "item attribute"))); + Vb.mk ~loc:lb.lb_loc lb.lb_pattern lb.lb_expression) + lbs.lbs_bindings + in + mkexp_attrs (Pexp_let(lbs.lbs_rec, List.rev bindings, body)) + (lbs.lbs_extension, lbs.lbs_attributes) + +let class_of_let_bindings lbs body = + let bindings = + List.map + (fun lb -> + if lb.lb_attributes <> [] then + raise Syntaxerr.(Error(Not_expecting(lb.lb_loc, "item attribute"))); + Vb.mk ~loc:lb.lb_loc lb.lb_pattern lb.lb_expression) + lbs.lbs_bindings + in + if lbs.lbs_extension <> None then + raise Syntaxerr.(Error(Not_expecting(lbs.lbs_loc, "extension"))); + if lbs.lbs_attributes <> [] then + raise Syntaxerr.(Error(Not_expecting(lbs.lbs_loc, "attributes"))); + mkclass(Pcl_let (lbs.lbs_rec, List.rev bindings, body)) %} @@ -372,6 +479,7 @@ let mkctf_attrs d attrs = %token MUTABLE %token <nativeint> NATIVEINT %token NEW +%token NONREC %token OBJECT %token OF %token OPEN @@ -393,6 +501,7 @@ let mkctf_attrs d attrs = %token SEMI %token SEMISEMI %token SHARP +%token <string> SHARPOP %token SIG %token STAR %token <string * string option> STRING @@ -411,6 +520,7 @@ let mkctf_attrs d attrs = %token WHILE %token WITH %token <string * Location.t> COMMENT +%token <Docstrings.docstring> DOCSTRING %token EOL @@ -470,6 +580,7 @@ The precedences must be listed from low to high. %nonassoc prec_constr_appl /* above AS BAR COLONCOLON COMMA */ %nonassoc below_SHARP %nonassoc SHARP /* simple_expr/toplevel_directive */ +%left SHARPOP %nonassoc below_DOT %nonassoc DOT /* Finally, the first tokens of simple_expr are above everything else. */ @@ -500,38 +611,52 @@ The precedences must be listed from low to high. /* Entry points */ implementation: - structure EOF { $1 } + structure EOF { extra_str 1 $1 } ; interface: - signature EOF { $1 } + signature EOF { extra_sig 1 $1 } ; toplevel_phrase: - top_structure SEMISEMI { Ptop_def $1 } + top_structure SEMISEMI { Ptop_def (extra_str 1 $1) } | toplevel_directive SEMISEMI { $1 } | EOF { raise End_of_file } ; top_structure: - seq_expr post_item_attributes { [mkstrexp $1 $2] } - | top_structure_tail { $1 } + seq_expr post_item_attributes + { (text_str 1) @ [mkstrexp $1 $2] } + | top_structure_tail + { $1 } ; top_structure_tail: /* empty */ { [] } - | structure_item top_structure_tail { $1 :: $2 } + | structure_item top_structure_tail { (text_str 1) @ $1 :: $2 } ; use_file: + use_file_body { extra_def 1 $1 } +; +use_file_body: use_file_tail { $1 } | seq_expr post_item_attributes use_file_tail - { Ptop_def[mkstrexp $1 $2] :: $3 } + { (text_def 1) @ Ptop_def[mkstrexp $1 $2] :: $3 } ; use_file_tail: - EOF { [] } - | SEMISEMI EOF { [] } + EOF + { [] } + | SEMISEMI EOF + { text_def 1 } | SEMISEMI seq_expr post_item_attributes use_file_tail - { Ptop_def[mkstrexp $2 $3] :: $4 } - | SEMISEMI structure_item use_file_tail { Ptop_def[$2] :: $3 } - | SEMISEMI toplevel_directive use_file_tail { $2 :: $3 } - | structure_item use_file_tail { Ptop_def[$1] :: $2 } - | toplevel_directive use_file_tail { $1 :: $2 } + { mark_rhs_docs 2 3; + (text_def 1) @ (text_def 2) @ Ptop_def[mkstrexp $2 $3] :: $4 } + | SEMISEMI structure_item use_file_tail + { (text_def 1) @ (text_def 2) @ Ptop_def[$2] :: $3 } + | SEMISEMI toplevel_directive use_file_tail + { mark_rhs_docs 2 3; + (text_def 1) @ (text_def 2) @ $2 :: $3 } + | structure_item use_file_tail + { (text_def 1) @ Ptop_def[$1] :: $2 } + | toplevel_directive use_file_tail + { mark_rhs_docs 1 1; + (text_def 1) @ $1 :: $2 } ; parse_core_type: core_type EOF { $1 } @@ -568,7 +693,7 @@ module_expr: mod_longident { mkmod(Pmod_ident (mkrhs $1 1)) } | STRUCT structure END - { mkmod(Pmod_structure($2)) } + { mkmod(Pmod_structure(extra_str 2 $2)) } | STRUCT structure error { unclosed "struct" 1 "end" 3 } | FUNCTOR functor_args MINUSGREATER module_expr @@ -613,62 +738,52 @@ module_expr: ; structure: - seq_expr post_item_attributes structure_tail { mkstrexp $1 $2 :: $3 } + seq_expr post_item_attributes structure_tail + { mark_rhs_docs 1 2; + (text_str 1) @ mkstrexp $1 $2 :: $3 } | structure_tail { $1 } ; structure_tail: /* empty */ { [] } - | SEMISEMI structure { $2 } - | structure_item structure_tail { $1 :: $2 } + | SEMISEMI structure { (text_str 1) @ $2 } + | structure_item structure_tail { (text_str 1) @ $1 :: $2 } ; structure_item: - LET ext_attributes rec_flag let_bindings - { - match $4 with - [ {pvb_pat = { ppat_desc = Ppat_any; ppat_loc = _ }; - pvb_expr = exp; pvb_attributes = attrs}] -> - let exp = wrap_exp_attrs exp $2 in - mkstr(Pstr_eval (exp, attrs)) - | l -> - 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 - { mkstr - (Pstr_primitive (Val.mk (mkrhs $2 2) $4 - ~prim:$6 ~attrs:$7 ~loc:(symbol_rloc ()))) } - | TYPE type_declarations - { mkstr(Pstr_type (List.rev $2) ) } - | TYPE str_type_extension - { mkstr(Pstr_typext $2) } - | EXCEPTION str_exception_declaration - { mkstr(Pstr_exception $2) } - | MODULE module_binding - { mkstr(Pstr_module $2) } - | MODULE REC module_bindings - { mkstr(Pstr_recmodule(List.rev $3)) } - | MODULE TYPE ident post_item_attributes - { mkstr(Pstr_modtype (Mtd.mk (mkrhs $3 3) - ~attrs:$4 ~loc:(symbol_rloc()))) } - | MODULE TYPE ident EQUAL module_type post_item_attributes - { mkstr(Pstr_modtype (Mtd.mk (mkrhs $3 3) - ~typ:$5 ~attrs:$6 ~loc:(symbol_rloc()))) } + let_bindings + { val_of_let_bindings $1 } + | primitive_declaration + { mkstr (Pstr_primitive $1) } + | value_description + { mkstr (Pstr_primitive $1) } + | type_declarations + { let (nr, l) = $1 in mkstr(Pstr_type (nr, List.rev l)) } + | str_type_extension + { mkstr(Pstr_typext $1) } + | str_exception_declaration + { mkstr(Pstr_exception $1) } + | module_binding + { mkstr(Pstr_module $1) } + | rec_module_bindings + { mkstr(Pstr_recmodule(List.rev $1)) } + | module_type_declaration + { mkstr(Pstr_modtype $1) } | 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 (Incl.mk $2 ~attrs:$3 ~loc:(symbol_rloc()))) } + | class_declarations + { mkstr(Pstr_class (List.rev $1)) } + | class_type_declarations + { mkstr(Pstr_class_type (List.rev $1)) } + | str_include_statement + { mkstr(Pstr_include $1) } | item_extension post_item_attributes - { mkstr(Pstr_extension ($1, $2)) } + { mkstr(Pstr_extension ($1, (add_docs_attrs (symbol_docs ()) $2))) } | floating_attribute - { mkstr(Pstr_attribute $1) } + { mark_symbol_docs (); + mkstr(Pstr_attribute $1) } +; +str_include_statement: + INCLUDE module_expr post_item_attributes + { Incl.mk $2 ~attrs:$3 + ~loc:(symbol_rloc()) ~docs:(symbol_docs ()) } ; module_binding_body: EQUAL module_expr @@ -678,13 +793,24 @@ module_binding_body: | functor_arg module_binding_body { mkmod(Pmod_functor(fst $1, snd $1, $2)) } ; -module_bindings: - module_binding { [$1] } - | module_bindings AND module_binding { $3 :: $1 } -; module_binding: - UIDENT module_binding_body post_item_attributes - { Mb.mk (mkrhs $1 1) $2 ~attrs:$3 ~loc:(symbol_rloc ()) } + MODULE UIDENT module_binding_body post_item_attributes + { Mb.mk (mkrhs $2 2) $3 ~attrs:$4 + ~loc:(symbol_rloc ()) ~docs:(symbol_docs ()) } +; +rec_module_bindings: + rec_module_binding { [$1] } + | rec_module_bindings and_module_binding { $2 :: $1 } +; +rec_module_binding: + MODULE REC UIDENT module_binding_body post_item_attributes + { Mb.mk (mkrhs $3 3) $4 ~attrs:$5 + ~loc:(symbol_rloc ()) ~docs:(symbol_docs ()) } +; +and_module_binding: + AND UIDENT module_binding_body post_item_attributes + { Mb.mk (mkrhs $2 2) $3 ~attrs:$4 ~loc:(symbol_rloc ()) + ~text:(symbol_text ()) ~docs:(symbol_docs ()) } ; /* Module types */ @@ -693,7 +819,7 @@ module_type: mty_longident { mkmty(Pmty_ident (mkrhs $1 1)) } | SIG signature END - { mkmty(Pmty_signature $2) } + { mkmty(Pmty_signature (extra_sig 2 $2)) } | SIG signature error { unclosed "sig" 1 "end" 3 } | FUNCTOR functor_args MINUSGREATER module_type @@ -717,90 +843,112 @@ module_type: ; signature: /* empty */ { [] } - | SEMISEMI signature { $2 } - | signature_item signature { $1 :: $2 } + | SEMISEMI signature { (text_sig 1) @ $2 } + | signature_item signature { (text_sig 1) @ $1 :: $2 } ; signature_item: - VAL val_ident COLON core_type post_item_attributes - { mksig(Psig_value - (Val.mk (mkrhs $2 2) $4 ~attrs:$5 ~loc:(symbol_rloc()))) } - | EXTERNAL val_ident COLON core_type EQUAL primitive_declaration - post_item_attributes - { mksig(Psig_value - (Val.mk (mkrhs $2 2) $4 ~prim:$6 ~attrs:$7 - ~loc:(symbol_rloc()))) } - | TYPE type_declarations - { mksig(Psig_type (List.rev $2)) } - | 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) - $3 ~attrs:$4 ~loc:(symbol_rloc()))) } - | MODULE UIDENT EQUAL mod_longident post_item_attributes - { mksig(Psig_module (Md.mk (mkrhs $2 2) - (Mty.alias ~loc:(rhs_loc 4) (mkrhs $4 4)) - ~attrs:$5 - ~loc:(symbol_rloc()) - )) } - | MODULE REC module_rec_declarations - { mksig(Psig_recmodule (List.rev $3)) } - | MODULE TYPE ident post_item_attributes - { mksig(Psig_modtype (Mtd.mk (mkrhs $3 3) - ~attrs:$4 ~loc:(symbol_rloc()))) } - | MODULE TYPE ident EQUAL module_type post_item_attributes - { mksig(Psig_modtype (Mtd.mk (mkrhs $3 3) ~typ:$5 - ~loc:(symbol_rloc()) - ~attrs:$6)) } + value_description + { mksig(Psig_value $1) } + | primitive_declaration + { mksig(Psig_value $1) } + | type_declarations + { let (nr, l) = $1 in mksig(Psig_type (nr, List.rev l)) } + | sig_type_extension + { mksig(Psig_typext $1) } + | sig_exception_declaration + { mksig(Psig_exception $1) } + | module_declaration + { mksig(Psig_module $1) } + | module_alias + { mksig(Psig_module $1) } + | rec_module_declarations + { mksig(Psig_recmodule (List.rev $1)) } + | module_type_declaration + { mksig(Psig_modtype $1) } | open_statement { mksig(Psig_open $1) } - | INCLUDE module_type post_item_attributes %prec below_WITH - { 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)) } + | sig_include_statement + { mksig(Psig_include $1) } + | class_descriptions + { mksig(Psig_class (List.rev $1)) } + | class_type_declarations + { mksig(Psig_class_type (List.rev $1)) } | item_extension post_item_attributes - { mksig(Psig_extension ($1, $2)) } + { mksig(Psig_extension ($1, (add_docs_attrs (symbol_docs ()) $2))) } | floating_attribute - { mksig(Psig_attribute $1) } + { mark_symbol_docs (); + 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()) } + { Opn.mk (mkrhs $3 3) ~override:$2 ~attrs:$4 + ~loc:(symbol_rloc()) ~docs:(symbol_docs ()) } ; -module_declaration: +sig_include_statement: + INCLUDE module_type post_item_attributes %prec below_WITH + { Incl.mk $2 ~attrs:$3 + ~loc:(symbol_rloc()) ~docs:(symbol_docs ()) } +; +module_declaration_body: COLON module_type { $2 } - | LPAREN UIDENT COLON module_type RPAREN module_declaration + | LPAREN UIDENT COLON module_type RPAREN module_declaration_body { mkmty(Pmty_functor(mkrhs $2 2, Some $4, $6)) } - | LPAREN RPAREN module_declaration + | LPAREN RPAREN module_declaration_body { mkmty(Pmty_functor(mkrhs "*" 1, None, $3)) } ; -module_rec_declarations: - module_rec_declaration { [$1] } - | module_rec_declarations AND module_rec_declaration { $3 :: $1 } -; -module_rec_declaration: - UIDENT COLON module_type post_item_attributes - { Md.mk (mkrhs $1 1) $3 ~attrs:$4 ~loc:(symbol_rloc()) } +module_declaration: + MODULE UIDENT module_declaration_body post_item_attributes + { Md.mk (mkrhs $2 2) $3 ~attrs:$4 + ~loc:(symbol_rloc()) ~docs:(symbol_docs ()) } +; +module_alias: + MODULE UIDENT EQUAL mod_longident post_item_attributes + { Md.mk (mkrhs $2 2) + (Mty.alias ~loc:(rhs_loc 4) (mkrhs $4 4)) ~attrs:$5 + ~loc:(symbol_rloc()) ~docs:(symbol_docs ()) } +; +rec_module_declarations: + rec_module_declaration { [$1] } + | rec_module_declarations and_module_declaration { $2 :: $1 } +; +rec_module_declaration: + MODULE REC UIDENT COLON module_type post_item_attributes + { Md.mk (mkrhs $3 3) $5 ~attrs:$6 + ~loc:(symbol_rloc()) ~docs:(symbol_docs ()) } +; +and_module_declaration: + AND UIDENT COLON module_type post_item_attributes + { Md.mk (mkrhs $2 2) $4 ~attrs:$5 ~loc:(symbol_rloc()) + ~text:(symbol_text()) ~docs:(symbol_docs()) } +; +module_type_declaration_body: + /* empty */ { None } + | EQUAL module_type { Some $2 } +; +module_type_declaration: + MODULE TYPE ident module_type_declaration_body post_item_attributes + { Mtd.mk (mkrhs $3 3) ?typ:$4 ~attrs:$5 + ~loc:(symbol_rloc()) ~docs:(symbol_docs ()) } ; - /* Class expressions */ class_declarations: - class_declarations AND class_declaration { $3 :: $1 } - | class_declaration { [$1] } + class_declaration { [$1] } + | class_declarations and_class_declaration { $2 :: $1 } ; class_declaration: - virtual_flag class_type_parameters LIDENT class_fun_binding + CLASS virtual_flag class_type_parameters LIDENT class_fun_binding post_item_attributes - { - Ci.mk (mkrhs $3 3) $4 - ~virt:$1 ~params:$2 - ~attrs:$5 ~loc:(symbol_rloc ()) - } + { Ci.mk (mkrhs $4 4) $5 ~virt:$2 ~params:$3 ~attrs:$6 + ~loc:(symbol_rloc ()) ~docs:(symbol_docs ()) } +; +and_class_declaration: + AND virtual_flag class_type_parameters LIDENT class_fun_binding + post_item_attributes + { Ci.mk (mkrhs $4 4) $5 ~virt:$2 ~params:$3 + ~attrs:$6 ~loc:(symbol_rloc ()) + ~text:(symbol_text ()) ~docs:(symbol_docs ()) } ; class_fun_binding: EQUAL class_expr @@ -827,8 +975,8 @@ class_expr: { $2 } | class_simple_expr simple_labeled_expr_list { mkclass(Pcl_apply($1, List.rev $2)) } - | LET rec_flag let_bindings_no_attrs IN class_expr - { mkclass(Pcl_let ($2, List.rev $3, $5)) } + | let_bindings IN class_expr + { class_of_let_bindings $1 $3 } | class_expr attribute { Cl.attr $1 $2 } | extension @@ -840,7 +988,7 @@ class_simple_expr: | class_longident { mkclass(Pcl_constr(mkrhs $1 1, [])) } | OBJECT class_structure END - { mkclass(Pcl_structure($2)) } + { mkclass(Pcl_structure $2) } | OBJECT class_structure error { unclosed "object" 1 "end" 3 } | LPAREN class_expr COLON class_type RPAREN @@ -853,8 +1001,8 @@ class_simple_expr: { unclosed "(" 1 ")" 3 } ; class_structure: - class_self_pattern class_fields - { Cstr.mk $1 (List.rev $2) } + | class_self_pattern class_fields + { Cstr.mk $1 (extra_cstr 2 (List.rev $2)) } ; class_self_pattern: LPAREN pattern RPAREN @@ -868,23 +1016,24 @@ class_fields: /* empty */ { [] } | class_fields class_field - { $2 :: $1 } + { $2 :: (text_cstr 2) @ $1 } ; class_field: | INHERIT override_flag class_expr parent_binder post_item_attributes - { mkcf_attrs (Pcf_inherit ($2, $3, $4)) $5 } + { mkcf (Pcf_inherit ($2, $3, $4)) ~attrs:$5 ~docs:(symbol_docs ()) } | VAL value post_item_attributes - { mkcf_attrs (Pcf_val $2) $3 } + { mkcf (Pcf_val $2) ~attrs:$3 ~docs:(symbol_docs ()) } | METHOD method_ post_item_attributes - { mkcf_attrs (Pcf_method $2) $3 } + { mkcf (Pcf_method $2) ~attrs:$3 ~docs:(symbol_docs ()) } | CONSTRAINT constrain_field post_item_attributes - { mkcf_attrs (Pcf_constraint $2) $3 } + { mkcf (Pcf_constraint $2) ~attrs:$3 ~docs:(symbol_docs ()) } | INITIALIZER seq_expr post_item_attributes - { mkcf_attrs (Pcf_initializer $2) $3 } + { mkcf (Pcf_initializer $2) ~attrs:$3 ~docs:(symbol_docs ()) } | item_extension post_item_attributes - { mkcf_attrs (Pcf_extension $1) $2 } + { mkcf (Pcf_extension $1) ~attrs:$2 ~docs:(symbol_docs ()) } | floating_attribute - { mkcf (Pcf_attribute $1) } + { mark_symbol_docs (); + mkcf (Pcf_attribute $1) } ; parent_binder: AS LIDENT @@ -933,15 +1082,15 @@ method_: class_type: class_signature { $1 } - | QUESTION LIDENT COLON simple_core_type_or_tuple_no_attr MINUSGREATER + | QUESTION LIDENT COLON simple_core_type_or_tuple 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)) } - | LIDENT COLON simple_core_type_or_tuple_no_attr MINUSGREATER class_type - { mkcty(Pcty_arrow($1, $3, $5)) } - | simple_core_type_or_tuple_no_attr MINUSGREATER class_type - { mkcty(Pcty_arrow("", $1, $3)) } + { mkcty(Pcty_arrow(Optional $2 , $4, $6)) } + | OPTLABEL simple_core_type_or_tuple MINUSGREATER class_type + { mkcty(Pcty_arrow(Optional $1, $2, $4)) } + | LIDENT COLON simple_core_type_or_tuple MINUSGREATER class_type + { mkcty(Pcty_arrow(Labelled $1, $3, $5)) } + | simple_core_type_or_tuple MINUSGREATER class_type + { mkcty(Pcty_arrow(Nolabel, $1, $3)) } ; class_signature: LBRACKET core_type_comma_list RBRACKET clty_longident @@ -959,7 +1108,7 @@ class_signature: ; class_sig_body: class_self_type class_sig_fields - { Csig.mk $1 (List.rev $2) } + { Csig.mk $1 (extra_csig 2 (List.rev $2)) } ; class_self_type: LPAREN core_type RPAREN @@ -969,24 +1118,25 @@ class_self_type: ; class_sig_fields: /* empty */ { [] } -| class_sig_fields class_sig_field { $2 :: $1 } +| class_sig_fields class_sig_field { $2 :: (text_csig 2) @ $1 } ; class_sig_field: INHERIT class_signature post_item_attributes - { mkctf_attrs (Pctf_inherit $2) $3 } + { mkctf (Pctf_inherit $2) ~attrs:$3 ~docs:(symbol_docs ()) } | VAL value_type post_item_attributes - { mkctf_attrs (Pctf_val $2) $3 } + { mkctf (Pctf_val $2) ~attrs:$3 ~docs:(symbol_docs ()) } | METHOD private_virtual_flags label COLON poly_type post_item_attributes { let (p, v) = $2 in - mkctf_attrs (Pctf_method ($3, p, v, $5)) $6 + mkctf (Pctf_method ($3, p, v, $5)) ~attrs:$6 ~docs:(symbol_docs ()) } | CONSTRAINT constrain_field post_item_attributes - { mkctf_attrs (Pctf_constraint $2) $3 } + { mkctf (Pctf_constraint $2) ~attrs:$3 ~docs:(symbol_docs ()) } | item_extension post_item_attributes - { mkctf_attrs (Pctf_extension $1) $2 } + { mkctf (Pctf_extension $1) ~attrs:$2 ~docs:(symbol_docs ()) } | floating_attribute - { mkctf(Pctf_attribute $1) } + { mark_symbol_docs (); + mkctf(Pctf_attribute $1) } ; value_type: VIRTUAL mutable_flag label COLON core_type @@ -1003,30 +1153,38 @@ constrain_field: core_type EQUAL core_type { $1, $3 } ; class_descriptions: - class_descriptions AND class_description { $3 :: $1 } - | class_description { [$1] } + class_description { [$1] } + | class_descriptions and_class_description { $2 :: $1 } ; class_description: - virtual_flag class_type_parameters LIDENT COLON class_type + CLASS virtual_flag class_type_parameters LIDENT COLON class_type post_item_attributes - { - Ci.mk (mkrhs $3 3) $5 - ~virt:$1 ~params:$2 - ~attrs:$6 ~loc:(symbol_rloc ()) - } + { Ci.mk (mkrhs $4 4) $6 ~virt:$2 ~params:$3 ~attrs:$7 + ~loc:(symbol_rloc ()) ~docs:(symbol_docs ()) } +; +and_class_description: + AND virtual_flag class_type_parameters LIDENT COLON class_type + post_item_attributes + { Ci.mk (mkrhs $4 4) $6 ~virt:$2 ~params:$3 + ~attrs:$7 ~loc:(symbol_rloc ()) + ~text:(symbol_text ()) ~docs:(symbol_docs ()) } ; class_type_declarations: - class_type_declarations AND class_type_declaration { $3 :: $1 } - | class_type_declaration { [$1] } + class_type_declaration { [$1] } + | class_type_declarations and_class_type_declaration { $2 :: $1 } ; class_type_declaration: - virtual_flag class_type_parameters LIDENT EQUAL class_signature - post_item_attributes - { - Ci.mk (mkrhs $3 3) $5 - ~virt:$1 ~params:$2 - ~attrs:$6 ~loc:(symbol_rloc ()) - } + CLASS TYPE virtual_flag class_type_parameters LIDENT EQUAL + class_signature post_item_attributes + { Ci.mk (mkrhs $5 5) $7 ~virt:$3 ~params:$4 ~attrs:$8 + ~loc:(symbol_rloc ()) ~docs:(symbol_docs ()) } +; +and_class_type_declaration: + AND virtual_flag class_type_parameters LIDENT EQUAL + class_signature post_item_attributes + { Ci.mk (mkrhs $4 4) $6 ~virt:$2 ~params:$3 + ~attrs:$7 ~loc:(symbol_rloc ()) + ~text:(symbol_text ()) ~docs:(symbol_docs ()) } ; /* Core expressions */ @@ -1038,21 +1196,21 @@ seq_expr: ; labeled_simple_pattern: QUESTION LPAREN label_let_pattern opt_default RPAREN - { ("?" ^ fst $3, $4, snd $3) } + { (Optional (fst $3), $4, snd $3) } | QUESTION label_var - { ("?" ^ fst $2, None, snd $2) } + { (Optional (fst $2), None, snd $2) } | OPTLABEL LPAREN let_pattern opt_default RPAREN - { ("?" ^ $1, $4, $3) } + { (Optional $1, $4, $3) } | OPTLABEL pattern_var - { ("?" ^ $1, None, $2) } + { (Optional $1, None, $2) } | TILDE LPAREN label_let_pattern RPAREN - { (fst $3, None, snd $3) } + { (Labelled (fst $3), None, snd $3) } | TILDE label_var - { (fst $2, None, snd $2) } + { (Labelled (fst $2), None, snd $2) } | LABEL simple_pattern - { ($1, None, $2) } + { (Labelled $1, None, $2) } | simple_pattern - { ("", None, $1) } + { (Nolabel, None, $1) } ; pattern_var: LIDENT { mkpat(Ppat_var (mkrhs $1 1)) } @@ -1082,8 +1240,8 @@ expr: { $1 } | simple_expr simple_labeled_expr_list { mkexp(Pexp_apply($1, List.rev $2)) } - | LET ext_attributes rec_flag let_bindings_no_attrs IN seq_expr - { mkexp_attrs (Pexp_let($3, List.rev $4, $6)) $2 } + | let_bindings IN seq_expr + { expr_of_let_bindings $1 $3 } | LET MODULE ext_attributes UIDENT module_binding_body IN seq_expr { mkexp_attrs (Pexp_letmodule(mkrhs $4 4, $5, $7)) $3 } | LET OPEN override_flag ext_attributes mod_longident IN seq_expr @@ -1093,8 +1251,8 @@ expr: | FUN ext_attributes labeled_simple_pattern fun_def { let (l,o,p) = $3 in mkexp_attrs (Pexp_fun(l, o, p, $4)) $2 } - | FUN ext_attributes LPAREN TYPE LIDENT RPAREN fun_def - { mkexp_attrs (Pexp_newtype($5, $7)) $2 } + | FUN ext_attributes LPAREN TYPE lident_list RPAREN fun_def + { mkexp_attrs (mk_newtypes $5 $7).pexp_desc $2 } | MATCH ext_attributes seq_expr WITH opt_bar match_cases { mkexp_attrs (Pexp_match($3, List.rev $6)) $2 } | TRY ext_attributes seq_expr WITH opt_bar match_cases @@ -1167,11 +1325,11 @@ expr: | simple_expr DOT label_longident LESSMINUS expr { mkexp(Pexp_setfield($1, mkrhs $3 3, $5)) } | simple_expr DOT LPAREN seq_expr RPAREN LESSMINUS expr - { mkexp(Pexp_apply(ghexp(Pexp_ident(array_function "Array" "set")), - ["",$1; "",$4; "",$7])) } + { mkexp(Pexp_apply(ghexp(Pexp_ident(array_function ".()" true)), + [Nolabel,$1; Nolabel,$4; Nolabel,$7])) } | simple_expr DOT LBRACKET seq_expr RBRACKET LESSMINUS expr - { mkexp(Pexp_apply(ghexp(Pexp_ident(array_function "String" "set")), - ["",$1; "",$4; "",$7])) } + { mkexp(Pexp_apply(ghexp(Pexp_ident(array_function ".[]" true)), + [Nolabel,$1; Nolabel,$4; Nolabel,$7])) } | simple_expr DOT LBRACE expr RBRACE LESSMINUS expr { bigarray_set $1 $4 $7 } | label LESSMINUS expr @@ -1213,16 +1371,19 @@ simple_expr: { mkexp(Pexp_field($1, mkrhs $3 3)) } | mod_longident DOT LPAREN seq_expr RPAREN { mkexp(Pexp_open(Fresh, mkrhs $1 1, $4)) } + | mod_longident DOT LPAREN RPAREN + { mkexp(Pexp_open(Fresh, mkrhs $1 1, + mkexp(Pexp_construct(mkrhs (Lident "()") 1, None)))) } | mod_longident DOT LPAREN seq_expr error { unclosed "(" 3 ")" 5 } | simple_expr DOT LPAREN seq_expr RPAREN - { mkexp(Pexp_apply(ghexp(Pexp_ident(array_function "Array" "get")), - ["",$1; "",$4])) } + { mkexp(Pexp_apply(ghexp(Pexp_ident(array_function ".()" false)), + [Nolabel,$1; Nolabel,$4])) } | simple_expr DOT LPAREN seq_expr error { unclosed "(" 3 ")" 5 } | simple_expr DOT LBRACKET seq_expr RBRACKET - { mkexp(Pexp_apply(ghexp(Pexp_ident(array_function "String" "get")), - ["",$1; "",$4])) } + { mkexp(Pexp_apply(ghexp(Pexp_ident(array_function ".[]" false)), + [Nolabel,$1; Nolabel,$4])) } | simple_expr DOT LBRACKET seq_expr error { unclosed "[" 3 "]" 5 } | simple_expr DOT LBRACE expr RBRACE @@ -1247,6 +1408,8 @@ simple_expr: { mkexp (Pexp_array []) } | mod_longident DOT LBRACKETBAR expr_semi_list opt_semi BARRBRACKET { mkexp(Pexp_open(Fresh, mkrhs $1 1, mkexp(Pexp_array(List.rev $4)))) } + | mod_longident DOT LBRACKETBAR BARRBRACKET + { mkexp(Pexp_open(Fresh, mkrhs $1 1, mkexp(Pexp_array []))) } | mod_longident DOT LBRACKETBAR expr_semi_list opt_semi error { unclosed "[|" 3 "|]" 6 } | LBRACKET expr_semi_list opt_semi RBRACKET @@ -1256,26 +1419,33 @@ simple_expr: | mod_longident DOT LBRACKET expr_semi_list opt_semi RBRACKET { let list_exp = reloc_exp (mktailexp (rhs_loc 6) (List.rev $4)) in mkexp(Pexp_open(Fresh, mkrhs $1 1, list_exp)) } + | mod_longident DOT LBRACKET RBRACKET + { mkexp(Pexp_open(Fresh, mkrhs $1 1, + mkexp(Pexp_construct(mkrhs (Lident "[]") 1, None)))) } | mod_longident DOT LBRACKET expr_semi_list opt_semi error { unclosed "[" 3 "]" 6 } | PREFIXOP simple_expr - { mkexp(Pexp_apply(mkoperator $1 1, ["",$2])) } + { mkexp(Pexp_apply(mkoperator $1 1, [Nolabel,$2])) } | BANG simple_expr - { mkexp(Pexp_apply(mkoperator "!" 1, ["",$2])) } + { mkexp(Pexp_apply(mkoperator "!" 1, [Nolabel,$2])) } | NEW ext_attributes class_longident { mkexp_attrs (Pexp_new(mkrhs $3 3)) $2 } - | LBRACELESS field_expr_list opt_semi GREATERRBRACE - { mkexp (Pexp_override(List.rev $2)) } - | LBRACELESS field_expr_list opt_semi error + | LBRACELESS field_expr_list GREATERRBRACE + { mkexp (Pexp_override $2) } + | LBRACELESS field_expr_list error { unclosed "{<" 1 ">}" 4 } | 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))))} - | mod_longident DOT LBRACELESS field_expr_list opt_semi error + | mod_longident DOT LBRACELESS field_expr_list GREATERRBRACE + { mkexp(Pexp_open(Fresh, mkrhs $1 1, mkexp (Pexp_override $4)))} + | mod_longident DOT LBRACELESS GREATERRBRACE + { mkexp(Pexp_open(Fresh, mkrhs $1 1, mkexp (Pexp_override [])))} + | mod_longident DOT LBRACELESS field_expr_list error { unclosed "{<" 3 ">}" 6 } | simple_expr SHARP label { mkexp(Pexp_send($1, $3)) } + | simple_expr SHARPOP simple_expr + { mkinfix $1 $2 $3 } | LPAREN MODULE module_expr RPAREN { mkexp (Pexp_pack $3) } | LPAREN MODULE module_expr COLON package_type RPAREN @@ -1300,49 +1470,28 @@ simple_labeled_expr_list: ; labeled_simple_expr: simple_expr %prec below_SHARP - { ("", $1) } + { (Nolabel, $1) } | label_expr { $1 } ; label_expr: LABEL simple_expr %prec below_SHARP - { ($1, $2) } + { (Labelled $1, $2) } | TILDE label_ident - { $2 } + { (Labelled (fst $2), snd $2) } | QUESTION label_ident - { ("?" ^ fst $2, snd $2) } + { (Optional (fst $2), snd $2) } | OPTLABEL simple_expr %prec below_SHARP - { ("?" ^ $1, $2) } + { (Optional $1, $2) } ; label_ident: LIDENT { ($1, mkexp(Pexp_ident(mkrhs (Lident $1) 1))) } ; -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 ~loc:(symbol_rloc()) ~attrs:$2 p e - } -; -let_binding_: +let_binding_body: val_ident fun_binding { (mkpatvar $1 1, $2) } | val_ident COLON typevar_list DOT core_type EQUAL seq_expr @@ -1357,6 +1506,18 @@ let_binding_: | simple_pattern_not_ident COLON core_type EQUAL seq_expr { (ghpat(Ppat_constraint($1, $3)), $5) } ; +let_bindings: + let_binding { $1 } + | let_bindings and_let_binding { addlb $1 $2 } +; +let_binding: + LET ext_attributes rec_flag let_binding_body post_item_attributes + { mklbs $2 $3 (mklb $4 $5) } +; +and_let_binding: + AND let_binding_body post_item_attributes + { mklb $2 $3 } +; fun_binding: strict_binding { $1 } @@ -1368,8 +1529,8 @@ strict_binding: { $2 } | labeled_simple_pattern fun_binding { let (l, o, p) = $1 in ghexp(Pexp_fun(l, o, p, $2)) } - | LPAREN TYPE LIDENT RPAREN fun_binding - { mkexp(Pexp_newtype($3, $5)) } + | LPAREN TYPE lident_list RPAREN fun_binding + { mk_newtypes $3 $5 } ; match_cases: match_case { [$1] } @@ -1389,8 +1550,8 @@ fun_def: let (l,o,p) = $1 in ghexp(Pexp_fun(l, o, p, $2)) } - | LPAREN TYPE LIDENT RPAREN fun_def - { mkexp(Pexp_newtype($3, $5)) } + | LPAREN TYPE lident_list RPAREN fun_def + { mk_newtypes $3 $5 } ; expr_comma_list: expr_comma_list COMMA expr { $3 :: $1 } @@ -1412,10 +1573,14 @@ lbl_expr: { (mkrhs $1 1, exp_of_label $1 1) } ; field_expr_list: + field_expr opt_semi { [$1] } + | field_expr SEMI field_expr_list { $1 :: $3 } +; +field_expr: label EQUAL expr - { [mkrhs $1 1,$3] } - | field_expr_list SEMI label EQUAL expr - { (mkrhs $3 3, $5) :: $1 } + { (mkrhs $1 1, $3) } + | label + { (mkrhs $1 1, exp_of_label (Lident $1) 1) } ; expr_semi_list: expr { [$1] } @@ -1539,27 +1704,54 @@ lbl_pattern: { (mkrhs $1 1, pat_of_label $1 1) } ; +/* Value descriptions */ + +value_description: + VAL val_ident COLON core_type post_item_attributes + { Val.mk (mkrhs $2 2) $4 ~attrs:$5 + ~loc:(symbol_rloc()) ~docs:(symbol_docs ()) } +; + /* Primitive declarations */ -primitive_declaration: +primitive_declaration_body: STRING { [fst $1] } - | STRING primitive_declaration { fst $1 :: $2 } + | STRING primitive_declaration_body { fst $1 :: $2 } +; +primitive_declaration: + EXTERNAL val_ident COLON core_type EQUAL primitive_declaration_body + post_item_attributes + { Val.mk (mkrhs $2 2) $4 ~prim:$6 ~attrs:$7 + ~loc:(symbol_rloc ()) ~docs:(symbol_docs ()) } ; /* Type declarations */ type_declarations: - type_declaration { [$1] } - | type_declarations AND type_declaration { $3 :: $1 } + type_declaration + { let (nonrec_flag, ty) = $1 in (nonrec_flag, [ty]) } + | type_declarations and_type_declaration + { let (nonrec_flag, tys) = $1 in (nonrec_flag, $2 :: tys) } ; type_declaration: - optional_type_parameters LIDENT type_kind constraints post_item_attributes - { let (kind, priv, manifest) = $3 in - Type.mk (mkrhs $2 2) - ~params:$1 ~cstrs:(List.rev $4) - ~kind ~priv ?manifest ~attrs:$5 ~loc:(symbol_rloc()) - } + TYPE nonrec_flag optional_type_parameters LIDENT type_kind constraints + post_item_attributes + { let (kind, priv, manifest) = $5 in + let ty = + Type.mk (mkrhs $4 4) ~params:$3 ~cstrs:(List.rev $6) ~kind + ~priv ?manifest ~attrs:$7 + ~loc:(symbol_rloc ()) ~docs:(symbol_docs ()) + in + ($2, ty) } +; +and_type_declaration: + AND optional_type_parameters LIDENT type_kind constraints + post_item_attributes + { let (kind, priv, manifest) = $4 in + Type.mk (mkrhs $3 3) ~params:$2 ~cstrs:(List.rev $5) + ~kind ~priv ?manifest ~attrs:$6 ~loc:(symbol_rloc ()) + ~text:(symbol_text ()) ~docs:(symbol_docs ()) } ; constraints: constraints CONSTRAINT constrain { $3 :: $1 } @@ -1576,18 +1768,16 @@ type_kind: { (Ptype_variant(List.rev $2), Public, None) } | EQUAL PRIVATE constructor_declarations { (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 private_flag LBRACE label_declarations RBRACE + { (Ptype_record $4, $2, None) } + | EQUAL core_type EQUAL private_flag constructor_declarations + { (Ptype_variant(List.rev $5), $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) } + | EQUAL core_type EQUAL private_flag LBRACE label_declarations RBRACE + { (Ptype_record $6, $4, Some $2) } ; optional_type_parameters: /*empty*/ { [] } @@ -1628,34 +1818,39 @@ type_parameter_list: | type_parameter_list COMMA type_parameter { $3 :: $1 } ; constructor_declarations: - constructor_declaration { [$1] } - | constructor_declarations BAR constructor_declaration { $3 :: $1 } + constructor_declaration { [$1] } + | bar_constructor_declaration { [$1] } + | constructor_declarations bar_constructor_declaration { $2 :: $1 } ; constructor_declaration: - | constr_ident attributes generalized_constructor_arguments + | constr_ident generalized_constructor_arguments attributes { - let args,res = $3 in - Type.constructor (mkrhs $1 1) ~args ?res ~loc:(symbol_rloc()) ~attrs:$2 + let args,res = $2 in + Type.constructor (mkrhs $1 1) ~args ?res ~attrs:$3 + ~loc:(symbol_rloc()) ~info:(symbol_info ()) } ; -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 +bar_constructor_declaration: + | BAR constr_ident generalized_constructor_arguments attributes { - let ext = $1 in - {ext with pext_attributes = ext.pext_attributes @ $2} + let args,res = $3 in + Type.constructor (mkrhs $2 2) ~args ?res ~attrs:$4 + ~loc:(symbol_rloc()) ~info:(symbol_info ()) } ; +str_exception_declaration: + | sig_exception_declaration { $1 } + | EXCEPTION constr_ident EQUAL constr_longident attributes + post_item_attributes + { Te.rebind (mkrhs $2 2) (mkrhs $4 4) ~attrs:($5 @ $6) + ~loc:(symbol_rloc()) ~docs:(symbol_docs ()) } +; sig_exception_declaration: - | extension_constructor_declaration post_item_attributes - { - let ext = $1 in - {ext with pext_attributes = ext.pext_attributes @ $2} - } + | EXCEPTION constr_ident generalized_constructor_arguments attributes + post_item_attributes + { let args, res = $3 in + Te.decl (mkrhs $2 2) ~args ?res ~attrs:($4 @ $5) + ~loc:(symbol_rloc()) ~docs:(symbol_docs ()) } ; generalized_constructor_arguments: /*empty*/ { (Pcstr_tuple [],None) } @@ -1667,55 +1862,87 @@ generalized_constructor_arguments: ; constructor_arguments: - | core_type_list { Pcstr_tuple (List.rev $1) } - | LBRACE label_declarations opt_semi RBRACE { Pcstr_record (List.rev $2) } + | core_type_list { Pcstr_tuple (List.rev $1) } + | LBRACE label_declarations RBRACE { Pcstr_record $2 } ; label_declarations: label_declaration { [$1] } - | label_declarations SEMI label_declaration { $3 :: $1 } + | label_declaration_semi { [$1] } + | label_declaration_semi label_declarations { $1 :: $2 } ; label_declaration: - mutable_flag label attributes COLON poly_type + mutable_flag label COLON poly_type_no_attr attributes + { + Type.field (mkrhs $2 2) $4 ~mut:$1 ~attrs:$5 + ~loc:(symbol_rloc()) ~info:(symbol_info ()) + } +; +label_declaration_semi: + mutable_flag label COLON poly_type_no_attr attributes SEMI attributes { - Type.field (mkrhs $2 2) $5 ~mut:$1 ~attrs:$3 ~loc:(symbol_rloc()) + let info = + match rhs_info 5 with + | Some _ as info_before_semi -> info_before_semi + | None -> symbol_info () + in + Type.field (mkrhs $2 2) $4 ~mut:$1 ~attrs:($5 @ $7) + ~loc:(symbol_rloc()) ~info } ; /* 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 } + TYPE nonrec_flag optional_type_parameters type_longident + PLUSEQ private_flag str_extension_constructors post_item_attributes + { if $2 <> Recursive then not_expecting 2 "nonrec flag"; + Te.mk (mkrhs $4 4) (List.rev $7) ~params:$3 ~priv:$6 + ~attrs:$8 ~docs:(symbol_docs ()) } ; 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 } + TYPE nonrec_flag optional_type_parameters type_longident + PLUSEQ private_flag sig_extension_constructors post_item_attributes + { if $2 <> Recursive then not_expecting 2 "nonrec flag"; + Te.mk (mkrhs $4 4) (List.rev $7) ~params:$3 ~priv:$6 + ~attrs:$8 ~docs:(symbol_docs ()) } ; str_extension_constructors: extension_constructor_declaration { [$1] } + | bar_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 } + | bar_extension_constructor_rebind { [$1] } + | str_extension_constructors bar_extension_constructor_declaration + { $2 :: $1 } + | str_extension_constructors bar_extension_constructor_rebind + { $2 :: $1 } ; sig_extension_constructors: extension_constructor_declaration { [$1] } - | sig_extension_constructors BAR extension_constructor_declaration - { $3 :: $1 } + | bar_extension_constructor_declaration { [$1] } + | sig_extension_constructors bar_extension_constructor_declaration + { $2 :: $1 } ; extension_constructor_declaration: - | constr_ident attributes generalized_constructor_arguments + | constr_ident generalized_constructor_arguments attributes + { let args, res = $2 in + Te.decl (mkrhs $1 1) ~args ?res ~attrs:$3 + ~loc:(symbol_rloc()) ~info:(symbol_info ()) } +; +bar_extension_constructor_declaration: + | BAR constr_ident generalized_constructor_arguments attributes { let args, res = $3 in - Te.decl (mkrhs $1 1) ~args ?res ~loc:(symbol_rloc()) ~attrs:$2 } + Te.decl (mkrhs $2 2) ~args ?res ~attrs:$4 + ~loc:(symbol_rloc()) ~info:(symbol_info ()) } ; extension_constructor_rebind: - | constr_ident attributes EQUAL constr_longident - { Te.rebind (mkrhs $1 1) (mkrhs $4 4) ~loc:(symbol_rloc()) ~attrs:$2 } + | constr_ident EQUAL constr_longident attributes + { Te.rebind (mkrhs $1 1) (mkrhs $3 3) ~attrs:$4 + ~loc:(symbol_rloc()) ~info:(symbol_info ()) } +; +bar_extension_constructor_rebind: + | BAR constr_ident EQUAL constr_longident attributes + { Te.rebind (mkrhs $2 2) (mkrhs $4 4) ~attrs:$5 + ~loc:(symbol_rloc()) ~info:(symbol_info ()) } ; /* "with" constraints (additional type equations over signature components) */ @@ -1725,7 +1952,7 @@ with_constraints: | with_constraints AND with_constraint { $3 :: $1 } ; with_constraint: - TYPE type_parameters label_longident with_type_binder core_type constraints + TYPE type_parameters label_longident with_type_binder core_type_no_attr constraints { Pwith_type (mkrhs $3 3, (Type.mk (mkrhs (Longident.last $3) 3) @@ -1736,7 +1963,7 @@ with_constraint: ~loc:(symbol_rloc()))) } /* used label_longident instead of type_longident to disallow functor applications in type path */ - | TYPE type_parameters label COLONEQUAL core_type + | TYPE type_parameters label COLONEQUAL core_type_no_attr { Pwith_typesubst (Type.mk (mkrhs $3 3) ~params:$2 @@ -1764,10 +1991,22 @@ poly_type: | typevar_list DOT core_type { mktyp(Ptyp_poly(List.rev $1, $3)) } ; +poly_type_no_attr: + core_type_no_attr + { $1 } + | typevar_list DOT core_type_no_attr + { mktyp(Ptyp_poly(List.rev $1, $3)) } +; /* Core types */ core_type: + core_type_no_attr + { $1 } + | core_type attribute + { Typ.attr $1 $2 } +; +core_type_no_attr: core_type2 { $1 } | core_type2 AS QUOTE ident @@ -1777,13 +2016,13 @@ core_type2: simple_core_type_or_tuple { $1 } | QUESTION LIDENT COLON core_type2 MINUSGREATER core_type2 - { mktyp(Ptyp_arrow("?" ^ $2 , mkoption $4, $6)) } + { mktyp(Ptyp_arrow(Optional $2 , $4, $6)) } | OPTLABEL core_type2 MINUSGREATER core_type2 - { mktyp(Ptyp_arrow("?" ^ $1 , mkoption $2, $4)) } + { mktyp(Ptyp_arrow(Optional $1 , $2, $4)) } | LIDENT COLON core_type2 MINUSGREATER core_type2 - { mktyp(Ptyp_arrow($1, $3, $5)) } + { mktyp(Ptyp_arrow(Labelled $1, $3, $5)) } | core_type2 MINUSGREATER core_type2 - { mktyp(Ptyp_arrow("", $1, $3)) } + { mktyp(Ptyp_arrow(Nolabel, $1, $3)) } ; simple_core_type: @@ -1791,15 +2030,6 @@ simple_core_type: { $1 } | LPAREN core_type_comma_list RPAREN %prec below_SHARP { match $2 with [sty] -> sty | _ -> raise Parse_error } - | simple_core_type attribute - { Typ.attr $1 $2 } -; - -simple_core_type_no_attr: - simple_core_type2 %prec below_SHARP - { $1 } - | LPAREN core_type_comma_list RPAREN %prec below_SHARP - { match $2 with [sty] -> sty | _ -> raise Parse_error } ; simple_core_type2: @@ -1866,8 +2096,8 @@ row_field: | simple_core_type { Rinherit $1 } ; tag_field: - name_tag attributes OF opt_ampersand amper_type_list - { Rtag ($1, $2, $4, List.rev $5) } + name_tag OF opt_ampersand amper_type_list attributes + { Rtag ($1, $5, $3, List.rev $4) } | name_tag attributes { Rtag ($1, $2, true, []) } ; @@ -1876,43 +2106,33 @@ opt_ampersand: | /* empty */ { false } ; amper_type_list: - core_type { [$1] } - | amper_type_list AMPERSAND core_type { $3 :: $1 } + core_type_no_attr { [$1] } + | amper_type_list AMPERSAND core_type_no_attr { $3 :: $1 } ; name_tag_list: name_tag { [$1] } | name_tag_list name_tag { $2 :: $1 } ; simple_core_type_or_tuple: - simple_core_type %prec below_LBRACKETAT { $1 } + simple_core_type { $1 } | simple_core_type STAR core_type_list { mktyp(Ptyp_tuple($1 :: List.rev $3)) } ; -simple_core_type_or_tuple_no_attr: - simple_core_type_no_attr - { $1 } - | simple_core_type_no_attr STAR core_type_list_no_attr - { mktyp(Ptyp_tuple($1 :: List.rev $3)) } -; core_type_comma_list: core_type { [$1] } | core_type_comma_list COMMA core_type { $3 :: $1 } ; core_type_list: - simple_core_type %prec below_LBRACKETAT { [$1] } + simple_core_type { [$1] } | core_type_list STAR simple_core_type { $3 :: $1 } ; -core_type_list_no_attr: - simple_core_type_no_attr { [$1] } - | 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 opt_semi { [$1], Closed } | DOTDOT { [], Open } ; field: - label attributes COLON poly_type { ($1, $2, $4) } + label COLON poly_type_no_attr attributes { ($1, $4, $3) } ; label: LIDENT { $1 } @@ -1963,6 +2183,7 @@ operator: | INFIXOP2 { $1 } | INFIXOP3 { $1 } | INFIXOP4 { $1 } + | SHARPOP { $1 } | BANG { "!" } | PLUS { "+" } | PLUSDOT { "+." } @@ -1979,7 +2200,25 @@ operator: | COLONEQUAL { ":=" } | PLUSEQ { "+=" } | PERCENT { "%" } + | index_operator { $1 } ; +index_operator: + DOT index_operator_core opt_assign_arrow { $2^$3 } +; +index_operator_core: + | LPAREN RPAREN { ".()" } + | LBRACKET RBRACKET { ".[]" } + | LBRACE RBRACE { ".{}" } + | LBRACE COMMA RBRACE { ".{,}" } + | LBRACE COMMA COMMA RBRACE { ".{,,}" } + | LBRACE COMMA DOTDOT COMMA RBRACE { ".{,..,}"} +; + +opt_assign_arrow: + { "" } + | LESSMINUS { "<-" } +; + constr_ident: UIDENT { $1 } /* | LBRACKET RBRACKET { "[]" } */ @@ -2052,6 +2291,10 @@ rec_flag: /* empty */ { Nonrecursive } | REC { Recursive } ; +nonrec_flag: + /* empty */ { Recursive } + | NONREC { Nonrecursive } +; direction_flag: TO { Upto } | DOWNTO { Downto } @@ -2131,6 +2374,7 @@ single_attr_id: | MODULE { "module" } | MUTABLE { "mutable" } | NEW { "new" } + | NONREC { "nonrec" } | OBJECT { "object" } | OF { "of" } | OPEN { "open" } diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli index d287b9eee7..3f97142a51 100644 --- a/parsing/parsetree.mli +++ b/parsing/parsetree.mli @@ -36,7 +36,7 @@ and attributes = attribute list and payload = | PStr of structure | PTyp of core_type (* : T *) - | PPat of pattern * expression option (* : P or : P when E *) + | PPat of pattern * expression option (* ? P or ? P when E *) (** {2 Core language} *) @@ -54,10 +54,10 @@ and core_type_desc = (* _ *) | Ptyp_var of string (* 'a *) - | Ptyp_arrow of label * core_type * core_type - (* T1 -> T2 (label = "") - ~l:T1 -> T2 (label = "l") - ?l:T1 -> T2 (label = "?l") + | Ptyp_arrow of arg_label * core_type * core_type + (* T1 -> T2 Simple + ~l:T1 -> T2 Labelled + ?l:T1 -> T2 Otional *) | Ptyp_tuple of core_type list (* T1 * ... * Tn @@ -219,18 +219,18 @@ and expression_desc = *) | Pexp_function of case list (* function P1 -> E1 | ... | Pn -> En *) - | Pexp_fun of label * expression option * pattern * expression - (* fun P -> E1 (lab = "", None) - fun ~l:P -> E1 (lab = "l", None) - fun ?l:P -> E1 (lab = "?l", None) - fun ?l:(P = E0) -> E1 (lab = "?l", Some E0) + | Pexp_fun of arg_label * expression option * pattern * expression + (* fun P -> E1 (Simple, None) + fun ~l:P -> E1 (Labelled l, None) + fun ?l:P -> E1 (Optional l, None) + fun ?l:(P = E0) -> E1 (Optional l, Some E0) Notes: - - If E0 is provided, lab must start with '?'. + - If E0 is provided, only Optional is allowed. - "fun P1 P2 .. Pn -> E1" is represented as nested Pexp_fun. - "let f P = E" is represented using Pexp_fun. *) - | Pexp_apply of expression * (label * expression) list + | Pexp_apply of expression * (arg_label * expression) list (* E0 ~l1:E1 ... ~ln:En li can be empty (non labeled argument) or start with '?' (optional argument). @@ -342,8 +342,6 @@ and value_description = (* val x: T (prim = []) external x: T = "s1" ... "sn" (prim = ["s1";..."sn"]) - - Note: when used under Pstr_primitive, prim cannot be empty *) (* Type declarations *) @@ -466,10 +464,10 @@ and class_type_desc = ['a1, ..., 'an] c *) | Pcty_signature of class_signature (* object ... end *) - | Pcty_arrow of label * core_type * class_type - (* T -> CT (label = "") - ~l:T -> CT (label = "l") - ?l:T -> CT (label = "?l") + | Pcty_arrow of arg_label * core_type * class_type + (* T -> CT Simple + ~l:T -> CT Labelled l + ?l:T -> CT Optional l *) | Pcty_extension of extension (* [%id] *) @@ -542,13 +540,13 @@ and class_expr_desc = ['a1, ..., 'an] c *) | Pcl_structure of class_structure (* object ... end *) - | Pcl_fun of label * expression option * pattern * class_expr - (* fun P -> CE (lab = "", None) - fun ~l:P -> CE (lab = "l", None) - fun ?l:P -> CE (lab = "?l", None) - fun ?l:(P = E0) -> CE (lab = "?l", Some E0) + | Pcl_fun of arg_label * expression option * pattern * class_expr + (* fun P -> CE (Simple, None) + fun ~l:P -> CE (Labelled l, None) + fun ?l:P -> CE (Optional l, None) + fun ?l:(P = E0) -> CE (Optional l, Some E0) *) - | Pcl_apply of class_expr * (label * expression) list + | Pcl_apply of class_expr * (arg_label * expression) list (* CE ~l1:E1 ... ~ln:En li can be empty (non labeled argument) or start with '?' (optional argument). @@ -651,7 +649,7 @@ and signature_item_desc = val x: T external x: T = "s1" ... "sn" *) - | Psig_type of type_declaration list + | Psig_type of rec_flag * type_declaration list (* type t1 = ... and ... and tn = ... *) | Psig_typext of type_extension (* type t1 += ... *) @@ -776,8 +774,9 @@ and structure_item_desc = let rec P1 = E1 and ... and Pn = EN (flag = Recursive) *) | Pstr_primitive of value_description - (* external x: T = "s1" ... "sn" *) - | Pstr_type of type_declaration list + (* val x: T + external x: T = "s1" ... "sn" *) + | Pstr_type of rec_flag * type_declaration list (* type t1 = ... and ... and tn = ... *) | Pstr_typext of type_extension (* type t1 += ... *) diff --git a/parsing/pprintast.ml b/parsing/pprintast.ml index d078118f89..4090fe3fc1 100644 --- a/parsing/pprintast.ml +++ b/parsing/pprintast.ml @@ -51,10 +51,6 @@ let view_fixity_of_exp = function let is_infix = function | `Infix _ -> true | _ -> false -let is_predef_option = function - | (Ldot (Lident "*predef*","option")) -> true - | _ -> false - (* which identifiers are in fact operators needing parentheses *) let needs_parens txt = is_infix (fixity_of_string txt) @@ -197,9 +193,14 @@ class printer ()= object(self:'self) | Virtual -> pp f "virtual@;" (* trailing space added *) - method rec_flag f = function + method rec_flag f rf = + match rf with | Nonrecursive -> () | Recursive -> pp f "rec " + method nonrec_flag f rf = + match rf with + | Nonrecursive -> pp f "nonrec " + | Recursive -> () method direction_flag f = function | Upto -> pp f "to@ " | Downto -> pp f "downto@ " @@ -220,15 +221,9 @@ class printer ()= object(self:'self) method type_with_label f (label,({ptyp_desc;_}as c) ) = match label with - | "" -> self#core_type1 f c (* otherwise parenthesize *) - | s -> - if s.[0]='?' then - match ptyp_desc with - | Ptyp_constr ({txt;_}, l) -> - assert (is_predef_option txt); - pp f "%s:%a" s (self#list self#core_type1) l - | _ -> failwith "invalid input in print_type_with_label" - else pp f "%s:%a" s self#core_type1 c + | Nolabel -> self#core_type1 f c (* otherwise parenthesize *) + | Labelled s -> pp f "%s:%a" s self#core_type1 c + | Optional s -> pp f "?%s:%a" s self#core_type1 c method core_type f x = if x.ptyp_attributes <> [] then begin pp f "((%a)%a)" self#core_type {x with ptyp_attributes=[]} @@ -268,12 +263,12 @@ class printer ()= object(self:'self) | Ptyp_variant (l, closed, low) -> let type_variant_helper f x = match x with - | Rtag (l, attrs, _, ctl) -> pp f "@[<2>%a%a%a@]" self#string_quot l - self#attributes attrs + | Rtag (l, attrs, _, ctl) -> pp f "@[<2>%a%a@;%a@]" self#string_quot l (fun f l -> match l with |[] -> () | _ -> pp f "@;of@;%a" (self#list self#core_type ~sep:"&") ctl) ctl + self#attributes attrs | Rinherit ct -> self#core_type f ct in pp f "@[<2>[%a%a]@]" (fun f l @@ -363,7 +358,8 @@ class printer ()= object(self:'self) | None -> pp f "%a@;"self#longident_loc li ) | _ -> self#simple_pattern f x method simple_pattern (f:Format.formatter) (x:pattern) :unit = - match x.ppat_desc with + if x.ppat_attributes <> [] then self#pattern f x + else match x.ppat_desc with | Ppat_construct (({txt=Lident ("()"|"[]" as x);_}), _) -> pp f "%s" x | Ppat_any -> pp f "_"; | Ppat_var ({txt = txt;_}) -> protect_ident f txt @@ -397,16 +393,15 @@ class printer ()= object(self:'self) pp f "@[<2>(lazy@;%a)@]" self#pattern1 p | Ppat_exception p -> pp f "@[<2>exception@;%a@]" self#pattern1 p + | Ppat_extension e -> self#extension f e | _ -> self#paren true self#pattern f x method label_exp f (l,opt,p) = - if l = "" then + match l with + | Nolabel -> pp f "%a@ " self#simple_pattern p (*single case pattern parens needed here *) - else - if l.[0] = '?' then - let len = String.length l - 1 in - let rest = String.sub l 1 len in begin - match p.ppat_desc with + | Optional rest -> + begin match p.ppat_desc with | Ppat_var {txt;_} when txt = rest -> (match opt with | Some o -> pp f "?(%s=@;%a)@;" rest self#expression o @@ -414,10 +409,10 @@ class printer ()= object(self:'self) | _ -> (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) + pp f "?%s:(%a=@;%a)@;" rest self#pattern1 p self#expression o + | None -> pp f "?%s:%a@;" rest self#simple_pattern p) end - else + | Labelled l -> (match p.ppat_desc with | Ppat_var {txt;_} when txt = l -> pp f "~%s@;" l @@ -608,7 +603,7 @@ 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: impossible but we should print it anyway, rather than 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) -> @@ -700,6 +695,8 @@ class printer ()= object(self:'self) pp f "@[<2>[@@@@@@%s@ %a]@]" s.txt self#payload e method value_description f x = + (* note: value_description has an attribute field, + but they're already printed by the callers this method *) pp f "@[<hov2>%a%a@]" self#core_type x.pval_type (fun f x -> if x.pval_prim<>[] then begin @@ -929,8 +926,8 @@ class printer ()= object(self:'self) method signature_item f x :unit= begin match x.psig_desc with - | Psig_type l -> - self#type_def_list f l + | Psig_type (rf, l) -> + self#type_def_list f (rf, l) | Psig_value vd -> let intro = if vd.pval_prim = [] then "val" else "external" in pp f "@[<2>%s@ %a@ :@ %a@]%a" intro @@ -1050,11 +1047,12 @@ class printer ()= object(self:'self) (* transform [f = fun g h -> ..] to [f g h = ... ] could be improved *) method binding f {pvb_pat=p; pvb_expr=x; _} = + (* .pvb_attributes have already been printed by the caller, #bindings *) 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 | Pexp_fun (label, eo, p, e) -> - if label="" then + if label=Nolabel then pp f "%a@ %a" self#simple_pattern p pp_print_pexp_function e else pp f "%a@ %a" self#label_exp (label,eo,p) pp_print_pexp_function e @@ -1099,8 +1097,8 @@ class printer ()= object(self:'self) 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_type (_, []) -> assert false + | Pstr_type (rf, l) -> self#type_def_list f (rf, 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 @@ -1221,14 +1219,15 @@ class printer ()= object(self:'self) 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 = + method type_def_list f (rf, l) = + let type_decl kwd rf 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 + pp f "@[<2>%s %a%a%s%s%a@]%a" kwd + self#nonrec_flag rf self#type_params x.ptype_params x.ptype_name.txt eq self#type_declaration x @@ -1236,18 +1235,25 @@ class printer ()= object(self:'self) in match l with | [] -> assert false - | [x] -> type_decl "type" f x + | [x] -> type_decl "type" rf f x | x :: xs -> pp f "@[<v>%a@,%a@]" - (type_decl "type") x - (self#list ~sep:"@," (type_decl "and")) xs + (type_decl "type" rf) x + (self#list ~sep:"@," (type_decl "and" Recursive)) 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 "@[<2>%a%s:@;%a@;%a@]" + self#mutable_flag pld.pld_mutable + pld.pld_name.txt + self#core_type pld.pld_type + self#attributes pld.pld_attributes + in pp f "{@\n%a}" (self#list type_record_field ~sep:";@\n" ) lbls method type_declaration f x = + (* type_declaration has an attribute field, + but it's been printed by the caller of this method *) let priv f = match x.ptype_private with Public -> () @@ -1260,14 +1266,8 @@ class printer ()= object(self:'self) 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 + self#constructor_declaration f (pcd.pcd_name.txt, pcd.pcd_args, + pcd.pcd_res, pcd.pcd_attributes) in let repr f = let intro f = @@ -1280,16 +1280,15 @@ class printer ()= object(self:'self) (self#list ~sep:"@\n" constructor_declaration) xs | Ptype_abstract -> () | Ptype_record l -> - pp f "%t@;{@\n%a}" intro - (self#list ~sep:"@\n" label_declaration) l ; + pp f "%t@;%a" intro self#record_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@]" + List.iter + (fun (ct1,ct2,_) -> + pp f "@[<hov2>@ constraint@ %a@ =@ %a@]" self#core_type ct1 self#core_type ct2) - f x.ptype_cstrs + x.ptype_cstrs in pp f "%t%t%t%t" priv manifest repr constraints @@ -1300,7 +1299,9 @@ class printer ()= object(self:'self) pp f "@[<2>type %a%a +=%a@]%a" (fun f -> function | [] -> () - | l -> pp f "%a@;" (self#list self#type_param ~first:"(" ~last:")" ~sep:",") l) + | 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) @@ -1310,17 +1311,16 @@ class printer ()= object(self:'self) method constructor_declaration f (name, args, res, attrs) = match res with | None -> - pp f "%s%a%a" name - self#attributes attrs + pp f "%s%a@;%a" name (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 + | Some r -> + pp f "%s:@;%a@;%a" name (fun f -> function | Pcstr_tuple [] -> self#core_type1 f r | Pcstr_tuple l -> pp f "%a@;->@;%a" @@ -1330,6 +1330,7 @@ class printer ()= object(self:'self) pp f "%a@;->@;%a" (self#record_declaration) l self#core_type1 r ) args + self#attributes attrs method extension_constructor f x = @@ -1347,19 +1348,17 @@ class printer ()= object(self:'self) self#pattern pc_lhs (self#option self#expression ~first:"@;when@;") pc_guard self#under_pipe#expression pc_rhs in self#list aux f l ~sep:"" method label_x_expression_param f (l,e) = - match l with - | "" -> self#expression2 f e ; (* level 2*) - | lbl -> - let simple_name = match e.pexp_desc with - | Pexp_ident {txt=Lident l;_} -> Some l - | _ -> None in - if lbl.[0] = '?' then - let str = String.sub lbl 1 (String.length lbl-1) in + let simple_name = match e.pexp_desc with + | Pexp_ident {txt=Lident l;_} -> Some l + | _ -> None + in match l with + | Nolabel -> self#expression2 f e ; (* level 2*) + | Optional str -> if Some str = simple_name then - pp f "%s" lbl + pp f "?%s" str else - pp f "%s:%a" lbl self#simple_expr e - else + pp f "?%s:%a" str self#simple_expr e + | Labelled lbl -> if Some lbl = simple_name then pp f "~%s" lbl else diff --git a/parsing/pprintast.mli b/parsing/pprintast.mli index 42a3409151..98105928dd 100644 --- a/parsing/pprintast.mli +++ b/parsing/pprintast.mli @@ -53,10 +53,10 @@ class printer : Format.formatter -> Parsetree.extension_constructor -> unit method label_exp : Format.formatter -> - Asttypes.label * Parsetree.expression option * Parsetree.pattern -> + Asttypes.arg_label * Parsetree.expression option * Parsetree.pattern -> unit method label_x_expression_param : - Format.formatter -> Asttypes.label * Parsetree.expression -> unit + Format.formatter -> Asttypes.arg_label * Parsetree.expression -> unit method list : ?sep:space_formatter -> ?first:space_formatter -> @@ -81,7 +81,9 @@ 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 nonrec_flag : Format.formatter -> Asttypes.rec_flag -> unit + method record_declaration : + Format.formatter -> Parsetree.label_declaration list -> unit method reset : 'b method reset_semi : 'b @@ -105,7 +107,7 @@ class printer : method type_declaration : Format.formatter -> Parsetree.type_declaration -> unit method type_def_list : - Format.formatter -> Parsetree.type_declaration list -> unit + Format.formatter -> Asttypes.rec_flag * Parsetree.type_declaration list -> unit method type_extension : Format.formatter -> Parsetree.type_extension -> unit method type_param : @@ -113,7 +115,7 @@ class printer : method type_params : Format.formatter -> (Parsetree.core_type * Asttypes.variance) list -> unit method type_with_label : - Format.formatter -> Asttypes.label * Parsetree.core_type -> unit + Format.formatter -> Asttypes.arg_label * Parsetree.core_type -> unit method tyvar : Format.formatter -> string -> unit method under_pipe : 'b method under_semi : 'b diff --git a/parsing/printast.ml b/parsing/printast.ml index 2bf9d8f3e9..a0bff6e9ad 100644 --- a/parsing/printast.ml +++ b/parsing/printast.ml @@ -130,6 +130,11 @@ let string i ppf s = line i ppf "\"%s\"\n" s;; let string_loc i ppf s = line i ppf "%a\n" fmt_string_loc s;; let bool i ppf x = line i ppf "%s\n" (string_of_bool x);; let label i ppf x = line i ppf "label=\"%s\"\n" x;; +let arg_label i ppf = function + | Nolabel -> line i ppf "Nolabel\n" + | Optional s -> line i ppf "Optional \"%s\"\n" s + | Labelled s -> line i ppf "Labelled \"%s\"\n" s +;; let rec core_type i ppf x = line i ppf "core_type %a\n" fmt_location x.ptyp_loc; @@ -140,7 +145,7 @@ let rec core_type i ppf x = | Ptyp_var (s) -> line i ppf "Ptyp_var %s\n" s; | Ptyp_arrow (l, ct1, ct2) -> line i ppf "Ptyp_arrow\n"; - string i ppf l; + arg_label i ppf l; core_type i ppf ct1; core_type i ppf ct2; | Ptyp_tuple l -> @@ -250,7 +255,8 @@ and expression i ppf x = line i ppf "Pexp_function\n"; list i case ppf l; | Pexp_fun (l, eo, p, e) -> - line i ppf "Pexp_fun \"%s\"\n" l; + line i ppf "Pexp_fun\n"; + arg_label i ppf l; option i expression ppf eo; pattern i ppf p; expression i ppf e; @@ -457,7 +463,8 @@ and class_type i ppf x = line i ppf "Pcty_signature\n"; class_signature i ppf cs; | Pcty_arrow (l, co, cl) -> - line i ppf "Pcty_arrow \"%s\"\n" l; + line i ppf "Pcty_arrow\n"; + arg_label i ppf l; core_type i ppf co; class_type i ppf cl; | Pcty_extension (s, arg) -> @@ -531,7 +538,7 @@ and class_expr i ppf x = class_structure i ppf cs; | Pcl_fun (l, eo, p, e) -> line i ppf "Pcl_fun\n"; - label i ppf l; + arg_label i ppf l; option i expression ppf eo; pattern i ppf p; class_expr i ppf e; @@ -640,8 +647,8 @@ and signature_item i ppf x = | Psig_value vd -> line i ppf "Psig_value\n"; value_description i ppf vd; - | Psig_type (l) -> - line i ppf "Psig_type\n"; + | Psig_type (rf, l) -> + line i ppf "Psig_type %a\n" fmt_rec_flag rf; list i type_declaration ppf l; | Psig_typext te -> line i ppf "Psig_typext\n"; @@ -748,8 +755,8 @@ and structure_item i ppf x = | Pstr_primitive vd -> line i ppf "Pstr_primitive\n"; value_description i ppf vd; - | Pstr_type l -> - line i ppf "Pstr_type\n"; + | Pstr_type (rf, l) -> + line i ppf "Pstr_type %a\n" fmt_rec_flag rf; list i type_declaration ppf l; | Pstr_typext te -> line i ppf "Pstr_typext\n"; @@ -852,7 +859,8 @@ and longident_x_expression i ppf (li, e) = expression (i+1) ppf e; and label_x_expression i ppf (l,e) = - line i ppf "<label> \"%s\"\n" l; + line i ppf "<arg>\n"; + arg_label i ppf l; expression (i+1) ppf e; and label_x_bool_x_core_type_list i ppf x = @@ -879,7 +887,7 @@ and directive_argument i ppf x = match x with | Pdir_none -> line i ppf "Pdir_none\n" | Pdir_string (s) -> line i ppf "Pdir_string \"%s\"\n" s; - | Pdir_int (i) -> line i ppf "Pdir_int %d\n" i; + | Pdir_int (n) -> line i ppf "Pdir_int %d\n" n; | Pdir_ident (li) -> line i ppf "Pdir_ident %a\n" fmt_longident li; | Pdir_bool (b) -> line i ppf "Pdir_bool %s\n" (string_of_bool b); ;; diff --git a/stdlib/.depend b/stdlib/.depend index 96f95082d2..3b6ebbda75 100644 --- a/stdlib/.depend +++ b/stdlib/.depend @@ -141,10 +141,10 @@ printf.cmx : camlinternalFormatBasics.cmx camlinternalFormat.cmx buffer.cmx \ printf.cmi queue.cmo : obj.cmi queue.cmi queue.cmx : obj.cmx queue.cmi -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 +random.cmo : pervasives.cmi nativeint.cmi int64.cmi int32.cmi digest.cmi \ + char.cmi array.cmi random.cmi +random.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 list.cmi \ camlinternalFormatBasics.cmi camlinternalFormat.cmi bytes.cmi buffer.cmi \ scanf.cmi @@ -267,10 +267,10 @@ printf.p.cmx : camlinternalFormatBasics.p.cmx camlinternalFormat.p.cmx buffer.p. printf.cmi queue.cmo : obj.cmi queue.cmi queue.p.cmx : obj.p.cmx queue.cmi -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 +random.cmo : pervasives.cmi nativeint.cmi int64.cmi int32.cmi digest.cmi \ + char.cmi array.cmi random.cmi +random.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 list.cmi \ camlinternalFormatBasics.cmi camlinternalFormat.cmi bytes.cmi buffer.cmi \ scanf.cmi diff --git a/stdlib/.ignore b/stdlib/.ignore index ad1b04e137..20d8653fe9 100644 --- a/stdlib/.ignore +++ b/stdlib/.ignore @@ -1,5 +1,7 @@ camlheader +target_camlheader camlheaderd +target_camlheaderd camlheader_ur labelled-* caml diff --git a/stdlib/Makefile b/stdlib/Makefile index 37f9a5f0bf..92fa3740ea 100644 --- a/stdlib/Makefile +++ b/stdlib/Makefile @@ -45,23 +45,28 @@ installopt-prof: stdlib.p.cmxa: $(OBJS:.cmo=.p.cmx) $(CAMLOPT) -a -o stdlib.p.cmxa $(OBJS:.cmo=.p.cmx) -camlheader camlheaderd camlheader_ur: header.c ../config/Makefile +camlheader target_camlheader camlheaderd target_camlheaderd camlheader_ur: \ + header.c ../config/Makefile if $(SHARPBANGSCRIPTS); then \ echo '#!$(BINDIR)/ocamlrun' > camlheader && \ + echo '#!$(TARGET_BINDIR)/ocamlrun' > target_camlheader && \ echo '#!$(BINDIR)/ocamlrund' > camlheaderd && \ + echo '#!$(TARGET_BINDIR)/ocamlrund' > target_camlheaderd && \ echo '#!' | tr -d '\012' > camlheader_ur; \ else \ - $(BYTECC) $(BYTECCCOMPOPTS) $(BYTECCLINKOPTS) \ - -DRUNTIME_NAME='"$(BINDIR)/ocamlrun"' \ - header.c -o tmpheader$(EXE) && \ - strip tmpheader$(EXE) && \ - mv tmpheader$(EXE) camlheader && \ - cp camlheader camlheader_ur && \ - $(BYTECC) $(BYTECCCOMPOPTS) $(BYTECCLINKOPTS) \ - -DRUNTIME_NAME='"$(BINDIR)/ocamlrund"' \ - header.c -o tmpheader$(EXE) && \ - strip tmpheader$(EXE) && \ - mv tmpheader$(EXE) camlheaderd; \ + for suff in '' d; do \ + $(BYTECC) $(BYTECCCOMPOPTS) $(BYTECCLINKOPTS) \ + -DRUNTIME_NAME='"$(BINDIR)/ocamlrun'$$suff'"' \ + header.c -o tmpheader$(EXE) && \ + strip tmpheader$(EXE) && \ + mv tmpheader$(EXE) camlheader$$suff && \ + $(BYTECC) $(BYTECCCOMPOPTS) $(BYTECCLINKOPTS) \ + -DRUNTIME_NAME='"$(TARGET_BINDIR)/ocamlrun'$$suff'"' \ + header.c -o tmpheader$(EXE) && \ + strip tmpheader$(EXE) && \ + mv tmpheader$(EXE) target_camlheader$$suff; \ + done && \ + cp camlheader camlheader_ur; \ fi .PHONY: all allopt allopt-noprof allopt-prof install installopt diff --git a/stdlib/Makefile.nt b/stdlib/Makefile.nt index 590701bf92..5bc2e0edfa 100644 --- a/stdlib/Makefile.nt +++ b/stdlib/Makefile.nt @@ -18,19 +18,21 @@ allopt: stdlib.cmxa std_exit.cmx installopt: cp stdlib.cmxa stdlib.$(A) std_exit.$(O) *.cmx $(INSTALL_LIBDIR) -camlheader camlheader_ur: headernt.c ../config/Makefile +camlheader target_camlheader camlheader_ur: headernt.c ../config/Makefile $(BYTECC) $(BYTECCCOMPOPTS) -c -I../byterun \ -DRUNTIME_NAME='"ocamlrun"' headernt.c $(MKEXE) -o tmpheader.exe headernt.$(O) $(EXTRALIBS) rm -f camlheader.exe mv tmpheader.exe camlheader + cp camlheader target_camlheader cp camlheader camlheader_ur -camlheaderd: headernt.c ../config/Makefile +camlheaderd target_camlheaderd: headernt.c ../config/Makefile $(BYTECC) $(BYTECCCOMPOPTS) -c -I../byterun \ -DRUNTIME_NAME='"ocamlrund"' headernt.c $(MKEXE) -o tmpheader.exe headernt.$(O) $(EXTRALIBS) mv tmpheader.exe camlheaderd + cp camlheaderd target_camlheaderd # TODO: do not call flexlink to build tmpheader.exe (we don't need # the export table) diff --git a/stdlib/Makefile.shared b/stdlib/Makefile.shared index 54de337cb4..b97ca21c6f 100755 --- a/stdlib/Makefile.shared +++ b/stdlib/Makefile.shared @@ -12,14 +12,17 @@ ######################################################################### include ../config/Makefile -RUNTIME=../boot/ocamlrun +CAMLRUN ?= ../boot/ocamlrun +CAMLYACC ?= ../boot/ocamlyacc +TARGET_BINDIR ?= $(BINDIR) + COMPILER=../ocamlc -CAMLC=$(RUNTIME) $(COMPILER) +CAMLC=$(CAMLRUN) $(COMPILER) COMPFLAGS=-strict-sequence -w +33..39 -g -warn-error A -bin-annot -nostdlib \ -safe-string OPTCOMPILER=../ocamlopt -CAMLOPT=$(RUNTIME) $(OPTCOMPILER) -CAMLDEP=../boot/ocamlrun ../tools/ocamldep +CAMLOPT=$(CAMLRUN) $(OPTCOMPILER) +CAMLDEP=$(CAMLRUN) ../tools/ocamldep OBJS=camlinternalFormatBasics.cmo pervasives.cmo $(OTHERS) OTHERS=array.cmo list.cmo char.cmo bytes.cmo string.cmo sys.cmo \ @@ -37,19 +40,21 @@ OTHERS=array.cmo list.cmo char.cmo bytes.cmo string.cmo sys.cmo \ arrayLabels.cmo listLabels.cmo bytesLabels.cmo \ stringLabels.cmo moreLabels.cmo stdLabels.cmo -all: stdlib.cma std_exit.cmo camlheader camlheader_ur +all: stdlib.cma std_exit.cmo camlheader target_camlheader camlheader_ur INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR) install: install-$(RUNTIMED) - cp stdlib.cma std_exit.cmo *.cmi *.mli *.ml camlheader camlheader_ur \ + cp stdlib.cma std_exit.cmo *.cmi *.cmt *.cmti *.mli *.ml \ + camlheader_ur \ $(INSTALL_LIBDIR) + cp target_camlheader $(INSTALL_LIBDIR)/camlheader install-noruntimed: .PHONY: install-noruntimed -install-runtimed: camlheaderd - cp camlheaderd $(INSTALL_LIBDIR) +install-runtimed: target_camlheaderd + cp target_camlheaderd $(INSTALL_LIBDIR)/camlheaderd .PHONY: install-runtimed stdlib.cma: $(OBJS) @@ -65,7 +70,7 @@ clean:: rm -f sys.ml clean:: - rm -f camlheader camlheader_ur camlheaderd + rm -f camlheader target_camlheader camlheader_ur target_camlheaderd .SUFFIXES: .mli .ml .cmi .cmo .cmx .p.cmx diff --git a/stdlib/array.ml b/stdlib/array.ml index 1990a78b86..243eeade17 100644 --- a/stdlib/array.ml +++ b/stdlib/array.ml @@ -29,6 +29,10 @@ external make_float: int -> float array = "caml_make_float_vect" let init l f = if l = 0 then [||] else + if l < 0 then invalid_arg "Array.init" + (* See #6575. We could also check for maximum array size, but this depends + on whether we create a float array or a regular one... *) + else let res = create l (f 0) in for i = 1 to pred l do unsafe_set res i (f i) diff --git a/stdlib/array.mli b/stdlib/array.mli index 99de0c806e..7580f7e754 100644 --- a/stdlib/array.mli +++ b/stdlib/array.mli @@ -154,7 +154,8 @@ val fold_right : ('b -> 'a -> 'a) -> 'b array -> 'a -> 'a external make_float: int -> float array = "caml_make_float_vect" (** [Array.make_float n] returns a fresh float array of length [n], - with uninitialized data. *) + with uninitialized data. + @since 4.02 *) (** {6 Sorting} *) diff --git a/stdlib/arrayLabels.mli b/stdlib/arrayLabels.mli index 0d046378ad..8fa55de43e 100644 --- a/stdlib/arrayLabels.mli +++ b/stdlib/arrayLabels.mli @@ -17,24 +17,24 @@ external length : 'a array -> int = "%array_length" (** Return the length (number of elements) of the given array. *) external get : 'a array -> int -> 'a = "%array_safe_get" -(** [Array.get a n] returns the element number [n] of array [a]. +(** [ArrayLabels.get a n] returns the element number [n] of array [a]. The first element has number 0. - The last element has number [Array.length a - 1]. - You can also write [a.(n)] instead of [Array.get a n]. + The last element has number [ArrayLabels.length a - 1]. + You can also write [a.(n)] instead of [ArrayLabels.get a n]. Raise [Invalid_argument "index out of bounds"] - if [n] is outside the range 0 to [(Array.length a - 1)]. *) + if [n] is outside the range 0 to [(ArrayLabels.length a - 1)]. *) external set : 'a array -> int -> 'a -> unit = "%array_safe_set" -(** [Array.set a n x] modifies array [a] in place, replacing +(** [ArrayLabels.set a n x] modifies array [a] in place, replacing element number [n] with [x]. - You can also write [a.(n) <- x] instead of [Array.set a n x]. + You can also write [a.(n) <- x] instead of [ArrayLabels.set a n x]. Raise [Invalid_argument "index out of bounds"] - if [n] is outside the range 0 to [Array.length a - 1]. *) + if [n] is outside the range 0 to [ArrayLabels.length a - 1]. *) external make : int -> 'a -> 'a array = "caml_make_vect" -(** [Array.make n x] returns a fresh array of length [n], +(** [ArrayLabels.make n x] returns a fresh array of length [n], initialized with [x]. All the elements of this new array are initially physically equal to [x] (in the sense of the [==] predicate). @@ -51,9 +51,9 @@ external create : int -> 'a -> 'a array = "caml_make_vect" (** @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], +(** [ArrayLabels.init n f] returns a fresh array of length [n], with element number [i] initialized to the result of [f i]. - In other terms, [Array.init n f] tabulates the results of [f] + In other terms, [ArrayLabels.init n f] tabulates the results of [f] applied to the integers [0] to [n-1]. Raise [Invalid_argument] if [n < 0] or [n > Sys.max_array_length]. @@ -61,7 +61,7 @@ val init : int -> f:(int -> 'a) -> 'a array size is only [Sys.max_array_length / 2].*) val make_matrix : dimx:int -> dimy:int -> 'a -> 'a array array -(** [Array.make_matrix dimx dimy e] returns a two-dimensional array +(** [ArrayLabels.make_matrix dimx dimy e] returns a two-dimensional array (an array of arrays) with first dimension [dimx] and second dimension [dimy]. All the elements of this new matrix are initially physically equal to [e]. @@ -79,27 +79,27 @@ val create_matrix : dimx:int -> dimy:int -> 'a -> 'a array array {!ArrayLabels.make_matrix}. *) val append : 'a array -> 'a array -> 'a array -(** [Array.append v1 v2] returns a fresh array containing the +(** [ArrayLabels.append v1 v2] returns a fresh array containing the concatenation of the arrays [v1] and [v2]. *) val concat : 'a array list -> 'a array -(** Same as [Array.append], but concatenates a list of arrays. *) +(** Same as [ArrayLabels.append], but concatenates a list of arrays. *) val sub : 'a array -> pos:int -> len:int -> 'a array -(** [Array.sub a start len] returns a fresh array of length [len], +(** [ArrayLabels.sub a start len] returns a fresh array of length [len], containing the elements number [start] to [start + len - 1] of array [a]. Raise [Invalid_argument "Array.sub"] if [start] and [len] do not designate a valid subarray of [a]; that is, if - [start < 0], or [len < 0], or [start + len > Array.length a]. *) + [start < 0], or [len < 0], or [start + len > ArrayLabels.length a]. *) val copy : 'a array -> 'a array -(** [Array.copy a] returns a copy of [a], that is, a fresh array +(** [ArrayLabels.copy a] returns a copy of [a], that is, a fresh array containing the same elements as [a]. *) val fill : 'a array -> pos:int -> len:int -> 'a -> unit -(** [Array.fill a ofs len x] modifies the array [a] in place, +(** [ArrayLabels.fill a ofs len x] modifies the array [a] in place, storing [x] in elements number [ofs] to [ofs + len - 1]. Raise [Invalid_argument "Array.fill"] if [ofs] and [len] do not @@ -108,7 +108,7 @@ val fill : 'a array -> pos:int -> len:int -> 'a -> unit val blit : src:'a array -> src_pos:int -> dst:'a array -> dst_pos:int -> len:int -> unit -(** [Array.blit v1 o1 v2 o2 len] copies [len] elements +(** [ArrayLabels.blit v1 o1 v2 o2 len] copies [len] elements from array [v1], starting at element number [o1], to array [v2], starting at element number [o2]. It works correctly even if [v1] and [v2] are the same array, and the source and @@ -119,21 +119,21 @@ val blit : designate a valid subarray of [v2]. *) val to_list : 'a array -> 'a list -(** [Array.to_list a] returns the list of all the elements of [a]. *) +(** [ArrayLabels.to_list a] returns the list of all the elements of [a]. *) val of_list : 'a list -> 'a array -(** [Array.of_list l] returns a fresh array containing the elements +(** [ArrayLabels.of_list l] returns a fresh array containing the elements of [l]. *) val iter : f:('a -> unit) -> 'a array -> unit -(** [Array.iter f a] applies function [f] in turn to all +(** [ArrayLabels.iter f a] applies function [f] in turn to all the elements of [a]. It is equivalent to - [f a.(0); f a.(1); ...; f a.(Array.length a - 1); ()]. *) + [f a.(0); f a.(1); ...; f a.(ArrayLabels.length a - 1); ()]. *) val map : f:('a -> 'b) -> 'a array -> 'b array -(** [Array.map f a] applies function [f] to all the elements of [a], +(** [ArrayLabels.map f a] applies function [f] to all the elements of [a], and builds an array with the results returned by [f]: - [[| f a.(0); f a.(1); ...; f a.(Array.length a - 1) |]]. *) + [[| f a.(0); f a.(1); ...; f a.(ArrayLabels.length a - 1) |]]. *) val iteri : f:(int -> 'a -> unit) -> 'a array -> unit (** Same as {!ArrayLabels.iter}, but the @@ -146,15 +146,19 @@ val mapi : f:(int -> 'a -> 'b) -> 'a array -> 'b array and the element itself as second argument. *) val fold_left : f:('a -> 'b -> 'a) -> init:'a -> 'b array -> 'a -(** [Array.fold_left f x a] computes +(** [ArrayLabels.fold_left f x a] computes [f (... (f (f x a.(0)) a.(1)) ...) a.(n-1)], where [n] is the length of the array [a]. *) val fold_right : f:('b -> 'a -> 'a) -> 'b array -> init:'a -> 'a -(** [Array.fold_right f a x] computes +(** [ArrayLabels.fold_right f a x] computes [f a.(0) (f a.(1) ( ... (f a.(n-1) x) ...))], where [n] is the length of the array [a]. *) +external make_float: int -> float array = "caml_make_float_vect" +(** [ArrayLabels.make_float n] returns a fresh float array of length [n], + with uninitialized data. + @since 4.02 *) (** {6 Sorting} *) @@ -166,9 +170,9 @@ val sort : cmp:('a -> 'a -> int) -> 'a array -> unit and a negative integer if the first is smaller (see below for a complete specification). For example, {!Pervasives.compare} is a suitable comparison function, provided there are no floating-point - NaN values in the data. After calling [Array.sort], the + NaN values in the data. After calling [ArrayLabels.sort], the array is sorted in place in increasing order. - [Array.sort] is guaranteed to run in constant heap space + [ArrayLabels.sort] is guaranteed to run in constant heap space and (at most) logarithmic stack space. The current implementation uses Heap Sort. It runs in constant @@ -180,7 +184,7 @@ val sort : cmp:('a -> 'a -> int) -> 'a array -> unit - [cmp x y] > 0 if and only if [cmp y x] < 0 - if [cmp x y] >= 0 and [cmp y z] >= 0 then [cmp x z] >= 0 - When [Array.sort] returns, [a] contains the same elements as before, + When [ArrayLabels.sort] returns, [a] contains the same elements as before, reordered in such a way that for all i and j valid indices of [a] : - [cmp a.(i) a.(j)] >= 0 if and only if i >= j *) @@ -196,8 +200,8 @@ val stable_sort : cmp:('a -> 'a -> int) -> 'a array -> unit *) val fast_sort : cmp:('a -> 'a -> int) -> 'a array -> unit -(** Same as {!Array.sort} or {!Array.stable_sort}, whichever is faster - on typical input. +(** Same as {!ArrayLabels.sort} or {!ArrayLabels.stable_sort}, whichever is + faster on typical input. *) diff --git a/stdlib/buffer.ml b/stdlib/buffer.ml index 986fe6f334..93a25cb09d 100644 --- a/stdlib/buffer.ml +++ b/stdlib/buffer.ml @@ -101,12 +101,20 @@ let add_bytes b s = add_string b (Bytes.unsafe_to_string s) let add_buffer b bs = add_subbytes b bs.buffer 0 bs.position +(* read up to [len] bytes from [ic] into [b]. *) +let rec add_channel_rec b ic len = + if len > 0 then ( + let n = input ic b.buffer b.position len in + b.position <- b.position + n; + if n = 0 then raise End_of_file + else add_channel_rec b ic (len-n) (* n <= len *) + ) + let add_channel b ic len = if len < 0 || len > Sys.max_string_length then (* PR#5004 *) invalid_arg "Buffer.add_channel"; if b.position + len > b.length then resize b len; - really_input ic b.buffer b.position len; - b.position <- b.position + len + add_channel_rec b ic len let output_buffer oc b = output oc b.buffer 0 b.position diff --git a/stdlib/buffer.mli b/stdlib/buffer.mli index e7ce8b9999..764b3bc681 100644 --- a/stdlib/buffer.mli +++ b/stdlib/buffer.mli @@ -38,11 +38,12 @@ val create : int -> t val contents : t -> string (** Return a copy of the current contents of the buffer. - The buffer itself is unchanged. *) + 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. *) + The buffer itself is unchanged. + @since 4.02 *) val sub : t -> int -> int -> string (** [Buffer.sub b off len] returns (a copy of) the bytes from the @@ -85,7 +86,8 @@ 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]. *) +(** [add_string b s] appends the string [s] at the end of the buffer [b]. + @since 4.02 *) val add_substring : t -> string -> int -> int -> unit (** [add_substring b s ofs len] takes [len] characters from offset @@ -93,7 +95,8 @@ val add_substring : t -> string -> int -> int -> unit 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]. *) + [ofs] in byte sequence [s] and appends them at the end of the buffer [b]. + @since 4.02 *) val add_substitute : t -> (string -> string) -> string -> unit (** [add_substitute b f s] appends the string pattern [s] at the end @@ -116,10 +119,11 @@ val add_buffer : t -> t -> unit at the end of buffer [b1]. [b2] is not modified. *) val add_channel : t -> in_channel -> int -> unit -(** [add_channel b ic n] reads exactly [n] character from the +(** [add_channel b ic n] reads at most [n] characters from the input channel [ic] and stores them at the end of buffer [b]. Raise [End_of_file] if the channel contains fewer than [n] - characters. *) + characters. In this case the characters are still added to + the buffer, so as to avoid loss of data. *) val output_buffer : out_channel -> t -> unit (** [output_buffer oc b] writes the current contents of buffer [b] diff --git a/stdlib/bytes.ml b/stdlib/bytes.ml index ce6e126db8..32d4468c34 100644 --- a/stdlib/bytes.ml +++ b/stdlib/bytes.ml @@ -122,7 +122,6 @@ let cat s1 s2 = r ;; -external is_printable: char -> bool = "caml_is_printable" external char_code: char -> int = "%identity" external char_chr: int -> char = "%identity" @@ -151,7 +150,8 @@ let escaped s = n := !n + (match unsafe_get s i with | '"' | '\\' | '\n' | '\t' | '\r' | '\b' -> 2 - | c -> if is_printable c then 1 else 4) + | ' ' .. '~' -> 1 + | _ -> 4) done; if !n = length s then copy s else begin let s' = create !n in @@ -168,19 +168,16 @@ let escaped s = unsafe_set s' !n '\\'; incr n; unsafe_set s' !n 'r' | '\b' -> unsafe_set s' !n '\\'; incr n; unsafe_set s' !n 'b' + | (' ' .. '~') as c -> unsafe_set s' !n c | 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 + 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; incr n done; @@ -203,8 +200,8 @@ let mapi f s = r end -let uppercase s = map Char.uppercase s -let lowercase s = map Char.lowercase s +let uppercase_ascii s = map Char.uppercase_ascii s +let lowercase_ascii s = map Char.lowercase_ascii s let apply1 f s = if length s = 0 then s else begin @@ -213,8 +210,8 @@ let apply1 f s = r end -let capitalize s = apply1 Char.uppercase s -let uncapitalize s = apply1 Char.lowercase s +let capitalize_ascii s = apply1 Char.uppercase_ascii s +let uncapitalize_ascii s = apply1 Char.lowercase_ascii s let rec index_rec s lim i c = if i >= lim then raise Not_found else @@ -260,3 +257,12 @@ let rcontains_from s i c = type t = bytes let compare (x: t) (y: t) = Pervasives.compare x y +external equal : t -> t -> bool = "caml_string_equal" + +(* Deprecated functions implemented via other deprecated functions *) +[@@@ocaml.warning "-3"] +let uppercase s = map Char.uppercase s +let lowercase s = map Char.lowercase s + +let capitalize s = apply1 Char.uppercase s +let uncapitalize s = apply1 Char.lowercase s diff --git a/stdlib/bytes.mli b/stdlib/bytes.mli index 82b28a28c5..621c619f78 100644 --- a/stdlib/bytes.mli +++ b/stdlib/bytes.mli @@ -179,6 +179,8 @@ val trim : bytes -> bytes val escaped : bytes -> bytes (** Return a copy of the argument, with special characters represented by escape sequences, following the lexical conventions of OCaml. + All characters outside the ASCII printable range (32..126) are + escaped, as well as backslash and double-quote. Raise [Invalid_argument] if the result is longer than {!Sys.max_string_length} bytes. *) @@ -229,22 +231,50 @@ val rcontains_from : bytes -> int -> char -> bool position in [s]. *) val uppercase : bytes -> bytes + [@@ocaml.deprecated "Use Bytes.uppercase_ascii instead."] (** 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. *) + translated to uppercase, including accented letters of the ISO + Latin-1 (8859-1) character set. + @deprecated Functions operating on Latin-1 character set are deprecated. *) val lowercase : bytes -> bytes + [@@ocaml.deprecated "Use Bytes.lowercase_ascii instead."] (** 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. *) + translated to lowercase, including accented letters of the ISO + Latin-1 (8859-1) character set. + @deprecated Functions operating on Latin-1 character set are deprecated. *) val capitalize : bytes -> bytes -(** Return a copy of the argument, with the first byte set to - uppercase. *) + [@@ocaml.deprecated "Use Bytes.capitalize_ascii instead."] +(** Return a copy of the argument, with the first character set to uppercase, + using the ISO Latin-1 (8859-1) character set.. + @deprecated Functions operating on Latin-1 character set are deprecated. *) val uncapitalize : bytes -> bytes -(** Return a copy of the argument, with the first byte set to - lowercase. *) + [@@ocaml.deprecated "Use Bytes.uncapitalize_ascii instead."] +(** Return a copy of the argument, with the first character set to lowercase, + using the ISO Latin-1 (8859-1) character set.. + @deprecated Functions operating on Latin-1 character set are deprecated. *) + +val uppercase_ascii : bytes -> bytes +(** Return a copy of the argument, with all lowercase letters + translated to uppercase, using the US-ASCII character set. + @since 4.03.0 *) + +val lowercase_ascii : bytes -> bytes +(** Return a copy of the argument, with all uppercase letters + translated to lowercase, using the US-ASCII character set. + @since 4.03.0 *) + +val capitalize_ascii : bytes -> bytes +(** Return a copy of the argument, with the first character set to uppercase, + using the US-ASCII character set. + @since 4.03.0 *) + +val uncapitalize_ascii : bytes -> bytes +(** Return a copy of the argument, with the first character set to lowercase, + using the US-ASCII character set. + @since 4.03.0 *) type t = bytes (** An alias for the type of byte sequences. *) @@ -255,6 +285,9 @@ val compare: t -> t -> int this function [compare] allows the module [Bytes] to be passed as argument to the functors {!Set.Make} and {!Map.Make}. *) +val equal: t -> t -> bool +(** The equality function for byte sequences. + @since 4.03.0 *) (** {4 Unsafe conversions (for advanced users)} diff --git a/stdlib/bytesLabels.mli b/stdlib/bytesLabels.mli index d48d95f5c7..04043182f4 100644 --- a/stdlib/bytesLabels.mli +++ b/stdlib/bytesLabels.mli @@ -11,7 +11,9 @@ (* *) (***********************************************************************) -(** Byte sequence operations. *) +(** Byte sequence operations. + @since 4.02.0 + *) external length : bytes -> int = "%string_length" (** Return the length (number of bytes) of the argument. *) diff --git a/stdlib/camlinternalFormat.ml b/stdlib/camlinternalFormat.ml index 77b539161f..a217895fb8 100644 --- a/stdlib/camlinternalFormat.ml +++ b/stdlib/camlinternalFormat.ml @@ -475,6 +475,7 @@ fun buf fmtty -> match fmtty with | 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; + | Any_ty rest -> buffer_add_string buf "%?"; bprint_fmtty buf rest; | Reader_ty rest -> buffer_add_string buf "%r"; bprint_fmtty buf rest; | Ignored_reader_ty rest -> @@ -492,6 +493,12 @@ fun buf fmtty -> match fmtty with (***) +let rec int_of_custom_arity : type a b c . + (a, b, c) custom_arity -> int = + function + | Custom_zero -> 0 + | Custom_succ x -> 1 + int_of_custom_arity x + (* Print a complete format in a buffer. *) let bprint_fmt buf fmt = let rec fmtiter : type a b c d e f . @@ -537,6 +544,12 @@ let bprint_fmt buf fmt = | Theta rest -> buffer_add_char buf '%'; bprint_ignored_flag buf ign_flag; buffer_add_char buf 't'; fmtiter rest false; + | Custom (arity, _, rest) -> + for _i = 1 to int_of_custom_arity arity do + buffer_add_char buf '%'; bprint_ignored_flag buf ign_flag; + buffer_add_char buf '?'; + done; + fmtiter rest false; | Reader rest -> buffer_add_char buf '%'; bprint_ignored_flag buf ign_flag; buffer_add_char buf 'r'; fmtiter rest false; @@ -623,6 +636,7 @@ let rec symm : type a1 b1 c1 d1 e1 f1 a2 b2 c2 d2 e2 f2 . | String_ty rest -> String_ty (symm rest) | Theta_ty rest -> Theta_ty (symm rest) | Alpha_ty rest -> Alpha_ty (symm rest) + | Any_ty rest -> Any_ty (symm rest) | Reader_ty rest -> Reader_ty (symm rest) | Ignored_reader_ty rest -> Ignored_reader_ty (symm rest) | Format_arg_ty (ty, rest) -> @@ -695,6 +709,11 @@ let rec fmtty_rel_det : type a1 b c d1 e1 f1 a2 d2 e2 f2 . (fun Refl -> let Refl = fa Refl in Refl), (fun Refl -> let Refl = af Refl in Refl), ed, de + | Any_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), @@ -765,6 +784,10 @@ and trans : type | Theta_ty _, _ -> assert false | _, Theta_ty _ -> assert false + | Any_ty rest1, Any_ty rest2 -> Any_ty (trans rest1 rest2) + | Any_ty _, _ -> assert false + | _, Any_ty _ -> assert false + | Reader_ty rest1, Reader_ty rest2 -> Reader_ty (trans rest1 rest2) | Reader_ty _, _ -> assert false | _, Reader_ty _ -> assert false @@ -835,6 +858,7 @@ fun fmtty -> match fmtty with | Bool rest -> Bool_ty (fmtty_of_fmt rest) | Alpha rest -> Alpha_ty (fmtty_of_fmt rest) | Theta rest -> Theta_ty (fmtty_of_fmt rest) + | Custom (arity, _, rest) -> fmtty_of_custom arity (fmtty_of_fmt rest) | Reader rest -> Reader_ty (fmtty_of_fmt rest) | Format_arg (_, ty, rest) -> @@ -856,6 +880,13 @@ fun fmtty -> match fmtty with | End_of_format -> End_of_fmtty +and fmtty_of_custom : type x y a b c d e f . + (a, x, y) custom_arity -> (a, b, c, d, e, f) fmtty -> + (y, b, c, d, e, f) fmtty = +fun arity fmtty -> match arity with + | Custom_zero -> fmtty + | Custom_succ arity -> Any_ty (fmtty_of_custom arity 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 . @@ -1332,15 +1363,16 @@ let format_of_iconvn = function (* Generate the format_float first argument form a float_conv. *) let format_of_fconv fconv prec = - let prec = abs prec in - 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 + if fconv = Float_F then "%.12g" else + let prec = abs prec in + let symb = 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 @@ -1424,6 +1456,8 @@ fun k o acc fmt -> match fmt with 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 + | Custom (arity, f, rest) -> + make_custom k o acc rest arity (f ()) | Reader _ -> (* This case is impossible, by typing of formats. *) (* Indeed, since printf and co. take a format4 as argument, the 'd and 'e @@ -1523,6 +1557,7 @@ fun k o acc fmtty fmt -> match fmtty with | 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 + | Any_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 @@ -1649,6 +1684,16 @@ and make_float_padding_precision : type x y a b c d e f . let str = fix_padding padty w (convert_float fconv p x) in make_printf k o (Acc_data_string (acc, str)) fmt +and make_custom : 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 -> + (a, x, y) custom_arity -> x -> y = + fun k o acc rest arity f -> match arity with + | Custom_zero -> make_printf k o (Acc_data_string (acc, f)) rest + | Custom_succ arity -> + fun x -> + make_custom k o acc rest arity (f x) + (******************************************************************************) (* Continuations for make_printf *) @@ -1827,7 +1872,7 @@ let fmt_ebb_of_string ?legacy_behavior str = let legacy_behavior = match legacy_behavior with | Some flag -> flag | None -> true - (** When this flag is enabled, the format parser tries to behave as + (* 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. @@ -2065,6 +2110,30 @@ let fmt_ebb_of_string ?legacy_behavior str = and get_prec () = prec_used := true; prec and get_padprec () = pad_used := true; padprec in + let get_int_pad () = + (* %5.3d is accepted and meaningful: pad to length 5 with + spaces, but first pad with zeros upto length 3 (0-padding + is the interpretation of "precision" for integer formats). + + %05.3d is redundant: pad to length 5 *with zeros*, but + first pad with zeros... To add insult to the injury, the + legacy implementation ignores the 0-padding indication and + does the 5 padding with spaces instead. We reuse this + interpretation for compatiblity, but statically reject this + format when the legacy mode is disabled, to protect strict + users from this corner case. *) + match get_pad (), get_prec () with + | pad, No_precision -> pad + | No_padding, _ -> No_padding + | Lit_padding (Zeros, n), _ -> + if legacy_behavior then Lit_padding (Right, n) + else incompatible_flag pct_ind str_ind '0' "precision" + | Arg_padding Zeros, _ -> + if legacy_behavior then Arg_padding Right + else incompatible_flag pct_ind str_ind '0' "precision" + | Lit_padding _ as pad, _ -> pad + | Arg_padding _ as pad, _ -> pad in + (* Check that padty <> Zeros. *) let check_no_0 symb (type a) (type b) (pad : (a, b) padding) = match pad with @@ -2160,31 +2229,8 @@ let fmt_ebb_of_string ?legacy_behavior str = let ignored = Ignored_int (iconv, get_pad_opt '_') in Fmt_EBB (Ignored_param (ignored, fmt_rest)) else - (* %5.3d is accepted and meaningful: pad to length 5 with - spaces, but first pad with zeros upto length 3 (0-padding - is the interpretation of "precision" for integer formats). - - %05.3d is redundant: pad to length 5 *with zeros*, but - first pad with zeros... To add insult to the injury, the - legacy implementation ignores the 0-padding indication and - does the 5 padding with spaces instead. We reuse this - interpretation for compatiblity, but statically reject this - format when the legacy mode is disabled, to protect strict - users from this corner case. - *) - let pad = match get_pad (), get_prec () with - | pad, No_precision -> pad - | No_padding, _ -> No_padding - | Lit_padding (Zeros, n), _ -> - if legacy_behavior then Lit_padding (Right, n) - else incompatible_flag pct_ind str_ind '0' "precision" - | Arg_padding Zeros, _ -> - if legacy_behavior then Arg_padding Right - else incompatible_flag pct_ind str_ind '0' "precision" - | Lit_padding _ as pad, _ -> pad - | Arg_padding _ as pad, _ -> pad in let Padprec_fmt_EBB (pad', prec', fmt_rest') = - make_padprec_fmt_ebb pad (get_prec ()) fmt_rest in + make_padprec_fmt_ebb (get_int_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 @@ -2193,7 +2239,7 @@ let fmt_ebb_of_string ?legacy_behavior str = let ignored = Ignored_scan_get_counter counter in Fmt_EBB (Ignored_param (ignored, fmt_rest)) else - Fmt_EBB (Scan_get_counter (counter, fmt_rest)) + 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 @@ -2212,7 +2258,7 @@ let fmt_ebb_of_string ?legacy_behavior str = 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 + make_padprec_fmt_ebb (get_int_pad ()) (get_prec ()) fmt_rest in Fmt_EBB (Int32 (iconv, pad', prec', fmt_rest')) | 'n' -> let iconv = @@ -2224,7 +2270,7 @@ let fmt_ebb_of_string ?legacy_behavior str = 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 + make_padprec_fmt_ebb (get_int_pad ()) (get_prec ()) fmt_rest in Fmt_EBB (Nativeint (iconv, pad', prec', fmt_rest')) | 'L' -> let iconv = @@ -2236,7 +2282,7 @@ let fmt_ebb_of_string ?legacy_behavior str = 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 + make_padprec_fmt_ebb (get_int_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 ()) diff --git a/stdlib/camlinternalFormatBasics.ml b/stdlib/camlinternalFormatBasics.ml index f45f434c8f..4e5db73db9 100644 --- a/stdlib/camlinternalFormatBasics.ml +++ b/stdlib/camlinternalFormatBasics.ml @@ -65,6 +65,12 @@ type ('a, 'b) precision = only accept an optional number as precision option (no extra argument) *) type prec_option = int option +(* see the Custom format combinator *) +type ('a, 'b, 'c) custom_arity = + | Custom_zero : ('a, string, 'a) custom_arity + | Custom_succ : ('a, 'b, 'c) custom_arity -> + ('a, 'x -> 'b, 'x -> 'c) custom_arity + (***) (* Relational format types @@ -306,6 +312,11 @@ and ('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 + | Any_ty : (* Used for custom formats *) + ('a1, 'b1, 'c1, 'd1, 'e1, 'f1, + 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel -> + ('x -> 'a1, 'b1, 'c1, 'd1, 'e1, 'f1, + 'x -> 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel (* Scanf specific constructor. *) | Reader_ty : (* %r *) @@ -417,6 +428,32 @@ and ('a, 'b, 'c, 'd, 'e, 'f) fmt = ('a, 'b, 'c, 'd, 'y, 'x) ignored * ('x, 'b, 'c, 'y, 'e, 'f) fmt -> ('a, 'b, 'c, 'd, 'e, 'f) fmt + (* Custom printing format (PR#6452, GPR#140) + + We include a type Custom of "custom converters", where an + arbitrary function can be used to convert one or more + arguments. There is no syntax for custom converters, it is only + inteded for custom processors that wish to rely on the + stdlib-defined format GADTs. + + For instance a pre-processor could choose to interpret strings + prefixed with ["!"] as format strings where [%{{ ... }}] is + a special form to pass a to_string function, so that one could + write: + + {[ + type t = { x : int; y : int } + + let string_of_t t = Printf.sprintf "{ x = %d; y = %d }" t.x t.y + + Printf.printf !"t = %{{string_of_t}}" { x = 42; y = 42 } + ]} + *) + | Custom : + ('a, 'x, 'y) custom_arity * (unit -> 'x) * ('a, 'b, 'c, 'd, 'e, 'f) fmt -> + ('y, 'b, 'c, 'd, 'e, 'f) fmt + + (* end of a format specification *) | End_of_format : ('f, 'b, 'c, 'e, 'e, 'f) fmt @@ -490,6 +527,8 @@ let rec erase_rel : type a b c d e f g h i j k l . Alpha_ty (erase_rel rest) | Theta_ty rest -> Theta_ty (erase_rel rest) + | Any_ty rest -> + Any_ty (erase_rel rest) | Reader_ty rest -> Reader_ty (erase_rel rest) | Ignored_reader_ty rest -> @@ -543,6 +582,8 @@ fun fmtty1 fmtty2 -> match fmtty1 with Alpha_ty (concat_fmtty rest fmtty2) | Theta_ty rest -> Theta_ty (concat_fmtty rest fmtty2) + | Any_ty rest -> + Any_ty (concat_fmtty rest fmtty2) | Reader_ty rest -> Reader_ty (concat_fmtty rest fmtty2) | Ignored_reader_ty rest -> @@ -588,6 +629,8 @@ fun fmt1 fmt2 -> match fmt1 with Alpha (concat_fmt rest fmt2) | Theta rest -> Theta (concat_fmt rest fmt2) + | Custom (arity, f, rest) -> + Custom (arity, f, concat_fmt rest fmt2) | Reader rest -> Reader (concat_fmt rest fmt2) | Flush rest -> diff --git a/stdlib/camlinternalFormatBasics.mli b/stdlib/camlinternalFormatBasics.mli index 4e579f3aa9..80866e8332 100644 --- a/stdlib/camlinternalFormatBasics.mli +++ b/stdlib/camlinternalFormatBasics.mli @@ -29,6 +29,11 @@ type ('a, 'b) precision = type prec_option = int option +type ('a, 'b, 'c) custom_arity = + | Custom_zero : ('a, string, 'a) custom_arity + | Custom_succ : ('a, 'b, 'c) custom_arity -> + ('a, 'x -> 'b, 'x -> 'c) custom_arity + type block_type = Pp_hbox | Pp_vbox | Pp_hvbox | Pp_hovbox | Pp_box | Pp_fits type formatting_lit = @@ -121,6 +126,11 @@ and ('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 +| Any_ty : (* Used for custom formats *) + ('a1, 'b1, 'c1, 'd1, 'e1, 'f1, + 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel -> + ('x -> 'a1, 'b1, 'c1, 'd1, 'e1, 'f1, + 'x -> 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel (* Scanf specific constructor. *) | Reader_ty : (* %r *) @@ -234,6 +244,11 @@ and ('a, 'b, 'c, 'd, 'e, 'f) fmt = ('a, 'b, 'c, 'd, 'y, 'x) ignored * ('x, 'b, 'c, 'y, 'e, 'f) fmt -> ('a, 'b, 'c, 'd, 'e, 'f) fmt +(* Custom printing format *) +| Custom : + ('a, 'x, 'y) custom_arity * (unit -> 'x) * ('a, 'b, 'c, 'd, 'e, 'f) fmt -> + ('y, 'b, 'c, 'd, 'e, 'f) fmt + | End_of_format : ('f, 'b, 'c, 'e, 'e, 'f) fmt diff --git a/stdlib/char.ml b/stdlib/char.ml index 15c4635429..58afbc7585 100644 --- a/stdlib/char.ml +++ b/stdlib/char.ml @@ -19,8 +19,6 @@ external unsafe_chr: int -> char = "%identity" let chr n = if n < 0 || n > 255 then invalid_arg "Char.chr" else unsafe_chr n -external is_printable: char -> bool = "caml_is_printable" - external string_create: int -> string = "caml_create_string" external string_unsafe_get : string -> int -> char = "%string_unsafe_get" external string_unsafe_set : string -> int -> char -> unit @@ -33,12 +31,11 @@ let escaped = function | '\t' -> "\\t" | '\r' -> "\\r" | '\b' -> "\\b" - | c -> - if is_printable c then begin + | ' ' .. '~' as c -> let s = string_create 1 in string_unsafe_set s 0 c; s - end else begin + | c -> let n = code c in let s = string_create 4 in string_unsafe_set s 0 '\\'; @@ -46,7 +43,6 @@ let escaped = function string_unsafe_set s 2 (unsafe_chr (48 + (n / 10) mod 10)); string_unsafe_set s 3 (unsafe_chr (48 + n mod 10)); s - end let lowercase c = if (c >= 'A' && c <= 'Z') @@ -62,6 +58,17 @@ let uppercase c = then unsafe_chr(code c - 32) else c +let lowercase_ascii c = + if (c >= 'A' && c <= 'Z') + then unsafe_chr(code c + 32) + else c + +let uppercase_ascii c = + if (c >= 'a' && c <= 'z') + then unsafe_chr(code c - 32) + else c + type t = char let compare c1 c2 = code c1 - code c2 +let equal (c1: t) (c2: t) = compare c1 c2 = 0 diff --git a/stdlib/char.mli b/stdlib/char.mli index d1baa64d3f..a5ad202114 100644 --- a/stdlib/char.mli +++ b/stdlib/char.mli @@ -23,14 +23,32 @@ val chr : int -> char val escaped : char -> string (** Return a string representing the given character, - with special characters escaped following the lexical conventions - of OCaml. *) + with special characters escaped following the lexical conventions + of OCaml. + All characters outside the ASCII printable range (32..126) are + escaped, as well as backslash, double-quote, and single-quote. *) val lowercase : char -> char -(** Convert the given character to its equivalent lowercase character. *) + [@@ocaml.deprecated "Use Char.lowercase_ascii instead."] +(** Convert the given character to its equivalent lowercase character, + using the ISO Latin-1 (8859-1) character set. + @deprecated Functions operating on Latin-1 character set are deprecated. *) val uppercase : char -> char -(** Convert the given character to its equivalent uppercase character. *) + [@@ocaml.deprecated "Use Char.uppercase_ascii instead."] +(** Convert the given character to its equivalent uppercase character, + using the ISO Latin-1 (8859-1) character set. + @deprecated Functions operating on Latin-1 character set are deprecated. *) + +val lowercase_ascii : char -> char +(** Convert the given character to its equivalent lowercase character, + using the US-ASCII character set. + @since 4.03.0 *) + +val uppercase_ascii : char -> char +(** Convert the given character to its equivalent uppercase character, + using the US-ASCII character set. + @since 4.03.0 *) type t = char (** An alias for the type of characters. *) @@ -41,6 +59,10 @@ val compare: t -> t -> int allows the module [Char] to be passed as argument to the functors {!Set.Make} and {!Map.Make}. *) +val equal: t -> t -> bool +(** The equal function for chars. + @since 4.03.0 *) + (**/**) (* The following is for system use only. Do not call directly. *) diff --git a/stdlib/digest.ml b/stdlib/digest.ml index 14cb4ebd90..aa3dc9eb35 100644 --- a/stdlib/digest.ml +++ b/stdlib/digest.ml @@ -16,6 +16,7 @@ type t = string let compare = String.compare +let equal = String.equal external unsafe_string: string -> int -> int -> t = "caml_md5_string" external channel: in_channel -> int -> t = "caml_md5_chan" @@ -34,9 +35,9 @@ 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 - close_in ic; - d + match channel ic (-1) with + | d -> close_in ic; d + | exception e -> close_in ic; raise e let output chan digest = output_string chan digest diff --git a/stdlib/digest.mli b/stdlib/digest.mli index 583d2a46b0..29e5b3973e 100644 --- a/stdlib/digest.mli +++ b/stdlib/digest.mli @@ -33,11 +33,16 @@ val compare : t -> t -> int argument to the functors {!Set.Make} and {!Map.Make}. @since 4.00.0 *) +val equal : t -> t -> bool +(** The equal function for 16-character digest. + @since 4.03.0 *) + val string : string -> t (** Return the digest of the given string. *) val bytes : bytes -> t -(** Return the digest of the given byte sequence. *) +(** Return the digest of the given byte sequence. + @since 4.02.0 *) val substring : string -> int -> int -> t (** [Digest.substring s ofs len] returns the digest of the substring @@ -45,7 +50,8 @@ val substring : string -> int -> int -> t 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. *) + of [s] starting at index [ofs] and containing [len] bytes. + @since 4.02.0 *) external channel : in_channel -> int -> t = "caml_md5_chan" (** If [len] is nonnegative, [Digest.channel ic len] reads [len] diff --git a/stdlib/filename.ml b/stdlib/filename.ml index db15169a04..526b763a3e 100644 --- a/stdlib/filename.ml +++ b/stdlib/filename.ml @@ -107,7 +107,7 @@ module Win32 = struct String.length name >= String.length suff && (let s = String.sub name (String.length name - String.length suff) (String.length suff) in - String.lowercase s = String.lowercase suff) + String.lowercase_ascii s = String.lowercase_ascii suff) let temp_dir_name = try Sys.getenv "TEMP" with Not_found -> "." let quote s = @@ -230,13 +230,13 @@ let temp_file ?(temp_dir = !current_temp_dir_name) prefix suffix = if counter >= 1000 then raise e else try_name (counter + 1) in try_name 0 -let open_temp_file ?(mode = [Open_text]) ?(temp_dir = !current_temp_dir_name) - prefix suffix = +let open_temp_file ?(mode = [Open_text]) ?(perms = 0o600) + ?(temp_dir = !current_temp_dir_name) prefix suffix = let rec try_name counter = let name = temp_file_name temp_dir prefix suffix in try (name, - open_out_gen (Open_wronly::Open_creat::Open_excl::mode) 0o600 name) + open_out_gen (Open_wronly::Open_creat::Open_excl::mode) perms name) with Sys_error _ as e -> if counter >= 1000 then raise e else try_name (counter + 1) in try_name 0 diff --git a/stdlib/filename.mli b/stdlib/filename.mli index c2cc6a486a..dbdeb50236 100644 --- a/stdlib/filename.mli +++ b/stdlib/filename.mli @@ -87,8 +87,8 @@ val temp_file : ?temp_dir: string -> string -> string -> string *) val open_temp_file : - ?mode: open_flag list -> ?temp_dir: string -> string -> string -> - string * out_channel + ?mode: open_flag list -> ?perms: int -> ?temp_dir: string -> string -> + string -> string * out_channel (** Same as {!Filename.temp_file}, but returns both the name of a fresh temporary file, and an output channel opened (atomically) on this file. This function is more secure than [temp_file]: there @@ -96,8 +96,12 @@ val open_temp_file : by a symbolic link) before the program opens it. The optional argument [mode] is a list of additional flags to control the opening of the file. It can contain one or several of [Open_append], [Open_binary], - and [Open_text]. The default is [[Open_text]] (open in text mode). - Raise [Sys_error] if the file could not be opened. + and [Open_text]. The default is [[Open_text]] (open in text mode). The + file is created with permissions [perms] (defaults to readable and + writable only by the file owner, [0o600]). + + @raise Sys_error if the file could not be opened. + @before 4.03.0 no ?perms optional argument @before 3.11.2 no ?temp_dir optional argument *) diff --git a/stdlib/format.ml b/stdlib/format.ml index 5e206e11f6..1d196a51bd 100644 --- a/stdlib/format.ml +++ b/stdlib/format.ml @@ -976,6 +976,12 @@ let flush_str_formatter () = s ;; +let flush_buf_formatter buf ppf = + pp_flush_queue ppf false; + let s = Buffer.contents buf in + Buffer.reset buf; + s + (************************************************************** Basic functions on the standard formatter @@ -1176,12 +1182,11 @@ let printf fmt = fprintf std_formatter fmt let eprintf fmt = fprintf err_formatter fmt let ksprintf k (Format (fmt, _)) = + let b = Buffer.create 512 in + let ppf = formatter_of_buffer b in 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 + k (flush_buf_formatter b ppf) in make_printf k' () End_of_acc fmt let sprintf fmt = @@ -1194,7 +1199,7 @@ let asprintf (Format (fmt, _)) = = fun ppf acc -> output_acc ppf acc; pp_flush_queue ppf false; - Buffer.contents b in + flush_buf_formatter b ppf in make_printf k' ppf End_of_acc fmt (************************************************************** diff --git a/stdlib/format.mli b/stdlib/format.mli index 541ffbe390..05e153b2e8 100644 --- a/stdlib/format.mli +++ b/stdlib/format.mli @@ -74,7 +74,7 @@ (** {6 Boxes} *) -val open_box : int -> unit;; +val open_box : int -> unit (** [open_box d] opens a new pretty-printing box with offset [d]. This box is the general purpose pretty-printing box. @@ -86,41 +86,41 @@ val open_box : int -> unit;; When a new line is printed in the box, [d] is added to the current indentation. *) -val close_box : unit -> unit;; +val close_box : unit -> unit (** Closes the most recently opened pretty-printing box. *) (** {6 Formatting functions} *) -val print_string : string -> unit;; +val print_string : string -> unit (** [print_string str] prints [str] in the current box. *) -val print_as : int -> string -> unit;; +val print_as : int -> string -> unit (** [print_as len str] prints [str] in the current box. The pretty-printer formats [str] as if it were of length [len]. *) -val print_int : int -> unit;; +val print_int : int -> unit (** Prints an integer in the current box. *) -val print_float : float -> unit;; +val print_float : float -> unit (** Prints a floating point number in the current box. *) -val print_char : char -> unit;; +val print_char : char -> unit (** Prints a character in the current box. *) -val print_bool : bool -> unit;; +val print_bool : bool -> unit (** Prints a boolean in the current box. *) (** {6 Break hints} *) -val print_space : unit -> unit;; +val print_space : unit -> unit (** [print_space ()] is used to separate items (typically to print a space between two words). It indicates that the line may be split at this point. It either prints one space or splits the line. It is equivalent to [print_break 1 0]. *) -val print_cut : unit -> unit;; +val print_cut : unit -> unit (** [print_cut ()] is used to mark a good break position. It indicates that the line may be split at this point. It either prints nothing or splits the line. @@ -128,7 +128,7 @@ val print_cut : unit -> unit;; point, without printing spaces or adding indentation. It is equivalent to [print_break 0 0]. *) -val print_break : int -> int -> unit;; +val print_break : int -> int -> unit (** Inserts a break hint in a pretty-printing box. [print_break nspaces offset] indicates that the line may be split (a newline character is printed) at this point, @@ -138,25 +138,25 @@ val print_break : int -> int -> unit;; the current indentation. If the line is not split, [nspaces] spaces are printed. *) -val print_flush : unit -> unit;; +val print_flush : unit -> unit (** Flushes the pretty printer: all opened boxes are closed, and all pending text is displayed. *) -val print_newline : unit -> unit;; +val print_newline : unit -> unit (** Equivalent to [print_flush] followed by a new line. *) -val force_newline : unit -> unit;; +val force_newline : unit -> unit (** Forces a newline in the current box. Not the normal way of pretty-printing, you should prefer break hints. *) -val print_if_newline : unit -> unit;; +val print_if_newline : unit -> unit (** Executes the next formatting command if the preceding line has just been split. Otherwise, ignore the next formatting command. *) (** {6 Margin} *) -val set_margin : int -> unit;; +val set_margin : int -> unit (** [set_margin d] sets the value of the right margin to [d] (in characters): this value is used to detect line overflows that leads to split lines. @@ -164,12 +164,12 @@ val set_margin : int -> unit;; If [d] is too large, the right margin is set to the maximum admissible value (which is greater than [10^9]). *) -val get_margin : unit -> int;; +val get_margin : unit -> int (** Returns the position of the right margin. *) (** {6 Maximum indentation limit} *) -val set_max_indent : int -> unit;; +val set_max_indent : int -> unit (** [set_max_indent d] sets the value of the maximum indentation limit to [d] (in characters): once this limit is reached, boxes are rejected to the left, @@ -178,32 +178,32 @@ val set_max_indent : int -> unit;; If [d] is too large, the limit is set to the maximum admissible value (which is greater than [10^9]). *) -val get_max_indent : unit -> int;; +val get_max_indent : unit -> int (** Return the value of the maximum indentation limit (in characters). *) (** {6 Formatting depth: maximum number of boxes allowed before ellipsis} *) -val set_max_boxes : int -> unit;; +val set_max_boxes : int -> unit (** [set_max_boxes max] sets the maximum number of boxes simultaneously opened. Material inside boxes nested deeper is printed as an ellipsis (more precisely as the text returned by [get_ellipsis_text ()]). Nothing happens if [max] is smaller than 2. *) -val get_max_boxes : unit -> int;; +val get_max_boxes : unit -> int (** Returns the maximum number of boxes allowed before ellipsis. *) -val over_max_boxes : unit -> bool;; +val over_max_boxes : unit -> bool (** Tests if the maximum number of boxes allowed have already been opened. *) (** {6 Advanced formatting} *) -val open_hbox : unit -> unit;; +val open_hbox : unit -> unit (** [open_hbox ()] opens a new pretty-printing box. This box is 'horizontal': the line is not split in this box (new lines may still occur inside boxes nested deeper). *) -val open_vbox : int -> unit;; +val open_vbox : int -> unit (** [open_vbox d] opens a new pretty-printing box with offset [d]. This box is 'vertical': every break hint inside this @@ -211,7 +211,7 @@ val open_vbox : int -> unit;; When a new line is printed in the box, [d] is added to the current indentation. *) -val open_hvbox : int -> unit;; +val open_hvbox : int -> unit (** [open_hvbox d] opens a new pretty-printing box with offset [d]. This box is 'horizontal-vertical': it behaves as an @@ -220,7 +220,7 @@ val open_hvbox : int -> unit;; When a new line is printed in the box, [d] is added to the current indentation. *) -val open_hovbox : int -> unit;; +val open_hovbox : int -> unit (** [open_hovbox d] opens a new pretty-printing box with offset [d]. This box is 'horizontal or vertical': break hints @@ -231,13 +231,13 @@ val open_hovbox : int -> unit;; (** {6 Tabulations} *) -val open_tbox : unit -> unit;; +val open_tbox : unit -> unit (** Opens a tabulation box. *) -val close_tbox : unit -> unit;; +val close_tbox : unit -> unit (** Closes the most recently opened tabulation box. *) -val print_tbreak : int -> int -> unit;; +val print_tbreak : int -> int -> unit (** Break hint in a tabulation box. [print_tbreak spaces offset] moves the insertion point to the next tabulation ([spaces] being added to this position). @@ -249,24 +249,24 @@ val print_tbreak : int -> int -> unit;; If a new line is printed, [offset] is added to the current indentation. *) -val set_tab : unit -> unit;; +val set_tab : unit -> unit (** Sets a tabulation mark at the current insertion point. *) -val print_tab : unit -> unit;; +val print_tab : unit -> unit (** [print_tab ()] is equivalent to [print_tbreak 0 0]. *) (** {6 Ellipsis} *) -val set_ellipsis_text : string -> unit;; +val set_ellipsis_text : string -> unit (** Set the text of the ellipsis printed when too many boxes are opened (a single dot, [.], by default). *) -val get_ellipsis_text : unit -> string;; +val get_ellipsis_text : unit -> string (** Return the text of the ellipsis. *) (** {6:tags Semantics Tags} *) -type tag = string;; +type tag = string (** {i Semantics tags} (or simply {e tags}) are used to decorate printed entities for user's defined purposes, e.g. setting font and giving size @@ -315,38 +315,42 @@ type tag = string;; Tag marking and tag printing functions are user definable and can be set by calling [set_formatter_tag_functions]. *) -val open_tag : tag -> unit;; +val open_tag : tag -> unit (** [open_tag t] opens the tag named [t]; the [print_open_tag] function of the formatter is called with [t] as argument; the tag marker [mark_open_tag t] will be flushed into the output device of the formatter. *) -val close_tag : unit -> unit;; +val close_tag : unit -> unit (** [close_tag ()] closes the most recently opened tag [t]. In addition, the [print_close_tag] function of the formatter is called with [t] as argument. The marker [mark_close_tag t] will be flushed into the output device of the formatter. *) -val set_tags : bool -> unit;; +val set_tags : bool -> unit (** [set_tags b] turns on or off the treatment of tags (default is off). *) -val set_print_tags : bool -> unit;; -val set_mark_tags : bool -> unit;; -(** [set_print_tags b] turns on or off the printing of tags, while - [set_mark_tags b] turns on or off the output of tag markers. *) -val get_print_tags : unit -> bool;; -val get_mark_tags : unit -> bool;; -(** Return the current status of tags printing and tags marking. *) + +val set_print_tags : bool -> unit +(**[set_print_tags b] turns on or off the printing of tags. *) + +val set_mark_tags : bool -> unit +(** [set_mark_tags b] turns on or off the output of tag markers. *) + +val get_print_tags : unit -> bool +(** Return the current status of tags printing. *) + +val get_mark_tags : unit -> bool +(** Return the current status of tags marking. *) (** {6 Redirecting the standard formatter output} *) -val set_formatter_out_channel : Pervasives.out_channel -> unit;; +val set_formatter_out_channel : Pervasives.out_channel -> unit (** Redirect the pretty-printer output to the given channel. (All the output functions of the standard formatter are set to the default output functions printing to the given channel.) *) val set_formatter_output_functions : (string -> int -> int -> unit) -> (unit -> unit) -> unit -;; (** [set_formatter_output_functions out flush] redirects the pretty-printer output functions to the functions [out] and [flush]. @@ -362,7 +366,6 @@ val set_formatter_output_functions : val get_formatter_output_functions : unit -> (string -> int -> int -> unit) * (unit -> unit) -;; (** Return the current output functions of the pretty-printer. *) (** {6:meaning Changing the meaning of standard formatter pretty printing} *) @@ -378,9 +381,9 @@ type formatter_out_functions = { out_newline : unit -> unit; out_spaces : int -> unit; } -;; -val set_formatter_out_functions : formatter_out_functions -> unit;; + +val set_formatter_out_functions : formatter_out_functions -> unit (** [set_formatter_out_functions f] Redirect the pretty-printer output to the functions [f.out_string] and [f.out_flush] as described in @@ -397,7 +400,7 @@ val set_formatter_out_functions : formatter_out_functions -> unit;; default values for [f.out_space] and [f.out_newline] are [f.out_string (String.make n ' ') 0 n] and [f.out_string "\n" 0 1]. *) -val get_formatter_out_functions : unit -> formatter_out_functions;; +val get_formatter_out_functions : unit -> formatter_out_functions (** Return the current output functions of the pretty-printer, including line breaking and indentation functions. Useful to record the current setting and restore it afterwards. *) @@ -410,7 +413,6 @@ type formatter_tag_functions = { print_open_tag : tag -> unit; print_close_tag : tag -> unit; } -;; (** The tag handling functions specific to a formatter: [mark] versions are the 'tag marking' functions that associate a string marker to a tag in order for the pretty-printing engine to flush @@ -418,7 +420,7 @@ type formatter_tag_functions = { [print] versions are the 'tag printing' functions that can perform regular printing when a tag is closed or opened. *) -val set_formatter_tag_functions : formatter_tag_functions -> unit;; +val set_formatter_tag_functions : formatter_tag_functions -> unit (** [set_formatter_tag_functions tag_funs] changes the meaning of opening and closing tags to use the functions in [tag_funs]. @@ -434,12 +436,12 @@ val set_formatter_tag_functions : formatter_tag_functions -> unit;; called at tag opening and tag closing time, to output regular material in the pretty-printer queue. *) -val get_formatter_tag_functions : unit -> formatter_tag_functions;; +val get_formatter_tag_functions : unit -> formatter_tag_functions (** Return the current tag functions of the pretty-printer. *) (** {6 Multiple formatted output} *) -type formatter;; +type formatter (** Abstract data corresponding to a pretty-printer (also called a formatter) and all its machinery. @@ -457,40 +459,39 @@ type formatter;; (convenient to output material to strings for instance). *) -val formatter_of_out_channel : out_channel -> formatter;; +val formatter_of_out_channel : out_channel -> formatter (** [formatter_of_out_channel oc] returns a new formatter that writes to the corresponding channel [oc]. *) -val std_formatter : formatter;; +val std_formatter : formatter (** The standard formatter used by the formatting functions above. It is defined as [formatter_of_out_channel stdout]. *) -val err_formatter : formatter;; +val err_formatter : formatter (** A formatter to use with formatting functions below for output to standard error. It is defined as [formatter_of_out_channel stderr]. *) -val formatter_of_buffer : Buffer.t -> formatter;; +val formatter_of_buffer : Buffer.t -> formatter (** [formatter_of_buffer b] returns a new formatter writing to buffer [b]. As usual, the formatter has to be flushed at the end of pretty printing, using [pp_print_flush] or [pp_print_newline], to display all the pending material. *) -val stdbuf : Buffer.t;; +val stdbuf : Buffer.t (** The string buffer in which [str_formatter] writes. *) -val str_formatter : formatter;; +val str_formatter : formatter (** A formatter to use with formatting functions below for output to the [stdbuf] string buffer. [str_formatter] is defined as [formatter_of_buffer stdbuf]. *) -val flush_str_formatter : unit -> string;; +val flush_str_formatter : unit -> string (** Returns the material printed with [str_formatter], flushes the formatter and resets the corresponding buffer. *) val make_formatter : (string -> int -> int -> unit) -> (unit -> unit) -> formatter -;; (** [make_formatter out flush] returns a new formatter that writes according to the output function [out], and the flushing function [flush]. For instance, a formatter to the [Pervasives.out_channel] [oc] is returned by @@ -498,67 +499,66 @@ val make_formatter : (** {6 Basic functions to use with formatters} *) -val pp_open_hbox : formatter -> unit -> unit;; -val pp_open_vbox : formatter -> int -> unit;; -val pp_open_hvbox : formatter -> int -> unit;; -val pp_open_hovbox : formatter -> int -> unit;; -val pp_open_box : formatter -> int -> unit;; -val pp_close_box : formatter -> unit -> unit;; -val pp_open_tag : formatter -> string -> unit;; -val pp_close_tag : formatter -> unit -> unit;; -val pp_print_string : formatter -> string -> unit;; -val pp_print_as : formatter -> int -> string -> unit;; -val pp_print_int : formatter -> int -> unit;; -val pp_print_float : formatter -> float -> unit;; -val pp_print_char : formatter -> char -> unit;; -val pp_print_bool : formatter -> bool -> unit;; -val pp_print_break : formatter -> int -> int -> unit;; -val pp_print_cut : formatter -> unit -> unit;; -val pp_print_space : formatter -> unit -> unit;; -val pp_force_newline : formatter -> unit -> unit;; -val pp_print_flush : formatter -> unit -> unit;; -val pp_print_newline : formatter -> unit -> unit;; -val pp_print_if_newline : formatter -> unit -> unit;; -val pp_open_tbox : formatter -> unit -> unit;; -val pp_close_tbox : formatter -> unit -> unit;; -val pp_print_tbreak : formatter -> int -> int -> unit;; -val pp_set_tab : formatter -> unit -> unit;; -val pp_print_tab : formatter -> unit -> unit;; -val pp_set_tags : formatter -> bool -> unit;; -val pp_set_print_tags : formatter -> bool -> unit;; -val pp_set_mark_tags : formatter -> bool -> unit;; -val pp_get_print_tags : formatter -> unit -> bool;; -val pp_get_mark_tags : formatter -> unit -> bool;; -val pp_set_margin : formatter -> int -> unit;; -val pp_get_margin : formatter -> unit -> int;; -val pp_set_max_indent : formatter -> int -> unit;; -val pp_get_max_indent : formatter -> unit -> int;; -val pp_set_max_boxes : formatter -> int -> unit;; -val pp_get_max_boxes : formatter -> unit -> int;; -val pp_over_max_boxes : formatter -> unit -> bool;; -val pp_set_ellipsis_text : formatter -> string -> unit;; -val pp_get_ellipsis_text : formatter -> unit -> string;; +val pp_open_hbox : formatter -> unit -> unit +val pp_open_vbox : formatter -> int -> unit +val pp_open_hvbox : formatter -> int -> unit +val pp_open_hovbox : formatter -> int -> unit +val pp_open_box : formatter -> int -> unit +val pp_close_box : formatter -> unit -> unit +val pp_open_tag : formatter -> string -> unit +val pp_close_tag : formatter -> unit -> unit +val pp_print_string : formatter -> string -> unit +val pp_print_as : formatter -> int -> string -> unit +val pp_print_int : formatter -> int -> unit +val pp_print_float : formatter -> float -> unit +val pp_print_char : formatter -> char -> unit +val pp_print_bool : formatter -> bool -> unit +val pp_print_break : formatter -> int -> int -> unit +val pp_print_cut : formatter -> unit -> unit +val pp_print_space : formatter -> unit -> unit +val pp_force_newline : formatter -> unit -> unit +val pp_print_flush : formatter -> unit -> unit +val pp_print_newline : formatter -> unit -> unit +val pp_print_if_newline : formatter -> unit -> unit +val pp_open_tbox : formatter -> unit -> unit +val pp_close_tbox : formatter -> unit -> unit +val pp_print_tbreak : formatter -> int -> int -> unit +val pp_set_tab : formatter -> unit -> unit +val pp_print_tab : formatter -> unit -> unit +val pp_set_tags : formatter -> bool -> unit +val pp_set_print_tags : formatter -> bool -> unit +val pp_set_mark_tags : formatter -> bool -> unit +val pp_get_print_tags : formatter -> unit -> bool +val pp_get_mark_tags : formatter -> unit -> bool +val pp_set_margin : formatter -> int -> unit +val pp_get_margin : formatter -> unit -> int +val pp_set_max_indent : formatter -> int -> unit +val pp_get_max_indent : formatter -> unit -> int +val pp_set_max_boxes : formatter -> int -> unit +val pp_get_max_boxes : formatter -> unit -> int +val pp_over_max_boxes : formatter -> unit -> bool +val pp_set_ellipsis_text : formatter -> string -> unit +val pp_get_ellipsis_text : formatter -> unit -> string val pp_set_formatter_out_channel : formatter -> Pervasives.out_channel -> unit -;; + val pp_set_formatter_output_functions : formatter -> (string -> int -> int -> unit) -> (unit -> unit) -> unit -;; + val pp_get_formatter_output_functions : formatter -> unit -> (string -> int -> int -> unit) * (unit -> unit) -;; + val pp_set_formatter_tag_functions : formatter -> formatter_tag_functions -> unit -;; + val pp_get_formatter_tag_functions : formatter -> unit -> formatter_tag_functions -;; + val pp_set_formatter_out_functions : formatter -> formatter_out_functions -> unit -;; + val pp_get_formatter_out_functions : formatter -> unit -> formatter_out_functions -;; (** These functions are the basic ones: usual functions operating on the standard formatter are defined via partial evaluation of these primitives. For instance, @@ -587,7 +587,7 @@ val pp_print_text : formatter -> string -> unit (** {6 [printf] like functions for pretty-printing.} *) -val fprintf : formatter -> ('a, formatter, unit) format -> 'a;; +val fprintf : formatter -> ('a, formatter, unit) format -> 'a (** [fprintf ff fmt arg1 ... argN] formats the arguments [arg1] to [argN] according to the format string [fmt], and outputs the resulting string on @@ -656,13 +656,13 @@ val fprintf : formatter -> ('a, formatter, unit) format -> 'a;; *) -val printf : ('a, formatter, unit) format -> 'a;; +val printf : ('a, formatter, unit) format -> 'a (** Same as [fprintf] above, but output on [std_formatter]. *) -val eprintf : ('a, formatter, unit) format -> 'a;; +val eprintf : ('a, formatter, unit) format -> 'a (** Same as [fprintf] above, but output on [err_formatter]. *) -val sprintf : ('a, unit, string) format -> 'a;; +val sprintf : ('a, unit, string) format -> 'a (** Same as [printf] above, but instead of printing on a formatter, returns a string containing the result of formatting the arguments. Note that the pretty-printer queue is flushed at the end of {e each @@ -678,7 +678,7 @@ val sprintf : ('a, unit, string) format -> 'a;; pretty-printing returns the desired string. *) -val asprintf : ('a, formatter, unit, string) format4 -> 'a;; +val asprintf : ('a, formatter, unit, string) format4 -> 'a (** Same as [printf] above, but instead of printing on a formatter, returns a string containing the result of formatting the arguments. The type of [asprintf] is general enough to interact nicely with [%a] @@ -686,7 +686,7 @@ val asprintf : ('a, formatter, unit, string) format4 -> 'a;; @since 4.01.0 *) -val ifprintf : formatter -> ('a, formatter, unit) format -> 'a;; +val ifprintf : formatter -> ('a, formatter, unit) format -> 'a (** Same as [fprintf] above, but does not print anything. Useful to ignore some material when conditionally printing. @since 3.10.0 @@ -696,19 +696,17 @@ val ifprintf : formatter -> ('a, formatter, unit) format -> 'a;; val kfprintf : (formatter -> 'a) -> formatter -> ('b, formatter, unit, 'a) format4 -> 'b -;; (** Same as [fprintf] above, but instead of returning immediately, passes the formatter to its first argument at the end of printing. *) val ikfprintf : (formatter -> 'a) -> formatter -> ('b, formatter, unit, 'a) format4 -> 'b -;; (** Same as [kfprintf] above, but does not print anything. Useful to ignore some material when conditionally printing. @since 3.12.0 *) -val ksprintf : (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b;; +val ksprintf : (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b (** Same as [sprintf] above, but instead of returning the string, passes it to the first argument. *) @@ -716,7 +714,6 @@ val ksprintf : (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b;; 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 @@ -725,7 +722,6 @@ val bprintf : Buffer.t -> ('a, formatter, unit) format -> 'a val kprintf : (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b [@@ocaml.deprecated "Use Format.ksprintf instead."] -;; (** @deprecated An alias for [ksprintf]. *) val set_all_formatter_output_functions : @@ -735,9 +731,7 @@ val set_all_formatter_output_functions : spaces:(int -> unit) -> unit [@@ocaml.deprecated "Use Format.set_formatter_out_functions instead."] -;; -(** @deprecated Subsumed by [set_formatter_out_functions]. -*) +(** @deprecated Subsumed by [set_formatter_out_functions]. *) val get_all_formatter_output_functions : unit -> @@ -746,22 +740,17 @@ val get_all_formatter_output_functions : (unit -> unit) * (int -> unit) [@@ocaml.deprecated "Use Format.get_formatter_out_functions instead."] -;; -(** @deprecated Subsumed by [get_formatter_out_functions]. -*) +(** @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 "Use Format.pp_set_formatter_out_functions instead."] -;; -(** @deprecated Subsumed by [pp_set_formatter_out_functions]. -*) +(** @deprecated Subsumed by [pp_set_formatter_out_functions]. *) val pp_get_all_formatter_output_functions : formatter -> unit -> (string -> int -> int -> unit) * (unit -> unit) * (unit -> unit) * (int -> unit) [@@ocaml.deprecated "Use Format.pp_get_formatter_out_functions instead."] -;; -(** @deprecated Subsumed by [pp_get_formatter_out_functions]. -*) +(** @deprecated Subsumed by [pp_get_formatter_out_functions]. *) diff --git a/stdlib/gc.mli b/stdlib/gc.mli index f86a1e687a..d07b3c1fbe 100644 --- a/stdlib/gc.mli +++ b/stdlib/gc.mli @@ -113,8 +113,8 @@ type control = - [0x020] Change of GC parameters. - [0x040] Computation of major GC slice size. - [0x080] Calling of finalisation functions. - - [0x100] Bytecode executable search at start-up. - - [0x200] Computation of compaction triggering condition. + - [0x100] Bytecode executable and shared library search at start-up. + - [0x200] Computation of compaction-triggering condition. Default: 0. *) mutable max_overhead : int; @@ -201,7 +201,8 @@ val finalise : ('a -> unit) -> 'a -> unit (** [finalise f v] registers [f] as a finalisation function for [v]. [v] must be heap-allocated. [f] will be called with [v] as argument at some point between the first time [v] becomes unreachable - and the time [v] is collected by the GC. Several functions can + (including through weak pointers) and the time [v] is collected by + the GC. Several functions can be registered for the same value, or even several instances of the same function. Each instance will be called once (or never, if the program terminates before [v] becomes unreachable). @@ -221,9 +222,10 @@ val finalise : ('a -> unit) -> 'a -> unit Anything reachable from the closure of finalisation functions is considered reachable, so the following code will not work as expected: - - [ let v = ... in Gc.finalise (fun x -> ...) v ] + - [ let v = ... in Gc.finalise (fun _ -> ...v...) v ] - Instead you should write: + Instead you should make sure that [v] is not in the closure of + the finalisation function by writing: - [ let f = fun x -> ... ;; let v = ... in Gc.finalise f v ] @@ -239,17 +241,16 @@ val finalise : ('a -> unit) -> 'a -> unit [finalise] will raise [Invalid_argument] if [v] is not - heap-allocated. Some examples of values that are not + guaranteed to be heap-allocated. Some examples of values that are not heap-allocated are integers, constant constructors, booleans, the empty array, the empty list, the unit value. The exact list of what is heap-allocated or not is implementation-dependent. Some constant values can be heap-allocated but never deallocated during the lifetime of the program, for example a list of integer constants; this is also implementation-dependent. - You should also be aware that compiler optimisations may duplicate - some immutable values, for example floating-point numbers when - stored into arrays, so they can be finalised and collected while - another copy is still in use by the program. + Note that values of types [float] and ['a lazy] (for any ['a]) are + sometimes allocated and sometimes not, so finalising them is unsafe, + and [finalise] will also raise [Invalid_argument] for them. The results of calling {!String.make}, {!Bytes.make}, {!Bytes.create}, diff --git a/stdlib/hashtbl.mli b/stdlib/hashtbl.mli index 0c3e4999f3..386f5a6cc9 100644 --- a/stdlib/hashtbl.mli +++ b/stdlib/hashtbl.mli @@ -345,7 +345,9 @@ val hash_param : int -> int -> 'a -> int hashing. Hashing performs a breadth-first, left-to-right traversal of the structure [x], stopping after [meaningful] meaningful nodes were encountered, or [total] nodes (meaningful or not) were - encountered. Meaningful nodes are: integers; floating-point + encountered. If [total] as specified by the user exceeds a certain + value, currently 256, then it is capped to that value. + Meaningful nodes are: integers; floating-point numbers; strings; characters; booleans; and constant constructors. Larger values of [meaningful] and [total] means that more nodes are taken into account to compute the final hash value, diff --git a/stdlib/header.c b/stdlib/header.c index 93cdfeb2dc..6f3dc5496a 100644 --- a/stdlib/header.c +++ b/stdlib/header.c @@ -23,8 +23,8 @@ #include <fcntl.h> #include <sys/types.h> #include <sys/stat.h> -#include "../byterun/mlvalues.h" -#include "../byterun/exec.h" +#include "../byterun/caml/mlvalues.h" +#include "../byterun/caml/exec.h" char * default_runtime_path = RUNTIME_NAME; @@ -40,7 +40,7 @@ char * default_runtime_path = RUNTIME_NAME; #define SEEK_END 2 #endif -#ifndef __CYGWIN32__ +#ifndef __CYGWIN__ /* Normal Unix search path function */ diff --git a/stdlib/headernt.c b/stdlib/headernt.c index aa113ac9d2..e95223dbc1 100644 --- a/stdlib/headernt.c +++ b/stdlib/headernt.c @@ -15,8 +15,8 @@ #define WIN32_LEAN_AND_MEAN #include <windows.h> -#include "mlvalues.h" -#include "exec.h" +#include "caml/mlvalues.h" +#include "caml/exec.h" #ifndef __MINGW32__ #pragma comment(linker , "/entry:headerentry") diff --git a/stdlib/int32.ml b/stdlib/int32.ml index e8e55ddc84..63c99e3d42 100644 --- a/stdlib/int32.ml +++ b/stdlib/int32.ml @@ -50,3 +50,4 @@ external of_string : string -> int32 = "caml_int32_of_string" type t = int32 let compare (x: t) (y: t) = Pervasives.compare x y +let equal (x: t) (y: t) = compare x y = 0 diff --git a/stdlib/int32.mli b/stdlib/int32.mli index fcd300a2d5..4a29e6c0f2 100644 --- a/stdlib/int32.mli +++ b/stdlib/int32.mli @@ -153,6 +153,10 @@ val compare: t -> t -> int allows the module [Int32] to be passed as argument to the functors {!Set.Make} and {!Map.Make}. *) +val equal: t -> t -> bool +(** The equal function for int32s. + @since 4.03.0 *) + (**/**) (** {6 Deprecated functions} *) diff --git a/stdlib/int64.ml b/stdlib/int64.ml index aa4add5f1b..274a9868d9 100644 --- a/stdlib/int64.ml +++ b/stdlib/int64.ml @@ -55,3 +55,4 @@ external float_of_bits : int64 -> float = "caml_int64_float_of_bits" type t = int64 let compare (x: t) (y: t) = Pervasives.compare x y +let equal (x: t) (y: t) = compare x y = 0 diff --git a/stdlib/int64.mli b/stdlib/int64.mli index 09b476f15a..edd600c690 100644 --- a/stdlib/int64.mli +++ b/stdlib/int64.mli @@ -175,6 +175,10 @@ val compare: t -> t -> int allows the module [Int64] to be passed as argument to the functors {!Set.Make} and {!Map.Make}. *) +val equal: t -> t -> bool +(** The equal function for int64s. + @since 4.03.0 *) + (**/**) (** {6 Deprecated functions} *) diff --git a/stdlib/list.ml b/stdlib/list.ml index 007a3ca764..e62af44874 100644 --- a/stdlib/list.ml +++ b/stdlib/list.ml @@ -19,6 +19,8 @@ let rec length_aux len = function let length l = length_aux 0 l +let cons a l = a::l + let hd = function [] -> failwith "hd" | a::l -> a diff --git a/stdlib/list.mli b/stdlib/list.mli index b53a63c646..77cf5d5db6 100644 --- a/stdlib/list.mli +++ b/stdlib/list.mli @@ -27,6 +27,11 @@ val length : 'a list -> int (** Return the length (number of elements) of the given list. *) +val cons : 'a -> 'a list -> 'a list +(** [cons x xs] is [x :: xs] + @since 4.03.0 +*) + val hd : 'a list -> 'a (** Return the first element of the given list. Raise [Failure "hd"] if the list is empty. *) @@ -279,7 +284,8 @@ val fast_sort : ('a -> 'a -> int) -> 'a list -> 'a list on typical input. *) val sort_uniq : ('a -> 'a -> int) -> 'a list -> 'a list -(** Same as {!List.sort}, but also remove duplicates. *) +(** Same as {!List.sort}, but also remove duplicates. + @since 4.02.0 *) val merge : ('a -> 'a -> int) -> 'a list -> 'a list -> 'a list (** Merge two lists: diff --git a/stdlib/listLabels.mli b/stdlib/listLabels.mli index 45e3c41ea1..a37056b414 100644 --- a/stdlib/listLabels.mli +++ b/stdlib/listLabels.mli @@ -50,7 +50,7 @@ val append : 'a list -> 'a list -> 'a list operator is not tail-recursive either. *) val rev_append : 'a list -> 'a list -> 'a list -(** [List.rev_append l1 l2] reverses [l1] and concatenates it to [l2]. +(** [ListLabels.rev_append l1 l2] reverses [l1] and concatenates it to [l2]. This is equivalent to {!ListLabels.rev}[ l1 @ l2], but [rev_append] is tail-recursive and more efficient. *) @@ -69,40 +69,40 @@ val flatten : 'a list list -> 'a list val iter : f:('a -> unit) -> 'a list -> unit -(** [List.iter f [a1; ...; an]] applies function [f] in turn to +(** [ListLabels.iter f [a1; ...; an]] applies function [f] in turn to [a1; ...; an]. It is equivalent to [begin f a1; f a2; ...; f an; () end]. *) val iteri : f:(int -> 'a -> unit) -> 'a list -> unit -(** Same as {!List.iter}, but the function is applied to the index of +(** Same as {!ListLabels.iter}, but the function is applied to the index of the element as first argument (counting from 0), and the element itself as second argument. @since 4.00.0 *) val map : f:('a -> 'b) -> 'a list -> 'b list -(** [List.map f [a1; ...; an]] applies function [f] to [a1, ..., an], +(** [ListLabels.map f [a1; ...; an]] applies function [f] to [a1, ..., an], and builds the list [[f a1; ...; f an]] with the results returned by [f]. Not tail-recursive. *) val mapi : f:(int -> 'a -> 'b) -> 'a list -> 'b list -(** Same as {!List.map}, but the function is applied to the index of +(** Same as {!ListLabels.map}, but the function is applied to the index of the element as first argument (counting from 0), and the element itself as second argument. @since 4.00.0 *) val rev_map : f:('a -> 'b) -> 'a list -> 'b list -(** [List.rev_map f l] gives the same result as +(** [ListLabels.rev_map f l] gives the same result as {!ListLabels.rev}[ (]{!ListLabels.map}[ f l)], but is tail-recursive and more efficient. *) val fold_left : f:('a -> 'b -> 'a) -> init:'a -> 'b list -> 'a -(** [List.fold_left f a [b1; ...; bn]] is +(** [ListLabels.fold_left f a [b1; ...; bn]] is [f (... (f (f a b1) b2) ...) bn]. *) val fold_right : f:('a -> 'b -> 'b) -> 'a list -> init:'b -> 'b -(** [List.fold_right f [a1; ...; an] b] is +(** [ListLabels.fold_right f [a1; ...; an] b] is [f a1 (f a2 (... (f an b) ...))]. Not tail-recursive. *) @@ -110,32 +110,32 @@ 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 +(** [ListLabels.iter2 f [a1; ...; an] [b1; ...; bn]] calls in turn [f a1 b1; ...; f an bn]. 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 +(** [ListLabels.map2 f [a1; ...; an] [b1; ...; bn]] is [[f a1 b1; ...; f an bn]]. 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 +(** [ListLabels.rev_map2 f l1 l2] gives the same result as {!ListLabels.rev}[ (]{!ListLabels.map2}[ f l1 l2)], but is tail-recursive and more efficient. *) 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 +(** [ListLabels.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 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 +(** [ListLabels.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 are determined to have different lengths. Not tail-recursive. *) @@ -259,7 +259,7 @@ val sort : cmp:('a -> 'a -> int) -> 'a list -> 'a list a complete specification). For example, {!Pervasives.compare} is a suitable comparison function. The resulting list is sorted in increasing order. - [List.sort] is guaranteed to run in constant heap space + [ListLabels.sort] is guaranteed to run in constant heap space (in addition to the size of the result list) and logarithmic stack space. @@ -277,8 +277,12 @@ val stable_sort : cmp:('a -> 'a -> int) -> 'a list -> 'a list *) val fast_sort : cmp:('a -> 'a -> int) -> 'a list -> 'a list -(** Same as {!List.sort} or {!List.stable_sort}, whichever is faster - on typical input. *) +(** Same as {!ListLabels.sort} or {!ListLabels.stable_sort}, whichever is + faster on typical input. *) + +val sort_uniq : cmp:('a -> 'a -> int) -> 'a list -> 'a list +(** Same as {!ListLabels.sort}, but also remove duplicates. + @since 4.02.0 *) val merge : cmp:('a -> 'a -> int) -> 'a list -> 'a list -> 'a list (** Merge two lists: diff --git a/stdlib/marshal.mli b/stdlib/marshal.mli index 9dfdd1624c..4f0ed49b78 100644 --- a/stdlib/marshal.mli +++ b/stdlib/marshal.mli @@ -114,7 +114,8 @@ external to_bytes : (** [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}. *) + {!Marshal.to_channel}. + @since 4.02.0 *) external to_string : 'a -> extern_flags list -> string = "caml_output_value_to_string" @@ -141,7 +142,8 @@ val from_bytes : bytes -> int -> 'a like {!Marshal.from_channel} does, except that the byte representation is not read from a channel, but taken from the byte sequence [buff], starting at position [ofs]. - The byte sequence is not mutated. *) + The byte sequence is not mutated. + @since 4.02.0 *) val from_string : string -> int -> 'a (** Same as [from_bytes] but take a string as argument instead of a diff --git a/stdlib/nativeint.ml b/stdlib/nativeint.ml index 94c4b94901..7412bca04e 100644 --- a/stdlib/nativeint.ml +++ b/stdlib/nativeint.ml @@ -51,3 +51,4 @@ external of_string: string -> nativeint = "caml_nativeint_of_string" type t = nativeint let compare (x: t) (y: t) = Pervasives.compare x y +let equal (x: t) (y: t) = compare x y = 0 diff --git a/stdlib/nativeint.mli b/stdlib/nativeint.mli index 3dce1b6c49..ffa57030cd 100644 --- a/stdlib/nativeint.mli +++ b/stdlib/nativeint.mli @@ -171,6 +171,10 @@ val compare: t -> t -> int allows the module [Nativeint] to be passed as argument to the functors {!Set.Make} and {!Map.Make}. *) +val equal: t -> t -> bool +(** The equal function for natives ints. + @since 4.03.0 *) + (**/**) (** {6 Deprecated functions} *) diff --git a/stdlib/obj.ml b/stdlib/obj.ml index ac9695cdb8..5cb970b8e4 100644 --- a/stdlib/obj.ml +++ b/stdlib/obj.ml @@ -37,6 +37,9 @@ let marshal (obj : t) = let unmarshal str pos = (Marshal.from_bytes str pos, pos + Marshal.total_size str pos) +let first_non_constant_constructor_tag = 0 +let last_non_constant_constructor_tag = 245 + let lazy_tag = 246 let closure_tag = 247 let object_tag = 248 diff --git a/stdlib/obj.mli b/stdlib/obj.mli index 3395fa86f5..6d06312b4d 100644 --- a/stdlib/obj.mli +++ b/stdlib/obj.mli @@ -36,6 +36,9 @@ external truncate : t -> int -> unit = "caml_obj_truncate" external add_offset : t -> Int32.t -> t = "caml_obj_add_offset" (* @since 3.12.0 *) +val first_non_constant_constructor_tag : int +val last_non_constant_constructor_tag : int + val lazy_tag : int val closure_tag : int val object_tag : int diff --git a/stdlib/pervasives.ml b/stdlib/pervasives.ml index 6b7165206e..21d4cbf307 100644 --- a/stdlib/pervasives.ml +++ b/stdlib/pervasives.ml @@ -206,6 +206,10 @@ external ( := ) : 'a ref -> 'a -> unit = "%setfield0" external incr : int ref -> unit = "%incr" external decr : int ref -> unit = "%decr" +(* Result type *) + +type ('a,'b) result = Ok of 'a | Error of 'b + (* String conversion functions *) external format_int : string -> int -> string = "caml_format_int" @@ -246,6 +250,14 @@ let rec ( @ ) l1 l2 = [] -> l2 | hd :: tl -> hd :: (tl @ l2) +(* Array index operators *) +external ( .() ) : 'a array -> int -> 'a = "%array_opt_get" +external ( .() <- ) : 'a array -> int -> 'a -> unit = "%array_opt_set" + +(* String index operators *) +external ( .[] ) : string -> int -> char = "%string_opt_get" +external ( .[] <- ) : bytes -> int -> char -> unit = "%string_opt_set" + (* I/O operations *) type in_channel @@ -268,8 +280,13 @@ type open_flag = external open_desc : string -> open_flag list -> int -> int = "caml_sys_open" +external set_out_channel_name: out_channel -> string -> unit = + "caml_ml_set_channel_name" + let open_out_gen mode perm name = - open_descriptor_out(open_desc name mode perm) + let c = open_descriptor_out(open_desc name mode perm) in + set_out_channel_name c name; + c let open_out name = open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_text] 0o666 name @@ -331,8 +348,13 @@ external set_binary_mode_out : out_channel -> bool -> unit (* General input functions *) +external set_in_channel_name: in_channel -> string -> unit = + "caml_ml_set_channel_name" + let open_in_gen mode perm name = - open_descriptor_in(open_desc name mode perm) + let c = open_descriptor_in(open_desc name mode perm) in + set_in_channel_name c name; + c let open_in name = open_in_gen [Open_rdonly; Open_text] 0 name diff --git a/stdlib/pervasives.mli b/stdlib/pervasives.mli index 6413829146..e5182a8ee7 100644 --- a/stdlib/pervasives.mli +++ b/stdlib/pervasives.mli @@ -147,39 +147,55 @@ external ( or ) : bool -> bool -> bool = "%sequor" 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" *) + error format of OCaml: "File %S, line %d, characters %d-%d". + @since 4.02.0 + *) external __FILE__ : string = "%loc_FILE" (** [__FILE__] returns the name of the file currently being - parsed by the compiler. *) + parsed by the compiler. + @since 4.02.0 +*) external __LINE__ : int = "%loc_LINE" (** [__LINE__] returns the line number at which this expression - appears in the file currently being parsed by the compiler. *) + appears in the file currently being parsed by the compiler. + @since 4.02.0 + *) external __MODULE__ : string = "%loc_MODULE" (** [__MODULE__] returns the module name of the file being - parsed by the compiler. *) + parsed by the compiler. + @since 4.02.0 + *) 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. *) + the line and [enum] the last character position in the line. + @since 4.02.0 + *) 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" *) + %d, characters %d-%d". + @since 4.02.0 + *) 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. *) + currently being parsed by the compiler. + @since 4.02.0 + *) external __POS_OF__ : 'a -> (string * int * int * int) * 'a = "%loc_POS" -(** [__POS_OF__ expr] returns a pair [(expr,loc)], where [loc] is a +(** [__POS_OF__ expr] returns a pair [(loc,expr)], 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. *) + the last character position in the line. + @since 4.02.0 + *) (** {6 Composition operators} *) @@ -565,6 +581,29 @@ val ( @ ) : 'a list -> 'a list -> 'a list (** List concatenation. *) + + +(** {6 Array index operators} *) + +external ( .() ) : 'a array -> int -> 'a = "%array_opt_get" +(** Parenthesis index operator for arrays. + [ a.(index) ] is desugared to [ ( .() ) a index ]. *) + +external ( .() <- ) : 'a array -> int -> 'a -> unit = "%array_opt_set" +(** Parenthesis indexed assignment operator for arrays. + [ a.(index) <- val ] is desugared to [ ( .() <- ) a index val ]*) + + +(** {6 String index operators} *) + +external ( .[] ) : string -> int -> char= "%string_opt_get" +(** Bracket index operator for strings. + [ a.[index] ] is desugared to [ (.[]) a index ]. *) + +external ( .[] <- ) : bytes -> int -> char-> unit = "%string_opt_set" +(** Bracket indexed assignment operator for bytes. + [ a.[index] <- val ] is desugared to [ ( .[]<- ) a index val ]. *) + (** {6 Input/output} Note: all input/output functions can raise [Sys_error] when the system calls they invoke fail. *) @@ -594,7 +633,8 @@ val print_string : string -> unit (** Print a string on standard output. *) val print_bytes : bytes -> unit -(** Print a byte sequence on standard output. *) +(** Print a byte sequence on standard output. + @since 4.02.0 *) val print_int : int -> unit (** Print an integer, in decimal, on standard output. *) @@ -621,7 +661,8 @@ val prerr_string : string -> unit (** Print a string on standard error. *) val prerr_bytes : bytes -> unit -(** Print a byte sequence on standard error. *) +(** Print a byte sequence on standard error. + @since 4.02.0 *) val prerr_int : int -> unit (** Print an integer, in decimal, on standard error. *) @@ -708,7 +749,8 @@ val output_string : out_channel -> string -> unit (** Write the string on the given output channel. *) val output_bytes : out_channel -> bytes -> unit -(** Write the byte sequence on the given output channel. *) +(** Write the byte sequence on the given output channel. + @since 4.02.0 *) val output : out_channel -> bytes -> int -> int -> unit (** [output oc buf pos len] writes [len] characters from byte sequence [buf], @@ -718,7 +760,8 @@ val output : out_channel -> bytes -> int -> int -> unit val output_substring : out_channel -> string -> int -> int -> unit (** Same as [output] but take a string as argument instead of - a byte sequence. *) + a byte sequence. + @since 4.02.0 *) val output_byte : out_channel -> int -> unit (** Write one 8-bit integer (as the single character with that code) @@ -838,7 +881,8 @@ 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. *) + characters have been read. + @since 4.02.0 *) val input_byte : in_channel -> int (** Same as {!Pervasives.input_char}, but return the 8-bit integer representing @@ -938,6 +982,9 @@ external decr : int ref -> unit = "%decr" (** Decrement the integer contained in the given reference. Equivalent to [fun r -> r := pred !r]. *) +(** {6 Result type} *) + +type ('a,'b) result = Ok of 'a | Error of 'b (** {6 Operations on format strings} *) diff --git a/stdlib/printexc.mli b/stdlib/printexc.mli index 12e021c234..c347b9915b 100644 --- a/stdlib/printexc.mli +++ b/stdlib/printexc.mli @@ -181,6 +181,8 @@ val backtrace_slots : raw_backtrace -> backtrace_slot array option debug information ([-g]) - the program is a bytecode program that has not been linked with debug information enabled ([ocamlc -g]) + + @since 4.02.0 *) type location = { @@ -247,6 +249,8 @@ type raw_backtrace_slot elements are equal, then they represent the same source location (the converse is not necessarily true in presence of inlining, for example). + + @since 4.02.0 *) val raw_backtrace_length : raw_backtrace -> int diff --git a/stdlib/printf.mli b/stdlib/printf.mli index 4a72566594..573414ec22 100644 --- a/stdlib/printf.mli +++ b/stdlib/printf.mli @@ -136,7 +136,7 @@ val ifprintf : 'a -> ('b, 'a, unit) format -> 'b (** Formatted output functions with continuations. *) val kfprintf : (out_channel -> 'a) -> out_channel -> - ('b, out_channel, unit, 'a) format4 -> 'b;; + ('b, out_channel, unit, 'a) format4 -> 'b (** Same as [fprintf], but instead of returning immediately, passes the out channel to its first argument at the end of printing. @since 3.09.0 @@ -144,20 +144,19 @@ val kfprintf : (out_channel -> 'a) -> out_channel -> val ikfprintf : (out_channel -> 'a) -> out_channel -> ('b, out_channel, unit, 'a) format4 -> 'b -;; (** Same as [kfprintf] above, but does not print anything. Useful to ignore some material when conditionally printing. @since 4.0 *) -val ksprintf : (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b;; +val ksprintf : (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b (** Same as [sprintf] above, but instead of returning the string, passes it to the first argument. @since 3.09.0 *) val kbprintf : (Buffer.t -> 'a) -> Buffer.t -> - ('b, Buffer.t, unit, 'a) format4 -> 'b;; + ('b, Buffer.t, unit, 'a) format4 -> 'b (** Same as [bprintf], but instead of returning immediately, passes the buffer to its first argument at the end of printing. @since 3.10.0 diff --git a/stdlib/scanf.ml b/stdlib/scanf.ml index 1372c41ae8..948808830c 100644 --- a/stdlib/scanf.ml +++ b/stdlib/scanf.ml @@ -500,7 +500,8 @@ let token_bool ib = let token_int_literal conv ib = let tok = match conv with - | 'd' | 'i' | 'u' -> Scanning.token ib + | 'd' | 'i' -> Scanning.token ib + | 'u' -> "0u" ^ Scanning.token ib | 'o' -> "0o" ^ Scanning.token ib | 'x' | 'X' -> "0x" ^ Scanning.token ib | 'b' -> "0b" ^ Scanning.token ib @@ -1029,6 +1030,7 @@ fun k fmt -> match fmt with | Flush rest -> take_format_readers k rest | String_literal (_, rest) -> take_format_readers k rest | Char_literal (_, rest) -> take_format_readers k rest + | Custom (_, _, rest) -> take_format_readers k rest | Scan_char_set (_, _, rest) -> take_format_readers k rest | Scan_get_counter (_, rest) -> take_format_readers k rest @@ -1068,6 +1070,7 @@ fun k fmtty fmt -> match fmtty with | 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 + | Any_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) -> @@ -1125,6 +1128,12 @@ fun ib fmt readers -> match fmt with 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, Formatting_gen (Open_tag (Format (fmt', _)), rest)) -> + let scan width _ ib = scan_string (Some '{') width ib in + pad_prec_scanf ib (concat_fmt fmt' rest) readers pad No_precision scan token_string + | String (pad, Formatting_gen (Open_box (Format (fmt', _)), rest)) -> + let scan width _ ib = scan_string (Some '[') width ib in + pad_prec_scanf ib (concat_fmt fmt' 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 @@ -1163,6 +1172,8 @@ fun ib fmt readers -> match fmt with invalid_arg "scanf: bad conversion \"%a\"" | Theta _ -> invalid_arg "scanf: bad conversion \"%t\"" + | Custom _ -> + invalid_arg "scanf: bad conversion \"%?\" (custom converter)" | Reader fmt_rest -> let Cons (reader, readers_rest) = readers in let x = reader ib in diff --git a/stdlib/scanf.mli b/stdlib/scanf.mli index 297d6f2d5a..f065c4610b 100644 --- a/stdlib/scanf.mli +++ b/stdlib/scanf.mli @@ -83,7 +83,7 @@ module Scanning : sig -type in_channel;; +type in_channel (** The notion of input channel for the [Scanf] module: those channels provide all the machinery necessary to read from a given [Pervasives.in_channel] value. @@ -93,7 +93,7 @@ type in_channel;; @since 3.12.0 *) -type scanbuf = in_channel;; +type scanbuf = in_channel (** The type of scanning buffers. A scanning buffer is the source from which a formatted input function gets characters. The scanning buffer holds the current state of the scan, plus a function to get the next char from the @@ -105,7 +105,7 @@ type scanbuf = in_channel;; character yet to be read. *) -val stdin : in_channel;; +val stdin : in_channel (** The standard input notion for the [Scanf] module. [Scanning.stdin] is the formatted input channel attached to [Pervasives.stdin]. @@ -118,12 +118,12 @@ val stdin : in_channel;; @since 3.12.0 *) -type file_name = string;; +type file_name = string (** A convenient alias to designate a file name. @since 4.00.0 *) -val open_in : file_name -> in_channel;; +val open_in : file_name -> in_channel (** [Scanning.open_in fname] returns a formatted input channel for bufferized reading in text mode from file [fname]. @@ -135,31 +135,32 @@ val open_in : file_name -> in_channel;; @since 3.12.0 *) -val open_in_bin : file_name -> in_channel;; +val open_in_bin : file_name -> in_channel (** [Scanning.open_in_bin fname] returns a formatted input channel for bufferized reading in binary mode from file [fname]. @since 3.12.0 *) -val close_in : in_channel -> unit;; +val close_in : in_channel -> unit (** Closes the [Pervasives.in_channel] associated with the given [Scanning.in_channel] formatted input channel. @since 3.12.0 *) -val from_file : file_name -> in_channel;; +val from_file : file_name -> in_channel (** An alias for [open_in] above. *) -val from_file_bin : string -> in_channel;; + +val from_file_bin : string -> in_channel (** An alias for [open_in_bin] above. *) -val from_string : string -> in_channel;; +val from_string : string -> in_channel (** [Scanning.from_string s] returns a formatted input channel which reads from the given string. Reading starts from the first character in the string. The end-of-input condition is set when the end of the string is reached. *) -val from_function : (unit -> char) -> in_channel;; +val from_function : (unit -> char) -> in_channel (** [Scanning.from_function f] returns a formatted input channel with the given function as its reading method. @@ -169,39 +170,39 @@ val from_function : (unit -> char) -> in_channel;; end-of-input condition by raising the exception [End_of_file]. *) -val from_channel : Pervasives.in_channel -> in_channel;; +val from_channel : Pervasives.in_channel -> in_channel (** [Scanning.from_channel ic] returns a formatted input channel which reads from the regular input channel [ic] argument, starting at the current reading position. *) -val end_of_input : in_channel -> bool;; +val end_of_input : in_channel -> bool (** [Scanning.end_of_input ic] tests the end-of-input condition of the given formatted input channel. *) -val beginning_of_input : in_channel -> bool;; +val beginning_of_input : in_channel -> bool (** [Scanning.beginning_of_input ic] tests the beginning of input condition of the given formatted input channel. *) -val name_of_input : in_channel -> string;; +val name_of_input : in_channel -> string (** [Scanning.name_of_input ic] returns the name of the character source for the formatted input channel [ic]. @since 3.09.0 *) -val stdib : in_channel;; +val stdib : in_channel (** A deprecated alias for [Scanning.stdin], the scanning buffer reading from [Pervasives.stdin]. *) -end;; +end (** {6 Type of formatted input functions} *) type ('a, 'b, 'c, 'd) scanner = - ('a, Scanning.in_channel, 'b, 'c, 'a -> 'd, 'd) format6 -> 'c;; + ('a, Scanning.in_channel, 'b, 'c, 'a -> 'd, 'd) format6 -> 'c (** The type of formatted input scanners: [('a, 'b, 'c, 'd) scanner] is the type of a formatted input function that reads from some formatted input channel according to some format string; more @@ -223,14 +224,14 @@ type ('a, 'b, 'c, 'd) scanner = @since 3.10.0 *) -exception Scan_failure of string;; +exception Scan_failure of string (** The exception that formatted input functions raise when the input cannot be read according to the given format. *) (** {6 The general formatted input function} *) -val bscanf : Scanning.in_channel -> ('a, 'b, 'c, 'd) scanner;; +val bscanf : Scanning.in_channel -> ('a, 'b, 'c, 'd) scanner (** [bscanf ic fmt r1 ... rN f] reads arguments for the function [f], from the formatted input channel [ic], according to the format string [fmt], and applies [f] to these values. @@ -453,7 +454,7 @@ val bscanf : Scanning.in_channel -> ('a, 'b, 'c, 'd) scanner;; (** {6 Specialised formatted input functions} *) -val fscanf : Pervasives.in_channel -> ('a, 'b, 'c, 'd) scanner;; +val fscanf : Pervasives.in_channel -> ('a, 'b, 'c, 'd) scanner (** Same as {!Scanf.bscanf}, but reads from the given regular input channel. Warning: since all formatted input functions operate from a {e formatted @@ -467,17 +468,17 @@ val fscanf : Pervasives.in_channel -> ('a, 'b, 'c, 'd) scanner;; scanning from the same regular input channel. *) -val sscanf : string -> ('a, 'b, 'c, 'd) scanner;; +val sscanf : string -> ('a, 'b, 'c, 'd) scanner (** Same as {!Scanf.bscanf}, but reads from the given string. *) -val scanf : ('a, 'b, 'c, 'd) scanner;; +val scanf : ('a, 'b, 'c, 'd) scanner (** Same as {!Scanf.bscanf}, but reads from the predefined formatted input channel {!Scanf.Scanning.stdin} that is connected to [Pervasives.stdin]. *) val kscanf : Scanning.in_channel -> (Scanning.in_channel -> exn -> 'd) -> - ('a, 'b, 'c, 'd) scanner;; + ('a, 'b, 'c, 'd) scanner (** Same as {!Scanf.bscanf}, but takes an additional function argument [ef] that is called in case of error: if the scanning process or some conversion fails, the scanning function aborts and calls the @@ -488,18 +489,20 @@ val kscanf : val ksscanf : string -> (Scanning.in_channel -> exn -> 'd) -> ('a, 'b, 'c, 'd) scanner -(** Same as {!Scanf.kscanf} but reads from the given string. *) +(** Same as {!Scanf.kscanf} but reads from the given string. + @since 4.02.0 *) 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. *) +(** Same as {!Scanf.kscanf}, but reads from the given regular input channel. + @since 4.02.0 *) (** {6 Reading format strings from input} *) val bscanf_format : Scanning.in_channel -> ('a, 'b, 'c, 'd, 'e, 'f) format6 -> - (('a, 'b, 'c, 'd, 'e, 'f) format6 -> 'g) -> 'g;; + (('a, 'b, 'c, 'd, 'e, 'f) format6 -> 'g) -> 'g (** [bscanf_format ic fmt f] reads a format string token from the formatted input channel [ic], according to the given format string [fmt], and applies [f] to the resulting format string value. @@ -510,14 +513,14 @@ val bscanf_format : val sscanf_format : string -> ('a, 'b, 'c, 'd, 'e, 'f) format6 -> - (('a, 'b, 'c, 'd, 'e, 'f) format6 -> 'g) -> 'g;; + (('a, 'b, 'c, 'd, 'e, 'f) format6 -> 'g) -> 'g (** Same as {!Scanf.bscanf_format}, but reads from the given string. @since 3.09.0 *) val format_from_string : string -> - ('a, 'b, 'c, 'd, 'e, 'f) format6 -> ('a, 'b, 'c, 'd, 'e, 'f) format6;; + ('a, 'b, 'c, 'd, 'e, 'f) format6 -> ('a, 'b, 'c, 'd, 'e, 'f) format6 (** [format_from_string s fmt] converts a string argument to a format string, according to the given format string [fmt]. Raise [Scan_failure] if [s], considered as a format string, does not @@ -525,7 +528,7 @@ val format_from_string : @since 3.10.0 *) -val unescaped : string -> string;; +val unescaped : string -> string (** Return a copy of the argument with escape sequences, following the lexical conventions of OCaml, replaced by their corresponding special characters. If there is no escape sequence in the diff --git a/stdlib/set.ml b/stdlib/set.ml index 5c6212d889..33386f1796 100644 --- a/stdlib/set.ml +++ b/stdlib/set.ml @@ -115,7 +115,12 @@ module Make(Ord: OrderedType) = | Node(l, v, r, _) as t -> let c = Ord.compare x v in if c = 0 then t else - if c < 0 then bal (add x l) v r else bal l v (add x r) + if c < 0 then + let ll = add x l in + if l == ll then t else bal ll v r + else + let rr = add x r in + if r == rr then t else bal l v rr let singleton x = Node(Empty, x, Empty, 1) @@ -218,10 +223,18 @@ module Make(Ord: OrderedType) = let rec remove x = function Empty -> Empty - | Node(l, v, r, _) -> + | (Node(l, v, r, _) as t) -> let c = Ord.compare x v in - if c = 0 then merge l r else - if c < 0 then bal (remove x l) v r else bal l v (remove x r) + if c = 0 then merge l r + else + if c < 0 then + let ll = remove x l in + if l == ll then t + else bal ll v r + else + let rr = remove x r in + if r == rr then t + else bal l v rr let rec union s1 s2 = match (s1, s2) with @@ -319,12 +332,14 @@ module Make(Ord: OrderedType) = let rec filter p = function Empty -> Empty - | Node(l, v, r, _) -> + | (Node(l, v, r, _)) as t -> (* call [p] in the expected left-to-right order *) let l' = filter p l in let pv = p v in let r' = filter p r in - if pv then join l' v r' else concat l' r' + if pv then + if l==l' && r==r' then t else join l' v r' + else concat l' r' let rec partition p = function Empty -> (Empty, Empty) diff --git a/stdlib/set.mli b/stdlib/set.mli index 1b67398eef..eb77a753dc 100644 --- a/stdlib/set.mli +++ b/stdlib/set.mli @@ -76,14 +76,18 @@ module type S = val add: elt -> t -> t (** [add x s] returns a set containing all elements of [s], - plus [x]. If [x] was already in [s], [s] is returned unchanged. *) + plus [x]. If [x] was already in [s], [s] is returned unchanged + (the result of the function is then physically equal to [s]). + @before 4.03 Physical equality was not ensured. *) val singleton: elt -> t (** [singleton x] returns the one-element set containing only [x]. *) val remove: elt -> t -> t (** [remove x s] returns a set containing all elements of [s], - except [x]. If [x] was not in [s], [s] is returned unchanged. *) + except [x]. If [x] was not in [s], [s] is returned unchanged + (the result of the function is then physically equal to [s]). + @before 4.03 Physical equality was not ensured. *) val union: t -> t -> t (** Set union. *) @@ -125,7 +129,10 @@ module type S = val filter: (elt -> bool) -> t -> t (** [filter p s] returns the set of all elements in [s] - that satisfy predicate [p]. *) + that satisfy predicate [p]. If [p] satisfies every element in [s], + [s] is returned unchanged (the result of the function is then + physically equal to [s]). + @before 4.03 Physical equality was not ensured.*) val partition: (elt -> bool) -> t -> t * t (** [partition p s] returns a pair of sets [(s1, s2)], where diff --git a/stdlib/stream.mli b/stdlib/stream.mli index 85a846102c..1957cf60d2 100644 --- a/stdlib/stream.mli +++ b/stdlib/stream.mli @@ -47,7 +47,8 @@ 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. *) +(** Return the stream of the characters of the bytes parameter. + @since 4.02.0 *) 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 93880af268..ecb1be3c3b 100644 --- a/stdlib/string.ml +++ b/stdlib/string.ml @@ -73,8 +73,6 @@ let mapi f s = 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" - let is_space = function | ' ' | '\012' | '\n' | '\r' | '\t' -> true | _ -> false @@ -90,7 +88,7 @@ let escaped s = 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) + | ' ' .. '~' -> needs_escape (i+1) | _ -> true in if needs_escape 0 then @@ -112,6 +110,23 @@ let contains_from s i c = B.contains_from (bos s) i c let rcontains_from s i c = B.rcontains_from (bos s) i c + +let uppercase_ascii s = + B.uppercase_ascii (bos s) |> bts +let lowercase_ascii s = + B.lowercase_ascii (bos s) |> bts +let capitalize_ascii s = + B.capitalize_ascii (bos s) |> bts +let uncapitalize_ascii s = + B.uncapitalize_ascii (bos s) |> bts + +type t = string + +let compare (x: t) (y: t) = Pervasives.compare x y +external equal : string -> string -> bool = "caml_string_equal" + +(* Deprecated functions implemented via other deprecated functions *) +[@@@ocaml.warning "-3"] let uppercase s = B.uppercase (bos s) |> bts let lowercase s = @@ -120,7 +135,3 @@ let capitalize s = B.capitalize (bos s) |> bts let uncapitalize s = B.uncapitalize (bos s) |> bts - -type t = string - -let compare (x: t) (y: t) = Pervasives.compare x y diff --git a/stdlib/string.mli b/stdlib/string.mli index 56065bbfbd..5b1233a6cf 100644 --- a/stdlib/string.mli +++ b/stdlib/string.mli @@ -158,13 +158,20 @@ val trim : string -> string val escaped : string -> string (** Return a copy of the argument, with special characters - 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. + represented by escape sequences, following the lexical + conventions of OCaml. + All characters outside the ASCII printable range (32..126) are + escaped, as well as backslash and double-quote. - Raise [Invalid_argument] if the result is longer than - {!Sys.max_string_length} bytes. *) + If there is no special character in the argument that needs + escaping, return the original string itself, not a copy. + + Raise [Invalid_argument] if the result is longer than + {!Sys.max_string_length} bytes. + + The function {!Scanf.unescaped} is a left inverse of [escaped], + i.e. [Scanf.unescaped (escaped s) = s] for any string [s] (unless + [escape s] fails). *) val index : string -> char -> int (** [String.index s c] returns the index of the first @@ -215,20 +222,50 @@ val rcontains_from : string -> int -> char -> bool position in [s]. *) val uppercase : string -> string + [@@ocaml.deprecated "Use String.uppercase_ascii instead."] (** 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. *) + Latin-1 (8859-1) character set. + @deprecated Functions operating on Latin-1 character set are deprecated. *) val lowercase : string -> string + [@@ocaml.deprecated "Use String.lowercase_ascii instead."] (** 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. *) + Latin-1 (8859-1) character set. + @deprecated Functions operating on Latin-1 character set are deprecated. *) val capitalize : string -> string -(** Return a copy of the argument, with the first character set to uppercase. *) + [@@ocaml.deprecated "Use String.capitalize_ascii instead."] +(** Return a copy of the argument, with the first character set to uppercase, + using the ISO Latin-1 (8859-1) character set.. + @deprecated Functions operating on Latin-1 character set are deprecated. *) val uncapitalize : string -> string -(** Return a copy of the argument, with the first character set to lowercase. *) + [@@ocaml.deprecated "Use String.uncapitalize_ascii instead."] +(** Return a copy of the argument, with the first character set to lowercase, + using the ISO Latin-1 (8859-1) character set.. + @deprecated Functions operating on Latin-1 character set are deprecated. *) + +val uppercase_ascii : string -> string +(** Return a copy of the argument, with all lowercase letters + translated to uppercase, using the US-ASCII character set. + @since 4.03.0 *) + +val lowercase_ascii : string -> string +(** Return a copy of the argument, with all uppercase letters + translated to lowercase, using the US-ASCII character set. + @since 4.03.0 *) + +val capitalize_ascii : string -> string +(** Return a copy of the argument, with the first character set to uppercase, + using the US-ASCII character set. + @since 4.03.0 *) + +val uncapitalize_ascii : string -> string +(** Return a copy of the argument, with the first character set to lowercase, + using the US-ASCII character set. + @since 4.03.0 *) type t = string (** An alias for the type of strings. *) @@ -239,6 +276,10 @@ val compare: t -> t -> int allows the module [String] to be passed as argument to the functors {!Set.Make} and {!Map.Make}. *) +val equal: t -> t -> bool +(** The equal function for strings. + @since 4.03.0 *) + (**/**) (* The following is for system use only. Do not call directly. *) diff --git a/stdlib/sys.mli b/stdlib/sys.mli index ae175c2e81..041425dceb 100644 --- a/stdlib/sys.mli +++ b/stdlib/sys.mli @@ -99,6 +99,13 @@ val word_size : int (** Size of one word on the machine currently executing the OCaml program, in bits: 32 or 64. *) +val int_size : int +(** Size of an int. It is 31 bits (resp. 63 bits) when using the + OCaml compiler on a 32 bits (resp. 64 bits) platform. It may + differ for other compilers, e.g. it is 32 bits when compiling to + JavaScript. + @since 4.03.0 *) + val big_endian : bool (** Whether the machine currently executing the Caml program is big-endian. @since 4.00.0 *) @@ -223,3 +230,13 @@ val ocaml_version : string;; where [major], [minor], and [patchlevel] are integers, and [additional-info] is an arbitrary string. The [[.patchlevel]] and [[+additional-info]] parts may be absent. *) + + +val enable_runtime_warnings: bool -> unit +(** Control whether the OCaml runtime system can emit warnings + on stderr. Currently, the only supported warning is triggered + when a channel created by [open_*] functions is finalized without + being closed. Runtime warnings are enabled by default. *) + +val runtime_warnings_enabled: unit -> bool +(** Return whether runtime warnings are currently enabled. *) diff --git a/stdlib/sys.mlp b/stdlib/sys.mlp index c54fcb8218..96b49264d2 100644 --- a/stdlib/sys.mlp +++ b/stdlib/sys.mlp @@ -21,6 +21,8 @@ external get_config: unit -> string * int * bool = "caml_sys_get_config" external get_argv: unit -> string * string array = "caml_sys_get_argv" external big_endian : unit -> bool = "%big_endian" external word_size : unit -> int = "%word_size" +external int_size : unit -> int = "%int_size" +external max_wosize : unit -> int = "%max_wosize" external unix : unit -> bool = "%ostype_unix" external win32 : unit -> bool = "%ostype_win32" external cygwin : unit -> bool = "%ostype_cygwin" @@ -29,10 +31,11 @@ let (executable_name, argv) = get_argv() let (os_type, _, _) = get_config() let big_endian = big_endian () let word_size = word_size () +let int_size = int_size () let unix = unix () let win32 = win32 () let cygwin = cygwin () -let max_array_length = (1 lsl (word_size - 10)) - 1;; +let max_array_length = max_wosize () let max_string_length = word_size / 8 * max_array_length - 1;; external file_exists: string -> bool = "caml_sys_file_exists" @@ -89,6 +92,11 @@ let catch_break on = set_signal sigint Signal_default +external enable_runtime_warnings: bool -> unit = + "caml_ml_enable_runtime_warnings" +external runtime_warnings_enabled: unit -> bool = + "caml_ml_runtime_warnings_enabled" + (* The version string is found in file ../VERSION *) let ocaml_version = "%%VERSION%%";; diff --git a/testsuite/external/.ignore b/testsuite/external/.ignore deleted file mode 100644 index 39e14de915..0000000000 --- a/testsuite/external/.ignore +++ /dev/null @@ -1,152 +0,0 @@ -*.tar.gz -*.tar.bz2 -*.tgz -*.tbz -*.zip - -log-* -log_* - -advi -advi-1.10.2 -altergo -alt-ergo-0.95.2 -binprot -bin_prot-109.30.00 -bitstring -ocaml-bitstring-2.0.3 -boomerang -boomerang-0.2 -calendar -calendar-2.03.2 -camlimages -camlimages-4.0.1 -camlpdf -camlpdf-0.5 -camlp4 -camlp4-trunk -camlp5 -camlp5-git -camlzip -camlzip-1.04 -camomile -camomile-0.8.4 -comparelib -comparelib-109.15.00 -compcert -compcert-1.13 -configfile -config-file-1.1 -coq -coq-8.4pl2 -core -core-109.37.00 -coreextended -core_extended-109.36.00 -corekernel -core_kernel-109.37.00 -cryptokit -cryptokit-1.6 -csv -csv-1.3.1 -customprintf -custom_printf-109.27.00 -dbm -camldbm-1.0 -expect -ocaml-expect-0.0.3 -extlib -extlib-1.5.2 -fieldslib -fieldslib-109.15.00 -fileutils -ocaml-fileutils-0.4.4 -findlib -findlib-1.4.1 -framac -frama-c-Oxygen-20120901 -geneweb -gw-6.05-src -herelib -herelib-109.35.00 -hevea -hevea-2.09 -kaputt -kaputt-1.2 -lablgtk -lablgtk-2.18.0 -lablgtkextras -lablgtkextras-1.3 -lwt -lwt-2.4.0 -menhir -menhir-20120123 -mldonkey -mldonkey-3.1.2 -mysql -ocaml-mysql-1.0.4 -oasis -oasis-0.3.0 -obrowser -obrowser-1.1.1 -ocamlgraph -ocamlgraph-1.8.2 -ocamlify -ocamlify-0.0.1 -ocamlmod -ocamlmod-0.0.3 -ocamlnet -ocamlnet-3.5.1 -ocamlscript -ocamlscript-2.0.3 -ocamlssl -ocaml-ssl-0.4.6 -ocamltext -ocaml-text-0.5 -ocgi -ocgi-0.5 -ocsigen -ocsigen-bundle-2.2.2 -odn -ocaml-data-notation-0.0.10 -omake -omake-0.9.8.6 -ounit -ounit-1.1.2 -paounit -pa_ounit-109.36.00 -pcre -pcre-ocaml-6.2.5 -pipebang -pipebang-109.28.00 -react -react-0.9.3 -res -res-3.2.0 -rss -ocamlrss-2.2.2 -sexplib -sexplib-109.15.00 -sks -sks-1.1.3 -sqlite -sqlite3-ocaml-2.0.1 -textutils -textutils-109.36.00 -typeconv -type_conv-109.28.00 -unison -unison-2.45.4 -variantslib -variantslib-109.15.00 -vsyml -vsyml-2010-04-06 -xmllight -xml-light.2.3 -xmlm -xmlm-1.1.0 -zarith -zarith-1.2.1 -zen -zen_2.3.2 -._ZEN_2.3.2 diff --git a/testsuite/external/Makefile b/testsuite/external/Makefile deleted file mode 100644 index 566aaf3921..0000000000 --- a/testsuite/external/Makefile +++ /dev/null @@ -1,1747 +0,0 @@ -######################################################################### -# # -# OCaml # -# # -# Damien Doligez, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2012 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. # -# # -######################################################################### - -# To use this test set, you need OCaml installed in a directory where -# you have write rights. - -# Warning: use of this Makefile will install lots of software -# in the same place where OCaml is installed. - -# It is recommended that you install OCaml in some isolated -# directory D (for example /usr/local/ocaml/test), add D/bin -# at the front of your PATH, then use this Makefile to test -# your OCaml installation. - -WGET = wget --no-check-certificate --progress=dot:mega - -PREFIX = "`ocamlc -where | sed -e 's|/[^/]*/[^/]*$$||'`" -VERSION = `ocamlc -vnum` - -.PHONY: default -default: - @printf "\n\n########## Starting make at " >>log-${VERSION} - @date >>log-${VERSION} - ${MAKE} platform >>log-${VERSION} 2>&1 - @printf '\n' - mv log-${VERSION} log_${VERSION}_`date -u '+%Y-%m-%d:%H:%M:%S'` - -# Platform-dependent subsets: add your own here. - -.PHONY: all-cygwin -all-cygwin: findlib ounit res pcre react ocamltext ocamlssl camlzip cryptokit \ - sqlite ocgi xmllight configfile xmlm omake \ - camomile zen vsyml extlib fileutils ocamlify ocamlmod \ - calendar dbm ocamlscript coq compcert - -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 \ - CYGWIN*) ${MAKE} all-cygwin;; \ - Darwin) ${MAKE} all-macos;; \ - *) ${MAKE} all;; \ - esac - -# https://github.com/ocaml/camlp4/ -CAMLP4=camlp4-trunk -${CAMLP4}.zip: - ${WGET} https://github.com/ocaml/camlp4/archive/trunk.zip - mv trunk.zip ${CAMLP4}.zip -xxcamlp4: ${CAMLP4}.zip - printf "%s " "$@" >/dev/tty - test -d ${PREFIX} - rm -rf ${CAMLP4} - unzip -q ${CAMLP4}.zip - ./Patcher.sh ${CAMLP4} - ( cd ${CAMLP4} && \ - export PATH=${PREFIX}/bin:$$PATH && \ - sh ./configure --prefix ${PREFIX} && \ - ${MAKE} all && \ - ocamlfind remove camlp4 && \ - ${MAKE} install ) - echo ${VERSION} >$@ -clean:: - rm -rf ${CAMLP4} camlp4 -distclean:: - rm -f ${CAMLP4}.tar.gz -all: camlp4 - -# http://projects.camlcity.org/projects/findlib.html -FINDLIB=findlib-1.4.1 -${FINDLIB}.tar.gz: - ${WGET} http://download.camlcity.org/download/$@ -findlib: ${FINDLIB}.tar.gz - printf "%s " "$@" >/dev/tty - test -d ${PREFIX} - rm -rf ${FINDLIB} - tar zxf ${FINDLIB}.tar.gz - ./Patcher.sh ${FINDLIB} - ( cd ${FINDLIB} && \ - export PATH=${PREFIX}/bin:$$PATH && \ - ./configure && \ - ${MAKE} all && \ - ${MAKE} opt && \ - ${MAKE} install ) - echo ${VERSION} >$@ -clean:: - rm -rf ${FINDLIB} findlib -distclean:: - rm -f ${FINDLIB}.tar.gz -all: findlib - -# http://lablgtk.forge.ocamlcore.org/ -LABLGTK=lablgtk-2.18.0 -${LABLGTK}.tar.gz: - ${WGET} https://forge.ocamlcore.org/frs/download.php/1261/$@ -xxlablgtk: ${LABLGTK}.tar.gz findlib camlp4 # TODO: add lablgl - printf "%s " "$@" >/dev/tty - test -d ${PREFIX} - rm -rf ${LABLGTK} - tar zxf ${LABLGTK}.tar.gz - ./Patcher.sh ${LABLGTK} - ( cd ${LABLGTK} && \ - export PATH=${PREFIX}/bin:$$PATH && \ - ./configure -prefix ${PREFIX} && \ - ${MAKE} world && \ - ocamlfind remove lablgtk2 && \ - ${MAKE} install && \ - rm -f ${PREFIX}/lib/ocaml/lablgtk2 && \ - ln -f -s ${PREFIX}/lib/ocaml/site-lib/lablgtk2 \ - ${PREFIX}/lib/ocaml/lablgtk2 ) - echo ${VERSION} >$@ -clean:: - rm -rf ${LABLGTK} lablgtk -distclean:: - rm -f ${LABLGTK}.tar.gz -all: lablgtk - -# http://ocamlgraph.lri.fr/ -OCAMLGRAPH=ocamlgraph-1.8.2 -${OCAMLGRAPH}.tar.gz: - ${WGET} http://ocamlgraph.lri.fr/download/$@ -ocamlgraph: ${OCAMLGRAPH}.tar.gz findlib - printf "%s " "$@" >/dev/tty - test -d ${PREFIX} - rm -rf ${OCAMLGRAPH} - tar zxf ${OCAMLGRAPH}.tar.gz - ./Patcher.sh ${OCAMLGRAPH} - ( cd ${OCAMLGRAPH} && \ - export PATH=${PREFIX}/bin:$$PATH && \ - ./configure -prefix ${PREFIX} && \ - ${MAKE} && \ - rm -rf ${PREFIX}/lib/ocaml/ocamlgraph && \ - ocamlfind remove ocamlgraph && \ - ${MAKE} install install-findlib && \ - ln -s ${PREFIX}/lib/ocaml/site-lib/ocamlgraph \ - ${PREFIX}/lib/ocaml/ocamlgraph ) - echo ${VERSION} >$@ -clean:: - rm -rf ${OCAMLGRAPH} ocamlgraph -distclean:: - rm -f ${OCAMLGRAPH}.tar.gz -all: ocamlgraph - -# http://ounit.forge.ocamlcore.org/ -OUNIT=ounit-1.1.2 -${OUNIT}.tar.gz: - ${WGET} http://forge.ocamlcore.org/frs/download.php/886/$@ -xxounit: ${OUNIT}.tar.gz findlib camlp4 - printf "%s " "$@" >/dev/tty - test -d ${PREFIX} - rm -rf ${OUNIT} - tar zxf ${OUNIT}.tar.gz - ./Patcher.sh ${OUNIT} - ( cd ${OUNIT} && \ - export PATH=${PREFIX}/bin:$$PATH && \ - ${MAKE} && \ - ocamlfind remove oUnit && \ - ${MAKE} install ) - echo ${VERSION} >$@ -clean:: - rm -rf ${OUNIT} ounit -distclean:: - rm -f ${OUNIT}.tar.gz -all: ounit - -# https://bitbucket.org/mmottl/res -RES=res-3.2.0 -${RES}.tar.gz: - ${WGET} https://bitbucket.org/mmottl/res/downloads/$@ -res: ${RES}.tar.gz findlib - printf "%s " "$@" >/dev/tty - test -d ${PREFIX} - rm -rf ${RES} - tar zxf ${RES}.tar.gz - ./Patcher.sh ${RES} - ( cd ${RES} && \ - export PATH=${PREFIX}/bin:$$PATH && \ - ${MAKE} && \ - ocamlfind remove res && \ - ${MAKE} install ) - echo ${VERSION} >$@ -clean:: - rm -rf ${RES} res -distclean:: - rm -f ${RES}.tar.gz -all: res - -# https://bitbucket.org/mmottl/pcre-ocaml -PCRE=pcre-ocaml-6.2.5 -${PCRE}.tar.gz: - ${WGET} https://bitbucket.org/mmottl/pcre-ocaml/downloads/$@ -pcre: ${PCRE}.tar.gz findlib - printf "%s " "$@" >/dev/tty - test -d ${PREFIX} - rm -rf ${PCRE} - tar zxf ${PCRE}.tar.gz - ./Patcher.sh ${PCRE} - ( cd ${PCRE} && \ - export PATH=${PREFIX}/bin:$$PATH && \ - ${MAKE} && \ - ocamlfind remove pcre && \ - ${MAKE} install ) - echo ${VERSION} >$@ -clean:: - rm -rf ${PCRE} pcre -distclean:: - rm -f ${PCRE}.tar.gz -all: pcre - -########################################################################### - -## Jane Street Core - -# https://ocaml.janestreet.com/ocaml-core/109.28.00/individual/ -TYPECONV=type_conv-109.28.00 -${TYPECONV}.tar.gz: - ${WGET} https://ocaml.janestreet.com/ocaml-core/109.28.00/individual/$@ -xxtypeconv: ${TYPECONV}.tar.gz findlib camlp4 - printf "%s " "$@" >/dev/tty - test -d ${PREFIX} - rm -rf ${TYPECONV} - tar zxf ${TYPECONV}.tar.gz - ./Patcher.sh ${TYPECONV} - ( cd ${TYPECONV} && \ - export PATH=${PREFIX}/bin:$$PATH && \ - ocaml setup.ml -configure && \ - ocaml setup.ml -build && \ - ocamlfind remove type_conv && \ - ocaml setup.ml -install ) - echo ${VERSION} >$@ -clean:: - rm -rf ${TYPECONV} typeconv -distclean:: - rm -f ${TYPECONV}.tar.gz -all: typeconv - -# https://ocaml.janestreet.com/ocaml-core/109.15.00/individual/ -VARIANTSLIB=variantslib-109.15.00 -${VARIANTSLIB}.tar.gz: - ${WGET} https://ocaml.janestreet.com/ocaml-core/109.15.00/individual/$@ -xxvariantslib: ${VARIANTSLIB}.tar.gz findlib typeconv - printf "%s " "$@" >/dev/tty - test -d ${PREFIX} - rm -rf ${VARIANTSLIB} - tar zxf ${VARIANTSLIB}.tar.gz - ./Patcher.sh ${VARIANTSLIB} - ( cd ${VARIANTSLIB} && \ - export PATH=${PREFIX}/bin:$$PATH && \ - ocaml setup.ml -configure && \ - ocaml setup.ml -build && \ - ocamlfind remove variantslib && \ - ocaml setup.ml -install ) - echo ${VERSION} >$@ -clean:: - rm -rf ${VARIANTSLIB} variantslib -distclean:: - rm -f ${VARIANTSLIB}.tar.gz -all: variantslib - -# https://ocaml.janestreet.com/ocaml-core/109.28.00/individual/ -PIPEBANG=pipebang-109.28.00 -${PIPEBANG}.tar.gz: - ${WGET} https://ocaml.janestreet.com/ocaml-core/109.28.00/individual/$@ -pipebang: ${PIPEBANG}.tar.gz findlib typeconv - printf "%s " "$@" >/dev/tty - test -d ${PREFIX} - rm -rf ${PIPEBANG} - tar zxf ${PIPEBANG}.tar.gz - ./Patcher.sh ${PIPEBANG} - ( cd ${PIPEBANG} && \ - export PATH=${PREFIX}/bin:$$PATH && \ - ocaml setup.ml -configure && \ - ocaml setup.ml -build && \ - ocamlfind remove pa_pipebang && \ - ocaml setup.ml -install ) - echo ${VERSION} >$@ -clean:: - rm -rf ${PIPEBANG} pipebang -distclean:: - rm -f ${PIPEBANG}.tar.gz -all: pipebang - -# https://ocaml.janestreet.com/ocaml-core/109.36.00/individual/ -PAOUNIT=pa_ounit-109.36.00 -${PAOUNIT}.tar.gz: - ${WGET} https://ocaml.janestreet.com/ocaml-core/109.36.00/individual/$@ -paounit: ${PAOUNIT}.tar.gz findlib typeconv - printf "%s " "$@" >/dev/tty - test -d ${PREFIX} - rm -rf ${PAOUNIT} - tar zxf ${PAOUNIT}.tar.gz - ./Patcher.sh ${PAOUNIT} - ( cd ${PAOUNIT} && \ - export PATH=${PREFIX}/bin:$$PATH && \ - ocaml setup.ml -configure && \ - ocaml setup.ml -build && \ - ocamlfind remove pa_ounit && \ - ocaml setup.ml -install ) - echo ${VERSION} >$@ -clean:: - rm -rf ${PAOUNIT} paounit -distclean:: - rm -f ${PAOUNIT}.tar.gz -all: paounit - -# https://ocaml.janestreet.com/ocaml-core/109.15.00/individual/ -COMPARELIB=comparelib-109.15.00 -${COMPARELIB}.tar.gz: - ${WGET} https://ocaml.janestreet.com/ocaml-core/109.15.00/individual/$@ -comparelib: ${COMPARELIB}.tar.gz findlib typeconv - printf "%s " "$@" >/dev/tty - test -d ${PREFIX} - rm -rf ${COMPARELIB} - tar zxf ${COMPARELIB}.tar.gz - ./Patcher.sh ${COMPARELIB} - ( cd ${COMPARELIB} && \ - export PATH=${PREFIX}/bin:$$PATH && \ - ocaml setup.ml -configure && \ - ocaml setup.ml -build && \ - ocamlfind remove comparelib && \ - ocaml setup.ml -install ) - echo ${VERSION} >$@ -clean:: - rm -rf ${COMPARELIB} comparelib -distclean:: - rm -f ${COMPARELIB}.tar.gz -all: comparelib - -# https://ocaml.janestreet.com/ocaml-core/109.30.00/individual/ -BINPROT=bin_prot-109.30.00 -${BINPROT}.tar.gz: - ${WGET} https://ocaml.janestreet.com/ocaml-core/109.30.00/individual/$@ -binprot: ${BINPROT}.tar.gz findlib typeconv ounit - printf "%s " "$@" >/dev/tty - test -d ${PREFIX} - rm -rf ${BINPROT} - tar zxf ${BINPROT}.tar.gz - ./Patcher.sh ${BINPROT} - ( cd ${BINPROT} && \ - export PATH=${PREFIX}/bin:$$PATH && \ - ocaml setup.ml -configure && \ - ocaml setup.ml -build && \ - ocamlfind remove bin_prot && \ - ocaml setup.ml -install ) - echo ${VERSION} >$@ -clean:: - rm -rf ${BINPROT} binprot -distclean:: - rm -f ${BINPROT}.tar.gz -all: binprot - -# https://ocaml.janestreet.com/ocaml-core/109.15.00/individual/ -FIELDSLIB=fieldslib-109.15.00 -${FIELDSLIB}.tar.gz: - ${WGET} https://ocaml.janestreet.com/ocaml-core/109.15.00/individual/$@ -fieldslib: ${FIELDSLIB}.tar.gz findlib typeconv - printf "%s " "$@" >/dev/tty - test -d ${PREFIX} - rm -rf ${FIELDSLIB} - tar zxf ${FIELDSLIB}.tar.gz - ./Patcher.sh ${FIELDSLIB} - ( cd ${FIELDSLIB} && \ - export PATH=${PREFIX}/bin:$$PATH && \ - ocaml setup.ml -configure && \ - ocaml setup.ml -build && \ - ocamlfind remove fieldslib && \ - ocaml setup.ml -install ) - echo ${VERSION} >$@ -clean:: - rm -rf ${FIELDSLIB} fieldslib -distclean:: - rm -f ${FIELDSLIB}.tar.gz -all: fieldslib - -# https://ocaml.janestreet.com/ocaml-core/109.15.00/individual/ -SEXPLIB=sexplib-109.15.00 -${SEXPLIB}.tar.gz: - ${WGET} https://ocaml.janestreet.com/ocaml-core/109.15.00/individual/$@ -sexplib: ${SEXPLIB}.tar.gz findlib typeconv - printf "%s " "$@" >/dev/tty - test -d ${PREFIX} - rm -rf ${SEXPLIB} - tar zxf ${SEXPLIB}.tar.gz - ./Patcher.sh ${SEXPLIB} - ( cd ${SEXPLIB} && \ - export PATH=${PREFIX}/bin:$$PATH && \ - ocaml setup.ml -configure && \ - ocaml setup.ml -build && \ - ocamlfind remove sexplib && \ - ocaml setup.ml -install ) - echo ${VERSION} >$@ -clean:: - rm -rf ${SEXPLIB} sexplib -distclean:: - rm -f ${SEXPLIB}.tar.gz -all: sexplib - -# https://ocaml.janestreet.com/ocaml-core/109.35.00/individual/ -HERELIB=herelib-109.35.00 -${HERELIB}.tar.gz: - ${WGET} https://ocaml.janestreet.com/ocaml-core/109.35.00/individual/$@ -herelib: ${HERELIB}.tar.gz - printf "%s " "$@" >/dev/tty - test -d ${PREFIX} - rm -rf ${HERELIB} - tar zxf ${HERELIB}.tar.gz - ./Patcher.sh ${HERELIB} - ( cd ${HERELIB} && \ - export PATH=${PREFIX}/bin:$$PATH && \ - sh ./configure --prefix ${PREFIX} && \ - ${MAKE} && \ - ocamlfind remove herelib && \ - ${MAKE} install ) - echo ${VERSION} >$@ -clean:: - rm -rf ${HERELIB} herelib -distclean:: - rm -f ${HERELIB}.tar.gz -all: herelib - -# https://ocaml.janestreet.com/ocaml-core/109.37.00/individual/ -COREKERNEL=core_kernel-109.37.00 -${COREKERNEL}.tar.gz: - ${WGET} https://ocaml.janestreet.com/ocaml-core/109.37.00/individual/$@ -corekernel: ${COREKERNEL}.tar.gz findlib variantslib sexplib fieldslib \ - binprot comparelib paounit pipebang res ounit herelib - printf "%s " "$@" >/dev/tty - test -d ${PREFIX} - rm -rf ${COREKERNEL} - tar zxf ${COREKERNEL}.tar.gz - ./Patcher.sh ${COREKERNEL} - ( cd ${COREKERNEL} && \ - export PATH=${PREFIX}/bin:$$PATH && \ - ocaml setup.ml -configure && \ - ocaml setup.ml -build && \ - ocamlfind remove core_kernel && \ - ocaml setup.ml -install ) - echo ${VERSION} >$@ -clean:: - rm -rf ${COREKERNEL} corekernel -distclean:: - rm -f ${COREKERNEL}.tar.gz -all: core - -# https://ocaml.janestreet.com/ocaml-core/109.37.00/individual/ -CORE=core-109.37.00 -${CORE}.tar.gz: - ${WGET} https://ocaml.janestreet.com/ocaml-core/109.37.00/individual/$@ -xxcore: ${CORE}.tar.gz findlib variantslib sexplib fieldslib binprot comparelib \ - paounit pipebang res ounit corekernel - printf "%s " "$@" >/dev/tty - test -d ${PREFIX} - rm -rf ${CORE} - tar zxf ${CORE}.tar.gz - ./Patcher.sh ${CORE} - ( cd ${CORE} && \ - export PATH=${PREFIX}/bin:$$PATH && \ - ocaml setup.ml -configure && \ - ocaml setup.ml -build && \ - ocamlfind remove core && \ - ocaml setup.ml -install ) - echo ${VERSION} >$@ -clean:: - rm -rf ${CORE} core -distclean:: - rm -f ${CORE}.tar.gz -all: core - -# https://ocaml.janestreet.com/ocaml-core/109.27.00/individual/ -CUSTOMPRINTF=custom_printf-109.27.00 -${CUSTOMPRINTF}.tar.gz: - ${WGET} https://ocaml.janestreet.com/ocaml-core/109.27.00/individual/$@ -customprintf: ${CUSTOMPRINTF}.tar.gz - printf "%s " "$@" >/dev/tty - test -d ${PREFIX} - rm -rf ${CUSTOMPRINTF} - tar zxf ${CUSTOMPRINTF}.tar.gz - ./Patcher.sh ${CUSTOMPRINTF} - ( cd ${CUSTOMPRINTF} && \ - export PATH=${PREFIX}/bin:$$PATH && \ - sh ./configure --prefix ${PREFIX} && \ - ${MAKE} && \ - ocamlfind remove customprintf && \ - ${MAKE} install ) - echo ${VERSION} >$@ -clean:: - rm -rf ${CUSTOMPRINTF} customprintf -distclean:: - rm -f ${CUSTOMPRINTF}.tar.gz -all: customprintf - -# https://ocaml.janestreet.com/ocaml-core/109.36.00/individual/ -TEXTUTILS=textutils-109.36.00 -${TEXTUTILS}.tar.gz: - ${WGET} https://ocaml.janestreet.com/ocaml-core/109.36.00/individual/$@ -textutils: ${TEXTUTILS}.tar.gz - printf "%s " "$@" >/dev/tty - test -d ${PREFIX} - rm -rf ${TEXTUTILS} - tar zxf ${TEXTUTILS}.tar.gz - ./Patcher.sh ${TEXTUTILS} - ( cd ${TEXTUTILS} && \ - export PATH=${PREFIX}/bin:$$PATH && \ - sh ./configure --prefix ${PREFIX} && \ - ${MAKE} && \ - ocamlfind remove textutils && \ - ${MAKE} install ) - echo ${VERSION} >$@ -clean:: - rm -rf ${TEXTUTILS} textutils -distclean:: - rm -f ${TEXTUTILS}.tar.gz -all: textutils - -# https://ocaml.janestreet.com/ocaml-core/109.36.00/individual/ -COREEXTENDED=core_extended-109.36.00 -${COREEXTENDED}.tar.gz: - ${WGET} https://ocaml.janestreet.com/ocaml-core/109.36.00/individual/$@ -coreextended: ${COREEXTENDED}.tar.gz findlib sexplib fieldslib binprot paounit \ - pipebang core pcre res comparelib ounit - printf "%s " "$@" >/dev/tty - test -d ${PREFIX} - rm -rf ${COREEXTENDED} - tar zxf ${COREEXTENDED}.tar.gz - ./Patcher.sh ${COREEXTENDED} - ( cd ${COREEXTENDED} && \ - export PATH=${PREFIX}/bin:$$PATH && \ - ocaml setup.ml -configure && \ - ocaml setup.ml -build && \ - ocaml setup.ml -install ) - echo ${VERSION} >$@ -clean:: - rm -rf ${COREEXTENDED} coreextended -distclean:: - rm -f ${COREEXTENDED}.tar.gz -all: coreextended - -########################################################################### - -# http://erratique.ch/software/react -REACT=react-0.9.3 -${REACT}.tbz: - ${WGET} http://erratique.ch/software/react/releases/$@ -react: ${REACT}.tbz findlib - printf "%s " "$@" >/dev/tty - test -d ${PREFIX} - rm -rf ${REACT} - tar jxf ${REACT}.tbz - ./Patcher.sh ${REACT} oasis-common.patch - ( cd ${REACT} && \ - export PATH=${PREFIX}/bin:$$PATH && \ - ocaml setup.ml -configure && \ - ocaml setup.ml -build && \ - ./test.native && \ - ocamlfind remove react && \ - ocaml setup.ml -install ) - echo ${VERSION} >$@ -clean:: - rm -rf ${REACT} react -distclean:: - rm -f ${REACT}.tbz -all: react - -# http://forge.ocamlcore.org/projects/ocaml-text/ -OCAMLTEXT=ocaml-text-0.5 -${OCAMLTEXT}.tar.gz: - ${WGET} http://forge.ocamlcore.org/frs/download.php/641/$@ -ocamltext: ${OCAMLTEXT}.tar.gz findlib - printf "%s " "$@" >/dev/tty - test -d ${PREFIX} - rm -rf ${OCAMLTEXT} - tar zxf ${OCAMLTEXT}.tar.gz - ./Patcher.sh ${OCAMLTEXT} oasis-common.patch - ( cd ${OCAMLTEXT} && \ - export PATH=${PREFIX}/bin:$$PATH && \ - ${MAKE} build && \ - ${MAKE} test && \ - ocamlfind remove text && \ - ${MAKE} install ) - echo ${VERSION} >$@ -clean:: - rm -rf ${OCAMLTEXT} ocamltext -distclean:: - rm -f ${OCAMLTEXT}.tar.gz -all: ocamltext - -# https://github.com/savonet/ocaml-ssl -OCAMLSSL=ocaml-ssl-0.4.6 -${OCAMLSSL}.tar.gz: - ${WGET} https://github.com/savonet/ocaml-ssl/archive/$@ -ocamlssl: ${OCAMLSSL}.tar.gz findlib - printf "%s " "$@" >/dev/tty - test -d ${PREFIX} - rm -rf ${OCAMLSSL} - tar zxf ${OCAMLSSL}.tar.gz && mv ocaml-ssl-${OCAMLSSL} ${OCAMLSSL} - ./Patcher.sh ${OCAMLSSL} - ( cd ${OCAMLSSL} && \ - export PATH=${PREFIX}/bin:$$PATH && \ - autoconf configure.ac >configure && \ - sh ./configure && \ - ${MAKE} && \ - ocamlfind remove ssl && \ - ${MAKE} install ) - echo ${VERSION} >$@ -clean:: - rm -rf ${OCAMLSSL} ocamlssl -distclean:: - rm -f ${OCAMLSSL}.tar.gz -all: ocamlssl - -# http://ocsigen.org/lwt/install -LWT=lwt-2.4.0 -${LWT}.tar.gz: - ${WGET} http://ocsigen.org/download/$@ -xxlwt: ${LWT}.tar.gz findlib react ocamltext ocamlssl camlp4 lablgtk - printf "%s " "$@" >/dev/tty - test -d ${PREFIX} - rm -rf ${LWT} - tar zxf ${LWT}.tar.gz - ./Patcher.sh ${LWT} - ( cd ${LWT} && \ - export PATH=${PREFIX}/bin:$$PATH && \ - export C_INCLUDE_PATH=/usr/include:/opt/local/include && \ - export LIBRARY_PATH=/usr/lib:/opt/local/lib && \ - ./configure --enable-ssl --enable-react && \ - ${MAKE} && \ - ocamlfind remove lwt && \ - ${MAKE} install ) - echo ${VERSION} >$@ -clean:: - rm -rf ${LWT} lwt -distclean:: - rm -f ${LWT}.tar.gz -all: lwt - -# http://forge.ocamlcore.org/projects/camlzip/ -CAMLZIP=camlzip-1.04 -${CAMLZIP}.tar.gz: - ${WGET} http://forge.ocamlcore.org/frs/download.php/328/$@ -camlzip: ${CAMLZIP}.tar.gz findlib - printf "%s " "$@" >/dev/tty - test -d ${PREFIX} - rm -rf ${CAMLZIP} - tar zxf ${CAMLZIP}.tar.gz - ./Patcher.sh ${CAMLZIP} - ( cd ${CAMLZIP} && \ - export PATH=${PREFIX}/bin:$$PATH && \ - ${MAKE} all && \ - ${MAKE} allopt && \ - ${MAKE} install && \ - ${MAKE} installopt && \ - ocamlfind remove camlzip && \ - ocamlfind install camlzip META ) - echo ${VERSION} >$@ -clean:: - rm -rf ${CAMLZIP} camlzip -distclean:: - rm -f ${CAMLZIP}.tar.gz -all: camlzip - -# http://forge.ocamlcore.org/projects/cryptokit/ -CRYPTOKIT=cryptokit-1.6 -${CRYPTOKIT}.tar.gz: - ${WGET} http://forge.ocamlcore.org/frs/download.php/891/$@ -cryptokit: ${CRYPTOKIT}.tar.gz findlib - printf "%s " "$@" >/dev/tty - test -d ${PREFIX} - rm -rf ${CRYPTOKIT} - tar zxf ${CRYPTOKIT}.tar.gz - ./Patcher.sh ${CRYPTOKIT} - ( cd ${CRYPTOKIT} && \ - export PATH=${PREFIX}/bin:$$PATH && \ - ${MAKE} build && \ - ${MAKE} test && \ - ocamlfind remove cryptokit && \ - ${MAKE} install ) - echo ${VERSION} >$@ -clean:: - rm -rf ${CRYPTOKIT} cryptokit -distclean:: - rm -f ${CRYPTOKIT}.tar.gz -all: cryptokit - -# https://bitbucket.org/mmottl -SQLITE=sqlite3-ocaml-2.0.1 -${SQLITE}.tar.gz: - ${WGET} https://bitbucket.org/mmottl/sqlite3-ocaml/downloads/$@ -sqlite: ${SQLITE}.tar.gz findlib - printf "%s " "$@" >/dev/tty - test -d ${PREFIX} - rm -rf ${SQLITE} - tar zxf ${SQLITE}.tar.gz - ./Patcher.sh ${SQLITE} oasis-common.patch - ( cd ${SQLITE} && \ - export PATH=${PREFIX}/bin:$$PATH && \ - ocaml setup.ml -configure && \ - ocaml setup.ml -build && \ - ocamlfind remove sqlite3 && \ - ocaml setup.ml -install ) - echo ${VERSION} >$@ -clean:: - rm -rf ${SQLITE} sqlite -distclean:: - rm -f ${SQLITE}.tar.gz -all: sqlite - -# http://gallium.inria.fr/~fpottier/menhir/ -MENHIR=menhir-20120123 -${MENHIR}.tar.gz: - ${WGET} http://gallium.inria.fr/~fpottier/menhir/$@ -menhir: ${MENHIR}.tar.gz - printf "%s " "$@" >/dev/tty - test -d ${PREFIX} - rm -rf ${MENHIR} - tar zxf ${MENHIR}.tar.gz - ./Patcher.sh ${MENHIR} - ( cd ${MENHIR} && \ - export PATH=${PREFIX}/bin:$$PATH && \ - ${MAKE} PREFIX=${PREFIX} && \ - ocamlfind remove MenhirLib && \ - ${MAKE} PREFIX=${PREFIX} install) - echo ${VERSION} >$@ -clean:: - rm -rf ${MENHIR} menhir -distclean:: - rm -f ${MENHIR}.tar.gz -all: menhir - -# disabled: cannot find module Js -# # http://ocsigen.org/obrowser/install -# OBROWSER=obrowser-1.1.1 -# ${OBROWSER}.tar.gz: -# ${WGET} http://ocsigen.org/download/$@ -# obrowser: ${OBROWSER}.tar.gz lwt menhir ocsigen -# printf "%s " "$@" >/dev/tty -# test -d ${PREFIX} -# rm -rf ${OBROWSER} -# tar zxf ${OBROWSER}.tar.gz -# ./Patcher.sh ${OBROWSER} -# ( cd ${OBROWSER} && \ -# export PATH=${PREFIX}/bin:$$PATH && \ -# ${MAKE} && \ -# ocamlfind remove obrowser && \ -# ${MAKE} install ) -# echo ${VERSION} >$@ -# clean:: -# rm -rf ${OBROWSER} obrowser -# distclean:: -# rm -f ${OBROWSER}.tar.gz -# all: obrowser - -# http://hevea.inria.fr/old/ -HEVEA=hevea-2.09 -${HEVEA}.tar.gz: - ${WGET} http://hevea.inria.fr/old/$@ -hevea: ${HEVEA}.tar.gz - printf "%s " "$@" >/dev/tty - test -d ${PREFIX} - rm -rf ${HEVEA} - tar zxf ${HEVEA}.tar.gz - ./Patcher.sh ${HEVEA} - ( cd ${HEVEA} && \ - export PATH=${PREFIX}/bin:$$PATH && \ - ${MAKE} PREFIX=${PREFIX} && \ - ${MAKE} PREFIX=${PREFIX} install ) - echo ${VERSION} >$@ -clean:: - rm -rf ${HEVEA} hevea -distclean:: - rm -f ${HEVEA}.tar.gz -all: hevea - -# http://www.seas.upenn.edu/~bcpierce/unison/download/releases/ -UNISON=unison-2.45.4 -${UNISON}.tar.gz: - ${WGET} http://www.seas.upenn.edu/~bcpierce/unison/download/releases/unison-2.45.4/$@ -unison: ${UNISON}.tar.gz lablgtk - printf "%s " "$@" >/dev/tty - test -d ${PREFIX} - rm -rf ${UNISON} - tar zxf ${UNISON}.tar.gz - ./Patcher.sh ${UNISON} - ( cd ${UNISON} && \ - export PATH=${PREFIX}/bin:$$PATH && \ - ${MAKE} UISTYLE=gtk2 && \ - touch ${PREFIX}/bin/unison && \ - ${MAKE} UISTYLE=gtk2 INSTALLDIR=${PREFIX}/bin/ install ) - echo ${VERSION} >$@ -clean:: - rm -rf ${UNISON} unison -distclean:: - rm -f ${UNISON}.tar.gz -all: unison - -# http://raevnos.pennmush.org/code/ocaml-mysql/ -MYSQL=ocaml-mysql-1.0.4 -${MYSQL}.tar.gz: - ${WGET} http://raevnos.pennmush.org/code/ocaml-mysql/$@ -mysql: ${MYSQL}.tar.gz findlib - printf "%s " "$@" >/dev/tty - test -d ${PREFIX} - rm -rf ${MYSQL} - tar zxf ${MYSQL}.tar.gz - ./Patcher.sh ${MYSQL} - ( cd ${MYSQL} && \ - export PATH=${PREFIX}/bin:$$PATH && \ - export CPPFLAGS=-I/opt/local/include/mysql5 && \ - export LDFLAGS=-L/opt/local/lib/mysql5/mysql && \ - ./configure -prefix ${PREFIX} && \ - ${MAKE} && \ - ${MAKE} opt && \ - ocamlfind remove mysql && \ - ${MAKE} install ) - echo ${VERSION} >$@ -clean:: - rm -rf ${MYSQL} mysql -distclean:: - rm -f ${MYSQL}.tar.gz -all: mysql - -# http://gallium.inria.fr/~guesdon/Tools/ocgi/ -OCGI=ocgi-0.5 -${OCGI}.tar.gz: - ${WGET} http://pauillac.inria.fr/~guesdon/Tools/Tars/$@ -ocgi: ${OCGI}.tar.gz camlp4 - printf "%s " "$@" >/dev/tty - test -d ${PREFIX} - rm -rf ${OCGI} - tar zxf ${OCGI}.tar.gz - ./Patcher.sh ${OCGI} - ( cd ${OCGI} && \ - export PATH=${PREFIX}/bin:$$PATH && \ - ./configure && \ - ${MAKE} && \ - ${MAKE} opt && \ - ${MAKE} install ) - echo ${VERSION} >$@ -clean:: - rm -rf ${OCGI} ocgi -distclean:: - rm -f ${OCGI}.tar.gz -all: ocgi - -# http://tech.motion-twin.com/xmllight -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} - tar zxf ${XMLLIGHT}.tar.gz - ./Patcher.sh ${XMLLIGHT} - ( cd ${XMLLIGHT} && \ - export PATH=${PREFIX}/bin:$$PATH && \ - ${MAKE} xml_parser.ml && \ - ${MAKE} all opt && \ - ${MAKE} install_ocamlfind ) - echo ${VERSION} >$@ -clean:: - rm -rf ${XMLLIGHT} xml-light xmllight -distclean:: - rm -f ${XMLLIGHT}.zip -all: xmllight - -# http://config-file.forge.ocamlcore.org/ -CONFIGFILE=config-file-1.1 -${CONFIGFILE}.tar.gz: - ${WGET} https://forge.ocamlcore.org/frs/download.php/845/$@ -configfile: ${CONFIGFILE}.tar.gz camlp4 - printf "%s " "$@" >/dev/tty - test -d ${PREFIX} - rm -rf ${CONFIGFILE} - tar zxf ${CONFIGFILE}.tar.gz - ./Patcher.sh ${CONFIGFILE} - ( cd ${CONFIGFILE} && \ - export PATH=${PREFIX}/bin:$$PATH && \ - sh ./configure --prefix=${PREFIX} && \ - ${MAKE} all && \ - ocamlfind remove config-file && \ - ${MAKE} install ) - echo ${VERSION} >$@ -clean:: - rm -rf ${CONFIGFILE} configfile -distclean:: - rm -f ${CONFIGFILE}.tar.gz -all: configfile - -# http://erratique.ch/software/xmlm -XMLM=xmlm-1.1.0 -${XMLM}.tbz: - ${WGET} http://erratique.ch/software/xmlm/releases/$@ -xmlm: ${XMLM}.tbz findlib - printf "%s " "$@" >/dev/tty - test -d ${PREFIX} - rm -rf ${XMLM} - tar jxf ${XMLM}.tbz - ./Patcher.sh ${XMLM} oasis-common.patch - ( cd ${XMLM} && \ - export PATH=${PREFIX}/bin:$$PATH && \ - ocaml setup.ml -configure --prefix ${PREFIX} && \ - ocaml setup.ml -build && \ - ocamlfind remove xmlm && \ - ocaml setup.ml -install ) - echo ${VERSION} >$@ -clean:: - rm -rf ${XMLM} xmlm -distclean:: - rm -f ${XMLM}.tbz -all: xmlm - -# http://forge.ocamlcore.org/projects/gtk-extras/ -LABLGTKEXTRAS=lablgtkextras-1.3 -${LABLGTKEXTRAS}.tar.gz: - ${WGET} http://forge.ocamlcore.org/frs/download.php/1072/$@ -lablgtkextras: ${LABLGTKEXTRAS}.tar.gz lablgtk configfile xmlm - printf "%s " "$@" >/dev/tty - test -d ${PREFIX} - rm -rf ${LABLGTKEXTRAS} - tar zxf ${LABLGTKEXTRAS}.tar.gz - ./Patcher.sh ${LABLGTKEXTRAS} - ( cd ${LABLGTKEXTRAS} && \ - export PATH=${PREFIX}/bin:$$PATH && \ - sh ./configure --prefix ${PREFIX} && \ - ${MAKE} all && \ - ocamlfind remove lablgtk2-extras && \ - ${MAKE} install ) - echo ${VERSION} >$@ -clean:: - rm -rf ${LABLGTKEXTRAS} lablgtkextras -distclean:: - rm -f ${LABLGTKEXTRAS}.tar.gz -all: lablgtkextras - -# https://bitbucket.org/skskeyserver/sks-keyserver/downloads -SKS=sks-1.1.3 -${SKS}.tgz: - ${WGET} https://bitbucket.org/skskeyserver/sks-keyserver/downloads/$@ -sks: ${SKS}.tgz camlp4 - printf "%s " "$@" >/dev/tty - test -d ${PREFIX} - rm -rf ${SKS} - tar zxf ${SKS}.tgz - ./Patcher.sh ${SKS} - ( cd ${SKS} && \ - export PATH=${PREFIX}/bin:$$PATH && \ - ${MAKE} dep PREFIX=${PREFIX} && \ - ${MAKE} all PREFIX=${PREFIX} && \ - ${MAKE} all.bc PREFIX=${PREFIX} && \ - ${MAKE} install PREFIX=${PREFIX} ) - echo ${VERSION} >$@ -clean:: - rm -rf ${SKS} sks -distclean:: - rm -f ${SKS}.tgz -all: sks - -# http://omake.metaprl.org/download.html -OMAKE=omake-0.9.8.6 -${OMAKE}-0.rc1.tar.gz: - ${WGET} http://omake.metaprl.org/downloads/$@ -omake: ${OMAKE}-0.rc1.tar.gz - printf "%s " "$@" >/dev/tty - test -d ${PREFIX} - rm -rf ${OMAKE} - tar zxf ${OMAKE}-0.rc1.tar.gz - ./Patcher.sh ${OMAKE} - ( cd ${OMAKE} && \ - export PATH=${PREFIX}/bin:$$PATH && \ - export PREFIX=${PREFIX} && \ - ${MAKE} all && \ - ${MAKE} install ) - echo ${VERSION} >$@ -clean:: - rm -rf ${OMAKE} omake -distclean:: - rm -f ${OMAKE}-0.rc1.tar.gz -all: omake - -# http://forge.ocamlcore.org/projects/zarith -ZARITH=zarith-1.2.1 -${ZARITH}.tar.gz: - ${WGET} http://forge.ocamlcore.org/frs/download.php/1199/$@ -zarith: ${ZARITH}.tar.gz - printf "%s " "$@" >/dev/tty - test -d ${PREFIX} - rm -rf ${ZARITH} - tar zxf ${ZARITH}.tar.gz - ./Patcher.sh ${ZARITH} - ( cd ${ZARITH} && \ - export PATH=${PREFIX}/bin:$$PATH && \ - sh ./configure && \ - ${MAKE} && \ - ocamlfind remove zarith && \ - ${MAKE} install ) - echo ${VERSION} >$@ -clean:: - rm -rf ${ZARITH} zarith -distclean:: - rm -f ${ZARITH}.tar.gz -all: zarith - -# http://alt-ergo.ocamlpro.com -ALTERGO=alt-ergo-0.95.2 -${ALTERGO}.tar.gz: - ${WGET} http://alt-ergo.ocamlpro.com/download_manager.php?target=$@ -O $@ -altergo: ${ALTERGO}.tar.gz ocamlgraph zarith - printf "%s " "$@" >/dev/tty - test -d ${PREFIX} - rm -rf ${ALTERGO} - tar zxf ${ALTERGO}.tar.gz - ./Patcher.sh ${ALTERGO} - ( cd ${ALTERGO} && \ - export PATH=${PREFIX}/bin:$$PATH && \ - ./configure -prefix ${PREFIX} && \ - ${MAKE} && \ - ${MAKE} install ) - echo ${VERSION} >$@ -clean:: - rm -rf ${ALTERGO} altergo -distclean:: - rm -f ${ALTERGO}.tar.gz -all: altergo - -# http://www.seas.upenn.edu/~harmony/ -BOOMERANG=boomerang-0.2 -${BOOMERANG}-source.tar.gz: - ${WGET} http://www.seas.upenn.edu/~harmony/download/$@ -boomerang: ${BOOMERANG}-source.tar.gz omake - printf "%s " "$@" >/dev/tty - test -d ${PREFIX} - rm -rf ${BOOMERANG} - tar zxf ${BOOMERANG}-source.tar.gz && mv boomerang-20090902 ${BOOMERANG} - ./Patcher.sh ${BOOMERANG} - ( cd ${BOOMERANG} && \ - export PATH=${PREFIX}/bin:$$PATH && \ - omake ) - echo ${VERSION} >$@ -clean:: - rm -rf ${BOOMERANG} boomerang -distclean:: - rm -f ${BOOMERANG}-source.tar.gz -all: boomerang - -# https://github.com/yoriyuki/Camomile/wiki -CAMOMILE=camomile-0.8.4 -${CAMOMILE}.tar.bz2: - ${WGET} https://github.com/downloads/yoriyuki/Camomile/$@ -camomile: ${CAMOMILE}.tar.bz2 camlp4 - printf "%s " "$@" >/dev/tty - test -d ${PREFIX} - rm -rf ${CAMOMILE} - tar xf ${CAMOMILE}.tar.bz2 - ./Patcher.sh ${CAMOMILE} - ( cd ${CAMOMILE} && \ - export PATH=${PREFIX}/bin:$$PATH && \ - ./configure -prefix ${PREFIX} && \ - ${MAKE} && \ - ocamlfind remove camomile && \ - ${MAKE} install ) - echo ${VERSION} >$@ -clean:: - rm -rf ${CAMOMILE} camomile -distclean:: - rm -f ${CAMOMILE}.tar.bz2 -all: camomile - -# http://sanskrit.inria.fr/ZEN/ -ZEN=zen_2.3.2 -${ZEN}.tar.gz: - ${WGET} http://sanskrit.inria.fr/ZEN/$@ -zen: ${ZEN}.tar.gz camlp4 - printf "%s " "$@" >/dev/tty - test -d ${PREFIX} - rm -rf ${ZEN} - tar zxf ${ZEN}.tar.gz && mv ZEN_* ${ZEN} - ./Patcher.sh ${ZEN} - ( cd ${ZEN} && \ - export PATH=${PREFIX}/bin:$$PATH && \ - ${MAKE} depend && \ - ${MAKE} all && \ - ${MAKE} install ) - echo ${VERSION} >$@ -clean:: - rm -rf ${ZEN} zen -distclean:: - rm -f ${ZEN}.tar.gz -all: zen - -# http://users-tima.imag.fr/vds/ouchet/index_fichiers/vsyml.html -VSYML=vsyml-2010-04-06 -${VSYML}.tar.gz: - ${WGET} http://users-tima.imag.fr/vds/ouchet/vsyml/$@ -vsyml: ${VSYML}.tar.gz - printf "%s " "$@" >/dev/tty - test -d ${PREFIX} - rm -rf ${VSYML} - tar zxf ${VSYML}.tar.gz - ./Patcher.sh ${VSYML} - ( cd ${VSYML} && \ - export PATH=${PREFIX}/bin:$$PATH && \ - ${MAKE} ) - echo ${VERSION} >$@ -clean:: - rm -rf ${VSYML} vsyml -distclean:: - rm -f ${VSYML}.tar.gz -all: vsyml - -# http://projects.camlcity.org/projects/ocamlnet.html -OCAMLNET=ocamlnet-3.5.1 -${OCAMLNET}.tar.gz: - ${WGET} http://download.camlcity.org/download/$@ -ocamlnet: ${OCAMLNET}.tar.gz findlib pcre camlp4 ocamlssl camlzip cryptokit - printf "%s " "$@" >/dev/tty - test -d ${PREFIX} - rm -rf ${OCAMLNET} - tar zxf ${OCAMLNET}.tar.gz - ./Patcher.sh ${OCAMLNET} - ( cd ${OCAMLNET} && \ - export PATH=${PREFIX}/bin:$$PATH && \ - ./configure && \ - ${MAKE} all && \ - ${MAKE} opt && \ - ocamlfind remove netsys && \ - ocamlfind remove netshm && \ - ocamlfind remove netstring && \ - ocamlfind remove equeue && \ - ocamlfind remove shell && \ - ocamlfind remove rpc-generator && \ - ocamlfind remove rpc-auth-local && \ - ocamlfind remove rpc && \ - ocamlfind remove pop && \ - ocamlfind remove smtp && \ - ocamlfind remove netclient && \ - ocamlfind remove netcgi2 && \ - ocamlfind remove netplex && \ - ocamlfind remove netcgi2-plex && \ - ocamlfind remove netcamlbox && \ - ocamlfind remove netmulticore && \ - ocamlfind remove netgssapi && \ - ${MAKE} install ) - echo ${VERSION} >$@ -clean:: - rm -rf ${OCAMLNET} ocamlnet -distclean:: - rm -f ${OCAMLNET}.tar.gz -all: ocamlnet - -# http://zoggy.github.io/ocamlrss/ -RSS=ocamlrss-2.2.2 -${RSS}.tar.gz: - ${WGET} http://zoggy.github.io/ocamlrss/$@ -rss: ${RSS}.tar.gz xmlm ocamlnet - printf "%s " "$@" >/dev/tty - test -d ${PREFIX} - rm -rf ${RSS} - tar zxf ${RSS}.tar.gz - ./Patcher.sh ${RSS} - ( cd ${RSS} && \ - export PATH=${PREFIX}/bin:$$PATH && \ - ${MAKE} all && \ - ocamlfind remove ocaml-rss && \ - ${MAKE} install ) - echo ${VERSION} >$@ -clean:: - rm -rf ${RSS} rss -distclean:: - rm -f ${RSS}.tar.gz -all: rss - -# http://code.google.com/p/ocaml-extlib/ -EXTLIB=extlib-1.5.2 -${EXTLIB}.tar.gz: - ${WGET} http://ocaml-extlib.googlecode.com/files/$@ -extlib: ${EXTLIB}.tar.gz - printf "%s " "$@" >/dev/tty - test -d ${PREFIX} - rm -rf ${EXTLIB} - tar zxf ${EXTLIB}.tar.gz - ./Patcher.sh ${EXTLIB} - ( cd ${EXTLIB} && \ - export PATH=${PREFIX}/bin:$$PATH && \ - ocamlfind remove extlib && \ - ocaml install.ml -b -n -doc ) - echo ${VERSION} >$@ -clean:: - rm -rf ${EXTLIB} extlib -distclean:: - rm -f ${EXTLIB}.tar.gz -all: extlib - -# http://forge.ocamlcore.org/projects/ocaml-fileutils -FILEUTILS=ocaml-fileutils-0.4.4 -${FILEUTILS}.tar.gz: - ${WGET} http://forge.ocamlcore.org/frs/download.php/892/$@ -xxfileutils: ${FILEUTILS}.tar.gz findlib ounit - printf "%s " "$@" >/dev/tty - test -d ${PREFIX} - rm -rf ${FILEUTILS} - tar xf ${FILEUTILS}.tar.gz - ./Patcher.sh ${FILEUTILS} - ( cd ${FILEUTILS} && \ - export PATH=${PREFIX}/bin:$$PATH && \ - sh ./configure --prefix ${PREFIX} && \ - ${MAKE} && \ - ocamlfind remove fileutils && \ - ${MAKE} install ) - echo ${VERSION} >$@ -clean:: - rm -rf ${FILEUTILS} fileutils -distclean:: - rm -f ${FILEUTILS}.tar.gz -all: fileutils - -# http://forge.ocamlcore.org/projects/odn -ODN=ocaml-data-notation-0.0.10 -${ODN}.tar.gz: - ${WGET} http://forge.ocamlcore.org/frs/download.php/1029/$@ -odn: ${ODN}.tar.gz findlib core ounit fileutils - printf "%s " "$@" >/dev/tty - test -d ${PREFIX} - rm -rf ${ODN} - tar zxf ${ODN}.tar.gz - ./Patcher.sh ${ODN} oasis-common.patch - ( cd ${ODN} && \ - export PATH=${PREFIX}/bin:$$PATH && \ - ocaml setup.ml -configure && \ - ocaml setup.ml -build && \ - ocamlfind remove odn && \ - ocaml setup.ml -install ) - echo ${VERSION} >$@ -clean:: - rm -rf ${ODN} odn -distclean:: - rm -f ${ODN}.tar.gz -all: odn - -# http://forge.ocamlcore.org/projects/ocamlify -OCAMLIFY=ocamlify-0.0.1 -${OCAMLIFY}.tar.gz: - ${WGET} http://forge.ocamlcore.org/frs/download.php/379/$@ -ocamlify: ${OCAMLIFY}.tar.gz findlib - printf "%s " "$@" >/dev/tty - test -d ${PREFIX} - rm -rf ${OCAMLIFY} - tar zxf ${OCAMLIFY}.tar.gz - ./Patcher.sh ${OCAMLIFY} oasis-common.patch - ( cd ${OCAMLIFY} && \ - export PATH=${PREFIX}/bin:$$PATH && \ - sh ./configure --prefix ${PREFIX} && \ - ocaml setup.ml -build && \ - ocaml setup.ml -install ) - echo ${VERSION} >$@ -clean:: - rm -rf ${OCAMLIFY} ocamlify -distclean:: - rm -f ${OCAMLIFY}.tar.gz -all: ocamlify - -# http://forge.ocamlcore.org/projects/ocaml-expect -EXPECT=ocaml-expect-0.0.3 -${EXPECT}.tar.gz: - ${WGET} http://forge.ocamlcore.org/frs/download.php/894/$@ -expect: ${EXPECT}.tar.gz findlib extlib pcre ounit - printf "%s " "$@" >/dev/tty - test -d ${PREFIX} - rm -rf ${EXPECT} - tar zxf ${EXPECT}.tar.gz - ./Patcher.sh ${EXPECT} oasis-common.patch - ( cd ${EXPECT} && \ - export PATH=${PREFIX}/bin:$$PATH && \ - ocaml setup.ml -configure && \ - ocaml setup.ml -build && \ - ocamlfind remove expect && \ - ocaml setup.ml -install ) - echo ${VERSION} >$@ -clean:: - rm -rf ${EXPECT} expect -distclean:: - rm -f ${EXPECT}.tar.gz -all: expect - -# http://forge.ocamlcore.org/projects/ocamlmod/ -OCAMLMOD=ocamlmod-0.0.3 -${OCAMLMOD}.tar.gz: - ${WGET} http://forge.ocamlcore.org/frs/download.php/856/$@ -ocamlmod: ${OCAMLMOD}.tar.gz findlib fileutils pcre - printf "%s " "$@" >/dev/tty - test -d ${PREFIX} - rm -rf ${OCAMLMOD} - tar zxf ${OCAMLMOD}.tar.gz - ./Patcher.sh ${OCAMLMOD} - ( cd ${OCAMLMOD} && \ - export PATH=${PREFIX}/bin:$$PATH && \ - sh ./configure --prefix ${PREFIX} && \ - ${MAKE} && \ - ${MAKE} install ) - echo ${VERSION} >$@ -clean:: - rm -rf ${OCAMLMOD} ocamlmod -distclean:: - rm -f ${OCAMLMOD}.tar.gz -all: ocamlmod - -# http://forge.ocamlcore.org/projects/oasis -OASIS=oasis-0.3.0 -${OASIS}.tar.gz: - ${WGET} http://forge.ocamlcore.org/frs/download.php/918/$@ -oasis: ${OASIS}.tar.gz findlib fileutils pcre extlib odn ocamlgraph ocamlify \ - ounit expect ocamlmod - printf "%s " "$@" >/dev/tty - test -d ${PREFIX} - rm -rf ${OASIS} - tar zxf ${OASIS}.tar.gz - ./Patcher.sh ${OASIS} oasis-common.patch - ( cd ${OASIS} && \ - export PATH=${PREFIX}/bin:$$PATH && \ - sh ./configure --prefix ${PREFIX} && \ - ocaml setup.ml -build && \ - ocamlfind remove oasis && \ - ocamlfind remove userconf && \ - ocamlfind remove plugin-loader && \ - ocaml setup.ml -install ) - echo ${VERSION} >$@ -clean:: - rm -rf ${OASIS} oasis -distclean:: - rm -f ${OASIS}.tar.gz -all: oasis - -# http://calendar.forge.ocamlcore.org/ -CALENDAR=calendar-2.03.2 -${CALENDAR}.tar.gz: - ${WGET} https://forge.ocamlcore.org/frs/download.php/915/$@ -calendar: ${CALENDAR}.tar.gz - printf "%s " "$@" >/dev/tty - test -d ${PREFIX} - rm -rf ${CALENDAR} - tar zxf ${CALENDAR}.tar.gz - ./Patcher.sh ${CALENDAR} - ( cd ${CALENDAR} && \ - export PATH=${PREFIX}/bin:$$PATH && \ - sh ./configure --prefix ${PREFIX} && \ - ${MAKE} && \ - ${MAKE} install ) - echo ${VERSION} >$@ -clean:: - rm -rf ${CALENDAR} calendar -distclean:: - rm -f ${CALENDAR}.tar.gz -all: calendar - -# http://gallium.inria.fr/camlimages/ -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 $@ -xxcamlimages: ${CAMLIMAGES}.tar.gz findlib omake lablgtk - printf "%s " "$@" >/dev/tty - test -d ${PREFIX} - rm -rf ${CAMLIMAGES} - tar xf ${CAMLIMAGES}.tar.gz - mv camlspotter-camlimages-c803efa9d5d3 ${CAMLIMAGES} - mv ${CAMLIMAGES}/doc/old/* ${CAMLIMAGES}/doc/ - ./Patcher.sh ${CAMLIMAGES} - ( cd ${CAMLIMAGES} && \ - export PATH=${PREFIX}/bin:$$PATH && \ - omake && \ - ocamlfind remove camlimages && \ - omake install ) - echo ${VERSION} >$@ -clean:: - rm -rf ${CAMLIMAGES} camlimages -distclean:: - rm -f ${CAMLIMAGES}.tar.gz -all: camlimages - -# http://advi.inria.fr/ -ADVI=advi-1.10.2 -${ADVI}.tar.gz: - ${WGET} http://advi.inria.fr/$@ -advi: ${ADVI}.tar.gz findlib camlimages - printf "%s " "$@" >/dev/tty - test -d ${PREFIX} - rm -rf ${ADVI} - tar zxf ${ADVI}.tar.gz - ./Patcher.sh ${ADVI} - ( cd ${ADVI} && \ - export PATH=${PREFIX}/bin:$$PATH && \ - sh ./configure --prefix ${PREFIX} && \ - ${MAKE} && \ - ${MAKE} install ) - echo ${VERSION} >$@ -clean:: - rm -rf ${ADVI} advi -distclean:: - rm -f ${ADVI}.tar.gz -all: advi - -# http://forge.ocamlcore.org/projects/camldbm -DBM=camldbm-1.0 -${DBM}.tgz: - ${WGET} http://forge.ocamlcore.org/frs/download.php/728/$@ -dbm: ${DBM}.tgz - printf "%s " "$@" >/dev/tty - test -d ${PREFIX} - rm -rf ${DBM} - tar zxf ${DBM}.tgz - ./Patcher.sh ${DBM} - ( cd ${DBM} && \ - export PATH=${PREFIX}/bin:$$PATH && \ - sh ./configure --prefix ${PREFIX} && \ - ${MAKE} && \ - ${MAKE} install ) - echo ${VERSION} >$@ -clean:: - rm -rf ${DBM} dbm -distclean:: - rm -f ${DBM}.tgz -all: dbm - -# http://ocsigen.org/ -OCSIGEN=ocsigen-bundle-2.2.2 -${OCSIGEN}.tar.gz: - ${WGET} http://ocsigen.org/download/$@ -ocsigen: ${OCSIGEN}.tar.gz findlib lwt pcre ocamlnet ocamlssl \ - sqlite camlzip cryptokit calendar dbm - printf "%s " "$@" >/dev/tty - test -d ${PREFIX} - rm -rf ${OCSIGEN} - tar zxf ${OCSIGEN}.tar.gz - ./Patcher.sh ${OCSIGEN} - ( cd ${OCSIGEN} && \ - export PATH=${PREFIX}/bin:$$PATH && \ - export OCSIGEN_USER=${USER}; export OCSIGEN_GROUP=everyone && \ - ./configure --prefix=${PREFIX} && \ - ${MAKE} && \ - rm -rf ${PREFIX}/lib/ocaml/ocsigenserver/extensions && \ - ocamlfind remove -destdir ${PREFIX}/lib/ocaml deriving-ocsigen && \ - ocamlfind remove -destdir ${PREFIX}/lib/ocaml js_of_ocaml && \ - ocamlfind remove -destdir ${PREFIX}/lib/ocaml ocsigenserver && \ - ocamlfind remove -destdir ${PREFIX}/lib/ocaml tyxml && \ - ${MAKE} install ) - echo ${VERSION} >$@ -clean:: - rm -rf ${OCSIGEN} ocsigen -distclean:: - rm -f ${OCSIGEN}.tar.gz -all: ocsigen - -# http://mldonkey.sourceforge.net/ -MLDONKEY=mldonkey-3.1.2 -${MLDONKEY}.tar.bz2: - ${WGET} http://freefr.dl.sourceforge.net/project/mldonkey/mldonkey/3.1.2/$@ -mldonkey: ${MLDONKEY}.tar.bz2 lablgtk - printf "%s " "$@" >/dev/tty - test -d ${PREFIX} - rm -rf ${MLDONKEY} - tar zxf ${MLDONKEY}.tar.bz2 - ./Patcher.sh ${MLDONKEY} - ( cd ${MLDONKEY} && \ - export PATH=${PREFIX}/bin:$$PATH && \ - sh ./configure && \ - ${MAKE} ) - echo ${VERSION} >$@ -clean:: - rm -rf ${MLDONKEY} mldonkey -distclean:: - rm -f ${MLDONKEY}.tar.bz2 -all: mldonkey - -# http://mjambon.com/releases/ocamlscript -OCAMLSCRIPT=ocamlscript-2.0.3 -${OCAMLSCRIPT}.tar.gz: - ${WGET} http://mjambon.com/releases/ocamlscript/$@ -ocamlscript: ${OCAMLSCRIPT}.tar.gz findlib camlp4 - printf "%s " "$@" >/dev/tty - test -d ${PREFIX} - rm -rf ${OCAMLSCRIPT} - tar xf ${OCAMLSCRIPT}.tar.gz - ./Patcher.sh ${OCAMLSCRIPT} - ( cd ${OCAMLSCRIPT} && \ - export PATH=${PREFIX}/bin:$$PATH && \ - ${MAKE} && \ - ocamlfind remove ocamlscript && \ - ${MAKE} install ) - echo ${VERSION} >$@ -clean:: - rm -rf ${OCAMLSCRIPT} ocamlscript -distclean:: - rm -f ${OCAMLSCRIPT}.tar.bz2 -all: ocamlscript - -# https://forge.ocamlcore.org/projects/kaputt/ -KAPUTT=kaputt-1.2 -${KAPUTT}.tar.gz: - ${WGET} https://forge.ocamlcore.org/frs/download.php/987/$@ -kaputt: ${KAPUTT}.tar.gz findlib - printf "%s " "$@" >/dev/tty - test -d ${PREFIX} - rm -rf ${KAPUTT} - tar zxf ${KAPUTT}.tar.gz - ./Patcher.sh ${KAPUTT} - ( cd ${KAPUTT} && \ - export PATH=${PREFIX}/bin:$$PATH && \ - sh ./configure -ocaml-prefix ${PREFIX} && \ - ${MAKE} all && \ - ocamlfind remove kaputt && \ - ${MAKE} install ) - echo ${VERSION} >$@ -clean:: - rm -rf ${KAPUTT} kaputt -distclean:: - rm -f ${KAPUTT}.tar.gz -all: kaputt - -# http://www.coherentpdf.com/ocaml-libraries.html -CAMLPDF=camlpdf-0.5 -${CAMLPDF}.tar.bz2: - ${WGET} http://www.coherentpdf.com/$@ -camlpdf: ${CAMLPDF}.tar.bz2 - printf "%s " "$@" >/dev/tty - test -d ${PREFIX} - rm -rf ${CAMLPDF} - tar zxf ${CAMLPDF}.tar.bz2 - ./Patcher.sh ${CAMLPDF} - ( cd ${CAMLPDF} && \ - export PATH=${PREFIX}/bin:$$PATH && \ - ${MAKE} all && \ - ${MAKE} install ) - echo ${VERSION} >$@ -clean:: - rm -rf ${CAMLPDF} camlpdf -distclean:: - rm -f ${CAMLPDF}.tar.gz -all: camlpdf - -# 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 camlp5 - printf "%s " "$@" >/dev/tty - test -d ${PREFIX} - rm -rf ${COQ} - tar zxf ${COQ}.tar.gz - ./Patcher.sh ${COQ} - ( cd ${COQ} && \ - export PATH=${PREFIX}/bin:$$PATH && \ - ./configure -prefix ${PREFIX} -with-doc no && \ - ${MAKE} world && \ - ${MAKE} install ) - echo ${VERSION} >$@ -clean:: - rm -rf ${COQ} coq -distclean:: - rm -f ${COQ}.tar.gz -all: coq - -# http://code.google.com/p/bitstring/ - -BITSTRING=ocaml-bitstring-2.0.3 -${BITSTRING}.tar.gz: - ${WGET} http://bitstring.googlecode.com/files/$@ -bitstring: ${BITSTRING}.tar.gz findlib # cil FIXME ? - printf "%s " "$@" >/dev/tty - test -d ${PREFIX} - rm -rf ${BITSTRING} - tar zxf ${BITSTRING}.tar.gz - ./Patcher.sh ${BITSTRING} - ( cd ${BITSTRING} && \ - export PATH=${PREFIX}/bin:$$PATH && \ - sh ./configure --prefix ${PREFIX} && \ - ${MAKE} && \ - ${MAKE} check && \ - ${MAKE} examples && \ - ocamlfind remove bitstring && \ - ${MAKE} install ) - echo ${VERSION} >$@ -clean:: - rm -rf ${BITSTRING} bitstring -distclean:: - rm -f ${BITSTRING}.tar.gz -all: bitstring - -# http://compcert.inria.fr -COMPCERT=compcert-1.13 -${COMPCERT}.tgz: - ${WGET} http://compcert.inria.fr/release/$@ -compcert: ${COMPCERT}.tgz coq bitstring - printf "%s " "$@" >/dev/tty - test -d ${PREFIX} - rm -rf ${COMPCERT} - tar zxf ${COMPCERT}.tgz - ./Patcher.sh ${COMPCERT} - ( cd ${COMPCERT} && \ - export PATH=${PREFIX}/bin:$$PATH && \ - sh ./configure -prefix ${PREFIX} ppc-linux && \ - ${MAKE} all && \ - ${MAKE} install ) - echo ${VERSION} >$@ -clean:: - rm -rf ${COMPCERT} compcert -distclean:: - rm -f ${COMPCERT}.tgz -all: compcert - -# http://frama-c.com/ -FRAMAC=frama-c-Oxygen-20120901 -${FRAMAC}.tar.gz: - ${WGET} http://frama-c.com/download/$@ -framac: ${FRAMAC}.tar.gz - printf "%s " "$@" >/dev/tty - test -d ${PREFIX} - rm -rf ${FRAMAC} - tar zxf ${FRAMAC}.tar.gz - ./Patcher.sh ${FRAMAC} - ( cd ${FRAMAC} && \ - export PATH=${PREFIX}/bin:$$PATH && \ - ./configure --enable-verbosemake --prefix ${PREFIX} && \ - ${MAKE} && \ - ${MAKE} oracles && \ - ${MAKE} install ) - echo ${VERSION} >$@ -clean:: - rm -rf ${FRAMAC} framac -distclean:: - rm -f ${FRAMAC}.tar.gz -all: framac - -################################################################## -### Template for new entries -################################################################## - -FOO= -${FOO}.tar.gz: - ${WGET} http://foo.bar.com/.../$@ -foo: ${FOO}.tar.gz - printf "%s " "$@" >/dev/tty - test -d ${PREFIX} - rm -rf ${FOO} - tar zxf ${FOO}.tar.gz - ./Patcher.sh ${FOO} - ( cd ${FOO} && \ - export PATH=${PREFIX}/bin:$$PATH && \ - sh ./configure --prefix ${PREFIX} && \ - ${MAKE} && \ - ocamlfind remove foo && \ - ${MAKE} install ) - echo ${VERSION} >$@ -xxclean:: - rm -rf ${FOO} foo -xxdistclean:: - rm -f ${FOO}.tar.gz -xxall: foo - -################################################################## - -.PHONY: clean - -.PHONY: distclean -distclean:: - ${MAKE} clean - -.PHONY: all -all: - echo >/dev/tty diff --git a/testsuite/external/TODO.txt b/testsuite/external/TODO.txt deleted file mode 100644 index 18a5460ed0..0000000000 --- a/testsuite/external/TODO.txt +++ /dev/null @@ -1,26 +0,0 @@ -TODO: -Understand why ocamlnet does not detect lablgtk, ocamlssl, camlzip, cryptokit - -TODO: cryptogps -http://www.ocaml-programming.de/packages -and make ocamlnet depend on it - -# TODO: lablgl -# http://wwwfun.kurims.kyoto-u.ac.jp/soft/lsl/lablgl.html - -Haxe: missing a source archive of released version... -# # http://code.google.com/p/haxe/source/browse/#svn%2Ftrunk -# HAXE=haxe-2.10dev -# haxe: -# printf "%s " "$@" >/dev/tty -# test -d ${PREFIX} -# rm -rf ${HAXE} -# tar zxf ${HAXE}.tar.gz -# ./Patcher.sh ${HAXE} -# ( cd ${HAXE} && \ -# export PATH=${PREFIX}/bin:$$PATH && \ -# make ) -# echo ${VERSION} >$@ -# clean:: -# rm -rf ${HAXE} haxe -# all: haxe diff --git a/testsuite/external/boomerang-0.2.patch b/testsuite/external/boomerang-0.2.patch deleted file mode 100644 index 0bb8eb3702..0000000000 --- a/testsuite/external/boomerang-0.2.patch +++ /dev/null @@ -1,11 +0,0 @@ ---- boomerang-0.2/OMakefile.orig 2010-06-07 15:01:55.000000000 +0200 -+++ boomerang-0.2/OMakefile 2010-06-07 15:02:08.000000000 +0200 -@@ -126,7 +126,7 @@ - ############################################################################## - # Include sub-directories - --SUBDIRS = common src lenses examples doc -+SUBDIRS = common src lenses examples #doc - - .SUBDIRS: $(SUBDIRS) - diff --git a/testsuite/external/camlimages-4.0.1.patch b/testsuite/external/camlimages-4.0.1.patch deleted file mode 100644 index ff2f93e50b..0000000000 --- a/testsuite/external/camlimages-4.0.1.patch +++ /dev/null @@ -1,11 +0,0 @@ ---- camlimages-4.0.1.orig/OMakefile 2011-06-22 20:04:32.000000000 +0200 -+++ camlimages-4.0.1/OMakefile 2013-02-19 15:35:38.000000000 +0100 -@@ -138,7 +138,7 @@ - SUPPORTED_FORMATS+=jpeg - export - -- HAVE_TIFF = $(Check_header_library tiff, tiff.h, TIFFOpen) -+ HAVE_TIFF = false # $(Check_header_library tiff, tiff.h, TIFFOpen) - SUPPORT_TIFF = $(and $(HAVE_Z) $(HAVE_JPEG) $(HAVE_TIFF)) - LDFLAGS_tiff= - if $(SUPPORT_TIFF) diff --git a/testsuite/external/camlp5-6.06.patch b/testsuite/external/camlp5-6.06.patch deleted file mode 100644 index 8b7e58a380..0000000000 --- a/testsuite/external/camlp5-6.06.patch +++ /dev/null @@ -1,2243 +0,0 @@ -diff -r -u -N camlp5-6.06.orig/ocaml_src/lib/versdep/4.00.1.ml camlp5-6.06/ocaml_src/lib/versdep/4.00.1.ml ---- camlp5-6.06.orig/ocaml_src/lib/versdep/4.00.1.ml 1970-01-01 01:00:00.000000000 +0100 -+++ camlp5-6.06/ocaml_src/lib/versdep/4.00.1.ml 2012-07-31 16:52:22.000000000 +0200 -@@ -0,0 +1,465 @@ -+(* camlp5r pa_macro.cmo *) -+(* File generated by program: edit only if it does not compile. *) -+(* Copyright (c) INRIA 2007-2012 *) -+ -+open Parsetree;; -+open Longident;; -+open Asttypes;; -+ -+type ('a, 'b) choice = -+ Left of 'a -+ | Right of 'b -+;; -+ -+let sys_ocaml_version = Sys.ocaml_version;; -+ -+let ocaml_location (fname, lnum, bolp, lnuml, bolpl, bp, ep) = -+ let loc_at n lnum bolp = -+ {Lexing.pos_fname = if lnum = -1 then "" else fname; -+ Lexing.pos_lnum = lnum; Lexing.pos_bol = bolp; Lexing.pos_cnum = n} -+ in -+ {Location.loc_start = loc_at bp lnum bolp; -+ Location.loc_end = loc_at ep lnuml bolpl; -+ Location.loc_ghost = bp = 0 && ep = 0} -+;; -+ -+let loc_none = -+ let loc = -+ {Lexing.pos_fname = "_none_"; Lexing.pos_lnum = 1; Lexing.pos_bol = 0; -+ Lexing.pos_cnum = -1} -+ in -+ {Location.loc_start = loc; Location.loc_end = loc; -+ Location.loc_ghost = true} -+;; -+ -+let mkloc loc txt = {Location.txt = txt; Location.loc = loc};; -+let mknoloc txt = mkloc loc_none txt;; -+ -+let ocaml_id_or_li_of_string_list loc sl = -+ let mkli s = -+ let rec loop f = -+ function -+ i :: il -> loop (fun s -> Ldot (f i, s)) il -+ | [] -> f s -+ in -+ loop (fun s -> Lident s) -+ in -+ match List.rev sl with -+ [] -> None -+ | s :: sl -> Some (mkli s (List.rev sl)) -+;; -+ -+let list_map_check f l = -+ let rec loop rev_l = -+ function -+ x :: l -> -+ begin match f x with -+ Some s -> loop (s :: rev_l) l -+ | None -> None -+ end -+ | [] -> Some (List.rev rev_l) -+ in -+ loop [] l -+;; -+ -+let ocaml_value_description t p = -+ {pval_type = t; pval_prim = p; pval_loc = t.ptyp_loc} -+;; -+ -+let ocaml_class_type_field loc ctfd = {pctf_desc = ctfd; pctf_loc = loc};; -+ -+let ocaml_class_field loc cfd = {pcf_desc = cfd; pcf_loc = loc};; -+ -+let ocaml_type_declaration params cl tk pf tm loc variance = -+ match list_map_check (fun s_opt -> s_opt) params with -+ Some params -> -+ let params = List.map (fun os -> Some (mknoloc os)) params in -+ Right -+ {ptype_params = params; ptype_cstrs = cl; ptype_kind = tk; -+ ptype_private = pf; ptype_manifest = tm; ptype_loc = loc; -+ ptype_variance = variance} -+ | None -> Left "no '_' type param in this ocaml version" -+;; -+ -+let ocaml_class_type = Some (fun d loc -> {pcty_desc = d; pcty_loc = loc});; -+ -+let ocaml_class_expr = Some (fun d loc -> {pcl_desc = d; pcl_loc = loc});; -+ -+let ocaml_class_structure p cil = {pcstr_pat = p; pcstr_fields = cil};; -+ -+let ocaml_pmty_ident loc li = Pmty_ident (mkloc loc li);; -+ -+let ocaml_pmty_functor sloc s mt1 mt2 = -+ Pmty_functor (mkloc sloc s, mt1, mt2) -+;; -+ -+let ocaml_pmty_typeof = Some (fun me -> Pmty_typeof me);; -+ -+let ocaml_pmty_with mt lcl = -+ let lcl = List.map (fun (s, c) -> mknoloc s, c) lcl in Pmty_with (mt, lcl) -+;; -+ -+let ocaml_ptype_abstract = Ptype_abstract;; -+ -+let ocaml_ptype_record ltl priv = -+ Ptype_record -+ (List.map (fun (s, mf, ct, loc) -> mkloc loc s, mf, ct, loc) ltl) -+;; -+ -+let ocaml_ptype_variant ctl priv = -+ try -+ let ctl = -+ List.map -+ (fun (c, tl, rto, loc) -> -+ if rto <> None then raise Exit else mknoloc c, tl, None, loc) -+ ctl -+ in -+ Some (Ptype_variant ctl) -+ with Exit -> None -+;; -+ -+let ocaml_ptyp_arrow lab t1 t2 = Ptyp_arrow (lab, t1, t2);; -+ -+let ocaml_ptyp_class li tl ll = Ptyp_class (mknoloc li, tl, ll);; -+ -+let ocaml_ptyp_constr li tl = Ptyp_constr (mknoloc li, tl);; -+ -+let ocaml_ptyp_package = Some (fun pt -> Ptyp_package pt);; -+ -+let ocaml_ptyp_poly = Some (fun cl t -> Ptyp_poly (cl, t));; -+ -+let ocaml_ptyp_variant catl clos sl_opt = -+ let catl = -+ List.map -+ (function -+ Left (c, a, tl) -> Rtag (c, a, tl) -+ | Right t -> Rinherit t) -+ catl -+ in -+ Some (Ptyp_variant (catl, clos, sl_opt)) -+;; -+ -+let ocaml_package_type li ltl = -+ mknoloc li, List.map (fun (li, t) -> mkloc t.ptyp_loc li, t) ltl -+;; -+ -+let ocaml_const_int32 = Some (fun s -> Const_int32 (Int32.of_string s));; -+ -+let ocaml_const_int64 = Some (fun s -> Const_int64 (Int64.of_string s));; -+ -+let ocaml_const_nativeint = -+ Some (fun s -> Const_nativeint (Nativeint.of_string s)) -+;; -+ -+let ocaml_pexp_apply f lel = Pexp_apply (f, lel);; -+ -+let ocaml_pexp_assertfalse fname loc = Pexp_assertfalse;; -+ -+let ocaml_pexp_assert fname loc e = Pexp_assert e;; -+ -+let ocaml_pexp_construct li po chk_arity = -+ Pexp_construct (mknoloc li, po, chk_arity) -+;; -+ -+let ocaml_pexp_field e li = Pexp_field (e, mknoloc li);; -+ -+let ocaml_pexp_for i e1 e2 df e = Pexp_for (mknoloc i, e1, e2, df, e);; -+ -+let ocaml_pexp_function lab eo pel = Pexp_function (lab, eo, pel);; -+ -+let ocaml_pexp_lazy = Some (fun e -> Pexp_lazy e);; -+ -+let ocaml_pexp_ident li = Pexp_ident (mknoloc li);; -+ -+let ocaml_pexp_letmodule = -+ Some (fun i me e -> Pexp_letmodule (mknoloc i, me, e)) -+;; -+ -+let ocaml_pexp_new loc li = Pexp_new (mkloc loc li);; -+ -+let ocaml_pexp_newtype = Some (fun s e -> Pexp_newtype (s, e));; -+ -+let ocaml_pexp_object = Some (fun cs -> Pexp_object cs);; -+ -+let ocaml_pexp_open = Some (fun li e -> Pexp_open (mknoloc li, e));; -+ -+let ocaml_pexp_override sel = -+ let sel = List.map (fun (s, e) -> mknoloc s, e) sel in Pexp_override sel -+;; -+ -+let ocaml_pexp_pack : ('a -> 'b -> 'c, 'd) choice option = -+ Some (Right ((fun me -> Pexp_pack me), (fun pt -> Ptyp_package pt))) -+;; -+ -+let ocaml_pexp_poly = Some (fun e t -> Pexp_poly (e, t));; -+ -+let ocaml_pexp_record lel eo = -+ let lel = List.map (fun (li, loc, e) -> mkloc loc li, e) lel in -+ Pexp_record (lel, eo) -+;; -+ -+let ocaml_pexp_setinstvar s e = Pexp_setinstvar (mknoloc s, e);; -+ -+let ocaml_pexp_variant = -+ let pexp_variant_pat = -+ function -+ Pexp_variant (lab, eo) -> Some (lab, eo) -+ | _ -> None -+ in -+ let pexp_variant (lab, eo) = Pexp_variant (lab, eo) in -+ Some (pexp_variant_pat, pexp_variant) -+;; -+ -+let ocaml_ppat_alias p i iloc = Ppat_alias (p, mkloc iloc i);; -+ -+let ocaml_ppat_array = Some (fun pl -> Ppat_array pl);; -+ -+let ocaml_ppat_construct li li_loc po chk_arity = -+ Ppat_construct (mkloc li_loc li, po, chk_arity) -+;; -+ -+let ocaml_ppat_construct_args = -+ function -+ Ppat_construct (li, po, chk_arity) -> Some (li.txt, li.loc, po, chk_arity) -+ | _ -> None -+;; -+ -+let ocaml_ppat_lazy = Some (fun p -> Ppat_lazy p);; -+ -+let ocaml_ppat_record lpl is_closed = -+ let lpl = List.map (fun (li, loc, p) -> mkloc loc li, p) lpl in -+ Ppat_record (lpl, (if is_closed then Closed else Open)) -+;; -+ -+let ocaml_ppat_type = Some (fun loc li -> Ppat_type (mkloc loc li));; -+ -+let ocaml_ppat_unpack = -+ Some ((fun loc s -> Ppat_unpack (mkloc loc s)), (fun pt -> Ptyp_package pt)) -+;; -+ -+let ocaml_ppat_var loc s = Ppat_var (mkloc loc s);; -+ -+let ocaml_ppat_variant = -+ let ppat_variant_pat = -+ function -+ Ppat_variant (lab, po) -> Some (lab, po) -+ | _ -> None -+ in -+ let ppat_variant (lab, po) = Ppat_variant (lab, po) in -+ Some (ppat_variant_pat, ppat_variant) -+;; -+ -+let ocaml_psig_class_type = Some (fun ctl -> Psig_class_type ctl);; -+ -+let ocaml_psig_exception s ed = Psig_exception (mknoloc s, ed);; -+ -+let ocaml_psig_module s mt = Psig_module (mknoloc s, mt);; -+ -+let ocaml_psig_modtype s mtd = Psig_modtype (mknoloc s, mtd);; -+ -+let ocaml_psig_open li = Psig_open (mknoloc li);; -+ -+let ocaml_psig_recmodule = -+ let f ntl = -+ let ntl = List.map (fun (s, mt) -> mknoloc s, mt) ntl in -+ Psig_recmodule ntl -+ in -+ Some f -+;; -+ -+let ocaml_psig_type stl = -+ let stl = List.map (fun (s, t) -> mknoloc s, t) stl in Psig_type stl -+;; -+ -+let ocaml_psig_value s vd = Psig_value (mknoloc s, vd);; -+ -+let ocaml_pstr_class_type = Some (fun ctl -> Pstr_class_type ctl);; -+ -+let ocaml_pstr_exception s ed = Pstr_exception (mknoloc s, ed);; -+ -+let ocaml_pstr_exn_rebind = -+ Some (fun s li -> Pstr_exn_rebind (mknoloc s, mknoloc li)) -+;; -+ -+let ocaml_pstr_include = Some (fun me -> Pstr_include me);; -+ -+let ocaml_pstr_modtype s mt = Pstr_modtype (mknoloc s, mt);; -+ -+let ocaml_pstr_module s me = Pstr_module (mknoloc s, me);; -+ -+let ocaml_pstr_open li = Pstr_open (mknoloc li);; -+ -+let ocaml_pstr_primitive s vd = Pstr_primitive (mknoloc s, vd);; -+ -+let ocaml_pstr_recmodule = -+ let f nel = -+ Pstr_recmodule (List.map (fun (s, mt, me) -> mknoloc s, mt, me) nel) -+ in -+ Some f -+;; -+ -+let ocaml_pstr_type stl = -+ let stl = List.map (fun (s, t) -> mknoloc s, t) stl in Pstr_type stl -+;; -+ -+let ocaml_class_infos = -+ Some -+ (fun virt (sl, sloc) name expr loc variance -> -+ let params = List.map (fun s -> mkloc loc s) sl, sloc in -+ {pci_virt = virt; pci_params = params; pci_name = mkloc loc name; -+ pci_expr = expr; pci_loc = loc; pci_variance = variance}) -+;; -+ -+let ocaml_pmod_ident li = Pmod_ident (mknoloc li);; -+ -+let ocaml_pmod_functor s mt me = Pmod_functor (mknoloc s, mt, me);; -+ -+let ocaml_pmod_unpack : ('a -> 'b -> 'c, 'd) choice option = -+ Some (Right ((fun e -> Pmod_unpack e), (fun pt -> Ptyp_package pt))) -+;; -+ -+let ocaml_pcf_cstr = Some (fun (t1, t2, loc) -> Pcf_constr (t1, t2));; -+ -+let ocaml_pcf_inher ce pb = Pcf_inher (Fresh, ce, pb);; -+ -+let ocaml_pcf_init = Some (fun e -> Pcf_init e);; -+ -+let ocaml_pcf_meth (s, pf, ovf, e, loc) = -+ let pf = if pf then Private else Public in -+ let ovf = if ovf then Override else Fresh in -+ Pcf_meth (mkloc loc s, pf, ovf, e) -+;; -+ -+let ocaml_pcf_val (s, mf, ovf, e, loc) = -+ let mf = if mf then Mutable else Immutable in -+ let ovf = if ovf then Override else Fresh in -+ Pcf_val (mkloc loc s, mf, ovf, e) -+;; -+ -+let ocaml_pcf_valvirt = -+ let ocaml_pcf (s, mf, t, loc) = -+ let mf = if mf then Mutable else Immutable in -+ Pcf_valvirt (mkloc loc s, mf, t) -+ in -+ Some ocaml_pcf -+;; -+ -+let ocaml_pcf_virt (s, pf, t, loc) = Pcf_virt (mkloc loc s, pf, t);; -+ -+let ocaml_pcl_apply = Some (fun ce lel -> Pcl_apply (ce, lel));; -+ -+let ocaml_pcl_constr = Some (fun li ctl -> Pcl_constr (mknoloc li, ctl));; -+ -+let ocaml_pcl_constraint = Some (fun ce ct -> Pcl_constraint (ce, ct));; -+ -+let ocaml_pcl_fun = Some (fun lab ceo p ce -> Pcl_fun (lab, ceo, p, ce));; -+ -+let ocaml_pcl_let = Some (fun rf pel ce -> Pcl_let (rf, pel, ce));; -+ -+let ocaml_pcl_structure = Some (fun cs -> Pcl_structure cs);; -+ -+let ocaml_pctf_cstr = Some (fun (t1, t2, loc) -> Pctf_cstr (t1, t2));; -+ -+let ocaml_pctf_meth (s, pf, t, loc) = Pctf_meth (s, pf, t);; -+ -+let ocaml_pctf_val (s, mf, t, loc) = Pctf_val (s, mf, Concrete, t);; -+ -+let ocaml_pctf_virt (s, pf, t, loc) = Pctf_virt (s, pf, t);; -+ -+let ocaml_pcty_constr = Some (fun li ltl -> Pcty_constr (mknoloc li, ltl));; -+ -+let ocaml_pcty_fun = Some (fun lab t ct -> Pcty_fun (lab, t, ct));; -+ -+let ocaml_pcty_signature = -+ let f (t, ctfl) = -+ let cs = {pcsig_self = t; pcsig_fields = ctfl; pcsig_loc = t.ptyp_loc} in -+ Pcty_signature cs -+ in -+ Some f -+;; -+ -+let ocaml_pdir_bool = Some (fun b -> Pdir_bool b);; -+ -+let ocaml_pwith_modsubst = -+ Some (fun loc me -> Pwith_modsubst (mkloc loc me)) -+;; -+ -+let ocaml_pwith_module loc me = Pwith_module (mkloc loc me);; -+ -+let ocaml_pwith_typesubst = Some (fun td -> Pwith_typesubst td);; -+ -+let module_prefix_can_be_in_first_record_label_only = true;; -+ -+let split_or_patterns_with_bindings = false;; -+ -+let has_records_with_with = true;; -+ -+(* *) -+ -+let jocaml_pstr_def : (_ -> _) option = None;; -+ -+let jocaml_pexp_def : (_ -> _ -> _) option = None;; -+ -+let jocaml_pexp_par : (_ -> _ -> _) option = None;; -+ -+let jocaml_pexp_reply : (_ -> _ -> _ -> _) option = None;; -+ -+let jocaml_pexp_spawn : (_ -> _) option = None;; -+ -+let arg_rest = -+ function -+ Arg.Rest r -> Some r -+ | _ -> None -+;; -+ -+let arg_set_string = -+ function -+ Arg.Set_string r -> Some r -+ | _ -> None -+;; -+ -+let arg_set_int = -+ function -+ Arg.Set_int r -> Some r -+ | _ -> None -+;; -+ -+let arg_set_float = -+ function -+ Arg.Set_float r -> Some r -+ | _ -> None -+;; -+ -+let arg_symbol = -+ function -+ Arg.Symbol (s, f) -> Some (s, f) -+ | _ -> None -+;; -+ -+let arg_tuple = -+ function -+ Arg.Tuple t -> Some t -+ | _ -> None -+;; -+ -+let arg_bool = -+ function -+ Arg.Bool f -> Some f -+ | _ -> None -+;; -+ -+let char_escaped = Char.escaped;; -+ -+let hashtbl_mem = Hashtbl.mem;; -+ -+let list_rev_append = List.rev_append;; -+ -+let list_rev_map = List.rev_map;; -+ -+let list_sort = List.sort;; -+ -+let pervasives_set_binary_mode_out = Pervasives.set_binary_mode_out;; -+ -+let printf_ksprintf = Printf.ksprintf;; -+ -+let string_contains = String.contains;; -diff -r -u -N camlp5-6.06.orig/ocaml_stuff/4.00.1/parsing/.cvsignore camlp5-6.06/ocaml_stuff/4.00.1/parsing/.cvsignore ---- camlp5-6.06.orig/ocaml_stuff/4.00.1/parsing/.cvsignore 1970-01-01 01:00:00.000000000 +0100 -+++ camlp5-6.06/ocaml_stuff/4.00.1/parsing/.cvsignore 2012-07-31 16:52:22.000000000 +0200 -@@ -0,0 +1 @@ -+*.cm[oi] -diff -r -u -N camlp5-6.06.orig/ocaml_stuff/4.00.1/parsing/.depend camlp5-6.06/ocaml_stuff/4.00.1/parsing/.depend ---- camlp5-6.06.orig/ocaml_stuff/4.00.1/parsing/.depend 1970-01-01 01:00:00.000000000 +0100 -+++ camlp5-6.06/ocaml_stuff/4.00.1/parsing/.depend 2012-07-31 16:52:22.000000000 +0200 -@@ -0,0 +1,4 @@ -+asttypes.cmi : location.cmi -+location.cmi : ../utils/warnings.cmi -+longident.cmi : -+parsetree.cmi : longident.cmi location.cmi asttypes.cmi -diff -r -u -N camlp5-6.06.orig/ocaml_stuff/4.00.1/parsing/Makefile camlp5-6.06/ocaml_stuff/4.00.1/parsing/Makefile ---- camlp5-6.06.orig/ocaml_stuff/4.00.1/parsing/Makefile 1970-01-01 01:00:00.000000000 +0100 -+++ camlp5-6.06/ocaml_stuff/4.00.1/parsing/Makefile 2012-07-31 16:52:22.000000000 +0200 -@@ -0,0 +1,19 @@ -+# Id -+ -+FILES=asttypes.cmi location.cmi longident.cmi parsetree.cmi -+INCL=-I ../utils -+ -+all: $(FILES) -+ -+clean: -+ rm -f *.cmi -+ -+depend: -+ ocamldep $(INCL) *.ml* | sed -e 's/ *$$//' > .depend -+ -+.SUFFIXES: .mli .cmi -+ -+.mli.cmi: -+ $(OCAMLN)c $(INCL) -c $< -+ -+include .depend -diff -r -u -N camlp5-6.06.orig/ocaml_stuff/4.00.1/parsing/asttypes.mli camlp5-6.06/ocaml_stuff/4.00.1/parsing/asttypes.mli ---- camlp5-6.06.orig/ocaml_stuff/4.00.1/parsing/asttypes.mli 1970-01-01 01:00:00.000000000 +0100 -+++ camlp5-6.06/ocaml_stuff/4.00.1/parsing/asttypes.mli 2012-07-31 16:52:22.000000000 +0200 -@@ -0,0 +1,45 @@ -+(***********************************************************************) -+(* *) -+(* 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 Q Public License version 1.0. *) -+(* *) -+(***********************************************************************) -+ -+(* Id *) -+ -+(* Auxiliary a.s.t. types used by parsetree and typedtree. *) -+ -+type constant = -+ Const_int of int -+ | Const_char of char -+ | Const_string of string -+ | Const_float of string -+ | Const_int32 of int32 -+ | Const_int64 of int64 -+ | Const_nativeint of nativeint -+ -+type rec_flag = Nonrecursive | Recursive | Default -+ -+type direction_flag = Upto | Downto -+ -+type private_flag = Private | Public -+ -+type mutable_flag = Immutable | Mutable -+ -+type virtual_flag = Virtual | Concrete -+ -+type override_flag = Override | Fresh -+ -+type closed_flag = Closed | Open -+ -+type label = string -+ -+type 'a loc = 'a Location.loc = { -+ txt : 'a; -+ loc : Location.t; -+} -diff -r -u -N camlp5-6.06.orig/ocaml_stuff/4.00.1/parsing/location.mli camlp5-6.06/ocaml_stuff/4.00.1/parsing/location.mli ---- camlp5-6.06.orig/ocaml_stuff/4.00.1/parsing/location.mli 1970-01-01 01:00:00.000000000 +0100 -+++ camlp5-6.06/ocaml_stuff/4.00.1/parsing/location.mli 2012-07-31 16:52:22.000000000 +0200 -@@ -0,0 +1,80 @@ -+(***********************************************************************) -+(* *) -+(* 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 Q Public License version 1.0. *) -+(* *) -+(***********************************************************************) -+ -+(* Id *) -+ -+(* Source code locations (ranges of positions), used in parsetree. *) -+ -+open Format -+ -+type t = { -+ loc_start: Lexing.position; -+ loc_end: Lexing.position; -+ loc_ghost: bool; -+} -+ -+(* Note on the use of Lexing.position in this module. -+ If [pos_fname = ""], then use [!input_name] instead. -+ If [pos_lnum = -1], then [pos_bol = 0]. Use [pos_cnum] and -+ re-parse the file to get the line and character numbers. -+ Else all fields are correct. -+*) -+ -+val none : t -+(** An arbitrary value of type [t]; describes an empty ghost range. *) -+val in_file : string -> t;; -+(** Return an empty ghost range located in a given file. *) -+val init : Lexing.lexbuf -> string -> unit -+(** Set the file name and line number of the [lexbuf] to be the start -+ of the named file. *) -+val curr : Lexing.lexbuf -> t -+(** Get the location of the current token from the [lexbuf]. *) -+ -+val symbol_rloc: unit -> t -+val symbol_gloc: unit -> t -+ -+(** [rhs_loc n] returns the location of the symbol at position [n], starting -+ at 1, in the current parser rule. *) -+val rhs_loc: int -> t -+ -+val input_name: string ref -+val input_lexbuf: Lexing.lexbuf option ref -+ -+val get_pos_info: Lexing.position -> string * int * int (* file, line, char *) -+val print_loc: formatter -> t -> unit -+val print_error: formatter -> t -> unit -+val print_error_cur_file: formatter -> unit -+val print_warning: t -> formatter -> Warnings.t -> unit -+val prerr_warning: t -> Warnings.t -> unit -+val echo_eof: unit -> unit -+val reset: unit -> unit -+ -+val highlight_locations: formatter -> t -> t -> bool -+ -+type 'a loc = { -+ txt : 'a; -+ loc : t; -+} -+ -+val mknoloc : 'a -> 'a loc -+val mkloc : 'a -> t -> 'a loc -+ -+val print: formatter -> t -> unit -+val print_filename: formatter -> string -> unit -+ -+val show_filename: string -> string -+ (** In -absname mode, return the absolute path for this filename. -+ Otherwise, returns the filename unchanged. *) -+ -+ -+val absname: bool ref -+ -diff -r -u -N camlp5-6.06.orig/ocaml_stuff/4.00.1/parsing/longident.mli camlp5-6.06/ocaml_stuff/4.00.1/parsing/longident.mli ---- camlp5-6.06.orig/ocaml_stuff/4.00.1/parsing/longident.mli 1970-01-01 01:00:00.000000000 +0100 -+++ camlp5-6.06/ocaml_stuff/4.00.1/parsing/longident.mli 2012-07-31 16:52:22.000000000 +0200 -@@ -0,0 +1,24 @@ -+(***********************************************************************) -+(* *) -+(* 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 Q Public License version 1.0. *) -+(* *) -+(***********************************************************************) -+ -+(* Id *) -+ -+(* Long identifiers, used in parsetree. *) -+ -+type t = -+ Lident of string -+ | Ldot of t * string -+ | Lapply of t * t -+ -+val flatten: t -> string list -+val last: t -> string -+val parse: string -> t -diff -r -u -N camlp5-6.06.orig/ocaml_stuff/4.00.1/parsing/parsetree.mli camlp5-6.06/ocaml_stuff/4.00.1/parsing/parsetree.mli ---- camlp5-6.06.orig/ocaml_stuff/4.00.1/parsing/parsetree.mli 1970-01-01 01:00:00.000000000 +0100 -+++ camlp5-6.06/ocaml_stuff/4.00.1/parsing/parsetree.mli 2012-07-31 16:52:22.000000000 +0200 -@@ -0,0 +1,307 @@ -+(***********************************************************************) -+(* *) -+(* 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 Q Public License version 1.0. *) -+(* *) -+(***********************************************************************) -+ -+(* Id *) -+ -+(* Abstract syntax tree produced by parsing *) -+ -+open Asttypes -+ -+(* Type expressions for the core language *) -+ -+type core_type = -+ { ptyp_desc: core_type_desc; -+ ptyp_loc: Location.t } -+ -+and core_type_desc = -+ Ptyp_any -+ | Ptyp_var of string -+ | Ptyp_arrow of label * core_type * core_type -+ | Ptyp_tuple of core_type list -+ | Ptyp_constr of Longident.t loc * core_type list -+ | Ptyp_object of core_field_type list -+ | Ptyp_class of Longident.t loc * core_type list * label list -+ | Ptyp_alias of core_type * string -+ | Ptyp_variant of row_field list * bool * label list option -+ | Ptyp_poly of string list * core_type -+ | Ptyp_package of package_type -+ -+ -+and package_type = Longident.t loc * (Longident.t loc * core_type) list -+ -+and core_field_type = -+ { pfield_desc: core_field_desc; -+ pfield_loc: Location.t } -+ -+and core_field_desc = -+ Pfield of string * core_type -+ | Pfield_var -+ -+and row_field = -+ Rtag of label * bool * core_type list -+ | Rinherit of core_type -+ -+(* Type expressions for the class language *) -+ -+type 'a class_infos = -+ { pci_virt: virtual_flag; -+ pci_params: string loc list * Location.t; -+ pci_name: string loc; -+ pci_expr: 'a; -+ pci_variance: (bool * bool) list; -+ pci_loc: Location.t } -+ -+(* Value expressions for the core language *) -+ -+type pattern = -+ { ppat_desc: pattern_desc; -+ ppat_loc: Location.t } -+ -+and pattern_desc = -+ Ppat_any -+ | Ppat_var of string loc -+ | Ppat_alias of pattern * string loc -+ | Ppat_constant of constant -+ | Ppat_tuple of pattern list -+ | Ppat_construct of Longident.t loc * pattern option * bool -+ | Ppat_variant of label * pattern option -+ | Ppat_record of (Longident.t loc * pattern) list * closed_flag -+ | Ppat_array of pattern list -+ | Ppat_or of pattern * pattern -+ | Ppat_constraint of pattern * core_type -+ | Ppat_type of Longident.t loc -+ | Ppat_lazy of pattern -+ | Ppat_unpack of string loc -+ -+type expression = -+ { pexp_desc: expression_desc; -+ pexp_loc: Location.t } -+ -+and expression_desc = -+ Pexp_ident of Longident.t loc -+ | Pexp_constant of constant -+ | Pexp_let of rec_flag * (pattern * expression) list * expression -+ | Pexp_function of label * expression option * (pattern * expression) list -+ | Pexp_apply of expression * (label * expression) list -+ | Pexp_match of expression * (pattern * expression) list -+ | Pexp_try of expression * (pattern * expression) list -+ | Pexp_tuple of expression list -+ | Pexp_construct of Longident.t loc * expression option * bool -+ | Pexp_variant of label * expression option -+ | Pexp_record of (Longident.t loc * expression) list * expression option -+ | Pexp_field of expression * Longident.t loc -+ | Pexp_setfield of expression * Longident.t loc * expression -+ | Pexp_array of expression list -+ | Pexp_ifthenelse of expression * expression * expression option -+ | Pexp_sequence of expression * expression -+ | Pexp_while of expression * expression -+ | Pexp_for of string loc * expression * expression * direction_flag * expression -+ | Pexp_constraint of expression * core_type option * core_type option -+ | Pexp_when of expression * expression -+ | Pexp_send of expression * string -+ | Pexp_new of Longident.t loc -+ | Pexp_setinstvar of string loc * expression -+ | Pexp_override of (string loc * expression) list -+ | Pexp_letmodule of string loc * module_expr * expression -+ | Pexp_assert of expression -+ | Pexp_assertfalse -+ | Pexp_lazy of expression -+ | Pexp_poly of expression * core_type option -+ | Pexp_object of class_structure -+ | Pexp_newtype of string * expression -+ | Pexp_pack of module_expr -+ | Pexp_open of Longident.t loc * expression -+ -+(* Value descriptions *) -+ -+and value_description = -+ { pval_type: core_type; -+ pval_prim: string list; -+ pval_loc : Location.t -+ } -+ -+(* Type declarations *) -+ -+and type_declaration = -+ { ptype_params: string loc option list; -+ ptype_cstrs: (core_type * core_type * Location.t) list; -+ ptype_kind: type_kind; -+ ptype_private: private_flag; -+ ptype_manifest: core_type option; -+ ptype_variance: (bool * bool) list; -+ ptype_loc: Location.t } -+ -+and type_kind = -+ Ptype_abstract -+ | Ptype_variant of -+ (string loc * core_type list * core_type option * Location.t) list -+ | Ptype_record of -+ (string loc * mutable_flag * core_type * Location.t) list -+ -+and exception_declaration = core_type list -+ -+(* Type expressions for the class language *) -+ -+and class_type = -+ { pcty_desc: class_type_desc; -+ pcty_loc: Location.t } -+ -+and class_type_desc = -+ Pcty_constr of Longident.t loc * core_type list -+ | Pcty_signature of class_signature -+ | Pcty_fun of label * core_type * class_type -+ -+and class_signature = { -+ pcsig_self : core_type; -+ pcsig_fields : class_type_field list; -+ pcsig_loc : Location.t; -+ } -+ -+and class_type_field = { -+ pctf_desc : class_type_field_desc; -+ pctf_loc : Location.t; -+ } -+ -+and class_type_field_desc = -+ Pctf_inher of class_type -+ | Pctf_val of (string * mutable_flag * virtual_flag * core_type) -+ | Pctf_virt of (string * private_flag * core_type) -+ | Pctf_meth of (string * private_flag * core_type) -+ | Pctf_cstr of (core_type * core_type) -+ -+and class_description = class_type class_infos -+ -+and class_type_declaration = class_type class_infos -+ -+(* Value expressions for the class language *) -+ -+and class_expr = -+ { pcl_desc: class_expr_desc; -+ pcl_loc: Location.t } -+ -+and class_expr_desc = -+ Pcl_constr of Longident.t loc * core_type list -+ | Pcl_structure of class_structure -+ | Pcl_fun of label * expression option * pattern * class_expr -+ | Pcl_apply of class_expr * (label * expression) list -+ | Pcl_let of rec_flag * (pattern * expression) list * class_expr -+ | Pcl_constraint of class_expr * class_type -+ -+and class_structure = { -+ pcstr_pat : pattern; -+ pcstr_fields : class_field list; -+ } -+ -+and class_field = { -+ pcf_desc : class_field_desc; -+ pcf_loc : Location.t; -+ } -+ -+and class_field_desc = -+ Pcf_inher of override_flag * class_expr * string option -+ | Pcf_valvirt of (string loc * mutable_flag * core_type) -+ | Pcf_val of (string loc * mutable_flag * override_flag * expression) -+ | Pcf_virt of (string loc * private_flag * core_type) -+ | Pcf_meth of (string loc * private_flag *override_flag * expression) -+ | Pcf_constr of (core_type * core_type) -+ | Pcf_init of expression -+ -+and class_declaration = class_expr class_infos -+ -+(* Type expressions for the module language *) -+ -+and module_type = -+ { pmty_desc: module_type_desc; -+ pmty_loc: Location.t } -+ -+and module_type_desc = -+ Pmty_ident of Longident.t loc -+ | Pmty_signature of signature -+ | Pmty_functor of string loc * module_type * module_type -+ | Pmty_with of module_type * (Longident.t loc * with_constraint) list -+ | Pmty_typeof of module_expr -+ -+and signature = signature_item list -+ -+and signature_item = -+ { psig_desc: signature_item_desc; -+ psig_loc: Location.t } -+ -+and signature_item_desc = -+ Psig_value of string loc * value_description -+ | Psig_type of (string loc * type_declaration) list -+ | Psig_exception of string loc * exception_declaration -+ | Psig_module of string loc * module_type -+ | Psig_recmodule of (string loc * module_type) list -+ | Psig_modtype of string loc * modtype_declaration -+ | Psig_open of Longident.t loc -+ | Psig_include of module_type -+ | Psig_class of class_description list -+ | Psig_class_type of class_type_declaration list -+ -+and modtype_declaration = -+ Pmodtype_abstract -+ | Pmodtype_manifest of module_type -+ -+and with_constraint = -+ Pwith_type of type_declaration -+ | Pwith_module of Longident.t loc -+ | Pwith_typesubst of type_declaration -+ | Pwith_modsubst of Longident.t loc -+ -+(* Value expressions for the module language *) -+ -+and module_expr = -+ { pmod_desc: module_expr_desc; -+ pmod_loc: Location.t } -+ -+and module_expr_desc = -+ Pmod_ident of Longident.t loc -+ | Pmod_structure of structure -+ | Pmod_functor of string loc * module_type * module_expr -+ | Pmod_apply of module_expr * module_expr -+ | Pmod_constraint of module_expr * module_type -+ | Pmod_unpack of expression -+ -+and structure = structure_item list -+ -+and structure_item = -+ { pstr_desc: structure_item_desc; -+ pstr_loc: Location.t } -+ -+and structure_item_desc = -+ Pstr_eval of expression -+ | Pstr_value of rec_flag * (pattern * expression) list -+ | Pstr_primitive of string loc * value_description -+ | Pstr_type of (string loc * type_declaration) list -+ | Pstr_exception of string loc * exception_declaration -+ | Pstr_exn_rebind of string loc * Longident.t loc -+ | Pstr_module of string loc * module_expr -+ | Pstr_recmodule of (string loc * module_type * module_expr) list -+ | Pstr_modtype of string loc * module_type -+ | Pstr_open of Longident.t loc -+ | Pstr_class of class_declaration list -+ | Pstr_class_type of class_type_declaration list -+ | Pstr_include of module_expr -+ -+(* Toplevel phrases *) -+ -+type toplevel_phrase = -+ Ptop_def of structure -+ | Ptop_dir of string * directive_argument -+ -+and directive_argument = -+ Pdir_none -+ | Pdir_string of string -+ | Pdir_int of int -+ | Pdir_ident of Longident.t -+ | Pdir_bool of bool -diff -r -u -N camlp5-6.06.orig/ocaml_stuff/4.00.1/utils/.cvsignore camlp5-6.06/ocaml_stuff/4.00.1/utils/.cvsignore ---- camlp5-6.06.orig/ocaml_stuff/4.00.1/utils/.cvsignore 1970-01-01 01:00:00.000000000 +0100 -+++ camlp5-6.06/ocaml_stuff/4.00.1/utils/.cvsignore 2012-07-31 16:52:22.000000000 +0200 -@@ -0,0 +1 @@ -+*.cm[oix] -diff -r -u -N camlp5-6.06.orig/ocaml_stuff/4.00.1/utils/.depend camlp5-6.06/ocaml_stuff/4.00.1/utils/.depend ---- camlp5-6.06.orig/ocaml_stuff/4.00.1/utils/.depend 1970-01-01 01:00:00.000000000 +0100 -+++ camlp5-6.06/ocaml_stuff/4.00.1/utils/.depend 2012-07-31 16:52:22.000000000 +0200 -@@ -0,0 +1,4 @@ -+pconfig.cmo : pconfig.cmi -+pconfig.cmx : pconfig.cmi -+pconfig.cmi : -+warnings.cmi : -diff -r -u -N camlp5-6.06.orig/ocaml_stuff/4.00.1/utils/Makefile camlp5-6.06/ocaml_stuff/4.00.1/utils/Makefile ---- camlp5-6.06.orig/ocaml_stuff/4.00.1/utils/Makefile 1970-01-01 01:00:00.000000000 +0100 -+++ camlp5-6.06/ocaml_stuff/4.00.1/utils/Makefile 2012-07-31 16:52:22.000000000 +0200 -@@ -0,0 +1,27 @@ -+# Id -+ -+FILES=warnings.cmi pconfig.cmo -+INCL= -+ -+all: $(FILES) -+ -+opt: pconfig.cmx -+ -+clean: -+ rm -f *.cm[oix] *.o -+ -+depend: -+ ocamldep $(INCL) *.ml* | sed -e 's/ *$$//' > .depend -+ -+.SUFFIXES: .mli .cmi .ml .cmo .cmx -+ -+.mli.cmi: -+ $(OCAMLN)c $(INCL) -c $< -+ -+.ml.cmo: -+ $(OCAMLN)c $(INCL) -c $< -+ -+.ml.cmx: -+ $(OCAMLN)opt $(INCL) -c $< -+ -+include .depend -diff -r -u -N camlp5-6.06.orig/ocaml_stuff/4.00.1/utils/pconfig.ml camlp5-6.06/ocaml_stuff/4.00.1/utils/pconfig.ml ---- camlp5-6.06.orig/ocaml_stuff/4.00.1/utils/pconfig.ml 1970-01-01 01:00:00.000000000 +0100 -+++ camlp5-6.06/ocaml_stuff/4.00.1/utils/pconfig.ml 2012-07-31 16:53:40.000000000 +0200 -@@ -0,0 +1,4 @@ -+let ocaml_version = "4.00.1" -+let ocaml_name = "ocaml" -+let ast_impl_magic_number = "Caml1999M015" -+let ast_intf_magic_number = "Caml1999N014" -diff -r -u -N camlp5-6.06.orig/ocaml_stuff/4.00.1/utils/pconfig.mli camlp5-6.06/ocaml_stuff/4.00.1/utils/pconfig.mli ---- camlp5-6.06.orig/ocaml_stuff/4.00.1/utils/pconfig.mli 1970-01-01 01:00:00.000000000 +0100 -+++ camlp5-6.06/ocaml_stuff/4.00.1/utils/pconfig.mli 2012-07-31 16:52:22.000000000 +0200 -@@ -0,0 +1,4 @@ -+val ocaml_version : string -+val ocaml_name : string -+val ast_impl_magic_number : string -+val ast_intf_magic_number : string -diff -r -u -N camlp5-6.06.orig/ocaml_stuff/4.00.1/utils/warnings.mli camlp5-6.06/ocaml_stuff/4.00.1/utils/warnings.mli ---- camlp5-6.06.orig/ocaml_stuff/4.00.1/utils/warnings.mli 1970-01-01 01:00:00.000000000 +0100 -+++ camlp5-6.06/ocaml_stuff/4.00.1/utils/warnings.mli 2012-07-31 16:52:22.000000000 +0200 -@@ -0,0 +1,75 @@ -+(***********************************************************************) -+(* *) -+(* OCaml *) -+(* *) -+(* Pierre Weis && Damien Doligez, INRIA Rocquencourt *) -+(* *) -+(* Copyright 1998 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 *) -+ -+open Format -+ -+type t = -+ | Comment_start (* 1 *) -+ | Comment_not_end (* 2 *) -+ | Deprecated (* 3 *) -+ | Fragile_match of string (* 4 *) -+ | Partial_application (* 5 *) -+ | Labels_omitted (* 6 *) -+ | Method_override of string list (* 7 *) -+ | Partial_match of string (* 8 *) -+ | Non_closed_record_pattern of string (* 9 *) -+ | Statement_type (* 10 *) -+ | Unused_match (* 11 *) -+ | Unused_pat (* 12 *) -+ | Instance_variable_override of string list (* 13 *) -+ | Illegal_backslash (* 14 *) -+ | Implicit_public_methods of string list (* 15 *) -+ | Unerasable_optional_argument (* 16 *) -+ | Undeclared_virtual_method of string (* 17 *) -+ | Not_principal of string (* 18 *) -+ | Without_principality of string (* 19 *) -+ | Unused_argument (* 20 *) -+ | Nonreturning_statement (* 21 *) -+ | Camlp4 of string (* 22 *) -+ | Useless_record_with (* 23 *) -+ | Bad_module_name of string (* 24 *) -+ | All_clauses_guarded (* 25 *) -+ | Unused_var of string (* 26 *) -+ | Unused_var_strict of string (* 27 *) -+ | Wildcard_arg_to_constant_constr (* 28 *) -+ | Eol_in_string (* 29 *) -+ | Duplicate_definitions of string * string * string * string (*30 *) -+ | Multiple_definition of string * string * string (* 31 *) -+ | Unused_value_declaration of string (* 32 *) -+ | Unused_open of string (* 33 *) -+ | Unused_type_declaration of string (* 34 *) -+ | 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_rec_flag (* 39 *) -+;; -+ -+val parse_options : bool -> string -> unit;; -+ -+val is_active : t -> bool;; -+val is_error : t -> bool;; -+ -+val defaults_w : string;; -+val defaults_warn_error : string;; -+ -+val print : formatter -> t -> int;; -+ (* returns the number of newlines in the printed string *) -+ -+ -+exception Errors of int;; -+ -+val check_fatal : unit -> unit;; -+ -+val help_warnings: unit -> unit ---- camlp5-6.06/ocaml_stuff/4.01.0/utils/warnings.mli.orig 2013-02-18 15:14:16.000000000 +0100 -+++ camlp5-6.06/ocaml_stuff/4.01.0/utils/warnings.mli 2013-02-18 15:14:31.000000000 +0100 -@@ -54,6 +54,10 @@ - | Unused_constructor of string * bool * bool (* 37 *) - | Unused_exception of string * bool (* 38 *) - | Unused_rec_flag (* 39 *) -+ | Name_out_of_scope of string list * bool (* 40 *) -+ | Ambiguous_name of string list * bool (* 41 *) -+ | Disambiguated_name of string (* 42 *) -+ | Nonoptional_label of string (* 43 *) - ;; - - val parse_options : bool -> string -> unit;; -diff -N -r -u camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/.cvsignore camlp5-6.06/ocaml_stuff/4.00.2/parsing/.cvsignore ---- camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/.cvsignore 1970-01-01 01:00:00.000000000 +0100 -+++ camlp5-6.06/ocaml_stuff/4.00.2/parsing/.cvsignore 2013-03-06 14:44:56.000000000 +0100 -@@ -0,0 +1 @@ -+*.cm[oi] -diff -N -r -u camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/.depend camlp5-6.06/ocaml_stuff/4.00.2/parsing/.depend ---- camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/.depend 1970-01-01 01:00:00.000000000 +0100 -+++ camlp5-6.06/ocaml_stuff/4.00.2/parsing/.depend 2013-03-06 14:44:56.000000000 +0100 -@@ -0,0 +1,4 @@ -+asttypes.cmi : location.cmi -+location.cmi : ../utils/warnings.cmi -+longident.cmi : -+parsetree.cmi : longident.cmi location.cmi asttypes.cmi -diff -N -r -u camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/Makefile camlp5-6.06/ocaml_stuff/4.00.2/parsing/Makefile ---- camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/Makefile 1970-01-01 01:00:00.000000000 +0100 -+++ camlp5-6.06/ocaml_stuff/4.00.2/parsing/Makefile 2013-03-06 14:44:56.000000000 +0100 -@@ -0,0 +1,19 @@ -+# Id -+ -+FILES=asttypes.cmi location.cmi longident.cmi parsetree.cmi -+INCL=-I ../utils -+ -+all: $(FILES) -+ -+clean: -+ rm -f *.cmi -+ -+depend: -+ ocamldep $(INCL) *.ml* | sed -e 's/ *$$//' > .depend -+ -+.SUFFIXES: .mli .cmi -+ -+.mli.cmi: -+ $(OCAMLN)c $(INCL) -c $< -+ -+include .depend -diff -N -r -u camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/asttypes.mli camlp5-6.06/ocaml_stuff/4.00.2/parsing/asttypes.mli ---- camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/asttypes.mli 1970-01-01 01:00:00.000000000 +0100 -+++ camlp5-6.06/ocaml_stuff/4.00.2/parsing/asttypes.mli 2013-03-06 14:44:56.000000000 +0100 -@@ -0,0 +1,45 @@ -+(***********************************************************************) -+(* *) -+(* 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 Q Public License version 1.0. *) -+(* *) -+(***********************************************************************) -+ -+(* Id *) -+ -+(* Auxiliary a.s.t. types used by parsetree and typedtree. *) -+ -+type constant = -+ Const_int of int -+ | Const_char of char -+ | Const_string of string -+ | Const_float of string -+ | Const_int32 of int32 -+ | Const_int64 of int64 -+ | Const_nativeint of nativeint -+ -+type rec_flag = Nonrecursive | Recursive | Default -+ -+type direction_flag = Upto | Downto -+ -+type private_flag = Private | Public -+ -+type mutable_flag = Immutable | Mutable -+ -+type virtual_flag = Virtual | Concrete -+ -+type override_flag = Override | Fresh -+ -+type closed_flag = Closed | Open -+ -+type label = string -+ -+type 'a loc = 'a Location.loc = { -+ txt : 'a; -+ loc : Location.t; -+} -diff -N -r -u camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/location.mli camlp5-6.06/ocaml_stuff/4.00.2/parsing/location.mli ---- camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/location.mli 1970-01-01 01:00:00.000000000 +0100 -+++ camlp5-6.06/ocaml_stuff/4.00.2/parsing/location.mli 2013-03-06 14:44:56.000000000 +0100 -@@ -0,0 +1,80 @@ -+(***********************************************************************) -+(* *) -+(* 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 Q Public License version 1.0. *) -+(* *) -+(***********************************************************************) -+ -+(* Id *) -+ -+(* Source code locations (ranges of positions), used in parsetree. *) -+ -+open Format -+ -+type t = { -+ loc_start: Lexing.position; -+ loc_end: Lexing.position; -+ loc_ghost: bool; -+} -+ -+(* Note on the use of Lexing.position in this module. -+ If [pos_fname = ""], then use [!input_name] instead. -+ If [pos_lnum = -1], then [pos_bol = 0]. Use [pos_cnum] and -+ re-parse the file to get the line and character numbers. -+ Else all fields are correct. -+*) -+ -+val none : t -+(** An arbitrary value of type [t]; describes an empty ghost range. *) -+val in_file : string -> t;; -+(** Return an empty ghost range located in a given file. *) -+val init : Lexing.lexbuf -> string -> unit -+(** Set the file name and line number of the [lexbuf] to be the start -+ of the named file. *) -+val curr : Lexing.lexbuf -> t -+(** Get the location of the current token from the [lexbuf]. *) -+ -+val symbol_rloc: unit -> t -+val symbol_gloc: unit -> t -+ -+(** [rhs_loc n] returns the location of the symbol at position [n], starting -+ at 1, in the current parser rule. *) -+val rhs_loc: int -> t -+ -+val input_name: string ref -+val input_lexbuf: Lexing.lexbuf option ref -+ -+val get_pos_info: Lexing.position -> string * int * int (* file, line, char *) -+val print_loc: formatter -> t -> unit -+val print_error: formatter -> t -> unit -+val print_error_cur_file: formatter -> unit -+val print_warning: t -> formatter -> Warnings.t -> unit -+val prerr_warning: t -> Warnings.t -> unit -+val echo_eof: unit -> unit -+val reset: unit -> unit -+ -+val highlight_locations: formatter -> t -> t -> bool -+ -+type 'a loc = { -+ txt : 'a; -+ loc : t; -+} -+ -+val mknoloc : 'a -> 'a loc -+val mkloc : 'a -> t -> 'a loc -+ -+val print: formatter -> t -> unit -+val print_filename: formatter -> string -> unit -+ -+val show_filename: string -> string -+ (** In -absname mode, return the absolute path for this filename. -+ Otherwise, returns the filename unchanged. *) -+ -+ -+val absname: bool ref -+ -diff -N -r -u camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/longident.mli camlp5-6.06/ocaml_stuff/4.00.2/parsing/longident.mli ---- camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/longident.mli 1970-01-01 01:00:00.000000000 +0100 -+++ camlp5-6.06/ocaml_stuff/4.00.2/parsing/longident.mli 2013-03-06 14:44:56.000000000 +0100 -@@ -0,0 +1,24 @@ -+(***********************************************************************) -+(* *) -+(* 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 Q Public License version 1.0. *) -+(* *) -+(***********************************************************************) -+ -+(* Id *) -+ -+(* Long identifiers, used in parsetree. *) -+ -+type t = -+ Lident of string -+ | Ldot of t * string -+ | Lapply of t * t -+ -+val flatten: t -> string list -+val last: t -> string -+val parse: string -> t -diff -N -r -u camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/parsetree.mli camlp5-6.06/ocaml_stuff/4.00.2/parsing/parsetree.mli ---- camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/parsetree.mli 1970-01-01 01:00:00.000000000 +0100 -+++ camlp5-6.06/ocaml_stuff/4.00.2/parsing/parsetree.mli 2013-03-06 14:44:56.000000000 +0100 -@@ -0,0 +1,307 @@ -+(***********************************************************************) -+(* *) -+(* 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 Q Public License version 1.0. *) -+(* *) -+(***********************************************************************) -+ -+(* Id *) -+ -+(* Abstract syntax tree produced by parsing *) -+ -+open Asttypes -+ -+(* Type expressions for the core language *) -+ -+type core_type = -+ { ptyp_desc: core_type_desc; -+ ptyp_loc: Location.t } -+ -+and core_type_desc = -+ Ptyp_any -+ | Ptyp_var of string -+ | Ptyp_arrow of label * core_type * core_type -+ | Ptyp_tuple of core_type list -+ | Ptyp_constr of Longident.t loc * core_type list -+ | Ptyp_object of core_field_type list -+ | Ptyp_class of Longident.t loc * core_type list * label list -+ | Ptyp_alias of core_type * string -+ | Ptyp_variant of row_field list * bool * label list option -+ | Ptyp_poly of string list * core_type -+ | Ptyp_package of package_type -+ -+ -+and package_type = Longident.t loc * (Longident.t loc * core_type) list -+ -+and core_field_type = -+ { pfield_desc: core_field_desc; -+ pfield_loc: Location.t } -+ -+and core_field_desc = -+ Pfield of string * core_type -+ | Pfield_var -+ -+and row_field = -+ Rtag of label * bool * core_type list -+ | Rinherit of core_type -+ -+(* Type expressions for the class language *) -+ -+type 'a class_infos = -+ { pci_virt: virtual_flag; -+ pci_params: string loc list * Location.t; -+ pci_name: string loc; -+ pci_expr: 'a; -+ pci_variance: (bool * bool) list; -+ pci_loc: Location.t } -+ -+(* Value expressions for the core language *) -+ -+type pattern = -+ { ppat_desc: pattern_desc; -+ ppat_loc: Location.t } -+ -+and pattern_desc = -+ Ppat_any -+ | Ppat_var of string loc -+ | Ppat_alias of pattern * string loc -+ | Ppat_constant of constant -+ | Ppat_tuple of pattern list -+ | Ppat_construct of Longident.t loc * pattern option * bool -+ | Ppat_variant of label * pattern option -+ | Ppat_record of (Longident.t loc * pattern) list * closed_flag -+ | Ppat_array of pattern list -+ | Ppat_or of pattern * pattern -+ | Ppat_constraint of pattern * core_type -+ | Ppat_type of Longident.t loc -+ | Ppat_lazy of pattern -+ | Ppat_unpack of string loc -+ -+type expression = -+ { pexp_desc: expression_desc; -+ pexp_loc: Location.t } -+ -+and expression_desc = -+ Pexp_ident of Longident.t loc -+ | Pexp_constant of constant -+ | Pexp_let of rec_flag * (pattern * expression) list * expression -+ | Pexp_function of label * expression option * (pattern * expression) list -+ | Pexp_apply of expression * (label * expression) list -+ | Pexp_match of expression * (pattern * expression) list -+ | Pexp_try of expression * (pattern * expression) list -+ | Pexp_tuple of expression list -+ | Pexp_construct of Longident.t loc * expression option * bool -+ | Pexp_variant of label * expression option -+ | Pexp_record of (Longident.t loc * expression) list * expression option -+ | Pexp_field of expression * Longident.t loc -+ | Pexp_setfield of expression * Longident.t loc * expression -+ | Pexp_array of expression list -+ | Pexp_ifthenelse of expression * expression * expression option -+ | Pexp_sequence of expression * expression -+ | Pexp_while of expression * expression -+ | Pexp_for of string loc * expression * expression * direction_flag * expression -+ | Pexp_constraint of expression * core_type option * core_type option -+ | Pexp_when of expression * expression -+ | Pexp_send of expression * string -+ | Pexp_new of Longident.t loc -+ | Pexp_setinstvar of string loc * expression -+ | Pexp_override of (string loc * expression) list -+ | Pexp_letmodule of string loc * module_expr * expression -+ | Pexp_assert of expression -+ | Pexp_assertfalse -+ | Pexp_lazy of expression -+ | Pexp_poly of expression * core_type option -+ | Pexp_object of class_structure -+ | Pexp_newtype of string * expression -+ | Pexp_pack of module_expr -+ | Pexp_open of Longident.t loc * expression -+ -+(* Value descriptions *) -+ -+and value_description = -+ { pval_type: core_type; -+ pval_prim: string list; -+ pval_loc : Location.t -+ } -+ -+(* Type declarations *) -+ -+and type_declaration = -+ { ptype_params: string loc option list; -+ ptype_cstrs: (core_type * core_type * Location.t) list; -+ ptype_kind: type_kind; -+ ptype_private: private_flag; -+ ptype_manifest: core_type option; -+ ptype_variance: (bool * bool) list; -+ ptype_loc: Location.t } -+ -+and type_kind = -+ Ptype_abstract -+ | Ptype_variant of -+ (string loc * core_type list * core_type option * Location.t) list -+ | Ptype_record of -+ (string loc * mutable_flag * core_type * Location.t) list -+ -+and exception_declaration = core_type list -+ -+(* Type expressions for the class language *) -+ -+and class_type = -+ { pcty_desc: class_type_desc; -+ pcty_loc: Location.t } -+ -+and class_type_desc = -+ Pcty_constr of Longident.t loc * core_type list -+ | Pcty_signature of class_signature -+ | Pcty_fun of label * core_type * class_type -+ -+and class_signature = { -+ pcsig_self : core_type; -+ pcsig_fields : class_type_field list; -+ pcsig_loc : Location.t; -+ } -+ -+and class_type_field = { -+ pctf_desc : class_type_field_desc; -+ pctf_loc : Location.t; -+ } -+ -+and class_type_field_desc = -+ Pctf_inher of class_type -+ | Pctf_val of (string * mutable_flag * virtual_flag * core_type) -+ | Pctf_virt of (string * private_flag * core_type) -+ | Pctf_meth of (string * private_flag * core_type) -+ | Pctf_cstr of (core_type * core_type) -+ -+and class_description = class_type class_infos -+ -+and class_type_declaration = class_type class_infos -+ -+(* Value expressions for the class language *) -+ -+and class_expr = -+ { pcl_desc: class_expr_desc; -+ pcl_loc: Location.t } -+ -+and class_expr_desc = -+ Pcl_constr of Longident.t loc * core_type list -+ | Pcl_structure of class_structure -+ | Pcl_fun of label * expression option * pattern * class_expr -+ | Pcl_apply of class_expr * (label * expression) list -+ | Pcl_let of rec_flag * (pattern * expression) list * class_expr -+ | Pcl_constraint of class_expr * class_type -+ -+and class_structure = { -+ pcstr_pat : pattern; -+ pcstr_fields : class_field list; -+ } -+ -+and class_field = { -+ pcf_desc : class_field_desc; -+ pcf_loc : Location.t; -+ } -+ -+and class_field_desc = -+ Pcf_inher of override_flag * class_expr * string option -+ | Pcf_valvirt of (string loc * mutable_flag * core_type) -+ | Pcf_val of (string loc * mutable_flag * override_flag * expression) -+ | Pcf_virt of (string loc * private_flag * core_type) -+ | Pcf_meth of (string loc * private_flag *override_flag * expression) -+ | Pcf_constr of (core_type * core_type) -+ | Pcf_init of expression -+ -+and class_declaration = class_expr class_infos -+ -+(* Type expressions for the module language *) -+ -+and module_type = -+ { pmty_desc: module_type_desc; -+ pmty_loc: Location.t } -+ -+and module_type_desc = -+ Pmty_ident of Longident.t loc -+ | Pmty_signature of signature -+ | Pmty_functor of string loc * module_type * module_type -+ | Pmty_with of module_type * (Longident.t loc * with_constraint) list -+ | Pmty_typeof of module_expr -+ -+and signature = signature_item list -+ -+and signature_item = -+ { psig_desc: signature_item_desc; -+ psig_loc: Location.t } -+ -+and signature_item_desc = -+ Psig_value of string loc * value_description -+ | Psig_type of (string loc * type_declaration) list -+ | Psig_exception of string loc * exception_declaration -+ | Psig_module of string loc * module_type -+ | Psig_recmodule of (string loc * module_type) list -+ | Psig_modtype of string loc * modtype_declaration -+ | Psig_open of Longident.t loc -+ | Psig_include of module_type -+ | Psig_class of class_description list -+ | Psig_class_type of class_type_declaration list -+ -+and modtype_declaration = -+ Pmodtype_abstract -+ | Pmodtype_manifest of module_type -+ -+and with_constraint = -+ Pwith_type of type_declaration -+ | Pwith_module of Longident.t loc -+ | Pwith_typesubst of type_declaration -+ | Pwith_modsubst of Longident.t loc -+ -+(* Value expressions for the module language *) -+ -+and module_expr = -+ { pmod_desc: module_expr_desc; -+ pmod_loc: Location.t } -+ -+and module_expr_desc = -+ Pmod_ident of Longident.t loc -+ | Pmod_structure of structure -+ | Pmod_functor of string loc * module_type * module_expr -+ | Pmod_apply of module_expr * module_expr -+ | Pmod_constraint of module_expr * module_type -+ | Pmod_unpack of expression -+ -+and structure = structure_item list -+ -+and structure_item = -+ { pstr_desc: structure_item_desc; -+ pstr_loc: Location.t } -+ -+and structure_item_desc = -+ Pstr_eval of expression -+ | Pstr_value of rec_flag * (pattern * expression) list -+ | Pstr_primitive of string loc * value_description -+ | Pstr_type of (string loc * type_declaration) list -+ | Pstr_exception of string loc * exception_declaration -+ | Pstr_exn_rebind of string loc * Longident.t loc -+ | Pstr_module of string loc * module_expr -+ | Pstr_recmodule of (string loc * module_type * module_expr) list -+ | Pstr_modtype of string loc * module_type -+ | Pstr_open of Longident.t loc -+ | Pstr_class of class_declaration list -+ | Pstr_class_type of class_type_declaration list -+ | Pstr_include of module_expr -+ -+(* Toplevel phrases *) -+ -+type toplevel_phrase = -+ Ptop_def of structure -+ | Ptop_dir of string * directive_argument -+ -+and directive_argument = -+ Pdir_none -+ | Pdir_string of string -+ | Pdir_int of int -+ | Pdir_ident of Longident.t -+ | Pdir_bool of bool -diff -N -r -u camlp5-6.06.orig/ocaml_stuff/4.00.2/utils/.cvsignore camlp5-6.06/ocaml_stuff/4.00.2/utils/.cvsignore ---- camlp5-6.06.orig/ocaml_stuff/4.00.2/utils/.cvsignore 1970-01-01 01:00:00.000000000 +0100 -+++ camlp5-6.06/ocaml_stuff/4.00.2/utils/.cvsignore 2013-03-06 14:44:56.000000000 +0100 -@@ -0,0 +1 @@ -+*.cm[oix] -diff -N -r -u camlp5-6.06.orig/ocaml_stuff/4.00.2/utils/.depend camlp5-6.06/ocaml_stuff/4.00.2/utils/.depend ---- camlp5-6.06.orig/ocaml_stuff/4.00.2/utils/.depend 1970-01-01 01:00:00.000000000 +0100 -+++ camlp5-6.06/ocaml_stuff/4.00.2/utils/.depend 2013-03-06 14:44:56.000000000 +0100 -@@ -0,0 +1,2 @@ -+pconfig.cmo: pconfig.cmi -+pconfig.cmx: pconfig.cmi -diff -N -r -u camlp5-6.06.orig/ocaml_stuff/4.00.2/utils/Makefile camlp5-6.06/ocaml_stuff/4.00.2/utils/Makefile ---- camlp5-6.06.orig/ocaml_stuff/4.00.2/utils/Makefile 1970-01-01 01:00:00.000000000 +0100 -+++ camlp5-6.06/ocaml_stuff/4.00.2/utils/Makefile 2013-03-06 14:44:56.000000000 +0100 -@@ -0,0 +1,27 @@ -+# Id -+ -+FILES=warnings.cmi pconfig.cmo -+INCL= -+ -+all: $(FILES) -+ -+opt: pconfig.cmx -+ -+clean: -+ rm -f *.cm[oix] *.o -+ -+depend: -+ ocamldep $(INCL) *.ml* | sed -e 's/ *$$//' > .depend -+ -+.SUFFIXES: .mli .cmi .ml .cmo .cmx -+ -+.mli.cmi: -+ $(OCAMLN)c $(INCL) -c $< -+ -+.ml.cmo: -+ $(OCAMLN)c $(INCL) -c $< -+ -+.ml.cmx: -+ $(OCAMLN)opt $(INCL) -c $< -+ -+include .depend -diff -N -r -u camlp5-6.06.orig/ocaml_stuff/4.00.2/utils/pconfig.ml camlp5-6.06/ocaml_stuff/4.00.2/utils/pconfig.ml ---- camlp5-6.06.orig/ocaml_stuff/4.00.2/utils/pconfig.ml 1970-01-01 01:00:00.000000000 +0100 -+++ camlp5-6.06/ocaml_stuff/4.00.2/utils/pconfig.ml 2013-03-06 14:44:56.000000000 +0100 -@@ -0,0 +1,4 @@ -+let ocaml_version = "4.00.2" -+let ocaml_name = "ocaml" -+let ast_impl_magic_number = "Caml1999M015" -+let ast_intf_magic_number = "Caml1999N014" -diff -N -r -u camlp5-6.06.orig/ocaml_stuff/4.00.2/utils/pconfig.mli camlp5-6.06/ocaml_stuff/4.00.2/utils/pconfig.mli ---- camlp5-6.06.orig/ocaml_stuff/4.00.2/utils/pconfig.mli 1970-01-01 01:00:00.000000000 +0100 -+++ camlp5-6.06/ocaml_stuff/4.00.2/utils/pconfig.mli 2013-03-06 14:44:56.000000000 +0100 -@@ -0,0 +1,4 @@ -+val ocaml_version : string -+val ocaml_name : string -+val ast_impl_magic_number : string -+val ast_intf_magic_number : string -diff -N -r -u camlp5-6.06.orig/ocaml_stuff/4.00.2/utils/warnings.mli camlp5-6.06/ocaml_stuff/4.00.2/utils/warnings.mli ---- camlp5-6.06.orig/ocaml_stuff/4.00.2/utils/warnings.mli 1970-01-01 01:00:00.000000000 +0100 -+++ camlp5-6.06/ocaml_stuff/4.00.2/utils/warnings.mli 2013-03-06 14:44:56.000000000 +0100 -@@ -0,0 +1,75 @@ -+(***********************************************************************) -+(* *) -+(* OCaml *) -+(* *) -+(* Pierre Weis && Damien Doligez, INRIA Rocquencourt *) -+(* *) -+(* Copyright 1998 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 *) -+ -+open Format -+ -+type t = -+ | Comment_start (* 1 *) -+ | Comment_not_end (* 2 *) -+ | Deprecated (* 3 *) -+ | Fragile_match of string (* 4 *) -+ | Partial_application (* 5 *) -+ | Labels_omitted (* 6 *) -+ | Method_override of string list (* 7 *) -+ | Partial_match of string (* 8 *) -+ | Non_closed_record_pattern of string (* 9 *) -+ | Statement_type (* 10 *) -+ | Unused_match (* 11 *) -+ | Unused_pat (* 12 *) -+ | Instance_variable_override of string list (* 13 *) -+ | Illegal_backslash (* 14 *) -+ | Implicit_public_methods of string list (* 15 *) -+ | Unerasable_optional_argument (* 16 *) -+ | Undeclared_virtual_method of string (* 17 *) -+ | Not_principal of string (* 18 *) -+ | Without_principality of string (* 19 *) -+ | Unused_argument (* 20 *) -+ | Nonreturning_statement (* 21 *) -+ | Camlp4 of string (* 22 *) -+ | Useless_record_with (* 23 *) -+ | Bad_module_name of string (* 24 *) -+ | All_clauses_guarded (* 25 *) -+ | Unused_var of string (* 26 *) -+ | Unused_var_strict of string (* 27 *) -+ | Wildcard_arg_to_constant_constr (* 28 *) -+ | Eol_in_string (* 29 *) -+ | Duplicate_definitions of string * string * string * string (*30 *) -+ | Multiple_definition of string * string * string (* 31 *) -+ | Unused_value_declaration of string (* 32 *) -+ | Unused_open of string (* 33 *) -+ | Unused_type_declaration of string (* 34 *) -+ | 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_rec_flag (* 39 *) -+;; -+ -+val parse_options : bool -> string -> unit;; -+ -+val is_active : t -> bool;; -+val is_error : t -> bool;; -+ -+val defaults_w : string;; -+val defaults_warn_error : string;; -+ -+val print : formatter -> t -> int;; -+ (* returns the number of newlines in the printed string *) -+ -+ -+exception Errors of int;; -+ -+val check_fatal : unit -> unit;; -+ -+val help_warnings: unit -> unit -diff -r -u -N camlp5-6.06.orig/ocaml_src/lib/versdep/4.00.2.ml camlp5-6.06/ocaml_src/lib/versdep/4.00.2.ml ---- camlp5-6.06.orig/ocaml_src/lib/versdep/4.00.2.ml 1970-01-01 01:00:00.000000000 +0100 -+++ camlp5-6.06/ocaml_src/lib/versdep/4.00.2.ml 2012-07-31 16:52:22.000000000 +0200 -@@ -0,0 +1,465 @@ -+(* camlp5r pa_macro.cmo *) -+(* File generated by program: edit only if it does not compile. *) -+(* Copyright (c) INRIA 2007-2012 *) -+ -+open Parsetree;; -+open Longident;; -+open Asttypes;; -+ -+type ('a, 'b) choice = -+ Left of 'a -+ | Right of 'b -+;; -+ -+let sys_ocaml_version = Sys.ocaml_version;; -+ -+let ocaml_location (fname, lnum, bolp, lnuml, bolpl, bp, ep) = -+ let loc_at n lnum bolp = -+ {Lexing.pos_fname = if lnum = -1 then "" else fname; -+ Lexing.pos_lnum = lnum; Lexing.pos_bol = bolp; Lexing.pos_cnum = n} -+ in -+ {Location.loc_start = loc_at bp lnum bolp; -+ Location.loc_end = loc_at ep lnuml bolpl; -+ Location.loc_ghost = bp = 0 && ep = 0} -+;; -+ -+let loc_none = -+ let loc = -+ {Lexing.pos_fname = "_none_"; Lexing.pos_lnum = 1; Lexing.pos_bol = 0; -+ Lexing.pos_cnum = -1} -+ in -+ {Location.loc_start = loc; Location.loc_end = loc; -+ Location.loc_ghost = true} -+;; -+ -+let mkloc loc txt = {Location.txt = txt; Location.loc = loc};; -+let mknoloc txt = mkloc loc_none txt;; -+ -+let ocaml_id_or_li_of_string_list loc sl = -+ let mkli s = -+ let rec loop f = -+ function -+ i :: il -> loop (fun s -> Ldot (f i, s)) il -+ | [] -> f s -+ in -+ loop (fun s -> Lident s) -+ in -+ match List.rev sl with -+ [] -> None -+ | s :: sl -> Some (mkli s (List.rev sl)) -+;; -+ -+let list_map_check f l = -+ let rec loop rev_l = -+ function -+ x :: l -> -+ begin match f x with -+ Some s -> loop (s :: rev_l) l -+ | None -> None -+ end -+ | [] -> Some (List.rev rev_l) -+ in -+ loop [] l -+;; -+ -+let ocaml_value_description t p = -+ {pval_type = t; pval_prim = p; pval_loc = t.ptyp_loc} -+;; -+ -+let ocaml_class_type_field loc ctfd = {pctf_desc = ctfd; pctf_loc = loc};; -+ -+let ocaml_class_field loc cfd = {pcf_desc = cfd; pcf_loc = loc};; -+ -+let ocaml_type_declaration params cl tk pf tm loc variance = -+ match list_map_check (fun s_opt -> s_opt) params with -+ Some params -> -+ let params = List.map (fun os -> Some (mknoloc os)) params in -+ Right -+ {ptype_params = params; ptype_cstrs = cl; ptype_kind = tk; -+ ptype_private = pf; ptype_manifest = tm; ptype_loc = loc; -+ ptype_variance = variance} -+ | None -> Left "no '_' type param in this ocaml version" -+;; -+ -+let ocaml_class_type = Some (fun d loc -> {pcty_desc = d; pcty_loc = loc});; -+ -+let ocaml_class_expr = Some (fun d loc -> {pcl_desc = d; pcl_loc = loc});; -+ -+let ocaml_class_structure p cil = {pcstr_pat = p; pcstr_fields = cil};; -+ -+let ocaml_pmty_ident loc li = Pmty_ident (mkloc loc li);; -+ -+let ocaml_pmty_functor sloc s mt1 mt2 = -+ Pmty_functor (mkloc sloc s, mt1, mt2) -+;; -+ -+let ocaml_pmty_typeof = Some (fun me -> Pmty_typeof me);; -+ -+let ocaml_pmty_with mt lcl = -+ let lcl = List.map (fun (s, c) -> mknoloc s, c) lcl in Pmty_with (mt, lcl) -+;; -+ -+let ocaml_ptype_abstract = Ptype_abstract;; -+ -+let ocaml_ptype_record ltl priv = -+ Ptype_record -+ (List.map (fun (s, mf, ct, loc) -> mkloc loc s, mf, ct, loc) ltl) -+;; -+ -+let ocaml_ptype_variant ctl priv = -+ try -+ let ctl = -+ List.map -+ (fun (c, tl, rto, loc) -> -+ if rto <> None then raise Exit else mknoloc c, tl, None, loc) -+ ctl -+ in -+ Some (Ptype_variant ctl) -+ with Exit -> None -+;; -+ -+let ocaml_ptyp_arrow lab t1 t2 = Ptyp_arrow (lab, t1, t2);; -+ -+let ocaml_ptyp_class li tl ll = Ptyp_class (mknoloc li, tl, ll);; -+ -+let ocaml_ptyp_constr li tl = Ptyp_constr (mknoloc li, tl);; -+ -+let ocaml_ptyp_package = Some (fun pt -> Ptyp_package pt);; -+ -+let ocaml_ptyp_poly = Some (fun cl t -> Ptyp_poly (cl, t));; -+ -+let ocaml_ptyp_variant catl clos sl_opt = -+ let catl = -+ List.map -+ (function -+ Left (c, a, tl) -> Rtag (c, a, tl) -+ | Right t -> Rinherit t) -+ catl -+ in -+ Some (Ptyp_variant (catl, clos, sl_opt)) -+;; -+ -+let ocaml_package_type li ltl = -+ mknoloc li, List.map (fun (li, t) -> mkloc t.ptyp_loc li, t) ltl -+;; -+ -+let ocaml_const_int32 = Some (fun s -> Const_int32 (Int32.of_string s));; -+ -+let ocaml_const_int64 = Some (fun s -> Const_int64 (Int64.of_string s));; -+ -+let ocaml_const_nativeint = -+ Some (fun s -> Const_nativeint (Nativeint.of_string s)) -+;; -+ -+let ocaml_pexp_apply f lel = Pexp_apply (f, lel);; -+ -+let ocaml_pexp_assertfalse fname loc = Pexp_assertfalse;; -+ -+let ocaml_pexp_assert fname loc e = Pexp_assert e;; -+ -+let ocaml_pexp_construct li po chk_arity = -+ Pexp_construct (mknoloc li, po, chk_arity) -+;; -+ -+let ocaml_pexp_field e li = Pexp_field (e, mknoloc li);; -+ -+let ocaml_pexp_for i e1 e2 df e = Pexp_for (mknoloc i, e1, e2, df, e);; -+ -+let ocaml_pexp_function lab eo pel = Pexp_function (lab, eo, pel);; -+ -+let ocaml_pexp_lazy = Some (fun e -> Pexp_lazy e);; -+ -+let ocaml_pexp_ident li = Pexp_ident (mknoloc li);; -+ -+let ocaml_pexp_letmodule = -+ Some (fun i me e -> Pexp_letmodule (mknoloc i, me, e)) -+;; -+ -+let ocaml_pexp_new loc li = Pexp_new (mkloc loc li);; -+ -+let ocaml_pexp_newtype = Some (fun s e -> Pexp_newtype (s, e));; -+ -+let ocaml_pexp_object = Some (fun cs -> Pexp_object cs);; -+ -+let ocaml_pexp_open = Some (fun li e -> Pexp_open (mknoloc li, e));; -+ -+let ocaml_pexp_override sel = -+ let sel = List.map (fun (s, e) -> mknoloc s, e) sel in Pexp_override sel -+;; -+ -+let ocaml_pexp_pack : ('a -> 'b -> 'c, 'd) choice option = -+ Some (Right ((fun me -> Pexp_pack me), (fun pt -> Ptyp_package pt))) -+;; -+ -+let ocaml_pexp_poly = Some (fun e t -> Pexp_poly (e, t));; -+ -+let ocaml_pexp_record lel eo = -+ let lel = List.map (fun (li, loc, e) -> mkloc loc li, e) lel in -+ Pexp_record (lel, eo) -+;; -+ -+let ocaml_pexp_setinstvar s e = Pexp_setinstvar (mknoloc s, e);; -+ -+let ocaml_pexp_variant = -+ let pexp_variant_pat = -+ function -+ Pexp_variant (lab, eo) -> Some (lab, eo) -+ | _ -> None -+ in -+ let pexp_variant (lab, eo) = Pexp_variant (lab, eo) in -+ Some (pexp_variant_pat, pexp_variant) -+;; -+ -+let ocaml_ppat_alias p i iloc = Ppat_alias (p, mkloc iloc i);; -+ -+let ocaml_ppat_array = Some (fun pl -> Ppat_array pl);; -+ -+let ocaml_ppat_construct li li_loc po chk_arity = -+ Ppat_construct (mkloc li_loc li, po, chk_arity) -+;; -+ -+let ocaml_ppat_construct_args = -+ function -+ Ppat_construct (li, po, chk_arity) -> Some (li.txt, li.loc, po, chk_arity) -+ | _ -> None -+;; -+ -+let ocaml_ppat_lazy = Some (fun p -> Ppat_lazy p);; -+ -+let ocaml_ppat_record lpl is_closed = -+ let lpl = List.map (fun (li, loc, p) -> mkloc loc li, p) lpl in -+ Ppat_record (lpl, (if is_closed then Closed else Open)) -+;; -+ -+let ocaml_ppat_type = Some (fun loc li -> Ppat_type (mkloc loc li));; -+ -+let ocaml_ppat_unpack = -+ Some ((fun loc s -> Ppat_unpack (mkloc loc s)), (fun pt -> Ptyp_package pt)) -+;; -+ -+let ocaml_ppat_var loc s = Ppat_var (mkloc loc s);; -+ -+let ocaml_ppat_variant = -+ let ppat_variant_pat = -+ function -+ Ppat_variant (lab, po) -> Some (lab, po) -+ | _ -> None -+ in -+ let ppat_variant (lab, po) = Ppat_variant (lab, po) in -+ Some (ppat_variant_pat, ppat_variant) -+;; -+ -+let ocaml_psig_class_type = Some (fun ctl -> Psig_class_type ctl);; -+ -+let ocaml_psig_exception s ed = Psig_exception (mknoloc s, ed);; -+ -+let ocaml_psig_module s mt = Psig_module (mknoloc s, mt);; -+ -+let ocaml_psig_modtype s mtd = Psig_modtype (mknoloc s, mtd);; -+ -+let ocaml_psig_open li = Psig_open (mknoloc li);; -+ -+let ocaml_psig_recmodule = -+ let f ntl = -+ let ntl = List.map (fun (s, mt) -> mknoloc s, mt) ntl in -+ Psig_recmodule ntl -+ in -+ Some f -+;; -+ -+let ocaml_psig_type stl = -+ let stl = List.map (fun (s, t) -> mknoloc s, t) stl in Psig_type stl -+;; -+ -+let ocaml_psig_value s vd = Psig_value (mknoloc s, vd);; -+ -+let ocaml_pstr_class_type = Some (fun ctl -> Pstr_class_type ctl);; -+ -+let ocaml_pstr_exception s ed = Pstr_exception (mknoloc s, ed);; -+ -+let ocaml_pstr_exn_rebind = -+ Some (fun s li -> Pstr_exn_rebind (mknoloc s, mknoloc li)) -+;; -+ -+let ocaml_pstr_include = Some (fun me -> Pstr_include me);; -+ -+let ocaml_pstr_modtype s mt = Pstr_modtype (mknoloc s, mt);; -+ -+let ocaml_pstr_module s me = Pstr_module (mknoloc s, me);; -+ -+let ocaml_pstr_open li = Pstr_open (mknoloc li);; -+ -+let ocaml_pstr_primitive s vd = Pstr_primitive (mknoloc s, vd);; -+ -+let ocaml_pstr_recmodule = -+ let f nel = -+ Pstr_recmodule (List.map (fun (s, mt, me) -> mknoloc s, mt, me) nel) -+ in -+ Some f -+;; -+ -+let ocaml_pstr_type stl = -+ let stl = List.map (fun (s, t) -> mknoloc s, t) stl in Pstr_type stl -+;; -+ -+let ocaml_class_infos = -+ Some -+ (fun virt (sl, sloc) name expr loc variance -> -+ let params = List.map (fun s -> mkloc loc s) sl, sloc in -+ {pci_virt = virt; pci_params = params; pci_name = mkloc loc name; -+ pci_expr = expr; pci_loc = loc; pci_variance = variance}) -+;; -+ -+let ocaml_pmod_ident li = Pmod_ident (mknoloc li);; -+ -+let ocaml_pmod_functor s mt me = Pmod_functor (mknoloc s, mt, me);; -+ -+let ocaml_pmod_unpack : ('a -> 'b -> 'c, 'd) choice option = -+ Some (Right ((fun e -> Pmod_unpack e), (fun pt -> Ptyp_package pt))) -+;; -+ -+let ocaml_pcf_cstr = Some (fun (t1, t2, loc) -> Pcf_constr (t1, t2));; -+ -+let ocaml_pcf_inher ce pb = Pcf_inher (Fresh, ce, pb);; -+ -+let ocaml_pcf_init = Some (fun e -> Pcf_init e);; -+ -+let ocaml_pcf_meth (s, pf, ovf, e, loc) = -+ let pf = if pf then Private else Public in -+ let ovf = if ovf then Override else Fresh in -+ Pcf_meth (mkloc loc s, pf, ovf, e) -+;; -+ -+let ocaml_pcf_val (s, mf, ovf, e, loc) = -+ let mf = if mf then Mutable else Immutable in -+ let ovf = if ovf then Override else Fresh in -+ Pcf_val (mkloc loc s, mf, ovf, e) -+;; -+ -+let ocaml_pcf_valvirt = -+ let ocaml_pcf (s, mf, t, loc) = -+ let mf = if mf then Mutable else Immutable in -+ Pcf_valvirt (mkloc loc s, mf, t) -+ in -+ Some ocaml_pcf -+;; -+ -+let ocaml_pcf_virt (s, pf, t, loc) = Pcf_virt (mkloc loc s, pf, t);; -+ -+let ocaml_pcl_apply = Some (fun ce lel -> Pcl_apply (ce, lel));; -+ -+let ocaml_pcl_constr = Some (fun li ctl -> Pcl_constr (mknoloc li, ctl));; -+ -+let ocaml_pcl_constraint = Some (fun ce ct -> Pcl_constraint (ce, ct));; -+ -+let ocaml_pcl_fun = Some (fun lab ceo p ce -> Pcl_fun (lab, ceo, p, ce));; -+ -+let ocaml_pcl_let = Some (fun rf pel ce -> Pcl_let (rf, pel, ce));; -+ -+let ocaml_pcl_structure = Some (fun cs -> Pcl_structure cs);; -+ -+let ocaml_pctf_cstr = Some (fun (t1, t2, loc) -> Pctf_cstr (t1, t2));; -+ -+let ocaml_pctf_meth (s, pf, t, loc) = Pctf_meth (s, pf, t);; -+ -+let ocaml_pctf_val (s, mf, t, loc) = Pctf_val (s, mf, Concrete, t);; -+ -+let ocaml_pctf_virt (s, pf, t, loc) = Pctf_virt (s, pf, t);; -+ -+let ocaml_pcty_constr = Some (fun li ltl -> Pcty_constr (mknoloc li, ltl));; -+ -+let ocaml_pcty_fun = Some (fun lab t ct -> Pcty_fun (lab, t, ct));; -+ -+let ocaml_pcty_signature = -+ let f (t, ctfl) = -+ let cs = {pcsig_self = t; pcsig_fields = ctfl; pcsig_loc = t.ptyp_loc} in -+ Pcty_signature cs -+ in -+ Some f -+;; -+ -+let ocaml_pdir_bool = Some (fun b -> Pdir_bool b);; -+ -+let ocaml_pwith_modsubst = -+ Some (fun loc me -> Pwith_modsubst (mkloc loc me)) -+;; -+ -+let ocaml_pwith_module loc me = Pwith_module (mkloc loc me);; -+ -+let ocaml_pwith_typesubst = Some (fun td -> Pwith_typesubst td);; -+ -+let module_prefix_can_be_in_first_record_label_only = true;; -+ -+let split_or_patterns_with_bindings = false;; -+ -+let has_records_with_with = true;; -+ -+(* *) -+ -+let jocaml_pstr_def : (_ -> _) option = None;; -+ -+let jocaml_pexp_def : (_ -> _ -> _) option = None;; -+ -+let jocaml_pexp_par : (_ -> _ -> _) option = None;; -+ -+let jocaml_pexp_reply : (_ -> _ -> _ -> _) option = None;; -+ -+let jocaml_pexp_spawn : (_ -> _) option = None;; -+ -+let arg_rest = -+ function -+ Arg.Rest r -> Some r -+ | _ -> None -+;; -+ -+let arg_set_string = -+ function -+ Arg.Set_string r -> Some r -+ | _ -> None -+;; -+ -+let arg_set_int = -+ function -+ Arg.Set_int r -> Some r -+ | _ -> None -+;; -+ -+let arg_set_float = -+ function -+ Arg.Set_float r -> Some r -+ | _ -> None -+;; -+ -+let arg_symbol = -+ function -+ Arg.Symbol (s, f) -> Some (s, f) -+ | _ -> None -+;; -+ -+let arg_tuple = -+ function -+ Arg.Tuple t -> Some t -+ | _ -> None -+;; -+ -+let arg_bool = -+ function -+ Arg.Bool f -> Some f -+ | _ -> None -+;; -+ -+let char_escaped = Char.escaped;; -+ -+let hashtbl_mem = Hashtbl.mem;; -+ -+let list_rev_append = List.rev_append;; -+ -+let list_rev_map = List.rev_map;; -+ -+let list_sort = List.sort;; -+ -+let pervasives_set_binary_mode_out = Pervasives.set_binary_mode_out;; -+ -+let printf_ksprintf = Printf.ksprintf;; -+ -+let string_contains = String.contains;; diff --git a/testsuite/external/camlp5-6.08.patch b/testsuite/external/camlp5-6.08.patch deleted file mode 100644 index 60d708d60c..0000000000 --- a/testsuite/external/camlp5-6.08.patch +++ /dev/null @@ -1,1127 +0,0 @@ ---- camlp5-6.06/ocaml_stuff/4.01.0/utils/warnings.mli.orig 2013-02-18 15:14:16.000000000 +0100 -+++ camlp5-6.06/ocaml_stuff/4.01.0/utils/warnings.mli 2013-02-18 15:14:31.000000000 +0100 -@@ -54,6 +54,10 @@ - | Unused_constructor of string * bool * bool (* 37 *) - | Unused_exception of string * bool (* 38 *) - | Unused_rec_flag (* 39 *) -+ | Name_out_of_scope of string list * bool (* 40 *) -+ | Ambiguous_name of string list * string list * bool (* 41 *) -+ | Disambiguated_name of string (* 42 *) -+ | Nonoptional_label of string (* 43 *) - ;; - - val parse_options : bool -> string -> unit;; -diff -N -r -u camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/.cvsignore camlp5-6.06/ocaml_stuff/4.00.2/parsing/.cvsignore ---- camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/.cvsignore 1970-01-01 01:00:00.000000000 +0100 -+++ camlp5-6.06/ocaml_stuff/4.00.2/parsing/.cvsignore 2013-03-06 14:44:56.000000000 +0100 -@@ -0,0 +1 @@ -+*.cm[oi] -diff -N -r -u camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/.depend camlp5-6.06/ocaml_stuff/4.00.2/parsing/.depend ---- camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/.depend 1970-01-01 01:00:00.000000000 +0100 -+++ camlp5-6.06/ocaml_stuff/4.00.2/parsing/.depend 2013-03-06 14:44:56.000000000 +0100 -@@ -0,0 +1,4 @@ -+asttypes.cmi : location.cmi -+location.cmi : ../utils/warnings.cmi -+longident.cmi : -+parsetree.cmi : longident.cmi location.cmi asttypes.cmi -diff -N -r -u camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/Makefile camlp5-6.06/ocaml_stuff/4.00.2/parsing/Makefile ---- camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/Makefile 1970-01-01 01:00:00.000000000 +0100 -+++ camlp5-6.06/ocaml_stuff/4.00.2/parsing/Makefile 2013-03-06 14:44:56.000000000 +0100 -@@ -0,0 +1,19 @@ -+# Id -+ -+FILES=asttypes.cmi location.cmi longident.cmi parsetree.cmi -+INCL=-I ../utils -+ -+all: $(FILES) -+ -+clean: -+ rm -f *.cmi -+ -+depend: -+ ocamldep $(INCL) *.ml* | sed -e 's/ *$$//' > .depend -+ -+.SUFFIXES: .mli .cmi -+ -+.mli.cmi: -+ $(OCAMLN)c $(INCL) -c $< -+ -+include .depend -diff -N -r -u camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/asttypes.mli camlp5-6.06/ocaml_stuff/4.00.2/parsing/asttypes.mli ---- camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/asttypes.mli 1970-01-01 01:00:00.000000000 +0100 -+++ camlp5-6.06/ocaml_stuff/4.00.2/parsing/asttypes.mli 2013-03-06 14:44:56.000000000 +0100 -@@ -0,0 +1,45 @@ -+(***********************************************************************) -+(* *) -+(* 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 Q Public License version 1.0. *) -+(* *) -+(***********************************************************************) -+ -+(* Id *) -+ -+(* Auxiliary a.s.t. types used by parsetree and typedtree. *) -+ -+type constant = -+ Const_int of int -+ | Const_char of char -+ | Const_string of string -+ | Const_float of string -+ | Const_int32 of int32 -+ | Const_int64 of int64 -+ | Const_nativeint of nativeint -+ -+type rec_flag = Nonrecursive | Recursive | Default -+ -+type direction_flag = Upto | Downto -+ -+type private_flag = Private | Public -+ -+type mutable_flag = Immutable | Mutable -+ -+type virtual_flag = Virtual | Concrete -+ -+type override_flag = Override | Fresh -+ -+type closed_flag = Closed | Open -+ -+type label = string -+ -+type 'a loc = 'a Location.loc = { -+ txt : 'a; -+ loc : Location.t; -+} -diff -N -r -u camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/location.mli camlp5-6.06/ocaml_stuff/4.00.2/parsing/location.mli ---- camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/location.mli 1970-01-01 01:00:00.000000000 +0100 -+++ camlp5-6.06/ocaml_stuff/4.00.2/parsing/location.mli 2013-03-06 14:44:56.000000000 +0100 -@@ -0,0 +1,80 @@ -+(***********************************************************************) -+(* *) -+(* 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 Q Public License version 1.0. *) -+(* *) -+(***********************************************************************) -+ -+(* Id *) -+ -+(* Source code locations (ranges of positions), used in parsetree. *) -+ -+open Format -+ -+type t = { -+ loc_start: Lexing.position; -+ loc_end: Lexing.position; -+ loc_ghost: bool; -+} -+ -+(* Note on the use of Lexing.position in this module. -+ If [pos_fname = ""], then use [!input_name] instead. -+ If [pos_lnum = -1], then [pos_bol = 0]. Use [pos_cnum] and -+ re-parse the file to get the line and character numbers. -+ Else all fields are correct. -+*) -+ -+val none : t -+(** An arbitrary value of type [t]; describes an empty ghost range. *) -+val in_file : string -> t;; -+(** Return an empty ghost range located in a given file. *) -+val init : Lexing.lexbuf -> string -> unit -+(** Set the file name and line number of the [lexbuf] to be the start -+ of the named file. *) -+val curr : Lexing.lexbuf -> t -+(** Get the location of the current token from the [lexbuf]. *) -+ -+val symbol_rloc: unit -> t -+val symbol_gloc: unit -> t -+ -+(** [rhs_loc n] returns the location of the symbol at position [n], starting -+ at 1, in the current parser rule. *) -+val rhs_loc: int -> t -+ -+val input_name: string ref -+val input_lexbuf: Lexing.lexbuf option ref -+ -+val get_pos_info: Lexing.position -> string * int * int (* file, line, char *) -+val print_loc: formatter -> t -> unit -+val print_error: formatter -> t -> unit -+val print_error_cur_file: formatter -> unit -+val print_warning: t -> formatter -> Warnings.t -> unit -+val prerr_warning: t -> Warnings.t -> unit -+val echo_eof: unit -> unit -+val reset: unit -> unit -+ -+val highlight_locations: formatter -> t -> t -> bool -+ -+type 'a loc = { -+ txt : 'a; -+ loc : t; -+} -+ -+val mknoloc : 'a -> 'a loc -+val mkloc : 'a -> t -> 'a loc -+ -+val print: formatter -> t -> unit -+val print_filename: formatter -> string -> unit -+ -+val show_filename: string -> string -+ (** In -absname mode, return the absolute path for this filename. -+ Otherwise, returns the filename unchanged. *) -+ -+ -+val absname: bool ref -+ -diff -N -r -u camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/longident.mli camlp5-6.06/ocaml_stuff/4.00.2/parsing/longident.mli ---- camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/longident.mli 1970-01-01 01:00:00.000000000 +0100 -+++ camlp5-6.06/ocaml_stuff/4.00.2/parsing/longident.mli 2013-03-06 14:44:56.000000000 +0100 -@@ -0,0 +1,24 @@ -+(***********************************************************************) -+(* *) -+(* 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 Q Public License version 1.0. *) -+(* *) -+(***********************************************************************) -+ -+(* Id *) -+ -+(* Long identifiers, used in parsetree. *) -+ -+type t = -+ Lident of string -+ | Ldot of t * string -+ | Lapply of t * t -+ -+val flatten: t -> string list -+val last: t -> string -+val parse: string -> t -diff -N -r -u camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/parsetree.mli camlp5-6.06/ocaml_stuff/4.00.2/parsing/parsetree.mli ---- camlp5-6.06.orig/ocaml_stuff/4.00.2/parsing/parsetree.mli 1970-01-01 01:00:00.000000000 +0100 -+++ camlp5-6.06/ocaml_stuff/4.00.2/parsing/parsetree.mli 2013-03-06 14:44:56.000000000 +0100 -@@ -0,0 +1,307 @@ -+(***********************************************************************) -+(* *) -+(* 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 Q Public License version 1.0. *) -+(* *) -+(***********************************************************************) -+ -+(* Id *) -+ -+(* Abstract syntax tree produced by parsing *) -+ -+open Asttypes -+ -+(* Type expressions for the core language *) -+ -+type core_type = -+ { ptyp_desc: core_type_desc; -+ ptyp_loc: Location.t } -+ -+and core_type_desc = -+ Ptyp_any -+ | Ptyp_var of string -+ | Ptyp_arrow of label * core_type * core_type -+ | Ptyp_tuple of core_type list -+ | Ptyp_constr of Longident.t loc * core_type list -+ | Ptyp_object of core_field_type list -+ | Ptyp_class of Longident.t loc * core_type list * label list -+ | Ptyp_alias of core_type * string -+ | Ptyp_variant of row_field list * bool * label list option -+ | Ptyp_poly of string list * core_type -+ | Ptyp_package of package_type -+ -+ -+and package_type = Longident.t loc * (Longident.t loc * core_type) list -+ -+and core_field_type = -+ { pfield_desc: core_field_desc; -+ pfield_loc: Location.t } -+ -+and core_field_desc = -+ Pfield of string * core_type -+ | Pfield_var -+ -+and row_field = -+ Rtag of label * bool * core_type list -+ | Rinherit of core_type -+ -+(* Type expressions for the class language *) -+ -+type 'a class_infos = -+ { pci_virt: virtual_flag; -+ pci_params: string loc list * Location.t; -+ pci_name: string loc; -+ pci_expr: 'a; -+ pci_variance: (bool * bool) list; -+ pci_loc: Location.t } -+ -+(* Value expressions for the core language *) -+ -+type pattern = -+ { ppat_desc: pattern_desc; -+ ppat_loc: Location.t } -+ -+and pattern_desc = -+ Ppat_any -+ | Ppat_var of string loc -+ | Ppat_alias of pattern * string loc -+ | Ppat_constant of constant -+ | Ppat_tuple of pattern list -+ | Ppat_construct of Longident.t loc * pattern option * bool -+ | Ppat_variant of label * pattern option -+ | Ppat_record of (Longident.t loc * pattern) list * closed_flag -+ | Ppat_array of pattern list -+ | Ppat_or of pattern * pattern -+ | Ppat_constraint of pattern * core_type -+ | Ppat_type of Longident.t loc -+ | Ppat_lazy of pattern -+ | Ppat_unpack of string loc -+ -+type expression = -+ { pexp_desc: expression_desc; -+ pexp_loc: Location.t } -+ -+and expression_desc = -+ Pexp_ident of Longident.t loc -+ | Pexp_constant of constant -+ | Pexp_let of rec_flag * (pattern * expression) list * expression -+ | Pexp_function of label * expression option * (pattern * expression) list -+ | Pexp_apply of expression * (label * expression) list -+ | Pexp_match of expression * (pattern * expression) list -+ | Pexp_try of expression * (pattern * expression) list -+ | Pexp_tuple of expression list -+ | Pexp_construct of Longident.t loc * expression option * bool -+ | Pexp_variant of label * expression option -+ | Pexp_record of (Longident.t loc * expression) list * expression option -+ | Pexp_field of expression * Longident.t loc -+ | Pexp_setfield of expression * Longident.t loc * expression -+ | Pexp_array of expression list -+ | Pexp_ifthenelse of expression * expression * expression option -+ | Pexp_sequence of expression * expression -+ | Pexp_while of expression * expression -+ | Pexp_for of string loc * expression * expression * direction_flag * expression -+ | Pexp_constraint of expression * core_type option * core_type option -+ | Pexp_when of expression * expression -+ | Pexp_send of expression * string -+ | Pexp_new of Longident.t loc -+ | Pexp_setinstvar of string loc * expression -+ | Pexp_override of (string loc * expression) list -+ | Pexp_letmodule of string loc * module_expr * expression -+ | Pexp_assert of expression -+ | Pexp_assertfalse -+ | Pexp_lazy of expression -+ | Pexp_poly of expression * core_type option -+ | Pexp_object of class_structure -+ | Pexp_newtype of string * expression -+ | Pexp_pack of module_expr -+ | Pexp_open of Longident.t loc * expression -+ -+(* Value descriptions *) -+ -+and value_description = -+ { pval_type: core_type; -+ pval_prim: string list; -+ pval_loc : Location.t -+ } -+ -+(* Type declarations *) -+ -+and type_declaration = -+ { ptype_params: string loc option list; -+ ptype_cstrs: (core_type * core_type * Location.t) list; -+ ptype_kind: type_kind; -+ ptype_private: private_flag; -+ ptype_manifest: core_type option; -+ ptype_variance: (bool * bool) list; -+ ptype_loc: Location.t } -+ -+and type_kind = -+ Ptype_abstract -+ | Ptype_variant of -+ (string loc * core_type list * core_type option * Location.t) list -+ | Ptype_record of -+ (string loc * mutable_flag * core_type * Location.t) list -+ -+and exception_declaration = core_type list -+ -+(* Type expressions for the class language *) -+ -+and class_type = -+ { pcty_desc: class_type_desc; -+ pcty_loc: Location.t } -+ -+and class_type_desc = -+ Pcty_constr of Longident.t loc * core_type list -+ | Pcty_signature of class_signature -+ | Pcty_fun of label * core_type * class_type -+ -+and class_signature = { -+ pcsig_self : core_type; -+ pcsig_fields : class_type_field list; -+ pcsig_loc : Location.t; -+ } -+ -+and class_type_field = { -+ pctf_desc : class_type_field_desc; -+ pctf_loc : Location.t; -+ } -+ -+and class_type_field_desc = -+ Pctf_inher of class_type -+ | Pctf_val of (string * mutable_flag * virtual_flag * core_type) -+ | Pctf_virt of (string * private_flag * core_type) -+ | Pctf_meth of (string * private_flag * core_type) -+ | Pctf_cstr of (core_type * core_type) -+ -+and class_description = class_type class_infos -+ -+and class_type_declaration = class_type class_infos -+ -+(* Value expressions for the class language *) -+ -+and class_expr = -+ { pcl_desc: class_expr_desc; -+ pcl_loc: Location.t } -+ -+and class_expr_desc = -+ Pcl_constr of Longident.t loc * core_type list -+ | Pcl_structure of class_structure -+ | Pcl_fun of label * expression option * pattern * class_expr -+ | Pcl_apply of class_expr * (label * expression) list -+ | Pcl_let of rec_flag * (pattern * expression) list * class_expr -+ | Pcl_constraint of class_expr * class_type -+ -+and class_structure = { -+ pcstr_pat : pattern; -+ pcstr_fields : class_field list; -+ } -+ -+and class_field = { -+ pcf_desc : class_field_desc; -+ pcf_loc : Location.t; -+ } -+ -+and class_field_desc = -+ Pcf_inher of override_flag * class_expr * string option -+ | Pcf_valvirt of (string loc * mutable_flag * core_type) -+ | Pcf_val of (string loc * mutable_flag * override_flag * expression) -+ | Pcf_virt of (string loc * private_flag * core_type) -+ | Pcf_meth of (string loc * private_flag *override_flag * expression) -+ | Pcf_constr of (core_type * core_type) -+ | Pcf_init of expression -+ -+and class_declaration = class_expr class_infos -+ -+(* Type expressions for the module language *) -+ -+and module_type = -+ { pmty_desc: module_type_desc; -+ pmty_loc: Location.t } -+ -+and module_type_desc = -+ Pmty_ident of Longident.t loc -+ | Pmty_signature of signature -+ | Pmty_functor of string loc * module_type * module_type -+ | Pmty_with of module_type * (Longident.t loc * with_constraint) list -+ | Pmty_typeof of module_expr -+ -+and signature = signature_item list -+ -+and signature_item = -+ { psig_desc: signature_item_desc; -+ psig_loc: Location.t } -+ -+and signature_item_desc = -+ Psig_value of string loc * value_description -+ | Psig_type of (string loc * type_declaration) list -+ | Psig_exception of string loc * exception_declaration -+ | Psig_module of string loc * module_type -+ | Psig_recmodule of (string loc * module_type) list -+ | Psig_modtype of string loc * modtype_declaration -+ | Psig_open of Longident.t loc -+ | Psig_include of module_type -+ | Psig_class of class_description list -+ | Psig_class_type of class_type_declaration list -+ -+and modtype_declaration = -+ Pmodtype_abstract -+ | Pmodtype_manifest of module_type -+ -+and with_constraint = -+ Pwith_type of type_declaration -+ | Pwith_module of Longident.t loc -+ | Pwith_typesubst of type_declaration -+ | Pwith_modsubst of Longident.t loc -+ -+(* Value expressions for the module language *) -+ -+and module_expr = -+ { pmod_desc: module_expr_desc; -+ pmod_loc: Location.t } -+ -+and module_expr_desc = -+ Pmod_ident of Longident.t loc -+ | Pmod_structure of structure -+ | Pmod_functor of string loc * module_type * module_expr -+ | Pmod_apply of module_expr * module_expr -+ | Pmod_constraint of module_expr * module_type -+ | Pmod_unpack of expression -+ -+and structure = structure_item list -+ -+and structure_item = -+ { pstr_desc: structure_item_desc; -+ pstr_loc: Location.t } -+ -+and structure_item_desc = -+ Pstr_eval of expression -+ | Pstr_value of rec_flag * (pattern * expression) list -+ | Pstr_primitive of string loc * value_description -+ | Pstr_type of (string loc * type_declaration) list -+ | Pstr_exception of string loc * exception_declaration -+ | Pstr_exn_rebind of string loc * Longident.t loc -+ | Pstr_module of string loc * module_expr -+ | Pstr_recmodule of (string loc * module_type * module_expr) list -+ | Pstr_modtype of string loc * module_type -+ | Pstr_open of Longident.t loc -+ | Pstr_class of class_declaration list -+ | Pstr_class_type of class_type_declaration list -+ | Pstr_include of module_expr -+ -+(* Toplevel phrases *) -+ -+type toplevel_phrase = -+ Ptop_def of structure -+ | Ptop_dir of string * directive_argument -+ -+and directive_argument = -+ Pdir_none -+ | Pdir_string of string -+ | Pdir_int of int -+ | Pdir_ident of Longident.t -+ | Pdir_bool of bool -diff -N -r -u camlp5-6.06.orig/ocaml_stuff/4.00.2/utils/.cvsignore camlp5-6.06/ocaml_stuff/4.00.2/utils/.cvsignore ---- camlp5-6.06.orig/ocaml_stuff/4.00.2/utils/.cvsignore 1970-01-01 01:00:00.000000000 +0100 -+++ camlp5-6.06/ocaml_stuff/4.00.2/utils/.cvsignore 2013-03-06 14:44:56.000000000 +0100 -@@ -0,0 +1 @@ -+*.cm[oix] -diff -N -r -u camlp5-6.06.orig/ocaml_stuff/4.00.2/utils/.depend camlp5-6.06/ocaml_stuff/4.00.2/utils/.depend ---- camlp5-6.06.orig/ocaml_stuff/4.00.2/utils/.depend 1970-01-01 01:00:00.000000000 +0100 -+++ camlp5-6.06/ocaml_stuff/4.00.2/utils/.depend 2013-03-06 14:44:56.000000000 +0100 -@@ -0,0 +1,2 @@ -+pconfig.cmo: pconfig.cmi -+pconfig.cmx: pconfig.cmi -diff -N -r -u camlp5-6.06.orig/ocaml_stuff/4.00.2/utils/Makefile camlp5-6.06/ocaml_stuff/4.00.2/utils/Makefile ---- camlp5-6.06.orig/ocaml_stuff/4.00.2/utils/Makefile 1970-01-01 01:00:00.000000000 +0100 -+++ camlp5-6.06/ocaml_stuff/4.00.2/utils/Makefile 2013-03-06 14:44:56.000000000 +0100 -@@ -0,0 +1,27 @@ -+# Id -+ -+FILES=warnings.cmi pconfig.cmo -+INCL= -+ -+all: $(FILES) -+ -+opt: pconfig.cmx -+ -+clean: -+ rm -f *.cm[oix] *.o -+ -+depend: -+ ocamldep $(INCL) *.ml* | sed -e 's/ *$$//' > .depend -+ -+.SUFFIXES: .mli .cmi .ml .cmo .cmx -+ -+.mli.cmi: -+ $(OCAMLN)c $(INCL) -c $< -+ -+.ml.cmo: -+ $(OCAMLN)c $(INCL) -c $< -+ -+.ml.cmx: -+ $(OCAMLN)opt $(INCL) -c $< -+ -+include .depend -diff -N -r -u camlp5-6.06.orig/ocaml_stuff/4.00.2/utils/pconfig.ml camlp5-6.06/ocaml_stuff/4.00.2/utils/pconfig.ml ---- camlp5-6.06.orig/ocaml_stuff/4.00.2/utils/pconfig.ml 1970-01-01 01:00:00.000000000 +0100 -+++ camlp5-6.06/ocaml_stuff/4.00.2/utils/pconfig.ml 2013-03-06 14:44:56.000000000 +0100 -@@ -0,0 +1,4 @@ -+let ocaml_version = "4.00.2" -+let ocaml_name = "ocaml" -+let ast_impl_magic_number = "Caml1999M015" -+let ast_intf_magic_number = "Caml1999N014" -diff -N -r -u camlp5-6.06.orig/ocaml_stuff/4.00.2/utils/pconfig.mli camlp5-6.06/ocaml_stuff/4.00.2/utils/pconfig.mli ---- camlp5-6.06.orig/ocaml_stuff/4.00.2/utils/pconfig.mli 1970-01-01 01:00:00.000000000 +0100 -+++ camlp5-6.06/ocaml_stuff/4.00.2/utils/pconfig.mli 2013-03-06 14:44:56.000000000 +0100 -@@ -0,0 +1,4 @@ -+val ocaml_version : string -+val ocaml_name : string -+val ast_impl_magic_number : string -+val ast_intf_magic_number : string -diff -N -r -u camlp5-6.06.orig/ocaml_stuff/4.00.2/utils/warnings.mli camlp5-6.06/ocaml_stuff/4.00.2/utils/warnings.mli ---- camlp5-6.06.orig/ocaml_stuff/4.00.2/utils/warnings.mli 1970-01-01 01:00:00.000000000 +0100 -+++ camlp5-6.06/ocaml_stuff/4.00.2/utils/warnings.mli 2013-03-06 14:44:56.000000000 +0100 -@@ -0,0 +1,75 @@ -+(***********************************************************************) -+(* *) -+(* OCaml *) -+(* *) -+(* Pierre Weis && Damien Doligez, INRIA Rocquencourt *) -+(* *) -+(* Copyright 1998 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 *) -+ -+open Format -+ -+type t = -+ | Comment_start (* 1 *) -+ | Comment_not_end (* 2 *) -+ | Deprecated (* 3 *) -+ | Fragile_match of string (* 4 *) -+ | Partial_application (* 5 *) -+ | Labels_omitted (* 6 *) -+ | Method_override of string list (* 7 *) -+ | Partial_match of string (* 8 *) -+ | Non_closed_record_pattern of string (* 9 *) -+ | Statement_type (* 10 *) -+ | Unused_match (* 11 *) -+ | Unused_pat (* 12 *) -+ | Instance_variable_override of string list (* 13 *) -+ | Illegal_backslash (* 14 *) -+ | Implicit_public_methods of string list (* 15 *) -+ | Unerasable_optional_argument (* 16 *) -+ | Undeclared_virtual_method of string (* 17 *) -+ | Not_principal of string (* 18 *) -+ | Without_principality of string (* 19 *) -+ | Unused_argument (* 20 *) -+ | Nonreturning_statement (* 21 *) -+ | Camlp4 of string (* 22 *) -+ | Useless_record_with (* 23 *) -+ | Bad_module_name of string (* 24 *) -+ | All_clauses_guarded (* 25 *) -+ | Unused_var of string (* 26 *) -+ | Unused_var_strict of string (* 27 *) -+ | Wildcard_arg_to_constant_constr (* 28 *) -+ | Eol_in_string (* 29 *) -+ | Duplicate_definitions of string * string * string * string (*30 *) -+ | Multiple_definition of string * string * string (* 31 *) -+ | Unused_value_declaration of string (* 32 *) -+ | Unused_open of string (* 33 *) -+ | Unused_type_declaration of string (* 34 *) -+ | 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_rec_flag (* 39 *) -+;; -+ -+val parse_options : bool -> string -> unit;; -+ -+val is_active : t -> bool;; -+val is_error : t -> bool;; -+ -+val defaults_w : string;; -+val defaults_warn_error : string;; -+ -+val print : formatter -> t -> int;; -+ (* returns the number of newlines in the printed string *) -+ -+ -+exception Errors of int;; -+ -+val check_fatal : unit -> unit;; -+ -+val help_warnings: unit -> unit -diff -r -u -N camlp5-6.06.orig/ocaml_src/lib/versdep/4.00.2.ml camlp5-6.06/ocaml_src/lib/versdep/4.00.2.ml ---- camlp5-6.06.orig/ocaml_src/lib/versdep/4.00.2.ml 1970-01-01 01:00:00.000000000 +0100 -+++ camlp5-6.06/ocaml_src/lib/versdep/4.00.2.ml 2012-07-31 16:52:22.000000000 +0200 -@@ -0,0 +1,465 @@ -+(* camlp5r pa_macro.cmo *) -+(* File generated by program: edit only if it does not compile. *) -+(* Copyright (c) INRIA 2007-2012 *) -+ -+open Parsetree;; -+open Longident;; -+open Asttypes;; -+ -+type ('a, 'b) choice = -+ Left of 'a -+ | Right of 'b -+;; -+ -+let sys_ocaml_version = Sys.ocaml_version;; -+ -+let ocaml_location (fname, lnum, bolp, lnuml, bolpl, bp, ep) = -+ let loc_at n lnum bolp = -+ {Lexing.pos_fname = if lnum = -1 then "" else fname; -+ Lexing.pos_lnum = lnum; Lexing.pos_bol = bolp; Lexing.pos_cnum = n} -+ in -+ {Location.loc_start = loc_at bp lnum bolp; -+ Location.loc_end = loc_at ep lnuml bolpl; -+ Location.loc_ghost = bp = 0 && ep = 0} -+;; -+ -+let loc_none = -+ let loc = -+ {Lexing.pos_fname = "_none_"; Lexing.pos_lnum = 1; Lexing.pos_bol = 0; -+ Lexing.pos_cnum = -1} -+ in -+ {Location.loc_start = loc; Location.loc_end = loc; -+ Location.loc_ghost = true} -+;; -+ -+let mkloc loc txt = {Location.txt = txt; Location.loc = loc};; -+let mknoloc txt = mkloc loc_none txt;; -+ -+let ocaml_id_or_li_of_string_list loc sl = -+ let mkli s = -+ let rec loop f = -+ function -+ i :: il -> loop (fun s -> Ldot (f i, s)) il -+ | [] -> f s -+ in -+ loop (fun s -> Lident s) -+ in -+ match List.rev sl with -+ [] -> None -+ | s :: sl -> Some (mkli s (List.rev sl)) -+;; -+ -+let list_map_check f l = -+ let rec loop rev_l = -+ function -+ x :: l -> -+ begin match f x with -+ Some s -> loop (s :: rev_l) l -+ | None -> None -+ end -+ | [] -> Some (List.rev rev_l) -+ in -+ loop [] l -+;; -+ -+let ocaml_value_description t p = -+ {pval_type = t; pval_prim = p; pval_loc = t.ptyp_loc} -+;; -+ -+let ocaml_class_type_field loc ctfd = {pctf_desc = ctfd; pctf_loc = loc};; -+ -+let ocaml_class_field loc cfd = {pcf_desc = cfd; pcf_loc = loc};; -+ -+let ocaml_type_declaration params cl tk pf tm loc variance = -+ match list_map_check (fun s_opt -> s_opt) params with -+ Some params -> -+ let params = List.map (fun os -> Some (mknoloc os)) params in -+ Right -+ {ptype_params = params; ptype_cstrs = cl; ptype_kind = tk; -+ ptype_private = pf; ptype_manifest = tm; ptype_loc = loc; -+ ptype_variance = variance} -+ | None -> Left "no '_' type param in this ocaml version" -+;; -+ -+let ocaml_class_type = Some (fun d loc -> {pcty_desc = d; pcty_loc = loc});; -+ -+let ocaml_class_expr = Some (fun d loc -> {pcl_desc = d; pcl_loc = loc});; -+ -+let ocaml_class_structure p cil = {pcstr_pat = p; pcstr_fields = cil};; -+ -+let ocaml_pmty_ident loc li = Pmty_ident (mkloc loc li);; -+ -+let ocaml_pmty_functor sloc s mt1 mt2 = -+ Pmty_functor (mkloc sloc s, mt1, mt2) -+;; -+ -+let ocaml_pmty_typeof = Some (fun me -> Pmty_typeof me);; -+ -+let ocaml_pmty_with mt lcl = -+ let lcl = List.map (fun (s, c) -> mknoloc s, c) lcl in Pmty_with (mt, lcl) -+;; -+ -+let ocaml_ptype_abstract = Ptype_abstract;; -+ -+let ocaml_ptype_record ltl priv = -+ Ptype_record -+ (List.map (fun (s, mf, ct, loc) -> mkloc loc s, mf, ct, loc) ltl) -+;; -+ -+let ocaml_ptype_variant ctl priv = -+ try -+ let ctl = -+ List.map -+ (fun (c, tl, rto, loc) -> -+ if rto <> None then raise Exit else mknoloc c, tl, None, loc) -+ ctl -+ in -+ Some (Ptype_variant ctl) -+ with Exit -> None -+;; -+ -+let ocaml_ptyp_arrow lab t1 t2 = Ptyp_arrow (lab, t1, t2);; -+ -+let ocaml_ptyp_class li tl ll = Ptyp_class (mknoloc li, tl, ll);; -+ -+let ocaml_ptyp_constr li tl = Ptyp_constr (mknoloc li, tl);; -+ -+let ocaml_ptyp_package = Some (fun pt -> Ptyp_package pt);; -+ -+let ocaml_ptyp_poly = Some (fun cl t -> Ptyp_poly (cl, t));; -+ -+let ocaml_ptyp_variant catl clos sl_opt = -+ let catl = -+ List.map -+ (function -+ Left (c, a, tl) -> Rtag (c, a, tl) -+ | Right t -> Rinherit t) -+ catl -+ in -+ Some (Ptyp_variant (catl, clos, sl_opt)) -+;; -+ -+let ocaml_package_type li ltl = -+ mknoloc li, List.map (fun (li, t) -> mkloc t.ptyp_loc li, t) ltl -+;; -+ -+let ocaml_const_int32 = Some (fun s -> Const_int32 (Int32.of_string s));; -+ -+let ocaml_const_int64 = Some (fun s -> Const_int64 (Int64.of_string s));; -+ -+let ocaml_const_nativeint = -+ Some (fun s -> Const_nativeint (Nativeint.of_string s)) -+;; -+ -+let ocaml_pexp_apply f lel = Pexp_apply (f, lel);; -+ -+let ocaml_pexp_assertfalse fname loc = Pexp_assertfalse;; -+ -+let ocaml_pexp_assert fname loc e = Pexp_assert e;; -+ -+let ocaml_pexp_construct li po chk_arity = -+ Pexp_construct (mknoloc li, po, chk_arity) -+;; -+ -+let ocaml_pexp_field e li = Pexp_field (e, mknoloc li);; -+ -+let ocaml_pexp_for i e1 e2 df e = Pexp_for (mknoloc i, e1, e2, df, e);; -+ -+let ocaml_pexp_function lab eo pel = Pexp_function (lab, eo, pel);; -+ -+let ocaml_pexp_lazy = Some (fun e -> Pexp_lazy e);; -+ -+let ocaml_pexp_ident li = Pexp_ident (mknoloc li);; -+ -+let ocaml_pexp_letmodule = -+ Some (fun i me e -> Pexp_letmodule (mknoloc i, me, e)) -+;; -+ -+let ocaml_pexp_new loc li = Pexp_new (mkloc loc li);; -+ -+let ocaml_pexp_newtype = Some (fun s e -> Pexp_newtype (s, e));; -+ -+let ocaml_pexp_object = Some (fun cs -> Pexp_object cs);; -+ -+let ocaml_pexp_open = Some (fun li e -> Pexp_open (mknoloc li, e));; -+ -+let ocaml_pexp_override sel = -+ let sel = List.map (fun (s, e) -> mknoloc s, e) sel in Pexp_override sel -+;; -+ -+let ocaml_pexp_pack : ('a -> 'b -> 'c, 'd) choice option = -+ Some (Right ((fun me -> Pexp_pack me), (fun pt -> Ptyp_package pt))) -+;; -+ -+let ocaml_pexp_poly = Some (fun e t -> Pexp_poly (e, t));; -+ -+let ocaml_pexp_record lel eo = -+ let lel = List.map (fun (li, loc, e) -> mkloc loc li, e) lel in -+ Pexp_record (lel, eo) -+;; -+ -+let ocaml_pexp_setinstvar s e = Pexp_setinstvar (mknoloc s, e);; -+ -+let ocaml_pexp_variant = -+ let pexp_variant_pat = -+ function -+ Pexp_variant (lab, eo) -> Some (lab, eo) -+ | _ -> None -+ in -+ let pexp_variant (lab, eo) = Pexp_variant (lab, eo) in -+ Some (pexp_variant_pat, pexp_variant) -+;; -+ -+let ocaml_ppat_alias p i iloc = Ppat_alias (p, mkloc iloc i);; -+ -+let ocaml_ppat_array = Some (fun pl -> Ppat_array pl);; -+ -+let ocaml_ppat_construct li li_loc po chk_arity = -+ Ppat_construct (mkloc li_loc li, po, chk_arity) -+;; -+ -+let ocaml_ppat_construct_args = -+ function -+ Ppat_construct (li, po, chk_arity) -> Some (li.txt, li.loc, po, chk_arity) -+ | _ -> None -+;; -+ -+let ocaml_ppat_lazy = Some (fun p -> Ppat_lazy p);; -+ -+let ocaml_ppat_record lpl is_closed = -+ let lpl = List.map (fun (li, loc, p) -> mkloc loc li, p) lpl in -+ Ppat_record (lpl, (if is_closed then Closed else Open)) -+;; -+ -+let ocaml_ppat_type = Some (fun loc li -> Ppat_type (mkloc loc li));; -+ -+let ocaml_ppat_unpack = -+ Some ((fun loc s -> Ppat_unpack (mkloc loc s)), (fun pt -> Ptyp_package pt)) -+;; -+ -+let ocaml_ppat_var loc s = Ppat_var (mkloc loc s);; -+ -+let ocaml_ppat_variant = -+ let ppat_variant_pat = -+ function -+ Ppat_variant (lab, po) -> Some (lab, po) -+ | _ -> None -+ in -+ let ppat_variant (lab, po) = Ppat_variant (lab, po) in -+ Some (ppat_variant_pat, ppat_variant) -+;; -+ -+let ocaml_psig_class_type = Some (fun ctl -> Psig_class_type ctl);; -+ -+let ocaml_psig_exception s ed = Psig_exception (mknoloc s, ed);; -+ -+let ocaml_psig_module s mt = Psig_module (mknoloc s, mt);; -+ -+let ocaml_psig_modtype s mtd = Psig_modtype (mknoloc s, mtd);; -+ -+let ocaml_psig_open li = Psig_open (mknoloc li);; -+ -+let ocaml_psig_recmodule = -+ let f ntl = -+ let ntl = List.map (fun (s, mt) -> mknoloc s, mt) ntl in -+ Psig_recmodule ntl -+ in -+ Some f -+;; -+ -+let ocaml_psig_type stl = -+ let stl = List.map (fun (s, t) -> mknoloc s, t) stl in Psig_type stl -+;; -+ -+let ocaml_psig_value s vd = Psig_value (mknoloc s, vd);; -+ -+let ocaml_pstr_class_type = Some (fun ctl -> Pstr_class_type ctl);; -+ -+let ocaml_pstr_exception s ed = Pstr_exception (mknoloc s, ed);; -+ -+let ocaml_pstr_exn_rebind = -+ Some (fun s li -> Pstr_exn_rebind (mknoloc s, mknoloc li)) -+;; -+ -+let ocaml_pstr_include = Some (fun me -> Pstr_include me);; -+ -+let ocaml_pstr_modtype s mt = Pstr_modtype (mknoloc s, mt);; -+ -+let ocaml_pstr_module s me = Pstr_module (mknoloc s, me);; -+ -+let ocaml_pstr_open li = Pstr_open (mknoloc li);; -+ -+let ocaml_pstr_primitive s vd = Pstr_primitive (mknoloc s, vd);; -+ -+let ocaml_pstr_recmodule = -+ let f nel = -+ Pstr_recmodule (List.map (fun (s, mt, me) -> mknoloc s, mt, me) nel) -+ in -+ Some f -+;; -+ -+let ocaml_pstr_type stl = -+ let stl = List.map (fun (s, t) -> mknoloc s, t) stl in Pstr_type stl -+;; -+ -+let ocaml_class_infos = -+ Some -+ (fun virt (sl, sloc) name expr loc variance -> -+ let params = List.map (fun s -> mkloc loc s) sl, sloc in -+ {pci_virt = virt; pci_params = params; pci_name = mkloc loc name; -+ pci_expr = expr; pci_loc = loc; pci_variance = variance}) -+;; -+ -+let ocaml_pmod_ident li = Pmod_ident (mknoloc li);; -+ -+let ocaml_pmod_functor s mt me = Pmod_functor (mknoloc s, mt, me);; -+ -+let ocaml_pmod_unpack : ('a -> 'b -> 'c, 'd) choice option = -+ Some (Right ((fun e -> Pmod_unpack e), (fun pt -> Ptyp_package pt))) -+;; -+ -+let ocaml_pcf_cstr = Some (fun (t1, t2, loc) -> Pcf_constr (t1, t2));; -+ -+let ocaml_pcf_inher ce pb = Pcf_inher (Fresh, ce, pb);; -+ -+let ocaml_pcf_init = Some (fun e -> Pcf_init e);; -+ -+let ocaml_pcf_meth (s, pf, ovf, e, loc) = -+ let pf = if pf then Private else Public in -+ let ovf = if ovf then Override else Fresh in -+ Pcf_meth (mkloc loc s, pf, ovf, e) -+;; -+ -+let ocaml_pcf_val (s, mf, ovf, e, loc) = -+ let mf = if mf then Mutable else Immutable in -+ let ovf = if ovf then Override else Fresh in -+ Pcf_val (mkloc loc s, mf, ovf, e) -+;; -+ -+let ocaml_pcf_valvirt = -+ let ocaml_pcf (s, mf, t, loc) = -+ let mf = if mf then Mutable else Immutable in -+ Pcf_valvirt (mkloc loc s, mf, t) -+ in -+ Some ocaml_pcf -+;; -+ -+let ocaml_pcf_virt (s, pf, t, loc) = Pcf_virt (mkloc loc s, pf, t);; -+ -+let ocaml_pcl_apply = Some (fun ce lel -> Pcl_apply (ce, lel));; -+ -+let ocaml_pcl_constr = Some (fun li ctl -> Pcl_constr (mknoloc li, ctl));; -+ -+let ocaml_pcl_constraint = Some (fun ce ct -> Pcl_constraint (ce, ct));; -+ -+let ocaml_pcl_fun = Some (fun lab ceo p ce -> Pcl_fun (lab, ceo, p, ce));; -+ -+let ocaml_pcl_let = Some (fun rf pel ce -> Pcl_let (rf, pel, ce));; -+ -+let ocaml_pcl_structure = Some (fun cs -> Pcl_structure cs);; -+ -+let ocaml_pctf_cstr = Some (fun (t1, t2, loc) -> Pctf_cstr (t1, t2));; -+ -+let ocaml_pctf_meth (s, pf, t, loc) = Pctf_meth (s, pf, t);; -+ -+let ocaml_pctf_val (s, mf, t, loc) = Pctf_val (s, mf, Concrete, t);; -+ -+let ocaml_pctf_virt (s, pf, t, loc) = Pctf_virt (s, pf, t);; -+ -+let ocaml_pcty_constr = Some (fun li ltl -> Pcty_constr (mknoloc li, ltl));; -+ -+let ocaml_pcty_fun = Some (fun lab t ct -> Pcty_fun (lab, t, ct));; -+ -+let ocaml_pcty_signature = -+ let f (t, ctfl) = -+ let cs = {pcsig_self = t; pcsig_fields = ctfl; pcsig_loc = t.ptyp_loc} in -+ Pcty_signature cs -+ in -+ Some f -+;; -+ -+let ocaml_pdir_bool = Some (fun b -> Pdir_bool b);; -+ -+let ocaml_pwith_modsubst = -+ Some (fun loc me -> Pwith_modsubst (mkloc loc me)) -+;; -+ -+let ocaml_pwith_module loc me = Pwith_module (mkloc loc me);; -+ -+let ocaml_pwith_typesubst = Some (fun td -> Pwith_typesubst td);; -+ -+let module_prefix_can_be_in_first_record_label_only = true;; -+ -+let split_or_patterns_with_bindings = false;; -+ -+let has_records_with_with = true;; -+ -+(* *) -+ -+let jocaml_pstr_def : (_ -> _) option = None;; -+ -+let jocaml_pexp_def : (_ -> _ -> _) option = None;; -+ -+let jocaml_pexp_par : (_ -> _ -> _) option = None;; -+ -+let jocaml_pexp_reply : (_ -> _ -> _ -> _) option = None;; -+ -+let jocaml_pexp_spawn : (_ -> _) option = None;; -+ -+let arg_rest = -+ function -+ Arg.Rest r -> Some r -+ | _ -> None -+;; -+ -+let arg_set_string = -+ function -+ Arg.Set_string r -> Some r -+ | _ -> None -+;; -+ -+let arg_set_int = -+ function -+ Arg.Set_int r -> Some r -+ | _ -> None -+;; -+ -+let arg_set_float = -+ function -+ Arg.Set_float r -> Some r -+ | _ -> None -+;; -+ -+let arg_symbol = -+ function -+ Arg.Symbol (s, f) -> Some (s, f) -+ | _ -> None -+;; -+ -+let arg_tuple = -+ function -+ Arg.Tuple t -> Some t -+ | _ -> None -+;; -+ -+let arg_bool = -+ function -+ Arg.Bool f -> Some f -+ | _ -> None -+;; -+ -+let char_escaped = Char.escaped;; -+ -+let hashtbl_mem = Hashtbl.mem;; -+ -+let list_rev_append = List.rev_append;; -+ -+let list_rev_map = List.rev_map;; -+ -+let list_sort = List.sort;; -+ -+let pervasives_set_binary_mode_out = Pervasives.set_binary_mode_out;; -+ -+let printf_ksprintf = Printf.ksprintf;; -+ -+let string_contains = String.contains;; diff --git a/testsuite/external/camlp5-6.10.patch b/testsuite/external/camlp5-6.10.patch deleted file mode 100644 index eeaf4c41b3..0000000000 --- a/testsuite/external/camlp5-6.10.patch +++ /dev/null @@ -1,10 +0,0 @@ ---- camlp5-6.10.orig/ocaml_stuff/4.01.0/utils/warnings.mli 2013-06-19 04:17:42.000000000 +0200 -+++ camlp5-6.10/ocaml_stuff/4.01.0/utils/warnings.mli 2013-08-13 16:14:47.000000000 +0200 -@@ -58,6 +58,7 @@ - | Nonoptional_label of string (* 43 *) - | Open_shadow_identifier of string * string (* 44 *) - | Open_shadow_label_constructor of string * string (* 45 *) -+ | Bad_env_variable of string * string - ;; - - val parse_options : bool -> string -> unit;; diff --git a/testsuite/external/camlp5-git.patch b/testsuite/external/camlp5-git.patch deleted file mode 100644 index 8ea012cc5c..0000000000 --- a/testsuite/external/camlp5-git.patch +++ /dev/null @@ -1,12 +0,0 @@ -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/external/camlpdf-0.5.patch b/testsuite/external/camlpdf-0.5.patch deleted file mode 100644 index e13ac33997..0000000000 --- a/testsuite/external/camlpdf-0.5.patch +++ /dev/null @@ -1,25 +0,0 @@ ---- camlpdf-0.5.orig/makefile 2010-03-08 17:30:19.000000000 +0100 -+++ camlpdf-0.5/makefile 2013-05-30 17:07:12.000000000 +0200 -@@ -42,7 +42,7 @@ - - CLIBS = z - --CFLAGS = -m32 -+#CFLAGS = -m32 - - #Uncomment for debug build - #OCAMLNCFLAGS = -g -@@ -56,6 +56,13 @@ - #Remove native-code-library if you don't have native compilers - all : byte-code-library native-code-library - -+LIBDIR="`ocamlc -where`"/camlpdf -+.PHONY: install -+install : -+ mkdir -p ${LIBDIR} -+ cp *.mli *.cm[ia] *.cmxa *.a *.so ${LIBDIR}/ -+ cp introduction_to_camlpdf.pdf ${LIBDIR}/ -+ - # Predefined generic makefile - -include OCamlMakefile - diff --git a/testsuite/external/camlzip-1.04.patch b/testsuite/external/camlzip-1.04.patch deleted file mode 100644 index f49bc6a0a0..0000000000 --- a/testsuite/external/camlzip-1.04.patch +++ /dev/null @@ -1,45 +0,0 @@ ---- camlzip-1.04/Makefile 2009-10-20 15:59:55.000000000 +0200 -+++ camlzip-1.04/Makefile.new 2009-10-20 16:00:31.000000000 +0200 -@@ -4,10 +4,10 @@ - ZLIB_LIB=-lz - - # The directory containing the Zlib library (libz.a or libz.so) --ZLIB_LIBDIR=/usr/local/lib -+ZLIB_LIBDIR=/opt/local/lib - - # The directory containing the Zlib header file (zlib.h) --ZLIB_INCLUDE=/usr/local/include -+ZLIB_INCLUDE=/opt/local/include - - # Where to install the library. By default: sub-directory 'zip' of - # OCaml's standard library directory. ---- /dev/null 2009-10-20 16:35:40.000000000 +0200 -+++ camlzip-1.04/META 2009-10-20 16:37:31.000000000 +0200 -@@ -0,0 +1,6 @@ -+name = "camlzip" -+version = "1.04" -+description = "compression library" -+archive(byte) = "zip.cma" -+archive(native) = "zip.cmxa" -+directory = "+zip" ---- camlzip-1.04/Makefile.orig 2011-07-04 18:09:00.000000000 +0200 -+++ camlzip-1.04/Makefile 2011-07-04 18:10:09.000000000 +0200 -@@ -56,7 +56,8 @@ - - install: - mkdir -p $(INSTALLDIR) -- cp zip.cma zip.cmi gzip.cmi zip.mli gzip.mli libcamlzip.a $(INSTALLDIR) -+ cp zip.cma zip.cmi gzip.cmi zlib.cmi zip.mli gzip.mli zlib.mli \ -+ libcamlzip.a $(INSTALLDIR) - if test -f dllcamlzip.so; then \ - cp dllcamlzip.so $(INSTALLDIR); \ - ldconf=`$(OCAMLC) -where`/ld.conf; \ -@@ -66,7 +67,7 @@ - fi - - installopt: -- cp zip.cmxa zip.a zip.cmx gzip.cmx $(INSTALLDIR) -+ cp zip.cmxa zip.a zip.cmx gzip.cmx zlib.cmx $(INSTALLDIR) - - depend: - gcc -MM -I$(ZLIB_INCLUDE) *.c > .depend diff --git a/testsuite/external/coq-8.3pl4.patch b/testsuite/external/coq-8.3pl4.patch deleted file mode 100644 index 310510a501..0000000000 --- a/testsuite/external/coq-8.3pl4.patch +++ /dev/null @@ -1,59 +0,0 @@ ---- coq-8.3pl4.orig/configure 2011-12-19 22:57:30.000000000 +0100 -+++ coq-8.3pl4/configure 2012-03-16 11:44:55.000000000 +0100 -@@ -444,7 +444,7 @@ - - if [ "$coq_debug_flag" = "-g" ]; then - case $CAMLTAG in -- OCAML31*) -+ OCAML31*|OCAML4*) - # Compilation debug flag - coq_debug_flag_opt="-g" - ;; -@@ -494,7 +494,7 @@ - camlp4oexec=`echo $camlp4oexec | sed -e 's/4/5/'` - else - case $CAMLTAG in -- OCAML31*) -+ OCAML31*|OCAML4*) - if [ -x "${CAMLLIB}/camlp5" ]; then - CAMLP4LIB=+camlp5 - elif [ -x "${CAMLLIB}/site-lib/camlp5" ]; then -@@ -538,7 +538,7 @@ - CAMLOPTVERSION=`"$nativecamlc" -v | sed -n -e 's|.*version* *\(.*\)$|\1|p' ` - if [ "`uname -s`" = "Darwin" -a "$ARCH" = "i386" ]; then - case $CAMLOPTVERSION in -- 3.09.3|3.1?*) ;; -+ 3.09.3|3.1?*|4.*) ;; - *) echo "Native compilation on MacOS X Pentium requires Objective-Caml >= 3.09.3," - best_compiler=byte - echo "only the bytecode version of Coq will be available." ---- coq-8.3pl4/scripts/coqmktop.ml.orig 2012-05-26 21:32:12.000000000 +0200 -+++ coq-8.3pl4/scripts/coqmktop.ml 2012-05-26 21:36:35.000000000 +0200 -@@ -63,6 +63,7 @@ - (src_dirs ()) - (["-I"; "\"" ^ camlp4lib ^ "\""] @ - ["-I"; "\"" ^ coqlib ^ "\""] @ -+ ["-I"; "+compiler-libs"] @ - (if !coqide then ["-thread"; "-I"; "+lablgtk2"] else [])) - - (* Transform bytecode object file names in native object file names *) -@@ -274,7 +275,7 @@ - ocamloptexec^" -linkall" - end else - (* bytecode (we shunt ocamlmktop script which fails on win32) *) -- let ocamlmktoplib = " toplevellib.cma" in -+ let ocamlmktoplib = " ocamlcommon.cma ocamlbytecomp.cma ocamltoplevel.cma" in - let ocamlcexec = Filename.concat camlbin "ocamlc" in - let ocamlccustom = Printf.sprintf "%s %s -linkall " - ocamlcexec Coq_config.coqrunbyteflags in ---- coq-8.3pl4/configure.orig 2012-07-18 11:31:08.353180800 +0200 -+++ coq-8.3pl4/configure 2012-07-18 11:31:10.346046400 +0200 -@@ -272,7 +272,7 @@ - no) - # First we test if we are running a Cygwin system - if [ `uname -s | cut -c -6` = "CYGWIN" ] ; then -- ARCH="win32" -+ ARCH=`uname -s` - else - # If not, we determine the architecture - if test -x /bin/arch ; then diff --git a/testsuite/external/coq-8.4pl1.patch b/testsuite/external/coq-8.4pl1.patch deleted file mode 100644 index 058038282a..0000000000 --- a/testsuite/external/coq-8.4pl1.patch +++ /dev/null @@ -1,11 +0,0 @@ ---- coq-8.4pl1/kernel/univ.ml.orig 2013-11-27 15:53:01.000000000 +0100 -+++ coq-8.4pl1/kernel/univ.ml 2013-11-27 15:53:20.000000000 +0100 -@@ -226,7 +226,7 @@ - - - (* between : UniverseLevel.t -> canonical_arc -> canonical_arc list *) --(* between u v = {w|u<=w<=v, w canonical} *) -+(* between u v = {w |u<=w<=v, w canonical} *) - (* between is the most costly operation *) - - let between g arcu arcv = diff --git a/testsuite/external/coq-8.4pl2.patch b/testsuite/external/coq-8.4pl2.patch deleted file mode 100644 index 50a94edb47..0000000000 --- a/testsuite/external/coq-8.4pl2.patch +++ /dev/null @@ -1,11 +0,0 @@ ---- coq-8.4pl2/kernel/univ.ml.orig 2013-11-27 15:53:01.000000000 +0100 -+++ coq-8.4pl2/kernel/univ.ml 2013-11-27 15:53:20.000000000 +0100 -@@ -226,7 +226,7 @@ - - - (* between : UniverseLevel.t -> canonical_arc -> canonical_arc list *) --(* between u v = {w|u<=w<=v, w canonical} *) -+(* between u v = {w |u<=w<=v, w canonical} *) - (* between is the most costly operation *) - - let between g arcu arcv = diff --git a/testsuite/external/core-109.37.00.patch b/testsuite/external/core-109.37.00.patch deleted file mode 100644 index 53e443ee66..0000000000 --- a/testsuite/external/core-109.37.00.patch +++ /dev/null @@ -1,20 +0,0 @@ ---- core-109.37.00.orig/lib/core_unix.ml 2013-08-06 21:52:16.000000000 +0200 -+++ core-109.37.00/lib/core_unix.ml 2013-08-13 15:25:11.000000000 +0200 -@@ -890,6 +890,7 @@ - | O_SYNC - | O_RSYNC - | O_SHARE_DELETE -+| O_CLOEXEC - with sexp - - type file_perm = int with of_sexp ---- core-109.37.00.orig/lib/core_unix.mli 2013-08-06 21:52:16.000000000 +0200 -+++ core-109.37.00/lib/core_unix.mli 2013-08-13 15:25:32.000000000 +0200 -@@ -305,6 +305,7 @@ - | 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 - with sexp - - (** The type of file access rights. *) diff --git a/testsuite/external/core-suite-108.00.01.patch b/testsuite/external/core-suite-108.00.01.patch deleted file mode 100644 index 4c454aa803..0000000000 --- a/testsuite/external/core-suite-108.00.01.patch +++ /dev/null @@ -1,213 +0,0 @@ ---- core-suite-108.00.01.orig/sexplib-108.00.01/top/install_printers.ml 2012-05-14 20:53:09.000000000 +0200 -+++ core-suite-108.00.01/sexplib-108.00.01/top/install_printers.ml 2012-07-12 17:33:45.000000000 +0200 -@@ -3,8 +3,11 @@ - let eval_string - ?(print_outcome = false) ?(err_formatter = Format.err_formatter) str = - let lexbuf = Lexing.from_string str in -+assert false -+(* - let phrase = !Toploop.parse_toplevel_phrase lexbuf in - Toploop.execute_phrase print_outcome err_formatter phrase -+*) - - let rec install_printers = function - | [] -> true ---- core-suite-108.00.01.orig/core-108.00.01/lib/core_unix.mli 2012-05-25 23:10:12.000000000 +0200 -+++ core-suite-108.00.01/core-108.00.01/lib/core_unix.mli 2012-07-12 17:39:29.000000000 +0200 -@@ -296,6 +296,7 @@ - | 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 - with sexp - - (** The type of file access rights. *) ---- core-suite-108.00.01.orig/core-108.00.01/lib/core_unix.ml 2012-05-25 23:10:12.000000000 +0200 -+++ core-suite-108.00.01/core-108.00.01/lib/core_unix.ml 2012-07-12 17:44:04.000000000 +0200 -@@ -804,6 +804,7 @@ - | O_DSYNC - | O_SYNC - | O_RSYNC -+| O_SHARE_DELETE - with sexp - - type file_perm = int with of_sexp ---- core-suite-108.00.01.orig/core-108.00.01/top/install_printers.ml 2012-05-17 16:50:03.000000000 +0200 -+++ core-suite-108.00.01/core-108.00.01/top/install_printers.ml 2012-07-12 17:48:36.000000000 +0200 -@@ -5,8 +5,11 @@ - let eval_string - ?(print_outcome = false) ?(err_formatter = Format.err_formatter) str = - let lexbuf = Lexing.from_string str in -+assert false -+(* - let phrase = !Toploop.parse_toplevel_phrase lexbuf in - Toploop.execute_phrase print_outcome err_formatter phrase -+*) - - let rec install_printers = function - | [] -> true ---- core-suite-108.00.01.orig/async-108.00.01/myocamlbuild.ml 2012-05-26 00:48:10.000000000 +0200 -+++ core-suite-108.00.01/async-108.00.01/myocamlbuild.ml 2012-07-12 17:59:01.000000000 +0200 -@@ -630,7 +630,7 @@ - List.concat (List.map f flags) - in - flag ["compile"; "c"] (S cflags); -- flag ["compile"; "ocaml"] (S [A "-w"; A "@Aemr-28"; A "-strict-sequence" ]) -+ flag ["compile"; "ocaml"] (S [A "-w"; A "Aemr-28"; A "-strict-sequence" ]) - ;; - - let dispatch = function ---- core-suite-108.00.01.orig/async_core-108.00.01/myocamlbuild.ml 2012-05-26 00:48:09.000000000 +0200 -+++ core-suite-108.00.01/async_core-108.00.01/myocamlbuild.ml 2012-07-12 17:58:57.000000000 +0200 -@@ -630,7 +630,7 @@ - List.concat (List.map f flags) - in - flag ["compile"; "c"] (S cflags); -- flag ["compile"; "ocaml"] (S [A "-w"; A "@Aemr-28"; A "-strict-sequence" ]) -+ flag ["compile"; "ocaml"] (S [A "-w"; A "Aemr-28"; A "-strict-sequence" ]) - ;; - - let dispatch = function ---- core-suite-108.00.01.orig/async_extra-108.00.01/myocamlbuild.ml 2012-05-26 00:48:09.000000000 +0200 -+++ core-suite-108.00.01/async_extra-108.00.01/myocamlbuild.ml 2012-07-12 17:58:53.000000000 +0200 -@@ -630,7 +630,7 @@ - List.concat (List.map f flags) - in - flag ["compile"; "c"] (S cflags); -- flag ["compile"; "ocaml"] (S [A "-w"; A "@Aemr-28"; A "-strict-sequence" ]) -+ flag ["compile"; "ocaml"] (S [A "-w"; A "Aemr-28"; A "-strict-sequence" ]) - ;; - - let dispatch = function ---- core-suite-108.00.01.orig/async_unix-108.00.01/myocamlbuild.ml 2012-05-26 00:48:09.000000000 +0200 -+++ core-suite-108.00.01/async_unix-108.00.01/myocamlbuild.ml 2012-07-12 17:58:48.000000000 +0200 -@@ -630,7 +630,7 @@ - List.concat (List.map f flags) - in - flag ["compile"; "c"] (S cflags); -- flag ["compile"; "ocaml"] (S [A "-w"; A "@Aemr-28"; A "-strict-sequence" ]) -+ flag ["compile"; "ocaml"] (S [A "-w"; A "Aemr-28"; A "-strict-sequence" ]) - ;; - - let dispatch = function ---- core-suite-108.00.01.orig/bin_prot-108.00.01/myocamlbuild.ml 2012-05-26 00:48:07.000000000 +0200 -+++ core-suite-108.00.01/bin_prot-108.00.01/myocamlbuild.ml 2012-07-12 17:15:41.000000000 +0200 -@@ -636,7 +636,7 @@ - List.concat (List.map f flags) - in - flag ["compile"; "c"] (S cflags); -- flag ["compile"; "ocaml"] (S [A "-w"; A "@Aemr-28"; A "-strict-sequence" ]) -+ flag ["compile"; "ocaml"] (S [A "-w"; A "Aemr-28"; A "-strict-sequence" ]) - ;; - - (* We probably will want to set this up in the `configure` script at some ---- core-suite-108.00.01.orig/comparelib-108.00.01/myocamlbuild.ml 2012-05-26 00:48:06.000000000 +0200 -+++ core-suite-108.00.01/comparelib-108.00.01/myocamlbuild.ml 2012-07-12 17:58:40.000000000 +0200 -@@ -631,7 +631,7 @@ - List.concat (List.map f flags) - in - flag ["compile"; "c"] (S cflags); -- flag ["compile"; "ocaml"] (S [A "-w"; A "@Aemr-28"; A "-strict-sequence" ]) -+ flag ["compile"; "ocaml"] (S [A "-w"; A "Aemr-28"; A "-strict-sequence" ]) - ;; - - let dispatch = function ---- core-suite-108.00.01.orig/core-108.00.01/myocamlbuild.ml 2012-05-26 00:48:08.000000000 +0200 -+++ core-suite-108.00.01/core-108.00.01/myocamlbuild.ml 2012-07-12 17:35:18.000000000 +0200 -@@ -643,7 +643,7 @@ - List.concat (List.map f flags) - in - flag ["compile"; "c"] (S cflags); -- flag ["compile"; "ocaml"] (S [A "-w"; A "@Aemr-28"; A "-strict-sequence" ]) -+ flag ["compile"; "ocaml"] (S [A "-w"; A "Aemr-28"; A "-strict-sequence" ]) - ;; - - let dispatch = function ---- core-suite-108.00.01.orig/core_extended-108.00.01/myocamlbuild.ml 2012-05-26 00:48:09.000000000 +0200 -+++ core-suite-108.00.01/core_extended-108.00.01/myocamlbuild.ml 2012-07-12 17:51:57.000000000 +0200 -@@ -645,7 +645,7 @@ - List.concat (List.map f flags) - in - flag ["compile"; "c"] (S cflags); -- flag ["compile"; "ocaml"] (S [A "-w"; A "@Aemr-28"; A "-strict-sequence" ]) -+ flag ["compile"; "ocaml"] (S [A "-w"; A "Aemr-28"; A "-strict-sequence" ]) - ;; - - let dispatch = function ---- core-suite-108.00.01.orig/fieldslib-108.00.01/myocamlbuild.ml 2012-05-26 00:48:06.000000000 +0200 -+++ core-suite-108.00.01/fieldslib-108.00.01/myocamlbuild.ml 2012-07-12 17:07:50.000000000 +0200 -@@ -631,7 +631,7 @@ - List.concat (List.map f flags) - in - flag ["compile"; "c"] (S cflags); -- flag ["compile"; "ocaml"] (S [A "-w"; A "@Aemr-28"; A "-strict-sequence" ]) -+ flag ["compile"; "ocaml"] (S [A "-w"; A "Aemr-28"; A "-strict-sequence" ]) - ;; - - let dispatch = function ---- core-suite-108.00.01.orig/pa_ounit-108.00.01/myocamlbuild.ml 2012-05-26 00:48:06.000000000 +0200 -+++ core-suite-108.00.01/pa_ounit-108.00.01/myocamlbuild.ml 2012-07-12 17:13:58.000000000 +0200 -@@ -630,7 +630,7 @@ - List.concat (List.map f flags) - in - flag ["compile"; "c"] (S cflags); -- flag ["compile"; "ocaml"] (S [A "-w"; A "@Aemr-28"; A "-strict-sequence" ]) -+ flag ["compile"; "ocaml"] (S [A "-w"; A "Aemr-28"; A "-strict-sequence" ]) - ;; - - let dispatch = function ---- core-suite-108.00.01.orig/pipebang-108.00.01/myocamlbuild.ml 2012-05-26 00:48:06.000000000 +0200 -+++ core-suite-108.00.01/pipebang-108.00.01/myocamlbuild.ml 2012-07-12 17:58:22.000000000 +0200 -@@ -630,7 +630,7 @@ - List.concat (List.map f flags) - in - flag ["compile"; "c"] (S cflags); -- flag ["compile"; "ocaml"] (S [A "-w"; A "@Aemr-28"; A "-strict-sequence" ]) -+ flag ["compile"; "ocaml"] (S [A "-w"; A "Aemr-28"; A "-strict-sequence" ]) - ;; - - let dispatch = function ---- core-suite-108.00.01.orig/sexplib-108.00.01/myocamlbuild.ml 2012-05-26 00:48:07.000000000 +0200 -+++ core-suite-108.00.01/sexplib-108.00.01/myocamlbuild.ml 2012-07-12 17:24:42.000000000 +0200 -@@ -635,7 +635,7 @@ - List.concat (List.map f flags) - in - flag ["compile"; "c"] (S cflags); -- flag ["compile"; "ocaml"] (S [A "-w"; A "@Aemr-28"; A "-strict-sequence" ]) -+ flag ["compile"; "ocaml"] (S [A "-w"; A "Aemr-28"; A "-strict-sequence"]) - ;; - - Ocamlbuild_plugin.dispatch ---- core-suite-108.00.01.orig/type_conv-108.00.01/myocamlbuild.ml 2012-05-26 00:48:05.000000000 +0200 -+++ core-suite-108.00.01/type_conv-108.00.01/myocamlbuild.ml 2012-07-12 17:05:31.000000000 +0200 -@@ -630,7 +630,7 @@ - List.concat (List.map f flags) - in - flag ["compile"; "c"] (S cflags); -- flag ["compile"; "ocaml"] (S [A "-w"; A "@Aemr-28"; A "-strict-sequence" ]) -+ flag ["compile"; "ocaml"] (S [A "-w"; A "Aemr-28"; A "-strict-sequence" ]) - ;; - - let dispatch = function ---- core-suite-108.00.01.orig/typehashlib-108.00.01/myocamlbuild.ml 2012-05-26 00:48:06.000000000 +0200 -+++ core-suite-108.00.01/typehashlib-108.00.01/myocamlbuild.ml 2012-07-12 17:58:06.000000000 +0200 -@@ -631,7 +631,7 @@ - List.concat (List.map f flags) - in - flag ["compile"; "c"] (S cflags); -- flag ["compile"; "ocaml"] (S [A "-w"; A "@Aemr-28"; A "-strict-sequence" ]) -+ flag ["compile"; "ocaml"] (S [A "-w"; A "Aemr-28"; A "-strict-sequence" ]) - ;; - - let dispatch = function ---- core-suite-108.00.01.orig/variantslib-108.00.01/myocamlbuild.ml 2012-05-26 00:48:06.000000000 +0200 -+++ core-suite-108.00.01/variantslib-108.00.01/myocamlbuild.ml 2012-07-12 17:11:51.000000000 +0200 -@@ -631,7 +631,7 @@ - List.concat (List.map f flags) - in - flag ["compile"; "c"] (S cflags); -- flag ["compile"; "ocaml"] (S [A "-w"; A "@Aemr-28"; A "-strict-sequence" ]) -+ flag ["compile"; "ocaml"] (S [A "-w"; A "Aemr-28"; A "-strict-sequence" ]) - ;; - - let dispatch = function diff --git a/testsuite/external/extlib-1.5.2.patch b/testsuite/external/extlib-1.5.2.patch deleted file mode 100644 index 56e48b1286..0000000000 --- a/testsuite/external/extlib-1.5.2.patch +++ /dev/null @@ -1,10 +0,0 @@ ---- extlib-1.5.2.orig/extHashtbl.ml 2011-08-06 16:56:39.000000000 +0200 -+++ extlib-1.5.2/extHashtbl.ml 2012-01-12 19:48:28.000000000 +0100 -@@ -32,6 +32,7 @@ - } - - include Hashtbl -+ let create n = Hashtbl.create (* no seed *) n - - external h_conv : ('a, 'b) t -> ('a, 'b) h_t = "%identity" - external h_make : ('a, 'b) h_t -> ('a, 'b) t = "%identity" diff --git a/testsuite/external/frama-c-Nitrogen-20111001.patch b/testsuite/external/frama-c-Nitrogen-20111001.patch deleted file mode 100644 index f7fc29727a..0000000000 --- a/testsuite/external/frama-c-Nitrogen-20111001.patch +++ /dev/null @@ -1,126 +0,0 @@ -diff -r -u frama-c-Nitrogen-20111001.orig/src/type/datatype.mli frama-c-Nitrogen-20111001/src/type/datatype.mli ---- frama-c-Nitrogen-20111001.orig/src/type/datatype.mli 2011-10-10 10:38:09.000000000 +0200 -+++ frama-c-Nitrogen-20111001/src/type/datatype.mli 2012-01-05 18:35:45.000000000 +0100 -@@ -249,10 +249,27 @@ - - end - -+module type Hashtbl_S = sig -+ type key -+ type 'a t -+ val create : int -> 'a t -+ val clear : 'a t -> unit -+ val copy : 'a t -> 'a t -+ val add : 'a t -> key -> 'a -> unit -+ val remove : 'a t -> key -> unit -+ val find : 'a t -> key -> 'a -+ val find_all : 'a t -> key -> 'a list -+ val replace : 'a t -> key -> 'a -> unit -+ val mem : 'a t -> key -> bool -+ val iter : (key -> 'a -> unit) -> 'a t -> unit -+ val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b -+ val length : 'a t -> int -+end -+ - (** A standard OCaml hashtbl signature extended with datatype operations. *) - module type Hashtbl = sig - -- include Hashtbl.S -+ include Hashtbl_S - - val memo: 'a t -> key -> (key -> 'a) -> 'a - (** [memo tbl k f] returns the binding of [k] in [tbl]. If there is -@@ -468,7 +485,7 @@ - module Map(M: Map_common_interface.S)(Key: S with type t = M.key)(Info: Functor_info) : - Map with type 'a t = 'a M.t and type key = M.key and module Key = Key - --module Hashtbl(H: Hashtbl.S)(Key: S with type t = H.key)(Info : Functor_info): -+module Hashtbl(H: Hashtbl_S)(Key: S with type t = H.key)(Info : Functor_info): - Hashtbl with type 'a t = 'a H.t and type key = H.key and module Key = Key - - module type Sub_caml_weak_hashtbl = sig -diff -r -u frama-c-Nitrogen-20111001.orig/src/wp/LogicId.mli frama-c-Nitrogen-20111001/src/wp/LogicId.mli ---- frama-c-Nitrogen-20111001.orig/src/wp/LogicId.mli 2011-10-10 10:38:21.000000000 +0200 -+++ frama-c-Nitrogen-20111001/src/wp/LogicId.mli 2012-01-05 18:38:36.000000000 +0100 -@@ -40,7 +40,7 @@ - - module Iset : Set.S with type elt = t - module Imap : Map.S with type key = t --module Ihmap : Hashtbl.S with type key = t -+module Ihmap : Datatype.Hashtbl_S with type key = t - - (** {3 Name Spaces} *) - -diff -r -u frama-c-Nitrogen-20111001.orig/src/wp/fol_formula.ml frama-c-Nitrogen-20111001/src/wp/fol_formula.ml ---- frama-c-Nitrogen-20111001.orig/src/wp/fol_formula.ml 2011-10-10 10:38:21.000000000 +0200 -+++ frama-c-Nitrogen-20111001/src/wp/fol_formula.ml 2012-01-05 18:31:40.000000000 +0100 -@@ -389,7 +389,7 @@ - module type Identifiable = - sig - type t -- module H : Hashtbl.S -+ module H : Datatype.Hashtbl_S - val index : t -> H.key - val prefix : string - val basename : t -> string -diff -r -u frama-c-Nitrogen-20111001.orig/src/wp/formula.mli frama-c-Nitrogen-20111001/src/wp/formula.mli ---- frama-c-Nitrogen-20111001.orig/src/wp/formula.mli 2011-10-10 10:38:21.000000000 +0200 -+++ frama-c-Nitrogen-20111001/src/wp/formula.mli 2012-01-05 18:38:28.000000000 +0100 -@@ -147,7 +147,7 @@ - module type Identifiable = - sig - type t -- module H : Hashtbl.S -+ module H : Datatype.Hashtbl_S - val index : t -> H.key - val prefix : string - val basename : t -> string ---- frama-c-Nitrogen-20111001.orig/src/type/datatype.ml 2011-10-10 10:38:09.000000000 +0200 -+++ frama-c-Nitrogen-20111001/src/type/datatype.ml 2012-01-05 18:46:38.000000000 +0100 -@@ -306,8 +306,26 @@ - module Make(Data: S) : S with type t = Data.t t - end - -+module type Hashtbl_S = -+ sig -+ type key -+ type 'a t -+ val create : int -> 'a t -+ val clear : 'a t -> unit -+ val copy : 'a t -> 'a t -+ val add : 'a t -> key -> 'a -> unit -+ val remove : 'a t -> key -> unit -+ val find : 'a t -> key -> 'a -+ val find_all : 'a t -> key -> 'a list -+ val replace : 'a t -> key -> 'a -> unit -+ val mem : 'a t -> key -> bool -+ val iter : (key -> 'a -> unit) -> 'a t -> unit -+ val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b -+ val length : 'a t -> int -+ end -+ - module type Hashtbl = sig -- include Hashtbl.S -+ include Hashtbl_S - val memo: 'a t -> key -> (key -> 'a) -> 'a - module Key: S with type t = key - module Make(Data: S) : S with type t = Data.t t -@@ -970,7 +988,7 @@ - module Initial_caml_hashtbl = Hashtbl - - (* ocaml functors are generative *) --module Hashtbl(H: Hashtbl.S)(Key: S with type t = H.key)(Info : Functor_info) = -+module Hashtbl(H: Hashtbl_S)(Key: S with type t = H.key)(Info : Functor_info) = - struct - - let () = check Key.equal "equal" Key.name Info.module_name ---- frama-c-Nitrogen-20111001/configure.orig 2012-03-12 16:14:45.000000000 +0100 -+++ frama-c-Nitrogen-20111001/configure 2012-03-12 16:15:06.000000000 +0100 -@@ -2675,6 +2675,7 @@ - ;; - 3.10*) echo "${ECHO_T}good!";; - 3.1*) echo "${ECHO_T}good!"; OCAML_ANNOT_OPTION="-annot";; -+ 4.0*) echo "${ECHO_T}good!"; OCAML_ANNOT_OPTION="-annot";; - *) echo "${ECHO_T}Incompatible version!"; exit 2;; - esac - diff --git a/testsuite/external/frama-c-Oxygen-20120901.patch b/testsuite/external/frama-c-Oxygen-20120901.patch deleted file mode 100644 index 2f3ce3e6f2..0000000000 --- a/testsuite/external/frama-c-Oxygen-20120901.patch +++ /dev/null @@ -1,185 +0,0 @@ ---- frama-c-Oxygen-20120901.orig/src/type/datatype.ml 2012-09-19 13:55:23.000000000 +0200 -+++ frama-c-Oxygen-20120901/src/type/datatype.ml 2013-02-19 16:36:36.000000000 +0100 -@@ -285,8 +285,37 @@ - - end - -+module type Set_S = sig -+ type elt -+ type t -+ val empty: t -+ val is_empty: t -> bool -+ val mem: elt -> t -> bool -+ val add: elt -> t -> t -+ val singleton: elt -> t -+ val remove: elt -> t -> t -+ val union: t -> t -> t -+ val inter: t -> t -> t -+ val diff: t -> t -> t -+ val compare: t -> t -> int -+ val equal: t -> t -> bool -+ val subset: t -> t -> bool -+ val iter: (elt -> unit) -> t -> unit -+ val fold: (elt -> 'a -> 'a) -> t -> 'a -> 'a -+ val for_all: (elt -> bool) -> t -> bool -+ val exists: (elt -> bool) -> t -> bool -+ val filter: (elt -> bool) -> t -> t -+ val partition: (elt -> bool) -> t -> t * t -+ val cardinal: t -> int -+ val elements: t -> elt list -+ val min_elt: t -> elt -+ val max_elt: t -> elt -+ val choose: t -> elt -+ val split: elt -> t -> t * bool * t -+end -+ - module type Set = sig -- include Set.S -+ include Set_S - val ty: t Type.t - val name: string - val descr: t Descr.t -@@ -1093,7 +1122,7 @@ - module Initial_caml_set = Set - - (* ocaml functors are generative *) --module Set(S: Set.S)(E: S with type t = S.elt)(Info: Functor_info) = struct -+module Set(S: Set_S)(E: S with type t = S.elt)(Info: Functor_info) = struct - - let () = check E.equal "equal" E.name Info.module_name - let () = check E.compare "compare" E.name Info.module_name ---- frama-c-Oxygen-20120901.orig/src/type/datatype.mli 2012-09-19 13:55:23.000000000 +0200 -+++ frama-c-Oxygen-20120901/src/type/datatype.mli 2013-02-19 16:36:29.000000000 +0100 -@@ -230,9 +230,38 @@ - defining by applying the functor. *) - end - -+module type Set_S = sig -+ type elt -+ type t -+ val empty: t -+ val is_empty: t -> bool -+ val mem: elt -> t -> bool -+ val add: elt -> t -> t -+ val singleton: elt -> t -+ val remove: elt -> t -> t -+ val union: t -> t -> t -+ val inter: t -> t -> t -+ val diff: t -> t -> t -+ val compare: t -> t -> int -+ val equal: t -> t -> bool -+ val subset: t -> t -> bool -+ val iter: (elt -> unit) -> t -> unit -+ val fold: (elt -> 'a -> 'a) -> t -> 'a -> 'a -+ val for_all: (elt -> bool) -> t -> bool -+ val exists: (elt -> bool) -> t -> bool -+ val filter: (elt -> bool) -> t -> t -+ val partition: (elt -> bool) -> t -> t * t -+ val cardinal: t -> int -+ val elements: t -> elt list -+ val min_elt: t -> elt -+ val max_elt: t -> elt -+ val choose: t -> elt -+ val split: elt -> t -> t * bool * t -+end -+ - (** A standard OCaml set signature extended with datatype operations. *) - module type Set = sig -- include Set.S -+ include Set_S - val ty: t Type.t - val name: string - val descr: t Descr.t -@@ -602,7 +631,7 @@ - 'e Type.t -> - ('a -> 'b -> 'c -> 'd -> 'e) Type.t - --module Set(S: Set.S)(E: S with type t = S.elt)(Info : Functor_info): -+module Set(S: Set_S)(E: S with type t = S.elt)(Info : Functor_info): - Set with type t = S.t and type elt = E.t - - module Map ---- frama-c-Oxygen-20120901.orig/src/wp/qed/src/idxset.ml 2012-09-19 13:55:28.000000000 +0200 -+++ frama-c-Oxygen-20120901/src/wp/qed/src/idxset.ml 2013-02-19 16:45:08.000000000 +0100 -@@ -20,9 +20,38 @@ - (* *) - (**************************************************************************) - -+module type Set_S = sig -+ type elt -+ type t -+ val empty: t -+ val is_empty: t -> bool -+ val mem: elt -> t -> bool -+ val add: elt -> t -> t -+ val singleton: elt -> t -+ val remove: elt -> t -> t -+ val union: t -> t -> t -+ val inter: t -> t -> t -+ val diff: t -> t -> t -+ val compare: t -> t -> int -+ val equal: t -> t -> bool -+ val subset: t -> t -> bool -+ val iter: (elt -> unit) -> t -> unit -+ val fold: (elt -> 'a -> 'a) -> t -> 'a -> 'a -+ val for_all: (elt -> bool) -> t -> bool -+ val exists: (elt -> bool) -> t -> bool -+ val filter: (elt -> bool) -> t -> t -+ val partition: (elt -> bool) -> t -> t * t -+ val cardinal: t -> int -+ val elements: t -> elt list -+ val min_elt: t -> elt -+ val max_elt: t -> elt -+ val choose: t -> elt -+ val split: elt -> t -> t * bool * t -+end -+ - module type S = - sig -- include Set.S -+ include Set_S - val map : (elt -> elt) -> t -> t - val intersect : t -> t -> bool - end ---- frama-c-Oxygen-20120901.orig/src/wp/qed/src/idxset.mli 2012-09-19 13:55:28.000000000 +0200 -+++ frama-c-Oxygen-20120901/src/wp/qed/src/idxset.mli 2013-02-19 16:45:19.000000000 +0100 -@@ -22,9 +22,38 @@ - - (** Set of indexed elements implemented as Patricia sets. *) - -+module type Set_S = sig -+ type elt -+ type t -+ val empty: t -+ val is_empty: t -> bool -+ val mem: elt -> t -> bool -+ val add: elt -> t -> t -+ val singleton: elt -> t -+ val remove: elt -> t -> t -+ val union: t -> t -> t -+ val inter: t -> t -> t -+ val diff: t -> t -> t -+ val compare: t -> t -> int -+ val equal: t -> t -> bool -+ val subset: t -> t -> bool -+ val iter: (elt -> unit) -> t -> unit -+ val fold: (elt -> 'a -> 'a) -> t -> 'a -> 'a -+ val for_all: (elt -> bool) -> t -> bool -+ val exists: (elt -> bool) -> t -> bool -+ val filter: (elt -> bool) -> t -> t -+ val partition: (elt -> bool) -> t -> t * t -+ val cardinal: t -> int -+ val elements: t -> elt list -+ val min_elt: t -> elt -+ val max_elt: t -> elt -+ val choose: t -> elt -+ val split: elt -> t -> t * bool * t -+end -+ - module type S = - sig -- include Set.S -+ include Set_S - val map : (elt -> elt) -> t -> t - val intersect : t -> t -> bool - end diff --git a/testsuite/external/hevea-1.10.patch b/testsuite/external/hevea-1.10.patch deleted file mode 100644 index 40aab2b796..0000000000 --- a/testsuite/external/hevea-1.10.patch +++ /dev/null @@ -1,22 +0,0 @@ -diff -r -u hevea-1.10 2/hevea.ml hevea-1.10/hevea.ml ---- hevea-1.10 2/hevea.ml 2007-02-09 15:44:28.000000000 +0100 -+++ hevea-1.10/hevea.ml 2009-08-27 17:51:55.000000000 +0200 -@@ -237,6 +237,7 @@ - *) - end ; - let _ = finalize false in -+ begin try Sys.remove Parse_opts.name_out with _ -> () end; - prerr_endline "Adios" ; - exit 2 - ;; ---- hevea-1.10/Makefile.orig 2009-10-28 12:18:16.000000000 +0100 -+++ hevea-1.10/Makefile 2009-10-28 12:18:00.000000000 +0100 -@@ -48,7 +48,7 @@ - all-make: $(TARGET)-make - - install: config.sh -- ./install.sh $(TARGET) -+ LIBDIR=${LIBDIR} LATEXLIBDIR=${LATEXLIBDIR} ./install.sh $(TARGET) - - byte: ocb-byte - opt: ocb-opt diff --git a/testsuite/external/kaputt-1.2.patch b/testsuite/external/kaputt-1.2.patch deleted file mode 100644 index 279730ed98..0000000000 --- a/testsuite/external/kaputt-1.2.patch +++ /dev/null @@ -1,37 +0,0 @@ ---- kaputt-1.2/src/syntax/kaputt_pp.ml.orig 2012-12-19 16:46:36.000000000 +0100 -+++ kaputt-1.2/src/syntax/kaputt_pp.ml 2012-12-19 16:46:59.000000000 +0100 -@@ -54,6 +54,8 @@ - let temp_name, temp_chan = Filename.open_temp_file "kaputt" ".ml" in - let source_chan = open_in args.(len - 3) in - let test_chan = open_in test_file in -+ let directive = Printf.sprintf "# 1 %S\n" args.(len - 3) in -+ output_string temp_chan directive; - copy source_chan temp_chan; - let directive = Printf.sprintf "# 1 %S\n" test_file in - output_string temp_chan directive; ---- kaputt-1.2/src/syntax/kaputt_pp.ml.orig 2013-01-08 17:05:01.000000000 +0100 -+++ kaputt-1.2/src/syntax/kaputt_pp.ml 2013-01-08 17:05:46.000000000 +0100 -@@ -28,8 +28,7 @@ - Buffer.add_string buff (quote args.(i)); - Buffer.add_char buff ' '; - done; -- let code = Sys.command (Buffer.contents buff) in -- ignore (exit code) -+ Sys.command (Buffer.contents buff) - - let copy from_chan to_chan = - try -@@ -64,9 +63,11 @@ - close_in_noerr test_chan; - close_out_noerr temp_chan; - args.(len - 3) <- temp_name; -- call args -+ let code = call args in -+ (try Sys.remove temp_name with _ -> ()); -+ ignore (exit code) - end else begin -- call args -+ ignore (exit (call args)) - end - else begin - Printf.eprintf "Error: invalid command-line\n"; diff --git a/testsuite/external/lablgtk-2.14.2.patch b/testsuite/external/lablgtk-2.14.2.patch deleted file mode 100644 index 4824726a95..0000000000 --- a/testsuite/external/lablgtk-2.14.2.patch +++ /dev/null @@ -1,11 +0,0 @@ ---- lablgtk-2.14.2/src/Makefile.orig 2012-07-31 17:37:12.000000000 +0200 -+++ lablgtk-2.14.2/src/Makefile 2012-07-31 17:37:17.000000000 +0200 -@@ -191,7 +191,7 @@ - .ml4.cmo: - $(CAMLC) -c -pp "$(CAMLP4O) -impl" -impl $< - .cmxa.cmxs: -- $(CAMLOPT) -verbose -o $@ -shared -linkall -I . \ -+ $(CAMLOPT) -o $@ -shared -linkall -I . \ - -ccopt '$(filter -L%, $(DYNLINKLIBS))' $< - - #.ml4.ml: diff --git a/testsuite/external/lablgtk-2.16.0.patch b/testsuite/external/lablgtk-2.16.0.patch deleted file mode 100644 index c16e10cc4c..0000000000 --- a/testsuite/external/lablgtk-2.16.0.patch +++ /dev/null @@ -1,22 +0,0 @@ ---- lablgtk-2.16.0.orig/src/gMenu.ml 2012-08-23 12:37:48.000000000 +0200 -+++ lablgtk-2.16.0/src/gMenu.ml 2013-02-18 20:12:27.000000000 +0100 -@@ -87,7 +87,7 @@ - - class menu_item_skel = [menu_item] pre_menu_item_skel - --let pack_item self ~packing ~show = -+let pack_item self ?packing ?show = - may packing ~f:(fun f -> (f (self :> menu_item) : unit)); - if show <> Some false then self#misc#show (); - self ---- lablgtk-2.16.0.orig/src/gFile.ml 2012-08-23 12:37:48.000000000 +0200 -+++ lablgtk-2.16.0/src/gFile.ml 2013-02-18 20:13:37.000000000 +0100 -@@ -179,7 +179,7 @@ - FileChooser.P.file_system_backend backend - [ Gobject.param FileChooser.P.action action ]) in - let o = new chooser_widget w in -- GObj.pack_return o ?packing ?show -+ GObj.pack_return o ~packing ~show - - class chooser_button_signals obj = object - inherit GContainer.container_signals_impl obj diff --git a/testsuite/external/lablgtkextras-1.1.patch b/testsuite/external/lablgtkextras-1.1.patch deleted file mode 100644 index 19acf21d09..0000000000 --- a/testsuite/external/lablgtkextras-1.1.patch +++ /dev/null @@ -1,22 +0,0 @@ ---- lablgtkextras-1.1.orig/checkocaml.ml 2012-04-13 16:51:37.000000000 +0200 -+++ lablgtkextras-1.1/checkocaml.ml 2012-05-25 16:23:36.000000000 +0200 -@@ -885,7 +885,7 @@ - let _ = !print "\n### checking required tools and libraries ###\n" - - let () = check_ocamlfind_package conf "config-file";; --let () = check_ocamlfind_package conf "lablgtk2.sourceview2";; -+let () = check_ocamlfind_package conf "lablgtk2";; - let () = check_ocamlfind_package conf ~min_version: [1;1] "xmlm";; - - let _ = !print "\n###\n" ---- lablgtkextras-1.1.orig/src/Makefile 2012-04-13 16:51:37.000000000 +0200 -+++ lablgtkextras-1.1/src/Makefile 2012-05-25 16:27:58.000000000 +0200 -@@ -26,7 +26,7 @@ - - include ../master.Makefile - --PACKAGES=config-file,lablgtk2.sourceview2,xmlm -+PACKAGES=config-file,lablgtk2,xmlm - OF_FLAGS= -package $(PACKAGES) - - COMPFLAGS=-annot -g -warn-error A diff --git a/testsuite/external/lablgtkextras-1.3.patch b/testsuite/external/lablgtkextras-1.3.patch deleted file mode 100644 index e36480fd0a..0000000000 --- a/testsuite/external/lablgtkextras-1.3.patch +++ /dev/null @@ -1,11 +0,0 @@ ---- lablgtkextras-1.3/src/Makefile.orig 2013-05-29 14:21:34.000000000 +0200 -+++ lablgtkextras-1.3/src/Makefile 2013-05-29 14:21:52.000000000 +0200 -@@ -29,7 +29,7 @@ - PACKAGES=config-file,lablgtk2.sourceview2,xmlm - OF_FLAGS= -package $(PACKAGES) - --COMPFLAGS=-annot -g -warn-error A -+COMPFLAGS=-annot -g -warn-error a - - GELIB_CMOFILES= \ - gtke_version.cmo \ diff --git a/testsuite/external/lwt-2.4.0.patch b/testsuite/external/lwt-2.4.0.patch deleted file mode 100644 index 14ce097cb5..0000000000 --- a/testsuite/external/lwt-2.4.0.patch +++ /dev/null @@ -1,24 +0,0 @@ ---- lwt-2.4.0.orig/src/unix/lwt_unix.ml 2012-07-19 13:35:56.000000000 +0200 -+++ lwt-2.4.0/src/unix/lwt_unix.ml 2013-08-13 15:46:12.000000000 +0200 -@@ -596,6 +596,9 @@ - #if ocaml_version >= (3, 13) - | O_SHARE_DELETE - #endif -+#if ocaml_version >= (4, 01) -+ | O_CLOEXEC -+#endif - - #if windows - ---- lwt-2.4.0.orig/src/unix/lwt_unix.mli 2012-07-19 13:35:56.000000000 +0200 -+++ lwt-2.4.0/src/unix/lwt_unix.mli 2013-08-13 15:46:18.000000000 +0200 -@@ -315,6 +315,9 @@ - #if ocaml_version >= (3, 13) - | O_SHARE_DELETE - #endif -+#if ocaml_version >= (4, 01) -+ | O_CLOEXEC -+#endif - - val openfile : string -> open_flag list -> file_perm -> file_descr Lwt.t - (** Wrapper for [Unix.openfile]. *) diff --git a/testsuite/external/menhir-20120123.patch b/testsuite/external/menhir-20120123.patch deleted file mode 100644 index a6a83bdf89..0000000000 --- a/testsuite/external/menhir-20120123.patch +++ /dev/null @@ -1,11 +0,0 @@ ---- menhir-20120123/Makefile.arch.orig 2012-09-28 19:03:09.673811200 +0200 -+++ menhir-20120123/Makefile.arch 2012-09-28 19:07:38.680344000 +0200 -@@ -1,7 +1,7 @@ - # If ocaml reports that Sys.os_type is Unix, we assume Unix, otherwise - # we assume Windows. - --ifeq "$(shell rm -f ./o.ml && echo print_endline Sys.os_type > ./o.ml && ocaml ./o.ml && rm -f ./o.ml)" "Unix" -+ifneq "$(shell rm -f ./o.ml && echo print_endline Sys.os_type > ./o.ml && ocaml ./o.ml && rm -f ./o.ml)" "Win32" - MENHIREXE := menhir - OBJ := o - else diff --git a/testsuite/external/mldonkey-3.1.2.patch b/testsuite/external/mldonkey-3.1.2.patch deleted file mode 100644 index 82d3edb2fd..0000000000 --- a/testsuite/external/mldonkey-3.1.2.patch +++ /dev/null @@ -1,31 +0,0 @@ ---- mldonkey-3.1.2.orig/config/configure 2011-08-08 07:11:57.000000000 +0200 -+++ mldonkey-3.1.2/config/configure 2012-03-13 12:52:40.000000000 +0100 -@@ -4870,7 +4870,7 @@ - else - OCAMLVERSION=`$OCAMLC -v | sed -n -e 's|.*version* *\(.*\)$|\1|p' ` - case "$OCAMLVERSION" in -- "$REQUIRED_OCAML"*|3.12.*|3.11.*|3.10.1*|3.10.2*) ;; -+ "$REQUIRED_OCAML"*|4.*|3.1[23].*|3.11.*|3.10.1*|3.10.2*) ;; - *) - echo "Need build" - BUILD_OCAML=yes -@@ -5402,7 +5402,7 @@ - - # force usage of supported Ocaml versions - case "$OCAMLVERSION" in -- 3.10.1*|3.10.2*|3.1*) ;; -+ 3.10.1*|3.10.2*|3.1*|4.*) ;; - *) - if test "$REQUIRED_OCAML" != "SVN" ; then - echo "******** Version $REQUIRED_OCAML of Objective-Caml is required *********" 1>&2; ---- mldonkey-3.1.2.orig/Makefile 2012-05-16 11:56:34.000000000 +0200 -+++ mldonkey-3.1.2/Makefile 2012-05-25 19:24:15.000000000 +0200 -@@ -5447,7 +5449,7 @@ - $(OCAMLC) $(DEVFLAGS) $(INCLUDES) -c $< - - .mlcpp.ml: -- @$(CPP) -x c -P $< $(FIX_BROKEN_CPP) -o $@ -+ @$(CPP) -x c -P $< $(FIX_BROKEN_CPP) > $@ - - %.ml: %.mlp $(BITSTRING)/pa_bitstring.cmo - $(CAMLP4OF) build/bitstring.cma $(BITSTRING)/bitstring_persistent.cmo $(BITSTRING)/pa_bitstring.cmo -impl $< -o $@ diff --git a/testsuite/external/oasis-common.patch b/testsuite/external/oasis-common.patch deleted file mode 100644 index c13cd29052..0000000000 --- a/testsuite/external/oasis-common.patch +++ /dev/null @@ -1,55 +0,0 @@ ---- setup.ml 2011-03-22 17:00:48.000000000 +0100 -+++ setup.ml 2011-12-22 21:41:25.000000000 +0100 -@@ -2662,10 +2662,14 @@ - (ocamlc_config_map ()) - 0 - in -- let nm_config = -+ let chop_version_suffix s = -+ try String.sub s 0 (String.index s '+') -+ with _ -> s -+ in -+ let nm_config, value_config = - match nm with -- | "ocaml_version" -> "version" -- | _ -> nm -+ | "ocaml_version" -> "version", chop_version_suffix -+ | _ -> nm, (fun x -> x) - in - var_redefine - nm -@@ -2677,7 +2681,7 @@ - let value = - SMap.find nm_config map - in -- value -+ value_config value - with Not_found -> - failwithf2 - (f_ "Cannot find field '%s' in '%s -config' output") -@@ -3057,7 +3061,7 @@ - begin - let acc = - try -- Scanf.bscanf scbuf "%S %S@\n" -+ Scanf.bscanf scbuf "%S %S\n" - (fun e d -> - let t = - e, d ---- setup.ml.orig 2012-03-17 11:50:20.000000000 +0100 -+++ setup.ml 2012-07-31 17:45:43.000000000 +0200 -@@ -2284,7 +2284,13 @@ - let cmdline = - String.concat " " (cmd :: args) - in -- info (f_ "Running command '%s'") cmdline; -+ let printable_cmdline = -+ match List.rev args with -+ | _ :: (">" | "2>") :: rest -> -+ String.concat " " (cmd :: List.rev ("[file]" :: ">" :: rest)) -+ | _ -> cmdline -+ in -+ info (f_ "Running command '%s'") printable_cmdline; - match f_exit_code, Sys.command cmdline with - | None, 0 -> () - | None, i -> diff --git a/testsuite/external/obrowser-1.1.1.patch b/testsuite/external/obrowser-1.1.1.patch deleted file mode 100644 index f67a3b7a83..0000000000 --- a/testsuite/external/obrowser-1.1.1.patch +++ /dev/null @@ -1,1385 +0,0 @@ ---- obrowser-1.1.1/Makefile.orig 2011-07-05 16:15:30.000000000 +0200 -+++ obrowser-1.1.1/Makefile 2011-07-05 16:16:42.000000000 +0200 -@@ -16,9 +16,9 @@ - EXAMPLES = $(patsubst examples/%,%, $(wildcard examples/*)) - EXAMPLES_TARGETS = $(patsubst examples/%,%.example, $(wildcard examples/*)) - OCAMLFIND = ocamlfind --.PHONY: tuto dist plugin lwt -+.PHONY: tuto dist plugin lwt AXO - --all: .check_version rt/caml/stdlib.cma vm.js tuto $(EXAMPLES_TARGETS) examples.html AXO lwt -+all: .check_version rt/caml/stdlib.cma vm.js tuto AXO $(EXAMPLES_TARGETS) examples.html lwt - - .check_version: - @[ "$(shell ocamlc -vnum)" = "3.12.0" ] || \ ---- obrowser-1.1.1.orig/Makefile 2011-04-20 18:26:44.000000000 +0200 -+++ obrowser-1.1.1/Makefile 2012-03-12 16:55:44.000000000 +0100 -@@ -21,10 +21,11 @@ - all: .check_version rt/caml/stdlib.cma vm.js tuto $(EXAMPLES_TARGETS) examples.html AXO lwt - - .check_version: -- @[ "$(shell ocamlc -vnum)" = "3.12.0" ] || \ -- [ "$(shell ocamlc -vnum)" = "3.12.1" ] || \ -- ( echo "You need ocaml version 3.12.0 or 3.12.1"; \ -- exit 1 ) -+ @case `ocaml -vnum` in \ -+ 3.1[2-9].*);; \ -+ 4.*);; \ -+ *) echo "You need ocaml version 3.12.0 or later"; exit 1;; \ -+ esac - touch $@ - - %.example: ---- obrowser-1.1.1.orig/rt/caml/pervasives.mli 2011-04-20 18:26:44.000000000 +0200 -+++ obrowser-1.1.1/rt/caml/pervasives.mli 2012-01-12 01:07:49.000000000 +0100 -@@ -1,6 +1,6 @@ - (***********************************************************************) - (* *) --(* Objective Caml *) -+(* OCaml *) - (* *) - (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) - (* *) -@@ -52,24 +52,24 @@ - Equality between cyclic data structures may not terminate. *) - - external ( <> ) : 'a -> 'a -> bool = "%notequal" --(** Negation of {!Pervasives.(=)}. *) -+(** Negation of {!Pervasives.( = )}. *) - - external ( < ) : 'a -> 'a -> bool = "%lessthan" --(** See {!Pervasives.(>=)}. *) -+(** See {!Pervasives.( >= )}. *) - - external ( > ) : 'a -> 'a -> bool = "%greaterthan" --(** See {!Pervasives.(>=)}. *) -+(** See {!Pervasives.( >= )}. *) - - external ( <= ) : 'a -> 'a -> bool = "%lessequal" --(** See {!Pervasives.(>=)}. *) -+(** See {!Pervasives.( >= )}. *) - - external ( >= ) : 'a -> 'a -> bool = "%greaterequal" - (** Structural ordering functions. These functions coincide with - the usual orderings over integers, characters, strings - and floating-point numbers, and extend them to a - total ordering over all types. -- The ordering is compatible with [(=)]. As in the case -- of [(=)], mutable structures are compared by contents. -+ The ordering is compatible with [( = )]. As in the case -+ of [( = )], mutable structures are compared by contents. - Comparison between functional values raises [Invalid_argument]. - Comparison between cyclic structures may not terminate. *) - -@@ -108,12 +108,12 @@ - mutable fields and objects with mutable instance variables, - [e1 == e2] is true if and only if physical modification of [e1] - also affects [e2]. -- On non-mutable types, the behavior of [(==)] is -+ On non-mutable types, the behavior of [( == )] is - implementation-dependent; however, it is guaranteed that - [e1 == e2] implies [compare e1 e2 = 0]. *) - - external ( != ) : 'a -> 'a -> bool = "%noteq" --(** Negation of {!Pervasives.(==)}. *) -+(** Negation of {!Pervasives.( == )}. *) - - - (** {6 Boolean operations} *) -@@ -229,7 +229,7 @@ - - (** {6 Floating-point arithmetic} - -- Caml's floating-point numbers follow the -+ OCaml's floating-point numbers follow the - IEEE 754 standard, using double precision (64 bits) numbers. - Floating-point operations never raise an exception on overflow, - underflow, division by zero, etc. Instead, special IEEE numbers -@@ -310,10 +310,18 @@ - Result is in radians and is between [-pi/2] and [pi/2]. *) - - external atan2 : float -> float -> float = "caml_atan2_float" "atan2" "float" --(** [atan x y] returns the arc tangent of [y /. x]. The signs of [x] -+(** [atan2 y x] returns the arc tangent of [y /. x]. The signs of [x] - and [y] are used to determine the quadrant of the result. - Result is in radians and is between [-pi] and [pi]. *) - -+external hypot : float -> float -> float -+ = "caml_hypot_float" "caml_hypot" "float" -+(** [hypot x y] returns [sqrt(x *. x + y *. y)], that is, the length -+ of the hypotenuse of a right-angled triangle with sides of length -+ [x] and [y], or, equivalently, the distance of the point [(x,y)] -+ to origin. -+ @since 3.13.0 *) -+ - external cosh : float -> float = "caml_cosh_float" "cosh" "float" - (** Hyperbolic cosine. Argument is in radians. *) - -@@ -337,6 +345,14 @@ - external abs_float : float -> float = "%absfloat" - (** [abs_float f] returns the absolute value of [f]. *) - -+external copysign : float -> float -> float -+ = "caml_copysign_float" "caml_copysign" "float" -+(** [copysign x y] returns a float whose absolute value is that of [x] -+ and whose sign is that of [y]. If [x] is [nan], returns [nan]. -+ If [y] is [nan], returns either [x] or [-. x], but it is not -+ specified which. -+ @since 3.13.0 *) -+ - external mod_float : float -> float -> float = "caml_fmod_float" "fmod" "float" - (** [mod_float a b] returns the remainder of [a] with respect to - [b]. The returned value is [a -. n *. b], where [n] -@@ -505,7 +521,7 @@ - (** The standard output for the process. *) - - val stderr : out_channel --(** The standard error ouput for the process. *) -+(** The standard error output for the process. *) - - - (** {7 Output functions on standard output} *) -@@ -642,7 +658,7 @@ - The given integer is taken modulo 2{^32}. - The only reliable way to read it back is through the - {!Pervasives.input_binary_int} function. The format is compatible across -- all machines for a given version of Objective Caml. *) -+ all machines for a given version of OCaml. *) - - val output_value : out_channel -> 'a -> unit - (** Write the representation of a structured value of any type -@@ -855,12 +871,16 @@ - (** Format strings have a general and highly polymorphic type - [('a, 'b, 'c, 'd, 'e, 'f) format6]. Type [format6] is built in. - The two simplified types, [format] and [format4] below are -- included for backward compatibility with earlier releases of Objective -- Caml. -+ included for backward compatibility with earlier releases of OCaml. - ['a] is the type of the parameters of the format, -- ['c] is the result type for the "printf"-style function, -- and ['b] is the type of the first argument given to -- [%a] and [%t] printing functions. *) -+ ['b] is the type of the first argument given to -+ [%a] and [%t] printing functions, -+ ['c] is the type of the argument transmitted to the first argument of -+ "kprintf"-style functions, -+ ['d] is the result type for the "scanf"-style functions, -+ ['e] is the type of the receiver function for the "scanf"-style functions, -+ ['f] is the result type for the "printf"-style function. -+ *) - type ('a, 'b, 'c, 'd) format4 = ('a, 'b, 'c, 'c, 'c, 'd) format6 - - type ('a, 'b, 'c) format = ('a, 'b, 'c, 'c) format4 -@@ -888,7 +908,7 @@ - (** Terminate the process, returning the given status code - to the operating system: usually 0 to indicate no errors, - and a small positive integer to indicate failure. -- All open output channels are flushed with flush_all. -+ All open output channels are flushed with [flush_all]. - An implicit [exit 0] is performed each time a program - terminates normally. An implicit [exit 2] is performed if the program - terminates early because of an uncaught exception. *) ---- obrowser-1.1.1.orig/rt/caml/pervasives.ml 2011-04-20 18:26:44.000000000 +0200 -+++ obrowser-1.1.1/rt/caml/pervasives.ml 2012-01-12 17:04:04.000000000 +0100 -@@ -91,6 +91,8 @@ - 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" - 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" -@@ -104,6 +106,8 @@ - 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" - 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" ---- obrowser-1.1.1.orig/rt/caml/list.ml 2011-04-20 18:26:44.000000000 +0200 -+++ obrowser-1.1.1/rt/caml/list.ml 2012-01-12 17:30:31.000000000 +0100 -@@ -1,6 +1,6 @@ - (***********************************************************************) - (* *) --(* Objective Caml *) -+(* OCaml *) - (* *) - (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) - (* *) -@@ -56,6 +56,12 @@ - [] -> [] - | a::l -> let r = f a in r :: map f l - -+let rec mapi i f = function -+ [] -> [] -+ | a::l -> let r = f i a in r :: mapi (i + 1) f l -+ -+let mapi f l = mapi 0 f l -+ - let rev_map f l = - let rec rmap_f accu = function - | [] -> accu -@@ -68,6 +74,12 @@ - [] -> () - | a::l -> f a; iter f l - -+let rec iteri i f = function -+ [] -> () -+ | a::l -> f i a; iteri (i + 1) f l -+ -+let iteri f l = iteri 0 f l -+ - let rec fold_left f accu l = - match l with - [] -> accu ---- obrowser-1.1.1.orig/rt/caml/list.mli 2011-04-20 18:26:44.000000000 +0200 -+++ obrowser-1.1.1/rt/caml/list.mli 2012-01-12 17:30:31.000000000 +0100 -@@ -1,6 +1,6 @@ - (***********************************************************************) - (* *) --(* Objective Caml *) -+(* OCaml *) - (* *) - (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) - (* *) -@@ -75,11 +75,25 @@ - [a1; ...; an]. It is equivalent to - [begin f a1; f a2; ...; f an; () end]. *) - -+val iteri : (int -> 'a -> unit) -> 'a list -> unit -+(** Same as {!List.iter}, but the function is applied to the index of -+ the element as first argument (counting from 0), and the element -+ itself as second argument. -+ @since 3.13.0 -+*) -+ - val map : ('a -> 'b) -> 'a list -> 'b list - (** [List.map f [a1; ...; an]] applies function [f] to [a1, ..., an], - and builds the list [[f a1; ...; f an]] - with the results returned by [f]. Not tail-recursive. *) - -+val mapi : (int -> 'a -> 'b) -> 'a list -> 'b list -+(** Same as {!List.map}, but the function is applied to the index of -+ the element as first argument (counting from 0), and the element -+ itself as second argument. Not tail-recursive. -+ @since 3.13.0 -+*) -+ - val rev_map : ('a -> 'b) -> 'a list -> 'b list - (** [List.rev_map f l] gives the same result as - {!List.rev}[ (]{!List.map}[ f l)], but is tail-recursive and ---- obrowser-1.1.1-old/rt/caml/pervasives.mli 2013-06-20 13:50:19.000000000 +0200 -+++ obrowser-1.1.1/rt/caml/pervasives.mli 2013-06-20 13:50:59.000000000 +0200 -@@ -11,8 +11,6 @@ - (* *) - (***********************************************************************) - --(* $Id: pervasives.mli 10548 2010-06-09 10:26:19Z weis $ *) -- - (** The initially opened module. - - This module provides the basic operations over the built-in types -@@ -122,7 +120,7 @@ - (** The boolean negation. *) - - external ( && ) : bool -> bool -> bool = "%sequand" --(** The boolean ``and''. Evaluation is sequential, left-to-right: -+(** The boolean 'and'. Evaluation is sequential, left-to-right: - in [e1 && e2], [e1] is evaluated first, and if it returns [false], - [e2] is not evaluated at all. *) - -@@ -130,7 +128,7 @@ - (** @deprecated {!Pervasives.( && )} should be used instead. *) - - external ( || ) : bool -> bool -> bool = "%sequor" --(** The boolean ``or''. Evaluation is sequential, left-to-right: -+(** The boolean 'or'. Evaluation is sequential, left-to-right: - in [e1 || e2], [e1] is evaluated first, and if it returns [true], - [e2] is not evaluated at all. *) - -@@ -138,6 +136,20 @@ - (** @deprecated {!Pervasives.( || )} should be used instead.*) - - -+(** {6 Composition operators} *) -+ -+external ( |> ) : 'a -> ('a -> 'b) -> 'b = "%revapply" -+(** Reverse-application operator: [x |> f |> g] is exactly equivalent -+ to [g (f (x))]. -+ @since 4.01 -+*) -+ -+external ( @@ ) : ('a -> 'b) -> 'a -> 'b = "%apply" -+(** Application operator: [g @@ f @@ x] is exactly equivalent to -+ [g (f (x))]. -+ @since 4.01 -+*) -+ - (** {6 Integer arithmetic} *) - - (** Integers are 31 bits wide (or 63 bits on 64-bit processors). -@@ -234,7 +246,7 @@ - Floating-point operations never raise an exception on overflow, - underflow, division by zero, etc. Instead, special IEEE numbers - are returned as appropriate, such as [infinity] for [1.0 /. 0.0], -- [neg_infinity] for [-1.0 /. 0.0], and [nan] (``not a number'') -+ [neg_infinity] for [-1.0 /. 0.0], and [nan] ('not a number') - for [0.0 /. 0.0]. These special numbers then propagate through - floating-point computations as expected: for instance, - [1.0 /. infinity] is [0.0], and any arithmetic operation with [nan] -@@ -320,7 +332,7 @@ - of the hypotenuse of a right-angled triangle with sides of length - [x] and [y], or, equivalently, the distance of the point [(x,y)] - to origin. -- @since 3.13.0 *) -+ @since 4.00.0 *) - - external cosh : float -> float = "caml_cosh_float" "cosh" "float" - (** Hyperbolic cosine. Argument is in radians. *) -@@ -351,7 +363,7 @@ - and whose sign is that of [y]. If [x] is [nan], returns [nan]. - If [y] is [nan], returns either [x] or [-. x], but it is not - specified which. -- @since 3.13.0 *) -+ @since 4.00.0 *) - - external mod_float : float -> float -> float = "caml_fmod_float" "fmod" "float" - (** [mod_float a b] returns the remainder of [a] with respect to -@@ -395,7 +407,7 @@ - val nan : float - (** A special floating-point value denoting the result of an - undefined operation such as [0.0 /. 0.0]. Stands for -- ``not a number''. Any floating-point operation with [nan] as -+ 'not a number'. Any floating-point operation with [nan] as - argument returns [nan] as result. As for floating-point comparisons, - [=], [<], [<=], [>] and [>=] return [false] and [<>] returns [true] - if one or both of their arguments is [nan]. *) -@@ -461,7 +473,9 @@ - (** {6 String conversion functions} *) - - val string_of_bool : bool -> string --(** Return the string representation of a boolean. *) -+(** Return the string representation of a boolean. As the returned values -+ may be shared, the user should not modify them directly. -+*) - - val bool_of_string : string -> bool - (** Convert the given string to a boolean. -@@ -506,7 +520,9 @@ - (** List concatenation. *) - - --(** {6 Input/output} *) -+(** {6 Input/output} -+ Note: all input/output functions can raise [Sys_error] when the system -+ calls they invoke fail. *) - - type in_channel - (** The type of input channel. *) -@@ -864,23 +880,73 @@ - - (** {6 Operations on format strings} *) - --(** Format strings are used to read and print data using formatted input -- functions in module {!Scanf} and formatted output in modules {!Printf} and -- {!Format}. *) -+(** Format strings are character strings with special lexical conventions -+ that defines the functionality of formatted input/output functions. Format -+ strings are used to read data with formatted input functions from module -+ {!Scanf} and to print data with formatted output functions from modules -+ {!Printf} and {!Format}. -+ -+ Format strings are made of three kinds of entities: -+ - {e conversions specifications}, introduced by the special character ['%'] -+ followed by one or more characters specifying what kind of argument to -+ read or print, -+ - {e formatting indications}, introduced by the special character ['@'] -+ followed by one or more characters specifying how to read or print the -+ argument, -+ - {e plain characters} that are regular characters with usual lexical -+ conventions. Plain characters specify string literals to be read in the -+ input or printed in the output. -+ -+ There is an additional lexical rule to escape the special characters ['%'] -+ and ['@'] in format strings: if a special character follows a ['%'] -+ character, it is treated as a plain character. In other words, ["%%"] is -+ considered as a plain ['%'] and ["%@"] as a plain ['@']. -+ -+ For more information about conversion specifications and formatting -+ indications available, read the documentation of modules {!Scanf}, -+ {!Printf} and {!Format}. -+*) - - (** Format strings have a general and highly polymorphic type - [('a, 'b, 'c, 'd, 'e, 'f) format6]. Type [format6] is built in. - The two simplified types, [format] and [format4] below are -- included for backward compatibility with earlier releases of OCaml. -- ['a] is the type of the parameters of the format, -- ['b] is the type of the first argument given to -- [%a] and [%t] printing functions, -- ['c] is the type of the argument transmitted to the first argument of -- "kprintf"-style functions, -- ['d] is the result type for the "scanf"-style functions, -- ['e] is the type of the receiver function for the "scanf"-style functions, -- ['f] is the result type for the "printf"-style function. -- *) -+ included for backward compatibility with earlier releases of -+ OCaml. -+ -+ The meaning of format string type parameters is as follows: -+ -+ - ['a] is the type of the parameters of the format for formatted output -+ functions ([printf]-style functions); -+ ['a] is the type of the values read by the format for formatted input -+ functions ([scanf]-style functions). -+ -+ - ['b] is the type of input source for formatted input functions and the -+ type of output target for formatted output functions. -+ For [printf]-style functions from module [Printf], ['b] is typically -+ [out_channel]; -+ for [printf]-style functions from module [Format], ['b] is typically -+ [Format.formatter]; -+ for [scanf]-style functions from module [Scanf], ['b] is typically -+ [Scanf.Scanning.in_channel]. -+ -+ Type argument ['b] is also the type of the first argument given to -+ user's defined printing functions for [%a] and [%t] conversions, -+ and user's defined reading functions for [%r] conversion. -+ -+ - ['c] is the type of the result of the [%a] and [%t] printing -+ functions, and also the type of the argument transmitted to the -+ first argument of [kprintf]-style functions or to the -+ [kscanf]-style functions. -+ -+ - ['d] is the type of parameters for the [scanf]-style functions. -+ -+ - ['e] is the type of the receiver function for the [scanf]-style functions. -+ -+ - ['f] is the final result type of a formatted input/output function -+ invocation: for the [printf]-style functions, it is typically [unit]; -+ for the [scanf]-style functions, it is typically the result type of the -+ receiver function. -+*) - type ('a, 'b, 'c, 'd) format4 = ('a, 'b, 'c, 'c, 'c, 'd) format6 - - type ('a, 'b, 'c) format = ('a, 'b, 'c, 'c) format4 -@@ -892,14 +958,22 @@ - ('a, 'b, 'c, 'd, 'e, 'f) format6 -> - ('a, 'b, 'c, 'd, 'e, 'f) format6 = "%identity" - (** [format_of_string s] returns a format string read from the string -- literal [s]. *) -+ literal [s]. -+ Note: [format_of_string] can not convert a string argument that is not a -+ literal. If you need this functionality, use the more general -+ {!Scanf.format_from_string} function. -+*) - - val ( ^^ ) : - ('a, 'b, 'c, 'd, 'e, 'f) format6 -> - ('f, 'b, 'c, 'e, 'g, 'h) format6 -> - ('a, 'b, 'c, 'd, 'g, 'h) format6 --(** [f1 ^^ f2] catenates formats [f1] and [f2]. The result is a format -- that accepts arguments from [f1], then arguments from [f2]. *) -+(** [f1 ^^ f2] catenates format strings [f1] and [f2]. The result is a -+ format string that behaves as the concatenation of format strings [f1] and -+ [f2]: in case of formatted output, it accepts arguments from [f1], then -+ arguments from [f2]; in case of formatted input, it returns results from -+ [f1], then results from [f2]. -+*) - - - (** {6 Program termination} *) -@@ -918,13 +992,12 @@ - termination time. The functions registered with [at_exit] - will be called when the program executes {!Pervasives.exit}, - or terminates, either normally or because of an uncaught exception. -- The functions are called in ``last in, first out'' order: -+ The functions are called in 'last in, first out' order: - the function most recently added with [at_exit] is called first. *) - - (**/**) - -- --(** {6 For system use only, not for the casual user} *) -+(* The following is for system use only. Do not call directly. *) - - val valid_float_lexem : string -> string - ---- obrowser-1.1.1-old/rt/caml/pervasives.ml 2013-06-20 13:50:19.000000000 +0200 -+++ obrowser-1.1.1/rt/caml/pervasives.ml 2013-06-20 13:51:53.000000000 +0200 -@@ -1,6 +1,6 @@ - (***********************************************************************) - (* *) --(* Objective Caml *) -+(* OCaml *) - (* *) - (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) - (* *) -@@ -11,8 +11,6 @@ - (* *) - (***********************************************************************) - --(* $Id: pervasives.ml 9412 2009-11-09 11:42:39Z weis $ *) -- - (* type 'a option = None | Some of 'a *) - - (* Exceptions *) -@@ -24,66 +22,70 @@ - - exception Exit - -+(* Composition operators *) -+ -+external ( |> ) : 'a -> ('a -> 'b) -> 'b = "%revapply" -+external ( @@ ) : ('a -> 'b) -> 'a -> 'b = "%apply" -+ - (* 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 = "%mulint" --external (/) : int -> int -> int = "%divint" --external (mod) : int -> int -> int = "%modint" -+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" - - 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 32 = 1 then 31 else 63) (* obrowser mod: no tag bit*) -+let min_int = 1 lsl (if 1 lsl 31 = 0 then 30 else 62) - let max_int = min_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" -@@ -136,16 +138,16 @@ - | 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 *) - - external string_length : string -> int = "%string_length" --external string_create: int -> string = "caml_create_string" -+external string_create : int -> string = "caml_create_string" - external string_blit : string -> int -> string -> int -> int -> unit - = "caml_blit_string" "noalloc" - --let (^) s1 s2 = -+let ( ^ ) s1 s2 = - let l1 = string_length s1 and l2 = string_length s2 in - let s = string_create (l1 + l2) in - string_blit s1 0 s 0 l1; -@@ -170,8 +172,8 @@ - - (* 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" -@@ -187,7 +189,6 @@ - - module String = struct - external get : string -> int -> char = "%string_safe_get" -- external set : string -> int -> char -> unit = "%string_safe_set" - end - - let valid_float_lexem s = -@@ -195,7 +196,7 @@ - let rec loop i = - if i >= l then s ^ "." else - match s.[i] with -- | '0' .. '9' | '-' -> loop (i+1) -+ | '0' .. '9' | '-' -> loop (i + 1) - | _ -> s - in - loop 0 -@@ -207,7 +208,7 @@ - - (* List operations -- more in module List *) - --let rec (@) l1 l2 = -+let rec ( @ ) l1 l2 = - match l1 with - [] -> l2 - | hd :: tl -> hd :: (tl @ l2) -@@ -217,12 +218,13 @@ - type in_channel - type out_channel - --let open_descriptor_out _ = failwith "not implemented in obrowser" --let open_descriptor_in _ = failwith "not implemented in obrowser" -- --let stdin = Obj.magic 0 --let stdout = Obj.magic 0 --let stderr = Obj.magic 0 -+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 -+let stderr = open_descriptor_out 2 - - (* General output functions *) - -@@ -231,103 +233,184 @@ - | Open_creat | Open_trunc | Open_excl - | Open_binary | Open_text | Open_nonblock - --let open_desc _ _ _ = failwith "not implemented in obrowser" --let open_out_gen mode perm name = failwith "not implemented in obrowser" --let open_out name = failwith "not implemented in obrowser" --let open_out_bin name = failwith "not implemented in obrowser" --let flush _ = failwith "not implemented in obrowser" --let out_channels_list _ = failwith "not implemented in obrowser" --let flush_all () = failwith "not implemented in obrowser" --let unsafe_output _ _ _ _ = failwith "not implemented in obrowser" --let output_char _ _ = failwith "not implemented in obrowser" --let output_string oc s = failwith "not implemented in obrowser" --let output oc s ofs len = failwith "not implemented in obrowser" --let output_byte _ _ = failwith "not implemented in obrowser" --let output_binary_int _ _ = failwith "not implemented in obrowser" --let marshal_to_channel _ _ _ = failwith "not implemented in obrowser" --let output_value _ _ = failwith "not implemented in obrowser" --let seek_out _ _ = failwith "not implemented in obrowser" --let pos_out _ = failwith "not implemented in obrowser" --let out_channel_length _ = failwith "not implemented in obrowser" --let close_out_channel _ = failwith "not implemented in obrowser" --let close_out _ = failwith "not implemented in obrowser" --let close_out_noerr _ = failwith "not implemented in obrowser" --let set_binary_mode_out _ _ = failwith "not implemented in obrowser" -+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) -+ -+let open_out name = -+ open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_text] 0o666 name -+ -+let open_out_bin name = -+ open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_binary] 0o666 name -+ -+external flush : out_channel -> unit = "caml_ml_flush" -+ -+external out_channels_list : unit -> out_channel list -+ = "caml_ml_out_channels_list" -+ -+let flush_all () = -+ let rec iter = function -+ [] -> () -+ | a :: l -> (try flush a with _ -> ()); iter l -+ in iter (out_channels_list ()) -+ -+external unsafe_output : out_channel -> string -> int -> int -> unit -+ = "caml_ml_output" -+ -+external output_char : out_channel -> char -> unit = "caml_ml_output_char" -+ -+let output_string oc s = -+ unsafe_output oc s 0 (string_length s) -+ -+let output oc s ofs len = -+ if ofs < 0 || len < 0 || ofs > string_length s - len -+ then invalid_arg "output" -+ else unsafe_output 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" -+ -+external marshal_to_channel : out_channel -> 'a -> unit list -> unit -+ = "caml_output_value" -+let output_value chan v = marshal_to_channel chan v [] -+ -+external seek_out : out_channel -> int -> unit = "caml_ml_seek_out" -+external pos_out : out_channel -> int = "caml_ml_pos_out" -+external out_channel_length : out_channel -> int = "caml_ml_channel_size" -+external close_out_channel : out_channel -> unit = "caml_ml_close_channel" -+let close_out oc = flush oc; close_out_channel oc -+let close_out_noerr oc = -+ (try flush oc with _ -> ()); -+ (try close_out_channel oc with _ -> ()) -+external set_binary_mode_out : out_channel -> bool -> unit -+ = "caml_ml_set_binary_mode" - - (* General input functions *) - --let open_in_gen _ _ _ = failwith "not implemented in obrowser" --let open_in _ = failwith "not implemented in obrowser" --let open_in_bin _ = failwith "not implemented in obrowser" --let input_char _ = failwith "not implemented in obrowser" --let unsafe_input _ _ _ _ = failwith "not implemented in obrowser" --let input _ _ _ _ = failwith "not implemented in obrowser" --let rec unsafe_really_input _ _ _ _ = failwith "not implemented in obrowser" --let really_input _ _ _ _ = failwith "not implemented in obrowser" --let input_scan_line _ = failwith "not implemented in obrowser" --let input_line _ = failwith "not implemented in obrowser" -- --let input_byte _ = failwith "not implemented in obrowser" --let input_binary_int _ = failwith "not implemented in obrowser" --let input_value _ = failwith "not implemented in obrowser" --let seek_in _ _ = failwith "not implemented in obrowser" --let pos_in _ = failwith "not implemented in obrowser" --let in_channel_length _ = failwith "not implemented in obrowser" --let close_in _ = failwith "not implemented in obrowser" --let close_in_noerr _ = failwith "not implemented in obrowser" --let set_binary_mode_in _ _ = failwith "not implemented in obrowser" -+let open_in_gen mode perm name = -+ open_descriptor_in(open_desc name mode perm) - --(* Output functions on standard output *) -+let open_in name = -+ open_in_gen [Open_rdonly; Open_text] 0 name -+ -+let open_in_bin name = -+ open_in_gen [Open_rdonly; Open_binary] 0 name -+ -+external input_char : in_channel -> char = "caml_ml_input_char" -+ -+external unsafe_input : in_channel -> string -> int -> int -> int -+ = "caml_ml_input" -+ -+let input ic s ofs len = -+ if ofs < 0 || len < 0 || ofs > string_length s - len -+ then invalid_arg "input" -+ else unsafe_input ic s ofs len -+ -+let rec unsafe_really_input ic s ofs len = -+ if len <= 0 then () else begin -+ 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) -+ end - --external basic_io_write : string -> unit = "caml_basic_io_write" -+let really_input ic s ofs len = -+ if ofs < 0 || len < 0 || ofs > string_length s - len -+ then invalid_arg "really_input" -+ else unsafe_really_input ic s ofs len -+ -+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; -+ 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 -+ end else if n > 0 then begin (* n > 0: newline found in buffer *) -+ let res = string_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) -+ end else begin (* n < 0: newline not found *) -+ let beg = string_create (-n) in -+ ignore(unsafe_input chan beg 0 (-n)); -+ scan (beg :: accu) (len - n) -+ end -+ in scan [] 0 -+ -+external input_byte : in_channel -> int = "caml_ml_input_char" -+external input_binary_int : in_channel -> int = "caml_ml_input_int" -+external input_value : in_channel -> 'a = "caml_input_value" -+external seek_in : in_channel -> int -> unit = "caml_ml_seek_in" -+external pos_in : in_channel -> int = "caml_ml_pos_in" -+external in_channel_length : in_channel -> int = "caml_ml_channel_size" -+external close_in : in_channel -> unit = "caml_ml_close_channel" -+let close_in_noerr ic = (try close_in ic with _ -> ());; -+external set_binary_mode_in : in_channel -> bool -> unit -+ = "caml_ml_set_binary_mode" - --let print_char c = basic_io_write (let s = string_create 1 in s.[0] <- c ; s) --let print_string s = basic_io_write s --let print_int i = basic_io_write (string_of_int i) --let print_float f = basic_io_write (string_of_float f) -+(* Output functions on standard output *) -+ -+let print_char c = output_char stdout c -+let print_string s = output_string 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 = -- print_string s; print_char '\n' --let print_newline () = print_char '\n' -+ output_string stdout s; output_char stdout '\n'; flush stdout -+let print_newline () = output_char stdout '\n'; flush stdout - - (* Output functions on standard error *) - --let prerr_char c = basic_io_write (let s = string_create 1 in s.[0] <- c ; s) --let prerr_string s = basic_io_write s --let prerr_int i = basic_io_write (string_of_int i) --let prerr_float f = basic_io_write (string_of_float f) -+let prerr_char c = output_char stderr c -+let prerr_string s = output_string 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 = -- prerr_string s; prerr_char '\n' --let prerr_newline () = prerr_char '\n' -+ output_string stderr s; output_char stderr '\n'; flush stderr -+let prerr_newline () = output_char stderr '\n'; flush stderr - - (* Input functions on standard input *) - --let read_line () = failwith "not implemented in obrowser" --let read_int () = failwith "not implemented in obrowser" --let read_float () = failwith "not implemented in obrowser" -+let read_line () = flush stdout; input_line stdin -+let read_int () = int_of_string(read_line()) -+let read_float () = float_of_string(read_line()) - - (* Operations on large files *) - - module LargeFile = - struct -- let seek_out _ _ = failwith "not implemented in obrowser" -- let pos_out _ = failwith "not implemented in obrowser" -- let out_channel_length _ = failwith "not implemented in obrowser" -- let seek_in _ _ = failwith "not implemented in obrowser" -- let pos_in _ = failwith "not implemented in obrowser" -- let in_channel_length _ = failwith "not implemented in obrowser" -+ external seek_out : out_channel -> int64 -> unit = "caml_ml_seek_out_64" -+ external pos_out : out_channel -> int64 = "caml_ml_pos_out_64" -+ external out_channel_length : out_channel -> int64 -+ = "caml_ml_channel_size_64" -+ external seek_in : in_channel -> int64 -> unit = "caml_ml_seek_in_64" -+ external pos_in : in_channel -> int64 = "caml_ml_pos_in_64" -+ external in_channel_length : in_channel -> int64 = "caml_ml_channel_size_64" - end - - (* 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" - - (* Formats *) --type ('a, 'b, 'c, 'd) format4 = ('a, 'b, 'c, 'c, 'c, 'd) format6 -+type ('a, 'b, 'c, 'd) format4 = ('a, 'b, 'c, 'c, 'c, 'd) format6 - - type ('a, 'b, 'c) format = ('a, 'b, 'c, 'c) format4 - -@@ -345,7 +428,8 @@ - ('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);; -+ string_to_format (format_to_string fmt1 ^ "%," ^ format_to_string fmt2) -+;; - - let string_of_format fmt = - let s = format_to_string fmt in -@@ -358,7 +442,7 @@ - - external sys_exit : int -> 'a = "caml_sys_exit" - --let exit_function = ref (fun () -> ()) -+let exit_function = ref flush_all - - let at_exit f = - let g = !exit_function in ---- obrowser-1.1.1.orig/rt/caml/printexc.ml 2011-04-20 18:26:44.000000000 +0200 -+++ obrowser-1.1.1/rt/caml/printexc.ml 2013-08-13 15:54:35.000000000 +0200 -@@ -1,6 +1,6 @@ - (***********************************************************************) - (* *) --(* Objective Caml *) -+(* OCaml *) - (* *) - (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) - (* *) -@@ -11,8 +11,6 @@ - (* *) - (***********************************************************************) - --(* $Id: printexc.ml 10272 2010-04-19 12:25:46Z frisch $ *) -- - open Printf;; - - let printers = ref [] -@@ -56,9 +54,12 @@ - sprintf locfmt file line char (char+5) "Pattern matching failed" - | Assert_failure(file, line, char) -> - sprintf locfmt file line char (char+6) "Assertion failed" -+ | Undefined_recursive_module(file, line, char) -> -+ sprintf locfmt file line char (char+6) "Undefined recursive module" - | _ -> - let x = Obj.repr x in -- let constructor = (Obj.magic(Obj.field (Obj.field x 0) 0) : string) in -+ let constructor = -+ (Obj.magic (Obj.field (Obj.field x 0) 0) : string) in - constructor ^ (fields x) in - conv !printers - -@@ -78,6 +79,11 @@ - eprintf "Uncaught exception: %s\n" (to_string x); - exit 2 - -+type raw_backtrace -+ -+external get_raw_backtrace: -+ unit -> raw_backtrace = "caml_get_exception_raw_backtrace" -+ - type loc_info = - | Known_location of bool (* is_raise *) - * string (* filename *) -@@ -86,8 +92,13 @@ - * int (* end char *) - | Unknown_location of bool (*is_raise*) - --external get_exception_backtrace: -- unit -> loc_info array option = "caml_get_exception_backtrace" -+(* to avoid warning *) -+let _ = [Known_location (false, "", 0, 0, 0); Unknown_location false] -+ -+type backtrace = loc_info array -+ -+external convert_raw_backtrace: -+ raw_backtrace -> backtrace option = "caml_convert_raw_backtrace" - - let format_loc_info pos li = - let is_raise = -@@ -108,8 +119,8 @@ - sprintf "%s unknown location" - info - --let print_backtrace outchan = -- match get_exception_backtrace() with -+let print_exception_backtrace outchan backtrace = -+ match backtrace with - | None -> - fprintf outchan - "(Program not linked with -g, cannot print stack backtrace)\n" -@@ -119,8 +130,15 @@ - fprintf outchan "%s\n" (format_loc_info i a.(i)) - done - --let get_backtrace () = -- match get_exception_backtrace() with -+let print_raw_backtrace outchan raw_backtrace = -+ print_exception_backtrace outchan (convert_raw_backtrace raw_backtrace) -+ -+(* confusingly named: prints the global current backtrace *) -+let print_backtrace outchan = -+ print_raw_backtrace outchan (get_raw_backtrace ()) -+ -+let backtrace_to_string backtrace = -+ match backtrace with - | None -> - "(Program not linked with -g, cannot print stack backtrace)\n" - | Some a -> -@@ -131,8 +149,22 @@ - done; - Buffer.contents b - -+let raw_backtrace_to_string raw_backtrace = -+ backtrace_to_string (convert_raw_backtrace raw_backtrace) -+ -+(* 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" - 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" ---- obrowser-1.1.1.orig/rt/caml/printexc.mli 2011-04-20 18:26:44.000000000 +0200 -+++ obrowser-1.1.1/rt/caml/printexc.mli 2013-08-13 15:54:40.000000000 +0200 -@@ -1,6 +1,6 @@ - (***********************************************************************) - (* *) --(* Objective Caml *) -+(* OCaml *) - (* *) - (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) - (* *) -@@ -11,9 +11,7 @@ - (* *) - (***********************************************************************) - --(* $Id: printexc.mli 10457 2010-05-21 18:30:12Z doligez $ *) -- --(** Facilities for printing exceptions. *) -+(** Facilities for printing exceptions and inspecting current call stack. *) - - val to_string: exn -> string - (** [Printexc.to_string e] returns a string representation of -@@ -77,5 +75,40 @@ - in the reverse order of their registrations, until a printer returns - a [Some s] value (if no such printer exists, the runtime will use a - generic printer). -+ -+ When using this mechanism, one should be aware that an exception backtrace -+ is attached to the thread that saw it raised, rather than to the exception -+ itself. Practically, it means that the code related to [fn] should not use -+ the backtrace if it has itself raised an exception before. - @since 3.11.2 - *) -+ -+(** {6 Raw backtraces} *) -+ -+type raw_backtrace -+ -+(** The abstract type [backtrace] stores exception backtraces in -+ a low-level format, instead of directly exposing them as string as -+ the [get_backtrace()] function does. -+ -+ This allows to pay the performance overhead of representation -+ conversion and formatting only at printing time, which is useful -+ if you want to record more backtrace than you actually print. -+*) -+ -+val get_raw_backtrace: unit -> raw_backtrace -+val print_raw_backtrace: out_channel -> raw_backtrace -> unit -+val raw_backtrace_to_string: raw_backtrace -> string -+ -+ -+(** {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 -+ exceptions at all, despite being part of the [Printexc] module.) -+ -+ @since 4.01.0 -+*) ---- obrowser-1.1.1/rt/caml/pervasives.mli 2013-11-27 09:51:32.000000000 +0100 -+++ /usr/local/ocaml/trunk/lib/ocaml/pervasives.mli 2013-11-26 19:03:11.000000000 +0100 -@@ -28,6 +28,11 @@ - external raise : exn -> 'a = "%raise" - (** Raise the given exception value *) - -+external raise_notrace : exn -> 'a = "%raise_notrace" -+(** A faster version [raise] which does not record the backtrace. -+ @since 4.02.0 -+*) -+ - val invalid_arg : string -> 'a - (** Raise exception [Invalid_argument] with the given string. *) - ---- obrowser-1.1.1/rt/caml/pervasives.ml 2013-11-27 14:25:40.000000000 +0100 -+++ /usr/local/ocaml/trunk/lib/ocaml/pervasives.ml 2013-11-26 19:03:11.000000000 +0100 -@@ -15,7 +15,17 @@ - - (* Exceptions *) - -+external register_named_value : string -> 'a -> unit -+ = "caml_register_named_value" -+ -+let () = -+ (* for asmrun/fail.c *) -+ 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" - - let failwith s = raise(Failure s) - let invalid_arg s = raise(Invalid_argument s) -@@ -454,7 +464,4 @@ - do_at_exit (); - sys_exit retcode - --external register_named_value : string -> 'a -> unit -- = "caml_register_named_value" -- - let _ = register_named_value "Pervasives.do_at_exit" do_at_exit ---- obrowser-1.1.1/rt/caml/printexc.mli 2013-11-27 14:26:19.000000000 +0100 -+++ /usr/local/ocaml/trunk/lib/ocaml/printexc.mli 2013-11-26 19:03:11.000000000 +0100 -@@ -112,3 +112,23 @@ - - @since 4.01.0 - *) -+ -+ -+(** {6 Exception slots} *) -+ -+val exn_slot_id: exn -> int -+(** [Printexc.exn_slot_id] returns an integer which uniquely identifies -+ the constructor used to create the exception value [exn] -+ (in the current runtime). -+ -+ @since 4.02.0 -+*) -+ -+val exn_slot_name: exn -> string -+(** [Printexc.exn_slot_id exn] returns the internal name of the constructor -+ used to create the exception value [exn]. -+ -+ @since 4.02.0 -+*) -+ -+ ---- obrowser-1.1.1/rt/caml/printexc.ml 2013-11-27 14:27:37.000000000 +0100 -+++ /usr/local/ocaml/trunk/lib/ocaml/printexc.ml 2013-11-26 19:03:11.000000000 +0100 -@@ -58,9 +58,12 @@ - sprintf locfmt file line char (char+6) "Undefined recursive module" - | _ -> - let x = Obj.repr x in -- let constructor = -- (Obj.magic (Obj.field (Obj.field x 0) 0) : string) in -- constructor ^ (fields x) in -+ if Obj.tag x <> 0 then -+ (Obj.magic (Obj.field x 0) : string) -+ else -+ let constructor = -+ (Obj.magic (Obj.field (Obj.field x 0) 0) : string) in -+ constructor ^ (fields x) in - conv !printers - - let print fct arg = -@@ -168,3 +171,16 @@ - - - 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 -+ -+let exn_slot_id x = -+ let slot = exn_slot x in -+ (Obj.obj (Obj.field slot 1) : int) -+ -+let exn_slot_name x = -+ let slot = exn_slot x in -+ (Obj.obj (Obj.field slot 0) : string) ---- obrowser-1.1.1/rt/caml/list.mli 2013-11-27 14:28:14.000000000 +0100 -+++ /usr/local/ocaml/trunk/lib/ocaml/list.mli 2013-11-26 19:03:11.000000000 +0100 -@@ -280,6 +278,9 @@ - (** Same as {!List.sort} or {!List.stable_sort}, whichever is faster - on typical input. *) - -+val sort_uniq : ('a -> 'a -> int) -> 'a list -> 'a list -+(** Same as {!List.sort}, but also remove duplicates. *) -+ - val merge : ('a -> 'a -> int) -> 'a list -> 'a list -> 'a list - (** Merge two lists: - Assuming that [l1] and [l2] are sorted according to the ---- obrowser-1.1.1/rt/caml/list.ml 2013-11-27 14:29:31.000000000 +0100 -+++ /usr/local/ocaml/trunk/lib/ocaml/list.ml 2013-11-26 19:03:11.000000000 +0100 -@@ -326,3 +324,106 @@ - array_to_list_in_place a - ;; - *) -+ -+ -+(** sorting + removing duplicates *) -+ -+let sort_uniq cmp l = -+ let rec rev_merge l1 l2 accu = -+ match l1, l2 with -+ | [], l2 -> rev_append l2 accu -+ | l1, [] -> rev_append l1 accu -+ | h1::t1, h2::t2 -> -+ let c = cmp h1 h2 in -+ if c = 0 then rev_merge t1 t2 (h1::accu) -+ else if c < 0 -+ then rev_merge t1 l2 (h1::accu) -+ else rev_merge l1 t2 (h2::accu) -+ in -+ let rec rev_merge_rev l1 l2 accu = -+ match l1, l2 with -+ | [], l2 -> rev_append l2 accu -+ | l1, [] -> rev_append l1 accu -+ | h1::t1, h2::t2 -> -+ let c = cmp h1 h2 in -+ if c = 0 then rev_merge_rev t1 t2 (h1::accu) -+ else if c > 0 -+ then rev_merge_rev t1 l2 (h1::accu) -+ else rev_merge_rev l1 t2 (h2::accu) -+ in -+ let rec sort n l = -+ match n, l with -+ | 2, x1 :: x2 :: _ -> -+ let c = cmp x1 x2 in -+ if c = 0 then [x1] -+ else if c < 0 then [x1; x2] else [x2; x1] -+ | 3, x1 :: x2 :: x3 :: _ -> -+ let c = cmp x1 x2 in -+ if c = 0 then begin -+ let c = cmp x2 x3 in -+ if c = 0 then [x2] -+ else if c < 0 then [x2; x3] else [x3; x2] -+ end else if c < 0 then begin -+ let c = cmp x2 x3 in -+ if c = 0 then [x1; x2] -+ else if c < 0 then [x1; x2; x3] -+ else let c = cmp x1 x3 in -+ if c = 0 then [x1; x2] -+ else if c < 0 then [x1; x3; x2] -+ else [x3; x1; x2] -+ end else begin -+ let c = cmp x1 x3 in -+ if c = 0 then [x2; x1] -+ else if c < 0 then [x2; x1; x3] -+ else let c = cmp x2 x3 in -+ if c = 0 then [x2; x1] -+ else if c < 0 then [x2; x3; x1] -+ else [x3; x2; x1] -+ end -+ | n, l -> -+ let n1 = n asr 1 in -+ let n2 = n - n1 in -+ let l2 = chop n1 l in -+ let s1 = rev_sort n1 l in -+ let s2 = rev_sort n2 l2 in -+ rev_merge_rev s1 s2 [] -+ and rev_sort n l = -+ match n, l with -+ | 2, x1 :: x2 :: _ -> -+ let c = cmp x1 x2 in -+ if c = 0 then [x1] -+ else if c > 0 then [x1; x2] else [x2; x1] -+ | 3, x1 :: x2 :: x3 :: _ -> -+ let c = cmp x1 x2 in -+ if c = 0 then begin -+ let c = cmp x2 x3 in -+ if c = 0 then [x2] -+ else if c > 0 then [x2; x3] else [x3; x2] -+ end else if c > 0 then begin -+ let c = cmp x2 x3 in -+ if c = 0 then [x1; x2] -+ else if c > 0 then [x1; x2; x3] -+ else let c = cmp x1 x3 in -+ if c = 0 then [x1; x2] -+ else if c > 0 then [x1; x3; x2] -+ else [x3; x1; x2] -+ end else begin -+ let c = cmp x1 x3 in -+ if c = 0 then [x2; x1] -+ else if c > 0 then [x2; x1; x3] -+ else let c = cmp x2 x3 in -+ if c = 0 then [x2; x1] -+ else if c > 0 then [x2; x3; x1] -+ else [x3; x2; x1] -+ end -+ | n, l -> -+ let n1 = n asr 1 in -+ let n2 = n - n1 in -+ let l2 = chop n1 l in -+ let s1 = sort n1 l in -+ let s2 = sort n2 l2 in -+ rev_merge s1 s2 [] -+ in -+ let len = length l in -+ if len < 2 then l else sort len l -+;; diff --git a/testsuite/external/ocaml-bitstring-2.0.3.patch b/testsuite/external/ocaml-bitstring-2.0.3.patch deleted file mode 100644 index b73bca1359..0000000000 --- a/testsuite/external/ocaml-bitstring-2.0.3.patch +++ /dev/null @@ -1,11 +0,0 @@ ---- ocaml-bitstring-2.0.3/Makefile.in.orig 2013-04-04 17:42:45.000000000 +0200 -+++ ocaml-bitstring-2.0.3/Makefile.in 2013-04-04 17:43:06.000000000 +0200 -@@ -123,7 +123,7 @@ - - byteswap.h: byteswap.in.h - { echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \ -- cat $(srcdir)/byteswap.in.h; \ -+ cat byteswap.in.h; \ - } > $@-t - mv -f $@-t $@ - diff --git a/testsuite/external/ocaml-mysql-1.0.4.patch.disabled b/testsuite/external/ocaml-mysql-1.0.4.patch.disabled deleted file mode 100644 index 82da79dfe6..0000000000 --- a/testsuite/external/ocaml-mysql-1.0.4.patch.disabled +++ /dev/null @@ -1,15 +0,0 @@ ---- ocaml-mysql-1.0.4.orig/mysql_stubs.c 2006-02-24 00:12:36.000000000 +0100 -+++ ocaml-mysql-1.0.4/mysql_stubs.c 2012-08-09 20:51:24.000000000 +0200 -@@ -19,9 +19,9 @@ - - /* MySQL API */ - --#include <mysql/mysql.h> --#include <mysql/mysqld_error.h> --#include <mysql/errmsg.h> -+#include <mysql.h> -+#include <mysqld_error.h> -+#include <errmsg.h> - /* type 'a option = None | Some of 'a */ - - #define NONE Val_int(0) diff --git a/testsuite/external/ocamlnet-3.5.1.patch b/testsuite/external/ocamlnet-3.5.1.patch deleted file mode 100644 index 46884d2117..0000000000 --- a/testsuite/external/ocamlnet-3.5.1.patch +++ /dev/null @@ -1,52 +0,0 @@ ---- ocamlnet-3.5.1.orig/src/netsys/netsys_posix.ml 2011-10-12 14:09:05.000000000 +0200 -+++ ocamlnet-3.5.1/src/netsys/netsys_posix.ml 2012-01-12 19:33:39.000000000 +0100 -@@ -412,9 +412,11 @@ - type at_flag = AT_EACCESS | AT_SYMLINK_NOFOLLOW | AT_REMOVEDIR - - (* The stubs assume these type definitions: *) -+(* In fact, they don't: they assume OCaml's stdlib definition - type open_flag1 = Unix.open_flag = - O_RDONLY | O_WRONLY | O_RDWR | O_NONBLOCK | O_APPEND | O_CREAT | O_TRUNC - | O_EXCL | O_NOCTTY | O_DSYNC | O_SYNC | O_RSYNC -+*) - - type access_permission1 = Unix.access_permission = - R_OK | W_OK | X_OK | F_OK ---- ocamlnet-3.5.1.orig/src/netstring/Makefile.def 2012-02-29 19:02:52.000000000 +0100 -+++ ocamlnet-3.5.1/src/netstring/Makefile.def 2012-05-25 16:59:56.000000000 +0200 -@@ -13,7 +13,7 @@ - PKGNAME = netstring - - REQUIRES = $(REGEXP_PROVIDER) bigarray --INCLUDES += $(INC_NETSYS) -+INCLUDES += $(INC_NETSYS) -I +compiler-libs - - ISO_MAPPINGS = mappings/iso*.unimap - JP_MAPPINGS = mappings/jis*.*map ---- ocamlnet-3.5.1.orig/src/pop/netpop.ml 2012-02-29 19:02:53.000000000 +0100 -+++ ocamlnet-3.5.1/src/pop/netpop.ml 2013-06-20 14:06:11.000000000 +0200 -@@ -231,6 +231,7 @@ - status_response ic parse_line (Hashtbl.create 1) - with _ -> raise Protocol_error - -+(* - method stat () = - self#check_state `Transaction; - send_command oc "STAT"; -@@ -242,4 +243,5 @@ - (count, size, ext) - ) - with _ -> raise Protocol_error; -+*) - end ---- ocamlnet-3.5.1/src/netstring/netencoding.mli.orig 2013-11-27 14:41:37.000000000 +0100 -+++ ocamlnet-3.5.1/src/netstring/netencoding.mli 2013-11-27 14:41:52.000000000 +0100 -@@ -120,7 +120,7 @@ - * to ensure that all output lines have a length <= 76 bytes. - * - * Note unsafe characters: -- * As recommended by RFC 2045, the characters [!#$\@[]^`{|}~] -+ * As recommended by RFC 2045, the characters [!#$\@[]^`{}|~] - * and the double quotes - * are additionally represented as hex tokens. - * Furthermore, the letter 'F' is considered as unsafe if it diff --git a/testsuite/external/ocsigen-bundle-2.2.2.patch b/testsuite/external/ocsigen-bundle-2.2.2.patch deleted file mode 100644 index b947999a69..0000000000 --- a/testsuite/external/ocsigen-bundle-2.2.2.patch +++ /dev/null @@ -1,47 +0,0 @@ -diff -u -r ocsigen-bundle-2.2.2.orig/pkg/Makefile.lwt ocsigen-bundle-2.2.2/pkg/Makefile.lwt ---- ocsigen-bundle-2.2.2.orig/pkg/Makefile.lwt 2011-12-20 16:13:24.000000000 +0100 -+++ ocsigen-bundle-2.2.2/pkg/Makefile.lwt 2011-12-29 00:34:27.000000000 +0100 -@@ -70,7 +70,7 @@ - - ${METAS}/META.lwt: ${LWT_DIR}/src/core/META - echo "directory = \"${srcdir}/${LWT_DIR}/_build/src/core\"" > $@ -- sed -e 's%^package "\([^\"]*\)" (%package "\1" (\n directory = "../\1"%g' \ -+ sed -e 's%^package "\([^\"]*\)" (%package "\1" ( directory = "../\1"%g' \ - -e 's%../syntax%../../syntax%' \ - $< >> $@ - -diff -u -r ocsigen-bundle-2.2.2.orig/pkg/Makefile.ocsimore ocsigen-bundle-2.2.2/pkg/Makefile.ocsimore ---- ocsigen-bundle-2.2.2.orig/pkg/Makefile.ocsimore 2011-12-20 16:13:24.000000000 +0100 -+++ ocsigen-bundle-2.2.2/pkg/Makefile.ocsimore 2011-12-29 00:34:51.000000000 +0100 -@@ -37,8 +37,8 @@ - - ${METAS}/META.ocsimore: ${OCSIMORE_DIR}/src/core/META - echo "directory = \"${srcdir}/${OCSIMORE_DIR}/_build/src/core\"" > $@ -- sed -e 's%^package "\([^\"]*\(user\|wiki\|site\|forum\)\)" (%package "\1" (\n directory = "../\2"%g' \ -- -e 's%^package "site_client" (%package "site_client" (\n directory = "../site/client"%g' \ -+ sed -e 's%^package "\([^\"]*\(user\|wiki\|site\|forum\)\)" (%package "\1" ( directory = "../\2"%g' \ -+ -e 's%^package "site_client" (%package "site_client" ( directory = "../site/client"%g' \ - $< >> $@ - - -diff -u -r ocsigen-bundle-2.2.2.orig/pkg/Makefile.tyxml ocsigen-bundle-2.2.2/pkg/Makefile.tyxml ---- ocsigen-bundle-2.2.2.orig/pkg/Makefile.js_of_ocaml 2011-12-20 16:13:24.000000000 +0100 -+++ ocsigen-bundle-2.2.2/pkg/Makefile.js_of_ocaml 2011-12-29 01:47:00.000000000 +0100 -@@ -47,5 +47,5 @@ - - ${METAS}/META.js_of_ocaml: ${JS_OF_OCAML_DIR}/lib/META - echo "directory = \"${srcdir}/${JS_OF_OCAML_DIR}/lib\"" > $@ -- sed -e 's%package "syntax" (%package "syntax" (\n directory = "syntax"%g' \ -+ sed -e 's%package "syntax" (%package "syntax" ( directory = "syntax"%g' \ - $< >> $@ ---- ocsigen-bundle-2.2.2/configure.orig 2012-05-25 18:33:10.000000000 +0200 -+++ ocsigen-bundle-2.2.2/configure 2012-05-25 18:33:24.000000000 +0200 -@@ -11051,7 +11051,7 @@ - - - --build_projects="deriving-ocsigen lwt js_of_ocaml tyxml ocsigenserver eliom" -+build_projects="deriving-ocsigen js_of_ocaml tyxml ocsigenserver" - if test $enable_ocsimore = yes ; then : - build_projects+=" ocsimore" - fi diff --git a/testsuite/external/omake-0.9.8.6.patch b/testsuite/external/omake-0.9.8.6.patch deleted file mode 100644 index 9fd8a7a01d..0000000000 --- a/testsuite/external/omake-0.9.8.6.patch +++ /dev/null @@ -1,11 +0,0 @@ ---- omake-0.9.8.6.orig/lib/build/OCaml.om 2008-03-05 02:07:25.000000000 +0100 -+++ omake-0.9.8.6/lib/build/OCaml.om 2011-05-02 22:53:23.000000000 +0200 -@@ -176,7 +176,7 @@ - # - declare OCAMLDEPFLAGS - public.OCAMLPPFLAGS = --public.OCAMLFLAGS = -warn-error A -+public.OCAMLFLAGS = -warn-error a - public.OCAMLCFLAGS = -g - public.OCAMLOPTFLAGS = - public.OCAMLCPPFLAGS = diff --git a/testsuite/external/sks-1.1.3.patch b/testsuite/external/sks-1.1.3.patch deleted file mode 100644 index d59953402a..0000000000 --- a/testsuite/external/sks-1.1.3.patch +++ /dev/null @@ -1,20 +0,0 @@ -diff -N -r -u sks-1.1.3.orig/Makefile.local sks-1.1.3/Makefile.local ---- sks-1.1.3.orig/Makefile.local 1970-01-01 01:00:00.000000000 +0100 -+++ sks-1.1.3/Makefile.local 2010-05-17 14:49:16.000000000 +0200 -@@ -0,0 +1,5 @@ -+LIBDB=-ldb -+MANDIR=${PREFIX}/share/man -+export PREFIX -+export LIBDB -+export MANDIR ---- sks-1.1.3.orig/Makefile 2012-04-11 04:03:25.000000000 +0200 -+++ sks-1.1.3/Makefile 2013-05-30 14:40:03.000000000 +0200 -@@ -47,7 +47,7 @@ - - CAMLP4=-pp $(CAMLP4O) - CAMLINCLUDE= -I lib -I bdb --COMMONCAMLFLAGS=$(CAMLINCLUDE) $(OCAMLLIB) -ccopt -Lbdb -dtypes -ccopt -pthread -ccopt -pg -warn-error A -+COMMONCAMLFLAGS=$(CAMLINCLUDE) $(OCAMLLIB) -ccopt -Lbdb -dtypes -ccopt -pthread -ccopt -pg -warn-error a - OCAMLDEP=ocamldep $(CAMLP4) - CAMLLIBS=unix.cma str.cma bdb.cma nums.cma bigarray.cma cryptokit.cma - OCAMLFLAGS=$(COMMONCAMLFLAGS) -g $(CAMLLIBS) diff --git a/testsuite/external/vsyml-2010-04-06.patch b/testsuite/external/vsyml-2010-04-06.patch deleted file mode 100644 index a688e7a56e..0000000000 --- a/testsuite/external/vsyml-2010-04-06.patch +++ /dev/null @@ -1,20 +0,0 @@ ---- vsyml-2010-04-06.orig/makefile 2010-04-06 19:28:25.000000000 +0200 -+++ vsyml-2010-04-06/makefile 2010-08-23 15:16:22.000000000 +0200 -@@ -525,13 +525,13 @@ - - # dependencies for the symbolic simulator main file on cmo cma cmx and cmxa - $(VSYML_CMO_LST): $(VSYML_MAIN) -- echo -n "VSYML_CMO=" > $@ -- for i in `grep -o -e '[a-zA-Z0-9_]*\.cmo' $<` ; do echo -n $$i " " >> $@ ; done -+ echo "VSYML_CMO=" | tr -d '\012' > $@ -+ for i in `grep -o -e '[a-zA-Z0-9_]*\.cmo' $<` ; do echo $$i " " | tr -d '\012' >> $@ ; done - echo $(patsubst $(SRC_PATH)$(PATH_SEPARATOR)%.ml,%.cmo,$<) >> $@ - - $(VSYML_CMA_LST): $(VSYML_MAIN) -- echo -n "VSYML_CMA=" > $@ -- for i in `grep -o -e '[a-zA-Z0-9_]*\.cma' $<` ; do echo -n $$i " " >> $@ ; done -+ echo "VSYML_CMA=" | tr -d '\012' > $@ -+ for i in `grep -o -e '[a-zA-Z0-9_]*\.cma' $<` ; do echo $$i " " | tr -d '\012' >> $@ ; done - - $(VSYML_BYTE_CMO_LST): $(VSYML_CMO_LST) - sed -e 's@\([a-zA-Z0-9_]*\)\.cmo@$(BYTE_PATH)$(PATH_SEPARATOR)\1.cmo@g' -e 's/VSYML_CMO/VSYML_BYTE_CMO/' $< > $@ diff --git a/testsuite/external/xml-light-2.2.patch b/testsuite/external/xml-light-2.2.patch deleted file mode 100644 index 62351908ef..0000000000 --- a/testsuite/external/xml-light-2.2.patch +++ /dev/null @@ -1,19 +0,0 @@ ---- xml-light/Makefile 2003-10-12 11:16:12.000000000 +0200 -+++ xml-light-2.2/Makefile 2010-01-23 20:57:57.000000000 +0100 -@@ -2,7 +2,7 @@ - # http://tech.motion-twin.com
- .SUFFIXES : .ml .mli .cmo .cmx .cmi .mll .mly
-
--INSTALLDIR=`ocamlc -where`
-+INSTALLDIR=`ocamlc -where`/xml-light
- CFLAGS=
- LFLAGS= -a
- LIBS=
-@@ -12,6 +12,7 @@ - opt: xml-light.cmxa test_opt.exe
-
- install: all opt
-+ mkdir -p "${INSTALLDIR}"
- cp xml-light.cmxa xml-light.a xml-light.cma xml.mli xmlParser.mli dtd.mli xml.cmi xmlParser.cmi dtd.cmi xml.cmx dtd.cmx xmlParser.cmx $(INSTALLDIR)
-
- doc:
diff --git a/testsuite/makefiles/Makefile.dlambda b/testsuite/makefiles/Makefile.dlambda new file mode 100644 index 0000000000..eebf858c5e --- /dev/null +++ b/testsuite/makefiles/Makefile.dlambda @@ -0,0 +1,31 @@ +######################################################################### +# # +# 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. # +# # +######################################################################### + +# To avoid tests breaking each time the internal name generation +# changes, we strip -dlambda-produced identifiers of their unique +# identifier: "x/1234" becomes simply "x". + +default: + @for file in *.ml; do \ + $(OCAMLC) -dlambda -c $$file 2>&1 | \ + sed -e "s|\\([A-Za-z_][A-Za-z_']*\)/[0-9][0-9]*|\\1|g" > $$file.result; \ + done + @for file in *.reference; do \ + printf " ... testing '$$file':"; \ + $(DIFF) $$file `basename $$file reference`result >/dev/null \ + && echo " => passed" || echo " => failed"; \ + done + +promote: defaultpromote + +clean: defaultclean + @rm -f *.result diff --git a/testsuite/makefiles/Makefile.dparsetree b/testsuite/makefiles/Makefile.dparsetree new file mode 100644 index 0000000000..9e219be01b --- /dev/null +++ b/testsuite/makefiles/Makefile.dparsetree @@ -0,0 +1,27 @@ +######################################################################### +# # +# OCaml # +# # +# Xavier Clerc, SED, INRIA Rocquencourt # +# Jeremie Dimino, Jane Street Europe # +# # +# 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. # +# # +######################################################################### + +default: + @for file in *.ml; do \ + $(OCAMLC) -dparsetree -c $$file 2>$$file.result >/dev/null || true; \ + done + @for file in *.reference; do \ + printf " ... testing '$$file':"; \ + $(DIFF) $$file `basename $$file reference`result >/dev/null \ + && echo " => passed" || echo " => failed"; \ + done + +promote: defaultpromote + +clean: defaultclean + @rm -f *.result diff --git a/testsuite/makefiles/Makefile.one b/testsuite/makefiles/Makefile.one index 9f95b3656d..11c227ee4c 100644 --- a/testsuite/makefiles/Makefile.one +++ b/testsuite/makefiles/Makefile.one @@ -48,7 +48,8 @@ compile: $(ML_FILES) $(CMO_FILES) $(MAIN_MODULE).cmo @if $(BYTECODE_ONLY); then : ; else \ rm -f program.native program.native.exe; \ $(MAKE) $(CMX_FILES) $(MAIN_MODULE).cmx; \ - $(OCAMLOPT) $(ADD_COMPFLAGS) -o program.native$(EXE) $(O_FILES) \ + $(OCAMLOPT) $(ADD_COMPFLAGS) $(ADD_OPTCOMPFLAGS) \ + -o program.native$(EXE) $(O_FILES) \ $(CMXA_FILES) $(CMX_FILES) $(ADD_CMX_FILES) \ $(MAIN_MODULE).cmx; \ fi diff --git a/testsuite/makefiles/Makefile.several b/testsuite/makefiles/Makefile.several index 3482e3af30..541046306a 100644 --- a/testsuite/makefiles/Makefile.several +++ b/testsuite/makefiles/Makefile.several @@ -16,15 +16,17 @@ CMO_FILES=$(MODULES:=.cmo) CMX_FILES=$(MODULES:=.cmx) CMA_FILES=$(LIBRARIES:=.cma) CMXA_FILES=$(LIBRARIES:=.cmxa) -O_FILES=$(C_FILES:=.o) +O_FILES=$(F_FILES:=.o) $(C_FILES:=.o) CUSTOM_FLAG=`if [ -n "$(C_FILES)" ]; then echo '-custom'; fi` ADD_CFLAGS+=$(CUSTOM_FLAG) MYRUNTIME=`if [ -z "$(C_FILES)$(CUSTOM)" ]; then echo '$(OCAMLRUN)'; fi` -FORTRAN_LIB=`if [ -n "$(F_FILES)" ]; then echo '$(FORTRAN_LIBRARY)'; fi` +FORTRAN_LIB=`if [ -n "$(F_FILES)" ]; then echo $(FORTRAN_LIBRARY); fi` ADD_CFLAGS+=$(FORTRAN_LIB) ADD_OPTFLAGS+=$(FORTRAN_LIB) +C_INCLUDES+=-I $(CTOPDIR)/byterun -I$(CTOPDIR)/otherlibs/bigarray + .PHONY: check check: @if [ -n "$(FORTRAN_COMPILER)" -o -z "$(F_FILES)" ]; then \ @@ -34,10 +36,10 @@ check: .PHONY: run-all run-all: @for file in $(C_FILES); do \ - $(CC) -c -I$(PREFIX)/lib/ocaml/caml $$file.c; \ + $(CC) $(C_INCLUDES) -c $$file.c; \ done; @for file in $(F_FILES); do \ - $(FORTRAN_COMPILER) -c -I$(PREFIX)/lib/ocaml/caml $$file.f; \ + $(FORTRAN_COMPILER) -c $$file.f; \ done; @for file in *.ml; do \ if [ -f `basename $$file ml`precheck ]; then \ diff --git a/testsuite/makefiles/Makefile.toplevel b/testsuite/makefiles/Makefile.toplevel index 46acb3d78c..284465fe92 100644 --- a/testsuite/makefiles/Makefile.toplevel +++ b/testsuite/makefiles/Makefile.toplevel @@ -12,10 +12,10 @@ default: @for file in *.ml; do \ - $(OCAML) $(TOPFLAGS) <$$file 2>&1 \ + TERM=dumb $(OCAML) $(TOPFLAGS) <$$file 2>&1 \ | grep -v '^ OCaml version' > $$file.result; \ if [ -f $$file.principal.reference ]; then \ - $(OCAML) $(TOPFLAGS) -principal <$$file 2>&1 \ + TERM=dumb $(OCAML) $(TOPFLAGS) -principal <$$file 2>&1 \ | grep -v '^ OCaml version' > $$file.principal.result; \ fi; \ done diff --git a/testsuite/tests/asmcomp/Makefile b/testsuite/tests/asmcomp/Makefile index 501d0594d3..ef9bdd5eee 100644 --- a/testsuite/tests/asmcomp/Makefile +++ b/testsuite/tests/asmcomp/Makefile @@ -35,8 +35,8 @@ default: fi all: - $(MAKE) arch codegen - $(MAKE) tests + @$(MAKE) arch codegen + @$(MAKE) tests codegen: parsecmm.ml lexcmm.ml $(OBJS:.cmo=.cmi) $(OBJS) main.cmo @$(OCAMLC) $(LINKFLAGS) -o codegen $(OTHEROBJS) $(OBJS) main.cmo diff --git a/testsuite/tests/asmcomp/mainarith.c b/testsuite/tests/asmcomp/mainarith.c index d102c16dc3..94ff371e3c 100644 --- a/testsuite/tests/asmcomp/mainarith.c +++ b/testsuite/tests/asmcomp/mainarith.c @@ -16,7 +16,7 @@ #include <stdlib.h> #include <string.h> -#include "../../../byterun/config.h" +#include "../../../byterun/caml/config.h" #define FMT ARCH_INTNAT_PRINTF_FORMAT void caml_ml_array_bound_error(void) diff --git a/testsuite/tests/asmcomp/sparc.S b/testsuite/tests/asmcomp/sparc.S index ea029573a0..f2b9ce2073 100644 --- a/testsuite/tests/asmcomp/sparc.S +++ b/testsuite/tests/asmcomp/sparc.S @@ -10,7 +10,7 @@ /* */ /***********************************************************************/ -#if defined(SYS_solaris) || defined(SYS_elf) +#if defined(SYS_solaris) || defined(SYS_linux) #define Call_gen_code call_gen_code #define Caml_c_call caml_c_call #else diff --git a/testsuite/tests/backtrace/Makefile b/testsuite/tests/backtrace/Makefile index 33ca1ed8bc..1d638f5427 100644 --- a/testsuite/tests/backtrace/Makefile +++ b/testsuite/tests/backtrace/Makefile @@ -19,7 +19,7 @@ OTHERFILES=backtrace2.ml raw_backtrace.ml \ OTHERFILESNOINLINING=backtraces_and_finalizers.ml default: - $(MAKE) byte + @$(MAKE) byte @if $(BYTECODE_ONLY); then : ; else $(MAKE) native; fi .PHONY: byte @@ -30,7 +30,8 @@ byte: for arg in a b c d ''; do \ printf " ... testing '$$file' with ocamlc and argument '$$arg':"; \ F="`basename $$file .ml`"; \ - (OCAMLRUNPARAM=b=1 $(OCAMLRUN) $(EXECNAME) $$arg || true) \ + (OCAMLRUNPARAM=$$OCAMLRUNPARAM,b=1 \ + $(OCAMLRUN) $(EXECNAME) $$arg || true) \ >$$F.$$arg.byte.result 2>&1; \ $(DIFF) $$F.$$arg.reference $$F.$$arg.byte.result >/dev/null \ && echo " => passed" || echo " => failed"; \ @@ -41,7 +42,8 @@ byte: $(OCAMLC) -g -o $(EXECNAME) $$file; \ printf " ... testing '$$file' with ocamlc:"; \ F="`basename $$file .ml`"; \ - (OCAMLRUNPARAM=b=1 $(OCAMLRUN) $(EXECNAME) $$arg || true) \ + (OCAMLRUNPARAM=$$OCAMLRUNPARAM,b=1 \ + $(OCAMLRUN) $(EXECNAME) $$arg || true) \ >$$F.byte.result 2>&1; \ $(DIFF) $$F.reference $$F.byte.result >/dev/null \ && echo " => passed" || echo " => failed"; \ @@ -55,7 +57,8 @@ native: for arg in a b c d ''; do \ printf " ... testing '$$file' with ocamlopt and argument '$$arg':"; \ F="`basename $$file .ml`"; \ - (OCAMLRUNPARAM=b=1 ./$(EXECNAME) $$arg || true) \ + (OCAMLRUNPARAM=$$OCAMLRUNPARAM,b=1 \ + ./$(EXECNAME) $$arg || true) \ >$$F.$$arg.native.result 2>&1; \ $(DIFF) $$F.$$arg.reference $$F.$$arg.native.result >/dev/null \ && echo " => passed" || echo " => failed"; \ @@ -66,7 +69,8 @@ native: $(OCAMLOPT) -g -o $(EXECNAME) $$file; \ printf " ... testing '$$file' with ocamlopt:"; \ F="`basename $$file .ml`"; \ - (OCAMLRUNPARAM=b=1 ./$(EXECNAME) $$arg || true) \ + (OCAMLRUNPARAM=$OCAMLRUNPARAM,b=1 \ + ./$(EXECNAME) $$arg || true) \ >$$F.native.result 2>&1; \ $(DIFF) $$F.reference $$F.native.result >/dev/null \ && echo " => passed" || echo " => failed"; \ @@ -76,7 +80,8 @@ native: $(OCAMLOPT) -inline 0 -g -o $(EXECNAME) $$file; \ printf " ... testing '$$file' with ocamlopt:"; \ F="`basename $$file .ml`"; \ - (OCAMLRUNPARAM=b=1 ./$(EXECNAME) $$arg || true) \ + (OCAMLRUNPARAM=$$OCAMLRUNPARAM,b=1 \ + ./$(EXECNAME) $$arg || true) \ >$$F.native.result 2>&1; \ $(DIFF) $$F.reference $$F.native.result >/dev/null \ && echo " => passed" || echo " => failed"; \ diff --git a/testsuite/tests/basic-manyargs/manyargsprim.c b/testsuite/tests/basic-manyargs/manyargsprim.c index 65e9cf5eb8..55fbc2e03d 100644 --- a/testsuite/tests/basic-manyargs/manyargsprim.c +++ b/testsuite/tests/basic-manyargs/manyargsprim.c @@ -10,7 +10,7 @@ /* */ /***********************************************************************/ -#include "mlvalues.h" +#include "caml/mlvalues.h" #include "stdio.h" value manyargs(value a, value b, value c, value d, value e, value f, diff --git a/testsuite/tests/basic-modules/Makefile b/testsuite/tests/basic-modules/Makefile index 62dbc2a690..4c13f27247 100644 --- a/testsuite/tests/basic-modules/Makefile +++ b/testsuite/tests/basic-modules/Makefile @@ -12,7 +12,7 @@ BASEDIR=../.. -MODULES=offset +MODULES=offset pr6726 MAIN_MODULE=main include $(BASEDIR)/makefiles/Makefile.one diff --git a/testsuite/tests/basic-modules/main.ml b/testsuite/tests/basic-modules/main.ml index 54f8cbd61d..7f3f44d72b 100644 --- a/testsuite/tests/basic-modules/main.ml +++ b/testsuite/tests/basic-modules/main.ml @@ -11,3 +11,4 @@ end module M = F (Offset) let () = M.test (Offset.M.Set.singleton "42") +let v = Pr6726.Test.v diff --git a/testsuite/tests/basic-modules/pr6726.ml b/testsuite/tests/basic-modules/pr6726.ml new file mode 100644 index 0000000000..33ad956979 --- /dev/null +++ b/testsuite/tests/basic-modules/pr6726.ml @@ -0,0 +1,18 @@ +module ExtUnixAll = struct + external unused : unit -> unit = "caml_blit_string" + module BigEndian = struct + let get_uint8 str off = 33 + end +end + +module ExtUnix = struct + module All = ExtUnixAll +end + +module Test = struct + open ExtUnix.All + let test_endian_string x = + let module B = BigEndian in + B.get_uint8 x 0 + let v = test_endian_string 1 +end diff --git a/testsuite/tests/basic/divint.ml b/testsuite/tests/basic/divint.ml index 52d14b9c85..60f09962ff 100644 --- a/testsuite/tests/basic/divint.ml +++ b/testsuite/tests/basic/divint.ml @@ -74,6 +74,7 @@ let do_test divisor (df: nativeint -> nativeint) (mf: nativeint -> nativeint) = end let _ = + printf "1 int\n"; WithInt.do_test 1 (fun x -> x / 1)(fun x -> x mod 1); printf "2 int\n"; WithInt.do_test 2 (fun x -> x / 2)(fun x -> x mod 2); printf "3 int\n"; WithInt.do_test 3 (fun x -> x / 3)(fun x -> x mod 3); printf "4 int\n"; WithInt.do_test 4 (fun x -> x / 4)(fun x -> x mod 4); @@ -88,9 +89,11 @@ let _ = printf "55 int\n"; WithInt.do_test 55 (fun x -> x / 55)(fun x -> x mod 55); printf "125 int\n"; WithInt.do_test 125 (fun x -> x / 125)(fun x -> x mod 125); printf "625 int\n"; WithInt.do_test 625 (fun x -> x / 625)(fun x -> x mod 625); + printf "-1 int\n"; WithInt.do_test (-1) (fun x -> x / (-1))(fun x -> x mod (-1)); printf "-2 int\n"; WithInt.do_test (-2) (fun x -> x / (-2))(fun x -> x mod (-2)); printf "-3 int\n"; WithInt.do_test (-3) (fun x -> x / (-3))(fun x -> x mod (-3)); + printf "1 nat\n"; WithNat.do_test 1 (fun x -> Nativeint.div x 1n)(fun x -> Nativeint.rem x 1n); printf "2 nat\n"; WithNat.do_test 2 (fun x -> Nativeint.div x 2n)(fun x -> Nativeint.rem x 2n); printf "3 nat\n"; WithNat.do_test 3 (fun x -> Nativeint.div x 3n)(fun x -> Nativeint.rem x 3n); printf "4 nat\n"; WithNat.do_test 4 (fun x -> Nativeint.div x 4n)(fun x -> Nativeint.rem x 4n); @@ -105,8 +108,12 @@ let _ = printf "55 nat\n"; WithNat.do_test 55 (fun x -> Nativeint.div x 55n)(fun x -> Nativeint.rem x 55n); printf "125 nat\n"; WithNat.do_test 125 (fun x -> Nativeint.div x 125n)(fun x -> Nativeint.rem x 125n); printf "625 nat\n"; WithNat.do_test 625 (fun x -> Nativeint.div x 625n)(fun x -> Nativeint.rem x 625n); + printf "-1 nat\n"; WithNat.do_test (-1) (fun x -> Nativeint.div x (-1n))(fun x -> Nativeint.rem x (-1n)); printf "-2 nat\n"; WithNat.do_test (-2) (fun x -> Nativeint.div x (-2n))(fun x -> Nativeint.rem x (-2n)); printf "-3 nat\n"; WithNat.do_test (-3) (fun x -> Nativeint.div x (-3n))(fun x -> Nativeint.rem x (-3n)); if !error then printf "TEST FAILED.\n" else printf "Test passed.\n" +(* PR#6879 *) +let f n = assert (1 mod n = 0) +let () = f 1 diff --git a/testsuite/tests/basic/divint.reference b/testsuite/tests/basic/divint.reference index 4aa1e2110f..e9a6387fa8 100644 --- a/testsuite/tests/basic/divint.reference +++ b/testsuite/tests/basic/divint.reference @@ -1,3 +1,4 @@ +1 int 2 int 3 int 4 int @@ -12,8 +13,10 @@ 55 int 125 int 625 int +-1 int -2 int -3 int +1 nat 2 nat 3 nat 4 nat @@ -28,6 +31,7 @@ 55 nat 125 nat 625 nat +-1 nat -2 nat -3 nat Test passed. diff --git a/testsuite/tests/basic/patmatch.ml b/testsuite/tests/basic/patmatch.ml index e3f1453c05..4ef50a73cb 100644 --- a/testsuite/tests/basic/patmatch.ml +++ b/testsuite/tests/basic/patmatch.ml @@ -167,3 +167,1420 @@ let () = let s2 = test false in s1.[0] <- 'p'; if s1 <> s2 then printf "PR#6322=Ok\n%!" + +(* PR#6646 Avoid explosion of default cases when there are many constructors *) + +(* This took forever to compile *) + +type token = + | Abs + | Acload + | After + | And + | Annotate + | Apply + | Arc + | Array + | Arraymacro + | Arrayrelatedinfo + | Arraysite + | Assign + | Atleast + | Atmost + | Author + | Basearray + | Becomes + | Between + | Block + | Boolean + | Booleandisplay + | Booleanmap + | Booleanvalue + | Borderpattern + | Borderwidth + | Boundingbox + | Ceiling + | Cell + | Cellref + | Celltype + | Change + | Circle + | Color + | Comment + | Commentgraphics + | Compound + | Concat + | Connectlocation + | Constant + | Constraint + | Contents + | Cornertype + | Criticality + | Currentmap + | Curve + | Cycle + | Dataorigin + | Dcfaninload + | Dcfanoutload + | Dcmaxfanin + | Dcmaxfanout + | Delay + | Delta + | Derivation + | Design + | Designator + | Difference + | Direction + | Display + | Divide + | Dominates + | Dot + | Duration + | E + | Edif + | Ediflevel + | Edifversion + | Else + | Enclosuredistance + | Endtype + | Entry + | Equal + | Escape + | Event + | Exactly + | External + | Fabricate + | False + | Figure + | Figurearea + | Figuregroup + | Figuregroupobject + | Figuregroupoverride + | Figuregroupref + | Figureperimeter + | Figurewidth + | Fillpattern + | Fix + | Floor + | Follow + | Forbiddenevent + | Form + | Globalportref + | Greaterthan + | Gridmap + | If + | Ignore + | Includefiguregroup + | Increasing + | Initial + | Instance + | Instancebackannotate + | Instancegroup + | Instancemap + | Instancenamedef + | Instanceref + | Integer + | Integerdisplay + | Interface + | Interfiguregroupspacing + | Intersection + | Intrafiguregroupspacing + | Inverse + | Isolated + | Iterate + | Joined + | Justify + | Keyworddisplay + | Keywordlevel + | Keywordmap + | Lessthan + | Library + | Libraryref + | Listofnets + | Listofports + | Loaddelay + | Logicassign + | Logicinput + | Logiclist + | Logicmapinput + | Logicmapoutput + | Logiconeof + | Logicoutput + | Logicport + | Logicref + | Logicvalue + | Logicwaveform + | Maintain + | Match + | Max + | Member + | Min + | Minomax + | Minomaxdisplay + | Mnm + | Mod + | Multiplevalueset + | Mustjoin + | Name + | Negate + | Net + | Netbackannotate + | Netbundle + | Netdelay + | Netgroup + | Netmap + | Netref + | Nochange + | Nonpermutable + | Not + | Notallowed + | Notchspacing + | Number + | Numberdefinition + | Numberdisplay + | Offpageconnector + | Offsetevent + | Openshape + | Or + | Orientation + | Origin + | Overhangdistance + | Overlapdistance + | Oversize + | Owner + | Page + | Pagesize + | Parameter + | Parameterassign + | Parameterdisplay + | Path + | Pathdelay + | Pathwidth + | Permutable + | Physicaldesignrule + | Plug + | Point + | Pointdisplay + | Pointlist + | Pointsubtract + | Pointsum + | Polygon + | Port + | Portbackannotate + | Portbundle + | Portdelay + | Portgroup + | Portimplementation + | Portinstance + | Portlist + | Portlistalias + | Portmap + | Portref + | Product + | Program + | Property + | Propertydisplay + | Protectionframe + | Pt + | Rangevector + | Rectangle + | Rectanglesize + | Rename + | Resolves + | Scale + | Scalex + | Scaley + | Section + | Shape + | Simulate + | Simulationinfo + | Singlevalueset + | Site + | Socket + | Socketset + | Statement + | Status + | Steady + | Strictlyincreasing + | String + | Stringdisplay + | Strong + | Subtract + | Sum + | Symbol + | Symmetry + | Table + | Tabledefault + | Technology + | Textheight + | Then + | Timeinterval + | Timestamp + | Timing + | Transform + | Transition + | Trigger + | True + | Typedvalue + | Unconstrained + | Undefined + | Union + | Unit + | Unused + | Userdata + | Valuenameref + | Variable + | Version + | View + | Viewlist + | Viewmap + | Viewref + | Viewtype + | Visible + | Voltagemap + | Wavevalue + | Weak + | Weakjoined + | When + | While + | Written + | Xcoord + | Xor + | Ycoord + | ILLEGAL of (char) + | ID of (string) + | TLIST of (token list) + | TLIST2 of (token list*token list) + | ITEM of (token*token) + | ITEM2 of (token*token*token) + | STRING of (string) + | INT of (int) + | ENDOFFILE + | EOL + | LPAREN + | RPAREN + | EMPTY + +let test_match tok = match tok with + | ITEM2(Array, ITEM (Rename, TLIST [ID id; STRING str]), INT idx) -> + 1 + | ITEM2(Cellref, TLIST [ID id], TLIST lst) -> + 2 + | ITEM2(Cell, TLIST [ID cellid], TLIST lst) -> + 3 + | ITEM2(Contents, TLIST lst1, TLIST lst2) -> + 4 + | ITEM2(Design, TLIST [ID id], TLIST lst) -> + 5 + | ITEM2(Edif, TLIST [ID id], TLIST lst) -> + 6 + | ITEM2(Instance, TLIST [ID instid], TLIST[ITEM2(Viewref, TLIST [ID netlist], + TLIST[ITEM(Cellref, TLIST [ID cellid])])]) -> 7 + + + | ITEM2(Instance, TLIST [ID instid], TLIST[ITEM2(Viewref, TLIST [ID netlist], + TLIST[ITEM2(Cellref, TLIST [ID cellid], + TLIST [ITEM (Libraryref, TLIST [ID libid])])])]) -> 8 +(* *) + | ITEM2(Instance, TLIST [ID instid], + TLIST [ITEM2(viewref, + TLIST [ID netlist], + TLIST [ITEM2(cellref, + TLIST [ID cellid], + TLIST [ITEM(libraryref, + TLIST [ID libid])])]); + ITEM2(property, TLIST [ID xstlib], + TLIST [ITEM2(bool1, + TLIST [], + TLIST [ITEM(True, TLIST [])]); + ITEM(owner, TLIST [str])])]) -> 9 +(* *) + | ITEM2(Interface, TLIST [], TLIST lst) -> 100 + | ITEM2(Joined, TLIST [], TLIST lst) -> 10 + | ITEM2(Keywordmap, TLIST lst1, TLIST lst2) -> 11 + | ITEM2(Library, TLIST [], TLIST lst) -> 12 + | ITEM2(Library, TLIST [ID libid], TLIST lst) -> 13 + | ITEM2(Net, TLIST [], TLIST [ITEM (Rename, TLIST [ID oldid; STRING newid]); + ITEM2(Joined, TLIST [], + TLIST portlst)]) -> 14 + | ITEM2(Net, TLIST [ID netid], TLIST [ITEM2(Joined, TLIST [], + TLIST portlst)]) -> 15 + | ITEM2(Net, _, _) -> 16 + | ITEM2(Port, TLIST [], TLIST lst) -> 17 + | ITEM2(Port, TLIST [ID id], TLIST lst) -> 18 + | ITEM2(Portref, TLIST [ID id], TLIST [ITEM (Instanceref, TLIST [ID ref])]) ->19 + | ITEM2(Portref, TLIST [], TLIST [ITEM (Member, TLIST [ID mref; INT idx])]) -> 20 + | ITEM2(Portref, TLIST [], TLIST[ITEM (Member, TLIST [ID mref; INT idx]); ITEM (Instanceref, TLIST [ID instref])]) -> 21 + | ITEM2(Program, TLIST [STRING progid], TLIST lst) ->21 + | ITEM2(Property, TLIST [ID part], TLIST lst) -> 22 + | ITEM2(Status, TLIST lst1, TLIST lst2) -> 23 + | ITEM2(Technology, TLIST lst1, TLIST lst2) -> 24 + | ITEM2(View, TLIST [ID netlist], TLIST lst) -> 25 + | ITEM2(Viewref, TLIST [ID "netlist"], TLIST lst) -> 26 + | ITEM2(Written, TLIST lst1, TLIST lst2) -> 27 + | ITEM2(External, TLIST lst1, TLIST lst2) -> 28 + | ITEM(Integer, TLIST [INT n]) -> 29 + | ITEM (Author, TLIST [STRING author]) -> 30 + | ITEM (Cellref, TLIST [ID id]) -> 31 + | ITEM (Celltype, TLIST [ID "GENERIC"]) -> 32 + | ITEM (Direction, TLIST [ID dir]) -> 32 (* print_endline dir *) + | ITEM (Ediflevel, TLIST [INT 0]) -> 32 + | ITEM (Edifversion, TLIST [INT 2; INT 0; INT 0]) -> 32 + | ITEM (Instanceref, TLIST [ID id]) -> 32 + | ITEM (Keywordlevel, TLIST [INT 0]) -> 32 + | ITEM (Libraryref, TLIST [ID "work"]) -> 32 + | ITEM (Libraryref, TLIST [ID "xilinx"]) -> 32 + | ITEM (Member, TLIST [ID id; INT n]) -> 32 + | ITEM (Numberdefinition, TLIST []) -> 32 + | ITEM (Owner, TLIST [STRING "\"Xilinx\""]) -> 32 + | ITEM (Portref, TLIST [ID id]) -> 32 + | ITEM (Rename, TLIST [ID id; STRING str]) -> 33 + | ITEM (String, TLIST [STRING str]) -> 32 + | ITEM (String, TLIST lst) -> 34 + | ITEM (Timestamp, TLIST [INT yr; INT mon; INT day; INT hour; INT min; INT sec]) -> 32 + | ITEM (Version, TLIST [STRING str]) -> 32 + | ITEM (Viewtype, TLIST [ID "NETLIST"]) -> 32 + | ITEM (Designator, TLIST lst) -> 34 + | Abs -> failwith " Abs " + | Acload -> failwith " Acload " + | After -> failwith " After " + | And -> failwith " And " + | Annotate -> failwith " Annotate " + | Apply -> failwith " Apply " + | Arc -> failwith " Arc " + | Array -> failwith " Array " + | Arraymacro -> failwith " Arraymacro " + | Arrayrelatedinfo -> failwith " Arrayrelatedinfo " + | Arraysite -> failwith " Arraysite " + | Assign -> failwith " Assign " + | Atleast -> failwith " Atleast " + | Atmost -> failwith " Atmost " + | Author -> failwith " Author " + | Basearray -> failwith " Basearray " + | Becomes -> failwith " Becomes " + | Between -> failwith " Between " + | Block -> failwith " Block " + | Boolean -> failwith " Boolean " + | Booleandisplay -> failwith " Booleandisplay " + | Booleanmap -> failwith " Booleanmap " + | Booleanvalue -> failwith " Booleanvalue " + | Borderpattern -> failwith " Borderpattern " + | Borderwidth -> failwith " Borderwidth " + | Boundingbox -> failwith " Boundingbox " + | Ceiling -> failwith " Ceiling " + | Cell -> failwith " Cell " + | Cellref -> failwith " Cellref " + | Celltype -> failwith " Celltype " + | Change -> failwith " Change " + | Circle -> failwith " Circle " + | Color -> failwith " Color " + | Comment -> failwith " Comment " + | Commentgraphics -> failwith " Commentgraphics " + | Compound -> failwith " Compound " + | Concat -> failwith " Concat " + | Connectlocation -> failwith " Connectlocation " + | Constant -> failwith " Constant " + | Constraint -> failwith " Constraint " + | Contents -> failwith " Contents " + | Cornertype -> failwith " Cornertype " + | Criticality -> failwith " Criticality " + | Currentmap -> failwith " Currentmap " + | Curve -> failwith " Curve " + | Cycle -> failwith " Cycle " + | Dataorigin -> failwith " Dataorigin " + | Dcfaninload -> failwith " Dcfaninload " + | Dcfanoutload -> failwith " Dcfanoutload " + | Dcmaxfanin -> failwith " Dcmaxfanin " + | Dcmaxfanout -> failwith " Dcmaxfanout " + | Delay -> failwith " Delay " + | Delta -> failwith " Delta " + | Derivation -> failwith " Derivation " + | Design -> failwith " Design " + | Designator -> failwith " Designator " + | Difference -> failwith " Difference " + | Direction -> failwith " Direction " + | Display -> failwith " Display " + | Divide -> failwith " Divide " + | Dominates -> failwith " Dominates " + | Dot -> failwith " Dot " + | Duration -> failwith " Duration " + | E -> failwith " E " + | Edif -> failwith " Edif " + | Ediflevel -> failwith " Ediflevel " + | Edifversion -> failwith " Edifversion " + | Else -> failwith " Else " + | Enclosuredistance -> failwith " Enclosuredistance " + | Endtype -> failwith " Endtype " + | Entry -> failwith " Entry " + | Equal -> failwith " Equal " + | Escape -> failwith " Escape " + | Event -> failwith " Event " + | Exactly -> failwith " Exactly " + | External -> failwith " External " + | Fabricate -> failwith " Fabricate " + | False -> failwith " False " + | Figure -> failwith " Figure " + | Figurearea -> failwith " Figurearea " + | Figuregroup -> failwith " Figuregroup " + | Figuregroupobject -> failwith " Figuregroupobject " + | Figuregroupoverride -> failwith " Figuregroupoverride " + | Figuregroupref -> failwith " Figuregroupref " + | Figureperimeter -> failwith " Figureperimeter " + | Figurewidth -> failwith " Figurewidth " + | Fillpattern -> failwith " Fillpattern " + | Fix -> failwith " Fix " + | Floor -> failwith " Floor " + | Follow -> failwith " Follow " + | Forbiddenevent -> failwith " Forbiddenevent " + | Form -> failwith " Form " + | Globalportref -> failwith " Globalportref " + | Greaterthan -> failwith " Greaterthan " + | Gridmap -> failwith " Gridmap " + | If -> failwith " If " + | Ignore -> failwith " Ignore " + | Includefiguregroup -> failwith " Includefiguregroup " + | Increasing -> failwith " Increasing " + | Initial -> failwith " Initial " + | Instance -> failwith " Instance " + | Instancebackannotate -> failwith " Instancebackannotate " + | Instancegroup -> failwith " Instancegroup " + | Instancemap -> failwith " Instancemap " + | Instancenamedef -> failwith " Instancenamedef " + | Instanceref -> failwith " Instanceref " + | Integer -> failwith " Integer " + | Integerdisplay -> failwith " Integerdisplay " + | Interface -> failwith " Interface " + | Interfiguregroupspacing -> failwith " Interfiguregroupspacing " + | Intersection -> failwith " Intersection " + | Intrafiguregroupspacing -> failwith " Intrafiguregroupspacing " + | Inverse -> failwith " Inverse " + | Isolated -> failwith " Isolated " + | Iterate -> failwith " Iterate " + | Joined -> failwith " Joined " + | Justify -> failwith " Justify " + | Keyworddisplay -> failwith " Keyworddisplay " + | Keywordlevel -> failwith " Keywordlevel " + | Keywordmap -> failwith " Keywordmap " + | Lessthan -> failwith " Lessthan " + | Library -> failwith " Library " + | Libraryref -> failwith " Libraryref " + | Listofnets -> failwith " Listofnets " + | Listofports -> failwith " Listofports " + | Loaddelay -> failwith " Loaddelay " + | Logicassign -> failwith " Logicassign " + | Logicinput -> failwith " Logicinput " + | Logiclist -> failwith " Logiclist " + | Logicmapinput -> failwith " Logicmapinput " + | Logicmapoutput -> failwith " Logicmapoutput " + | Logiconeof -> failwith " Logiconeof " + | Logicoutput -> failwith " Logicoutput " + | Logicport -> failwith " Logicport " + | Logicref -> failwith " Logicref " + | Logicvalue -> failwith " Logicvalue " + | Logicwaveform -> failwith " Logicwaveform " + | Maintain -> failwith " Maintain " + | Match -> failwith " Match " + | Max -> failwith " Max " + | Member -> failwith " Member " + | Min -> failwith " Min " + | Minomax -> failwith " Minomax " + | Minomaxdisplay -> failwith " Minomaxdisplay " + | Mnm -> failwith " Mnm " + | Mod -> failwith " Mod " + | Multiplevalueset -> failwith " Multiplevalueset " + | Mustjoin -> failwith " Mustjoin " + | Name -> failwith " Name " + | Negate -> failwith " Negate " + | Net -> failwith " Net " + | Netbackannotate -> failwith " Netbackannotate " + | Netbundle -> failwith " Netbundle " + | Netdelay -> failwith " Netdelay " + | Netgroup -> failwith " Netgroup " + | Netmap -> failwith " Netmap " + | Netref -> failwith " Netref " + | Nochange -> failwith " Nochange " + | Nonpermutable -> failwith " Nonpermutable " + | Not -> failwith " Not " + | Notallowed -> failwith " Notallowed " + | Notchspacing -> failwith " Notchspacing " + | Number -> failwith " Number " + | Numberdefinition -> failwith " Numberdefinition " + | Numberdisplay -> failwith " Numberdisplay " + | Offpageconnector -> failwith " Offpageconnector " + | Offsetevent -> failwith " Offsetevent " + | Openshape -> failwith " Openshape " + | Or -> failwith " Or " + | Orientation -> failwith " Orientation " + | Origin -> failwith " Origin " + | Overhangdistance -> failwith " Overhangdistance " + | Overlapdistance -> failwith " Overlapdistance " + | Oversize -> failwith " Oversize " + | Owner -> failwith " Owner " + | Page -> failwith " Page " + | Pagesize -> failwith " Pagesize " + | Parameter -> failwith " Parameter " + | Parameterassign -> failwith " Parameterassign " + | Parameterdisplay -> failwith " Parameterdisplay " + | Path -> failwith " Path " + | Pathdelay -> failwith " Pathdelay " + | Pathwidth -> failwith " Pathwidth " + | Permutable -> failwith " Permutable " + | Physicaldesignrule -> failwith " Physicaldesignrule " + | Plug -> failwith " Plug " + | Point -> failwith " Point " + | Pointdisplay -> failwith " Pointdisplay " + | Pointlist -> failwith " Pointlist " + | Pointsubtract -> failwith " Pointsubtract " + | Pointsum -> failwith " Pointsum " + | Polygon -> failwith " Polygon " + | Port -> failwith " Port " + | Portbackannotate -> failwith " Portbackannotate " + | Portbundle -> failwith " Portbundle " + | Portdelay -> failwith " Portdelay " + | Portgroup -> failwith " Portgroup " + | Portimplementation -> failwith " Portimplementation " + | Portinstance -> failwith " Portinstance " + | Portlist -> failwith " Portlist " + | Portlistalias -> failwith " Portlistalias " + | Portmap -> failwith " Portmap " + | Portref -> failwith " Portref " + | Product -> failwith " Product " + | Program -> failwith " Program " + | Property -> failwith " Property " + | Propertydisplay -> failwith " Propertydisplay " + | Protectionframe -> failwith " Protectionframe " + | Pt -> failwith " Pt " + | Rangevector -> failwith " Rangevector " + | Rectangle -> failwith " Rectangle " + | Rectanglesize -> failwith " Rectanglesize " + | Rename -> failwith " Rename " + | Resolves -> failwith " Resolves " + | Scale -> failwith " Scale " + | Scalex -> failwith " Scalex " + | Scaley -> failwith " Scaley " + | Section -> failwith " Section " + | Shape -> failwith " Shape " + | Simulate -> failwith " Simulate " + | Simulationinfo -> failwith " Simulationinfo " + | Singlevalueset -> failwith " Singlevalueset " + | Site -> failwith " Site " + | Socket -> failwith " Socket " + | Socketset -> failwith " Socketset " + | Statement -> failwith " Statement " + | Status -> failwith " Status " + | Steady -> failwith " Steady " + | Strictlyincreasing -> failwith " Strictlyincreasing " + | String -> failwith " String " + | Stringdisplay -> failwith " Stringdisplay " + | Strong -> failwith " Strong " + | Subtract -> failwith " Subtract " + | Sum -> failwith " Sum " + | Symbol -> failwith " Symbol " + | Symmetry -> failwith " Symmetry " + | Table -> failwith " Table " + | Tabledefault -> failwith " Tabledefault " + | Technology -> failwith " Technology " + | Textheight -> failwith " Textheight " + | Then -> failwith " Then " + | Timeinterval -> failwith " Timeinterval " + | Timestamp -> failwith " Timestamp " + | Timing -> failwith " Timing " + | Transform -> failwith " Transform " + | Transition -> failwith " Transition " + | Trigger -> failwith " Trigger " + | True -> failwith " True " + | Typedvalue -> failwith " Typedvalue " + | Unconstrained -> failwith " Unconstrained " + | Undefined -> failwith " Undefined " + | Union -> failwith " Union " + | Unit -> failwith " Unit " + | Unused -> failwith " Unused " + | Userdata -> failwith " Userdata " + | Valuenameref -> failwith " Valuenameref " + | Variable -> failwith " Variable " + | Version -> failwith " Version " + | View -> failwith " View " + | Viewlist -> failwith " Viewlist " + | Viewmap -> failwith " Viewmap " + | Viewref -> failwith " Viewref " + | Viewtype -> failwith " Viewtype " + | Visible -> failwith " Visible " + | Voltagemap -> failwith " Voltagemap " + | Wavevalue -> failwith " Wavevalue " + | Weak -> failwith " Weak " + | Weakjoined -> failwith " Weakjoined " + | When -> failwith " When " + | While -> failwith " While " + | Written -> failwith " Written " + | Xcoord -> failwith " Xcoord " + | Xor -> failwith " Xor " + | Ycoord -> failwith " Ycoord " + | ILLEGAL _ -> failwith " ILLEGAL _ " + | ID _ -> failwith " ID _ " + | TLIST _ -> failwith " TLIST _ " + | TLIST2 _ -> failwith " TLIST2 _ " + | STRING _ -> failwith " STRING _ " + | INT _ -> failwith " INT _ " + | ENDOFFILE -> failwith " ENDOFFILE " + | EOL -> failwith " EOL " + | LPAREN -> failwith " LPAREN " + | RPAREN -> failwith " RPAREN " + | EMPTY -> failwith " EMPTY " + + | ITEM2(Abs, _, _) -> failwith " ITEM2(Abs, _, _) " + | ITEM2(Acload, _, _) -> failwith " ITEM2(Acload, _, _) " + | ITEM2(After, _, _) -> failwith " ITEM2(After, _, _) " + | ITEM2(And, _, _) -> failwith " ITEM2(And, _, _) " + | ITEM2(Annotate, _, _) -> failwith " ITEM2(Annotate, _, _) " + | ITEM2(Apply, _, _) -> failwith " ITEM2(Apply, _, _) " + | ITEM2(Arc, _, _) -> failwith " ITEM2(Arc, _, _) " + | ITEM2(Array, _, _) -> failwith " ITEM2(Array, _, _) " + | ITEM2(Arraymacro, _, _) -> failwith " ITEM2(Arraymacro, _, _) " + | ITEM2(Arrayrelatedinfo, _, _) -> failwith " ITEM2(Arrayrelatedinfo, _, _) " + | ITEM2(Arraysite, _, _) -> failwith " ITEM2(Arraysite, _, _) " + | ITEM2(Assign, _, _) -> failwith " ITEM2(Assign, _, _) " + | ITEM2(Atleast, _, _) -> failwith " ITEM2(Atleast, _, _) " + | ITEM2(Atmost, _, _) -> failwith " ITEM2(Atmost, _, _) " + | ITEM2(Author, _, _) -> failwith " ITEM2(Author, _, _) " + | ITEM2(Basearray, _, _) -> failwith " ITEM2(Basearray, _, _) " + | ITEM2(Becomes, _, _) -> failwith " ITEM2(Becomes, _, _) " + | ITEM2(Between, _, _) -> failwith " ITEM2(Between, _, _) " + | ITEM2(Block, _, _) -> failwith " ITEM2(Block, _, _) " + | ITEM2(Boolean, _, _) -> failwith " ITEM2(Boolean, _, _) " + | ITEM2(Booleandisplay, _, _) -> failwith " ITEM2(Booleandisplay, _, _) " + | ITEM2(Booleanmap, _, _) -> failwith " ITEM2(Booleanmap, _, _) " + | ITEM2(Booleanvalue, _, _) -> failwith " ITEM2(Booleanvalue, _, _) " + | ITEM2(Borderpattern, _, _) -> failwith " ITEM2(Borderpattern, _, _) " + | ITEM2(Borderwidth, _, _) -> failwith " ITEM2(Borderwidth, _, _) " + | ITEM2(Boundingbox, _, _) -> failwith " ITEM2(Boundingbox, _, _) " + | ITEM2(Ceiling, _, _) -> failwith " ITEM2(Ceiling, _, _) " + | ITEM2(Cell, _, _) -> failwith " ITEM2(Cell, _, _) " + | ITEM2(Cellref, _, _) -> failwith " ITEM2(Cellref, _, _) " + | ITEM2(Celltype, _, _) -> failwith " ITEM2(Celltype, _, _) " + | ITEM2(Change, _, _) -> failwith " ITEM2(Change, _, _) " + | ITEM2(Circle, _, _) -> failwith " ITEM2(Circle, _, _) " + | ITEM2(Color, _, _) -> failwith " ITEM2(Color, _, _) " + | ITEM2(Comment, _, _) -> failwith " ITEM2(Comment, _, _) " + | ITEM2(Commentgraphics, _, _) -> failwith " ITEM2(Commentgraphics, _, _) " + | ITEM2(Compound, _, _) -> failwith " ITEM2(Compound, _, _) " + | ITEM2(Concat, _, _) -> failwith " ITEM2(Concat, _, _) " + | ITEM2(Connectlocation, _, _) -> failwith " ITEM2(Connectlocation, _, _) " + | ITEM2(Constant, _, _) -> failwith " ITEM2(Constant, _, _) " + | ITEM2(Constraint, _, _) -> failwith " ITEM2(Constraint, _, _) " + | ITEM2(Contents, _, _) -> failwith " ITEM2(Contents, _, _) " + | ITEM2(Cornertype, _, _) -> failwith " ITEM2(Cornertype, _, _) " + | ITEM2(Criticality, _, _) -> failwith " ITEM2(Criticality, _, _) " + | ITEM2(Currentmap, _, _) -> failwith " ITEM2(Currentmap, _, _) " + | ITEM2(Curve, _, _) -> failwith " ITEM2(Curve, _, _) " + | ITEM2(Cycle, _, _) -> failwith " ITEM2(Cycle, _, _) " + | ITEM2(Dataorigin, _, _) -> failwith " ITEM2(Dataorigin, _, _) " + | ITEM2(Dcfaninload, _, _) -> failwith " ITEM2(Dcfaninload, _, _) " + | ITEM2(Dcfanoutload, _, _) -> failwith " ITEM2(Dcfanoutload, _, _) " + | ITEM2(Dcmaxfanin, _, _) -> failwith " ITEM2(Dcmaxfanin, _, _) " + | ITEM2(Dcmaxfanout, _, _) -> failwith " ITEM2(Dcmaxfanout, _, _) " + | ITEM2(Delay, _, _) -> failwith " ITEM2(Delay, _, _) " + | ITEM2(Delta, _, _) -> failwith " ITEM2(Delta, _, _) " + | ITEM2(Derivation, _, _) -> failwith " ITEM2(Derivation, _, _) " + | ITEM2(Design, _, _) -> failwith " ITEM2(Design, _, _) " + | ITEM2(Designator, _, _) -> failwith " ITEM2(Designator, _, _) " + | ITEM2(Difference, _, _) -> failwith " ITEM2(Difference, _, _) " + | ITEM2(Direction, _, _) -> failwith " ITEM2(Direction, _, _) " + | ITEM2(Display, _, _) -> failwith " ITEM2(Display, _, _) " + | ITEM2(Divide, _, _) -> failwith " ITEM2(Divide, _, _) " + | ITEM2(Dominates, _, _) -> failwith " ITEM2(Dominates, _, _) " + | ITEM2(Dot, _, _) -> failwith " ITEM2(Dot, _, _) " + | ITEM2(Duration, _, _) -> failwith " ITEM2(Duration, _, _) " + | ITEM2(E, _, _) -> failwith " ITEM2(E, _, _) " + | ITEM2(Edif, _, _) -> failwith " ITEM2(Edif, _, _) " + | ITEM2(Ediflevel, _, _) -> failwith " ITEM2(Ediflevel, _, _) " + | ITEM2(Edifversion, _, _) -> failwith " ITEM2(Edifversion, _, _) " + | ITEM2(Else, _, _) -> failwith " ITEM2(Else, _, _) " + | ITEM2(Enclosuredistance, _, _) -> failwith " ITEM2(Enclosuredistance, _, _) " + | ITEM2(Endtype, _, _) -> failwith " ITEM2(Endtype, _, _) " + | ITEM2(Entry, _, _) -> failwith " ITEM2(Entry, _, _) " + | ITEM2(Equal, _, _) -> failwith " ITEM2(Equal, _, _) " + | ITEM2(Escape, _, _) -> failwith " ITEM2(Escape, _, _) " + | ITEM2(Event, _, _) -> failwith " ITEM2(Event, _, _) " + | ITEM2(Exactly, _, _) -> failwith " ITEM2(Exactly, _, _) " + | ITEM2(External, _, _) -> failwith " ITEM2(External, _, _) " + | ITEM2(Fabricate, _, _) -> failwith " ITEM2(Fabricate, _, _) " + | ITEM2(False, _, _) -> failwith " ITEM2(False, _, _) " + | ITEM2(Figure, _, _) -> failwith " ITEM2(Figure, _, _) " + | ITEM2(Figurearea, _, _) -> failwith " ITEM2(Figurearea, _, _) " + | ITEM2(Figuregroup, _, _) -> failwith " ITEM2(Figuregroup, _, _) " + | ITEM2(Figuregroupobject, _, _) -> failwith " ITEM2(Figuregroupobject, _, _) " + | ITEM2(Figuregroupoverride, _, _) -> failwith " ITEM2(Figuregroupoverride, _, _) " + | ITEM2(Figuregroupref, _, _) -> failwith " ITEM2(Figuregroupref, _, _) " + | ITEM2(Figureperimeter, _, _) -> failwith " ITEM2(Figureperimeter, _, _) " + | ITEM2(Figurewidth, _, _) -> failwith " ITEM2(Figurewidth, _, _) " + | ITEM2(Fillpattern, _, _) -> failwith " ITEM2(Fillpattern, _, _) " + | ITEM2(Fix, _, _) -> failwith " ITEM2(Fix, _, _) " + | ITEM2(Floor, _, _) -> failwith " ITEM2(Floor, _, _) " + | ITEM2(Follow, _, _) -> failwith " ITEM2(Follow, _, _) " + | ITEM2(Forbiddenevent, _, _) -> failwith " ITEM2(Forbiddenevent, _, _) " + | ITEM2(Form, _, _) -> failwith " ITEM2(Form, _, _) " + | ITEM2(Globalportref, _, _) -> failwith " ITEM2(Globalportref, _, _) " + | ITEM2(Greaterthan, _, _) -> failwith " ITEM2(Greaterthan, _, _) " + | ITEM2(Gridmap, _, _) -> failwith " ITEM2(Gridmap, _, _) " + | ITEM2(If, _, _) -> failwith " ITEM2(If, _, _) " + | ITEM2(Ignore, _, _) -> failwith " ITEM2(Ignore, _, _) " + | ITEM2(Includefiguregroup, _, _) -> failwith " ITEM2(Includefiguregroup, _, _) " + | ITEM2(Increasing, _, _) -> failwith " ITEM2(Increasing, _, _) " + | ITEM2(Initial, _, _) -> failwith " ITEM2(Initial, _, _) " + | ITEM2(Instance, arg1, arg2) -> failwith (" ITEM2(Instance, ) ") + | ITEM2(Instancebackannotate, _, _) -> failwith " ITEM2(Instancebackannotate, _, _) " + | ITEM2(Instancegroup, _, _) -> failwith " ITEM2(Instancegroup, _, _) " + | ITEM2(Instancemap, _, _) -> failwith " ITEM2(Instancemap, _, _) " + | ITEM2(Instancenamedef, _, _) -> failwith " ITEM2(Instancenamedef, _, _) " + | ITEM2(Instanceref, _, _) -> failwith " ITEM2(Instanceref, _, _) " + | ITEM2(Integer, _, _) -> failwith " ITEM2(Integer, _, _) " + | ITEM2(Integerdisplay, _, _) -> failwith " ITEM2(Integerdisplay, _, _) " + | ITEM2(Interface, _, _) -> failwith " ITEM2(Interface, _, _) " + | ITEM2(Interfiguregroupspacing, _, _) -> failwith " ITEM2(Interfiguregroupspacing, _, _) " + | ITEM2(Intersection, _, _) -> failwith " ITEM2(Intersection, _, _) " + | ITEM2(Intrafiguregroupspacing, _, _) -> failwith " ITEM2(Intrafiguregroupspacing, _, _) " + | ITEM2(Inverse, _, _) -> failwith " ITEM2(Inverse, _, _) " + | ITEM2(Isolated, _, _) -> failwith " ITEM2(Isolated, _, _) " + | ITEM2(Iterate, _, _) -> failwith " ITEM2(Iterate, _, _) " + | ITEM2(Joined, _, _) -> failwith " ITEM2(Joined, _, _) " + | ITEM2(Justify, _, _) -> failwith " ITEM2(Justify, _, _) " + | ITEM2(Keyworddisplay, _, _) -> failwith " ITEM2(Keyworddisplay, _, _) " + | ITEM2(Keywordlevel, _, _) -> failwith " ITEM2(Keywordlevel, _, _) " + | ITEM2(Keywordmap, _, _) -> failwith " ITEM2(Keywordmap, _, _) " + | ITEM2(Lessthan, _, _) -> failwith " ITEM2(Lessthan, _, _) " + | ITEM2(Library, _, _) -> failwith " ITEM2(Library, _, _) " + | ITEM2(Libraryref, _, _) -> failwith " ITEM2(Libraryref, _, _) " + | ITEM2(Listofnets, _, _) -> failwith " ITEM2(Listofnets, _, _) " + | ITEM2(Listofports, _, _) -> failwith " ITEM2(Listofports, _, _) " + | ITEM2(Loaddelay, _, _) -> failwith " ITEM2(Loaddelay, _, _) " + | ITEM2(Logicassign, _, _) -> failwith " ITEM2(Logicassign, _, _) " + | ITEM2(Logicinput, _, _) -> failwith " ITEM2(Logicinput, _, _) " + | ITEM2(Logiclist, _, _) -> failwith " ITEM2(Logiclist, _, _) " + | ITEM2(Logicmapinput, _, _) -> failwith " ITEM2(Logicmapinput, _, _) " + | ITEM2(Logicmapoutput, _, _) -> failwith " ITEM2(Logicmapoutput, _, _) " + | ITEM2(Logiconeof, _, _) -> failwith " ITEM2(Logiconeof, _, _) " + | ITEM2(Logicoutput, _, _) -> failwith " ITEM2(Logicoutput, _, _) " + | ITEM2(Logicport, _, _) -> failwith " ITEM2(Logicport, _, _) " + | ITEM2(Logicref, _, _) -> failwith " ITEM2(Logicref, _, _) " + | ITEM2(Logicvalue, _, _) -> failwith " ITEM2(Logicvalue, _, _) " + | ITEM2(Logicwaveform, _, _) -> failwith " ITEM2(Logicwaveform, _, _) " + | ITEM2(Maintain, _, _) -> failwith " ITEM2(Maintain, _, _) " + | ITEM2(Match, _, _) -> failwith " ITEM2(Match, _, _) " + | ITEM2(Max, _, _) -> failwith " ITEM2(Max, _, _) " + | ITEM2(Member, _, _) -> failwith " ITEM2(Member, _, _) " + | ITEM2(Min, _, _) -> failwith " ITEM2(Min, _, _) " + | ITEM2(Minomax, _, _) -> failwith " ITEM2(Minomax, _, _) " + | ITEM2(Minomaxdisplay, _, _) -> failwith " ITEM2(Minomaxdisplay, _, _) " + | ITEM2(Mnm, _, _) -> failwith " ITEM2(Mnm, _, _) " + | ITEM2(Mod, _, _) -> failwith " ITEM2(Mod, _, _) " + | ITEM2(Multiplevalueset, _, _) -> failwith " ITEM2(Multiplevalueset, _, _) " + | ITEM2(Mustjoin, _, _) -> failwith " ITEM2(Mustjoin, _, _) " + | ITEM2(Name, _, _) -> failwith " ITEM2(Name, _, _) " + | ITEM2(Negate, _, _) -> failwith " ITEM2(Negate, _, _) " +(* + | ITEM2(Net, _, _) -> failwith " ITEM2(Net, _, _) " +*) + | ITEM2(Netbackannotate, _, _) -> failwith " ITEM2(Netbackannotate, _, _) " + | ITEM2(Netbundle, _, _) -> failwith " ITEM2(Netbundle, _, _) " + | ITEM2(Netdelay, _, _) -> failwith " ITEM2(Netdelay, _, _) " + | ITEM2(Netgroup, _, _) -> failwith " ITEM2(Netgroup, _, _) " + | ITEM2(Netmap, _, _) -> failwith " ITEM2(Netmap, _, _) " + | ITEM2(Netref, _, _) -> failwith " ITEM2(Netref, _, _) " + | ITEM2(Nochange, _, _) -> failwith " ITEM2(Nochange, _, _) " + | ITEM2(Nonpermutable, _, _) -> failwith " ITEM2(Nonpermutable, _, _) " + | ITEM2(Not, _, _) -> failwith " ITEM2(Not, _, _) " + | ITEM2(Notallowed, _, _) -> failwith " ITEM2(Notallowed, _, _) " + | ITEM2(Notchspacing, _, _) -> failwith " ITEM2(Notchspacing, _, _) " + | ITEM2(Number, _, _) -> failwith " ITEM2(Number, _, _) " + | ITEM2(Numberdefinition, _, _) -> failwith " ITEM2(Numberdefinition, _, _) " + | ITEM2(Numberdisplay, _, _) -> failwith " ITEM2(Numberdisplay, _, _) " + | ITEM2(Offpageconnector, _, _) -> failwith " ITEM2(Offpageconnector, _, _) " + | ITEM2(Offsetevent, _, _) -> failwith " ITEM2(Offsetevent, _, _) " + | ITEM2(Openshape, _, _) -> failwith " ITEM2(Openshape, _, _) " + | ITEM2(Or, _, _) -> failwith " ITEM2(Or, _, _) " + | ITEM2(Orientation, _, _) -> failwith " ITEM2(Orientation, _, _) " + | ITEM2(Origin, _, _) -> failwith " ITEM2(Origin, _, _) " + | ITEM2(Overhangdistance, _, _) -> failwith " ITEM2(Overhangdistance, _, _) " + | ITEM2(Overlapdistance, _, _) -> failwith " ITEM2(Overlapdistance, _, _) " + | ITEM2(Oversize, _, _) -> failwith " ITEM2(Oversize, _, _) " + | ITEM2(Owner, _, _) -> failwith " ITEM2(Owner, _, _) " + | ITEM2(Page, _, _) -> failwith " ITEM2(Page, _, _) " + | ITEM2(Pagesize, _, _) -> failwith " ITEM2(Pagesize, _, _) " + | ITEM2(Parameter, _, _) -> failwith " ITEM2(Parameter, _, _) " + | ITEM2(Parameterassign, _, _) -> failwith " ITEM2(Parameterassign, _, _) " + | ITEM2(Parameterdisplay, _, _) -> failwith " ITEM2(Parameterdisplay, _, _) " + | ITEM2(Path, _, _) -> failwith " ITEM2(Path, _, _) " + | ITEM2(Pathdelay, _, _) -> failwith " ITEM2(Pathdelay, _, _) " + | ITEM2(Pathwidth, _, _) -> failwith " ITEM2(Pathwidth, _, _) " + | ITEM2(Permutable, _, _) -> failwith " ITEM2(Permutable, _, _) " + | ITEM2(Physicaldesignrule, _, _) -> failwith " ITEM2(Physicaldesignrule, _, _) " + | ITEM2(Plug, _, _) -> failwith " ITEM2(Plug, _, _) " + | ITEM2(Point, _, _) -> failwith " ITEM2(Point, _, _) " + | ITEM2(Pointdisplay, _, _) -> failwith " ITEM2(Pointdisplay, _, _) " + | ITEM2(Pointlist, _, _) -> failwith " ITEM2(Pointlist, _, _) " + | ITEM2(Pointsubtract, _, _) -> failwith " ITEM2(Pointsubtract, _, _) " + | ITEM2(Pointsum, _, _) -> failwith " ITEM2(Pointsum, _, _) " + | ITEM2(Polygon, _, _) -> failwith " ITEM2(Polygon, _, _) " + | ITEM2(Port, _, _) -> failwith " ITEM2(Port, _, _) " + | ITEM2(Portbackannotate, _, _) -> failwith " ITEM2(Portbackannotate, _, _) " + | ITEM2(Portbundle, _, _) -> failwith " ITEM2(Portbundle, _, _) " + | ITEM2(Portdelay, _, _) -> failwith " ITEM2(Portdelay, _, _) " + | ITEM2(Portgroup, _, _) -> failwith " ITEM2(Portgroup, _, _) " + | ITEM2(Portimplementation, _, _) -> failwith " ITEM2(Portimplementation, _, _) " + | ITEM2(Portinstance, _, _) -> failwith " ITEM2(Portinstance, _, _) " + | ITEM2(Portlist, _, _) -> failwith " ITEM2(Portlist, _, _) " + | ITEM2(Portlistalias, _, _) -> failwith " ITEM2(Portlistalias, _, _) " + | ITEM2(Portmap, _, _) -> failwith " ITEM2(Portmap, _, _) " + | ITEM2(Portref, _, _) -> failwith " ITEM2(Portref, _, _) " + | ITEM2(Product, _, _) -> failwith " ITEM2(Product, _, _) " + | ITEM2(Program, _, _) -> failwith " ITEM2(Program, _, _) " + | ITEM2(Property, _, _) -> failwith " ITEM2(Property, _, _) " + | ITEM2(Propertydisplay, _, _) -> failwith " ITEM2(Propertydisplay, _, _) " + | ITEM2(Protectionframe, _, _) -> failwith " ITEM2(Protectionframe, _, _) " + | ITEM2(Pt, _, _) -> failwith " ITEM2(Pt, _, _) " + | ITEM2(Rangevector, _, _) -> failwith " ITEM2(Rangevector, _, _) " + | ITEM2(Rectangle, _, _) -> failwith " ITEM2(Rectangle, _, _) " + | ITEM2(Rectanglesize, _, _) -> failwith " ITEM2(Rectanglesize, _, _) " + | ITEM2(Rename, _, _) -> failwith " ITEM2(Rename, _, _) " + | ITEM2(Resolves, _, _) -> failwith " ITEM2(Resolves, _, _) " + | ITEM2(Scale, _, _) -> failwith " ITEM2(Scale, _, _) " + | ITEM2(Scalex, _, _) -> failwith " ITEM2(Scalex, _, _) " + | ITEM2(Scaley, _, _) -> failwith " ITEM2(Scaley, _, _) " + | ITEM2(Section, _, _) -> failwith " ITEM2(Section, _, _) " + | ITEM2(Shape, _, _) -> failwith " ITEM2(Shape, _, _) " + | ITEM2(Simulate, _, _) -> failwith " ITEM2(Simulate, _, _) " + | ITEM2(Simulationinfo, _, _) -> failwith " ITEM2(Simulationinfo, _, _) " + | ITEM2(Singlevalueset, _, _) -> failwith " ITEM2(Singlevalueset, _, _) " + | ITEM2(Site, _, _) -> failwith " ITEM2(Site, _, _) " + | ITEM2(Socket, _, _) -> failwith " ITEM2(Socket, _, _) " + | ITEM2(Socketset, _, _) -> failwith " ITEM2(Socketset, _, _) " + | ITEM2(Statement, _, _) -> failwith " ITEM2(Statement, _, _) " + | ITEM2(Status, _, _) -> failwith " ITEM2(Status, _, _) " + | ITEM2(Steady, _, _) -> failwith " ITEM2(Steady, _, _) " + | ITEM2(Strictlyincreasing, _, _) -> failwith " ITEM2(Strictlyincreasing, _, _) " + | ITEM2(String, _, _) -> failwith " ITEM2(String, _, _) " + | ITEM2(Stringdisplay, _, _) -> failwith " ITEM2(Stringdisplay, _, _) " + | ITEM2(Strong, _, _) -> failwith " ITEM2(Strong, _, _) " + | ITEM2(Subtract, _, _) -> failwith " ITEM2(Subtract, _, _) " + | ITEM2(Sum, _, _) -> failwith " ITEM2(Sum, _, _) " + | ITEM2(Symbol, _, _) -> failwith " ITEM2(Symbol, _, _) " + | ITEM2(Symmetry, _, _) -> failwith " ITEM2(Symmetry, _, _) " + | ITEM2(Table, _, _) -> failwith " ITEM2(Table, _, _) " + | ITEM2(Tabledefault, _, _) -> failwith " ITEM2(Tabledefault, _, _) " + | ITEM2(Technology, _, _) -> failwith " ITEM2(Technology, _, _) " + | ITEM2(Textheight, _, _) -> failwith " ITEM2(Textheight, _, _) " + | ITEM2(Then, _, _) -> failwith " ITEM2(Then, _, _) " + | ITEM2(Timeinterval, _, _) -> failwith " ITEM2(Timeinterval, _, _) " + | ITEM2(Timestamp, _, _) -> failwith " ITEM2(Timestamp, _, _) " + | ITEM2(Timing, _, _) -> failwith " ITEM2(Timing, _, _) " + | ITEM2(Transform, _, _) -> failwith " ITEM2(Transform, _, _) " + | ITEM2(Transition, _, _) -> failwith " ITEM2(Transition, _, _) " + | ITEM2(Trigger, _, _) -> failwith " ITEM2(Trigger, _, _) " + | ITEM2(True, _, _) -> failwith " ITEM2(True, _, _) " + | ITEM2(Typedvalue, _, _) -> failwith " ITEM2(Typedvalue, _, _) " + | ITEM2(Unconstrained, _, _) -> failwith " ITEM2(Unconstrained, _, _) " + | ITEM2(Undefined, _, _) -> failwith " ITEM2(Undefined, _, _) " + | ITEM2(Union, _, _) -> failwith " ITEM2(Union, _, _) " + | ITEM2(Unit, _, _) -> failwith " ITEM2(Unit, _, _) " + | ITEM2(Unused, _, _) -> failwith " ITEM2(Unused, _, _) " + | ITEM2(Userdata, _, _) -> failwith " ITEM2(Userdata, _, _) " + | ITEM2(Valuenameref, _, _) -> failwith " ITEM2(Valuenameref, _, _) " + | ITEM2(Variable, _, _) -> failwith " ITEM2(Variable, _, _) " + | ITEM2(Version, _, _) -> failwith " ITEM2(Version, _, _) " + | ITEM2(View, _, _) -> failwith " ITEM2(View, _, _) " + | ITEM2(Viewlist, _, _) -> failwith " ITEM2(Viewlist, _, _) " + | ITEM2(Viewmap, _, _) -> failwith " ITEM2(Viewmap, _, _) " + | ITEM2(Viewref, _, _) -> failwith " ITEM2(Viewref, _, _) " + | ITEM2(Viewtype, _, _) -> failwith " ITEM2(Viewtype, _, _) " + | ITEM2(Visible, _, _) -> failwith " ITEM2(Visible, _, _) " + | ITEM2(Voltagemap, _, _) -> failwith " ITEM2(Voltagemap, _, _) " + | ITEM2(Wavevalue, _, _) -> failwith " ITEM2(Wavevalue, _, _) " + | ITEM2(Weak, _, _) -> failwith " ITEM2(Weak, _, _) " + | ITEM2(Weakjoined, _, _) -> failwith " ITEM2(Weakjoined, _, _) " + | ITEM2(When, _, _) -> failwith " ITEM2(When, _, _) " + | ITEM2(While, _, _) -> failwith " ITEM2(While, _, _) " + | ITEM2(Written, _, _) -> failwith " ITEM2(Written, _, _) " + | ITEM2(Xcoord, _, _) -> failwith " ITEM2(Xcoord, _, _) " + | ITEM2(Xor, _, _) -> failwith " ITEM2(Xor, _, _) " + | ITEM2(Ycoord, _, _) -> failwith " ITEM2(Ycoord, _, _) " + | ITEM2(ILLEGAL _, _, _) -> failwith " ITEM2(ILLEGAL _, _, _) " + | ITEM2(ID _, _, _) -> failwith " ITEM2(ID _, _, _) " + | ITEM2(TLIST _, _, _) -> failwith " ITEM2(TLIST _, _, _) " + | ITEM2(TLIST2 _, _, _) -> failwith " ITEM2(TLIST2 _, _, _) " + | ITEM2(STRING _, _, _) -> failwith " ITEM2(STRING _, _, _) " + | ITEM2(INT _, _, _) -> failwith " ITEM2(INT _, _, _) " + | ITEM2(ENDOFFILE, _, _) -> failwith " ITEM2(ENDOFFILE, _, _) " + | ITEM2(EOL, _, _) -> failwith " ITEM2(EOL, _, _) " + | ITEM2(LPAREN, _, _) -> failwith " ITEM2(LPAREN, _, _) " + | ITEM2(RPAREN, _, _) -> failwith " ITEM2(RPAREN, _, _) " + | ITEM2(EMPTY, _, _) -> failwith " ITEM2(EMPTY, _, _) " + + | ITEM(Abs, _) -> failwith " ITEM(Abs, _) " + | ITEM(Acload, _) -> failwith " ITEM(Acload, _) " + | ITEM(After, _) -> failwith " ITEM(After, _) " + | ITEM(And, _) -> failwith " ITEM(And, _) " + | ITEM(Annotate, _) -> failwith " ITEM(Annotate, _) " + | ITEM(Apply, _) -> failwith " ITEM(Apply, _) " + | ITEM(Arc, _) -> failwith " ITEM(Arc, _) " + | ITEM(Array, _) -> failwith " ITEM(Array, _) " + | ITEM(Arraymacro, _) -> failwith " ITEM(Arraymacro, _) " + | ITEM(Arrayrelatedinfo, _) -> failwith " ITEM(Arrayrelatedinfo, _) " + | ITEM(Arraysite, _) -> failwith " ITEM(Arraysite, _) " + | ITEM(Assign, _) -> failwith " ITEM(Assign, _) " + | ITEM(Atleast, _) -> failwith " ITEM(Atleast, _) " + | ITEM(Atmost, _) -> failwith " ITEM(Atmost, _) " + | ITEM(Author, _) -> failwith " ITEM(Author, _) " + | ITEM(Basearray, _) -> failwith " ITEM(Basearray, _) " + | ITEM(Becomes, _) -> failwith " ITEM(Becomes, _) " + | ITEM(Between, _) -> failwith " ITEM(Between, _) " + | ITEM(Block, _) -> failwith " ITEM(Block, _) " + | ITEM(Boolean, _) -> failwith " ITEM(Boolean, _) " + | ITEM(Booleandisplay, _) -> failwith " ITEM(Booleandisplay, _) " + | ITEM(Booleanmap, _) -> failwith " ITEM(Booleanmap, _) " + | ITEM(Booleanvalue, _) -> failwith " ITEM(Booleanvalue, _) " + | ITEM(Borderpattern, _) -> failwith " ITEM(Borderpattern, _) " + | ITEM(Borderwidth, _) -> failwith " ITEM(Borderwidth, _) " + | ITEM(Boundingbox, _) -> failwith " ITEM(Boundingbox, _) " + | ITEM(Ceiling, _) -> failwith " ITEM(Ceiling, _) " + | ITEM(Cell, _) -> failwith " ITEM(Cell, _) " + | ITEM(Cellref, _) -> failwith " ITEM(Cellref, _) " + | ITEM(Celltype, _) -> failwith " ITEM(Celltype, _) " + | ITEM(Change, _) -> failwith " ITEM(Change, _) " + | ITEM(Circle, _) -> failwith " ITEM(Circle, _) " + | ITEM(Color, _) -> failwith " ITEM(Color, _) " + | ITEM(Comment, _) -> 32 + | ITEM(Commentgraphics, _) -> failwith " ITEM(Commentgraphics, _) " + | ITEM(Compound, _) -> failwith " ITEM(Compound, _) " + | ITEM(Concat, _) -> failwith " ITEM(Concat, _) " + | ITEM(Connectlocation, _) -> failwith " ITEM(Connectlocation, _) " + | ITEM(Constant, _) -> failwith " ITEM(Constant, _) " + | ITEM(Constraint, _) -> failwith " ITEM(Constraint, _) " + | ITEM(Contents, _) -> failwith " ITEM(Contents, _) " + | ITEM(Cornertype, _) -> failwith " ITEM(Cornertype, _) " + | ITEM(Criticality, _) -> failwith " ITEM(Criticality, _) " + | ITEM(Currentmap, _) -> failwith " ITEM(Currentmap, _) " + | ITEM(Curve, _) -> failwith " ITEM(Curve, _) " + | ITEM(Cycle, _) -> failwith " ITEM(Cycle, _) " + | ITEM(Dataorigin, _) -> failwith " ITEM(Dataorigin, _) " + | ITEM(Dcfaninload, _) -> failwith " ITEM(Dcfaninload, _) " + | ITEM(Dcfanoutload, _) -> failwith " ITEM(Dcfanoutload, _) " + | ITEM(Dcmaxfanin, _) -> failwith " ITEM(Dcmaxfanin, _) " + | ITEM(Dcmaxfanout, _) -> failwith " ITEM(Dcmaxfanout, _) " + | ITEM(Delay, _) -> failwith " ITEM(Delay, _) " + | ITEM(Delta, _) -> failwith " ITEM(Delta, _) " + | ITEM(Derivation, _) -> failwith " ITEM(Derivation, _) " + | ITEM(Design, _) -> failwith " ITEM(Design, _) " + | ITEM(Designator, _) -> failwith " ITEM(Designator, _) " + | ITEM(Difference, _) -> failwith " ITEM(Difference, _) " + | ITEM(Direction, _) -> failwith " ITEM(Direction, _) " + | ITEM(Display, _) -> failwith " ITEM(Display, _) " + | ITEM(Divide, _) -> failwith " ITEM(Divide, _) " + | ITEM(Dominates, _) -> failwith " ITEM(Dominates, _) " + | ITEM(Dot, _) -> failwith " ITEM(Dot, _) " + | ITEM(Duration, _) -> failwith " ITEM(Duration, _) " + | ITEM(E, _) -> failwith " ITEM(E, _) " + | ITEM(Edif, _) -> failwith " ITEM(Edif, _) " + | ITEM(Ediflevel, _) -> failwith " ITEM(Ediflevel, _) " + | ITEM(Edifversion, _) -> failwith " ITEM(Edifversion, _) " + | ITEM(Else, _) -> failwith " ITEM(Else, _) " + | ITEM(Enclosuredistance, _) -> failwith " ITEM(Enclosuredistance, _) " + | ITEM(Endtype, _) -> failwith " ITEM(Endtype, _) " + | ITEM(Entry, _) -> failwith " ITEM(Entry, _) " + | ITEM(Equal, _) -> failwith " ITEM(Equal, _) " + | ITEM(Escape, _) -> failwith " ITEM(Escape, _) " + | ITEM(Event, _) -> failwith " ITEM(Event, _) " + | ITEM(Exactly, _) -> failwith " ITEM(Exactly, _) " + | ITEM(External, _) -> failwith " ITEM(External, _) " + | ITEM(Fabricate, _) -> failwith " ITEM(Fabricate, _) " + | ITEM(False, _) -> failwith " ITEM(False, _) " + | ITEM(Figure, _) -> failwith " ITEM(Figure, _) " + | ITEM(Figurearea, _) -> failwith " ITEM(Figurearea, _) " + | ITEM(Figuregroup, _) -> failwith " ITEM(Figuregroup, _) " + | ITEM(Figuregroupobject, _) -> failwith " ITEM(Figuregroupobject, _) " + | ITEM(Figuregroupoverride, _) -> failwith " ITEM(Figuregroupoverride, _) " + | ITEM(Figuregroupref, _) -> failwith " ITEM(Figuregroupref, _) " + | ITEM(Figureperimeter, _) -> failwith " ITEM(Figureperimeter, _) " + | ITEM(Figurewidth, _) -> failwith " ITEM(Figurewidth, _) " + | ITEM(Fillpattern, _) -> failwith " ITEM(Fillpattern, _) " + | ITEM(Fix, _) -> failwith " ITEM(Fix, _) " + | ITEM(Floor, _) -> failwith " ITEM(Floor, _) " + | ITEM(Follow, _) -> failwith " ITEM(Follow, _) " + | ITEM(Forbiddenevent, _) -> failwith " ITEM(Forbiddenevent, _) " + | ITEM(Form, _) -> failwith " ITEM(Form, _) " + | ITEM(Globalportref, _) -> failwith " ITEM(Globalportref, _) " + | ITEM(Greaterthan, _) -> failwith " ITEM(Greaterthan, _) " + | ITEM(Gridmap, _) -> failwith " ITEM(Gridmap, _) " + | ITEM(If, _) -> failwith " ITEM(If, _) " + | ITEM(Ignore, _) -> failwith " ITEM(Ignore, _) " + | ITEM(Includefiguregroup, _) -> failwith " ITEM(Includefiguregroup, _) " + | ITEM(Increasing, _) -> failwith " ITEM(Increasing, _) " + | ITEM(Initial, _) -> failwith " ITEM(Initial, _) " + | ITEM(Instance, _) -> failwith " ITEM(Instance, _) " + | ITEM(Instancebackannotate, _) -> failwith " ITEM(Instancebackannotate, _) " + | ITEM(Instancegroup, _) -> failwith " ITEM(Instancegroup, _) " + | ITEM(Instancemap, _) -> failwith " ITEM(Instancemap, _) " + | ITEM(Instancenamedef, _) -> failwith " ITEM(Instancenamedef, _) " + | ITEM(Instanceref, _) -> failwith " ITEM(Instanceref, _) " + | ITEM(Integer, _) -> failwith " ITEM(Integer, _) " + | ITEM(Integerdisplay, _) -> failwith " ITEM(Integerdisplay, _) " + | ITEM(Interface, _) -> failwith " ITEM(Interface, _) " + | ITEM(Interfiguregroupspacing, _) -> failwith " ITEM(Interfiguregroupspacing, _) " + | ITEM(Intersection, _) -> failwith " ITEM(Intersection, _) " + | ITEM(Intrafiguregroupspacing, _) -> failwith " ITEM(Intrafiguregroupspacing, _) " + | ITEM(Inverse, _) -> failwith " ITEM(Inverse, _) " + | ITEM(Isolated, _) -> failwith " ITEM(Isolated, _) " + | ITEM(Iterate, _) -> failwith " ITEM(Iterate, _) " + | ITEM(Joined, _) -> failwith " ITEM(Joined, _) " + | ITEM(Justify, _) -> failwith " ITEM(Justify, _) " + | ITEM(Keyworddisplay, _) -> failwith " ITEM(Keyworddisplay, _) " + | ITEM(Keywordlevel, _) -> failwith " ITEM(Keywordlevel, _) " + | ITEM(Keywordmap, _) -> failwith " ITEM(Keywordmap, _) " + | ITEM(Lessthan, _) -> failwith " ITEM(Lessthan, _) " + | ITEM(Library, _) -> failwith " ITEM(Library, _) " + | ITEM(Libraryref, _) -> failwith " ITEM(Libraryref, _) " + | ITEM(Listofnets, _) -> failwith " ITEM(Listofnets, _) " + | ITEM(Listofports, _) -> failwith " ITEM(Listofports, _) " + | ITEM(Loaddelay, _) -> failwith " ITEM(Loaddelay, _) " + | ITEM(Logicassign, _) -> failwith " ITEM(Logicassign, _) " + | ITEM(Logicinput, _) -> failwith " ITEM(Logicinput, _) " + | ITEM(Logiclist, _) -> failwith " ITEM(Logiclist, _) " + | ITEM(Logicmapinput, _) -> failwith " ITEM(Logicmapinput, _) " + | ITEM(Logicmapoutput, _) -> failwith " ITEM(Logicmapoutput, _) " + | ITEM(Logiconeof, _) -> failwith " ITEM(Logiconeof, _) " + | ITEM(Logicoutput, _) -> failwith " ITEM(Logicoutput, _) " + | ITEM(Logicport, _) -> failwith " ITEM(Logicport, _) " + | ITEM(Logicref, _) -> failwith " ITEM(Logicref, _) " + | ITEM(Logicvalue, _) -> failwith " ITEM(Logicvalue, _) " + | ITEM(Logicwaveform, _) -> failwith " ITEM(Logicwaveform, _) " + | ITEM(Maintain, _) -> failwith " ITEM(Maintain, _) " + | ITEM(Match, _) -> failwith " ITEM(Match, _) " + | ITEM(Max, _) -> failwith " ITEM(Max, _) " + | ITEM(Member, _) -> failwith " ITEM(Member, _) " + | ITEM(Min, _) -> failwith " ITEM(Min, _) " + | ITEM(Minomax, _) -> failwith " ITEM(Minomax, _) " + | ITEM(Minomaxdisplay, _) -> failwith " ITEM(Minomaxdisplay, _) " + | ITEM(Mnm, _) -> failwith " ITEM(Mnm, _) " + | ITEM(Mod, _) -> failwith " ITEM(Mod, _) " + | ITEM(Multiplevalueset, _) -> failwith " ITEM(Multiplevalueset, _) " + | ITEM(Mustjoin, _) -> failwith " ITEM(Mustjoin, _) " + | ITEM(Name, _) -> failwith " ITEM(Name, _) " + | ITEM(Negate, _) -> failwith " ITEM(Negate, _) " + | ITEM(Net, _) -> failwith " ITEM(Net, _) " + | ITEM(Netbackannotate, _) -> failwith " ITEM(Netbackannotate, _) " + | ITEM(Netbundle, _) -> failwith " ITEM(Netbundle, _) " + | ITEM(Netdelay, _) -> failwith " ITEM(Netdelay, _) " + | ITEM(Netgroup, _) -> failwith " ITEM(Netgroup, _) " + | ITEM(Netmap, _) -> failwith " ITEM(Netmap, _) " + | ITEM(Netref, _) -> failwith " ITEM(Netref, _) " + | ITEM(Nochange, _) -> failwith " ITEM(Nochange, _) " + | ITEM(Nonpermutable, _) -> failwith " ITEM(Nonpermutable, _) " + | ITEM(Not, _) -> failwith " ITEM(Not, _) " + | ITEM(Notallowed, _) -> failwith " ITEM(Notallowed, _) " + | ITEM(Notchspacing, _) -> failwith " ITEM(Notchspacing, _) " + | ITEM(Number, _) -> failwith " ITEM(Number, _) " + | ITEM(Numberdefinition, _) -> failwith " ITEM(Numberdefinition, _) " + | ITEM(Numberdisplay, _) -> failwith " ITEM(Numberdisplay, _) " + | ITEM(Offpageconnector, _) -> failwith " ITEM(Offpageconnector, _) " + | ITEM(Offsetevent, _) -> failwith " ITEM(Offsetevent, _) " + | ITEM(Openshape, _) -> failwith " ITEM(Openshape, _) " + | ITEM(Or, _) -> failwith " ITEM(Or, _) " + | ITEM(Orientation, _) -> failwith " ITEM(Orientation, _) " + | ITEM(Origin, _) -> failwith " ITEM(Origin, _) " + | ITEM(Overhangdistance, _) -> failwith " ITEM(Overhangdistance, _) " + | ITEM(Overlapdistance, _) -> failwith " ITEM(Overlapdistance, _) " + | ITEM(Oversize, _) -> failwith " ITEM(Oversize, _) " + | ITEM(Owner, _) -> failwith " ITEM(Owner, _) " + | ITEM(Page, _) -> failwith " ITEM(Page, _) " + | ITEM(Pagesize, _) -> failwith " ITEM(Pagesize, _) " + | ITEM(Parameter, _) -> failwith " ITEM(Parameter, _) " + | ITEM(Parameterassign, _) -> failwith " ITEM(Parameterassign, _) " + | ITEM(Parameterdisplay, _) -> failwith " ITEM(Parameterdisplay, _) " + | ITEM(Path, _) -> failwith " ITEM(Path, _) " + | ITEM(Pathdelay, _) -> failwith " ITEM(Pathdelay, _) " + | ITEM(Pathwidth, _) -> failwith " ITEM(Pathwidth, _) " + | ITEM(Permutable, _) -> failwith " ITEM(Permutable, _) " + | ITEM(Physicaldesignrule, _) -> failwith " ITEM(Physicaldesignrule, _) " + | ITEM(Plug, _) -> failwith " ITEM(Plug, _) " + | ITEM(Point, _) -> failwith " ITEM(Point, _) " + | ITEM(Pointdisplay, _) -> failwith " ITEM(Pointdisplay, _) " + | ITEM(Pointlist, _) -> failwith " ITEM(Pointlist, _) " + | ITEM(Pointsubtract, _) -> failwith " ITEM(Pointsubtract, _) " + | ITEM(Pointsum, _) -> failwith " ITEM(Pointsum, _) " + | ITEM(Polygon, _) -> failwith " ITEM(Polygon, _) " + | ITEM(Port, _) -> failwith " ITEM(Port, _) " + | ITEM(Portbackannotate, _) -> failwith " ITEM(Portbackannotate, _) " + | ITEM(Portbundle, _) -> failwith " ITEM(Portbundle, _) " + | ITEM(Portdelay, _) -> failwith " ITEM(Portdelay, _) " + | ITEM(Portgroup, _) -> failwith " ITEM(Portgroup, _) " + | ITEM(Portimplementation, _) -> failwith " ITEM(Portimplementation, _) " + | ITEM(Portinstance, _) -> failwith " ITEM(Portinstance, _) " + | ITEM(Portlist, _) -> failwith " ITEM(Portlist, _) " + | ITEM(Portlistalias, _) -> failwith " ITEM(Portlistalias, _) " + | ITEM(Portmap, _) -> failwith " ITEM(Portmap, _) " + | ITEM(Portref, _) -> failwith " ITEM(Portref, _) " + | ITEM(Product, _) -> failwith " ITEM(Product, _) " + | ITEM(Program, _) -> failwith " ITEM(Program, _) " + | ITEM(Property, _) -> failwith " ITEM(Property, _) " + | ITEM(Propertydisplay, _) -> failwith " ITEM(Propertydisplay, _) " + | ITEM(Protectionframe, _) -> failwith " ITEM(Protectionframe, _) " + | ITEM(Pt, _) -> failwith " ITEM(Pt, _) " + | ITEM(Rangevector, _) -> failwith " ITEM(Rangevector, _) " + | ITEM(Rectangle, _) -> failwith " ITEM(Rectangle, _) " + | ITEM(Rectanglesize, _) -> failwith " ITEM(Rectanglesize, _) " + | ITEM(Rename, _) -> failwith " ITEM(Rename, _) " + | ITEM(Resolves, _) -> failwith " ITEM(Resolves, _) " + | ITEM(Scale, _) -> failwith " ITEM(Scale, _) " + | ITEM(Scalex, _) -> failwith " ITEM(Scalex, _) " + | ITEM(Scaley, _) -> failwith " ITEM(Scaley, _) " + | ITEM(Section, _) -> failwith " ITEM(Section, _) " + | ITEM(Shape, _) -> failwith " ITEM(Shape, _) " + | ITEM(Simulate, _) -> failwith " ITEM(Simulate, _) " + | ITEM(Simulationinfo, _) -> failwith " ITEM(Simulationinfo, _) " + | ITEM(Singlevalueset, _) -> failwith " ITEM(Singlevalueset, _) " + | ITEM(Site, _) -> failwith " ITEM(Site, _) " + | ITEM(Socket, _) -> failwith " ITEM(Socket, _) " + | ITEM(Socketset, _) -> failwith " ITEM(Socketset, _) " + | ITEM(Statement, _) -> failwith " ITEM(Statement, _) " + | ITEM(Status, _) -> failwith " ITEM(Status, _) " + | ITEM(Steady, _) -> failwith " ITEM(Steady, _) " + | ITEM(Strictlyincreasing, _) -> failwith " ITEM(Strictlyincreasing, _) " + | ITEM(String, _) -> failwith " ITEM(String, _) " + | ITEM(Stringdisplay, _) -> failwith " ITEM(Stringdisplay, _) " + | ITEM(Strong, _) -> failwith " ITEM(Strong, _) " + | ITEM(Subtract, _) -> failwith " ITEM(Subtract, _) " + | ITEM(Sum, _) -> failwith " ITEM(Sum, _) " + | ITEM(Symbol, _) -> failwith " ITEM(Symbol, _) " + | ITEM(Symmetry, _) -> failwith " ITEM(Symmetry, _) " + | ITEM(Table, _) -> failwith " ITEM(Table, _) " + | ITEM(Tabledefault, _) -> failwith " ITEM(Tabledefault, _) " + | ITEM(Technology, _) -> failwith " ITEM(Technology, _) " + | ITEM(Textheight, _) -> failwith " ITEM(Textheight, _) " + | ITEM(Then, _) -> failwith " ITEM(Then, _) " + | ITEM(Timeinterval, _) -> failwith " ITEM(Timeinterval, _) " + | ITEM(Timestamp, _) -> failwith " ITEM(Timestamp, _) " + | ITEM(Timing, _) -> failwith " ITEM(Timing, _) " + | ITEM(Transform, _) -> failwith " ITEM(Transform, _) " + | ITEM(Transition, _) -> failwith " ITEM(Transition, _) " + | ITEM(Trigger, _) -> failwith " ITEM(Trigger, _) " + | ITEM(True, _) -> failwith " ITEM(True, _) " + | ITEM(Typedvalue, _) -> failwith " ITEM(Typedvalue, _) " + | ITEM(Unconstrained, _) -> failwith " ITEM(Unconstrained, _) " + | ITEM(Undefined, _) -> failwith " ITEM(Undefined, _) " + | ITEM(Union, _) -> failwith " ITEM(Union, _) " + | ITEM(Unit, _) -> failwith " ITEM(Unit, _) " + | ITEM(Unused, _) -> failwith " ITEM(Unused, _) " + | ITEM(Userdata, _) -> failwith " ITEM(Userdata, _) " + | ITEM(Valuenameref, _) -> failwith " ITEM(Valuenameref, _) " + | ITEM(Variable, _) -> failwith " ITEM(Variable, _) " + | ITEM(Version, _) -> failwith " ITEM(Version, _) " + | ITEM(View, _) -> failwith " ITEM(View, _) " + | ITEM(Viewlist, _) -> failwith " ITEM(Viewlist, _) " + | ITEM(Viewmap, _) -> failwith " ITEM(Viewmap, _) " + | ITEM(Viewref, _) -> failwith " ITEM(Viewref, _) " + | ITEM(Viewtype, _) -> failwith " ITEM(Viewtype, _) " + | ITEM(Visible, _) -> failwith " ITEM(Visible, _) " + | ITEM(Voltagemap, _) -> failwith " ITEM(Voltagemap, _) " + | ITEM(Wavevalue, _) -> failwith " ITEM(Wavevalue, _) " + | ITEM(Weak, _) -> failwith " ITEM(Weak, _) " + | ITEM(Weakjoined, _) -> failwith " ITEM(Weakjoined, _) " + | ITEM(When, _) -> failwith " ITEM(When, _) " + | ITEM(While, _) -> failwith " ITEM(While, _) " + | ITEM(Written, _) -> failwith " ITEM(Written, _) " + | ITEM(Xcoord, _) -> failwith " ITEM(Xcoord, _) " + | ITEM(Xor, _) -> failwith " ITEM(Xor, _) " + | ITEM(Ycoord, _) -> failwith " ITEM(Ycoord, _) " + | ITEM(ILLEGAL _, _) -> failwith " ITEM(ILLEGAL _, _) " + | ITEM(ID _, _) -> failwith " ITEM(ID _, _) " + | ITEM(TLIST _, _) -> failwith " ITEM(TLIST _, _) " + | ITEM(TLIST2 _, _) -> failwith " ITEM(TLIST2 _, _) " + | ITEM(STRING _, _) -> failwith " ITEM(STRING _, _) " + | ITEM(INT _, _) -> failwith " ITEM(INT _, _) " + | ITEM(ENDOFFILE, _) -> failwith " ITEM(ENDOFFILE, _) " + | ITEM(EOL, _) -> failwith " ITEM(EOL, _) " + | ITEM(LPAREN, _) -> failwith " ITEM(LPAREN, _) " + | ITEM(RPAREN, _) -> failwith " ITEM(RPAREN, _) " + | ITEM(EMPTY, _) -> failwith " ITEM(EMPTY, _) " + | ITEM ((ITEM _|ITEM2 _), _) -> failwith " ITEM ((ITEM _|ITEM2 _), _) " + | ITEM2 ((ITEM _|ITEM2 _), _, _) -> failwith " ITEM2 ((ITEM _|ITEM2 _), _, _) " + +let () = printf "PR#6646=Ok\n%!" + +(* Simplified example, with application test *) + +type t = + | B of int + | C of int + | I of t list + | A00 + | A01 + | A02 + | A03 + | A04 + | A05 + | A06 + | A07 + | A08 + | A09 + | A10 + | A11 + | A12 + | A13 + | A14 + | A15 + | A16 + | A17 + | A18 + | A19 + | A20 + | A21 + | A22 + | A23 + | A24 + | A25 + | A26 + | A27 + | A28 + | A29 + | A30 + | A31 + | A32 + | A33 + | A34 + | A35 + | A36 + | A37 + | A38 + | A39 + | A40 + | A41 + | A42 + | A43 + | A44 + | A45 + | A46 + | A47 + | A48 + | A49 + | A50 + | A51 + | A52 + | A53 + | A54 + | A55 + | A56 + | A57 + | A58 + | A59 + | A60 + | A61 + | A62 + | A63 + | A64 + | A65 + | A66 + | A67 + | A68 + | A69 + | A70 + | A71 + | A72 + | A73 + | A74 + | A75 + | A76 + | A77 + | A78 + | A79 + | A80 + | A81 + | A82 + | A83 + | A84 + | A85 + | A86 + | A87 + | A88 + | A89 + | A90 + | A91 + | A92 + | A93 + | A94 + | A95 + | A96 + | A97 + | A98 + | A99 + + +let test = function + | I [A00;I [I [A00;I [A00]]]] -> 1 + | I [A00;I [I [A00;I [A01]]]] -> 2 + | I [A00;I [I [A00;I [A02]]]] -> 3 + | I [A00;I [I [A00;I [A03]]]] -> -3 + | I [A00;I [I [A00;I [A04]]]] -> 4 + | I [A00;I [I [A00;I [A05]]]] -> 5 + | I [A00;I [I [A00;I [A06]]]] -> 6 + | I [A00;I [I [A00;I [A07]]]] -> 7 + | I [A00;I [I [A00;I [A08]]]] -> 8 + | I [A00;I [I [A00;I [A09]]]] -> 9 + + | I [A00;I [I [_ ; I [A00]]]] -> 11 + | I [A00;I [I [_ ; I [A01]]]] -> 12 + | I [A00;I [I [_ ; I [A02]]]] -> 13 + | _ -> -1 + + +let () = + assert (test (I [A00;I [I [A00;I [A00]]]]) = 1) ; + assert (test (I [A00;I [I [A20;I [A00]]]]) = 11) ; + assert (test (I [A00;I [I [A00;I [A01]]]]) = 2) ; + assert (test (I [A00;I [I [A20;I [A01]]]]) = 12) ; + assert (test (I [A00;I [I [A00;I [A02]]]]) = 3) ; + assert (test (I [A00;I [I [A20;I [A02]]]]) = 13) ; + assert (test (I [A00;I [I [A00;I [A03]]]]) = -3) ; + assert (test (I [A00;I [I [A20;I [A03]]]]) = -1) ; + printf "PR#6646=Ok\n%!" + +(* PR#6674, a compilation failure introduced by correcting PR#6646 *) + +type t6674 = + | A1 + | A2 + | A3 + | A4 + | A5 + | A6 + | A7 + | A8 + | A9 + | A10 + | A11 + | A12 + | A13 + | A14 + | A15 + | A16 + | A17 + | A18 + | A19 + | A20 + | A21 + | A22 + | A23 + | A24 + | A25 + | A26 + | A27 + | A28 + | A29 + | A30 + | A31 + | A32 + | X of string + +let f = function + | X _ -> true + | _ -> false + +let () = printf "PR#6676=Ok\n%!" diff --git a/testsuite/tests/basic/patmatch.reference b/testsuite/tests/basic/patmatch.reference index fbe0167c91..aafc1b5c4f 100644 --- a/testsuite/tests/basic/patmatch.reference +++ b/testsuite/tests/basic/patmatch.reference @@ -70,3 +70,6 @@ PR#5992=Ok PR#5788=Ok PR#5788=Ok PR#6322=Ok +PR#6646=Ok +PR#6646=Ok +PR#6676=Ok diff --git a/testsuite/tests/callback/Makefile b/testsuite/tests/callback/Makefile index 58b5ed8aa9..d89c532635 100644 --- a/testsuite/tests/callback/Makefile +++ b/testsuite/tests/callback/Makefile @@ -31,9 +31,9 @@ common: run-byte: common @printf " ... testing 'bytecode':" @$(OCAMLC) $(COMPFLAGS) -c tcallback.ml - @$(OCAMLC) $(COMPFLAGS) -o ./program -custom unix.cma \ + @$(OCAMLC) $(COMPFLAGS) -o ./program$(EXE) -custom unix.cma \ callbackprim.$(O) tcallback.cmo - @./program >bytecode.result + @./program$(EXE) >bytecode.result @$(DIFF) reference bytecode.result \ && echo " => passed" || echo " => failed" @@ -42,9 +42,9 @@ run-opt: common @if $(BYTECODE_ONLY); then : ; else \ printf " ... testing 'native':"; \ $(OCAMLOPT) $(COMPFLAGS) -c tcallback.ml; \ - $(OCAMLOPT) $(COMPFLAGS) -o ./program unix.cmxa callbackprim.$(O) \ - tcallback.cmx; \ - ./program >native.result; \ + $(OCAMLOPT) $(COMPFLAGS) -o ./program$(EXE) unix.cmxa \ + callbackprim.$(O) tcallback.cmx; \ + ./program$(EXE) >native.result; \ $(DIFF) reference native.result \ && echo " => passed" || echo " => failed"; \ fi @@ -54,6 +54,6 @@ promote: defaultpromote .PHONY: clean clean: defaultclean - @rm -f *.result ./program + @rm -f *.result ./program$(EXE) include $(BASEDIR)/makefiles/Makefile.common diff --git a/testsuite/tests/callback/callbackprim.c b/testsuite/tests/callback/callbackprim.c index f3c5981102..71a123d18e 100644 --- a/testsuite/tests/callback/callbackprim.c +++ b/testsuite/tests/callback/callbackprim.c @@ -10,9 +10,9 @@ /* */ /***********************************************************************/ -#include "mlvalues.h" -#include "memory.h" -#include "callback.h" +#include "caml/mlvalues.h" +#include "caml/memory.h" +#include "caml/callback.h" value mycallback1(value fun, value arg) { diff --git a/testsuite/tests/embedded/Makefile b/testsuite/tests/embedded/Makefile index a8de4dc00e..088b021656 100644 --- a/testsuite/tests/embedded/Makefile +++ b/testsuite/tests/embedded/Makefile @@ -18,16 +18,12 @@ default: $(MAKE) run .PHONY: compile -compile: caml - @$(OCAMLC) -ccopt -I -ccopt . cmstub.c - @$(OCAMLC) -ccopt -I -ccopt . cmmain.c +compile: + @$(OCAMLC) -ccopt -I -ccopt $(CTOPDIR)/byterun cmstub.c + @$(OCAMLC) -ccopt -I -ccopt $(CTOPDIR)/byterun cmmain.c @$(OCAMLC) -c cmcaml.ml @$(OCAMLC) -custom -o program cmstub.$(O) cmcaml.cmo cmmain.$(O) -caml: - @mkdir -p caml || : - @cp -f $(TOPDIR)/byterun/*.h caml/ - .PHONY: run run: @printf " ... testing 'cmmain':" @@ -41,6 +37,5 @@ promote: defaultpromote .PHONY: clean clean: defaultclean @rm -f *.result program - @rm -rf caml include $(BASEDIR)/makefiles/Makefile.common diff --git a/testsuite/tests/float-unboxing/Makefile b/testsuite/tests/float-unboxing/Makefile new file mode 100644 index 0000000000..6852411858 --- /dev/null +++ b/testsuite/tests/float-unboxing/Makefile @@ -0,0 +1,7 @@ +BASEDIR=../.. +MODULES= +MAIN_MODULE=float_subst_boxed_number +ADD_OPTCOMPFLAGS=-inline 20 + +include $(BASEDIR)/makefiles/Makefile.one +include $(BASEDIR)/makefiles/Makefile.common diff --git a/testsuite/tests/float-unboxing/float_subst_boxed_number.ml b/testsuite/tests/float-unboxing/float_subst_boxed_number.ml new file mode 100644 index 0000000000..ce175ceb6b --- /dev/null +++ b/testsuite/tests/float-unboxing/float_subst_boxed_number.ml @@ -0,0 +1,52 @@ +module PR_6686 = struct + type t = + | A of float + | B of (int * int) + + let rec foo = function + | A x -> x + | B (x, y) -> float x +. float y + + let (_ : float) = foo (A 4.) +end + +module PR_6770 = struct + type t = + | Constant of float + | Exponent of (float * float) + + let to_string = function + | Exponent (_b, _e) -> + ignore _b; + ignore _e; + "" + | Constant _ -> "" + + let _ = to_string (Constant 4.) +end + + +module GPR_109 = struct + + let f () = + let r = ref 0. in + for i = 1 to 1000 do + r := !r +. float i + done; + !r + + let test () = + let a0 = Gc.allocated_bytes () in + let a1 = Gc.allocated_bytes () in + let _x = f () in + let a2 = Gc.allocated_bytes () in + let alloc = (a2 -. 2. *. a1 +. a0) in + assert(alloc < 100.) + + let () = + (* is there a better to test whether we run in native code? *) + match Filename.basename Sys.argv.(0) with + | "program.byte" | "program.byte.exe" -> () + | "program.native" | "program.native.exe" -> test () + | _ -> assert false +end diff --git a/testsuite/tests/float-unboxing/float_subst_boxed_number.reference b/testsuite/tests/float-unboxing/float_subst_boxed_number.reference new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/float-unboxing/float_subst_boxed_number.reference diff --git a/testsuite/tests/gc-roots/globrootsprim.c b/testsuite/tests/gc-roots/globrootsprim.c index f7bb32ceab..5c540acf55 100644 --- a/testsuite/tests/gc-roots/globrootsprim.c +++ b/testsuite/tests/gc-roots/globrootsprim.c @@ -13,10 +13,10 @@ /* For testing global root registration */ -#include "mlvalues.h" -#include "memory.h" -#include "alloc.h" -#include "gc.h" +#include "caml/mlvalues.h" +#include "caml/memory.h" +#include "caml/alloc.h" +#include "caml/gc.h" struct block { value header; value v; }; diff --git a/testsuite/tests/lib-bigarray-2/Makefile b/testsuite/tests/lib-bigarray-2/Makefile index 373ff94493..a438c9a321 100644 --- a/testsuite/tests/lib-bigarray-2/Makefile +++ b/testsuite/tests/lib-bigarray-2/Makefile @@ -14,6 +14,8 @@ BASEDIR=../.. LIBRARIES=unix bigarray C_FILES=bigarrfstub F_FILES=bigarrf +ADD_COMPFLAGS=-I $(OTOPDIR)/otherlibs/bigarray \ + -I $(OTOPDIR)/otherlibs/$(UNIXLIB) include $(BASEDIR)/makefiles/Makefile.several include $(BASEDIR)/makefiles/Makefile.common diff --git a/testsuite/tests/lib-bigarray-2/bigarrfml.ml b/testsuite/tests/lib-bigarray-2/bigarrfml.ml index 906826fae6..d73f1555f0 100644 --- a/testsuite/tests/lib-bigarray-2/bigarrfml.ml +++ b/testsuite/tests/lib-bigarray-2/bigarrfml.ml @@ -39,7 +39,7 @@ let test test_number answer correct_answer = (* External C and Fortran functions *) external c_filltab : - unit -> (float, float64_elt, c_layout) Array2.t = "c_filltaab" + 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 : diff --git a/testsuite/tests/lib-bigarray-2/bigarrfstub.c b/testsuite/tests/lib-bigarray-2/bigarrfstub.c index 354082848a..7287298746 100644 --- a/testsuite/tests/lib-bigarray-2/bigarrfstub.c +++ b/testsuite/tests/lib-bigarray-2/bigarrfstub.c @@ -11,7 +11,7 @@ /***********************************************************************/ #include <stdio.h> -#include <mlvalues.h> +#include <caml/mlvalues.h> #include <bigarray.h> extern void filltab_(void); diff --git a/testsuite/tests/lib-bigarray/bigarrays.ml b/testsuite/tests/lib-bigarray/bigarrays.ml index 5ac8e7f742..d5b2ec72e8 100644 --- a/testsuite/tests/lib-bigarray/bigarrays.ml +++ b/testsuite/tests/lib-bigarray/bigarrays.ml @@ -163,6 +163,86 @@ let _ = set 1 vals; a in + (* Test indexing arrays. This test has to be copy-pasted, otherwise indexing may not + use the optimizations in Cmmgen.bigarray_indexing. *) + begin + let v = 123 in + let cb = Array1.create int8_signed c_layout 1000 in + let fb = Array1.create int8_signed fortran_layout 1000 in + Array1.fill cb v; + Array1.fill fb v; + let return = ref true in + for i = 1 to 99 do + let i = i * 10 in + return := !return + && Array1.unsafe_get cb (i - 10) = v + && Array1.unsafe_get cb (i ) = v + && Array1.unsafe_get cb (i + 9) = v + && Array1.unsafe_get fb (i - 9) = v + && Array1.unsafe_get fb (i ) = v + && Array1.unsafe_get fb (i + 10) = v + done; + test 13 true !return + end; + begin + let v = 123 in + let cb = Array1.create int16_unsigned c_layout 1000 in + let fb = Array1.create int16_unsigned fortran_layout 1000 in + Array1.fill cb v; + Array1.fill fb v; + let return = ref true in + for i = 1 to 99 do + let i = i * 10 in + return := !return + && Array1.unsafe_get cb (i - 10) = v + && Array1.unsafe_get cb (i ) = v + && Array1.unsafe_get cb (i + 9) = v + && Array1.unsafe_get fb (i - 9) = v + && Array1.unsafe_get fb (i ) = v + && Array1.unsafe_get fb (i + 10) = v + done; + test 14 true !return + end; + begin + let v = 123. in + let cb = Array1.create float32 c_layout 1000 in + let fb = Array1.create float32 fortran_layout 1000 in + Array1.fill cb v; + Array1.fill fb v; + let return = ref true in + for i = 1 to 99 do + let i = i * 10 in + return := !return + && Array1.unsafe_get cb (i - 10) = v + && Array1.unsafe_get cb (i ) = v + && Array1.unsafe_get cb (i + 9) = v + && Array1.unsafe_get fb (i - 9) = v + && Array1.unsafe_get fb (i ) = v + && Array1.unsafe_get fb (i + 10) = v + done; + test 15 true !return + end; + + begin + let v = 123. in + let cb = Array1.create float64 c_layout 1000 in + let fb = Array1.create float64 fortran_layout 1000 in + Array1.fill cb v; + Array1.fill fb v; + let return = ref true in + for i = 1 to 99 do + let i = i * 10 in + return := !return + && Array1.unsafe_get cb (i - 10) = v + && Array1.unsafe_get cb (i ) = v + && Array1.unsafe_get cb (i + 9) = v + && Array1.unsafe_get fb (i - 9) = v + && Array1.unsafe_get fb (i ) = v + && Array1.unsafe_get fb (i + 10) = v + done; + test 16 true !return + end; + testing_function "set/get (specialized)"; let a = Array1.create int c_layout 3 in for i = 0 to 2 do a.{i} <- i done; diff --git a/testsuite/tests/lib-bigarray/bigarrays.reference b/testsuite/tests/lib-bigarray/bigarrays.reference index bdc7beae23..af05f4ca54 100644 --- a/testsuite/tests/lib-bigarray/bigarrays.reference +++ b/testsuite/tests/lib-bigarray/bigarrays.reference @@ -2,7 +2,7 @@ ------ Array1 -------- create/set/get - 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... + 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... 13... 14... 15... 16... set/get (specialized) 1... 2... 3... 4... 5... 6... 7... 8... 8... 9... 10... 11... 12... 13... 14... 15... 16... 17... 18... 19... set/get (unsafe, specialized) diff --git a/testsuite/tests/lib-dynlink-bytecode/Makefile b/testsuite/tests/lib-dynlink-bytecode/Makefile index 832e367ee6..f9b1c6f9c3 100644 --- a/testsuite/tests/lib-dynlink-bytecode/Makefile +++ b/testsuite/tests/lib-dynlink-bytecode/Makefile @@ -24,10 +24,10 @@ default: fi .PHONY: compile -compile: caml +compile: @$(OCAMLC) -c registry.ml @for file in stub*.c; do \ - $(OCAMLC) -ccopt -I -ccopt . -c $$file; \ + $(OCAMLC) -ccopt -I -ccopt $(CTOPDIR)/byterun/caml -c $$file; \ $(OCAMLMKLIB) -o `echo $$file | sed -e 's/stub/plug/' -e 's/\.c//'` \ `basename $$file c`$(O); \ done @@ -43,10 +43,6 @@ compile: caml @$(OCAMLC) -o custom$(EXE) -custom -linkall registry.cmo plug2.cma \ plug1.cma -I . -caml: - @mkdir -p caml || : - @cp -f $(TOPDIR)/byterun/*.h caml/ - .PHONY: run run: @printf " ... testing 'main'" @@ -70,6 +66,5 @@ promote: defaultpromote .PHONY: clean clean: defaultclean @rm -f main static custom custom.exe *.result marshal.data - @rm -rf caml include $(BASEDIR)/makefiles/Makefile.common diff --git a/testsuite/tests/lib-dynlink-csharp/plugin.ml b/testsuite/tests/lib-dynlink-csharp/plugin.ml index 241e8bb5aa..71f2790cdf 100755 --- a/testsuite/tests/lib-dynlink-csharp/plugin.ml +++ b/testsuite/tests/lib-dynlink-csharp/plugin.ml @@ -9,7 +9,7 @@ (* under the terms of the Q Public License version 1.0. *) (* *) (***********************************************************************) - +open Bigarray let f x = x.{2} let () = diff --git a/testsuite/tests/lib-dynlink-native/Makefile b/testsuite/tests/lib-dynlink-native/Makefile index f4f9d09942..1054e4afd4 100644 --- a/testsuite/tests/lib-dynlink-native/Makefile +++ b/testsuite/tests/lib-dynlink-native/Makefile @@ -102,14 +102,11 @@ mypack.cmx: packed1.cmx mylib.cmxa: plugin.cmx plugin2.cmx @$(OCAMLOPT) $(COMPFLAGS) -a -o mylib.cmxa plugin.cmx plugin2.cmx -factorial.$(O): factorial.c caml - @$(OCAMLOPT) -c -ccopt "$(SHAREDCCCOMPOPTS)" -ccopt -I -ccopt . \ +factorial.$(O): factorial.c + @$(OCAMLOPT) -c -ccopt "$(SHAREDCCCOMPOPTS)" -ccopt -I \ + -ccopt $(CTOPDIR)/byterun/caml \ factorial.c -caml: - @mkdir -p caml || : - @cp $(TOPDIR)/byterun/*.h caml/ - .PHONY: promote promote: @cp result reference @@ -120,6 +117,5 @@ clean: defaultclean @rm -f *.a *.lib @rm -f sub/*.so sub/*.o sub/*.cm* sub/*.s sub/*.asm sub/*.obj @rm -f marshal.data - @rm -rf caml include $(BASEDIR)/makefiles/Makefile.common diff --git a/testsuite/tests/lib-format/pr6824.ml b/testsuite/tests/lib-format/pr6824.ml new file mode 100644 index 0000000000..aa5e7eed6d --- /dev/null +++ b/testsuite/tests/lib-format/pr6824.ml @@ -0,0 +1,7 @@ +let f = Format.sprintf "[%i]";; +print_endline (f 1);; +print_endline (f 2);; + +let f = Format.asprintf "[%i]";; +print_endline (f 1);; +print_endline (f 2);; diff --git a/testsuite/tests/lib-format/pr6824.reference b/testsuite/tests/lib-format/pr6824.reference new file mode 100644 index 0000000000..69035c7649 --- /dev/null +++ b/testsuite/tests/lib-format/pr6824.reference @@ -0,0 +1,6 @@ +[1] +[2] +[1] +[2] + +All tests succeeded. diff --git a/testsuite/tests/lib-hashtbl/htbl.ml b/testsuite/tests/lib-hashtbl/htbl.ml index 655191a8e3..bd5f33a656 100644 --- a/testsuite/tests/lib-hashtbl/htbl.ml +++ b/testsuite/tests/lib-hashtbl/htbl.ml @@ -193,7 +193,7 @@ let _ = printf "-- Random integers, narrow range\n%!"; TI2.test (random_integers 100_000 1_000); let d = - try file_data "/usr/share/dict/words" with Sys_error _ -> string_data in + try file_data "../../LICENSE" with Sys_error _ -> string_data in printf "-- Strings, generic interface\n%!"; TS1.test d; printf "-- Strings, functorial interface\n%!"; diff --git a/testsuite/tests/lib-marshal/intextaux.c b/testsuite/tests/lib-marshal/intextaux.c index 924b896e50..03688462d6 100644 --- a/testsuite/tests/lib-marshal/intextaux.c +++ b/testsuite/tests/lib-marshal/intextaux.c @@ -10,8 +10,8 @@ /* */ /***********************************************************************/ -#include <mlvalues.h> -#include <intext.h> +#include <caml/mlvalues.h> +#include <caml/intext.h> value marshal_to_block(value vbuf, value vlen, value v, value vflags) { diff --git a/testsuite/tests/lib-num/end_test.reference b/testsuite/tests/lib-num/end_test.reference index 2d234bfb07..ab99ae015d 100644 --- a/testsuite/tests/lib-num/end_test.reference +++ b/testsuite/tests/lib-num/end_test.reference @@ -85,6 +85,8 @@ extract_big_int 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... hashing of big integers 1... 2... 3... 4... 5... 6... +float_of_big_int + 1... 2... 3... 4... 5... 6... 7... 8... create_ratio 1... 2... 3... 4... 5... 6... 7... 8... create_normalized_ratio @@ -143,6 +145,8 @@ approx_ratio_fix 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... 13... 14... approx_ratio_exp 1... 2... 3... 4... 5... 6... 7... 8... 9... +float_of_ratio + 1... add_num 1... 2... 3... 4... 5... 6... 7... 8... 9... sub_num diff --git a/testsuite/tests/lib-num/test.ml b/testsuite/tests/lib-num/test.ml index f3cec77dd9..b04815388b 100644 --- a/testsuite/tests/lib-num/test.ml +++ b/testsuite/tests/lib-num/test.ml @@ -90,6 +90,7 @@ let eq_string (i: string) (j: string) = (i = j);; let eq_nativeint (i: nativeint) (j: nativeint) = (i = j);; let eq_int32 (i: int32) (j: int32) = (i = j);; let eq_int64 (i: int64) (j: int64) = (i = j);; +let eq_float (x: float) (y: float) = Pervasives.compare x y = 0;; let sixtyfour = (1 lsl 31) <> 0;; diff --git a/testsuite/tests/lib-num/test_big_ints.ml b/testsuite/tests/lib-num/test_big_ints.ml index f036f127f8..9e89d25092 100644 --- a/testsuite/tests/lib-num/test_big_ints.ml +++ b/testsuite/tests/lib-num/test_big_ints.ml @@ -977,3 +977,47 @@ test 6 eq_int (Hashtbl.hash (sub_big_int (big_int_of_string "123456789123456789") (big_int_of_string "123456789123456788")), 992063522);; + +testing_function "float_of_big_int";; + +test 1 eq_float (float_of_big_int zero_big_int, 0.0);; +test 2 eq_float (float_of_big_int unit_big_int, 1.0);; +test 3 eq_float (float_of_big_int (minus_big_int unit_big_int), -1.0);; +test 4 eq_float (float_of_big_int (shift_left_big_int unit_big_int 1024), + infinity);; +test 5 eq_float (float_of_big_int (shift_left_big_int unit_big_int 1023), + ldexp 1.0 1023);; +(* Some random int64 values *) +let ok = ref true in +for i = 1 to 100 do + let n = Random.int64 Int64.max_int in + if not (eq_float (float_of_big_int (big_int_of_int64 n)) (Int64.to_float n)) + then ok := false; + let n = Int64.neg n in + if not (eq_float (float_of_big_int (big_int_of_int64 n)) (Int64.to_float n)) + then ok := false +done; +test 6 eq (!ok, true);; +(* Some random int64 values scaled by some random power of 2 *) +let ok = ref true in +for i = 1 to 1000 do + let n = Random.int64 Int64.max_int in + let exp = Random.int 1200 in + if not (eq_float + (float_of_big_int + (shift_left_big_int (big_int_of_int64 n) exp)) + (ldexp (Int64.to_float n) exp)) + then ok := false +done; +test 7 eq (!ok, true);; +(* Round to nearest even *) +let ok = ref true in +for i = 0 to 15 do + let n = Int64.(add 0xfffffffffffff0L (of_int i)) in + if not (eq_float + (float_of_big_int + (shift_left_big_int (big_int_of_int64 n) 32)) + (ldexp (Int64.to_float n) 32)) + then ok := false +done; +test 8 eq (!ok, true);; diff --git a/testsuite/tests/lib-num/test_ratios.ml b/testsuite/tests/lib-num/test_ratios.ml index 568e3bce10..69f0626600 100644 --- a/testsuite/tests/lib-num/test_ratios.ml +++ b/testsuite/tests/lib-num/test_ratios.ml @@ -1186,3 +1186,23 @@ failwith_test 9 (approx_ratio_exp 5) (create_ratio (big_int_of_int 0) (big_int_of_int 0)) (Failure "approx_ratio_exp infinite or undefined rational number") ;; + +testing_function "float_of_ratio";; +let ok = ref true in +for i = 1 to 100 do + let p = Random.int64 0x20000000000000L + and pexp = Random.int 100 + and q = Random.int64 0x20000000000000L + and qexp = Random.int 100 in + if not (eq_float + (float_of_ratio + (create_ratio + (shift_left_big_int (big_int_of_int64 p) pexp) + (shift_left_big_int (big_int_of_int64 q) qexp))) + (ldexp (Int64.to_float p) pexp /. + ldexp (Int64.to_float q) qexp)) + then ok := false +done; +test 1 eq (!ok, true) +;; + diff --git a/testsuite/tests/lib-printf/pr6938.ml b/testsuite/tests/lib-printf/pr6938.ml new file mode 100644 index 0000000000..8e72d9b007 --- /dev/null +++ b/testsuite/tests/lib-printf/pr6938.ml @@ -0,0 +1,42 @@ +(* these are not valid under -strict-formats, but we test them here + for backward-compatibility *) + +Printf.printf "%047.27d\n" 1736201459;; +Printf.printf "%047.27ld\n" 1736201459l;; +Printf.printf "%047.27Ld\n" 1736201459L;; +Printf.printf "%047.27nd\n" 1736201459n;; + +print_newline ();; + +Printf.printf "%047.27i\n" 1736201459;; +Printf.printf "%047.27li\n" 1736201459l;; +Printf.printf "%047.27Li\n" 1736201459L;; +Printf.printf "%047.27ni\n" 1736201459n;; + +print_newline ();; + +Printf.printf "%047.27u\n" 1736201459;; +Printf.printf "%047.27lu\n" 1736201459l;; +Printf.printf "%047.27Lu\n" 1736201459L;; +Printf.printf "%047.27nu\n" 1736201459n;; + +print_newline ();; + +Printf.printf "%047.27x\n" 1736201459;; +Printf.printf "%047.27lx\n" 1736201459l;; +Printf.printf "%047.27Lx\n" 1736201459L;; +Printf.printf "%047.27nx\n" 1736201459n;; + +print_newline ();; + +Printf.printf "%047.27X\n" 1736201459;; +Printf.printf "%047.27lX\n" 1736201459l;; +Printf.printf "%047.27LX\n" 1736201459L;; +Printf.printf "%047.27nX\n" 1736201459n;; + +print_newline ();; + +Printf.printf "%047.27o\n" 1736201459;; +Printf.printf "%047.27lo\n" 1736201459l;; +Printf.printf "%047.27Lo\n" 1736201459L;; +Printf.printf "%047.27no\n" 1736201459n;; diff --git a/testsuite/tests/lib-printf/pr6938.reference b/testsuite/tests/lib-printf/pr6938.reference new file mode 100644 index 0000000000..ebd5057633 --- /dev/null +++ b/testsuite/tests/lib-printf/pr6938.reference @@ -0,0 +1,31 @@ + 000000000000000001736201459 + 000000000000000001736201459 + 000000000000000001736201459 + 000000000000000001736201459 + + 000000000000000001736201459 + 000000000000000001736201459 + 000000000000000001736201459 + 000000000000000001736201459 + + 000000000000000001736201459 + 000000000000000001736201459 + 000000000000000001736201459 + 000000000000000001736201459 + + 0000000000000000000677c54f3 + 0000000000000000000677c54f3 + 0000000000000000000677c54f3 + 0000000000000000000677c54f3 + + 0000000000000000000677C54F3 + 0000000000000000000677C54F3 + 0000000000000000000677C54F3 + 0000000000000000000677C54F3 + + 000000000000000014737052363 + 000000000000000014737052363 + 000000000000000014737052363 + 000000000000000014737052363 + +All tests succeeded. diff --git a/testsuite/tests/lib-scanf/tscanf.ml b/testsuite/tests/lib-scanf/tscanf.ml index 33054b66e7..a93637ec04 100644 --- a/testsuite/tests/lib-scanf/tscanf.ml +++ b/testsuite/tests/lib-scanf/tscanf.ml @@ -1268,7 +1268,12 @@ sscanf "Hello \n" "%s%s%_1[ ]\n" (fun s1 s2 -> sscanf "Hello\nWorld!" "%s\n%s%!" (fun s1 s2 -> s1 = "Hello" && s2 = "World!") && sscanf "Hello\nWorld!" "%s\n%s@!%!" (fun s1 s2 -> - s1 = "Hello" && s2 = "World") + s1 = "Hello" && s2 = "World") && + (* PR#6791 *) + sscanf "Hello{foo}" "%s@{%s" (fun s1 s2 -> + s1 = "Hello" && s2 = "foo}") && + sscanf "Hello[foo]" "%s@[%s" (fun s1 s2 -> + s1 = "Hello" && s2 = "foo]") ;; test (test52 ()) @@ -1351,7 +1356,7 @@ test (test54 ()) (* Creating digests for files. *) let add_digest_ib ob ib = - let digest s = String.uppercase (Digest.to_hex (Digest.string s)) in + let digest s = String.uppercase_ascii (Digest.to_hex (Digest.string s)) in let scan_line ib f = Scanf.bscanf ib "%[^\n\r]\n" f in let output_line_digest s = Buffer.add_string ob s; diff --git a/testsuite/tests/lib-set/testset.ml b/testsuite/tests/lib-set/testset.ml index 3e55942a41..5881332061 100644 --- a/testsuite/tests/lib-set/testset.ml +++ b/testsuite/tests/lib-set/testset.ml @@ -130,3 +130,41 @@ let rset() = let _ = Random.init 42; for i = 1 to 25000 do test (relt()) (rset()) (rset()) done + +let () = + (* #6645: check that adding an element to set that already contains + it doesn't allocate and return the original set. *) + let s1 = ref S.empty in + for i = 1 to 10 do s1 := S.add i !s1 done; + let s2 = ref !s1 in + + let a0 = Gc.allocated_bytes () in + let a1 = Gc.allocated_bytes () in + for i = 1 to 10 do s2 := S.add i !s2 done; + let a2 = Gc.allocated_bytes () in + + assert (!s2 == !s1); + assert(a2 -. a1 = a1 -. a0) + +let () = + (* check that removing an element from a set that is not present in this set + (1) doesn't allocate and (2) return the original set *) + let s1 = ref S.empty in + for i = 1 to 10 do s1 := S.add i !s1 done; + let s2 = ref !s1 in + + let a0 = Gc.allocated_bytes () in + let a1 = Gc.allocated_bytes () in + for i = 11 to 30 do s2 := S.remove i !s2 done; + let a2 = Gc.allocated_bytes () in + + assert (!s2 == !s1); + assert(a2 -. a1 = a1 -. a0) + +let () = + (* check that filtering a set where all elements are satisfied by + the given predicate return the original set *) + let s1 = ref S.empty in + for i = 1 to 10 do s1 := S.add i !s1 done; + let s2 = S.filter (fun e -> e >= 0) !s1 in + assert (s2 == !s1) diff --git a/testsuite/external/Patcher.sh b/testsuite/tests/lib-string/Makefile index 57597d0811..6ae7266b0c 100755..100644 --- a/testsuite/external/Patcher.sh +++ b/testsuite/tests/lib-string/Makefile @@ -1,31 +1,19 @@ -#!/bin/sh - ######################################################################### # # # OCaml # # # -# Damien Doligez, projet Gallium, INRIA Rocquencourt # +# Xavier Clerc, SED, INRIA Rocquencourt # # # -# Copyright 2012 Institut National de Recherche en Informatique et # +# 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. # # # ######################################################################### -# usage: -# Patcher.sh <directory> [<patchfile>] - -if [ -f "$1.patch" ]; then - echo "patch -d $1 -p1 < $1.patch" - patch -d $1 -p1 < "$1.patch" -fi - -if [ -f "$1-$VERSION.patch" ]; then - echo "patch -d $1 -p1 < $1-$VERSION.patch" - patch -d $1 -p1 < "$1-$VERSION.patch" -fi +BASEDIR=../.. +LIBRARIES=str +ADD_COMPFLAGS=-I $(OTOPDIR)/otherlibs/str +LD_PATH=$(TOPDIR)/otherlibs/str -if [ -f "$2" ]; then - echo "patch -d $1 -l -p0 < $2" - patch -d $1 -l -p0 < "$2" || exit 0 -fi +include $(BASEDIR)/makefiles/Makefile.several +include $(BASEDIR)/makefiles/Makefile.common diff --git a/testsuite/tests/lib-string/test_string.ml b/testsuite/tests/lib-string/test_string.ml new file mode 100644 index 0000000000..5043915085 --- /dev/null +++ b/testsuite/tests/lib-string/test_string.ml @@ -0,0 +1,35 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Damien Doligez, Jane Street Group, LLC *) +(* *) +(* Copyright 2015 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. *) +(* *) +(***********************************************************************) + +let rec build_string f n accu = + if n <= 0 + then String.concat "" accu + else build_string f (n-1) (f (n-1) :: accu) +;; + +let char n = String.make 1 (Char.chr n);; + +let reference n = + if n = 8 then "\\b" + else if n = 9 then "\\t" + else if n = 10 then "\\n" + else if n = 13 then "\\r" + else if n = Char.code '"' then "\\\"" + else if n = Char.code '\\' then "\\\\" + else if n < 32 || n > 126 then Printf.sprintf "\\%03d" n + else char n +;; + +let raw_string = build_string char 256 [];; +let ref_string = build_string reference 256 [];; + +if String.escaped raw_string <> ref_string then failwith "test:String.escaped";; diff --git a/testsuite/tests/lib-string/test_string.reference b/testsuite/tests/lib-string/test_string.reference new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/lib-string/test_string.reference diff --git a/testsuite/tests/misc/weaklifetime.ml b/testsuite/tests/misc/weaklifetime.ml new file mode 100644 index 0000000000..d6b23f3d22 --- /dev/null +++ b/testsuite/tests/misc/weaklifetime.ml @@ -0,0 +1,74 @@ +(*************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Damien Doligez, Jane Street Group, LLC *) +(* *) +(* Copyright 2015 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. *) +(* *) +(*************************************************************************) + +Random.init 12345;; + +let size = 1000;; + +type block = int array;; + +type objdata = + | Present of block + | Absent of int (* GC count at time of erase *) +;; + +type bunch = { + objs : objdata array; + wp : block Weak.t; +};; + +let data = + Array.init size (fun i -> + let n = 1 + Random.int size in + { + objs = Array.make n (Absent 0); + wp = Weak.create n; + } + ) +;; + +let gccount () = (Gc.quick_stat ()).Gc.major_collections;; + +(* Check the correctness condition on the data at (i,j): + 1. if the block is present, the weak pointer must be full + 2. if the block was removed at GC n, and the weak pointer is still + full, then the current GC must be at most n+1. + + Then modify the data in one of the following ways: + 1. if the block and weak pointer are absent, fill them + 2. if the block and weak pointer are present, randomly erase the block +*) +let check_and_change i j = + let gc1 = gccount () in + match data.(i).objs.(j), Weak.check data.(i).wp j with + | Present x, false -> assert false + | Absent n, true -> assert (gc1 <= n+1) + | Absent _, false -> + let x = Array.make (1 + Random.int 10) 42 in + data.(i).objs.(j) <- Present x; + Weak.set data.(i).wp j (Some x); + | Present _, true -> + if Random.int 10 = 0 then begin + data.(i).objs.(j) <- Absent gc1; + let gc2 = gccount () in + if gc1 <> gc2 then data.(i).objs.(j) <- Absent gc2; + end +;; + +let dummy = ref [||];; + +while gccount () < 20 do + dummy := Array.make (Random.int 300) 0; + let i = Random.int size in + let j = Random.int (Array.length data.(i).objs) in + check_and_change i j; +done diff --git a/testsuite/tests/misc/weaklifetime.reference b/testsuite/tests/misc/weaklifetime.reference new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/misc/weaklifetime.reference diff --git a/testsuite/tests/parsing/Makefile b/testsuite/tests/parsing/Makefile new file mode 100644 index 0000000000..c8de7609d1 --- /dev/null +++ b/testsuite/tests/parsing/Makefile @@ -0,0 +1,16 @@ +######################################################################### +# # +# OCaml # +# # +# Jeremie Dimino, Jane Street Europe # +# # +# 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=../.. +TOPFLAGS+=-dparsetree +include $(BASEDIR)/makefiles/Makefile.dparsetree +include $(BASEDIR)/makefiles/Makefile.common diff --git a/testsuite/tests/parsing/pr6865.ml b/testsuite/tests/parsing/pr6865.ml new file mode 100644 index 0000000000..78cd602feb --- /dev/null +++ b/testsuite/tests/parsing/pr6865.ml @@ -0,0 +1,3 @@ +let%foo x = 42 +let%foo _ = () and _ = () +let%foo _ = () diff --git a/testsuite/tests/parsing/pr6865.ml.reference b/testsuite/tests/parsing/pr6865.ml.reference new file mode 100644 index 0000000000..0dc38fb240 --- /dev/null +++ b/testsuite/tests/parsing/pr6865.ml.reference @@ -0,0 +1,47 @@ +[ + structure_item (pr6865.ml[1,0+0]..[1,0+14]) ghost + Pstr_extension "foo" + [ + structure_item (pr6865.ml[1,0+0]..[1,0+14]) + Pstr_value Nonrec + [ + <def> + pattern (pr6865.ml[1,0+8]..[1,0+9]) + Ppat_var "x" (pr6865.ml[1,0+8]..[1,0+9]) + expression (pr6865.ml[1,0+12]..[1,0+14]) + Pexp_constant Const_int 42 + ] + ] + structure_item (pr6865.ml[2,15+0]..[2,15+25]) ghost + Pstr_extension "foo" + [ + structure_item (pr6865.ml[2,15+0]..[2,15+25]) + Pstr_value Nonrec + [ + <def> + pattern (pr6865.ml[2,15+8]..[2,15+9]) + Ppat_any + expression (pr6865.ml[2,15+12]..[2,15+14]) + Pexp_construct "()" (pr6865.ml[2,15+12]..[2,15+14]) + None + <def> + pattern (pr6865.ml[2,15+19]..[2,15+20]) + Ppat_any + expression (pr6865.ml[2,15+23]..[2,15+25]) + Pexp_construct "()" (pr6865.ml[2,15+23]..[2,15+25]) + None + ] + ] + structure_item (pr6865.ml[3,41+0]..[3,41+14]) ghost + Pstr_extension "foo" + [ + structure_item (pr6865.ml[3,41+0]..[3,41+14]) + Pstr_eval + expression (pr6865.ml[3,41+12]..[3,41+14]) + Pexp_construct "()" (pr6865.ml[3,41+12]..[3,41+14]) + None + ] +] + +File "pr6865.ml", line 1, characters 4-7: +Uninterpreted extension 'foo'. diff --git a/testsuite/tests/ppx-attributes/Makefile b/testsuite/tests/ppx-attributes/Makefile new file mode 100644 index 0000000000..e94bb069b1 --- /dev/null +++ b/testsuite/tests/ppx-attributes/Makefile @@ -0,0 +1,15 @@ +######################################################################### +# # +# OCaml # +# # +# Peter Zotov # +# # +# 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. # +# # +######################################################################### + +BASEDIR=../.. +include $(BASEDIR)/makefiles/Makefile.several +include $(BASEDIR)/makefiles/Makefile.common diff --git a/testsuite/tests/ppx-attributes/warning.ml b/testsuite/tests/ppx-attributes/warning.ml new file mode 100644 index 0000000000..f50c3d6048 --- /dev/null +++ b/testsuite/tests/ppx-attributes/warning.ml @@ -0,0 +1,47 @@ +[@@@ocaml.warning "@A"] + +(* Fixture *) + +module type DEPRECATED = sig end +[@@ocaml.deprecated] + +module T = struct + type deprecated + [@@ocaml.deprecated] +end + +(* Structure items *) + +let _ = let x = 1 in () +[@@ocaml.warning "-26"] + +include (struct let _ = let x = 1 in () end) +[@@ocaml.warning "-26"] + +module A = struct let _ = let x = 1 in () end +[@@ocaml.warning "-26"] + +module rec B : sig type t end = struct type t = T.deprecated end +[@@ocaml.warning "-3"] + +module type T = sig type t = T.deprecated end +[@@ocaml.warning "-3"] + +(* Signature items *) + +module type S = sig + val x : T.deprecated + [@@ocaml.warning "-3"] + + module AA : sig type t = T.deprecated end + [@@ocaml.warning "-3"] + + module rec BB : sig type t = T.deprecated end + [@@ocaml.warning "-3"] + + module type T = sig type t = T.deprecated end + [@@ocaml.warning "-3"] + + include DEPRECATED + [@@ocaml.warning "-3"] +end diff --git a/testsuite/tests/ppx-attributes/warning.reference b/testsuite/tests/ppx-attributes/warning.reference new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/ppx-attributes/warning.reference diff --git a/testsuite/tests/prim-bigstring/bigstring_access.ml b/testsuite/tests/prim-bigstring/bigstring_access.ml index 8fad87b151..512181f088 100644 --- a/testsuite/tests/prim-bigstring/bigstring_access.ml +++ b/testsuite/tests/prim-bigstring/bigstring_access.ml @@ -63,40 +63,57 @@ let () = assert_bound_check3 caml_bigstring_set_32 empty_s 0 0l; assert_bound_check3 caml_bigstring_set_64 empty_s 0 0L +external bswap16: int -> int = "%bswap16" +external bswap32: int32 -> int32 = "%bswap_int32" +external bswap64: int64 -> int64 = "%bswap_int64" +let swap16 x = + if Sys.big_endian + then bswap16 x + else x + +let swap32 x = + if Sys.big_endian + then bswap32 x + else x + +let swap64 x = + if Sys.big_endian + then bswap64 x + else x let () = - caml_bigstring_set_16 s 0 0x1234; + caml_bigstring_set_16 s 0 (swap16 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; + (swap16 (caml_bigstring_get_16 s 0)) + (swap16 (caml_bigstring_get_16 s 1)) + (swap16 (caml_bigstring_get_16 s 2)); + caml_bigstring_set_16 s 0 (swap16 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) + (swap16 (caml_bigstring_get_16 s 0)) + (swap16 (caml_bigstring_get_16 s 1)) + (swap16 (caml_bigstring_get_16 s 2)) let () = - caml_bigstring_set_32 s 0 0x12345678l; + caml_bigstring_set_32 s 0 (swap32 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; + (swap32 (caml_bigstring_get_32 s 0)) + (swap32 (caml_bigstring_get_32 s 1)) + (swap32 (caml_bigstring_get_32 s 2)); + caml_bigstring_set_32 s 0 (swap32 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) + (swap32 (caml_bigstring_get_32 s 0)) + (swap32 (caml_bigstring_get_32 s 1)) + (swap32 (caml_bigstring_get_32 s 2)) let () = - caml_bigstring_set_64 s 0 0x1234567890ABCDEFL; + caml_bigstring_set_64 s 0 (swap64 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; + (swap64 (caml_bigstring_get_64 s 0)) + (swap64 (caml_bigstring_get_64 s 1)) + (swap64 (caml_bigstring_get_64 s 2)); + caml_bigstring_set_64 s 0 (swap64 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) + (swap64 (caml_bigstring_get_64 s 0)) + (swap64 (caml_bigstring_get_64 s 1)) + (swap64 (caml_bigstring_get_64 s 2)) diff --git a/testsuite/tests/prim-bigstring/string_access.ml b/testsuite/tests/prim-bigstring/string_access.ml index 3afcc6c552..48964c0b33 100644 --- a/testsuite/tests/prim-bigstring/string_access.ml +++ b/testsuite/tests/prim-bigstring/string_access.ml @@ -50,40 +50,57 @@ let () = assert_bound_check3 caml_string_set_32 empty_s 0 0l; assert_bound_check3 caml_string_set_64 empty_s 0 0L +external bswap16: int -> int = "%bswap16" +external bswap32: int32 -> int32 = "%bswap_int32" +external bswap64: int64 -> int64 = "%bswap_int64" +let swap16 x = + if Sys.big_endian + then bswap16 x + else x + +let swap32 x = + if Sys.big_endian + then bswap32 x + else x + +let swap64 x = + if Sys.big_endian + then bswap64 x + else x let () = - caml_string_set_16 s 0 0x1234; + caml_string_set_16 s 0 (swap16 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; + (swap16 (caml_string_get_16 s 0)) + (swap16 (caml_string_get_16 s 1)) + (swap16 (caml_string_get_16 s 2)); + caml_string_set_16 s 0 (swap16 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) + (swap16 (caml_string_get_16 s 0)) + (swap16 (caml_string_get_16 s 1)) + (swap16 (caml_string_get_16 s 2)) let () = - caml_string_set_32 s 0 0x12345678l; + caml_string_set_32 s 0 (swap32 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; + (swap32 (caml_string_get_32 s 0)) + (swap32 (caml_string_get_32 s 1)) + (swap32 (caml_string_get_32 s 2)); + caml_string_set_32 s 0 (swap32 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) + (swap32 (caml_string_get_32 s 0)) + (swap32 (caml_string_get_32 s 1)) + (swap32 (caml_string_get_32 s 2)) let () = - caml_string_set_64 s 0 0x1234567890ABCDEFL; + caml_string_set_64 s 0 (swap64 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; + (swap64 (caml_string_get_64 s 0)) + (swap64 (caml_string_get_64 s 1)) + (swap64 (caml_string_get_64 s 2)); + caml_string_set_64 s 0 (swap64 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) + (swap64 (caml_string_get_64 s 0)) + (swap64 (caml_string_get_64 s 1)) + (swap64 (caml_string_get_64 s 2)) diff --git a/testsuite/tests/translprim/Makefile b/testsuite/tests/translprim/Makefile new file mode 100644 index 0000000000..c4223d4522 --- /dev/null +++ b/testsuite/tests/translprim/Makefile @@ -0,0 +1,4 @@ +BASEDIR=../.. +TOPFLAGS+=-dlambda +include $(BASEDIR)/makefiles/Makefile.dlambda +include $(BASEDIR)/makefiles/Makefile.common diff --git a/testsuite/tests/translprim/array_spec.ml b/testsuite/tests/translprim/array_spec.ml new file mode 100644 index 0000000000..e78c96343c --- /dev/null +++ b/testsuite/tests/translprim/array_spec.ml @@ -0,0 +1,62 @@ +external len : 'a array -> int = "%array_length" +external safe_get : 'a array -> int -> 'a = "%array_safe_get" +external unsafe_get : 'a array -> int -> 'a = "%array_unsafe_get" +external safe_set : 'a array -> int -> 'a -> unit = "%array_safe_set" +external unsafe_set : 'a array -> int -> 'a -> unit = "%array_unsafe_set" + +(* Specialization in application *) + +let int_a = [|1;2;3|];; +let float_a = [|1.;2.;3.|];; +let addr_a = [|"a";"b";"c"|];; + +len int_a;; +len float_a;; +len addr_a;; +(fun a -> len a);; + +safe_get int_a 0;; +safe_get float_a 0;; +safe_get addr_a 0;; +(fun a -> safe_get a 0);; + +unsafe_get int_a 0;; +unsafe_get float_a 0;; +unsafe_get addr_a 0;; +(fun a -> unsafe_get a 0);; + +safe_set int_a 0 1;; +safe_set float_a 0 1.;; +safe_set addr_a 0 "a";; +(fun a x -> safe_set a 0 x);; + +unsafe_set int_a 0 1;; +unsafe_set float_a 0 1.;; +unsafe_set addr_a 0 "a";; +(fun a x -> unsafe_set a 0 x);; + +(* Specialization during eta-expansion *) + +let eta_gen_len : 'a array -> _ = len;; +let eta_gen_safe_get : 'a array -> int -> 'a = safe_get;; +let eta_gen_unsafe_get : 'a array -> int -> 'a = unsafe_get;; +let eta_gen_safe_set : 'a array -> int -> 'a -> unit = safe_set;; +let eta_gen_unsafe_set : 'a array -> int -> 'a -> unit = unsafe_set;; + +let eta_int_len : int array -> _ = len;; +let eta_int_safe_get : int array -> int -> int = safe_get;; +let eta_int_unsafe_get : int array -> int -> int = unsafe_get;; +let eta_int_safe_set : int array -> int -> int -> unit = safe_set;; +let eta_int_unsafe_set : int array -> int -> int -> unit = unsafe_set;; + +let eta_float_len : float array -> _ = len;; +let eta_float_safe_get : float array -> int -> float = safe_get;; +let eta_float_unsafe_get : float array -> int -> float = unsafe_get;; +let eta_float_safe_set : float array -> int -> float -> unit = safe_set;; +let eta_float_unsafe_set : float array -> int -> float -> unit = unsafe_set;; + +let eta_addr_len : string array -> _ = len;; +let eta_addr_safe_get : string array -> int -> string = safe_get;; +let eta_addr_unsafe_get : string array -> int -> string = unsafe_get;; +let eta_addr_safe_set : string array -> int -> string -> unit = safe_set;; +let eta_addr_unsafe_set : string array -> int -> string -> unit = unsafe_set;; diff --git a/testsuite/tests/translprim/array_spec.ml.reference b/testsuite/tests/translprim/array_spec.ml.reference new file mode 100644 index 0000000000..7b48cfdde5 --- /dev/null +++ b/testsuite/tests/translprim/array_spec.ml.reference @@ -0,0 +1,88 @@ +(setglobal Array_spec! + (let + (int_a = (makearray[int] 1 2 3) + float_a = (makearray[float] 1. 2. 3.) + addr_a = (makearray[addr] "a" "b" "c")) + (seq (array.length[int] int_a) (array.length[float] float_a) + (array.length[addr] addr_a) + (function a (array.length[gen] a)) + (array.get[int] int_a 0) (array.get[float] float_a 0) + (array.get[addr] addr_a 0) + (function a (array.get[gen] a 0)) + (array.unsafe_get[int] int_a 0) + (array.unsafe_get[float] float_a 0) + (array.unsafe_get[addr] addr_a 0) + (function a (array.unsafe_get[gen] a 0)) + (array.set[int] int_a 0 1) (array.set[float] float_a 0 1.) + (array.set[addr] addr_a 0 "a") + (function a x (array.set[gen] a 0 x)) + (array.unsafe_set[int] int_a 0 1) + (array.unsafe_set[float] float_a 0 1.) + (array.unsafe_set[addr] addr_a 0 "a") + (function a x (array.unsafe_set[gen] a 0 x)) + (let + (eta_gen_len = + (function prim (array.length[gen] prim)) + eta_gen_safe_get = + (function prim prim + (array.get[gen] prim prim)) + eta_gen_unsafe_get = + (function prim prim + (array.unsafe_get[gen] prim prim)) + eta_gen_safe_set = + (function prim prim prim + (array.set[gen] prim prim prim)) + eta_gen_unsafe_set = + (function prim prim prim + (array.unsafe_set[gen] prim prim prim)) + eta_int_len = + (function prim (array.length[int] prim)) + eta_int_safe_get = + (function prim prim + (array.get[int] prim prim)) + eta_int_unsafe_get = + (function prim prim + (array.unsafe_get[int] prim prim)) + eta_int_safe_set = + (function prim prim prim + (array.set[int] prim prim prim)) + eta_int_unsafe_set = + (function prim prim prim + (array.unsafe_set[int] prim prim prim)) + eta_float_len = + (function prim (array.length[float] prim)) + eta_float_safe_get = + (function prim prim + (array.get[float] prim prim)) + eta_float_unsafe_get = + (function prim prim + (array.unsafe_get[float] prim prim)) + eta_float_safe_set = + (function prim prim prim + (array.set[float] prim prim prim)) + eta_float_unsafe_set = + (function prim prim prim + (array.unsafe_set[float] prim prim prim)) + eta_addr_len = + (function prim (array.length[addr] prim)) + eta_addr_safe_get = + (function prim prim + (array.get[addr] prim prim)) + eta_addr_unsafe_get = + (function prim prim + (array.unsafe_get[addr] prim prim)) + eta_addr_safe_set = + (function prim prim prim + (array.set[addr] prim prim prim)) + eta_addr_unsafe_set = + (function prim prim prim + (array.unsafe_set[addr] prim prim prim))) + (makeblock 0 int_a float_a addr_a eta_gen_len + eta_gen_safe_get eta_gen_unsafe_get eta_gen_safe_set + eta_gen_unsafe_set eta_int_len eta_int_safe_get + eta_int_unsafe_get eta_int_safe_set + eta_int_unsafe_set eta_float_len eta_float_safe_get + eta_float_unsafe_get eta_float_safe_set + eta_float_unsafe_set eta_addr_len eta_addr_safe_get + eta_addr_unsafe_get eta_addr_safe_set + eta_addr_unsafe_set))))) diff --git a/testsuite/tests/translprim/comparison_table.ml b/testsuite/tests/translprim/comparison_table.ml new file mode 100644 index 0000000000..129ea5c55f --- /dev/null +++ b/testsuite/tests/translprim/comparison_table.ml @@ -0,0 +1,239 @@ +external cmp : 'a -> 'a -> int = "%compare";; +external eq : 'a -> 'a -> bool = "%equal";; +external ne : 'a -> 'a -> bool = "%notequal";; +external lt : 'a -> 'a -> bool = "%lessthan";; +external gt : 'a -> 'a -> bool = "%greaterthan";; +external le : 'a -> 'a -> bool = "%lessequal";; +external ge : 'a -> 'a -> bool = "%greaterequal";; + +type intlike = A | B | C | D + +(* Check specialization in explicit application *) + +let gen_cmp x y = cmp x y;; +let int_cmp (x : int) y = cmp x y;; +let bool_cmp (x : bool) y = cmp x y;; +let intlike_cmp (x : intlike) y = cmp x y;; +let float_cmp (x : float) y = cmp x y;; +let string_cmp (x : string) y = cmp x y;; +let int32_cmp (x : int32) y = cmp x y;; +let int64_cmp (x : int64) y = cmp x y;; +let nativeint_cmp (x : nativeint) y = cmp x y;; + +let gen_eq x y = eq x y;; +let int_eq (x : int) y = eq x y;; +let bool_eq (x : bool) y = eq x y;; +let intlike_eq (x : intlike) y = eq x y;; +let float_eq (x : float) y = eq x y;; +let string_eq (x : string) y = eq x y;; +let int32_eq (x : int32) y = eq x y;; +let int64_eq (x : int64) y = eq x y;; +let nativeint_eq (x : nativeint) y = eq x y;; + +let gen_ne x y = ne x y;; +let int_ne (x : int) y = ne x y;; +let bool_ne (x : bool) y = ne x y;; +let intlike_ne (x : intlike) y = ne x y;; +let float_ne (x : float) y = ne x y;; +let string_ne (x : string) y = ne x y;; +let int32_ne (x : int32) y = ne x y;; +let int64_ne (x : int64) y = ne x y;; +let nativeint_ne (x : nativeint) y = ne x y;; + +let gen_lt x y = lt x y;; +let int_lt (x : int) y = lt x y;; +let bool_lt (x : bool) y = lt x y;; +let intlike_lt (x : intlike) y = lt x y;; +let float_lt (x : float) y = lt x y;; +let string_lt (x : string) y = lt x y;; +let int32_lt (x : int32) y = lt x y;; +let int64_lt (x : int64) y = lt x y;; +let nativeint_lt (x : nativeint) y = lt x y;; + +let gen_gt x y = gt x y;; +let int_gt (x : int) y = gt x y;; +let bool_gt (x : bool) y = gt x y;; +let intlike_gt (x : intlike) y = gt x y;; +let float_gt (x : float) y = gt x y;; +let string_gt (x : string) y = gt x y;; +let int32_gt (x : int32) y = gt x y;; +let int64_gt (x : int64) y = gt x y;; +let nativeint_gt (x : nativeint) y = gt x y;; + +let gen_le x y = le x y;; +let int_le (x : int) y = le x y;; +let bool_le (x : bool) y = le x y;; +let intlike_le (x : intlike) y = le x y;; +let float_le (x : float) y = le x y;; +let string_le (x : string) y = le x y;; +let int32_le (x : int32) y = le x y;; +let int64_le (x : int64) y = le x y;; +let nativeint_le (x : nativeint) y = le x y;; + +let gen_ge x y = ge x y;; +let int_ge (x : int) y = ge x y;; +let bool_ge (x : bool) y = ge x y;; +let intlike_ge (x : intlike) y = ge x y;; +let float_ge (x : float) y = ge x y;; +let string_ge (x : string) y = ge x y;; +let int32_ge (x : int32) y = ge x y;; +let int64_ge (x : int64) y = ge x y;; +let nativeint_ge (x : nativeint) y = ge x y;; + +(* Check specialization in eta-expansion *) + +let eta_gen_cmp : 'a -> _ = cmp;; +let eta_int_cmp : int -> _ = cmp;; +let eta_bool_cmp : bool -> _ = cmp;; +let eta_intlike_cmp : intlike -> _ = cmp;; +let eta_float_cmp : float -> _ = cmp;; +let eta_string_cmp : string -> _ = cmp;; +let eta_int32_cmp : int32 -> _ = cmp;; +let eta_int64_cmp : int64 -> _ = cmp;; +let eta_nativeint_cmp : nativeint -> _ = cmp;; + +let eta_gen_eq : 'a -> _ = eq;; +let eta_int_eq : int -> _ = eq;; +let eta_bool_eq : bool -> _ = eq;; +let eta_intlike_eq : intlike -> _ = eq;; +let eta_float_eq : float -> _ = eq;; +let eta_string_eq : string -> _ = eq;; +let eta_int32_eq : int32 -> _ = eq;; +let eta_int64_eq : int64 -> _ = eq;; +let eta_nativeint_eq : nativeint -> _ = eq;; + +let eta_gen_ne : 'a -> _ = ne;; +let eta_int_ne : int -> _ = ne;; +let eta_bool_ne : bool -> _ = ne;; +let eta_intlike_ne : intlike -> _ = ne;; +let eta_float_ne : float -> _ = ne;; +let eta_string_ne : string -> _ = ne;; +let eta_int32_ne : int32 -> _ = ne;; +let eta_int64_ne : int64 -> _ = ne;; +let eta_nativeint_ne : nativeint -> _ = ne;; + +let eta_gen_lt : 'a -> _ = lt;; +let eta_int_lt : int -> _ = lt;; +let eta_bool_lt : bool -> _ = lt;; +let eta_intlike_lt : intlike -> _ = lt;; +let eta_float_lt : float -> _ = lt;; +let eta_string_lt : string -> _ = lt;; +let eta_int32_lt : int32 -> _ = lt;; +let eta_int64_lt : int64 -> _ = lt;; +let eta_nativeint_lt : nativeint -> _ = lt;; + +let eta_gen_gt : 'a -> _ = gt;; +let eta_int_gt : int -> _ = gt;; +let eta_bool_gt : bool -> _ = gt;; +let eta_intlike_gt : intlike -> _ = gt;; +let eta_float_gt : float -> _ = gt;; +let eta_string_gt : string -> _ = gt;; +let eta_int32_gt : int32 -> _ = gt;; +let eta_int64_gt : int64 -> _ = gt;; +let eta_nativeint_gt : nativeint -> _ = gt;; + +let eta_gen_le : 'a -> _ = le;; +let eta_int_le : int -> _ = le;; +let eta_bool_le : bool -> _ = le;; +let eta_intlike_le : intlike -> _ = le;; +let eta_float_le : float -> _ = le;; +let eta_string_le : string -> _ = le;; +let eta_int32_le : int32 -> _ = le;; +let eta_int64_le : int64 -> _ = le;; +let eta_nativeint_le : nativeint -> _ = le;; + +let eta_gen_ge : 'a -> _ = ge;; +let eta_int_ge : int -> _ = ge;; +let eta_bool_ge : bool -> _ = ge;; +let eta_intlike_ge : intlike -> _ = ge;; +let eta_float_ge : float -> _ = ge;; +let eta_string_ge : string -> _ = ge;; +let eta_int32_ge : int32 -> _ = ge;; +let eta_int64_ge : int64 -> _ = ge;; +let eta_nativeint_ge : nativeint -> _ = ge;; + +(* Check results of computations *) + +let int_vec = [(1,1);(1,2);(2,1)];; +let bool_vec = [(false,false);(false,true);(true,false)];; +let intlike_vec = [(A,A);(A,B);(B,A)];; +let float_vec = [(1.,1.);(1.,2.);(2.,1.)];; +let string_vec = [("1","1");("1","2");("2","1")];; +let int32_vec = [(1l,1l);(1l,2l);(2l,1l)];; +let int64_vec = [(1L,1L);(1L,2L);(2L,1L)];; +let nativeint_vec = [(1n,1n);(1n,2n);(2n,1n)];; + +let test_vec cmp eq ne lt gt le ge vec = + let uncurry f (x,y) = f x y in + let map f l = List.map (uncurry f) l in + (map gen_cmp vec, map cmp vec), + (map (fun gen spec -> map gen vec, map spec vec) + [gen_eq,eq; gen_ne,ne; gen_lt,lt; gen_gt,gt; gen_le,le; gen_ge,ge]) +;; + +test_vec + int_cmp int_eq int_ne int_lt int_gt int_le int_ge + int_vec;; +test_vec + bool_cmp bool_eq bool_ne bool_lt bool_gt bool_le bool_ge + bool_vec;; +test_vec + intlike_cmp intlike_eq intlike_ne intlike_lt intlike_gt intlike_le intlike_ge + intlike_vec;; +test_vec + float_cmp float_eq float_ne float_lt float_gt float_le float_ge + float_vec;; +test_vec + string_cmp string_eq string_ne string_lt string_gt string_le string_ge + string_vec;; +test_vec + int32_cmp int32_eq int32_ne int32_lt int32_gt int32_le int32_ge + int32_vec;; +test_vec + int64_cmp int64_eq int64_ne int64_lt int64_gt int64_le int64_ge + int64_vec;; +test_vec + nativeint_cmp nativeint_eq nativeint_ne + nativeint_lt nativeint_gt nativeint_le nativeint_ge + nativeint_vec;; + +let eta_test_vec cmp eq ne lt gt le ge vec = + let uncurry f (x,y) = f x y in + let map f l = List.map (uncurry f) l in + (map eta_gen_cmp vec, map cmp vec), + (map (fun gen spec -> map gen vec, map spec vec) + [eta_gen_eq,eq; eta_gen_ne,ne; eta_gen_lt,lt; + eta_gen_gt,gt; eta_gen_le,le; eta_gen_ge,ge]) +;; + +eta_test_vec + eta_int_cmp eta_int_eq eta_int_ne eta_int_lt eta_int_gt eta_int_le eta_int_ge + int_vec;; +eta_test_vec + eta_bool_cmp eta_bool_eq eta_bool_ne eta_bool_lt eta_bool_gt + eta_bool_le eta_bool_ge + bool_vec;; +eta_test_vec + eta_intlike_cmp eta_intlike_eq eta_intlike_ne eta_intlike_lt eta_intlike_gt + eta_intlike_le eta_intlike_ge + intlike_vec;; +eta_test_vec + eta_float_cmp eta_float_eq eta_float_ne eta_float_lt eta_float_gt + eta_float_le eta_float_ge + float_vec;; +eta_test_vec + eta_string_cmp eta_string_eq eta_string_ne eta_string_lt eta_string_gt + eta_string_le eta_string_ge + string_vec;; +eta_test_vec + eta_int32_cmp eta_int32_eq eta_int32_ne eta_int32_lt eta_int32_gt + eta_int32_le eta_int32_ge + int32_vec;; +eta_test_vec + eta_int64_cmp eta_int64_eq eta_int64_ne eta_int64_lt eta_int64_gt + eta_int64_le eta_int64_ge + int64_vec;; +eta_test_vec + eta_nativeint_cmp eta_nativeint_eq eta_nativeint_ne + eta_nativeint_lt eta_nativeint_gt eta_nativeint_le eta_nativeint_ge + nativeint_vec;; diff --git a/testsuite/tests/translprim/comparison_table.ml.reference b/testsuite/tests/translprim/comparison_table.ml.reference new file mode 100644 index 0000000000..525ff898cf --- /dev/null +++ b/testsuite/tests/translprim/comparison_table.ml.reference @@ -0,0 +1,364 @@ +(setglobal Comparison_table! + (let + (gen_cmp = (function x y (caml_compare x y)) + int_cmp = (function x y (caml_int_compare x y)) + bool_cmp = + (function x y (caml_int_compare x y)) + intlike_cmp = + (function x y (caml_int_compare x y)) + float_cmp = + (function x y (caml_float_compare x y)) + string_cmp = + (function x y (caml_string_compare x y)) + int32_cmp = + (function x y (caml_int32_compare x y)) + int64_cmp = + (function x y (caml_int64_compare x y)) + nativeint_cmp = + (function x y (caml_nativeint_compare x y)) + gen_eq = (function x y (caml_equal x y)) + int_eq = (function x y (== x y)) + bool_eq = (function x y (== x y)) + intlike_eq = (function x y (== x y)) + float_eq = (function x y (==. x y)) + string_eq = + (function x y (caml_string_equal x y)) + int32_eq = (function x y (Int32.== x y)) + int64_eq = (function x y (Int64.== x y)) + nativeint_eq = + (function x y (Nativeint.== x y)) + gen_ne = (function x y (caml_notequal x y)) + int_ne = (function x y (!= x y)) + bool_ne = (function x y (!= x y)) + intlike_ne = (function x y (!= x y)) + float_ne = (function x y (!=. x y)) + string_ne = + (function x y (caml_string_notequal x y)) + int32_ne = (function x y (Int32.!= x y)) + int64_ne = (function x y (Int64.!= x y)) + nativeint_ne = + (function x y (Nativeint.!= x y)) + gen_lt = (function x y (caml_lessthan x y)) + int_lt = (function x y (< x y)) + bool_lt = (function x y (< x y)) + intlike_lt = (function x y (< x y)) + float_lt = (function x y (<. x y)) + string_lt = + (function x y (caml_string_lessthan x y)) + int32_lt = (function x y (Int32.< x y)) + int64_lt = (function x y (Int64.< x y)) + nativeint_lt = (function x y (Nativeint.< x y)) + gen_gt = (function x y (caml_greaterthan x y)) + int_gt = (function x y (> x y)) + bool_gt = (function x y (> x y)) + intlike_gt = (function x y (> x y)) + float_gt = (function x y (>. x y)) + string_gt = + (function x y (caml_string_greaterthan x y)) + int32_gt = (function x y (Int32.> x y)) + int64_gt = (function x y (Int64.> x y)) + nativeint_gt = (function x y (Nativeint.> x y)) + gen_le = (function x y (caml_lessequal x y)) + int_le = (function x y (<= x y)) + bool_le = (function x y (<= x y)) + intlike_le = (function x y (<= x y)) + float_le = (function x y (<=. x y)) + string_le = + (function x y (caml_string_lessequal x y)) + int32_le = (function x y (Int32.<= x y)) + int64_le = (function x y (Int64.<= x y)) + nativeint_le = + (function x y (Nativeint.<= x y)) + gen_ge = (function x y (caml_greaterequal x y)) + int_ge = (function x y (>= x y)) + bool_ge = (function x y (>= x y)) + intlike_ge = (function x y (>= x y)) + float_ge = (function x y (>=. x y)) + string_ge = + (function x y (caml_string_greaterequal x y)) + int32_ge = (function x y (Int32.>= x y)) + int64_ge = (function x y (Int64.>= x y)) + nativeint_ge = + (function x y (Nativeint.>= x y)) + eta_gen_cmp = + (function prim prim (caml_compare prim prim)) + eta_int_cmp = + (function prim prim (caml_int_compare prim prim)) + eta_bool_cmp = + (function prim prim (caml_int_compare prim prim)) + eta_intlike_cmp = + (function prim prim (caml_int_compare prim prim)) + eta_float_cmp = + (function prim prim + (caml_float_compare prim prim)) + eta_string_cmp = + (function prim prim + (caml_string_compare prim prim)) + eta_int32_cmp = + (function prim prim + (caml_int32_compare prim prim)) + eta_int64_cmp = + (function prim prim + (caml_int64_compare prim prim)) + eta_nativeint_cmp = + (function prim prim + (caml_nativeint_compare prim prim)) + eta_gen_eq = + (function prim prim (caml_equal prim prim)) + eta_int_eq = + (function prim prim (== prim prim)) + eta_bool_eq = + (function prim prim (== prim prim)) + eta_intlike_eq = + (function prim prim (== prim prim)) + eta_float_eq = + (function prim prim (==. prim prim)) + eta_string_eq = + (function prim prim (caml_string_equal prim prim)) + eta_int32_eq = + (function prim prim (Int32.== prim prim)) + eta_int64_eq = + (function prim prim (Int64.== prim prim)) + eta_nativeint_eq = + (function prim prim (Nativeint.== prim prim)) + eta_gen_ne = + (function prim prim (caml_notequal prim prim)) + eta_int_ne = + (function prim prim (!= prim prim)) + eta_bool_ne = + (function prim prim (!= prim prim)) + eta_intlike_ne = + (function prim prim (!= prim prim)) + eta_float_ne = + (function prim prim (!=. prim prim)) + eta_string_ne = + (function prim prim + (caml_string_notequal prim prim)) + eta_int32_ne = + (function prim prim (Int32.!= prim prim)) + eta_int64_ne = + (function prim prim (Int64.!= prim prim)) + eta_nativeint_ne = + (function prim prim (Nativeint.!= prim prim)) + eta_gen_lt = + (function prim prim (caml_lessthan prim prim)) + eta_int_lt = (function prim prim (< prim prim)) + eta_bool_lt = + (function prim prim (< prim prim)) + eta_intlike_lt = + (function prim prim (< prim prim)) + eta_float_lt = + (function prim prim (<. prim prim)) + eta_string_lt = + (function prim prim + (caml_string_lessthan prim prim)) + eta_int32_lt = + (function prim prim (Int32.< prim prim)) + eta_int64_lt = + (function prim prim (Int64.< prim prim)) + eta_nativeint_lt = + (function prim prim (Nativeint.< prim prim)) + eta_gen_gt = + (function prim prim (caml_greaterthan prim prim)) + eta_int_gt = (function prim prim (> prim prim)) + eta_bool_gt = + (function prim prim (> prim prim)) + eta_intlike_gt = + (function prim prim (> prim prim)) + eta_float_gt = + (function prim prim (>. prim prim)) + eta_string_gt = + (function prim prim + (caml_string_greaterthan prim prim)) + eta_int32_gt = + (function prim prim (Int32.> prim prim)) + eta_int64_gt = + (function prim prim (Int64.> prim prim)) + eta_nativeint_gt = + (function prim prim (Nativeint.> prim prim)) + eta_gen_le = + (function prim prim (caml_lessequal prim prim)) + eta_int_le = + (function prim prim (<= prim prim)) + eta_bool_le = + (function prim prim (<= prim prim)) + eta_intlike_le = + (function prim prim (<= prim prim)) + eta_float_le = + (function prim prim (<=. prim prim)) + eta_string_le = + (function prim prim + (caml_string_lessequal prim prim)) + eta_int32_le = + (function prim prim (Int32.<= prim prim)) + eta_int64_le = + (function prim prim (Int64.<= prim prim)) + eta_nativeint_le = + (function prim prim (Nativeint.<= prim prim)) + eta_gen_ge = + (function prim prim (caml_greaterequal prim prim)) + eta_int_ge = + (function prim prim (>= prim prim)) + eta_bool_ge = + (function prim prim (>= prim prim)) + eta_intlike_ge = + (function prim prim (>= prim prim)) + eta_float_ge = + (function prim prim (>=. prim prim)) + eta_string_ge = + (function prim prim + (caml_string_greaterequal prim prim)) + eta_int32_ge = + (function prim prim (Int32.>= prim prim)) + eta_int64_ge = + (function prim prim (Int64.>= prim prim)) + eta_nativeint_ge = + (function prim prim (Nativeint.>= prim prim)) + int_vec = [0: [0: 1 1] [0: [0: 1 2] [0: [0: 2 1] 0a]]] + bool_vec = [0: [0: 0a 0a] [0: [0: 0a 1a] [0: [0: 1a 0a] 0a]]] + intlike_vec = [0: [0: 0a 0a] [0: [0: 0a 1a] [0: [0: 1a 0a] 0a]]] + float_vec = [0: [0: 1. 1.] [0: [0: 1. 2.] [0: [0: 2. 1.] 0a]]] + string_vec = + [0: [0: "1" "1"] [0: [0: "1" "2"] [0: [0: "2" "1"] 0a]]] + int32_vec = [0: [0: 1l 1l] [0: [0: 1l 2l] [0: [0: 2l 1l] 0a]]] + int64_vec = [0: [0: 1L 1L] [0: [0: 1L 2L] [0: [0: 2L 1L] 0a]]] + nativeint_vec = [0: [0: 1n 1n] [0: [0: 1n 2n] [0: [0: 2n 1n] 0a]]] + test_vec = + (function cmp eq ne lt gt le ge + vec + (let + (uncurry = + (function f param + (apply f (field 0 param) (field 1 param))) + map = + (function f l + (apply (field 12 (global List!)) (apply uncurry f) + l))) + (makeblock 0 + (makeblock 0 (apply map gen_cmp vec) + (apply map cmp vec)) + (apply map + (function gen spec + (makeblock 0 (apply map gen vec) + (apply map spec vec))) + (makeblock 0 (makeblock 0 gen_eq eq) + (makeblock 0 (makeblock 0 gen_ne ne) + (makeblock 0 (makeblock 0 gen_lt lt) + (makeblock 0 (makeblock 0 gen_gt gt) + (makeblock 0 (makeblock 0 gen_le le) + (makeblock 0 (makeblock 0 gen_ge ge) 0a))))))))))) + (seq + (apply test_vec int_cmp int_eq int_ne int_lt + int_gt int_le int_ge int_vec) + (apply test_vec bool_cmp bool_eq bool_ne + bool_lt bool_gt bool_le bool_ge bool_vec) + (apply test_vec intlike_cmp intlike_eq intlike_ne + intlike_lt intlike_gt intlike_le intlike_ge + intlike_vec) + (apply test_vec float_cmp float_eq float_ne + float_lt float_gt float_le float_ge + float_vec) + (apply test_vec string_cmp string_eq string_ne + string_lt string_gt string_le string_ge + string_vec) + (apply test_vec int32_cmp int32_eq int32_ne + int32_lt int32_gt int32_le int32_ge + int32_vec) + (apply test_vec int64_cmp int64_eq int64_ne + int64_lt int64_gt int64_le int64_ge + int64_vec) + (apply test_vec nativeint_cmp nativeint_eq + nativeint_ne nativeint_lt nativeint_gt + nativeint_le nativeint_ge nativeint_vec) + (let + (eta_test_vec = + (function cmp eq ne lt gt le ge + vec + (let + (uncurry = + (function f param + (apply f (field 0 param) (field 1 param))) + map = + (function f l + (apply (field 12 (global List!)) + (apply uncurry f) l))) + (makeblock 0 + (makeblock 0 (apply map eta_gen_cmp vec) + (apply map cmp vec)) + (apply map + (function gen spec + (makeblock 0 (apply map gen vec) + (apply map spec vec))) + (makeblock 0 (makeblock 0 eta_gen_eq eq) + (makeblock 0 (makeblock 0 eta_gen_ne ne) + (makeblock 0 (makeblock 0 eta_gen_lt lt) + (makeblock 0 (makeblock 0 eta_gen_gt gt) + (makeblock 0 (makeblock 0 eta_gen_le le) + (makeblock 0 + (makeblock 0 eta_gen_ge ge) 0a))))))))))) + (seq + (apply eta_test_vec eta_int_cmp eta_int_eq + eta_int_ne eta_int_lt eta_int_gt eta_int_le + eta_int_ge int_vec) + (apply eta_test_vec eta_bool_cmp eta_bool_eq + eta_bool_ne eta_bool_lt eta_bool_gt + eta_bool_le eta_bool_ge bool_vec) + (apply eta_test_vec eta_intlike_cmp eta_intlike_eq + eta_intlike_ne eta_intlike_lt eta_intlike_gt + eta_intlike_le eta_intlike_ge intlike_vec) + (apply eta_test_vec eta_float_cmp eta_float_eq + eta_float_ne eta_float_lt eta_float_gt + eta_float_le eta_float_ge float_vec) + (apply eta_test_vec eta_string_cmp eta_string_eq + eta_string_ne eta_string_lt eta_string_gt + eta_string_le eta_string_ge string_vec) + (apply eta_test_vec eta_int32_cmp eta_int32_eq + eta_int32_ne eta_int32_lt eta_int32_gt + eta_int32_le eta_int32_ge int32_vec) + (apply eta_test_vec eta_int64_cmp eta_int64_eq + eta_int64_ne eta_int64_lt eta_int64_gt + eta_int64_le eta_int64_ge int64_vec) + (apply eta_test_vec eta_nativeint_cmp + eta_nativeint_eq eta_nativeint_ne eta_nativeint_lt + eta_nativeint_gt eta_nativeint_le eta_nativeint_ge + nativeint_vec) + (makeblock 0 gen_cmp int_cmp bool_cmp + intlike_cmp float_cmp string_cmp int32_cmp + int64_cmp nativeint_cmp gen_eq int_eq + bool_eq intlike_eq float_eq string_eq + int32_eq int64_eq nativeint_eq gen_ne + int_ne bool_ne intlike_ne float_ne + string_ne int32_ne int64_ne nativeint_ne + gen_lt int_lt bool_lt intlike_lt + float_lt string_lt int32_lt int64_lt + nativeint_lt gen_gt int_gt bool_gt + intlike_gt float_gt string_gt int32_gt + int64_gt nativeint_gt gen_le int_le + bool_le intlike_le float_le string_le + int32_le int64_le nativeint_le gen_ge + int_ge bool_ge intlike_ge float_ge + string_ge int32_ge int64_ge nativeint_ge + eta_gen_cmp eta_int_cmp eta_bool_cmp + eta_intlike_cmp eta_float_cmp eta_string_cmp + eta_int32_cmp eta_int64_cmp eta_nativeint_cmp + eta_gen_eq eta_int_eq eta_bool_eq + eta_intlike_eq eta_float_eq eta_string_eq + eta_int32_eq eta_int64_eq eta_nativeint_eq + eta_gen_ne eta_int_ne eta_bool_ne + eta_intlike_ne eta_float_ne eta_string_ne + eta_int32_ne eta_int64_ne eta_nativeint_ne + eta_gen_lt eta_int_lt eta_bool_lt + eta_intlike_lt eta_float_lt eta_string_lt + eta_int32_lt eta_int64_lt eta_nativeint_lt + eta_gen_gt eta_int_gt eta_bool_gt + eta_intlike_gt eta_float_gt eta_string_gt + eta_int32_gt eta_int64_gt eta_nativeint_gt + eta_gen_le eta_int_le eta_bool_le + eta_intlike_le eta_float_le eta_string_le + eta_int32_le eta_int64_le eta_nativeint_le + eta_gen_ge eta_int_ge eta_bool_ge + eta_intlike_ge eta_float_ge eta_string_ge + eta_int32_ge eta_int64_ge eta_nativeint_ge + int_vec bool_vec intlike_vec float_vec + string_vec int32_vec int64_vec nativeint_vec + test_vec eta_test_vec)))))) diff --git a/testsuite/tests/translprim/module_coercion.ml b/testsuite/tests/translprim/module_coercion.ml new file mode 100644 index 0000000000..041b30341f --- /dev/null +++ b/testsuite/tests/translprim/module_coercion.ml @@ -0,0 +1,37 @@ +module M = struct + external len : 'a array -> int = "%array_length" + external safe_get : 'a array -> int -> 'a = "%array_safe_get" + external unsafe_get : 'a array -> int -> 'a = "%array_unsafe_get" + external safe_set : 'a array -> int -> 'a -> unit = "%array_safe_set" + external unsafe_set : 'a array -> int -> 'a -> unit = "%array_unsafe_set" + external cmp : 'a -> 'a -> int = "%compare";; + external eq : 'a -> 'a -> bool = "%equal";; + external ne : 'a -> 'a -> bool = "%notequal";; + external lt : 'a -> 'a -> bool = "%lessthan";; + external gt : 'a -> 'a -> bool = "%greaterthan";; + external le : 'a -> 'a -> bool = "%lessequal";; + external ge : 'a -> 'a -> bool = "%greaterequal";; +end;; + +module type T = sig + type t + val len : t array -> int + val safe_get : t array -> int -> t + val unsafe_get : t array -> int -> t + val safe_set : t array -> int -> t -> unit + val unsafe_set : t array -> int -> t -> unit + val cmp : t -> t -> int + val eq : t -> t -> bool + val ne : t -> t -> bool + val lt : t -> t -> bool + val gt : t -> t -> bool + val le : t -> t -> bool + val ge : t -> t -> bool +end;; + +module M_int : T with type t := int = M;; +module M_float : T with type t := float = M;; +module M_string : T with type t := string = M;; +module M_int32 : T with type t := int32 = M;; +module M_int64 : T with type t := int64 = M;; +module M_nativeint : T with type t := nativeint = M;; diff --git a/testsuite/tests/translprim/module_coercion.ml.reference b/testsuite/tests/translprim/module_coercion.ml.reference new file mode 100644 index 0000000000..b84637f440 --- /dev/null +++ b/testsuite/tests/translprim/module_coercion.ml.reference @@ -0,0 +1,104 @@ +(setglobal Module_coercion! + (let (M = (makeblock 0)) + (makeblock 0 M + (makeblock 0 (function prim (array.length[int] prim)) + (function prim prim (array.get[int] prim prim)) + (function prim prim + (array.unsafe_get[int] prim prim)) + (function prim prim prim + (array.set[int] prim prim prim)) + (function prim prim prim + (array.unsafe_set[int] prim prim prim)) + (function prim prim (caml_int_compare prim prim)) + (function prim prim (== prim prim)) + (function prim prim (!= prim prim)) + (function prim prim (< prim prim)) + (function prim prim (> prim prim)) + (function prim prim (<= prim prim)) + (function prim prim (>= prim prim))) + (makeblock 0 (function prim (array.length[float] prim)) + (function prim prim (array.get[float] prim prim)) + (function prim prim + (array.unsafe_get[float] prim prim)) + (function prim prim prim + (array.set[float] prim prim prim)) + (function prim prim prim + (array.unsafe_set[float] prim prim prim)) + (function prim prim + (caml_float_compare prim prim)) + (function prim prim (==. prim prim)) + (function prim prim (!=. prim prim)) + (function prim prim (<. prim prim)) + (function prim prim (>. prim prim)) + (function prim prim (<=. prim prim)) + (function prim prim (>=. prim prim))) + (makeblock 0 (function prim (array.length[addr] prim)) + (function prim prim (array.get[addr] prim prim)) + (function prim prim + (array.unsafe_get[addr] prim prim)) + (function prim prim prim + (array.set[addr] prim prim prim)) + (function prim prim prim + (array.unsafe_set[addr] prim prim prim)) + (function prim prim + (caml_string_compare prim prim)) + (function prim prim + (caml_string_equal prim prim)) + (function prim prim + (caml_string_notequal prim prim)) + (function prim prim + (caml_string_lessthan prim prim)) + (function prim prim + (caml_string_greaterthan prim prim)) + (function prim prim + (caml_string_lessequal prim prim)) + (function prim prim + (caml_string_greaterequal prim prim))) + (makeblock 0 (function prim (array.length[addr] prim)) + (function prim prim (array.get[addr] prim prim)) + (function prim prim + (array.unsafe_get[addr] prim prim)) + (function prim prim prim + (array.set[addr] prim prim prim)) + (function prim prim prim + (array.unsafe_set[addr] prim prim prim)) + (function prim prim + (caml_int32_compare prim prim)) + (function prim prim (Int32.== prim prim)) + (function prim prim (Int32.!= prim prim)) + (function prim prim (Int32.< prim prim)) + (function prim prim (Int32.> prim prim)) + (function prim prim (Int32.<= prim prim)) + (function prim prim (Int32.>= prim prim))) + (makeblock 0 (function prim (array.length[addr] prim)) + (function prim prim (array.get[addr] prim prim)) + (function prim prim + (array.unsafe_get[addr] prim prim)) + (function prim prim prim + (array.set[addr] prim prim prim)) + (function prim prim prim + (array.unsafe_set[addr] prim prim prim)) + (function prim prim + (caml_int64_compare prim prim)) + (function prim prim (Int64.== prim prim)) + (function prim prim (Int64.!= prim prim)) + (function prim prim (Int64.< prim prim)) + (function prim prim (Int64.> prim prim)) + (function prim prim (Int64.<= prim prim)) + (function prim prim (Int64.>= prim prim))) + (makeblock 0 (function prim (array.length[addr] prim)) + (function prim prim (array.get[addr] prim prim)) + (function prim prim + (array.unsafe_get[addr] prim prim)) + (function prim prim prim + (array.set[addr] prim prim prim)) + (function prim prim prim + (array.unsafe_set[addr] prim prim prim)) + (function prim prim + (caml_nativeint_compare prim prim)) + (function prim prim (Nativeint.== prim prim)) + (function prim prim (Nativeint.!= prim prim)) + (function prim prim (Nativeint.< prim prim)) + (function prim prim (Nativeint.> prim prim)) + (function prim prim (Nativeint.<= prim prim)) + (function prim prim (Nativeint.>= prim prim)))))) diff --git a/testsuite/tests/translprim/ref_spec.ml b/testsuite/tests/translprim/ref_spec.ml new file mode 100644 index 0000000000..37553ef914 --- /dev/null +++ b/testsuite/tests/translprim/ref_spec.ml @@ -0,0 +1,42 @@ +type 'a custom_rec = { x : unit; mutable y : 'a } +type float_rec = { w : float; mutable z : float } + +type cst = A | B +type gen = C | D of string + +type var = [ `A | `B ] +type vargen = [ `A | `B of int | `C ] + +let int_ref = ref 1;; +let var_ref : var ref = ref `A;; +let vargen_ref : vargen ref = ref `A;; +let cst_ref = ref A;; +let gen_ref = ref C;; +let flt_ref = ref 0.;; + +int_ref := 2;; +var_ref := `B;; +vargen_ref := `B 0;; +vargen_ref := `C;; +cst_ref := B;; +gen_ref := D "foo";; +gen_ref := C;; +flt_ref := 1.;; + +let int_rec = { x = (); y = 1 };; +let var_rec : var custom_rec = { x = (); y = `A };; +let vargen_rec : vargen custom_rec = { x = (); y = `A };; +let cst_rec = { x = (); y = A };; +let gen_rec = { x = (); y = C };; +let flt_rec = { x = (); y = 0. };; +let flt_rec' = { w = 0.; z = 0. };; + +int_rec.y <- 2;; +var_rec.y <- `B;; +vargen_rec.y <- `B 0;; +vargen_rec.y <- `C;; +cst_rec.y <- B;; +gen_rec.y <- D "foo";; +gen_rec.y <- C;; +flt_rec.y <- 1.;; +flt_rec'.z <- 1.;; diff --git a/testsuite/tests/translprim/ref_spec.ml.reference b/testsuite/tests/translprim/ref_spec.ml.reference new file mode 100644 index 0000000000..ff0753dc6c --- /dev/null +++ b/testsuite/tests/translprim/ref_spec.ml.reference @@ -0,0 +1,33 @@ +(setglobal Ref_spec! + (let + (int_ref = (makemutable 0 1) + var_ref = (makemutable 0 65a) + vargen_ref = (makemutable 0 65a) + cst_ref = (makemutable 0 0a) + gen_ref = (makemutable 0 0a) + flt_ref = (makemutable 0 0.)) + (seq (setfield_imm 0 int_ref 2) (setfield_ptr 0 var_ref 66a) + (setfield_ptr 0 vargen_ref [0: 66 0]) + (setfield_ptr 0 vargen_ref 67a) (setfield_imm 0 cst_ref 1a) + (setfield_ptr 0 gen_ref [0: "foo"]) + (setfield_ptr 0 gen_ref 0a) (setfield_ptr 0 flt_ref 1.) + (let + (int_rec = (makemutable 0 0a 1) + var_rec = (makemutable 0 0a 65a) + vargen_rec = (makemutable 0 0a 65a) + cst_rec = (makemutable 0 0a 0a) + gen_rec = (makemutable 0 0a 0a) + flt_rec = (makemutable 0 0a 0.) + flt_rec' = (makearray[float] 0. 0.)) + (seq (setfield_imm 1 int_rec 2) + (setfield_ptr 1 var_rec 66a) + (setfield_ptr 1 vargen_rec [0: 66 0]) + (setfield_ptr 1 vargen_rec 67a) + (setfield_imm 1 cst_rec 1a) + (setfield_ptr 1 gen_rec [0: "foo"]) + (setfield_ptr 1 gen_rec 0a) (setfield_ptr 1 flt_rec 1.) + (setfloatfield 1 flt_rec' 1.) + (makeblock 0 int_ref var_ref vargen_ref cst_ref + gen_ref flt_ref int_rec var_rec + vargen_rec cst_rec gen_rec flt_rec + flt_rec')))))) diff --git a/testsuite/tests/typing-extensions/open_types.ml b/testsuite/tests/typing-extensions/open_types.ml index e7632cac29..766bee0434 100644 --- a/testsuite/tests/typing-extensions/open_types.ml +++ b/testsuite/tests/typing-extensions/open_types.ml @@ -107,3 +107,11 @@ type foo = .. type foo += Foo let f = function Foo -> () ;; (* warn *) + +(* More complex exhaustiveness *) + +let f = function + | [Foo] -> 1 + | _::_::_ -> 3 + | [] -> 2 +;; (* warn *) diff --git a/testsuite/tests/typing-extensions/open_types.ml.reference b/testsuite/tests/typing-extensions/open_types.ml.reference index 841a94baa2..8e86ec0937 100644 --- a/testsuite/tests/typing-extensions/open_types.ml.reference +++ b/testsuite/tests/typing-extensions/open_types.ml.reference @@ -13,21 +13,21 @@ type bar += Bar of int (* Error: type is not open *) ^^^^^^^^^^ Error: Cannot extend type definition bar -# Characters 6-20: +# Characters 1-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: +# Characters 1-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: +# Characters 1-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. @@ -76,10 +76,21 @@ Error: Signature mismatch: ^^^^^^^^^^^^^^^^^^ Warning 8: this pattern-matching is not exhaustive. Here is an example of a value that is not matched: -_ -Matching over values of open types must include -a wild card pattern in order to be exhaustive. +*extension* +Matching over values of extensible variant types (the *extension* above) +must include a wild card pattern in order to be exhaustive. type foo = .. type foo += Foo val f : foo -> unit = <fun> +# Characters 44-96: + ........function + | [Foo] -> 1 + | _::_::_ -> 3 + | [] -> 2 +Warning 8: this pattern-matching is not exhaustive. +Here is an example of a value that is not matched: +*extension*::[] +Matching over values of extensible variant types (the *extension* above) +must include a wild card pattern in order to be exhaustive. +val f : foo list -> int = <fun> # diff --git a/testsuite/tests/typing-gadts/pr5689.ml b/testsuite/tests/typing-gadts/pr5689.ml index 304f8e6cde..856ddc2738 100644 --- a/testsuite/tests/typing-gadts/pr5689.ml +++ b/testsuite/tests/typing-gadts/pr5689.ml @@ -9,7 +9,7 @@ type _ inline_t = let uppercase seq = let rec process: type a. a inline_t -> a inline_t = function - | Text txt -> Text (String.uppercase txt) + | Text txt -> Text (String.uppercase_ascii txt) | Bold xs -> Bold (List.map process xs) | Link lnk -> Link lnk | Mref (lnk, xs) -> Mref (lnk, List.map process xs) diff --git a/testsuite/tests/typing-gadts/pr5985.ml.reference b/testsuite/tests/typing-gadts/pr5985.ml.reference index af6154dda7..4c29f6dae2 100644 --- a/testsuite/tests/typing-gadts/pr5985.ml.reference +++ b/testsuite/tests/typing-gadts/pr5985.ml.reference @@ -1,43 +1,43 @@ -# Characters 92-115: +# Characters 88-115: type _ t = T : 'a -> 'a s t - ^^^^^^^^^^^^^^^^^^^^^^^ + ^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: In this definition, a type variable cannot be deduced from the type parameters. # * * * Characters 140-141: module F (S : sig type #'a s end) = struct ^ Error: Syntax error -# * * * * * Characters 296-374: - ........['a] c x = +# * * * * * Characters 290-374: + ..class ['a] c x = object constraint 'a = 'b T.t val x' : 'b = x method x = x' end Error: In this definition, a type variable cannot be deduced from the type parameters. -# Characters 83-128: +# Characters 79-128: type 'x t = A of 'a constraint 'x = [< `X of 'a ] ;; (* fail *) - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: In this definition, a type variable cannot be deduced from the type parameters. # Characters 36-37: let A x = A x in ^ Error: Unbound constructor A -# Characters 4-37: +# Characters 0-37: type 'a t = A : 'a -> [< `X of 'a ] t;; (* fail *) - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: In this definition, a type variable cannot be deduced from the type parameters. # type (_, _) eq = Eq : ('a, 'a) eq # val eq : 'a = <poly> # val eq : ('a Queue.t, 'b Queue.t) eq = Eq -# Characters 4-33: +# Characters 0-33: type _ t = T : 'a -> 'a Queue.t t;; (* fail *) - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: In this definition, a type variable cannot be deduced from the type parameters. -# * * * * Characters 254-277: +# * * * * Characters 250-277: type _ t = T : 'a -> 'a s t - ^^^^^^^^^^^^^^^^^^^^^^^ + ^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: In this definition, a type variable cannot be deduced from the type parameters. # Characters 59-60: @@ -50,17 +50,17 @@ Error: Unbound module type S ^ Error: Syntax error # * * * * type 'a q = Q -# Characters 5-36: +# Characters 0-36: type +'a t = 'b constraint 'a = 'b q;; - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: In this definition, a type variable has a variance that cannot be deduced from the type parameters. It was expected to be unrestricted, but it is covariant. # type 'a t = T of 'a # type +'a s = 'b constraint 'a = 'b t -# Characters 5-36: +# Characters 0-36: type -'a s = 'b constraint 'a = 'b t;; (* fail *) - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: In this definition, a type variable has a variance that is not reflected by its occurrence in type parameters. It was expected to be contravariant, but it is covariant. @@ -68,9 +68,9 @@ Error: In this definition, a type variable has a variance that # type 'a t = T of ('a -> 'a) # type -'a s = 'b constraint 'a = 'b t # type +'a s = 'b constraint 'a = 'b q t -# Characters 5-38: +# Characters 0-38: type +'a s = 'b constraint 'a = 'b t q;; (* fail *) - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: In this definition, a type variable has a variance that cannot be deduced from the type parameters. It was expected to be unrestricted, but it is covariant. @@ -81,9 +81,9 @@ Error: In this definition, a type variable has a variance that method virtual add : 'a -> unit end # type +'a t = unit constraint 'a = 'b list -# Characters 4-27: +# Characters 0-27: type _ g = G : 'a -> 'a t g;; (* fail *) - ^^^^^^^^^^^^^^^^^^^^^^^ + ^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: In this definition, a type variable cannot be deduced from the type parameters. # diff --git a/testsuite/tests/typing-gadts/pr6158.ml.principal.reference b/testsuite/tests/typing-gadts/pr6158.ml.principal.reference index e7d5458744..7cf1ed1eeb 100644 --- a/testsuite/tests/typing-gadts/pr6158.ml.principal.reference +++ b/testsuite/tests/typing-gadts/pr6158.ml.principal.reference @@ -14,6 +14,6 @@ Error: This pattern matches values of type (int s, int s) eq ^^^^ Error: This pattern matches values of type (ex#0 S.s, ex#1 S.t) eq but a pattern was expected which matches values of type - (ex#0 S.s, ex#0 S.t) eq + ('a S.s, 'a S.t) eq The type constructor ex#0 would escape its scope # diff --git a/testsuite/tests/typing-gadts/pr6690.ml b/testsuite/tests/typing-gadts/pr6690.ml new file mode 100644 index 0000000000..46ece4b239 --- /dev/null +++ b/testsuite/tests/typing-gadts/pr6690.ml @@ -0,0 +1,28 @@ +type 'a visit_action + +type insert + +type 'a local_visit_action + +type ('a, 'result, 'visit_action) context = + | Local : ('a, ('a * insert) as 'result, 'a local_visit_action) context + | Global : ('a, 'a, 'a visit_action) context +;; + +let vexpr (type visit_action) : (_, _, visit_action) context -> _ -> visit_action = + function + | Local -> fun _ -> raise Exit + | Global -> fun _ -> raise Exit +;; + +let vexpr (type visit_action) : ('a, 'result, visit_action) context -> 'a -> visit_action = + function + | Local -> fun _ -> raise Exit + | Global -> fun _ -> raise Exit +;; + +let vexpr (type result) (type visit_action) : (unit, result, visit_action) context -> unit -> visit_action = + function + | Local -> fun _ -> raise Exit + | Global -> fun _ -> raise Exit +;; diff --git a/testsuite/tests/typing-gadts/pr6690.ml.principal.reference b/testsuite/tests/typing-gadts/pr6690.ml.principal.reference new file mode 100644 index 0000000000..2ff1624546 --- /dev/null +++ b/testsuite/tests/typing-gadts/pr6690.ml.principal.reference @@ -0,0 +1,23 @@ + +# type 'a visit_action +type insert +type 'a local_visit_action +type ('a, 'result, 'visit_action) context = + Local : ('a, 'a * insert, 'a local_visit_action) context + | Global : ('a, 'a, 'a visit_action) context +# Characters 133-139: + | Global -> fun _ -> raise Exit + ^^^^^^ +Error: This pattern matches values of type (ex#1, ex#1, visit_action) context + but a pattern was expected which matches values of type + (ex#0, ex#0 * insert, visit_action) context + Type ex#1 is not compatible with type ex#0 +# Characters 141-147: + | Global -> fun _ -> raise Exit + ^^^^^^ +Error: This pattern matches values of type (ex#3, ex#3, visit_action) context + but a pattern was expected which matches values of type + (ex#2, ex#2 * insert, visit_action) context + Type ex#3 is not compatible with type ex#2 +# val vexpr : (unit, 'a, 'b) context -> unit -> 'b = <fun> +# diff --git a/testsuite/tests/typing-gadts/pr6690.ml.reference b/testsuite/tests/typing-gadts/pr6690.ml.reference new file mode 100644 index 0000000000..fad5ad0ead --- /dev/null +++ b/testsuite/tests/typing-gadts/pr6690.ml.reference @@ -0,0 +1,25 @@ + +# type 'a visit_action +type insert +type 'a local_visit_action +type ('a, 'result, 'visit_action) context = + Local : ('a, 'a * insert, 'a local_visit_action) context + | Global : ('a, 'a, 'a visit_action) context +# Characters 11-162: + ..........(type visit_action) : (_, _, visit_action) context -> _ -> visit_action = + function + | Local -> fun _ -> raise Exit + | Global -> fun _ -> raise Exit +Error: This expression has type (ex#0, ex#0 * insert, 'a) context -> 'b -> 'a + but an expression was expected of type 'c + The type constructor ex#0 would escape its scope +# Characters 11-170: + ..........(type visit_action) : ('a, 'result, visit_action) context -> 'a -> visit_action = + function + | Local -> fun _ -> raise Exit + | Global -> fun _ -> raise Exit +Error: This expression has type (a#0, a#0 * insert, 'a) context -> a#0 -> 'a + but an expression was expected of type 'b + The type constructor a#0 would escape its scope +# val vexpr : (unit, 'a, 'b) context -> unit -> 'b = <fun> +# diff --git a/testsuite/tests/typing-gadts/pr6817.ml b/testsuite/tests/typing-gadts/pr6817.ml new file mode 100644 index 0000000000..73c1f6351e --- /dev/null +++ b/testsuite/tests/typing-gadts/pr6817.ml @@ -0,0 +1,24 @@ +module A = struct + type nil = Cstr + end +open A +;; + +type _ s = + | Nil : nil s + | Cons : 't s -> ('h -> 't) s + +type ('stack, 'typ) var = + | Head : (('typ -> _) s, 'typ) var + | Tail : ('tail s, 'typ) var -> ((_ -> 'tail) s, 'typ) var + +type _ lst = + | CNil : nil lst + | CCons : 'h * ('t lst) -> ('h -> 't) lst +;; + +let rec get_var : type stk ret. (stk s, ret) var -> stk lst -> ret = fun n s -> + match n, s with + | Head, CCons (h, _) -> h + | Tail n', CCons (_, t) -> get_var n' t +;; diff --git a/testsuite/tests/typing-gadts/pr6817.ml.reference b/testsuite/tests/typing-gadts/pr6817.ml.reference new file mode 100644 index 0000000000..ec47bcc99e --- /dev/null +++ b/testsuite/tests/typing-gadts/pr6817.ml.reference @@ -0,0 +1,9 @@ + +# module A : sig type nil = Cstr end +# type _ s = Nil : A.nil s | Cons : 't s -> ('h -> 't) s +type ('stack, 'typ) var = + Head : (('typ -> 'a) s, 'typ) var + | Tail : ('tail s, 'typ) var -> (('b -> 'tail) s, 'typ) var +type _ lst = CNil : A.nil lst | CCons : 'h * 't lst -> ('h -> 't) lst +# val get_var : ('stk s, 'ret) var -> 'stk lst -> 'ret = <fun> +# diff --git a/testsuite/tests/typing-gadts/test.ml b/testsuite/tests/typing-gadts/test.ml index 2f0bb91962..70b391f51c 100644 --- a/testsuite/tests/typing-gadts/test.ml +++ b/testsuite/tests/typing-gadts/test.ml @@ -91,6 +91,12 @@ module Exhaustive = end ;; +module PR6862 = struct + class c (Some x) = object method x : int = x end + type _ opt = Just : 'a -> 'a opt | Nothing : 'a opt + class d (Just x) = object method x : int = x end +end;; + module Existential_escape = struct type _ t = C : int -> int t @@ -157,6 +163,13 @@ module Normal_constrs = struct let f = function A -> 1 | B -> 2 end;; +module PR6849 = struct + type 'a t = Foo : int t + + let f : int -> int = function + Foo -> 5 +end;; + type _ t = Int : int t ;; let ky x y = ignore (x = y); x ;; @@ -337,7 +350,7 @@ let f : type a b. (a,b) eq -> < m : a; .. > -> < m : b > = let f : type a b. (a,b) eq -> [> `A of a] -> [> `A of b] = fun Eq o -> o ;; (* fail *) -let f (type a) (type b) (eq : (a,b) eq) (v : [> `A of a]) : [> `A of b] = +let f (type a b) (eq : (a,b) eq) (v : [> `A of a]) : [> `A of b] = match eq with Eq -> v ;; (* should fail *) let f : type a b. (a,b) eq -> [< `A of a | `B] -> [< `A of b | `B] = diff --git a/testsuite/tests/typing-gadts/test.ml.principal.reference b/testsuite/tests/typing-gadts/test.ml.principal.reference index fd9fb3501c..90a799a711 100644 --- a/testsuite/tests/typing-gadts/test.ml.principal.reference +++ b/testsuite/tests/typing-gadts/test.ml.principal.reference @@ -47,11 +47,29 @@ module Nonexhaustive : type 'a v = Foo : t -> t v | Bar : u -> u v val same_type : 's v * 's v -> bool end +# Characters 34-42: + class c (Some x) = object method x : int = x end + ^^^^^^^^ +Warning 8: this pattern-matching is not exhaustive. +Here is an example of a value that is not matched: +None +Characters 139-147: + class d (Just x) = object method x : int = x end + ^^^^^^^^ +Warning 8: this pattern-matching is not exhaustive. +Here is an example of a value that is not matched: +Nothing +module PR6862 : + sig + class c : int option -> object method x : int end + type _ opt = Just : 'a -> 'a opt | Nothing : 'a opt + class d : int opt -> object method x : int end + end # Characters 118-119: let eval (D x) = x ^ Error: This expression has type a#2 t but an expression was expected of type - a#2 t + 'a The type constructor a#2 would escape its scope # module Rectype : sig type (_, _) t = C : ('a, 'a) t val f : ('s, 's * 's) t -> unit end @@ -75,6 +93,11 @@ Error: This expression has type bool but an expression was expected of type s ^ Error: This pattern matches values of type b but a pattern was expected which matches values of type a +# Characters 89-92: + Foo -> 5 + ^^^ +Error: This pattern matches values of type 'a t + but a pattern was expected which matches values of type int # type _ t = Int : int t # val ky : 'a -> 'a -> 'a = <fun> # val test : 'a t -> 'a = <fun> @@ -83,21 +106,21 @@ Error: This pattern matches values of type b function Int -> ky (1 : a) 1 (* fails *) ^^^^^^^^^^^^ Error: This expression has type a = int - but an expression was expected of type a = int + but an expression was expected of type 'a This instance of int is ambiguous: it would escape the scope of its equation # Characters 70-82: let r = match x with Int -> ky (1 : a) 1 (* fails *) ^^^^^^^^^^^^ Error: This expression has type a = int - but an expression was expected of type a = int + but an expression was expected of type 'a This instance of int is ambiguous: it would escape the scope of its equation # Characters 69-81: let r = match x with Int -> ky 1 (1 : a) (* fails *) ^^^^^^^^^^^^ Error: This expression has type a = int - but an expression was expected of type a = int + but an expression was expected of type 'a This instance of int is ambiguous: it would escape the scope of its equation # val test : 'a t -> int = <fun> @@ -121,7 +144,7 @@ Error: This expression has type int option match v with Int -> let y = either 1 x in y ^ Error: This expression has type a = int - but an expression was expected of type a = int + but an expression was expected of type 'a This instance of int is ambiguous: it would escape the scope of its equation # val f : 'a t -> 'a -> 'a = <fun> @@ -192,7 +215,7 @@ Error: This expression has type [> `A of a ] Type a is not compatible with type b = a This instance of a is ambiguous: it would escape the scope of its equation -# Characters 97-98: +# Characters 90-91: match eq with Eq -> v ;; (* should fail *) ^ Error: This expression has type [> `A of a ] @@ -299,7 +322,7 @@ Error: This expression has type t = < foo : int; .. > # Characters 98-99: (x:<foo:int;bar:int;..>) ^ -Error: This expression has type < bar : int; foo : int; .. > as 'a +Error: This expression has type < bar : int; foo : int; .. > but an expression was expected of type 'a The type constructor ex#22 would escape its scope # val g : 'a -> 'a int_foo -> 'a int_bar -> 'a = <fun> diff --git a/testsuite/tests/typing-gadts/test.ml.reference b/testsuite/tests/typing-gadts/test.ml.reference index a5faa02c01..3308fd6a12 100644 --- a/testsuite/tests/typing-gadts/test.ml.reference +++ b/testsuite/tests/typing-gadts/test.ml.reference @@ -47,11 +47,29 @@ module Nonexhaustive : type 'a v = Foo : t -> t v | Bar : u -> u v val same_type : 's v * 's v -> bool end +# Characters 34-42: + class c (Some x) = object method x : int = x end + ^^^^^^^^ +Warning 8: this pattern-matching is not exhaustive. +Here is an example of a value that is not matched: +None +Characters 139-147: + class d (Just x) = object method x : int = x end + ^^^^^^^^ +Warning 8: this pattern-matching is not exhaustive. +Here is an example of a value that is not matched: +Nothing +module PR6862 : + sig + class c : int option -> object method x : int end + type _ opt = Just : 'a -> 'a opt | Nothing : 'a opt + class d : int opt -> object method x : int end + end # Characters 118-119: let eval (D x) = x ^ Error: This expression has type a#2 t but an expression was expected of type - a#2 t + 'a The type constructor a#2 would escape its scope # module Rectype : sig type (_, _) t = C : ('a, 'a) t val f : ('s, 's * 's) t -> unit end @@ -76,6 +94,11 @@ Error: This pattern matches values of type int t ^ Error: This variant pattern is expected to have type a The constructor B does not belong to type a +# Characters 89-92: + Foo -> 5 + ^^^ +Error: This pattern matches values of type 'a t + but a pattern was expected which matches values of type int # type _ t = Int : int t # val ky : 'a -> 'a -> 'a = <fun> # val test : 'a t -> 'a = <fun> @@ -84,21 +107,21 @@ Error: This variant pattern is expected to have type a function Int -> ky (1 : a) 1 (* fails *) ^^^^^^^^^^^^ Error: This expression has type a = int - but an expression was expected of type a = int + but an expression was expected of type 'a This instance of int is ambiguous: it would escape the scope of its equation # Characters 70-82: let r = match x with Int -> ky (1 : a) 1 (* fails *) ^^^^^^^^^^^^ Error: This expression has type a = int - but an expression was expected of type a = int + but an expression was expected of type 'a This instance of int is ambiguous: it would escape the scope of its equation # Characters 69-81: let r = match x with Int -> ky 1 (1 : a) (* fails *) ^^^^^^^^^^^^ Error: This expression has type a = int - but an expression was expected of type a = int + but an expression was expected of type 'a This instance of int is ambiguous: it would escape the scope of its equation # val test : 'a t -> int = <fun> @@ -122,7 +145,7 @@ Error: This expression has type int option match v with Int -> let y = either 1 x in y ^ Error: This expression has type a = int - but an expression was expected of type a = int + but an expression was expected of type 'a This instance of int is ambiguous: it would escape the scope of its equation # val f : 'a t -> 'a -> 'a = <fun> @@ -186,7 +209,7 @@ Error: This expression has type [> `A of a ] Type a is not compatible with type b = a This instance of a is ambiguous: it would escape the scope of its equation -# Characters 97-98: +# Characters 90-91: match eq with Eq -> v ;; (* should fail *) ^ Error: This expression has type [> `A of a ] @@ -286,7 +309,7 @@ Error: This expression has type t = < foo : int; .. > # Characters 98-99: (x:<foo:int;bar:int;..>) ^ -Error: This expression has type < bar : int; foo : int; .. > as 'a +Error: This expression has type < bar : int; foo : int; .. > but an expression was expected of type 'a The type constructor ex#22 would escape its scope # val g : 'a -> 'a int_foo -> 'a int_bar -> 'a = <fun> diff --git a/testsuite/tests/typing-gadts/yallop_bugs.ml b/testsuite/tests/typing-gadts/yallop_bugs.ml index 08708a67cc..983822bcc8 100644 --- a/testsuite/tests/typing-gadts/yallop_bugs.ml +++ b/testsuite/tests/typing-gadts/yallop_bugs.ml @@ -3,7 +3,7 @@ type (_, _) eq = Refl : ('a, 'a) eq let magic : 'a 'b. 'a -> 'b = - fun (type a) (type b) (x : a) -> + fun (type a b) (x : a) -> let module M = (functor (T : sig type 'a t end) -> struct diff --git a/testsuite/tests/typing-gadts/yallop_bugs.ml.principal.reference b/testsuite/tests/typing-gadts/yallop_bugs.ml.principal.reference index ddae4d248e..accbebf428 100644 --- a/testsuite/tests/typing-gadts/yallop_bugs.ml.principal.reference +++ b/testsuite/tests/typing-gadts/yallop_bugs.ml.principal.reference @@ -1,11 +1,11 @@ -# Characters 240-248: +# Characters 233-241: let f (Refl : (a T.t, b T.t) eq) = (x :> b) ^^^^^^^^ Error: Type a is not a subtype of b -# Characters 36-67: +# Characters 31-67: type (_, +_) eq = Refl : ('a, 'a) eq - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: In this GADT definition, the variance of some parameter cannot be checked # Characters 115-175: diff --git a/testsuite/tests/typing-gadts/yallop_bugs.ml.reference b/testsuite/tests/typing-gadts/yallop_bugs.ml.reference index ddae4d248e..accbebf428 100644 --- a/testsuite/tests/typing-gadts/yallop_bugs.ml.reference +++ b/testsuite/tests/typing-gadts/yallop_bugs.ml.reference @@ -1,11 +1,11 @@ -# Characters 240-248: +# Characters 233-241: let f (Refl : (a T.t, b T.t) eq) = (x :> b) ^^^^^^^^ Error: Type a is not a subtype of b -# Characters 36-67: +# Characters 31-67: type (_, +_) eq = Refl : ('a, 'a) eq - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: In this GADT definition, the variance of some parameter cannot be checked # Characters 115-175: diff --git a/testsuite/tests/typing-misc/constraints.ml.reference b/testsuite/tests/typing-misc/constraints.ml.reference index 83a3dc1f99..41a324c69a 100644 --- a/testsuite/tests/typing-misc/constraints.ml.reference +++ b/testsuite/tests/typing-misc/constraints.ml.reference @@ -7,16 +7,16 @@ Error: Constraints are not satisfied in this type. [ `A of 'a ] t t as 'a should be an instance of ([ `A of 'b t t ] as 'b) t -# Characters 5-27: +# Characters 1-27: type 'a t = [`A of 'a t t];; (* fails *) - ^^^^^^^^^^^^^^^^^^^^^^ + ^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: In the definition of t, type 'a t t should be 'a t # type 'a t = [ `A of 'a t t ] constraint 'a = 'a t # type 'a t = [ `A of 'a t ] constraint 'a = 'a t # type 'a t = 'a constraint 'a = [ `A of 'a ] -# Characters 47-52: +# Characters 43-52: type 'a v = [`A of u v] constraint 'a = t and t = u and u = t;; (* fails *) - ^^^^^ + ^^^^^^^^^ Error: The type abbreviation t is cyclic # type 'a t = 'a # Characters 11-21: @@ -26,9 +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: +# Characters 80-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/polyvars.ml b/testsuite/tests/typing-misc/polyvars.ml index 00dacf7540..de8cb221bb 100644 --- a/testsuite/tests/typing-misc/polyvars.ml +++ b/testsuite/tests/typing-misc/polyvars.ml @@ -5,3 +5,11 @@ let f x = ignore (match x with `A|`B -> 1); ignore (x : [`A]);; let f (x : [< `A | `B]) = match x with `A | `B | `C -> 0;; (* warn *) let f (x : [`A | `B]) = match x with `A | `B | `C -> 0;; (* fail *) + +(* PR#6787 *) +let revapply x f = f x;; + +let f x (g : [< `Foo]) = + let y = `Bar x, g in + revapply y (fun ((`Bar i), _) -> i);; +(* f : 'a -> [< `Foo ] -> 'a *) diff --git a/testsuite/tests/typing-misc/polyvars.ml.principal.reference b/testsuite/tests/typing-misc/polyvars.ml.principal.reference index bc0741abb6..6732640e9f 100644 --- a/testsuite/tests/typing-misc/polyvars.ml.principal.reference +++ b/testsuite/tests/typing-misc/polyvars.ml.principal.reference @@ -29,4 +29,6 @@ val f : [< `A | `B ] -> int = <fun> Error: This pattern matches values of type [? `C ] but a pattern was expected which matches values of type [ `A | `B ] The second variant type does not allow tag(s) `C -# +# val revapply : 'a -> ('a -> 'b) -> 'b = <fun> +# val f : 'a -> [< `Foo ] -> 'a = <fun> +# diff --git a/testsuite/tests/typing-misc/polyvars.ml.reference b/testsuite/tests/typing-misc/polyvars.ml.reference index 27c4cd4304..751b02fc07 100644 --- a/testsuite/tests/typing-misc/polyvars.ml.reference +++ b/testsuite/tests/typing-misc/polyvars.ml.reference @@ -29,4 +29,6 @@ val f : [< `A | `B ] -> int = <fun> Error: This pattern matches values of type [? `C ] but a pattern was expected which matches values of type [ `A | `B ] The second variant type does not allow tag(s) `C -# +# val revapply : 'a -> ('a -> 'b) -> 'b = <fun> +# val f : 'a -> [< `Foo ] -> 'a = <fun> +# diff --git a/testsuite/tests/typing-misc/wellfounded.ml b/testsuite/tests/typing-misc/wellfounded.ml new file mode 100644 index 0000000000..b33adc5e17 --- /dev/null +++ b/testsuite/tests/typing-misc/wellfounded.ml @@ -0,0 +1,11 @@ +(* PR#6768 *) + +type _ prod = Prod : ('a * 'y) prod;; + +let f : type t. t prod -> _ = function Prod -> + let module M = + struct + type d = d * d + end + in () +;; diff --git a/testsuite/tests/typing-misc/wellfounded.ml.principal.reference b/testsuite/tests/typing-misc/wellfounded.ml.principal.reference new file mode 100644 index 0000000000..04bf5586bb --- /dev/null +++ b/testsuite/tests/typing-misc/wellfounded.ml.principal.reference @@ -0,0 +1,7 @@ + +# type _ prod = Prod : ('a * 'y) prod +# Characters 82-96: + type d = d * d + ^^^^^^^^^^^^^^ +Error: The type abbreviation d is cyclic +# diff --git a/testsuite/tests/typing-misc/wellfounded.ml.reference b/testsuite/tests/typing-misc/wellfounded.ml.reference new file mode 100644 index 0000000000..04bf5586bb --- /dev/null +++ b/testsuite/tests/typing-misc/wellfounded.ml.reference @@ -0,0 +1,7 @@ + +# type _ prod = Prod : ('a * 'y) prod +# Characters 82-96: + type d = d * d + ^^^^^^^^^^^^^^ +Error: The type abbreviation d is cyclic +# diff --git a/testsuite/tests/typing-modules-bugs/pr51_ok.ml b/testsuite/tests/typing-modules-bugs/pr51_ok.ml new file mode 100644 index 0000000000..d833ef5483 --- /dev/null +++ b/testsuite/tests/typing-modules-bugs/pr51_ok.ml @@ -0,0 +1,13 @@ +module X=struct + module type SIG=sig type t=int val x:t end + module F(Y:SIG) : SIG = struct type t=Y.t let x=Y.x end +end;; +module DUMMY=struct type t=int let x=2 end;; +let x = (3 : X.F(DUMMY).t);; + +module X2=struct + module type SIG=sig type t=int val x:t end + module F(Y:SIG)(Z:SIG) = struct type t=Y.t let x=Y.x type t'=Z.t let x'=Z.x end +end;; +let x = (3 : X2.F(DUMMY)(DUMMY).t);; +let x = (3 : X2.F(DUMMY)(DUMMY).t');; diff --git a/testsuite/tests/typing-modules-bugs/pr5663_ok.ml b/testsuite/tests/typing-modules-bugs/pr5663_ok.ml new file mode 100644 index 0000000000..ce791f9075 --- /dev/null +++ b/testsuite/tests/typing-modules-bugs/pr5663_ok.ml @@ -0,0 +1,7 @@ +module F (M : sig + type 'a t + type 'a u = string + val f : unit -> _ u t + end) = struct + let t = M.f () + end diff --git a/testsuite/tests/typing-modules-bugs/pr6651_ok.ml b/testsuite/tests/typing-modules-bugs/pr6651_ok.ml new file mode 100644 index 0000000000..9c43005149 --- /dev/null +++ b/testsuite/tests/typing-modules-bugs/pr6651_ok.ml @@ -0,0 +1,13 @@ +module type S = sig + module type T + module X : T +end + +module F (X : S) = X.X + +module M = struct + module type T = sig type t end + module X = struct type t = int end +end + +type t = F(M).t diff --git a/testsuite/tests/typing-modules-bugs/pr6752_ok.ml b/testsuite/tests/typing-modules-bugs/pr6752_ok.ml new file mode 100644 index 0000000000..846af0d178 --- /dev/null +++ b/testsuite/tests/typing-modules-bugs/pr6752_ok.ml @@ -0,0 +1,43 @@ +module Common0 = + struct + type msg = Msg + + let handle_msg = ref (function _ -> failwith "Unable to handle message") + let extend_handle f = + let old = !handle_msg in + handle_msg := f old + + let q : _ Queue.t = Queue.create () + let add msg = Queue.add msg q + let handle_queue_messages () = Queue.iter !handle_msg q + end + +let q' : Common0.msg Queue.t = Common0.q + +module Common = + struct + type msg = .. + + let handle_msg = ref (function _ -> failwith "Unable to handle message") + let extend_handle f = + let old = !handle_msg in + handle_msg := f old + + let q : _ Queue.t = Queue.create () + let add msg = Queue.add msg q + let handle_queue_messages () = Queue.iter !handle_msg q + end + +module M1 = + struct + type Common.msg += Reload of string | Alert of string + + let handle fallback = function + Reload s -> print_endline ("Reload "^s) + | Alert s -> print_endline ("Alert "^s) + | x -> fallback x + + let () = Common.extend_handle handle + let () = Common.add (Reload "config.file") + let () = Common.add (Alert "Initialisation done") + end diff --git a/testsuite/tests/typing-modules-bugs/pr6899_first_bad.ml b/testsuite/tests/typing-modules-bugs/pr6899_first_bad.ml new file mode 100644 index 0000000000..07435e11c5 --- /dev/null +++ b/testsuite/tests/typing-modules-bugs/pr6899_first_bad.ml @@ -0,0 +1,3 @@ +let should_reject = + let table = Hashtbl.create 1 in + fun x y -> Hashtbl.add table x y diff --git a/testsuite/tests/typing-modules-bugs/pr6899_ok.ml b/testsuite/tests/typing-modules-bugs/pr6899_ok.ml new file mode 100644 index 0000000000..e049534ded --- /dev/null +++ b/testsuite/tests/typing-modules-bugs/pr6899_ok.ml @@ -0,0 +1,6 @@ +type 'a t = 'a option +let is_some = function + | None -> false + | Some _ -> true + +let should_accept ?x () = is_some x diff --git a/testsuite/tests/typing-modules-bugs/pr6899_second_bad.ml b/testsuite/tests/typing-modules-bugs/pr6899_second_bad.ml new file mode 100644 index 0000000000..4d49fe1e70 --- /dev/null +++ b/testsuite/tests/typing-modules-bugs/pr6899_second_bad.ml @@ -0,0 +1,5 @@ +include struct + let foo `Test = () + let wrap f `Test = f + let bar = wrap () +end diff --git a/testsuite/tests/typing-modules/Makefile b/testsuite/tests/typing-modules/Makefile index 02fc5fb0ba..c9433b2ecb 100644 --- a/testsuite/tests/typing-modules/Makefile +++ b/testsuite/tests/typing-modules/Makefile @@ -10,5 +10,6 @@ # # ######################################################################### -include ../../makefiles/Makefile.toplevel -include ../../makefiles/Makefile.common +BASEDIR=../.. +include $(BASEDIR)/makefiles/Makefile.toplevel +include $(BASEDIR)/makefiles/Makefile.common diff --git a/testsuite/tests/typing-modules/aliases.ml.reference b/testsuite/tests/typing-modules/aliases.ml.reference index db35fa5e86..724f01389c 100644 --- a/testsuite/tests/typing-modules/aliases.ml.reference +++ b/testsuite/tests/typing-modules/aliases.ml.reference @@ -8,8 +8,11 @@ val escaped : char -> string val lowercase : char -> char val uppercase : char -> char + val lowercase_ascii : char -> char + val uppercase_ascii : char -> char type t = char val compare : t -> t -> int + val equal : t -> t -> bool external unsafe_chr : int -> char = "%identity" end # - : char = 'B' @@ -20,8 +23,11 @@ val escaped : char -> string val lowercase : char -> char val uppercase : char -> char + val lowercase_ascii : char -> char + val uppercase_ascii : char -> char type t = char val compare : t -> t -> int + val equal : t -> t -> bool external unsafe_chr : int -> char = "%identity" end # - : char = 'B' @@ -35,8 +41,11 @@ val escaped : char -> string val lowercase : char -> char val uppercase : char -> char + val lowercase_ascii : char -> char + val uppercase_ascii : char -> char type t = char val compare : t -> t -> int + val equal : t -> t -> bool external unsafe_chr : int -> char = "%identity" end # module C4 : @@ -46,8 +55,11 @@ val escaped : char -> string val lowercase : char -> char val uppercase : char -> char + val lowercase_ascii : char -> char + val uppercase_ascii : char -> char type t = char val compare : t -> t -> int + val equal : t -> t -> bool external unsafe_chr : int -> char = "%identity" end # - : char = 'B' diff --git a/testsuite/tests/typing-modules/printing.ml b/testsuite/tests/typing-modules/printing.ml new file mode 100644 index 0000000000..77dd8c70ee --- /dev/null +++ b/testsuite/tests/typing-modules/printing.ml @@ -0,0 +1,14 @@ +(* PR#6650 *) + +module type S = sig + class type c = object method m : int end + module M : sig + class type d = c + end +end;; +module F (X : S) = X.M;; + +(* PR#6648 *) + +module M = struct module N = struct let x = 1 end end;; +#show_module M;; diff --git a/testsuite/tests/typing-modules/printing.ml.reference b/testsuite/tests/typing-modules/printing.ml.reference new file mode 100644 index 0000000000..c5a9a773db --- /dev/null +++ b/testsuite/tests/typing-modules/printing.ml.reference @@ -0,0 +1,10 @@ + +# module type S = + sig + class type c = object method m : int end + module M : sig class type d = c end + end +# module F : functor (X : S) -> sig class type d = X.c end +# module M : sig module N : sig val x : int end end +# module M : sig module N : sig ... end end +# diff --git a/testsuite/tests/typing-objects/Exemples.ml.principal.reference b/testsuite/tests/typing-objects/Exemples.ml.principal.reference index 2b12a7d9b7..f0f3812ea3 100644 --- a/testsuite/tests/typing-objects/Exemples.ml.principal.reference +++ b/testsuite/tests/typing-objects/Exemples.ml.principal.reference @@ -24,8 +24,8 @@ # val get_x : < get_x : 'a; .. > -> 'a = <fun> # val set_x : < set_x : 'a; .. > -> 'a = <fun> # - : int list = [10; 5] -# Characters 7-96: - ......ref x_init = object +# Characters 1-96: + class ref x_init = object val mutable x = x_init method get = x method set y = x <- y diff --git a/testsuite/tests/typing-objects/Exemples.ml.reference b/testsuite/tests/typing-objects/Exemples.ml.reference index 7cbd68ec29..085a9e92ec 100644 --- a/testsuite/tests/typing-objects/Exemples.ml.reference +++ b/testsuite/tests/typing-objects/Exemples.ml.reference @@ -24,8 +24,8 @@ # val get_x : < get_x : 'a; .. > -> 'a = <fun> # val set_x : < set_x : 'a; .. > -> 'a = <fun> # - : int list = [10; 5] -# Characters 7-96: - ......ref x_init = object +# Characters 1-96: + class ref x_init = object val mutable x = x_init method get = x method set y = x <- y diff --git a/testsuite/tests/typing-objects/Tests.ml.principal.reference b/testsuite/tests/typing-objects/Tests.ml.principal.reference index e5d9bb8d59..6c9449441e 100644 --- a/testsuite/tests/typing-objects/Tests.ml.principal.reference +++ b/testsuite/tests/typing-objects/Tests.ml.principal.reference @@ -4,8 +4,8 @@ = <fun> # class ['a] c : unit -> object constraint 'a = int method f : int c end and ['a] d : unit -> object constraint 'a = int method f : int c end -# Characters 238-275: - ........d () = object +# Characters 234-275: + ....and d () = object inherit ['a] c () end.. Error: Some type variables are unbound in this type: @@ -19,8 +19,8 @@ and ['a] d : unit -> object constraint 'a = int #c end # * class ['a] c : 'a -> object ('a) constraint 'a = < f : 'a; .. > method f : 'a end # - : ('a c as 'a) -> 'a = <fun> -# * Characters 134-176: - ......x () = object +# * Characters 128-176: + class x () = object method virtual f : int end.. Error: This class should be virtual. The following methods are undefined : f @@ -29,8 +29,8 @@ Error: This class should be virtual. The following methods are undefined : f ^^^^^^^^ Error: This pattern cannot match self: it only matches values of type < f : int > -# Characters 38-110: - ......['a] c () = object +# Characters 32-110: + class ['a] c () = object constraint 'a = int method f x = (x : bool c) end.. @@ -51,17 +51,17 @@ Error: The abbreviation c is used with parameters bool c method f : 'a -> 'b -> unit end # val x : '_a list ref = {contents = []} -# Characters 6-50: - ......['a] c () = object +# Characters 0-50: + class ['a] c () = object method f = (x : 'a) end.. Error: The type of this class, class ['a] c : unit -> object constraint 'a = '_b list ref method f : 'a end, contains type variables that cannot be generalized -# Characters 24-52: +# Characters 20-52: type 'a c = <f : 'a c; g : 'a d> - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: In the definition of d, type int c should be 'a c # type 'a c = < f : 'a c; g : 'a d > and 'a d = < f : 'a c > @@ -69,14 +69,14 @@ and 'a d = < f : 'a c > and 'a d = < f : int c > # type 'a u = < x : 'a > and 'a t = 'a t u -# Characters 18-32: +# Characters 15-32: and 'a t = 'a t u;; - ^^^^^^^^^^^^^^ + ^^^^^^^^^^^^^^^^^ Error: The type abbreviation t is cyclic # type 'a u = 'a -# Characters 5-18: +# Characters 0-18: type t = t u * t u;; - ^^^^^^^^^^^^^ + ^^^^^^^^^^^^^^^^^^ Error: The type abbreviation t is cyclic # type t = < x : 'a > as 'a # type 'a u = 'a @@ -217,8 +217,8 @@ 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-154: - ......virtual ['a] matrix (sz, init : int * 'a) = object +# Characters 1-154: + class virtual ['a] matrix (sz, init : int * 'a) = object val m = Array.make_matrix sz sz init method add (mtx : 'a matrix) = (mtx#m.(0).(0) : 'a) end.. diff --git a/testsuite/tests/typing-objects/Tests.ml.reference b/testsuite/tests/typing-objects/Tests.ml.reference index ed4df922d4..6c9449441e 100644 --- a/testsuite/tests/typing-objects/Tests.ml.reference +++ b/testsuite/tests/typing-objects/Tests.ml.reference @@ -2,10 +2,10 @@ # - : < x : int > -> < x : int > -> < x : int > -> < x : int > * < x : int > * < x : int > = <fun> -# class ['a] c : unit -> object constraint 'a = int method f : 'a c end -and ['a] d : unit -> object constraint 'a = int method f : 'a c end -# Characters 238-275: - ........d () = object +# class ['a] c : unit -> object constraint 'a = int method f : int c end +and ['a] d : unit -> object constraint 'a = int method f : int c end +# Characters 234-275: + ....and d () = object inherit ['a] c () end.. Error: Some type variables are unbound in this type: @@ -19,8 +19,8 @@ and ['a] d : unit -> object constraint 'a = int #c end # * class ['a] c : 'a -> object ('a) constraint 'a = < f : 'a; .. > method f : 'a end # - : ('a c as 'a) -> 'a = <fun> -# * Characters 134-176: - ......x () = object +# * Characters 128-176: + class x () = object method virtual f : int end.. Error: This class should be virtual. The following methods are undefined : f @@ -29,8 +29,8 @@ Error: This class should be virtual. The following methods are undefined : f ^^^^^^^^ Error: This pattern cannot match self: it only matches values of type < f : int > -# Characters 38-110: - ......['a] c () = object +# Characters 32-110: + class ['a] c () = object constraint 'a = int method f x = (x : bool c) end.. @@ -51,17 +51,17 @@ Error: The abbreviation c is used with parameters bool c method f : 'a -> 'b -> unit end # val x : '_a list ref = {contents = []} -# Characters 6-50: - ......['a] c () = object +# Characters 0-50: + class ['a] c () = object method f = (x : 'a) end.. Error: The type of this class, class ['a] c : unit -> object constraint 'a = '_b list ref method f : 'a end, contains type variables that cannot be generalized -# Characters 24-52: +# Characters 20-52: type 'a c = <f : 'a c; g : 'a d> - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: In the definition of d, type int c should be 'a c # type 'a c = < f : 'a c; g : 'a d > and 'a d = < f : 'a c > @@ -69,14 +69,14 @@ and 'a d = < f : 'a c > and 'a d = < f : int c > # type 'a u = < x : 'a > and 'a t = 'a t u -# Characters 18-32: +# Characters 15-32: and 'a t = 'a t u;; - ^^^^^^^^^^^^^^ + ^^^^^^^^^^^^^^^^^ Error: The type abbreviation t is cyclic # type 'a u = 'a -# Characters 5-18: +# Characters 0-18: type t = t u * t u;; - ^^^^^^^^^^^^^ + ^^^^^^^^^^^^^^^^^^ Error: The type abbreviation t is cyclic # type t = < x : 'a > as 'a # type 'a u = 'a @@ -217,8 +217,8 @@ 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-154: - ......virtual ['a] matrix (sz, init : int * 'a) = object +# Characters 1-154: + class virtual ['a] matrix (sz, init : int * 'a) = object val m = Array.make_matrix sz sz init method add (mtx : 'a matrix) = (mtx#m.(0).(0) : 'a) end.. @@ -285,7 +285,8 @@ Error: This expression has type 'a t but an expression was expected of type Warning 10: this expression should have type unit. - : ('a t as 'a) t -> unit = <fun> # class ['a] c : - unit -> object constraint 'a = (< .. > as 'b) -> unit method m : 'a end + unit -> + object constraint 'a = (< .. > as 'b) -> unit method m : 'b -> unit end # class ['a] c : unit -> object constraint 'a = unit -> (< .. > as 'b) method m : 'a -> 'b end diff --git a/testsuite/tests/typing-objects/pr5545.ml b/testsuite/tests/typing-objects/pr5545.ml new file mode 100644 index 0000000000..1273e6f0b1 --- /dev/null +++ b/testsuite/tests/typing-objects/pr5545.ml @@ -0,0 +1,22 @@ +type foo = int;; + +class o = + object(this) + method x : foo = 10 + method y : int = this # x + end;; + + +class o = + object(this) + method x : foo = 10 + method y = (this # x : int) + end;; + + + +class o = + object(this) + method x : int = (10 : int) + method y = (this # x : foo) + end;; diff --git a/testsuite/tests/typing-objects/pr5545.ml.principal.reference b/testsuite/tests/typing-objects/pr5545.ml.principal.reference new file mode 100644 index 0000000000..4f7fda9661 --- /dev/null +++ b/testsuite/tests/typing-objects/pr5545.ml.principal.reference @@ -0,0 +1,6 @@ + +# type foo = int +# class o : object method x : foo method y : int end +# class o : object method x : foo method y : int end +# class o : object method x : int method y : foo end +# diff --git a/testsuite/tests/typing-objects/pr5545.ml.reference b/testsuite/tests/typing-objects/pr5545.ml.reference new file mode 100644 index 0000000000..4f7fda9661 --- /dev/null +++ b/testsuite/tests/typing-objects/pr5545.ml.reference @@ -0,0 +1,6 @@ + +# type foo = int +# class o : object method x : foo method y : int end +# class o : object method x : foo method y : int end +# class o : object method x : int method y : foo end +# diff --git a/testsuite/tests/typing-objects/pr6123_bad.ml.principal.reference b/testsuite/tests/typing-objects/pr6123_bad.ml.principal.reference index a7e48182e3..eb3b05c083 100644 --- a/testsuite/tests/typing-objects/pr6123_bad.ml.principal.reference +++ b/testsuite/tests/typing-objects/pr6123_bad.ml.principal.reference @@ -2,7 +2,7 @@ # Characters 253-257: let args = List.map (fun ty -> new argument(self, ty)) args_ty in ^^^^ -Error: This expression has type < arguments : 'b; .. > as 'a - but an expression was expected of type 'a +Error: This expression has type < arguments : 'a; .. > + but an expression was expected of type 'b Self type cannot escape its class # diff --git a/testsuite/tests/typing-objects/pr6123_bad.ml.reference b/testsuite/tests/typing-objects/pr6123_bad.ml.reference index a7e48182e3..eb3b05c083 100644 --- a/testsuite/tests/typing-objects/pr6123_bad.ml.reference +++ b/testsuite/tests/typing-objects/pr6123_bad.ml.reference @@ -2,7 +2,7 @@ # Characters 253-257: let args = List.map (fun ty -> new argument(self, ty)) args_ty in ^^^^ -Error: This expression has type < arguments : 'b; .. > as 'a - but an expression was expected of type 'a +Error: This expression has type < arguments : 'a; .. > + but an expression was expected of type 'b Self type cannot escape its class # diff --git a/testsuite/tests/typing-poly/poly.ml b/testsuite/tests/typing-poly/poly.ml index 36dc76a43a..e1ada4924c 100644 --- a/testsuite/tests/typing-poly/poly.ml +++ b/testsuite/tests/typing-poly/poly.ml @@ -667,3 +667,23 @@ let using_match b = match (fun x -> x), fun x -> x with x, y -> x, y;; match fun x -> x with x -> x, x;; + +(* PR#6747 *) +(* ok *) +let n = object + method m : 'x 'o. ([< `Foo of 'x] as 'o) -> 'x = fun x -> assert false +end;; +(* ok, but not with -principal *) +let n = + object method m : 'x. [< `Foo of 'x] -> 'x = fun x -> assert false end;; +(* fail *) +let (n : < m : 'a. [< `Foo of int] -> 'a >) = + object method m : 'x. [< `Foo of 'x] -> 'x = fun x -> assert false end;; +(* fail *) +let (n : 'b -> < m : 'a . ([< `Foo of int] as 'b) -> 'a >) = fun x -> + object method m : 'x. [< `Foo of 'x] -> 'x = fun x -> assert false end;; + +(* PR#6171 *) +let f b (x: 'x) = + let module M = struct type t = A end in + if b then x else M.A;; diff --git a/testsuite/tests/typing-poly/poly.ml.principal.reference b/testsuite/tests/typing-poly/poly.ml.principal.reference index 53acb415ba..26cdd596cc 100644 --- a/testsuite/tests/typing-poly/poly.ml.principal.reference +++ b/testsuite/tests/typing-poly/poly.ml.principal.reference @@ -74,7 +74,11 @@ method empty : bool method fold : f:('a -> 'c -> 'c) -> init:'c -> 'c end -# class ['a] ostream1 : +# Characters 166-178: + self#tl#fold ~f ~init:(f self#hd init) + ^^^^^^^^^^^^ +Warning 18: this use of a polymorphic method is not principal. +class ['a] ostream1 : hd:'a -> tl:'b -> object ('b) @@ -169,9 +173,9 @@ val f4 : id -> int * bool = <fun> # class c : object method m : #id -> int * bool end # class id2 : object method id : 'a -> 'a method mono : int -> int end # val app : int * bool = (1, true) -# Characters 4-25: +# Characters 0-25: type 'a foo = 'a foo list - ^^^^^^^^^^^^^^^^^^^^^ + ^^^^^^^^^^^^^^^^^^^^^^^^^ Error: The type abbreviation foo is cyclic # class ['a] bar : 'a -> object end # type 'a foo = 'a foo bar @@ -271,9 +275,9 @@ Error: The universal type variable 'a cannot be generalized: type 'b alist = < visit : 'a. ('a, 'b) list_visitor -> 'a > class type ct = object ('a) method fold : ('b -> 'a -> 'b) -> 'b -> 'b end type t = { f : 'a 'b. ('b -> (#ct as 'a) -> 'b) -> 'b; } -# Characters 20-25: +# Characters 15-25: type t = u and u = t;; - ^^^^^ + ^^^^^^^^^^ Error: The type abbreviation t is cyclic # class ['a] a : object constraint 'a = [> `A of 'a a ] end type t = [ `A of t a ] @@ -301,9 +305,9 @@ Error: Constraints are not satisfied in this type. Type 'a u t should be an instance of g t # type 'a u = 'a constraint 'a = g and 'a v = 'a u t constraint 'a = g -# Characters 38-58: +# Characters 34-58: type 'a u = < m : 'a v > and 'a v = 'a list u;; - ^^^^^^^^^^^^^^^^^^^^ + ^^^^^^^^^^^^^^^^^^^^^^^^ Error: In the definition of v, type 'a list u should be 'a u # type 'a t = 'a type 'a u = A of 'a t @@ -346,9 +350,9 @@ Characters 21-24: ^^^ Warning 11: this match case is unused. - : int * [< `B ] -> int = <fun> -# Characters 69-135: +# Characters 64-135: type ('a, 'b) a = 'a -> unit constraint 'a = [> `B of ('a, 'b) b as 'b] - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: Constraints are not satisfied in this type. Type ([> `B of 'a ], 'a) b as 'a @@ -640,11 +644,32 @@ Error: This field value has type unit -> unit which is less general than # Exception: Pervasives.Exit. # Exception: Pervasives.Exit. # Exception: Pervasives.Exit. -# Characters 20-44: +# Characters 16-44: type 'x t = < f : 'y. 'y t >;; - ^^^^^^^^^^^^^^^^^^^^^^^^ + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: In the definition of t, type 'y t should be 'x t # val using_match : bool -> int * ('a -> 'a) = <fun> # - : ('a -> 'a) * ('b -> 'b) = (<fun>, <fun>) # - : ('a -> 'a) * ('b -> 'b) = (<fun>, <fun>) +# val n : < m : 'x 'a. ([< `Foo of 'x ] as 'a) -> 'x > = <obj> +# Characters 90-111: + object method m : 'x. [< `Foo of 'x] -> 'x = fun x -> assert false end;; + ^^^^^^^^^^^^^^^^^^^^^ +Error: This method has type ([< `Foo of 'b ] as 'a) -> 'b + which is less general than 'x. 'a -> 'x +# Characters 105-126: + object method m : 'x. [< `Foo of 'x] -> 'x = fun x -> assert false end;; + ^^^^^^^^^^^^^^^^^^^^^ +Error: This method has type ([< `Foo of 'b ] as 'a) -> 'b + which is less general than 'x. 'a -> 'x +# Characters 128-149: + object method m : 'x. [< `Foo of 'x] -> 'x = fun x -> assert false end;; + ^^^^^^^^^^^^^^^^^^^^^ +Error: This method has type ([< `Foo of 'b ] as 'a) -> 'b + which is less general than 'x. 'a -> 'x +# Characters 95-98: + if b then x else M.A;; + ^^^ +Error: This expression has type M.t but an expression was expected of type 'x + The type constructor M.t would escape its scope # diff --git a/testsuite/tests/typing-poly/poly.ml.reference b/testsuite/tests/typing-poly/poly.ml.reference index 9929020d54..25e938e8ee 100644 --- a/testsuite/tests/typing-poly/poly.ml.reference +++ b/testsuite/tests/typing-poly/poly.ml.reference @@ -161,9 +161,9 @@ Error: This expression has type bool but an expression was expected of type # class c : object method m : #id -> int * bool end # class id2 : object method id : 'a -> 'a method mono : int -> int end # val app : int * bool = (1, true) -# Characters 4-25: +# Characters 0-25: type 'a foo = 'a foo list - ^^^^^^^^^^^^^^^^^^^^^ + ^^^^^^^^^^^^^^^^^^^^^^^^^ Error: The type abbreviation foo is cyclic # class ['a] bar : 'a -> object end # type 'a foo = 'a foo bar @@ -254,9 +254,9 @@ Error: The universal type variable 'a cannot be generalized: type 'b alist = < visit : 'a. ('a, 'b) list_visitor -> 'a > class type ct = object ('a) method fold : ('b -> 'a -> 'b) -> 'b -> 'b end type t = { f : 'a 'b. ('b -> (#ct as 'a) -> 'b) -> 'b; } -# Characters 20-25: +# Characters 15-25: type t = u and u = t;; - ^^^^^ + ^^^^^^^^^^ Error: The type abbreviation t is cyclic # class ['a] a : object constraint 'a = [> `A of 'a a ] end type t = [ `A of t a ] @@ -284,9 +284,9 @@ Error: Constraints are not satisfied in this type. Type 'a u t should be an instance of g t # type 'a u = 'a constraint 'a = g and 'a v = 'a u t constraint 'a = g -# Characters 38-58: +# Characters 34-58: type 'a u = < m : 'a v > and 'a v = 'a list u;; - ^^^^^^^^^^^^^^^^^^^^ + ^^^^^^^^^^^^^^^^^^^^^^^^ Error: In the definition of v, type 'a list u should be 'a u # type 'a t = 'a type 'a u = A of 'a t @@ -329,9 +329,9 @@ Characters 21-24: ^^^ Warning 11: this match case is unused. - : int * [< `B ] -> int = <fun> -# Characters 69-135: +# Characters 64-135: type ('a, 'b) a = 'a -> unit constraint 'a = [> `B of ('a, 'b) b as 'b] - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: Constraints are not satisfied in this type. Type ([> `B of 'a ], 'a) b as 'a @@ -598,11 +598,32 @@ Error: This field value has type unit -> unit which is less general than # Exception: Pervasives.Exit. # Exception: Pervasives.Exit. # Exception: Pervasives.Exit. -# Characters 20-44: +# Characters 16-44: type 'x t = < f : 'y. 'y t >;; - ^^^^^^^^^^^^^^^^^^^^^^^^ + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: In the definition of t, type 'y t should be 'x t # val using_match : bool -> int * ('a -> 'a) = <fun> # - : ('a -> 'a) * ('b -> 'b) = (<fun>, <fun>) # - : ('a -> 'a) * ('b -> 'b) = (<fun>, <fun>) +# val n : < m : 'x 'a. ([< `Foo of 'x ] as 'a) -> 'x > = <obj> +# val n : < m : 'x. [< `Foo of 'x ] -> 'x > = <obj> +# Characters 60-130: + object method m : 'x. [< `Foo of 'x] -> 'x = fun x -> assert false end;; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This expression has type < m : 'x. [< `Foo of 'x ] -> 'x > + but an expression was expected of type + < m : 'a. [< `Foo of int ] -> 'a > + The universal variable 'x would escape its scope +# Characters 83-153: + object method m : 'x. [< `Foo of 'x] -> 'x = fun x -> assert false end;; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This expression has type < m : 'x. [< `Foo of 'x ] -> 'x > + but an expression was expected of type + < m : 'a. [< `Foo of int ] -> 'a > + The universal variable 'x would escape its scope +# Characters 95-98: + if b then x else M.A;; + ^^^ +Error: This expression has type M.t but an expression was expected of type 'x + The type constructor M.t would escape its scope # diff --git a/testsuite/tests/typing-private/private.ml.principal.reference b/testsuite/tests/typing-private/private.ml.principal.reference index 96b1d75955..db933583f5 100644 --- a/testsuite/tests/typing-private/private.ml.principal.reference +++ b/testsuite/tests/typing-private/private.ml.principal.reference @@ -84,9 +84,9 @@ Error: Signature mismatch: # module M1 : sig type t = M.t val mk : int -> t end # module M2 : sig type t = M.t val mk : int -> t end # module M3 : sig type t = M.t val mk : int -> t end -# Characters 26-44: +# Characters 21-44: type t = M.t = T of int - ^^^^^^^^^^^^^^^^^^ + ^^^^^^^^^^^^^^^^^^^^^^^ Error: This variant or record definition does not match that of type M.t A private type would be revealed. # module M5 : sig type t = M.t = private T of int val mk : int -> t end diff --git a/testsuite/tests/typing-private/private.ml.reference b/testsuite/tests/typing-private/private.ml.reference index cb1573ed49..341bc93686 100644 --- a/testsuite/tests/typing-private/private.ml.reference +++ b/testsuite/tests/typing-private/private.ml.reference @@ -84,9 +84,9 @@ Error: Signature mismatch: # module M1 : sig type t = M.t val mk : int -> t end # module M2 : sig type t = M.t val mk : int -> t end # module M3 : sig type t = M.t val mk : int -> t end -# Characters 26-44: +# Characters 21-44: type t = M.t = T of int - ^^^^^^^^^^^^^^^^^^ + ^^^^^^^^^^^^^^^^^^^^^^^ Error: This variant or record definition does not match that of type M.t A private type would be revealed. # module M5 : sig type t = M.t = private T of int val mk : int -> t end diff --git a/testsuite/tests/typing-recordarg/recordarg.ml b/testsuite/tests/typing-recordarg/recordarg.ml index 82fad0783b..ebd8d05671 100644 --- a/testsuite/tests/typing-recordarg/recordarg.ml +++ b/testsuite/tests/typing-recordarg/recordarg.ml @@ -84,3 +84,9 @@ module Z = struct type X1.t += A of {x: int} type X2.t += A of {x: int} end;; + +(* PR#6716 *) + +type _ c = C : [`A] c +type t = T : {x:[<`A] c} -> t;; +let f (T { x = C }) = ();; diff --git a/testsuite/tests/typing-recordarg/recordarg.ml.reference b/testsuite/tests/typing-recordarg/recordarg.ml.reference index 12f609acaa..5a671d6528 100644 --- a/testsuite/tests/typing-recordarg/recordarg.ml.reference +++ b/testsuite/tests/typing-recordarg/recordarg.ml.reference @@ -61,4 +61,7 @@ Error: Multiple definition of the extension constructor name A. ^ Error: Multiple definition of the extension constructor name A. Names must be unique in a given structure or signature. +# type _ c = C : [ `A ] c +type t = T : { x : [< `A ] c; } -> t +# val f : t -> unit = <fun> # diff --git a/testsuite/tests/typing-rectypes-bugs/pr6870_bad.ml b/testsuite/tests/typing-rectypes-bugs/pr6870_bad.ml new file mode 100644 index 0000000000..ed83460555 --- /dev/null +++ b/testsuite/tests/typing-rectypes-bugs/pr6870_bad.ml @@ -0,0 +1,2 @@ +module type T = sig type 'a t end +module Fix (T : T) = struct type r = ('r T.t as 'r) end diff --git a/testsuite/tests/typing-short-paths/pr6836.ml b/testsuite/tests/typing-short-paths/pr6836.ml new file mode 100644 index 0000000000..121bc463d5 --- /dev/null +++ b/testsuite/tests/typing-short-paths/pr6836.ml @@ -0,0 +1,6 @@ +type t = [`A | `B];; +type 'a u = t;; +let a : [< int u] = `A;; + +type 'a s = 'a;; +let b : [< t s] = `B;; diff --git a/testsuite/tests/typing-short-paths/pr6836.ml.reference b/testsuite/tests/typing-short-paths/pr6836.ml.reference new file mode 100644 index 0000000000..3f8c6dbd01 --- /dev/null +++ b/testsuite/tests/typing-short-paths/pr6836.ml.reference @@ -0,0 +1,7 @@ + +# type t = [ `A | `B ] +# type 'a u = t +# val a : [< int u > `A ] = `A +# type 'a s = 'a +# val b : [< t > `B ] = `B +# diff --git a/testsuite/tests/typing-short-paths/short-paths.ml b/testsuite/tests/typing-short-paths/short-paths.ml index a9812f4fad..5d691acaab 100644 --- a/testsuite/tests/typing-short-paths/short-paths.ml +++ b/testsuite/tests/typing-short-paths/short-paths.ml @@ -52,3 +52,6 @@ module N2 = struct type u = v and v = M1.v end;; module type PR6566 = sig type t = string end;; module PR6566 = struct type t = int end;; module PR6566' : PR6566 = PR6566;; + +module A = struct module B = struct type t = T end end;; +module M2 = struct type u = A.B.t type foo = int type v = A.B.t end;; diff --git a/testsuite/tests/typing-short-paths/short-paths.ml.reference b/testsuite/tests/typing-short-paths/short-paths.ml.reference index 53309ad383..db44521aa2 100644 --- a/testsuite/tests/typing-short-paths/short-paths.ml.reference +++ b/testsuite/tests/typing-short-paths/short-paths.ml.reference @@ -69,7 +69,7 @@ type u = M.u = C # module N1 : sig type u = v and v = t1 end # type t1 = B # module N2 : sig type u = v and v = N1.v end -# module type PR6566 = sig type t = bytes end +# module type PR6566 = sig type t = string end # module PR6566 : sig type t = int end # Characters 26-32: module PR6566' : PR6566 = PR6566;; @@ -79,5 +79,7 @@ Error: Signature mismatch: Type declarations do not match: type t = int is not included in - type t = bytes + type t = string +# module A : sig module B : sig type t = T end end +# module M2 : sig type u = A.B.t type foo = int type v = u end # diff --git a/testsuite/tests/typing-signatures/pr6672.ml b/testsuite/tests/typing-signatures/pr6672.ml new file mode 100644 index 0000000000..5b168f05a0 --- /dev/null +++ b/testsuite/tests/typing-signatures/pr6672.ml @@ -0,0 +1,3 @@ +module type S = sig type 'a t end;; +module type T = S with type +'a t = 'a list;; +module type T = S with type -'a t = 'a list;; diff --git a/testsuite/tests/typing-signatures/pr6672.ml.reference b/testsuite/tests/typing-signatures/pr6672.ml.reference new file mode 100644 index 0000000000..959cee7eb6 --- /dev/null +++ b/testsuite/tests/typing-signatures/pr6672.ml.reference @@ -0,0 +1,10 @@ + +# module type S = sig type 'a t end +# module type T = sig type 'a t = 'a list end +# Characters 23-43: + module type T = S with type -'a t = 'a list;; + ^^^^^^^^^^^^^^^^^^^^ +Error: In this definition, expected parameter variances are not satisfied. + The 1st type parameter was expected to be contravariant, + but it is injective covariant. +# diff --git a/testsuite/tests/typing-typeparam/newtype.ml.reference b/testsuite/tests/typing-typeparam/newtype.ml.reference index c28cf53a6e..217697531f 100644 --- a/testsuite/tests/typing-typeparam/newtype.ml.reference +++ b/testsuite/tests/typing-typeparam/newtype.ml.reference @@ -9,11 +9,11 @@ false # Characters 33-34: let f x (type a) (y : a) = (x = y);; (* Fails *) ^ -Error: This expression has type a but an expression was expected of type a +Error: This expression has type a but an expression was expected of type 'a The type constructor a would escape its scope # Characters 117-118: method n : 'a -> 'a = fun (type g) (x:g) -> self#m x ^ -Error: This expression has type g but an expression was expected of type g +Error: This expression has type g but an expression was expected of type 'a The type constructor g would escape its scope # diff --git a/testsuite/tests/typing-warnings/pr6872.ml b/testsuite/tests/typing-warnings/pr6872.ml new file mode 100644 index 0000000000..6eba3e7011 --- /dev/null +++ b/testsuite/tests/typing-warnings/pr6872.ml @@ -0,0 +1,9 @@ +exception A;; +type a = A;; + +A;; +raise A;; +fun (A : a) -> ();; +function Not_found -> 1 | A -> 2 | _ -> 3;; +try raise A with A -> 2;; + diff --git a/testsuite/tests/typing-warnings/pr6872.ml.principal.reference b/testsuite/tests/typing-warnings/pr6872.ml.principal.reference new file mode 100644 index 0000000000..0227cfd9c1 --- /dev/null +++ b/testsuite/tests/typing-warnings/pr6872.ml.principal.reference @@ -0,0 +1,35 @@ + +# exception A +# type a = A +# Characters 1-2: + A;; + ^ +Warning 41: A belongs to several types: a exn +The first one was selected. Please disambiguate if this is wrong. +- : a = A +# Characters 6-7: + raise A;; + ^ +Warning 42: this use of A required disambiguation. +Exception: A. +# - : a -> unit = <fun> +# Characters 26-27: + function Not_found -> 1 | A -> 2 | _ -> 3;; + ^ +Warning 41: A belongs to several types: a exn +The first one was selected. Please disambiguate if this is wrong. +Characters 26-27: + function Not_found -> 1 | A -> 2 | _ -> 3;; + ^ +Error: This pattern matches values of type a + but a pattern was expected which matches values of type exn +# Characters 10-11: + try raise A with A -> 2;; + ^ +Warning 42: this use of A required disambiguation. +Characters 17-18: + try raise A with A -> 2;; + ^ +Warning 42: this use of A required disambiguation. +- : int = 2 +# diff --git a/testsuite/tests/typing-warnings/pr6872.ml.reference b/testsuite/tests/typing-warnings/pr6872.ml.reference new file mode 100644 index 0000000000..7aeebbebf1 --- /dev/null +++ b/testsuite/tests/typing-warnings/pr6872.ml.reference @@ -0,0 +1,30 @@ + +# exception A +# type a = A +# Characters 1-2: + A;; + ^ +Warning 41: A belongs to several types: a exn +The first one was selected. Please disambiguate if this is wrong. +- : a = A +# Characters 6-7: + raise A;; + ^ +Warning 42: this use of A required disambiguation. +Exception: A. +# - : a -> unit = <fun> +# Characters 26-27: + function Not_found -> 1 | A -> 2 | _ -> 3;; + ^ +Warning 42: this use of A required disambiguation. +- : exn -> int = <fun> +# Characters 10-11: + try raise A with A -> 2;; + ^ +Warning 42: this use of A required disambiguation. +Characters 17-18: + try raise A with A -> 2;; + ^ +Warning 42: this use of A required disambiguation. +- : int = 2 +# diff --git a/testsuite/tests/typing-warnings/unused_types.ml b/testsuite/tests/typing-warnings/unused_types.ml new file mode 100644 index 0000000000..afe7d4cf16 --- /dev/null +++ b/testsuite/tests/typing-warnings/unused_types.ml @@ -0,0 +1,18 @@ +module Unused : sig +end = struct + type unused = int +end +;; + +module Unused_nonrec : sig +end = struct + type nonrec used = int + type nonrec unused = used +end +;; + +module Unused_rec : sig +end = struct + type unused = A of unused +end +;; diff --git a/testsuite/tests/typing-warnings/unused_types.ml.reference b/testsuite/tests/typing-warnings/unused_types.ml.reference new file mode 100644 index 0000000000..d515c24e47 --- /dev/null +++ b/testsuite/tests/typing-warnings/unused_types.ml.reference @@ -0,0 +1,21 @@ + +# Characters 35-52: + type unused = int + ^^^^^^^^^^^^^^^^^ +Warning 34: unused type unused. +module Unused : sig end +# Characters 68-93: + type nonrec unused = used + ^^^^^^^^^^^^^^^^^^^^^^^^^ +Warning 34: unused type unused. +module Unused_nonrec : sig end +# Characters 40-65: + type unused = A of unused + ^^^^^^^^^^^^^^^^^^^^^^^^^ +Warning 34: unused type unused. +Characters 40-65: + type unused = A of unused + ^^^^^^^^^^^^^^^^^^^^^^^^^ +Warning 37: unused constructor A. +module Unused_rec : sig end +# diff --git a/testsuite/tests/utils/Makefile b/testsuite/tests/utils/Makefile index 4b7ab0dd42..1d50868024 100644 --- a/testsuite/tests/utils/Makefile +++ b/testsuite/tests/utils/Makefile @@ -18,3 +18,5 @@ CMO_FILES+="misc.cmo" include $(BASEDIR)/makefiles/Makefile.several include $(BASEDIR)/makefiles/Makefile.common + +BYTECODE_ONLY=true diff --git a/testsuite/tests/warnings/w06.ml b/testsuite/tests/warnings/w06.ml new file mode 100644 index 0000000000..6e8a1bca03 --- /dev/null +++ b/testsuite/tests/warnings/w06.ml @@ -0,0 +1,6 @@ +let foo ~bar = ignore bar (* one label *) + +let bar ~foo ~baz = ignore (foo, baz) (* two labels *) + +let () = foo 2 +let () = bar 4 2 diff --git a/testsuite/tests/warnings/w06.reference b/testsuite/tests/warnings/w06.reference new file mode 100644 index 0000000000..b3019f4d1d --- /dev/null +++ b/testsuite/tests/warnings/w06.reference @@ -0,0 +1,4 @@ +File "w06.ml", line 5, characters 9-12: +Warning 6: label bar was omitted in the application of this function. +File "w06.ml", line 6, characters 9-12: +Warning 6: labels foo, baz were omitted in the application of this function. diff --git a/testsuite/tests/warnings/w51.ml b/testsuite/tests/warnings/w51.ml new file mode 100644 index 0000000000..25e087068d --- /dev/null +++ b/testsuite/tests/warnings/w51.ml @@ -0,0 +1,5 @@ + +let rec fact = function + | 1 -> 1 + | n -> n * (fact [@tailcall]) (n-1) +;; diff --git a/testsuite/tests/warnings/w51.reference b/testsuite/tests/warnings/w51.reference new file mode 100644 index 0000000000..5e3cf374d6 --- /dev/null +++ b/testsuite/tests/warnings/w51.reference @@ -0,0 +1,2 @@ +File "w51.ml", line 4, characters 13-37: +Warning 51: expected tailcall diff --git a/testsuite/tests/warnings/w51_bis.ml b/testsuite/tests/warnings/w51_bis.ml new file mode 100644 index 0000000000..810fcdd4f5 --- /dev/null +++ b/testsuite/tests/warnings/w51_bis.ml @@ -0,0 +1,5 @@ +let rec foldl op acc = function + [] -> acc + | x :: xs -> + try (foldl [@tailcall]) op (op x acc) xs + with Not_found -> assert false diff --git a/testsuite/tests/warnings/w51_bis.reference b/testsuite/tests/warnings/w51_bis.reference new file mode 100644 index 0000000000..ee5cab5a35 --- /dev/null +++ b/testsuite/tests/warnings/w51_bis.reference @@ -0,0 +1,2 @@ +File "w51_bis.ml", line 4, characters 12-48: +Warning 51: expected tailcall diff --git a/tools/.depend b/tools/.depend index c33f5c6f22..626cdc6af2 100644 --- a/tools/.depend +++ b/tools/.depend @@ -1,24 +1,21 @@ depend.cmi : ../parsing/parsetree.cmi ../parsing/longident.cmi profiling.cmi : -tast_iter.cmi : ../typing/typedtree.cmi ../parsing/asttypes.cmi -untypeast.cmi : ../typing/typedtree.cmi ../typing/path.cmi \ - ../parsing/parsetree.cmi ../parsing/longident.cmi addlabels.cmo : ../parsing/parsetree.cmi ../parsing/parse.cmi \ ../parsing/longident.cmi ../parsing/location.cmi ../parsing/asttypes.cmi addlabels.cmx : ../parsing/parsetree.cmi ../parsing/parse.cmx \ ../parsing/longident.cmx ../parsing/location.cmx ../parsing/asttypes.cmi -cmt2annot.cmo : untypeast.cmi ../typing/types.cmi ../typing/typedtree.cmi \ - tast_iter.cmi ../typing/stypes.cmi ../parsing/pprintast.cmi \ - ../typing/path.cmi ../typing/oprint.cmi ../parsing/location.cmi \ - ../typing/ident.cmi ../typing/envaux.cmi ../typing/env.cmi \ - ../utils/config.cmi ../typing/cmt_format.cmi ../parsing/asttypes.cmi \ - ../typing/annot.cmi -cmt2annot.cmx : untypeast.cmx ../typing/types.cmx ../typing/typedtree.cmx \ - tast_iter.cmx ../typing/stypes.cmx ../parsing/pprintast.cmx \ - ../typing/path.cmx ../typing/oprint.cmx ../parsing/location.cmx \ - ../typing/ident.cmx ../typing/envaux.cmx ../typing/env.cmx \ - ../utils/config.cmx ../typing/cmt_format.cmx ../parsing/asttypes.cmi \ - ../typing/annot.cmi +cmt2annot.cmo : ../typing/untypeast.cmi ../typing/types.cmi \ + ../typing/typedtree.cmi ../typing/tast_mapper.cmi ../typing/stypes.cmi \ + ../parsing/pprintast.cmi ../typing/path.cmi ../typing/oprint.cmi \ + ../parsing/location.cmi ../typing/ident.cmi ../typing/envaux.cmi \ + ../typing/env.cmi ../utils/config.cmi ../typing/cmt_format.cmi \ + ../parsing/asttypes.cmi ../typing/annot.cmi +cmt2annot.cmx : ../typing/untypeast.cmx ../typing/types.cmx \ + ../typing/typedtree.cmx ../typing/tast_mapper.cmx ../typing/stypes.cmx \ + ../parsing/pprintast.cmx ../typing/path.cmx ../typing/oprint.cmx \ + ../parsing/location.cmx ../typing/ident.cmx ../typing/envaux.cmx \ + ../typing/env.cmx ../utils/config.cmx ../typing/cmt_format.cmx \ + ../parsing/asttypes.cmi ../typing/annot.cmi cvt_emit.cmo : cvt_emit.cmx : depend.cmo : ../parsing/parsetree.cmi ../utils/misc.cmi \ @@ -52,13 +49,13 @@ ocaml299to3.cmx : ocamlcp.cmo : ../driver/main_args.cmi ocamlcp.cmx : ../driver/main_args.cmx ocamldep.cmo : ../driver/pparse.cmi ../parsing/parsetree.cmi \ - ../parsing/parse.cmi ../utils/misc.cmi ../parsing/longident.cmi \ - ../parsing/location.cmi depend.cmi ../utils/config.cmi \ - ../driver/compenv.cmi ../utils/clflags.cmi + ../parsing/parser.cmi ../parsing/parse.cmi ../utils/misc.cmi \ + ../parsing/longident.cmi ../parsing/location.cmi ../parsing/lexer.cmi \ + depend.cmi ../utils/config.cmi ../driver/compenv.cmi ../utils/clflags.cmi ocamldep.cmx : ../driver/pparse.cmx ../parsing/parsetree.cmi \ - ../parsing/parse.cmx ../utils/misc.cmx ../parsing/longident.cmx \ - ../parsing/location.cmx depend.cmx ../utils/config.cmx \ - ../driver/compenv.cmx ../utils/clflags.cmx + ../parsing/parser.cmx ../parsing/parse.cmx ../utils/misc.cmx \ + ../parsing/longident.cmx ../parsing/location.cmx ../parsing/lexer.cmx \ + depend.cmx ../utils/config.cmx ../driver/compenv.cmx ../utils/clflags.cmx ocamlmklib.cmo : ocamlmklibconfig.cmo ocamlmklib.cmx : ocamlmklibconfig.cmx ocamlmklibconfig.cmo : @@ -81,13 +78,3 @@ read_cmt.cmo : ../typing/cmt_format.cmi cmt2annot.cmo ../utils/clflags.cmi read_cmt.cmx : ../typing/cmt_format.cmx cmt2annot.cmx ../utils/clflags.cmx scrapelabels.cmo : scrapelabels.cmx : -tast_iter.cmo : ../typing/typedtree.cmi ../utils/misc.cmi tast_iter.cmi -tast_iter.cmx : ../typing/typedtree.cmx ../utils/misc.cmx tast_iter.cmi -untypeast.cmo : ../typing/typedtree.cmi ../typing/path.cmi \ - ../parsing/parsetree.cmi ../utils/misc.cmi ../parsing/longident.cmi \ - ../typing/ident.cmi ../parsing/asttypes.cmi ../parsing/ast_helper.cmi \ - untypeast.cmi -untypeast.cmx : ../typing/typedtree.cmx ../typing/path.cmx \ - ../parsing/parsetree.cmi ../utils/misc.cmx ../parsing/longident.cmx \ - ../typing/ident.cmx ../parsing/asttypes.cmi ../parsing/ast_helper.cmx \ - untypeast.cmi diff --git a/tools/Makefile.shared b/tools/Makefile.shared index 251743449f..3a6dfbc855 100644 --- a/tools/Makefile.shared +++ b/tools/Makefile.shared @@ -11,8 +11,9 @@ ######################################################################### include ../config/Makefile +CAMLRUN ?= ../boot/ocamlrun +CAMLYACC ?= ../boot/ocamlyacc -CAMLRUN=../boot/ocamlrun CAMLC=$(CAMLRUN) ../boot/ocamlc -nostdlib -I ../boot CAMLOPT=$(CAMLRUN) ../ocamlopt -nostdlib -I ../stdlib CAMLLEX=$(CAMLRUN) ../boot/ocamllex @@ -24,8 +25,6 @@ LINKFLAGS=$(INCLUDES) all: ocamldep ocamlprof ocamlcp ocamloptp ocamlmktop ocamlmklib dumpobj \ objinfo read_cmt -all: tast_iter.cmo - # scrapelabels addlabels .PHONY: all @@ -37,7 +36,7 @@ opt.opt: ocamldep.opt read_cmt.opt CAMLDEP_OBJ=depend.cmo ocamldep.cmo CAMLDEP_IMPORTS=misc.cmo config.cmo clflags.cmo terminfo.cmo \ - warnings.cmo location.cmo longident.cmo \ + warnings.cmo location.cmo longident.cmo docstrings.cmo \ syntaxerr.cmo ast_helper.cmo parser.cmo lexer.cmo parse.cmo \ ccomp.cmo ast_mapper.cmo pparse.cmo compenv.cmo @@ -67,7 +66,7 @@ install:: CSLPROF=ocamlprof.cmo CSLPROF_IMPORTS=misc.cmo config.cmo clflags.cmo terminfo.cmo \ - warnings.cmo location.cmo longident.cmo \ + warnings.cmo location.cmo longident.cmo docstrings.cmo \ syntaxerr.cmo ast_helper.cmo parser.cmo lexer.cmo parse.cmo ocamlprof: $(CSLPROF) profiling.cmo @@ -160,7 +159,7 @@ clean:: # Insert labels following an interface file (upgrade 3.02 to 3.03) ADDLABELS_IMPORTS=misc.cmo config.cmo clflags.cmo terminfo.cmo \ - warnings.cmo location.cmo longident.cmo \ + warnings.cmo location.cmo longident.cmo docstrings.cmo \ syntaxerr.cmo ast_helper.cmo parser.cmo lexer.cmo parse.cmo addlabels: addlabels.cmo @@ -205,6 +204,7 @@ READ_CMT= \ ../utils/clflags.cmo \ ../parsing/location.cmo \ ../parsing/longident.cmo \ + ../parsing/docstrings.cmo \ ../parsing/lexer.cmo \ ../parsing/pprintast.cmo \ ../parsing/ast_helper.cmo \ @@ -225,13 +225,11 @@ READ_CMT= \ ../typing/printtyp.cmo \ ../typing/mtype.cmo \ ../typing/envaux.cmo \ - ../typing/typedtreeMap.cmo \ - ../typing/typedtreeIter.cmo \ + ../typing/tast_mapper.cmo \ ../typing/cmt_format.cmo \ ../typing/stypes.cmo \ + ../typing/untypeast.cmo \ \ - untypeast.cmo \ - tast_iter.cmo \ cmt2annot.cmo read_cmt.cmo read_cmt: $(READ_CMT) @@ -257,7 +255,7 @@ dumpobj: $(DUMPOBJ) clean:: rm -f dumpobj -opnames.ml: ../byterun/instruct.h +opnames.ml: ../byterun/caml/instruct.h unset LC_ALL || : ; \ unset LC_CTYPE || : ; \ unset LC_COLLATE LANG || : ; \ @@ -267,7 +265,7 @@ opnames.ml: ../byterun/instruct.h -e 's/.*};$$/ |]/' \ -e 's/\([A-Z][A-Z_0-9a-z]*\)/"\1"/g' \ -e 's/,/;/g' \ - ../byterun/instruct.h > opnames.ml + ../byterun/caml/instruct.h > opnames.ml clean:: rm -f opnames.ml @@ -276,9 +274,22 @@ beforedepend:: opnames.ml # Display info on compiled files +ifeq "$(SYSTEM)" "macosx" +DEF_SYMBOL_PREFIX = '-Dsymbol_prefix="_"' +else +DEF_SYMBOL_PREFIX = '-Dsymbol_prefix=""' +endif + +ifeq "$(CCOMPTYPE)" "msvc" +CCOUT = -Fe +else +EMPTY = +CCOUT = -o $(EMPTY) +endif + objinfo_helper$(EXE): objinfo_helper.c ../config/s.h - $(BYTECC) -o objinfo_helper$(EXE) $(BYTECCCOMPOPTS) \ - objinfo_helper.c $(LIBBFD_LINK) + $(BYTECC) $(CCOUT)objinfo_helper$(EXE) $(BYTECCCOMPOPTS) \ + $(DEF_SYMBOL_PREFIX) $(LIBBFD_INCLUDE) objinfo_helper.c $(LIBBFD_LINK) OBJINFO=../compilerlibs/ocamlcommon.cma \ ../compilerlibs/ocamlbytecomp.cma \ diff --git a/tools/ci-build b/tools/ci-build index 4bb2593eb6..c4466ce70a 100755 --- a/tools/ci-build +++ b/tools/ci-build @@ -135,6 +135,9 @@ done ######################################################################### # Do the work +# Tell gcc to use only ASCII in its diagnostic outputs. +export LC_ALL=C + $make -f Makefile$nt distclean || : if $docheckout; then diff --git a/tools/cmt2annot.ml b/tools/cmt2annot.ml index 36ca187ca5..820bd0c7f4 100644 --- a/tools/cmt2annot.ml +++ b/tools/cmt2annot.ml @@ -14,24 +14,29 @@ open Asttypes open Typedtree +open Tast_mapper let bind_variables scope = - object - inherit Tast_iter.iter as super - - method! pattern pat = - super # pattern pat; - match pat.pat_desc with - | Tpat_var (id, _) | Tpat_alias (_, id, _) -> - Stypes.record (Stypes.An_ident (pat.pat_loc, - Ident.name id, - Annot.Idef scope)) - | _ -> () - end + let super = Tast_mapper.default in + let pat sub p = + begin match p.pat_desc with + | Tpat_var (id, _) | Tpat_alias (_, id, _) -> + Stypes.record (Stypes.An_ident (p.pat_loc, + Ident.name id, + Annot.Idef scope)) + | _ -> () + end; + super.pat sub p; + in + {super with pat} + +let bind_variables scope = + let o = bind_variables scope in + fun p -> ignore (o.pat o p) let bind_bindings scope bindings = let o = bind_variables scope in - List.iter (fun x -> o # pattern x.vb_pat) bindings + List.iter (fun x -> o x.vb_pat) bindings let bind_cases l = List.iter @@ -42,110 +47,108 @@ let bind_cases l = | None -> c_rhs.exp_loc | Some g -> {c_rhs.exp_loc with loc_start=g.exp_loc.loc_start} in - (bind_variables loc) # pattern c_lhs) l - -let iterator rebuild_env = - object(this) - val scope = Location.none (* scope of the surrounding structure *) - - inherit Tast_iter.iter as super - - method! class_expr node = - Stypes.record (Stypes.Ti_class node); - super # class_expr node - - method! module_expr node = - Stypes.record (Stypes.Ti_mod node); - Tast_iter.module_expr {< scope = node.mod_loc >} node - - method! expression exp = - begin match exp.exp_desc with - | Texp_ident (path, _, _) -> - let full_name = Path.name ~paren:Oprint.parenthesized_ident path in - let env = - if rebuild_env then - try - Env.env_of_only_summary Envaux.env_from_summary exp.exp_env - with Envaux.Error err -> - Format.eprintf "%a@." Envaux.report_error err; - exit 2 - else - exp.exp_env - in - let annot = + bind_variables loc c_lhs + ) + l + +let rec iterator ~scope rebuild_env = + let super = Tast_mapper.default in + let class_expr sub node = + Stypes.record (Stypes.Ti_class node); + super.class_expr sub node + + and module_expr _sub node = + Stypes.record (Stypes.Ti_mod node); + super.module_expr (iterator ~scope:node.mod_loc rebuild_env) node + + and expr sub exp = + begin match exp.exp_desc with + | Texp_ident (path, _, _) -> + let full_name = Path.name ~paren:Oprint.parenthesized_ident path in + let env = + if rebuild_env then try - let desc = Env.find_value path env in - let dloc = desc.Types.val_loc in - if dloc.Location.loc_ghost then Annot.Iref_external - else Annot.Iref_internal dloc - with Not_found -> - Annot.Iref_external - in - Stypes.record - (Stypes.An_ident (exp.exp_loc, full_name , annot)) - | Texp_let (Recursive, bindings, _) -> - bind_bindings exp.exp_loc bindings - | Texp_let (Nonrecursive, bindings, body) -> - bind_bindings body.exp_loc bindings - | Texp_match (_, f1, f2, _) -> + Env.env_of_only_summary Envaux.env_from_summary exp.exp_env + with Envaux.Error err -> + Format.eprintf "%a@." Envaux.report_error err; + exit 2 + else + exp.exp_env + in + let annot = + try + let desc = Env.find_value path env in + let dloc = desc.Types.val_loc in + if dloc.Location.loc_ghost then Annot.Iref_external + else Annot.Iref_internal dloc + with Not_found -> + Annot.Iref_external + in + Stypes.record + (Stypes.An_ident (exp.exp_loc, full_name , annot)) + | Texp_let (Recursive, bindings, _) -> + 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_try (_, f) -> - bind_cases f - | _ -> () - end; - Stypes.record (Stypes.Ti_expr exp); - super # expression exp - - method! pattern pat = - super # pattern pat; - Stypes.record (Stypes.Ti_pat pat) - - method private structure_item_rem s rem = - begin match s with - | {str_desc = Tstr_value (rec_flag, bindings); str_loc = loc} -> - let open Location in - let doit loc_start = bind_bindings {scope with loc_start} bindings in - begin match rec_flag, rem with - | Recursive, _ -> doit loc.loc_start - | Nonrecursive, [] -> doit loc.loc_end - | Nonrecursive, {str_loc = loc2} :: _ -> doit loc2.loc_start - end - | _ -> - () - end; - Stypes.record_phrase s.str_loc; - super # structure_item s - - method! structure_item s = - (* This will be used for Partial_structure_item. - We don't have here the location of the "next" item, - this will give a slightly different scope for the non-recursive - binding case. *) - this # structure_item_rem s [] - - method! structure l = - let rec loop = function - | str :: rem -> this # structure_item_rem str rem; loop rem - | [] -> () - in - loop l.str_items + | Texp_function (_, f, _) + | Texp_try (_, f) -> + bind_cases f + | _ -> () + end; + Stypes.record (Stypes.Ti_expr exp); + super.expr sub exp + + and pat sub p = + Stypes.record (Stypes.Ti_pat p); + super.pat sub p + in -(* TODO: support binding for Tcl_fun, Tcl_let, etc *) - end + let structure_item_rem sub s rem = + begin match s with + | {str_desc = Tstr_value (rec_flag, bindings); str_loc = loc} -> + let open Location in + let doit loc_start = bind_bindings {scope with loc_start} bindings in + begin match rec_flag, rem with + | Recursive, _ -> doit loc.loc_start + | Nonrecursive, [] -> doit loc.loc_end + | Nonrecursive, {str_loc = loc2} :: _ -> doit loc2.loc_start + end + | _ -> + () + end; + Stypes.record_phrase s.str_loc; + super.structure_item sub s + in + let structure_item sub s = + (* This will be used for Partial_structure_item. + We don't have here the location of the "next" item, + this will give a slightly different scope for the non-recursive + binding case. *) + structure_item_rem sub s [] + and structure sub l = + let rec loop = function + | str :: rem -> structure_item_rem sub str rem :: loop rem + | [] -> [] + in + {l with str_items = loop l.str_items} + in + {super with class_expr; module_expr; expr; pat; structure_item; structure} let binary_part iter x = + let app f x = ignore (f iter x) in let open Cmt_format in match x with - | Partial_structure x -> iter # structure x - | Partial_structure_item x -> iter # structure_item x - | Partial_expression x -> iter # expression x - | Partial_pattern x -> iter # pattern x - | Partial_class_expr x -> iter # class_expr x - | Partial_signature x -> iter # signature x - | Partial_signature_item x -> iter # signature_item x - | Partial_module_type x -> iter # module_type x + | Partial_structure x -> app iter.structure x + | Partial_structure_item x -> app iter.structure_item x + | Partial_expression x -> app iter.expr x + | Partial_pattern x -> app iter.pat x + | Partial_class_expr x -> app iter.class_expr x + | Partial_signature x -> app iter.signature x + | Partial_signature_item x -> app iter.signature_item x + | Partial_module_type x -> app iter.module_type x let gen_annot target_filename filename {Cmt_format.cmt_loadpath; cmt_annots; cmt_use_summaries; _} = @@ -158,10 +161,10 @@ let gen_annot target_filename filename | Some "-" -> None | Some _ -> target_filename in - let iterator = iterator cmt_use_summaries in + let iterator = iterator ~scope:Location.none cmt_use_summaries in match cmt_annots with | Implementation typedtree -> - iterator # structure typedtree; + ignore (iterator.structure iterator typedtree); Stypes.dump target_filename | Interface _ -> Printf.eprintf "Cannot generate annotations for interface file\n%!"; diff --git a/tools/depend.ml b/tools/depend.ml index 222d08d31e..a09c156765 100644 --- a/tools/depend.ml +++ b/tools/depend.ml @@ -245,7 +245,7 @@ and add_sig_item bv item = match item.psig_desc with Psig_value vd -> add_type bv vd.pval_type; bv - | Psig_type dcls -> + | Psig_type (_, dcls) -> List.iter (add_type_declaration bv) dcls; bv | Psig_typext te -> add_type_extension bv te; bv @@ -304,7 +304,7 @@ and add_struct_item bv item = let bv = add_bindings rf bv pel in bv | Pstr_primitive vd -> add_type bv vd.pval_type; bv - | Pstr_type dcls -> + | Pstr_type (_, dcls) -> List.iter (add_type_declaration bv) dcls; bv | Pstr_typext te -> add_type_extension bv te; diff --git a/tools/dumpobj.ml b/tools/dumpobj.ml index f1e2897381..7fd3e43914 100644 --- a/tools/dumpobj.ml +++ b/tools/dumpobj.ml @@ -394,6 +394,8 @@ let op_shapes = [ opSTOP, Nothing; opEVENT, Nothing; opBREAK, Nothing; + opRERAISE, Nothing; + opRAISE_NOTRACE, Nothing; ];; let print_event ev = @@ -412,52 +414,54 @@ let print_instr ic = if op >= Array.length names_of_instructions || op < 0 then (print_string "*** unknown opcode : "; print_int op) else print_string names_of_instructions.(op); - print_string " "; - begin try match List.assoc op op_shapes with - | Uint -> print_int (inputu ic) - | Sint -> print_int (inputs ic) - | Uint_Uint - -> print_int (inputu ic); print_string ", "; print_int (inputu ic) - | Disp -> let p = currpc ic in print_int (p + inputs ic) - | Uint_Disp - -> print_int (inputu ic); print_string ", "; - let p = currpc ic in print_int (p + inputs ic) - | Sint_Disp - -> print_int (inputs ic); print_string ", "; - let p = currpc ic in print_int (p + inputs ic) - | Getglobal -> print_getglobal_name ic - | Getglobal_Uint - -> print_getglobal_name ic; print_string ", "; print_int (inputu ic) - | Setglobal -> print_setglobal_name ic - | Primitive -> print_primitive ic - | Uint_Primitive - -> print_int(inputu ic); print_string ", "; print_primitive ic - | Switch - -> let n = inputu ic in - let orig = currpc ic in - for i = 0 to (n land 0xFFFF) - 1 do - print_string "\n int "; print_int i; print_string " -> "; - print_int(orig + inputs ic); - done; - for i = 0 to (n lsr 16) - 1 do - print_string "\n tag "; print_int i; print_string " -> "; - print_int(orig + inputs ic); - done; - | Closurerec - -> let nfuncs = inputu ic in - let nvars = inputu ic in - let orig = currpc ic in - print_int nvars; - for _i = 0 to nfuncs - 1 do - print_string ", "; - print_int (orig + inputs ic); - done; - | Pubmet - -> let tag = inputs ic in - let _cache = inputu ic in - print_int tag - | Nothing -> () - with Not_found -> print_string "(unknown arguments)" + begin try + let shape = List.assoc op op_shapes in + if shape <> Nothing then print_string " "; + match shape with + | Uint -> print_int (inputu ic) + | Sint -> print_int (inputs ic) + | Uint_Uint + -> print_int (inputu ic); print_string ", "; print_int (inputu ic) + | Disp -> let p = currpc ic in print_int (p + inputs ic) + | Uint_Disp + -> print_int (inputu ic); print_string ", "; + let p = currpc ic in print_int (p + inputs ic) + | Sint_Disp + -> print_int (inputs ic); print_string ", "; + let p = currpc ic in print_int (p + inputs ic) + | Getglobal -> print_getglobal_name ic + | Getglobal_Uint + -> print_getglobal_name ic; print_string ", "; print_int (inputu ic) + | Setglobal -> print_setglobal_name ic + | Primitive -> print_primitive ic + | Uint_Primitive + -> print_int(inputu ic); print_string ", "; print_primitive ic + | Switch + -> let n = inputu ic in + let orig = currpc ic in + for i = 0 to (n land 0xFFFF) - 1 do + print_string "\n int "; print_int i; print_string " -> "; + print_int(orig + inputs ic); + done; + for i = 0 to (n lsr 16) - 1 do + print_string "\n tag "; print_int i; print_string " -> "; + print_int(orig + inputs ic); + done; + | Closurerec + -> let nfuncs = inputu ic in + let nvars = inputu ic in + let orig = currpc ic in + print_int nvars; + for _i = 0 to nfuncs - 1 do + print_string ", "; + print_int (orig + inputs ic); + done; + | Pubmet + -> let tag = inputs ic in + let _cache = inputu ic in + print_int tag + | Nothing -> () + with Not_found -> print_string " (unknown arguments)" end; print_string "\n"; ;; diff --git a/tools/eqparsetree.ml b/tools/eqparsetree.ml index 128453e0c3..4c699e9988 100644 --- a/tools/eqparsetree.ml +++ b/tools/eqparsetree.ml @@ -273,12 +273,13 @@ let rec eq_structure_item_desc : | (Pstr_primitive (a0, a1), Pstr_primitive (b0, b1)) -> (Asttypes.eq_loc eq_string (a0, b0)) && (eq_value_description (a1, b1)) - | (Pstr_type a0, Pstr_type b0) -> + | (Pstr_type (a0, a1), Pstr_type (b0, b1)) -> + (Asttypes.eq_rec_flag (a0, b0)) && eq_list (fun ((a0, a1), (b0, b1)) -> (Asttypes.eq_loc eq_string (a0, b0)) && (eq_type_declaration (a1, b1))) - (a0, b0) + (a1, b1) | (Pstr_exception (a0, a1), Pstr_exception (b0, b1)) -> (Asttypes.eq_loc eq_string (a0, b0)) && (eq_exception_declaration (a1, b1)) @@ -359,12 +360,13 @@ and eq_signature_item_desc : | (Psig_value (a0, a1), Psig_value (b0, b1)) -> (Asttypes.eq_loc eq_string (a0, b0)) && (eq_value_description (a1, b1)) - | (Psig_type a0, Psig_type b0) -> + | (Psig_type (a0, a1), Psig_type (b0, b1)) -> + (Asttypes.eq_rec_flag (a0, b0)) && eq_list (fun ((a0, a1), (b0, b1)) -> (Asttypes.eq_loc eq_string (a0, b0)) && (eq_type_declaration (a1, b1))) - (a0, b0) + (a1, b1) | (Psig_exception (a0, a1), Psig_exception (b0, b1)) -> (Asttypes.eq_loc eq_string (a0, b0)) && (eq_exception_declaration (a1, b1)) diff --git a/tools/gdb-macros b/tools/gdb-macros new file mode 100644 index 0000000000..5dfa2b2ed0 --- /dev/null +++ b/tools/gdb-macros @@ -0,0 +1,318 @@ +######################################################################### +# # +# OCaml # +# # +# Damien Doligez, Jane Street Group, LLC # +# # +# Copyright 2015 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 set of macros for low-level debugging of OCaml programs and of the +# OCaml runtime itself (both native and byte-code). + +# This file should be loaded in gdb with [ source gdb-macros ]. +# It defines one command: [caml] +# Usage: +# [caml <value>] +# If <value> is an OCaml value, this will display it in a low-level +# but legible format, including the header information. + +# To do: a [camlsearch] command to find all (gc-traceable) pointers to +# a given heap block. + +set $camlwordsize = sizeof(char *) + +if $camlwordsize == 8 + set $caml_unalloc_mask = 0xFF00FFFFFF00FFFF + set $caml_unalloc_value = 0xD700D7D7D700D6D7 +else + set $caml_unalloc_mask = 0xFF00FFFF + set $caml_unalloc_value = 0xD700D6D7 +end + +define camlcheckheader + if $arg0 >> 10 <= 0 || $arg0 >> 10 >= 0x1000000000000 + if ($arg0 & $caml_unalloc_mask) == $caml_unalloc_value + set $camlcheckheader_result = 2 + else + if $arg0 == (unsigned long) 0 + set $camlcheckheader_result = 3 + else + set $camlcheckheader_result = 1 + end + end + else + set $camlcheckheader_result = 0 + end +end + +define camlheader + set $hd = * (unsigned long *) ($arg0 - $camlwordsize) + set $tag = $hd & 0xFF + set $color = ($hd >> 8) & 3 + set $size = $hd >> 10 + + camlcheckheader $hd + if $camlcheckheader_result != 0 + if $camlcheckheader_result == 2 + printf "[UNALLOCATED MEMORY]" + else + if $camlcheckheader_result == 3 + printf "[** fragment **] 0x%016lu", $hd + else + printf "[**invalid header**] 0x%016lu", $hd + end + end + set $size = 0 + else + printf "[" + if $color == 0 + printf "white " + end + if $color == 1 + printf "gray " + end + if $color == 2 + printf "blue " + end + if $color == 3 + printf "black " + end + + if $tag < 246 + printf "tag%d ", $tag + end + if $tag == 246 + printf "Lazy " + end + if $tag == 247 + printf "Closure " + end + if $tag == 248 + printf "Object " + end + if $tag == 249 + printf "Infix " + end + if $tag == 250 + printf "Forward " + end + if $tag == 251 + printf "Abstract " + end + if $tag == 252 + printf "String " + end + if $tag == 253 + printf "Double " + end + if $tag == 254 + printf "Double_array " + end + if $tag == 255 + printf "Custom " + end + + printf "%lu]", $size + end +end + +define camlheap + if $arg0 >= caml_young_start && $arg0 < caml_young_end + printf "YOUNG" + set $camlheap_result = 1 + else + set $chunk = caml_heap_start + set $found = 0 + while $chunk != 0 && ! $found + set $chunk_size = * (unsigned long *) ($chunk - 2 * $camlwordsize) + if $arg0 > $chunk && $arg0 <= $chunk + $chunk_size + printf "OLD" + set $found = 1 + end + set $chunk = * (unsigned long *) ($chunk - $camlwordsize) + end + if $found + set $camlheap_result = 1 + else + printf "OUT-OF-HEAP" + set $camlheap_result = 0 + end + end +end + +define camlint + if ($arg0 & $caml_unalloc_mask) == $caml_unalloc_value + printf "UNALLOCATED MEMORY" + else + printf "INT %ld", ($arg0 >> 1) + end + if ($arg0 & 0xFF) == 0xF9 && ($arg0 >> 10) < 0x1000000000000 + printf " [possible infix header]" + end +end + +define camlblock + printf "%#lx: ", $arg0 - $camlwordsize + camlheap $arg0 + printf " " + camlheader $arg0 + set $mysize = $size + set $camlnext = $arg0 + $camlwordsize * ($size + 1) + printf "\n" + + if $tag == 252 + x/s $arg0 + end + if $tag == 253 + x/f $arg0 + end + if $tag == 254 + while $count < $mysize && $count < 10 + if $count + 1 < $size + x/2f $arg0 + $camlwordsize * $count + else + x/f $arg0 + $camlwordsize * $count + end + set $count = $count + 2 + end + if $count < $mysize + printf "... truncated ...\n" + end + end + + if $tag == 249 + printf "... infix header, displaying enclosing block:\n" + set $mybaseaddr = $arg0 - $camlwordsize * $mysize + camlblock $mybaseaddr + # reset $tag, which was clobbered by the recursive call (yuck) + set $tag = 249 + end + + if $tag != 249 && $tag != 252 && $tag != 253 && $tag != 254 + set $isvalues = $tag < 251 + set $count = 0 + while $count < $mysize && $count < 10 + set $adr = $arg0 + $camlwordsize * $count + set $field = * (unsigned long *) $adr + printf "%#lx: [%d] 0x%016lx ", $adr, $count, $field + if ($field & 7) == 0 && $isvalues + camlheap $field + if $camlheap_result + printf " " + camlheader $field + end + end + if ($field & 1) == 1 + camlint $field + end + printf "\n" + set $count = $count + 1 + end + if $count < $mysize + printf "... truncated ...\n" + end + end + printf "next block head: %#lx value: %#lx\n", \ + $arg0 + $camlwordsize * $mysize, $arg0 + $camlwordsize * ($mysize+1) +end + +# displays an OCaml value +define caml + set $camllast = (long) $arg0 + if ($camllast & 1) == 1 + set $camlnext = 0 + camlint $camllast + printf "\n" + end + if ($camllast & 7) == 0 + camlblock $camllast + end + if ($camllast & 7) != 0 && ($camllast & 1) != 1 + set $camlnext = 0 + printf "invalid pointer: %#016lx\n", $camllast + end +end + +# displays the next OCaml value in memory +define camlnext + caml $camlnext +end + +# displays the n-th field of the previously displayed value +define camlfield + set $camlfield_addr = ((long *) $camllast)[$arg0] + caml $camlfield_addr +end + +# displays the list of heap chunks +define camlchunks + set $chunk = * (unsigned long *) &caml_heap_start + while $chunk != 0 + set $chunk_size = * (unsigned long *) ($chunk - 2 * $camlwordsize) + set $chunk_alloc = * (unsigned long *) ($chunk - 3 * $camlwordsize) + printf "chunk: addr = %#lx .. %#lx", $chunk, $chunk + $chunk_size + printf " (size = %#lx; alloc = %#lx)\n", $chunk_size, $chunk_alloc + set $chunk = * (unsigned long *) ($chunk - $camlwordsize) + end +end + +# walk the heap and launch command `camlvisitfun` on each block +# the variables `$hp` `$val` `$hd` `$tag` `$color` and `$size` +# are set before calling `camlvisitfun` +# `camlvisitfun` can set `$camlvisitstop` to stop the iteration + +define camlvisit + set $cvchunk = * (unsigned long *) &caml_heap_start + set $camlvisitstop = 0 + while $cvchunk != 0 && ! $camlvisitstop + set $cvchunk_size = * (unsigned long *) ($cvchunk - 2 * $camlwordsize) + set $cvhp = $cvchunk + while $cvhp < $cvchunk + $cvchunk_size && !$camlvisitstop + set $hp = $cvhp + set $val = $hp + $camlwordsize + set $hd = * (unsigned long *) $hp + set $tag = $hd & 0xFF + set $color = ($hd >> 8) & 3 + set $cvsize = $hd >> 10 + set $size = $cvsize + camlvisitfun + set $cvhp = $cvhp + (($cvsize + 1) * $camlwordsize) + end + set $cvchunk = * (unsigned long *) ($cvchunk - $camlwordsize) + end +end + +define caml_cv_check_fl0 + if $hp == * (unsigned long *) &caml_heap_start + set $flcheck_prev = ((unsigned long) &sentinels + 16) + end + if $color == 2 && $size > 5 + if $val != * (unsigned long *) $flcheck_prev + printf "free-list: missing link %#x -> %#x\n", $flcheck_prev, $val + set $camlvisitstop = 1 + end + set $flcheck_prev = $val + end +end + +define caml_check_fl + set $listsize = $arg0 + set $blueseen = $listsize == 0 + set $val = * (unsigned long *) ((long) &sentinels + 16 + 32 * $listsize) + while $val != 0 + printf "%#x\n", $val + set $hd = * (unsigned long *) ($val - 8) + set $color = ($hd >> 8) & 3 + if $blueseen && $color != 2 + printf "non-blue block at address %#x\n", $val + loop_break + else + set $blueseen = 1 + end + set $val = * (unsigned long *) $val + end +end diff --git a/tools/objinfo_helper.c b/tools/objinfo_helper.c index a8c79bd39d..ef7b7af7df 100644 --- a/tools/objinfo_helper.c +++ b/tools/objinfo_helper.c @@ -10,8 +10,8 @@ /***********************************************************************/ #include "../config/s.h" -#include "../byterun/mlvalues.h" -#include "../byterun/alloc.h" +#include "../byterun/caml/mlvalues.h" +#include "../byterun/caml/alloc.h" #include <stdio.h> #ifdef HAS_LIBBFD @@ -24,6 +24,8 @@ #include <bfd.h> #undef PACKAGE +#define plugin_header_sym (symbol_prefix "caml_plugin_header") + int main(int argc, char ** argv) { bfd *fd; @@ -74,14 +76,14 @@ int main(int argc, char ** argv) sym_count = bfd_canonicalize_dynamic_symtab (fd, symbol_table); for (i = 0; i < sym_count; i++) { - if (strcmp(symbol_table[i]->name, "caml_plugin_header") == 0) { + if (strcmp(symbol_table[i]->name, plugin_header_sym) == 0) { printf("%ld\n", (long) (offset + symbol_table[i]->value)); bfd_close(fd); return 0; } } - fprintf(stderr, "Error: missing symbol caml_plugin_header\n"); + fprintf(stderr, "Error: missing symbol %s\n", plugin_header_sym); bfd_close(fd); return 2; } diff --git a/tools/ocamlcp.ml b/tools/ocamlcp.ml index 51559aea3e..26ced6c567 100644 --- a/tools/ocamlcp.ml +++ b/tools/ocamlcp.ml @@ -61,12 +61,14 @@ module Options = Main_args.Make_bytecomp_options (struct let _impl s = with_impl := true; option_with_arg "-impl" s let _intf s = with_intf := true; option_with_arg "-intf" s let _intf_suffix s = option_with_arg "-intf-suffix" s + let _keep_docs = option "-keep-docs" let _keep_locs = option "-keep-locs" 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 _no_check_prims = option "-no-check-prims" let _noassert = option "-noassert" let _nolabels = option "-nolabels" let _noautolink = option "-noautolink" @@ -74,6 +76,7 @@ module Options = Main_args.Make_bytecomp_options (struct let _o s = option_with_arg "-o" s let _open s = option_with_arg "-open" s let _output_obj = option "-output-obj" + let _output_complete_obj = option "-output-complete-obj" let _pack = option "-pack" let _pp _s = incompatible "-pp" let _ppx _s = incompatible "-ppx" diff --git a/tools/ocamldep.ml b/tools/ocamldep.ml index db0695c9c7..0206846547 100644 --- a/tools/ocamldep.ml +++ b/tools/ocamldep.ml @@ -28,6 +28,7 @@ let sort_files = ref false let all_dependencies = ref false let one_line = ref false let files = ref [] +let allow_approximation = ref false (* Fix path to use '/' as directory separator instead of '\'. Only under Windows. *) @@ -78,7 +79,7 @@ let add_to_synonym_list synonyms suffix = (* Find file 'name' (capitalized) in search path *) let find_file name = - let uname = String.uncapitalize name in + let uname = String.uncapitalize_ascii name in let rec find_in_array a pos = if pos >= Array.length a then None else begin let s = a.(pos) in @@ -192,11 +193,15 @@ let print_raw_dependencies source_file deps = print_filename source_file; print_string depends_on; Depend.StringSet.iter (fun dep -> + (* filter out "*predef*" *) if (String.length dep > 0) - && (match dep.[0] with 'A'..'Z' -> true | _ -> false) then begin - print_char ' '; - print_string dep - end) + && (match dep.[0] with + | 'A'..'Z' | '\128'..'\255' -> true + | _ -> false) then + begin + print_char ' '; + print_string dep + end) deps; print_char '\n' @@ -217,6 +222,53 @@ let report_err exn = let tool_name = "ocamldep" +let rec lexical_approximation lexbuf = + (* Approximation when a file can't be parsed. + Heuristic: + - first component of any path starting with an uppercase character is a + dependency. + - always skip the token after a dot, unless dot is preceded by a + lower-case identifier + - always skip the token after a backquote + *) + try + let rec process after_lident lexbuf = + match Lexer.token lexbuf with + | Parser.UIDENT name -> + Depend.free_structure_names := + Depend.StringSet.add name !Depend.free_structure_names; + process false lexbuf + | Parser.LIDENT _ -> process true lexbuf + | Parser.DOT when after_lident -> process false lexbuf + | Parser.DOT | Parser.BACKQUOTE -> skip_one lexbuf + | Parser.EOF -> () + | _ -> process false lexbuf + and skip_one lexbuf = + match Lexer.token lexbuf with + | Parser.DOT | Parser.BACKQUOTE -> skip_one lexbuf + | Parser.EOF -> () + | _ -> process false lexbuf + + in + process false lexbuf + with Lexer.Error _ -> lexical_approximation lexbuf + +let read_and_approximate inputfile = + error_occurred := false; + let ic = open_in_bin inputfile in + try + seek_in ic 0; + Location.input_name := inputfile; + let lexbuf = Lexing.from_channel ic in + Location.init lexbuf inputfile; + lexical_approximation lexbuf; + close_in ic; + !Depend.free_structure_names + with exn -> + close_in ic; + report_err exn; + !Depend.free_structure_names + let read_parse_and_extract parse_function extract_function magic source_file = Depend.free_structure_names := Depend.StringSet.empty; try @@ -237,9 +289,12 @@ let read_parse_and_extract parse_function extract_function magic source_file = Pparse.remove_preprocessed input_file; raise x end - with x -> + with x -> begin report_err x; - Depend.StringSet.empty + if not !allow_approximation + then Depend.StringSet.empty + else read_and_approximate source_file + end let ml_file_dependencies source_file = let parse_use_file_as_impl lexbuf = @@ -331,7 +386,7 @@ let sort_files_by_dependencies files = (* Init Hashtbl with all defined modules *) let files = List.map (fun (file, file_kind, deps) -> let modname = - String.capitalize (Filename.chop_extension (Filename.basename file)) + String.capitalize_ascii (Filename.chop_extension (Filename.basename file)) in let key = (modname, file_kind) in let new_deps = ref [] in @@ -427,6 +482,8 @@ let _ = "<f> Process <f> as a .ml file"; "-intf", Arg.String (file_dependencies_as MLI), "<f> Process <f> as a .mli file"; + "-allow-approx", Arg.Set allow_approximation, + " Fallback to a lexer-based approximation on unparseable files."; "-ml-synonym", Arg.String(add_to_synonym_list ml_synonyms), "<e> Consider <e> as a synonym of the .ml extension"; "-mli-synonym", Arg.String(add_to_synonym_list mli_synonyms), diff --git a/tools/ocamlmklib.ml b/tools/ocamlmklib.ml index 77ae57becb..23a273ec12 100644 --- a/tools/ocamlmklib.ml +++ b/tools/ocamlmklib.ml @@ -27,14 +27,17 @@ and caml_opts = ref [] (* -ccopt to pass to ocamlc, ocamlopt *) and dynlink = ref supports_shared_libraries and failsafe = ref false (* whether to fall back on static build only *) and c_libs = ref [] (* libs to pass to mksharedlib and ocamlc -cclib *) -and c_Lopts = ref [] (* options to pass to mksharedlib and ocamlc -cclib *) -and c_opts = ref [] (* options to pass to mksharedlib and ocamlc -ccopt *) +and c_Lopts = ref [] (* options to pass to mksharedlib and ocamlc -cclib *) +and c_opts = ref [] (* options to pass to mksharedlib and ocamlc -ccopt *) and ld_opts = ref [] (* options to pass only to the linker *) and ocamlc = ref (compiler_path "ocamlc") +and ocamlc_opts = ref [] (* options to pass only to ocamlc *) and ocamlopt = ref (compiler_path "ocamlopt") +and ocamlopt_opts = ref [] (* options to pass only to ocamlc *) and output = ref "a" (* Output name for OCaml part of library *) and output_c = ref "" (* Output name for C part of library *) and rpath = ref [] (* rpath options *) +and debug = ref false (* -g option *) and verbose = ref false let starts_with s pref = @@ -84,6 +87,8 @@ let parse_arguments argv = caml_opts := next_arg () :: "-I" :: !caml_opts else if s = "-failsafe" then failsafe := true + else if s = "-g" then + debug := true else if s = "-h" || s = "-help" || s = "--help" then raise (Bad_argument "") else if s = "-ldopt" then @@ -96,10 +101,14 @@ let parse_arguments argv = (c_Lopts := s :: !c_Lopts; let l = chop_prefix s "-L" in if not (Filename.is_relative l) then rpath := l :: !rpath) + else if s = "-ocamlcflags" then + ocamlc_opts := next_arg () :: !ocamlc_opts else if s = "-ocamlc" then ocamlc := next_arg () else if s = "-ocamlopt" then ocamlopt := next_arg () + else if s = "-ocamloptflags" then + ocamlopt_opts := next_arg () :: !ocamlopt_opts else if s = "-o" then output := next_arg() else if s = "-oc" then @@ -148,7 +157,8 @@ Usage: ocamlmklib [options] <.cmo|.cma|.cmx|.cmxa|.ml|.mli|.o|.a|.obj|.lib|\ \nOptions are:\ \n -cclib <lib> C library passed to ocamlc -a or ocamlopt -a only\ \n -ccopt <opt> C option passed to ocamlc -a or ocamlopt -a only\ -\n -custom disable dynamic loading\ +\n -custom Disable dynamic loading\ +\n -g Build with debug information\ \n -dllpath <dir> Add <dir> to the run-time search path for DLLs\ \n -F<dir> Specify a framework directory (MacOSX)\ \n -framework <name> Use framework <name> (MacOSX)\ @@ -162,7 +172,9 @@ Usage: ocamlmklib [options] <.cmo|.cma|.cmx|.cmxa|.ml|.mli|.o|.a|.obj|.lib|\ \n -l<lib> Specify a dependent C library\ \n -L<dir> Add <dir> to the path searched for C libraries\ \n -ocamlc <cmd> Use <cmd> in place of \"ocamlc\"\ +\n -ocamlcflags <opt> Pass <opt> to ocamlc\ \n -ocamlopt <cmd> Use <cmd> in place of \"ocamlopt\"\ +\n -ocamloptflags <opt> Pass <opt> to ocamlopt\ \n -o <name> Generated OCaml library is named <name>.cma or <name>.cmxa\ \n -oc <name> Generated C library is named dll<name>.so or lib<name>.a\ \n -rpath <dir> Same as -dllpath <dir>\ @@ -229,8 +241,9 @@ let build_libs () = if !c_objs <> [] then begin if !dynlink then begin let retcode = command - (Printf.sprintf "%s -o %s %s %s %s %s %s" + (Printf.sprintf "%s %s -o %s %s %s %s %s %s" mkdll + (if !debug then "-g" else "") (prepostfix "dll" !output_c ext_dll) (String.concat " " !c_objs) (String.concat " " !c_opts) @@ -248,9 +261,11 @@ let build_libs () = end; if !bytecode_objs <> [] then scommand - (sprintf "%s -a %s -o %s.cma %s %s -dllib -l%s -cclib -l%s %s %s %s %s" + (sprintf "%s -a %s %s %s -o %s.cma %s %s -dllib -l%s -cclib -l%s %s %s %s %s" (transl_path !ocamlc) + (if !debug then "-g" else "") (if !dynlink then "" else "-custom") + (String.concat " " !ocamlc_opts) !output (String.concat " " !caml_opts) (String.concat " " !bytecode_objs) @@ -262,8 +277,10 @@ let build_libs () = (String.concat " " !caml_libs)); if !native_objs <> [] then scommand - (sprintf "%s -a -o %s.cmxa %s %s -cclib -l%s %s %s %s %s" + (sprintf "%s -a %s %s -o %s.cmxa %s %s -cclib -l%s %s %s %s %s" (transl_path !ocamlopt) + (if !debug then "-g" else "") + (String.concat " " !ocamlopt_opts) !output (String.concat " " !caml_opts) (String.concat " " !native_objs) diff --git a/tools/ocamloptp.ml b/tools/ocamloptp.ml index 0b788843fe..fd15fe5968 100644 --- a/tools/ocamloptp.ml +++ b/tools/ocamloptp.ml @@ -61,6 +61,7 @@ module Options = Main_args.Make_optcomp_options (struct let _inline n = option_with_int "-inline" n let _intf s = with_intf := true; option_with_arg "-intf" s let _intf_suffix s = option_with_arg "-intf-suffix" s + let _keep_docs = option "-keep-docs" let _keep_locs = option "-keep-locs" let _labels = option "-labels" let _linkall = option "-linkall" @@ -75,6 +76,7 @@ module Options = Main_args.Make_optcomp_options (struct let _o s = option_with_arg "-o" s let _open s = option_with_arg "-open" s let _output_obj = option "-output-obj" + let _output_complete_obj = option "-output-complete-obj" let _p = option "-p" let _pack = option "-pack" let _pp _s = incompatible "-pp" diff --git a/tools/tast_iter.ml b/tools/tast_iter.ml deleted file mode 100644 index be5b854419..0000000000 --- a/tools/tast_iter.ml +++ /dev/null @@ -1,394 +0,0 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* Alain Frisch, LexiFi *) -(* *) -(* Copyright 2012 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. *) -(* *) -(***********************************************************************) - -open Typedtree - -let opt f = function None -> () | Some x -> f x - -let structure sub str = - List.iter (sub # structure_item) str.str_items - -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_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 - | Tstr_open _ -> () - | Tstr_class list -> - 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 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) - decl.typ_cstrs; - begin match decl.typ_kind with - | Ttype_abstract -> () - | Ttype_variant list -> - List.iter (constructor_decl sub) list - | Ttype_record 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 _ - | Tpat_unpack -> () - | Tpat_constraint ct -> sub # core_type ct - in - List.iter (fun (c, _, _) -> extra c) pat.pat_extra; - match pat.pat_desc with - | Tpat_any - | Tpat_var _ - | Tpat_constant _ -> () - | Tpat_tuple l - | Tpat_construct (_, _, l) -> List.iter (sub # pattern) l - | Tpat_variant (_, po, _) -> opt (sub # pattern) po - | Tpat_record (l, _) -> List.iter (fun (_, _, pat) -> sub # pattern pat) l - | Tpat_array l -> List.iter (sub # pattern) l - | Tpat_or (p1, p2, _) -> sub # pattern p1; sub # pattern p2 - | Tpat_alias (p, _, _) - | Tpat_lazy p -> sub # pattern p - -let expression sub exp = - let extra = function - | Texp_constraint cty -> - sub # core_type cty - | Texp_coerce (cty1, cty2) -> - opt (sub # core_type) cty1; sub # core_type cty2 - | Texp_open _ - | Texp_newtype _ -> () - | Texp_poly cto -> opt (sub # core_type) cto - in - List.iter (fun (c, _, _) -> extra c) exp.exp_extra; - match exp.exp_desc with - | Texp_ident _ - | Texp_constant _ -> () - | Texp_let (rec_flag, list, exp) -> - sub # bindings (rec_flag, list); - sub # expression exp - | Texp_function (_, cases, _) -> - sub # cases cases - | Texp_apply (exp, list) -> - sub # expression exp; - List.iter (fun (_, expo, _) -> opt (sub # expression) expo) list - | Texp_match (exp, cases, exn_cases, _) -> - sub # expression exp; - sub # cases cases; - sub # cases exn_cases - | Texp_try (exp, cases) -> - sub # expression exp; - sub # cases cases - | Texp_tuple list -> - List.iter (sub # expression) list - | Texp_construct (_, _, args) -> - List.iter (sub # expression) args - | Texp_variant (_, expo) -> - opt (sub # expression) expo - | Texp_record (list, expo) -> - List.iter (fun (_, _, exp) -> sub # expression exp) list; - opt (sub # expression) expo - | Texp_field (exp, _, _label) -> - sub # expression exp - | Texp_setfield (exp1, _, _label, exp2) -> - sub # expression exp1; - sub # expression exp2 - | Texp_array list -> - List.iter (sub # expression) list - | Texp_ifthenelse (exp1, exp2, expo) -> - sub # expression exp1; - sub # expression exp2; - opt (sub # expression) expo - | Texp_sequence (exp1, exp2) -> - sub # expression exp1; - sub # expression exp2 - | Texp_while (exp1, exp2) -> - sub # expression exp1; - sub # expression exp2 - | Texp_for (_id, _, exp1, exp2, _dir, exp3) -> - sub # expression exp1; - sub # expression exp2; - sub # expression exp3 - | Texp_send (exp, _meth, expo) -> - sub # expression exp; - opt (sub # expression) expo - | Texp_new (_path, _, _) -> () - | Texp_instvar (_, _path, _) -> () - | Texp_setinstvar (_, _, _, exp) -> - sub # expression exp - | Texp_override (_, list) -> - List.iter (fun (_path, _, exp) -> sub # expression exp) list - | Texp_letmodule (_id, _, mexpr, exp) -> - sub # module_expr mexpr; - sub # expression exp - | Texp_assert exp -> sub # expression exp - | Texp_lazy exp -> sub # expression exp - | Texp_object (cl, _) -> - sub # class_structure cl - | Texp_pack (mexpr) -> - sub # module_expr mexpr - - -let package_type sub pack = - List.iter (fun (_s, ct) -> sub # core_type ct) pack.pack_fields - -let signature sub sg = - List.iter (sub # signature_item) sg.sig_items - -let signature_item sub item = - match item.sig_desc with - | Tsig_value v -> - sub # value_description v - | Tsig_type list -> - List.iter (sub # type_declaration) list - | 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 -> - List.iter (fun md -> sub # module_type md.md_type) list - | Tsig_modtype mtd -> - opt (sub # module_type) mtd.mtd_type - | Tsig_open _ -> () - | Tsig_include incl -> sub # module_type incl.incl_mod - | Tsig_class list -> - List.iter (sub # class_description) list - | Tsig_class_type list -> - List.iter (sub # class_type_declaration) list - | Tsig_attribute _ -> () - -let class_description sub cd = - sub # class_type cd.ci_expr - -let class_type_declaration sub cd = - sub # class_type cd.ci_expr - -let module_type sub mty = - match mty.mty_desc with - | Tmty_ident (_path, _) -> () - | Tmty_alias (_path, _) -> () - | Tmty_signature sg -> sub # signature sg - | Tmty_functor (_id, _, mtype1, mtype2) -> - Misc.may (sub # module_type) mtype1; sub # module_type mtype2 - | Tmty_with (mtype, list) -> - sub # module_type mtype; - List.iter (fun (_, _, withc) -> sub # with_constraint withc) list - | Tmty_typeof mexpr -> - sub # module_expr mexpr - -let with_constraint sub cstr = - match cstr with - | Twith_type decl -> sub # type_declaration decl - | Twith_module _ -> () - | Twith_typesubst decl -> sub # type_declaration decl - | Twith_modsubst _ -> () - -let module_expr sub mexpr = - match mexpr.mod_desc with - | Tmod_ident (_p, _) -> () - | Tmod_structure st -> sub # structure st - | Tmod_functor (_id, _, mtype, mexpr) -> - Misc.may (sub # module_type) mtype; - sub # module_expr mexpr - | Tmod_apply (mexp1, mexp2, _) -> - sub # module_expr mexp1; - sub # module_expr mexp2 - | Tmod_constraint (mexpr, _, Tmodtype_implicit, _ ) -> - sub # module_expr mexpr - | Tmod_constraint (mexpr, _, Tmodtype_explicit mtype, _) -> - sub # module_expr mexpr; - sub # module_type mtype - | Tmod_unpack (exp, _mty) -> - sub # expression exp -(* sub # module_type mty *) - -let module_binding sub mb = - module_expr sub mb.mb_expr - -let class_expr sub cexpr = - match cexpr.cl_desc with - | Tcl_constraint (cl, None, _, _, _ ) -> - sub # class_expr cl; - | Tcl_structure clstr -> sub # class_structure clstr - | Tcl_fun (_label, pat, priv, cl, _partial) -> - sub # pattern pat; - List.iter (fun (_id, _, exp) -> sub # expression exp) priv; - sub # class_expr cl - | Tcl_apply (cl, args) -> - sub # class_expr cl; - List.iter (fun (_label, expo, _) -> opt (sub # expression) expo) args - | Tcl_let (rec_flat, bindings, ivars, cl) -> - sub # bindings (rec_flat, bindings); - List.iter (fun (_id, _, exp) -> sub # expression exp) ivars; - sub # class_expr cl - | Tcl_constraint (cl, Some clty, _vals, _meths, _concrs) -> - sub # class_expr cl; - sub # class_type clty - | Tcl_ident (_, _, tyl) -> - List.iter (sub # core_type) tyl - -let class_type sub ct = - match ct.cltyp_desc with - | Tcty_signature csg -> sub # class_signature csg - | Tcty_constr (_path, _, list) -> List.iter (sub # core_type) list - | Tcty_arrow (_label, ct, cl) -> - sub # core_type ct; - sub # class_type cl - -let class_signature sub cs = - sub # core_type cs.csig_self; - List.iter (sub # class_type_field) cs.csig_fields - -let class_type_field sub ctf = - match ctf.ctf_desc with - | Tctf_inherit ct -> sub # class_type ct - | Tctf_val (_s, _mut, _virt, ct) -> - sub # core_type ct - | Tctf_method (_s, _priv, _virt, ct) -> - sub # core_type ct - | Tctf_constraint (ct1, ct2) -> - sub # core_type ct1; - sub # core_type ct2 - | Tctf_attribute _ -> () - -let core_type sub ct = - match ct.ctyp_desc with - | Ttyp_any -> () - | Ttyp_var _s -> () - | Ttyp_arrow (_label, ct1, ct2) -> - sub # core_type ct1; - sub # core_type ct2 - | Ttyp_tuple list -> List.iter (sub # core_type) list - | Ttyp_constr (_path, _, list) -> - List.iter (sub # core_type) list - | Ttyp_object (list, _o) -> - List.iter (fun (_, _, t) -> sub # core_type t) list - | Ttyp_class (_path, _, list) -> - List.iter (sub # core_type) list - | Ttyp_alias (ct, _s) -> - sub # core_type ct - | Ttyp_variant (list, _bool, _labels) -> - List.iter (sub # row_field) list - | Ttyp_poly (_list, ct) -> sub # core_type ct - | Ttyp_package pack -> sub # package_type pack - -let class_structure sub cs = - sub # pattern cs.cstr_self; - List.iter (sub # class_field) cs.cstr_fields - -let row_field sub rf = - match rf with - | Ttag (_label, _attrs, _bool, list) -> List.iter (sub # core_type) list - | Tinherit ct -> sub # core_type ct - -let class_field sub cf = - match cf.cf_desc with - | Tcf_inherit (_ovf, cl, _super, _vals, _meths) -> - sub # class_expr cl - | Tcf_constraint (cty, cty') -> - sub # core_type cty; - sub # core_type cty' - | Tcf_val (_, _, _mut, Tcfk_virtual cty, _override) -> - sub # core_type cty - | Tcf_val (_, _, _mut, Tcfk_concrete (_, exp), _override) -> - sub # expression exp - | Tcf_method (_, _priv, Tcfk_virtual cty) -> - sub # core_type cty - | Tcf_method (_, _priv, Tcfk_concrete (_, exp)) -> - sub # expression exp - | Tcf_initializer exp -> - sub # expression exp - | Tcf_attribute _ -> () - -let bindings sub (_rec_flag, list) = - List.iter (sub # binding) list - -let cases sub l = - List.iter (sub # case) l - -let case sub {c_lhs; c_guard; c_rhs} = - sub # pattern c_lhs; - opt (sub # expression) c_guard; - sub # expression c_rhs - -let binding sub vb = - sub # pattern vb.vb_pat; - sub # expression vb.vb_expr - -class iter = object(this) - method binding = binding this - method bindings = bindings this - method case = case this - method cases = cases this - method class_description = class_description this - method class_expr = class_expr this - method class_field = class_field this - method class_signature = class_signature this - method class_structure = class_structure this - method class_type = class_type this - method class_type_declaration = class_type_declaration 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 - method package_type = package_type this - method pattern = pattern this - method row_field = row_field this - method signature = signature this - method signature_item = signature_item 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 deleted file mode 100644 index 1d81afa568..0000000000 --- a/tools/tast_iter.mli +++ /dev/null @@ -1,82 +0,0 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* Alain Frisch, LexiFi *) -(* *) -(* Copyright 2012 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. *) -(* *) -(***********************************************************************) - -open Asttypes -open Typedtree - -class iter: object - method binding: value_binding -> unit - method bindings: (rec_flag * value_binding list) -> unit - method case: case -> unit - method cases: case list -> unit - method class_description: class_description -> unit - method class_expr: class_expr -> unit - method class_field: class_field -> unit - method class_signature: class_signature -> unit - method class_structure: class_structure -> unit - method class_type: class_type -> unit - method class_type_declaration: class_type_declaration -> unit - 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 - method package_type: package_type -> unit - method pattern: pattern -> unit - method row_field: row_field -> unit - method signature: signature -> unit - method signature_item: signature_item -> unit - 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 -(** Recursive iterator class. By inheriting from it and - overriding selected methods, it is possible to implement - custom behavior for specific kinds of nodes. *) - -(** {2 One-level iterators} *) - -(** The following functions apply the provided iterator to each - sub-component of the argument. *) - -val binding: iter -> value_binding -> unit -val bindings: iter -> (rec_flag * value_binding list) -> unit -val class_description: iter -> class_description -> unit -val class_expr: iter -> class_expr -> unit -val class_field: iter -> class_field -> unit -val class_signature: iter -> class_signature -> unit -val class_structure: iter -> class_structure -> unit -val class_type: iter -> class_type -> unit -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 -val package_type: iter -> package_type -> unit -val pattern: iter -> pattern -> unit -val row_field: iter -> row_field -> unit -val signature: iter -> signature -> unit -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 deleted file mode 100644 index 58242fc23e..0000000000 --- a/tools/untypeast.ml +++ /dev/null @@ -1,640 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Thomas Gazagnaire (OCamlPro), Fabrice Le Fessant (INRIA Saclay) *) -(* *) -(* Copyright 2007 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. *) -(* *) -(**************************************************************************) - -open Asttypes -open Typedtree -open Parsetree -open Ast_helper - -(* -Some notes: - - * For Pexp_function, we cannot go back to the exact original version - when there is a default argument, because the default argument is - translated in the typer. The code, if printed, will not be parsable because - new generated identifiers are not correct. - - * For Pexp_apply, it is unclear whether arguments are reordered, especially - when there are optional arguments. - - * TODO: check Ttype_variant -> Ptype_variant (stub None) - -*) - -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) - -let rec lident_of_path path = - match path with - Path.Pident id -> Longident.Lident (Ident.name id) - | Path.Pdot (p, s, _) -> Longident.Ldot (lident_of_path p, s) - | Path.Papply (p1, p2) -> - Longident.Lapply (lident_of_path p1, lident_of_path p2) - -let rec untype_structure str = - List.map untype_structure_item str.str_items - -and untype_structure_item item = - let desc = - match item.str_desc with - Tstr_eval (exp, attrs) -> Pstr_eval (untype_expression exp, attrs) - | Tstr_value (rec_flag, list) -> - Pstr_value (rec_flag, List.map untype_binding list) - | Tstr_primitive vd -> - Pstr_primitive (untype_value_description vd) - | Tstr_type list -> - Pstr_type (List.map untype_type_declaration list) - | 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; - pmtd_loc=mtd.mtd_loc;pmtd_attributes=mtd.mtd_attributes;} - | 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, _, _) -> untype_class_declaration ci) - list) - | Tstr_class_type list -> - 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 - { pstr_desc = desc; pstr_loc = item.str_loc; } - -and untype_value_description v = - { - pval_name = v.val_name; - pval_prim = v.val_prim; - pval_type = untype_core_type v.val_desc; - pval_loc = v.val_loc; - pval_attributes = v.val_attributes; - } - -and untype_module_binding mb = - { - pmb_name = mb.mb_name; - pmb_expr = untype_module_expr mb.mb_expr; - pmb_attributes = mb.mb_attributes; - pmb_loc = mb.mb_loc; - } - -and untype_type_declaration decl = - { - ptype_name = decl.typ_name; - 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) - ) decl.typ_cstrs; - ptype_kind = (match decl.typ_kind with - Ttype_abstract -> Ptype_abstract - | Ttype_variant list -> - Ptype_variant (List.map untype_constructor_declaration list) - | Ttype_record 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; - ptype_attributes = decl.typ_attributes; - 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 = 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 - { pat_extra=[Tpat_unpack, _, _attrs]; pat_desc = Tpat_var (_,name); _ } -> - Ppat_unpack name - | { pat_extra=[Tpat_type (_path, lid), _, _attrs]; _ } -> Ppat_type lid - | { pat_extra= (Tpat_constraint ct, _, _attrs) :: rem; _ } -> - Ppat_constraint (untype_pattern { pat with pat_extra=rem }, - untype_core_type ct) - | _ -> - match pat.pat_desc with - Tpat_any -> Ppat_any - | Tpat_var (id, name) -> - begin - match (Ident.name id).[0] with - 'A'..'Z' -> - Ppat_unpack name - | _ -> - Ppat_var name - end - | Tpat_alias (pat, _id, name) -> - Ppat_alias (untype_pattern pat, name) - | Tpat_constant cst -> Ppat_constant cst - | Tpat_tuple list -> - Ppat_tuple (List.map untype_pattern list) - | Tpat_construct (lid, _, args) -> - Ppat_construct (lid, - (match args with - [] -> None - | [arg] -> Some (untype_pattern arg) - | args -> - Some - (Pat.tuple ~loc:pat.pat_loc - (List.map untype_pattern args) - ) - )) - | Tpat_variant (label, pato, _) -> - Ppat_variant (label, option untype_pattern pato) - | Tpat_record (list, closed) -> - Ppat_record (List.map (fun (lid, _, pat) -> - lid, untype_pattern pat) list, closed) - | Tpat_array list -> Ppat_array (List.map untype_pattern list) - | 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 *) - -and untype_extra (extra, loc, attrs) sexp = - let desc = - match extra with - Texp_coerce (cty1, cty2) -> - Pexp_coerce (sexp, - option untype_core_type cty1, - untype_core_type cty2) - | Texp_constraint cty -> - Pexp_constraint (sexp, untype_core_type cty) - | Texp_open (ovf, _path, lid, _) -> Pexp_open (ovf, lid, sexp) - | Texp_poly cto -> Pexp_poly (sexp, option untype_core_type cto) - | Texp_newtype s -> Pexp_newtype (s, sexp) - in - Exp.mk ~loc ~attrs desc - -and untype_cases l = List.map untype_case l - -and untype_case {c_lhs; c_guard; c_rhs} = - { - pc_lhs = untype_pattern c_lhs; - pc_guard = option untype_expression c_guard; - pc_rhs = untype_expression c_rhs; - } - -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 = - let desc = - match exp.exp_desc with - Texp_ident (_path, lid, _) -> Pexp_ident (lid) - | Texp_constant cst -> Pexp_constant cst - | Texp_let (rec_flag, list, exp) -> - Pexp_let (rec_flag, - List.map untype_binding list, - untype_expression exp) - | Texp_function (label, [{c_lhs=p; c_guard=None; c_rhs=e}], _) -> - Pexp_fun (label, None, untype_pattern p, untype_expression e) - | Texp_function ("", cases, _) -> - Pexp_function (untype_cases cases) - | Texp_function _ -> - assert false - | Texp_apply (exp, list) -> - Pexp_apply (untype_expression exp, - List.fold_right (fun (label, expo, _) list -> - match expo with - None -> list - | Some exp -> (label, untype_expression exp) :: list - ) list []) - | 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 -> - Pexp_tuple (List.map untype_expression list) - | Texp_construct (lid, _, args) -> - Pexp_construct (lid, - (match args with - [] -> None - | [ arg ] -> Some (untype_expression arg) - | args -> - Some - (Exp.tuple ~loc:exp.exp_loc (List.map untype_expression args)) - )) - | Texp_variant (label, expo) -> - Pexp_variant (label, option untype_expression expo) - | Texp_record (list, expo) -> - Pexp_record (List.map (fun (lid, _, exp) -> - lid, untype_expression exp - ) list, - option untype_expression expo) - | Texp_field (exp, lid, _label) -> - Pexp_field (untype_expression exp, lid) - | Texp_setfield (exp1, lid, _label, exp2) -> - Pexp_setfield (untype_expression exp1, lid, - untype_expression exp2) - | Texp_array list -> - Pexp_array (List.map untype_expression list) - | Texp_ifthenelse (exp1, exp2, expo) -> - Pexp_ifthenelse (untype_expression exp1, - untype_expression exp2, - option untype_expression expo) - | Texp_sequence (exp1, exp2) -> - Pexp_sequence (untype_expression exp1, untype_expression exp2) - | Texp_while (exp1, exp2) -> - Pexp_while (untype_expression exp1, untype_expression exp2) - | Texp_for (_id, name, exp1, exp2, dir, exp3) -> - Pexp_for (name, - untype_expression exp1, untype_expression exp2, - dir, untype_expression exp3) - | Texp_send (exp, meth, _) -> - Pexp_send (untype_expression exp, match meth with - Tmeth_name name -> name - | Tmeth_val id -> Ident.name id) - | Texp_new (_path, lid, _) -> Pexp_new (lid) - | Texp_instvar (_, path, name) -> - Pexp_ident ({name with txt = lident_of_path path}) - | Texp_setinstvar (_, _path, lid, exp) -> - Pexp_setinstvar (lid, untype_expression exp) - | Texp_override (_, list) -> - Pexp_override (List.map (fun (_path, lid, exp) -> - lid, untype_expression exp - ) list) - | Texp_letmodule (_id, name, mexpr, exp) -> - Pexp_letmodule (name, untype_module_expr mexpr, - untype_expression exp) - | Texp_assert exp -> Pexp_assert (untype_expression exp) - | Texp_lazy exp -> Pexp_lazy (untype_expression exp) - | Texp_object (cl, _) -> - Pexp_object (untype_class_structure cl) - | Texp_pack (mexpr) -> - Pexp_pack (untype_module_expr mexpr) - in - List.fold_right untype_extra exp.exp_extra - (Exp.mk ~loc:exp.exp_loc ~attrs:exp.exp_attributes desc) - -and untype_package_type pack = - (pack.pack_txt, - List.map (fun (s, ct) -> - (s, untype_core_type ct)) pack.pack_fields) - -and untype_signature sg = - List.map untype_signature_item sg.sig_items - -and untype_signature_item item = - let desc = - match item.sig_desc with - Tsig_value v -> - Psig_value (untype_value_description v) - | Tsig_type list -> - Psig_type (List.map untype_type_declaration list) - | 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; - pmd_attributes = md.md_attributes; pmd_loc = md.md_loc; - } - | Tsig_recmodule list -> - Psig_recmodule (List.map (fun md -> - {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; - pmtd_attributes=mtd.mtd_attributes; pmtd_loc=mtd.mtd_loc} - | 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 -> - Psig_class_type (List.map untype_class_type_declaration list) - | Tsig_attribute x -> - Psig_attribute x - in - { psig_desc = desc; - 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 = 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; - pci_attributes = cd.ci_attributes; - } - -and untype_class_type_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_type cd.ci_expr; - pci_loc = cd.ci_loc; - pci_attributes = cd.ci_attributes; - } - -and untype_module_type mty = - let desc = match mty.mty_desc with - Tmty_ident (_path, lid) -> Pmty_ident (lid) - | Tmty_alias (_path, lid) -> Pmty_alias (lid) - | Tmty_signature sg -> Pmty_signature (untype_signature sg) - | Tmty_functor (_id, name, mtype1, mtype2) -> - Pmty_functor (name, Misc.may_map untype_module_type mtype1, - untype_module_type mtype2) - | Tmty_with (mtype, list) -> - Pmty_with (untype_module_type mtype, - List.map (fun (_path, lid, withc) -> - untype_with_constraint lid withc - ) list) - | Tmty_typeof mexpr -> - Pmty_typeof (untype_module_expr mexpr) - in - Mty.mk ~loc:mty.mty_loc desc - -and untype_with_constraint lid cstr = - match cstr with - Twith_type decl -> Pwith_type (lid, untype_type_declaration decl) - | Twith_module (_path, lid2) -> Pwith_module (lid, lid2) - | Twith_typesubst decl -> Pwith_typesubst (untype_type_declaration decl) - | Twith_modsubst (_path, lid2) -> - Pwith_modsubst ({loc = lid.loc; txt=Longident.last lid.txt}, lid2) - -and untype_module_expr mexpr = - match mexpr.mod_desc with - Tmod_constraint (m, _, Tmodtype_implicit, _ ) -> - untype_module_expr m - | _ -> - let desc = match mexpr.mod_desc with - Tmod_ident (_p, lid) -> Pmod_ident (lid) - | Tmod_structure st -> Pmod_structure (untype_structure st) - | Tmod_functor (_id, name, mtype, mexpr) -> - Pmod_functor (name, Misc.may_map untype_module_type mtype, - untype_module_expr mexpr) - | Tmod_apply (mexp1, mexp2, _) -> - Pmod_apply (untype_module_expr mexp1, untype_module_expr mexp2) - | Tmod_constraint (mexpr, _, Tmodtype_explicit mtype, _) -> - Pmod_constraint (untype_module_expr mexpr, - untype_module_type mtype) - | Tmod_constraint (_mexpr, _, Tmodtype_implicit, _) -> - assert false - | Tmod_unpack (exp, _pack) -> - Pmod_unpack (untype_expression exp) - (* TODO , untype_package_type pack) *) - - in - Mod.mk ~loc:mexpr.mod_loc desc - -and untype_class_expr cexpr = - let desc = match cexpr.cl_desc with - | Tcl_constraint ( { cl_desc = Tcl_ident (_path, lid, tyl); _ }, - None, _, _, _ ) -> - Pcl_constr (lid, - List.map untype_core_type tyl) - | Tcl_structure clstr -> Pcl_structure (untype_class_structure clstr) - - | Tcl_fun (label, pat, _pv, cl, _partial) -> - Pcl_fun (label, None, untype_pattern pat, untype_class_expr cl) - - | Tcl_apply (cl, args) -> - Pcl_apply (untype_class_expr cl, - List.fold_right (fun (label, expo, _) list -> - match expo with - None -> list - | Some exp -> (label, untype_expression exp) :: list - ) args []) - - | Tcl_let (rec_flat, bindings, _ivars, cl) -> - Pcl_let (rec_flat, - List.map untype_binding bindings, - untype_class_expr cl) - - | Tcl_constraint (cl, Some clty, _vals, _meths, _concrs) -> - Pcl_constraint (untype_class_expr cl, untype_class_type clty) - - | Tcl_ident _ -> assert false - | Tcl_constraint (_, None, _, _, _) -> assert false - in - { pcl_desc = desc; - pcl_loc = cexpr.cl_loc; - pcl_attributes = cexpr.cl_attributes; - } - -and untype_class_type ct = - let desc = match ct.cltyp_desc with - Tcty_signature csg -> Pcty_signature (untype_class_signature csg) - | Tcty_constr (_path, lid, list) -> - Pcty_constr (lid, List.map untype_core_type list) - | Tcty_arrow (label, ct, cl) -> - Pcty_arrow (label, untype_core_type ct, untype_class_type cl) - in - { pcty_desc = desc; - pcty_loc = ct.cltyp_loc; - pcty_attributes = ct.cltyp_attributes; - } - -and untype_class_signature cs = - { - pcsig_self = untype_core_type cs.csig_self; - pcsig_fields = List.map untype_class_type_field cs.csig_fields; - } - -and untype_class_type_field ctf = - let desc = match ctf.ctf_desc with - Tctf_inherit ct -> Pctf_inherit (untype_class_type ct) - | Tctf_val (s, mut, virt, ct) -> - Pctf_val (s, mut, virt, untype_core_type ct) - | Tctf_method (s, priv, virt, ct) -> - 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; - pctf_loc = ctf.ctf_loc; - pctf_attributes = ctf.ctf_attributes; - } - -and untype_core_type ct = - let desc = match ct.ctyp_desc with - Ttyp_any -> Ptyp_any - | Ttyp_var s -> Ptyp_var s - | Ttyp_arrow (label, ct1, ct2) -> - Ptyp_arrow (label, untype_core_type ct1, untype_core_type ct2) - | Ttyp_tuple list -> Ptyp_tuple (List.map untype_core_type list) - | Ttyp_constr (_path, lid, list) -> - Ptyp_constr (lid, - List.map untype_core_type list) - | Ttyp_object (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) -> - Ptyp_alias (untype_core_type ct, s) - | Ttyp_variant (list, bool, labels) -> - Ptyp_variant (List.map untype_row_field list, bool, labels) - | Ttyp_poly (list, ct) -> Ptyp_poly (list, untype_core_type ct) - | Ttyp_package pack -> Ptyp_package (untype_package_type pack) - in - Typ.mk ~loc:ct.ctyp_loc desc - -and untype_class_structure cs = - 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, 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) -> - Pcf_inherit (ovf, untype_class_expr cl, super) - | Tcf_constraint (cty, cty') -> - Pcf_constraint (untype_core_type cty, untype_core_type cty') - | Tcf_val (lab, mut, _, Tcfk_virtual cty, _) -> - Pcf_val (lab, mut, Cfk_virtual (untype_core_type cty)) - | Tcf_val (lab, mut, _, Tcfk_concrete (o, exp), _) -> - Pcf_val (lab, mut, Cfk_concrete (o, untype_expression exp)) - | 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 -> - 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 deleted file mode 100644 index efd0a031d5..0000000000 --- a/tools/untypeast.mli +++ /dev/null @@ -1,20 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Thomas Gazagnaire (OCamlPro), Fabrice Le Fessant (INRIA Saclay) *) -(* *) -(* Copyright 2007 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. *) -(* *) -(**************************************************************************) - -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_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 a893c60ddc..0d01b3290b 100644 --- a/toplevel/expunge.ml +++ b/toplevel/expunge.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* "Expunge" a toplevel by removing compiler modules from the global List.map. +(* "Expunge" a toplevel by removing compiler modules from the global map. Usage: expunge <source file> <dest file> <names of modules to keep> *) open Misc @@ -44,7 +44,7 @@ let main () = let input_name = Sys.argv.(1) in let output_name = Sys.argv.(2) in for i = (if negate then 4 else 3) to Array.length Sys.argv - 1 do - to_keep := StringSet.add (String.capitalize Sys.argv.(i)) !to_keep + to_keep := StringSet.add (String.capitalize_ascii Sys.argv.(i)) !to_keep done; let ic = open_in_bin input_name in Bytesections.read_toc ic; diff --git a/toplevel/genprintval.ml b/toplevel/genprintval.ml index 9af483ca99..b8a03736a0 100644 --- a/toplevel/genprintval.ml +++ b/toplevel/genprintval.ml @@ -37,11 +37,25 @@ module type EVALPATH = val same_value: valu -> valu -> bool end +type ('a, 'b) gen_printer = + | Zero of 'b + | Succ of ('a -> ('a, 'b) gen_printer) + module type S = sig type t val install_printer : Path.t -> Types.type_expr -> (formatter -> t -> unit) -> unit + val install_generic_printer : + Path.t -> Path.t -> + (int -> (int -> t -> Outcometree.out_value, + t -> Outcometree.out_value) gen_printer) -> + unit + val install_generic_printer' : + Path.t -> Path.t -> + (formatter -> t -> unit, + formatter -> t -> unit) gen_printer -> + unit val remove_printer : Path.t -> unit val outval_of_untyped_exception : t -> Outcometree.out_value val outval_of_value : @@ -50,8 +64,12 @@ module type S = Env.t -> t -> type_expr -> Outcometree.out_value end -module ObjTbl = Hashtbl.Make(struct - type t = Obj.t +module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct + + type t = O.t + + module ObjTbl = Hashtbl.Make(struct + type t = O.t let equal = (==) let hash x = try @@ -59,9 +77,6 @@ module ObjTbl = Hashtbl.Make(struct with exn -> 0 end) -module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct - - type t = O.t (* Given an exception value, we cannot recover its type, hence we cannot print its arguments in general. @@ -104,47 +119,74 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct (* The user-defined printers. Also used for some builtin types. *) + type printer = + | Simple of Types.type_expr * (O.t -> Outcometree.out_value) + | Generic of Path.t * (int -> (int -> O.t -> Outcometree.out_value, + O.t -> Outcometree.out_value) gen_printer) + let printers = ref ([ - Pident(Ident.create "print_int"), Predef.type_int, - (fun x -> Oval_int (O.obj x : int)); - Pident(Ident.create "print_float"), Predef.type_float, - (fun x -> Oval_float (O.obj x : float)); - Pident(Ident.create "print_char"), Predef.type_char, - (fun x -> Oval_char (O.obj x : char)); - Pident(Ident.create "print_string"), Predef.type_string, - (fun x -> Oval_string (O.obj x : string)); - Pident(Ident.create "print_int32"), Predef.type_int32, - (fun x -> Oval_int32 (O.obj x : int32)); - Pident(Ident.create "print_nativeint"), Predef.type_nativeint, - (fun x -> Oval_nativeint (O.obj x : nativeint)); - Pident(Ident.create "print_int64"), Predef.type_int64, - (fun x -> Oval_int64 (O.obj x : int64)) - ] : (Path.t * type_expr * (O.t -> Outcometree.out_value)) list) + ( Pident(Ident.create "print_int"), + Simple (Predef.type_int, + (fun x -> Oval_int (O.obj x : int))) ); + ( Pident(Ident.create "print_float"), + Simple (Predef.type_float, + (fun x -> Oval_float (O.obj x : float))) ); + ( Pident(Ident.create "print_char"), + Simple (Predef.type_char, + (fun x -> Oval_char (O.obj x : char))) ); + ( Pident(Ident.create "print_string"), + Simple (Predef.type_string, + (fun x -> Oval_string (O.obj x : string))) ); + ( Pident(Ident.create "print_int32"), + Simple (Predef.type_int32, + (fun x -> Oval_int32 (O.obj x : int32))) ); + ( Pident(Ident.create "print_nativeint"), + Simple (Predef.type_nativeint, + (fun x -> Oval_nativeint (O.obj x : nativeint))) ); + ( Pident(Ident.create "print_int64"), + Simple (Predef.type_int64, + (fun x -> Oval_int64 (O.obj x : int64)) )) + ] : (Path.t * printer) list) + + let exn_printer ppf path = + fprintf ppf "<printer %a raised an exception>" Printtyp.path path + + let out_exn path = + Oval_printer (fun ppf -> exn_printer ppf path) let install_printer path ty fn = let print_val ppf obj = - try fn ppf obj with - | exn -> - fprintf ppf "<printer %a raised an exception>" Printtyp.path path in + try fn ppf obj with exn -> exn_printer ppf path in let printer obj = Oval_printer (fun ppf -> print_val ppf obj) in - printers := (path, ty, printer) :: !printers + printers := (path, Simple (ty, printer)) :: !printers + + let install_generic_printer function_path constr_path fn = + printers := (function_path, Generic (constr_path, fn)) :: !printers + + let install_generic_printer' function_path ty_path fn = + let rec build gp depth = + match gp with + | Zero fn -> + let out_printer obj = + let printer ppf = + try fn ppf obj with _ -> exn_printer ppf function_path in + Oval_printer printer in + Zero out_printer + | Succ fn -> + let print_val fn_arg = + let print_arg ppf o = + !Oprint.out_value ppf (fn_arg (depth+1) o) in + build (fn print_arg) depth in + Succ print_val in + printers := (function_path, Generic (ty_path, build fn)) :: !printers let remove_printer path = let rec remove = function | [] -> raise Not_found - | (p, ty, fn as printer) :: rem -> + | ((p, _) as printer) :: rem -> if Path.same p path then rem else printer :: remove rem in printers := remove !printers - let find_printer env ty = - let rec find = function - | [] -> raise Not_found - | (name, sch, printer) :: remainder -> - if Ctype.moregeneral env false sch ty - then printer - else find remainder - in find !printers - (* Print a constructor or label, giving it the same prefix as the type it comes from. Attempt to omit the prefix if the type comes from a module that has been opened. *) @@ -184,8 +226,8 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct 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 + let repr = obj in + if not (O.is_block repr) then f depth obj ty else if ObjTbl.mem nested_values repr then @@ -205,7 +247,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct if !printer_steps < 0 || depth < 0 then Oval_ellipsis else begin try - find_printer env ty obj + find_printer depth env ty obj with Not_found -> match (Ctype.repr ty).desc with | Tvar _ | Tunivar _ -> @@ -258,12 +300,58 @@ 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.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>" + let obj_tag = O.tag obj in + (* Lazy values are represented in three possible ways: + + 1. a lazy thunk that is not yet forced has tag + Obj.lazy_tag + + 2. a lazy thunk that has just been forced has tag + Obj.forward_tag; its first field is the forced + result, which we can print + + 3. when the GC moves a forced trunk with forward_tag, + or when a thunk is directly created from a value, + we get a third representation where the value is + directly exposed, without the Obj.forward_tag + (if its own tag is not ambiguous, that is neither + lazy_tag nor forward_tag) + + Note that using Lazy.is_val and Lazy.force would be + unsafe, because they use the Obj.* functions rather + than the O.* functions of the functor argument, and + would thus crash if called from the toplevel + (debugger/printval instantiates Genprintval.Make with + an Obj module talking over a socket). + *) + if obj_tag = Obj.lazy_tag then Oval_stuff "<lazy>" + else begin + let forced_obj = + if obj_tag = Obj.forward_tag then O.field obj 0 else obj + in + (* calling oneself recursively on forced_obj risks + having a false positive for cycle detection; + indeed, in case (3) above, the value is stored + as-is instead of being wrapped in a forward + pointer. It means that, for (lazy "foo"), we have + forced_obj == obj + and it is easy to wrongly print (lazy <cycle>) in such + a case (PR#6669). + + Unfortunately, there is a corner-case that *is* + a real cycle: using -rectypes one can define + let rec x = lazy x + which creates a Forward_tagged block that points to + itself. For this reason, we still "nest" + (detect head cycles) on forward tags. + *) + let v = + if obj_tag = Obj.forward_tag + then nest tree_of_val depth forced_obj ty_arg + else tree_of_val depth forced_obj ty_arg + in + Oval_constr (Oide_ident "lazy", [v]) + end | Tconstr(path, ty_list, _) -> begin try let decl = Env.find_type path env in @@ -451,6 +539,35 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct | None -> Oval_stuff "<extension>" + and find_printer depth env ty = + let rec find = function + | [] -> raise Not_found + | (name, Simple (sch, printer)) :: remainder -> + if Ctype.moregeneral env false sch ty + then printer + else find remainder + | (name, Generic (path, fn)) :: remainder -> + begin match (Ctype.expand_head env ty).desc with + | Tconstr (p, args, _) when Path.same p path -> + begin try apply_generic_printer path (fn depth) args + with _ -> (fun obj -> out_exn path) end + | _ -> find remainder end in + find !printers + + and apply_generic_printer path printer args = + match (printer, args) with + | (Zero fn, []) -> (fun (obj : O.t)-> try fn obj with _ -> out_exn path) + | (Succ fn, arg :: args) -> + let printer = fn (fun depth obj -> tree_of_val depth obj arg) in + apply_generic_printer path printer args + | _ -> + (fun obj -> + let printer ppf = + fprintf ppf "<internal error: incorrect arity for '%a'>" + Printtyp.path path in + Oval_printer printer) + + in nest tree_of_val max_depth obj ty end diff --git a/toplevel/genprintval.mli b/toplevel/genprintval.mli index 3f7b85ab69..1c2ec471b8 100644 --- a/toplevel/genprintval.mli +++ b/toplevel/genprintval.mli @@ -33,11 +33,28 @@ module type EVALPATH = val same_value: valu -> valu -> bool end +type ('a, 'b) gen_printer = + | Zero of 'b + | Succ of ('a -> ('a, 'b) gen_printer) + module type S = sig type t val install_printer : Path.t -> Types.type_expr -> (formatter -> t -> unit) -> unit + val install_generic_printer : + Path.t -> Path.t -> + (int -> (int -> t -> Outcometree.out_value, + t -> Outcometree.out_value) gen_printer) -> + unit + val install_generic_printer' : + Path.t -> Path.t -> + (formatter -> t -> unit, + formatter -> t -> unit) gen_printer -> + unit + (** [install_generic_printer' function_path constructor_path printer] + function_path is used to remove the printer. *) + val remove_printer : Path.t -> unit val outval_of_untyped_exception : t -> Outcometree.out_value val outval_of_value : diff --git a/toplevel/opttoploop.ml b/toplevel/opttoploop.ml index 9e9e3d7447..7090129780 100644 --- a/toplevel/opttoploop.ml +++ b/toplevel/opttoploop.ml @@ -136,7 +136,7 @@ let load_lambda ppf (size, lam) = else Filename.temp_file ("caml" ^ !phrase_name) ext_dll in let fn = Filename.chop_extension dll in - Asmgen.compile_implementation ~toplevel:need_symbol fn ppf (size, lam); + Asmgen.compile_implementation ~toplevel:need_symbol fn ppf (size, slam); Asmlink.call_linker_shared [fn ^ ext_obj] dll; Sys.remove (fn ^ ext_obj); @@ -451,7 +451,14 @@ let run_script ppf name args = Array.blit args 0 Sys.argv 0 len; Obj.truncate (Obj.repr Sys.argv) len; Arg.current := 0; - Compmisc.init_path true; + Compmisc.init_path ~dir:(Filename.dirname name) true; + (* Note: would use [Filename.abspath] here, if we had it. *) toplevel_env := Compmisc.initial_env(); Sys.interactive := false; - use_silently ppf name + let explicit_name = + (* Prevent use_silently from searching in the path. *) + if Filename.is_implicit name + then Filename.concat Filename.current_dir_name name + else name + in + use_silently ppf explicit_name diff --git a/toplevel/topdirs.ml b/toplevel/topdirs.ml index 5f347a77de..ffe14577ca 100644 --- a/toplevel/topdirs.ml +++ b/toplevel/topdirs.ml @@ -86,11 +86,19 @@ let load_compunit ic filename ppf compunit = let initial_symtable = Symtable.current_state() in Symtable.patch_object code compunit.cu_reloc; Symtable.update_global_table(); + let events = + if compunit.cu_debug = 0 then [| |] + else begin + seek_in ic compunit.cu_debug; + [| input_value ic |] + end in + Meta.add_debug_info code code_size events; begin try may_trace := true; ignore((Meta.reify_bytecode code code_size) ()); may_trace := false; with exn -> + record_backtrace (); may_trace := false; Symtable.restore_state initial_symtable; print_exception_outcome ppf exn; @@ -185,17 +193,40 @@ let _ = Hashtbl.add directive_table "mod_use" (* Install, remove a printer *) +let filter_arrow ty = + let ty = Ctype.expand_head !toplevel_env ty in + match ty.desc with + | Tarrow (lbl, l, r, _) when not (Btype.is_optional lbl) -> Some (l, r) + | _ -> None + +let rec extract_last_arrow desc = + match filter_arrow desc with + | None -> raise (Ctype.Unify []) + | Some (_, r as res) -> + try extract_last_arrow r + with Ctype.Unify _ -> res + +let extract_target_type ty = fst (extract_last_arrow ty) +let extract_target_parameters ty = + let ty = extract_target_type ty |> Ctype.expand_head !toplevel_env in + match ty.desc with + | Tconstr (path, (_ :: _ as args), _) + when Ctype.all_distinct_vars !toplevel_env args -> Some (path, args) + | _ -> None + type 'a printer_type_new = Format.formatter -> 'a -> unit type 'a printer_type_old = 'a -> unit -let match_printer_type ppf desc typename = +let printer_type ppf typename = let (printer_type, _) = try Env.lookup_type (Ldot(Lident "Topdirs", typename)) !toplevel_env with Not_found -> fprintf ppf "Cannot find type Topdirs.%s.@." typename; raise Exit in - Ctype.init_def(Ident.current_time()); + printer_type + +let match_simple_printer_type ppf desc printer_type = Ctype.begin_def(); let ty_arg = Ctype.newvar() in Ctype.unify !toplevel_env @@ -203,16 +234,45 @@ let match_printer_type ppf desc typename = (Ctype.instance_def desc.val_type); Ctype.end_def(); Ctype.generalize ty_arg; - ty_arg + (ty_arg, None) + +let match_generic_printer_type ppf desc path args printer_type = + Ctype.begin_def(); + let args = List.map (fun _ -> Ctype.newvar ()) args in + let ty_target = Ctype.newty (Tconstr (path, args, ref Mnil)) in + let ty_args = + List.map (fun ty_var -> Ctype.newconstr printer_type [ty_var]) args in + let ty_expected = + List.fold_right + (fun ty_arg ty -> Ctype.newty (Tarrow (Asttypes.Nolabel, ty_arg, ty, Cunknown))) + ty_args (Ctype.newconstr printer_type [ty_target]) in + Ctype.unify !toplevel_env + ty_expected + (Ctype.instance_def desc.val_type); + Ctype.end_def(); + Ctype.generalize ty_expected; + if not (Ctype.all_distinct_vars !toplevel_env args) then + raise (Ctype.Unify []); + (ty_expected, Some (path, ty_args)) + +let match_printer_type ppf desc = + let printer_type_new = printer_type ppf "printer_type_new" in + let printer_type_old = printer_type ppf "printer_type_old" in + Ctype.init_def(Ident.current_time()); + match extract_target_parameters desc.val_type with + | None -> + (try + (match_simple_printer_type ppf desc printer_type_new, false) + with Ctype.Unify _ -> + (match_simple_printer_type ppf desc printer_type_old, true)) + | Some (path, args) -> + (* only 'new' style is available for generic printers *) + match_generic_printer_type ppf desc path args printer_type_new, false let find_printer_type ppf lid = try let (path, desc) = Env.lookup_value lid !toplevel_env in - let (ty_arg, is_old_style) = - try - (match_printer_type ppf desc "printer_type_new", false) - with Ctype.Unify _ -> - (match_printer_type ppf desc "printer_type_old", true) in + let (ty_arg, is_old_style) = match_printer_type ppf desc in (ty_arg, path, is_old_style) with | Not_found -> @@ -225,14 +285,30 @@ let find_printer_type ppf lid = let dir_install_printer ppf lid = try - let (ty_arg, path, is_old_style) = find_printer_type ppf lid in + let ((ty_arg, ty), path, is_old_style) = + find_printer_type ppf lid in let v = eval_path !toplevel_env path in - let print_function = - if is_old_style then - (fun formatter repr -> Obj.obj v (Obj.obj repr)) - else - (fun formatter repr -> Obj.obj v formatter (Obj.obj repr)) in - install_printer path ty_arg print_function + match ty with + | None -> + let print_function = + if is_old_style then + (fun formatter repr -> Obj.obj v (Obj.obj repr)) + else + (fun formatter repr -> Obj.obj v formatter (Obj.obj repr)) in + install_printer path ty_arg print_function + | Some (ty_path, ty_args) -> + let rec build v = function + | [] -> + let print_function = + if is_old_style then + (fun formatter repr -> Obj.obj v (Obj.obj repr)) + else + (fun formatter repr -> Obj.obj v formatter (Obj.obj repr)) in + Zero print_function + | _ :: args -> + Succ + (fun fn -> build ((Obj.obj v : _ -> Obj.t) fn) args) in + install_generic_printer' path ty_path (build v ty_args) with Exit -> () let dir_remove_printer ppf lid = @@ -327,19 +403,14 @@ let parse_warnings ppf iserr s = (* 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}, + Sig_module (id, {md with md_attributes = + (Location.mknoloc "...", Parsetree.PStr []) :: md.md_attributes}, rs) (*| Sig_modtype (id, Modtype_manifest mty) -> Sig_modtype (id, Modtype_manifest (trim_modtype mty))*) @@ -361,7 +432,8 @@ let show_prim to_sig ppf lid = in let id = Ident.create_persistent s in let sg = to_sig env loc id lid in - fprintf ppf "@[%a@]@." Printtyp.signature sg + Printtyp.wrap_printing_env env + (fun () -> fprintf ppf "@[%a@]@." Printtyp.signature sg) with | Not_found -> fprintf ppf "@[Unknown element.@]@." diff --git a/toplevel/toploop.ml b/toplevel/toploop.ml index 66a2b1abe3..296e1cc430 100644 --- a/toplevel/toploop.ml +++ b/toplevel/toploop.ml @@ -96,7 +96,13 @@ let outval_of_value env obj ty = let print_value env obj ppf ty = !print_out_value ppf (outval_of_value env obj ty) +type ('a, 'b) gen_printer = ('a, 'b) Genprintval.gen_printer = + | Zero of 'b + | Succ of ('a -> ('a, 'b) gen_printer) + let install_printer = Printer.install_printer +let install_generic_printer = Printer.install_generic_printer +let install_generic_printer' = Printer.install_generic_printer' let remove_printer = Printer.remove_printer (* Hooks for parsing functions *) @@ -110,7 +116,7 @@ let input_name = Location.input_name let parse_mod_use_file name lb = let modname = - String.capitalize (Filename.chop_extension (Filename.basename name)) + String.capitalize_ascii (Filename.chop_extension (Filename.basename name)) in let items = List.concat @@ -136,6 +142,12 @@ let toplevel_startup_hook = ref (fun () -> ()) let may_trace = ref false (* Global lock on tracing *) type evaluation_outcome = Result of Obj.t | Exception of exn +let backtrace = ref None + +let record_backtrace () = + if Printexc.backtrace_status () + then backtrace := Some (Printexc.get_backtrace ()) + let load_lambda ppf lam = if !Clflags.dump_rawlambda then fprintf ppf "%a@." Printlambda.lambda lam; let slam = Simplif.simplify_lambda lam in @@ -145,7 +157,8 @@ let load_lambda ppf lam = fprintf ppf "%a%a@." Printinstr.instrlist init_code Printinstr.instrlist fun_code; - let (code, code_size, reloc) = Emitcode.to_memory init_code fun_code in + let (code, code_size, reloc, events) = Emitcode.to_memory init_code fun_code in + Meta.add_debug_info code code_size [| events |]; let can_free = (fun_code = []) in let initial_symtable = Symtable.current_state() in Symtable.patch_object code reloc; @@ -157,13 +170,16 @@ let load_lambda ppf lam = let retval = (Meta.reify_bytecode code code_size) () in may_trace := false; if can_free then begin + Meta.remove_debug_info code; Meta.static_release_bytecode code code_size; Meta.static_free code; end; Result retval with x -> may_trace := false; + record_backtrace (); if can_free then begin + Meta.remove_debug_info code; Meta.static_release_bytecode code code_size; Meta.static_free code; end; @@ -194,7 +210,14 @@ let print_out_exception ppf exn outv = let print_exception_outcome ppf exn = if exn = Out_of_memory then Gc.full_major (); let outv = outval_of_value !toplevel_env (Obj.repr exn) Predef.type_exn in - print_out_exception ppf exn outv + print_out_exception ppf exn outv; + if Printexc.backtrace_status () + then + match !backtrace with + | None -> () + | Some b -> + print_string b; + backtrace := None (* The table of toplevel directives. Filled by functions from module topdirs. *) @@ -240,6 +263,15 @@ let execute_phrase print_outcome ppf phr = Ophr_exception (exn, outv) in !print_out_phrase ppf out_phr; + if Printexc.backtrace_status () + then begin + match !backtrace with + | None -> () + | Some b -> + pp_print_string ppf b; + pp_print_flush ppf (); + backtrace := None; + end; begin match out_phr with | Ophr_eval (_, _) | Ophr_signature _ -> true | Ophr_exception _ -> false @@ -391,6 +423,7 @@ let refill_lexbuf buffer len = can call directives from Topdirs. *) let _ = + Clflags.debug := true; Sys.interactive := true; let crc_intfs = Symtable.init_toplevel() in Compmisc.init_path false; @@ -432,6 +465,7 @@ let initialize_toplevel_env () = exception PPerror let loop ppf = + Location.formatter_for_warnings := ppf; fprintf ppf " OCaml version %s@.@." Config.version; initialize_toplevel_env (); let lb = Lexing.from_function refill_lexbuf in @@ -465,7 +499,14 @@ let run_script ppf name args = Array.blit args 0 Sys.argv 0 len; Obj.truncate (Obj.repr Sys.argv) len; Arg.current := 0; - Compmisc.init_path false; + Compmisc.init_path ~dir:(Filename.dirname name) true; + (* Note: would use [Filename.abspath] here, if we had it. *) toplevel_env := Compmisc.initial_env(); Sys.interactive := false; - use_silently ppf name + let explicit_name = + (* Prevent use_silently from searching in the path. *) + if Filename.is_implicit name + then Filename.concat Filename.current_dir_name name + else name + in + use_silently ppf explicit_name diff --git a/toplevel/toploop.mli b/toplevel/toploop.mli index 1867c001ed..704edb1077 100644 --- a/toplevel/toploop.mli +++ b/toplevel/toploop.mli @@ -65,14 +65,26 @@ val mod_use_file : formatter -> string -> bool [mod_use_file] wrap the file contents into a module. *) val eval_path: Env.t -> Path.t -> Obj.t (* Return the toplevel object referred to by the given path *) +val record_backtrace : unit -> unit (* Printing of values *) val print_value: Env.t -> Obj.t -> formatter -> Types.type_expr -> unit val print_untyped_exception: formatter -> Obj.t -> unit +type ('a, 'b) gen_printer = + | Zero of 'b + | Succ of ('a -> ('a, 'b) gen_printer) + val install_printer : Path.t -> Types.type_expr -> (formatter -> Obj.t -> unit) -> unit +val install_generic_printer : + Path.t -> Path.t -> + (int -> (int -> Obj.t -> Outcometree.out_value, + Obj.t -> Outcometree.out_value) gen_printer) -> unit +val install_generic_printer' : + Path.t -> Path.t -> (formatter -> Obj.t -> unit, + formatter -> Obj.t -> unit) gen_printer -> unit val remove_printer : Path.t -> unit val max_printer_depth: int ref diff --git a/toplevel/trace.ml b/toplevel/trace.ml index 6690448363..8c5fabecca 100644 --- a/toplevel/trace.ml +++ b/toplevel/trace.ml @@ -52,7 +52,8 @@ let set_code_pointer cls ptr = Obj.set_field cls 0 ptr let invoke_traced_function codeptr env arg = Meta.invoke_traced_function codeptr env arg -let print_label ppf l = if l <> "" then fprintf ppf "%s:" l +let print_label ppf l = + if l <> Asttypes.Nolabel then fprintf ppf "%s:" (Printtyp.string_of_label l) (* If a function returns a functional value, wrap it into a trace code *) diff --git a/typing/btype.ml b/typing/btype.ml index f23b7387b0..7627913c9e 100644 --- a/typing/btype.ml +++ b/typing/btype.ml @@ -13,6 +13,7 @@ (* Basic operations on core types *) open Misc +open Asttypes open Types (**** Sets, maps and hashtables of types ****) @@ -561,15 +562,17 @@ let check_memorized_abbrevs () = (* Utilities for labels *) (**********************************) -let is_optional l = - String.length l > 0 && l.[0] = '?' +let is_optional = function Optional _ -> true | _ -> false -let label_name l = - if is_optional l then String.sub l 1 (String.length l - 1) - else l +let label_name = function + Nolabel -> "" + | Labelled s + | Optional s -> s -let prefixed_label_name l = - if is_optional l then l else "~" ^ l +let prefixed_label_name = function + Nolabel -> "" + | Labelled s -> "~" ^ s + | Optional s -> "?" ^ s let rec extract_label_aux hd l = function [] -> raise Not_found diff --git a/typing/btype.mli b/typing/btype.mli index ec63e9ae63..4e1b1413c3 100644 --- a/typing/btype.mli +++ b/typing/btype.mli @@ -162,15 +162,15 @@ val forget_abbrev: (**** Utilities for labels ****) -val is_optional : label -> bool -val label_name : label -> label +val is_optional : arg_label -> bool +val label_name : arg_label -> label (* Returns the label name with first character '?' or '~' as appropriate. *) -val prefixed_label_name : label -> label +val prefixed_label_name : arg_label -> label val extract_label : - label -> (label * 'a) list -> - label * 'a * (label * 'a) list * (label * 'a) list + label -> (arg_label * 'a) list -> + arg_label * 'a * (arg_label * 'a) list * (arg_label * 'a) list (* actual label, value, before list, after list *) (**** Utilities for backtracking ****) diff --git a/typing/cmt_format.ml b/typing/cmt_format.ml index 6cecb1b691..772d7e3af8 100644 --- a/typing/cmt_format.ml +++ b/typing/cmt_format.ml @@ -68,68 +68,36 @@ let need_to_clear_env = let keep_only_summary = Env.keep_only_summary -module ClearEnv = TypedtreeMap.MakeMap (struct - open TypedtreeMap - include DefaultMapArgument - - let leave_pattern p = { p with pat_env = keep_only_summary p.pat_env } - let leave_expression e = - let exp_extra = List.map (function - (Texp_open (ovf, path, lloc, env), loc, attrs) -> - (Texp_open (ovf, path, lloc, keep_only_summary env), loc, attrs) - | exp_extra -> exp_extra) e.exp_extra in - { e with - exp_env = keep_only_summary e.exp_env; - exp_extra = exp_extra } - let leave_class_expr c = - { c with cl_env = keep_only_summary c.cl_env } - let leave_module_expr m = - { m with mod_env = keep_only_summary m.mod_env } - let leave_structure s = - { s with str_final_env = keep_only_summary s.str_final_env } - let leave_structure_item str = - { str with str_env = keep_only_summary str.str_env } - let leave_module_type m = - { m with mty_env = keep_only_summary m.mty_env } - let leave_signature s = - { s with sig_final_env = keep_only_summary s.sig_final_env } - let leave_signature_item s = - { s with sig_env = keep_only_summary s.sig_env } - let leave_core_type c = - { c with ctyp_env = keep_only_summary c.ctyp_env } - let leave_class_type c = - { c with cltyp_env = keep_only_summary c.cltyp_env } - -end) - -let clear_part p = match p with - | Partial_structure s -> Partial_structure (ClearEnv.map_structure s) +open Tast_mapper + +let cenv = + {Tast_mapper.default with env = fun _sub env -> keep_only_summary env} + +let clear_part = function + | Partial_structure s -> Partial_structure (cenv.structure cenv s) | Partial_structure_item s -> - Partial_structure_item (ClearEnv.map_structure_item s) - | Partial_expression e -> Partial_expression (ClearEnv.map_expression e) - | Partial_pattern p -> Partial_pattern (ClearEnv.map_pattern p) - | Partial_class_expr ce -> Partial_class_expr (ClearEnv.map_class_expr ce) - | Partial_signature s -> Partial_signature (ClearEnv.map_signature s) + Partial_structure_item (cenv.structure_item cenv s) + | Partial_expression e -> Partial_expression (cenv.expr cenv e) + | Partial_pattern p -> Partial_pattern (cenv.pat cenv p) + | Partial_class_expr ce -> Partial_class_expr (cenv.class_expr cenv ce) + | Partial_signature s -> Partial_signature (cenv.signature cenv s) | Partial_signature_item s -> - Partial_signature_item (ClearEnv.map_signature_item s) - | Partial_module_type s -> Partial_module_type (ClearEnv.map_module_type s) + Partial_signature_item (cenv.signature_item cenv s) + | Partial_module_type s -> Partial_module_type (cenv.module_type cenv s) let clear_env binary_annots = if need_to_clear_env then match binary_annots with - | Implementation s -> Implementation (ClearEnv.map_structure s) - | Interface s -> Interface (ClearEnv.map_signature s) - | Packed _ -> binary_annots - | Partial_implementation array -> + | Implementation s -> Implementation (cenv.structure cenv s) + | Interface s -> Interface (cenv.signature cenv s) + | Packed _ -> binary_annots + | Partial_implementation array -> Partial_implementation (Array.map clear_part array) - | Partial_interface array -> + | Partial_interface array -> Partial_interface (Array.map clear_part array) else binary_annots - - - exception Error of error let input_cmt ic = (input_value ic : cmt_infos) diff --git a/typing/ctype.ml b/typing/ctype.ml index aa6eabfae8..711f1893f1 100644 --- a/typing/ctype.ml +++ b/typing/ctype.ml @@ -454,38 +454,6 @@ let rec filter_row_fields erase = function (**************************************) -exception Non_closed0 - -let rec closed_schema_rec ty = - let ty = repr ty in - if ty.level >= lowest_level then begin - let level = ty.level in - ty.level <- pivot_level - level; - match ty.desc with - Tvar _ when level <> generic_level -> - raise Non_closed0 - | Tfield(_, kind, t1, t2) -> - if field_kind_repr kind = Fpresent then - closed_schema_rec t1; - closed_schema_rec t2 - | Tvariant row -> - let row = row_repr row in - iter_row closed_schema_rec row; - if not (static_row row) then closed_schema_rec row.row_more - | _ -> - iter_type_expr closed_schema_rec ty - end - -(* Return whether all variables of type [ty] are generic. *) -let closed_schema ty = - try - closed_schema_rec ty; - unmark_type ty; - true - with Non_closed0 -> - unmark_type ty; - false - exception Non_closed of type_expr * bool let free_variables = ref [] @@ -1059,20 +1027,25 @@ let rec copy ?env ?partial ?keep_names ty = (* Open row if partial for pattern and contains Reither *) let more', row = match partial with - Some (free_univars, false) when row.row_closed - && not row.row_fixed && TypeSet.is_empty (free_univars ty) -> + Some (free_univars, false) -> + let more' = + if more.id != more'.id then more' else + let lv = if keep then more.level else !current_level in + newty2 lv (Tvar None) + in let not_reither (_, f) = match row_field_repr f with Reither _ -> false | _ -> true in - if List.for_all not_reither row.row_fields - then (more', row) else - (newty2 (if keep then more.level else !current_level) - (Tvar None), - {row_fields = List.filter not_reither row.row_fields; - row_more = more; row_bound = (); - row_closed = false; row_fixed = false; row_name = None}) + if row.row_closed && not row.row_fixed + && TypeSet.is_empty (free_univars ty) + && not (List.for_all not_reither row.row_fields) then + (more', + {row_fields = List.filter not_reither row.row_fields; + row_more = more'; row_bound = (); + row_closed = false; row_fixed = false; row_name = None}) + else (more', row) | _ -> (more', row) in (* Register new type first for recursion *) @@ -1119,6 +1092,13 @@ let instance_def sch = cleanup_types (); ty +let generic_instance ?partial env sch = + let old = !current_level in + current_level := generic_level; + let ty = instance env sch in + current_level := old; + ty + let instance_list env schl = let env = gadt_env env in let tyl = List.map (fun t -> copy ?env t) schl in @@ -1460,8 +1440,8 @@ let expand_abbrev_gen kind find_type_expansion env ty = assert false (* Expand respecting privacy *) -let expand_abbrev ty = - expand_abbrev_gen Public Env.find_type_expansion ty +let expand_abbrev env ty = + expand_abbrev_gen Public Env.find_type_expansion env ty (* Expand once the head of a type *) let expand_head_once env ty = @@ -1671,10 +1651,11 @@ exception Occur let rec occur_rec env visited ty0 ty = if ty == ty0 then raise Occur; + let occur_ok = !Clflags.recursive_types && is_contractive env ty in match ty.desc with Tconstr(p, tl, abbrev) -> begin try - if List.memq ty visited || !Clflags.recursive_types then raise Occur; + if occur_ok || List.memq ty visited then raise Occur; iter_type_expr (occur_rec env (ty::visited) ty0) ty with Occur -> try let ty' = try_expand_head try_expand_once env ty in @@ -1685,15 +1666,15 @@ let rec occur_rec env visited ty0 ty = match ty'.desc with Tobject _ | Tvariant _ -> () | _ -> - if not !Clflags.recursive_types then + if not (!Clflags.recursive_types && is_contractive env ty') then iter_type_expr (occur_rec env (ty'::visited) ty0) ty' with Cannot_expand -> - if not !Clflags.recursive_types then raise Occur + if not occur_ok then raise Occur end | Tobject _ | Tvariant _ -> () | _ -> - if not !Clflags.recursive_types then + if not occur_ok then iter_type_expr (occur_rec env visited ty0) ty let type_changed = ref false (* trace possible changes to the studied type *) @@ -2061,8 +2042,11 @@ let rec mcomp type_pairs env t1 t2 = | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _)) -> mcomp_type_decl type_pairs env p1 p2 tl1 tl2 | (Tconstr (p, _, _), _) | (_, Tconstr (p, _, _)) -> - let decl = Env.find_type p env in - if non_aliasable p decl then raise (Unify []) + begin try + let decl = Env.find_type p env in + if non_aliasable p decl || is_datatype decl then raise (Unify []) + with Not_found -> () + end (* | (Tpackage (p1, n1, tl1), Tpackage (p2, n2, tl2)) when n1 = n2 -> mcomp_list type_pairs env tl1 tl2 @@ -2318,6 +2302,18 @@ let unify_eq env t1 t2 = try TypePairs.find unify_eq_set (order_type_pair t1 t2); true with Not_found -> false +let unify1_var env t1 t2 = + assert (is_Tvar t1); + occur env t1 t2; + occur_univar env t2; + let d1 = t1.desc in + link_type t1 t2; + try + update_level env t1.level t2 + with Unify _ as e -> + t1.desc <- d1; + raise e + let rec unify (env:Env.t ref) t1 t2 = (* First step: special cases (optimizations) *) if t1 == t2 then () else @@ -2334,15 +2330,9 @@ let rec unify (env:Env.t ref) t1 t2 = | (Tconstr _, Tvar _) when deep_occur t2 t1 -> unify2 env t1 t2 | (Tvar _, _) -> - occur !env t1 t2; - occur_univar !env t2; - link_type t1 t2; - update_level !env t1.level t2 + unify1_var !env t1 t2 | (_, Tvar _) -> - occur !env t2 t1; - occur_univar !env t1; - link_type t2 t1; - update_level !env t2.level t1 + unify1_var !env t2 t1 | (Tunivar _, Tunivar _) -> unify_univar t1 t2 !univar_pairs; update_level !env t1.level t2; @@ -2741,6 +2731,19 @@ and unify_row_field env fixed1 fixed2 more l f1 f2 = if List.memq ty tl then remq tl tl' else ty :: remq tl tl' in let tl2' = remq tl2 tl1 and tl1' = remq tl1 tl2 in + (* PR#6744 *) + let split_univars = + List.partition + (fun ty -> try occur_univar !env ty; true with Unify _ -> false) in + let (tl1',tlu1) = split_univars tl1' + and (tl2',tlu2) = split_univars tl2' in + begin match tlu1, tlu2 with + [], [] -> () + | (tu1::tlu1), (tu2::_) -> + (* Attempt to merge all the types containing univars *) + List.iter (unify env tu1) (tlu1@tlu2) + | (tu::_, []) | ([], tu::_) -> occur_univar !env tu + end; (* Is this handling of levels really principal? *) List.iter (update_level !env (repr more).level) (tl1' @ tl2'); let e = ref None in @@ -2845,7 +2848,7 @@ let filter_arrow env t l = link_type t t'; (t1, t2) | Tarrow(l', t1, t2, _) - when l = l' || !Clflags.classic && l = "" && not (is_optional l') -> + when l = l' || !Clflags.classic && l = Nolabel && not (is_optional l') -> (t1, t2) | _ -> raise (Unify []) @@ -3653,7 +3656,7 @@ let match_class_declarations env patt_params patt_type subj_params subj_type = (* Use moregeneral for class parameters, need to recheck everything to keeps relationships (PR#4824) *) let clty_params = - List.fold_right (fun ty cty -> Cty_arrow ("*",ty,cty)) in + List.fold_right (fun ty cty -> Cty_arrow (Labelled "*",ty,cty)) in match_class_types ~trace:false env (clty_params patt_params patt_type) (clty_params subj_params subj_type) @@ -4171,6 +4174,40 @@ let cyclic_abbrev env id ty = false in check_cycle [] ty +(* Check for non-generalizable type variables *) +exception Non_closed0 +let visited = ref TypeSet.empty + +let rec closed_schema_rec env ty = + let ty = expand_head env ty in + if TypeSet.mem ty !visited then () else begin + visited := TypeSet.add ty !visited; + match ty.desc with + Tvar _ when ty.level <> generic_level -> + raise Non_closed0 + | Tfield(_, kind, t1, t2) -> + if field_kind_repr kind = Fpresent then + closed_schema_rec env t1; + closed_schema_rec env t2 + | Tvariant row -> + let row = row_repr row in + iter_row (closed_schema_rec env) row; + if not (static_row row) then closed_schema_rec env row.row_more + | _ -> + iter_type_expr (closed_schema_rec env) ty + end + +(* Return whether all variables of type [ty] are generic. *) +let closed_schema env ty = + visited := TypeSet.empty; + try + closed_schema_rec env ty; + visited := TypeSet.empty; + true + with Non_closed0 -> + visited := TypeSet.empty; + false + (* Normalize a type before printing, saving... *) (* Cannot use mark_type because deep_occur uses it too *) let rec normalize_type_rec env visited ty = diff --git a/typing/ctype.mli b/typing/ctype.mli index 37daf3a428..bb75990f51 100644 --- a/typing/ctype.mli +++ b/typing/ctype.mli @@ -110,6 +110,8 @@ val instance: ?partial:bool -> Env.t -> type_expr -> type_expr partial=true -> newty2 ty.level Tvar for non generic subterms *) val instance_def: type_expr -> type_expr (* use defaults *) +val generic_instance: ?partial:bool -> Env.t -> type_expr -> type_expr + (* Same as instance, but new nodes at generic_level *) val instance_list: Env.t -> type_expr list -> type_expr list (* Take an instance of a list of type schemes *) val instance_constructor: @@ -144,6 +146,7 @@ val try_expand_once_opt: Env.t -> type_expr -> type_expr val expand_head_opt: Env.t -> type_expr -> type_expr (** The compiler's own version of [expand_head] necessary for type-based optimisations. *) + val full_expand: Env.t -> type_expr -> type_expr val extract_concrete_typedecl: Env.t -> type_expr -> Path.t * Path.t * type_declaration @@ -161,7 +164,7 @@ val unify_gadt: newtype_level:int -> Env.t ref -> type_expr -> type_expr -> unit val unify_var: Env.t -> type_expr -> type_expr -> unit (* Same as [unify], but allow free univars when first type is a variable. *) -val filter_arrow: Env.t -> type_expr -> label -> type_expr * type_expr +val filter_arrow: Env.t -> type_expr -> arg_label -> type_expr * type_expr (* A special case of unification (with l:'a -> 'b). *) val filter_method: Env.t -> string -> private_flag -> type_expr -> type_expr (* A special case of unification (with {m : 'a; 'b}). *) @@ -243,7 +246,7 @@ 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 +val closed_schema: Env.t -> type_expr -> bool (* Check whether the given type scheme contains no non-generic type variables *) diff --git a/typing/datarepr.ml b/typing/datarepr.ml index 1c121d35a9..1c90fea588 100644 --- a/typing/datarepr.ml +++ b/typing/datarepr.ml @@ -18,7 +18,7 @@ open Types open Btype (* Simplified version of Ctype.free_vars *) -let free_vars ty = +let free_vars ?(param=false) ty = let ret = ref TypeSet.empty in let rec loop ty = let ty = repr ty in @@ -30,7 +30,12 @@ let free_vars ty = | Tvariant row -> let row = row_repr row in iter_row loop row; - if not (static_row row) then loop row.row_more + if not (static_row row) then begin + match row.row_more.desc with + | Tvar _ when param -> ret := TypeSet.add ty !ret + | _ -> loop row.row_more + end + (* XXX: What about Tobject ? *) | _ -> iter_type_expr loop ty end @@ -47,17 +52,18 @@ let constructor_args cd_args cd_res path rep = | 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 arg_vars_set = free_vars (newgenty (Ttuple tyl)) in 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 arg_vars_set = free_vars ~param:true (newgenty (Ttuple tyl)) in let type_params = TypeSet.elements arg_vars_set in let tdecl = { diff --git a/typing/env.ml b/typing/env.ml index 4e6bba0c55..e0b3462298 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -58,6 +58,7 @@ type error = | Inconsistent_import of string * string * string | Need_recursive_types of string * string | Missing_module of Location.t * Path.t * Path.t + | Illegal_value_name of Location.t * string exception Error of error @@ -69,6 +70,7 @@ module EnvLazy : sig val force : ('a -> 'b) -> ('a,'b) t -> 'b val create : 'a -> ('a,'b) t val is_val : ('a,'b) t -> bool + val get_arg : ('a,'b) t -> 'a option end = struct @@ -95,6 +97,9 @@ end = struct let is_val x = match !x with Done _ -> true | _ -> false + let get_arg x = + match !x with Thunk a -> Some a | _ -> None + let create x = let x = ref (Thunk x) in x @@ -209,8 +214,6 @@ and functor_components = { fcomp_param: Ident.t; (* Formal parameter *) fcomp_arg: module_type option; (* Argument signature *) fcomp_res: module_type; (* Result signature *) - fcomp_env: t; (* Environment in which the result signature makes sense *) - fcomp_subst: Subst.t; (* Prefixing substitution for the result signature *) fcomp_cache: (Path.t, module_components) Hashtbl.t; (* For memoization *) fcomp_subst_cache: (Path.t, module_type) Hashtbl.t } @@ -228,8 +231,13 @@ let empty = { functor_args = Ident.empty; } -let in_signature env = - {env with flags = env.flags lor in_signature_flag} +let in_signature b env = + let flags = + if b then env.flags lor in_signature_flag + else env.flags land (lnot in_signature_flag) + in + {env with flags} + let implicit_coercion env = {env with flags = env.flags lor implicit_coercion_flag} @@ -270,8 +278,8 @@ let components_of_module_maker' = ref ((fun (env, sub, path, mty) -> assert false) : t * Subst.t * Path.t * module_type -> module_components_repr) let components_of_functor_appl' = - ref ((fun f p1 p2 -> assert false) : - functor_components -> Path.t -> Path.t -> module_components) + ref ((fun f env p1 p2 -> assert false) : + functor_components -> t -> Path.t -> Path.t -> module_components) let check_modtype_inclusion = (* to be filled with Includemod.check_modtype_inclusion *) ref ((fun env mty1 path1 mty2 -> assert false) : @@ -336,6 +344,12 @@ let check_consistency ps = (* Reading persistent structures from .cmi files *) +let save_pers_struct crc ps = + let modname = ps.ps_name in + Hashtbl.add persistent_structures modname (Some ps); + Consistbl.set crc_units modname crc ps.ps_filename; + add_import modname + let read_pers_struct modname filename = let cmi = read_cmi filename in let name = cmi.cmi_name in @@ -377,6 +391,10 @@ let find_pers_struct ?(check=true) name = | Some None -> raise Not_found | Some (Some sg) -> sg | None -> + (* PR#6843: record the weak dependency ([add_import]) even if + the [find_in_path_uncap] call below fails to find the .cmi, + to help make builds more deterministic. *) + add_import name; let filename = try find_in_path_uncap !load_path (name ^ ".cmi") with Not_found -> @@ -414,6 +432,9 @@ let reset_cache_toplevel () = let set_unit_name name = current_unit := name +let get_unit_name () = + !current_unit + (* Lookup by identifier *) let rec find_module_descr path env = @@ -423,7 +444,7 @@ let rec find_module_descr path env = let (p, desc) = EnvTbl.find_same id env.components in desc with Not_found -> - if Ident.persistent id + if Ident.persistent id && not (Ident.name id = !current_unit) then (find_pers_struct (Ident.name id)).ps_comps else raise Not_found end @@ -442,7 +463,7 @@ let rec find_module_descr path env = EnvLazy.force !components_of_module_maker' (find_module_descr p1 env) with Functor_comps f -> - !components_of_functor_appl' f p1 p2 + !components_of_functor_appl' f env p1 p2 | Structure_comps c -> raise Not_found end @@ -532,7 +553,7 @@ let find_module ~alias path env = let (p, data) = EnvTbl.find_same id env.modules in data with Not_found -> - if Ident.persistent id then + if Ident.persistent id && not (Ident.name id = !current_unit) then let ps = find_pers_struct (Ident.name id) in md (Mty_signature(Lazy.force ps.ps_sig)) else raise Not_found @@ -552,8 +573,7 @@ let find_module ~alias path env = begin match EnvLazy.force !components_of_module_maker' desc1 with Functor_comps f -> md begin match f.fcomp_res with - | Mty_alias p -> - Mty_alias (Subst.module_path f.fcomp_subst p) + | Mty_alias p as mty-> mty | mty -> if alias then mty else try @@ -561,7 +581,7 @@ let find_module ~alias path env = with Not_found -> let mty = Subst.modtype - (Subst.add_module f.fcomp_param p2 f.fcomp_subst) + (Subst.add_module f.fcomp_param p2 Subst.identity) f.fcomp_res in Hashtbl.add f.fcomp_subst_cache p2 mty; mty @@ -692,7 +712,7 @@ let rec lookup_module_descr lid env = begin match EnvLazy.force !components_of_module_maker' desc1 with Functor_comps f -> Misc.may (!check_modtype_inclusion env mty2 p2) f.fcomp_arg; - (Papply(p1, p2), !components_of_functor_appl' f p1 p2) + (Papply(p1, p2), !components_of_functor_appl' f env p1 p2) | Structure_comps c -> raise Not_found end @@ -756,22 +776,6 @@ let lookup proj1 proj2 lid env = | Lapply(l1, l2) -> raise Not_found -let lookup_simple proj1 proj2 lid env = - match lid with - Lident s -> - EnvTbl.find_name s (proj1 env) - | Ldot(l, s) -> - let (p, desc) = lookup_module_descr l env in - begin match EnvLazy.force !components_of_module_maker' desc with - Structure_comps c -> - let (data, pos) = Tbl.find s (proj2 c) in - data - | Functor_comps f -> - raise Not_found - end - | Lapply(l1, l2) -> - raise Not_found - let lookup_all_simple proj1 proj2 shadow lid env = match lid with Lident s -> @@ -972,20 +976,38 @@ let lookup_cltype lid env = (* Iter on an environment (ignoring the body of functors and not yet evaluated structures) *) -let iter_env proj1 proj2 f env = +type iter_cont = unit -> unit +let iter_env_cont = ref [] + +let rec scrape_alias_safe env mty = + match mty with + | Mty_alias (Pident id) when Ident.persistent id -> false + | Mty_alias path -> (* PR#6600: find_module may raise Not_found *) + scrape_alias_safe env (find_module path env).md_type + | _ -> true + +let iter_env proj1 proj2 f env () = Ident.iter (fun id (x,_) -> f (Pident id) x) (proj1 env); let rec iter_components path path' mcomps = - (* if EnvLazy.is_val mcomps then *) - match EnvLazy.force !components_of_module_maker' mcomps with - Structure_comps comps -> - Tbl.iter - (fun s (d, n) -> f (Pdot (path, s, n)) (Pdot (path', s, n), d)) - (proj2 comps); - Tbl.iter - (fun s (c, n) -> - iter_components (Pdot (path, s, n)) (Pdot (path', s, n)) c) - comps.comp_components - | Functor_comps _ -> () + let cont () = + let safe = + match EnvLazy.get_arg mcomps with + None -> true + | Some (env, sub, path, mty) -> + try scrape_alias_safe env mty with Not_found -> false + in + if not safe then () else + match EnvLazy.force !components_of_module_maker' mcomps with + Structure_comps comps -> + Tbl.iter + (fun s (d, n) -> f (Pdot (path, s, n)) (Pdot (path', s, n), d)) + (proj2 comps); + Tbl.iter + (fun s (c, n) -> + iter_components (Pdot (path, s, n)) (Pdot (path', s, n)) c) + comps.comp_components + | Functor_comps _ -> () + in iter_env_cont := (path, cont) :: !iter_env_cont in Hashtbl.iter (fun s pso -> @@ -998,6 +1020,13 @@ let iter_env proj1 proj2 f env = (fun id ((path, comps), _) -> iter_components (Pident id) path comps) env.components +let run_iter_cont l = + iter_env_cont := []; + List.iter (fun c -> c ()) l; + let cont = List.rev !iter_env_cont in + iter_env_cont := []; + cont + let iter_types f = iter_env (fun env -> env.types) (fun sc -> sc.comp_types) f let same_types env1 env2 = @@ -1147,12 +1176,15 @@ let rec prefix_idents root pos sub = function (Subst.add_modtype id (Mty_ident p) sub) rem in (p::pl, final_sub) | Sig_class(id, decl, _) :: rem -> + (* pretend this is a type, cf. PR#6650 *) let p = Pdot(root, Ident.name id, pos) in - let (pl, final_sub) = prefix_idents root (pos + 1) sub rem in + let (pl, final_sub) = + prefix_idents root (pos + 1) (Subst.add_type id p sub) rem in (p::pl, final_sub) | Sig_class_type(id, decl, _) :: rem -> let p = Pdot(root, Ident.name id, nopos) in - let (pl, final_sub) = prefix_idents root pos sub rem in + let (pl, final_sub) = + prefix_idents root pos (Subst.add_type id p sub) rem in (p::pl, final_sub) let subst_signature sub sg = @@ -1288,13 +1320,10 @@ and components_of_module_maker (env, sub, path, mty) = | Mty_functor(param, ty_arg, ty_res) -> Functor_comps { fcomp_param = param; - (* fcomp_arg must be prefixed eagerly, because it is interpreted - in the outer environment, not in env *) + (* fcomp_arg and fcomp_res must be prefixed eagerly, because they are interpreted + in the outer environment *) fcomp_arg = may_map (Subst.modtype sub) ty_arg; - (* fcomp_res is prefixed lazily, because it is interpreted in env *) - fcomp_res = ty_res; - fcomp_env = env; - fcomp_subst = sub; + fcomp_res = Subst.modtype sub ty_res; fcomp_cache = Hashtbl.create 17; fcomp_subst_cache = Hashtbl.create 17 } | Mty_ident _ @@ -1323,7 +1352,20 @@ and check_usage loc id warn tbl = (fun () -> if not !used then Location.prerr_warning loc (warn name)) end; +and check_value_name name loc = + (* Note: we could also check here general validity of the + identifier, to protect against bad identifiers forged by -pp or + -ppx preprocessors. *) + + if String.length name > 0 && (name.[0] = '#') then + for i = 1 to String.length name - 1 do + if name.[i] = '#' then + raise (Error(Illegal_value_name(loc, name))) + done + + and store_value ?check slot id path decl env renv = + check_value_name (Ident.name id) decl.val_loc; may (fun f -> check_usage decl.val_loc id f value_declarations) check; { env with values = EnvTbl.add "value" slot id (path, decl) env.values renv.values; @@ -1441,15 +1483,14 @@ and store_cltype slot id path desc env renv = (* Compute the components of a functor application in a path. *) -let components_of_functor_appl f p1 p2 = +let components_of_functor_appl f env p1 p2 = try Hashtbl.find f.fcomp_cache p2 with Not_found -> let p = Papply(p1, p2) in - let mty = - Subst.modtype (Subst.add_module f.fcomp_param p2 Subst.identity) - f.fcomp_res in - let comps = components_of_module f.fcomp_env f.fcomp_subst p mty in + let sub = Subst.add_module f.fcomp_param p2 Subst.identity in + let mty = Subst.modtype sub f.fcomp_res in + let comps = components_of_module env Subst.identity p mty in Hashtbl.add f.fcomp_cache p2 comps; comps @@ -1515,9 +1556,8 @@ 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_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) +and enter_module_declaration ?arg id md env = + add_module_declaration ?arg id md env (* let (id, env) = enter store_module name md env in (id, add_functor_arg ?arg id env) *) and enter_modtype = enter store_modtype @@ -1525,7 +1565,8 @@ and enter_class = enter store_class and enter_cltype = enter store_cltype let enter_module ?arg s mty env = - enter_module_declaration ?arg s (md mty) env + let id = Ident.create s in + (id, enter_module_declaration ?arg id (md mty) env) (* Insertion of all components of a signature *) @@ -1670,9 +1711,7 @@ let save_signature_with_imports sg modname filename imports = ps_flags = cmi.cmi_flags; ps_crcs_checked = false; } in - Hashtbl.add persistent_structures modname (Some ps); - Consistbl.set crc_units modname crc filename; - add_import modname; + save_pers_struct crc ps; sg with exn -> close_out oc; @@ -1835,11 +1874,16 @@ let report_error ppf = function fprintf ppf "@]@ @[%s@ %s@ %s.@]@]" "The compiled interface for module" (Ident.name (Path.head path2)) "was not found" + | Illegal_value_name(_loc, name) -> + fprintf ppf "'%s' is not a valid value identifier." + name let () = Location.register_error_of_exn (function - | Error (Missing_module (loc, _, _) as err) when loc <> Location.none -> + | Error (Missing_module (loc, _, _) + | Illegal_value_name (loc, _) + as err) when loc <> Location.none -> Some (Location.error_of_printer loc report_error err) | Error err -> Some (Location.error_of_printer_file report_error err) | _ -> None diff --git a/typing/env.mli b/typing/env.mli index 4ab08e83a8..06a1e2beb3 100644 --- a/typing/env.mli +++ b/typing/env.mli @@ -37,9 +37,11 @@ type type_descriptions = constructor_description list * label_description list (* For short-paths *) +type iter_cont val iter_types: (Path.t -> Path.t * (type_declaration * type_descriptions) -> unit) -> - t -> unit + t -> iter_cont +val run_iter_cont: iter_cont list -> (Path.t * iter_cont) list val same_types: t -> t -> bool val used_persistent: unit -> Concr.t val find_shadowed_types: Path.t -> t -> Path.t list @@ -133,7 +135,7 @@ val enter_type: string -> type_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 + ?arg:bool -> Ident.t -> module_declaration -> t -> t val enter_modtype: string -> modtype_declaration -> t -> Ident.t * t val enter_class: string -> class_declaration -> t -> Ident.t * t val enter_cltype: string -> class_type_declaration -> t -> Ident.t * t @@ -146,6 +148,7 @@ val reset_cache_toplevel: unit -> unit (* Remember the name of the current compilation unit. *) val set_unit_name: string -> unit +val get_unit_name: unit -> string (* Read, save a signature to/from a file *) @@ -190,6 +193,7 @@ type error = | Inconsistent_import of string * string * string | Need_recursive_types of string * string | Missing_module of Location.t * Path.t * Path.t + | Illegal_value_name of Location.t * string exception Error of error @@ -209,9 +213,11 @@ val mark_constructor: val mark_extension_used: constructor_usage -> t -> extension_constructor -> string -> unit -val in_signature: t -> t +val in_signature: bool -> t -> t val implicit_coercion: t -> t +val is_in_signature: t -> bool + val set_value_used_callback: string -> value_description -> (unit -> unit) -> unit val set_type_used_callback: @@ -257,3 +263,4 @@ val fold_cltypes: (** Utilities *) val scrape_alias: t -> module_type -> module_type +val check_value_name: string -> Location.t -> unit diff --git a/typing/includecore.ml b/typing/includecore.ml index a4da854cff..f3bbbfd86e 100644 --- a/typing/includecore.ml +++ b/typing/includecore.ml @@ -26,7 +26,10 @@ let value_descriptions env vd1 vd2 = match (vd1.val_kind, vd2.val_kind) with (Val_prim p1, Val_prim p2) -> if p1 = p2 then Tcoerce_none else raise Dont_match - | (Val_prim p, _) -> Tcoerce_primitive p + | (Val_prim p, _) -> + let pc = {pc_desc = p; pc_type = vd2.val_type; + pc_env = env; pc_loc = vd1.val_loc; } in + Tcoerce_primitive pc | (_, Val_prim p) -> raise Dont_match | (_, _) -> Tcoerce_none end else diff --git a/typing/includemod.ml b/typing/includemod.ml index 22628496c6..049f37aa4b 100644 --- a/typing/includemod.ml +++ b/typing/includemod.ml @@ -179,8 +179,9 @@ let rec print_coercion ppf c = pr "@[<2>functor@ (%a)@ (%a)@]" print_coercion inp print_coercion out - | Tcoerce_primitive pd -> - pr "prim %s" pd.Primitive.prim_name + | Tcoerce_primitive {pc_desc; pc_env = _; pc_type} -> + pr "prim %s@ (%a)" pc_desc.Primitive.prim_name + Printtyp.raw_type_expr pc_type | Tcoerce_alias (p, c) -> pr "@[<2>alias %a@ (%a)@]" Printtyp.path p @@ -279,7 +280,7 @@ and try_modtypes2 env cxt mty1 mty2 = and signatures env cxt subst sig1 sig2 = (* Environment used to check inclusion of components *) let new_env = - Env.add_signature sig1 (Env.in_signature env) in + Env.add_signature sig1 (Env.in_signature true env) in (* Keep ids for module aliases *) let (id_pos_list,_) = List.fold_left diff --git a/typing/mtype.ml b/typing/mtype.ml index 873ba3a23a..4768edeb5d 100644 --- a/typing/mtype.ml +++ b/typing/mtype.ml @@ -44,7 +44,8 @@ and strengthen_sig env sg p pos = match sg with [] -> [] | (Sig_value(id, desc) as sigelt) :: rem -> - sigelt :: strengthen_sig env rem p (pos+1) + let nextpos = match desc.val_kind with Val_prim _ -> pos | _ -> pos+1 in + sigelt :: strengthen_sig env rem p nextpos | Sig_type(id, decl, rs) :: rem -> let newdecl = match decl.type_manifest, decl.type_private, decl.type_kind with diff --git a/typing/oprint.ml b/typing/oprint.ml index 3c2d63708e..63b1272d19 100644 --- a/typing/oprint.ml +++ b/typing/oprint.ml @@ -426,7 +426,10 @@ and print_out_sig_item ppf = name !out_module_type mty | Osig_type(td, rs) -> print_out_type_decl - (if rs = Orec_next then "and" else "type") + (match rs with + | Orec_not -> "type nonrec" + | Orec_first -> "type" + | Orec_next -> "and") ppf td | Osig_value (name, ty, prims) -> let kwd = if prims = [] then "val" else "external" in @@ -439,6 +442,8 @@ and print_out_sig_item ppf = in fprintf ppf "@[<2>%s %a :@ %a%a@]" kwd value_ident name !out_type ty pr_prims prims + | Osig_ellipsis -> + fprintf ppf "..." and print_out_type_decl kwd ppf td = let print_constraints ppf = diff --git a/typing/outcometree.mli b/typing/outcometree.mli index 18885e8de6..9603466fab 100644 --- a/typing/outcometree.mli +++ b/typing/outcometree.mli @@ -92,6 +92,7 @@ and out_sig_item = | 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 + | Osig_ellipsis and out_type_decl = { otype_name: string; otype_params: (string * (bool * bool)) list; diff --git a/typing/parmatch.ml b/typing/parmatch.ml index 20b6e5b652..60448bec9e 100644 --- a/typing/parmatch.ml +++ b/typing/parmatch.ml @@ -210,7 +210,8 @@ and pretty_cdr ppf v = match v.pat_desc with | _ -> pretty_val ppf v and pretty_arg ppf v = match v.pat_desc with -| Tpat_construct (_,_,_::_) -> fprintf ppf "(%a)" pretty_val v +| Tpat_construct (_,_,_::_) +| Tpat_variant (_, Some _, _) -> fprintf ppf "(%a)" pretty_val v | _ -> pretty_val ppf v and pretty_or ppf v = match v.pat_desc with @@ -1774,6 +1775,14 @@ module Conv = struct (ps, constrs, labels) end +(* Whether the counter-example contains an extension pattern *) +let contains_extension pat = + let r = ref false in + let rec loop = function + {pat_desc=Tpat_construct(_, {cstr_name="*extension*"}, _)} -> + r := true + | p -> Typedtree.iter_pattern_desc loop p.pat_desc + in loop pat; !r let do_check_partial ?pred exhaust loc casel pss = match pss with | [] -> @@ -1809,11 +1818,7 @@ let do_check_partial ?pred exhaust loc casel pss = match pss with None -> Total | Some v -> let errmsg = - match v.pat_desc with - Tpat_construct (_, {cstr_name="*extension*"}, _) -> - "_\nMatching over values of open types must include\n\ - a wild card pattern in order to be exhaustive." - | _ -> try + try let buf = Buffer.create 16 in let fmt = formatter_of_buffer buf in top_pretty fmt v; @@ -1826,7 +1831,12 @@ let do_check_partial ?pred exhaust loc casel pss = match pss with is a pain in the top-level *) Buffer.add_string buf "\n(However, some guarded clause may match this value.)" - end ; + end; + if contains_extension v then + Buffer.add_string buf + "\nMatching over values of extensible variant types (the *extension* above)\n\ + must include a wild card pattern in order to be exhaustive." + ; Buffer.contents buf with _ -> "" diff --git a/typing/parmatch.mli b/typing/parmatch.mli index 947f16fa2c..dfd955a8bb 100644 --- a/typing/parmatch.mli +++ b/typing/parmatch.mli @@ -53,7 +53,6 @@ val complete_constrs : pattern -> constructor_tag list -> constructor_description list val pressure_variants: Env.t -> pattern list -> unit -val check_partial: Location.t -> case list -> partial val check_partial_gadt: ((string, constructor_description) Hashtbl.t -> (string, label_description) Hashtbl.t -> diff --git a/typing/predef.ml b/typing/predef.ml index bcad58efdd..49f9d91981 100644 --- a/typing/predef.ml +++ b/typing/predef.ml @@ -28,7 +28,7 @@ let ident_create_predef_exn = wrap Ident.create_predef_exn let ident_int = ident_create "int" and ident_char = ident_create "char" -and ident_string = ident_create "string" +and ident_bytes = ident_create "bytes" and ident_float = ident_create "float" and ident_bool = ident_create "bool" and ident_unit = ident_create "unit" @@ -40,11 +40,11 @@ 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" +and ident_string = ident_create "string" let path_int = Pident ident_int and path_char = Pident ident_char -and path_string = Pident ident_string +and path_bytes = Pident ident_bytes and path_float = Pident ident_float and path_bool = Pident ident_bool and path_unit = Pident ident_unit @@ -56,11 +56,11 @@ 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 +and path_string = Pident ident_string let type_int = newgenty (Tconstr(path_int, [], ref Mnil)) and type_char = newgenty (Tconstr(path_char, [], ref Mnil)) -and type_string = newgenty (Tconstr(path_string, [], ref Mnil)) +and type_bytes = newgenty (Tconstr(path_bytes, [], ref Mnil)) and type_float = newgenty (Tconstr(path_float, [], ref Mnil)) and type_bool = newgenty (Tconstr(path_bool, [], ref Mnil)) and type_unit = newgenty (Tconstr(path_unit, [], ref Mnil)) @@ -72,7 +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)) +and type_string = newgenty (Tconstr(path_string, [], ref Mnil)) let ident_match_failure = ident_create_predef_exn "Match_failure" and ident_out_of_memory = ident_create_predef_exn "Out_of_memory" diff --git a/typing/printtyp.ml b/typing/printtyp.ml index db856958b0..50e457a695 100644 --- a/typing/printtyp.ml +++ b/typing/printtyp.ml @@ -122,6 +122,11 @@ let print_name ppf = function None -> fprintf ppf "None" | Some name -> fprintf ppf "\"%s\"" name +let string_of_label = function + Nolabel -> "" + | Labelled s -> s + | Optional s -> "?"^s + let visited = ref [] let rec raw_type ppf ty = let ty = safe_repr [] ty in @@ -134,8 +139,8 @@ and raw_type_list tl = raw_list raw_type tl and raw_type_desc ppf = function Tvar name -> fprintf ppf "Tvar %a" print_name name | Tarrow(l,t1,t2,c) -> - fprintf ppf "@[<hov1>Tarrow(%s,@,%a,@,%a,@,%s)@]" - l raw_type t1 raw_type t2 + fprintf ppf "@[<hov1>Tarrow(\"%s\",@,%a,@,%a,@,%s)@]" + (string_of_label l) raw_type t1 raw_type t2 (safe_commu_repr [] c) | Ttuple tl -> fprintf ppf "@[<1>Ttuple@,%a@]" raw_type_list tl @@ -202,6 +207,10 @@ let () = Btype.print_raw := raw_type_expr type param_subst = Id | Nth of int | Map of int list +let is_nth = function + Nth _ -> true + | _ -> false + let compose l1 = function | Id -> Map l1 | Map l2 -> Map (List.map (List.nth l1) l2) @@ -216,6 +225,8 @@ let apply_subst s1 tyl = type best_path = Paths of Path.t list | Best of Path.t let printing_env = ref Env.empty +let printing_depth = ref 0 +let printing_cont = ref ([] : Env.iter_cont list) let printing_old = ref Env.empty let printing_pers = ref Concr.empty module Path2 = struct @@ -232,7 +243,7 @@ module Path2 = struct | _ -> Pervasives.compare p1 p2 end module PathMap = Map.Make(Path2) -let printing_map = ref (Lazy.from_val PathMap.empty) +let printing_map = ref PathMap.empty let same_type t t' = repr t == repr t' @@ -287,24 +298,24 @@ let set_printing_env env = (* printf "Reset printing_map@."; *) printing_old := env; printing_pers := Env.used_persistent (); - printing_map := lazy begin - (* printf "Recompute printing_map.@."; *) - let map = ref PathMap.empty in + printing_map := PathMap.empty; + printing_depth := 0; + (* printf "Recompute printing_map.@."; *) + let cont = Env.iter_types (fun p (p', decl) -> let (p1, s1) = normalize_type_path env p' ~cache:true in (* Format.eprintf "%a -> %a = %a@." path p path p' path p1 *) if s1 = Id then try - let r = PathMap.find p1 !map in + let r = PathMap.find p1 !printing_map in match !r with Paths l -> r := Paths (p :: l) - | Best _ -> assert false + | Best p' -> r := Paths [p; p'] (* assert false *) with Not_found -> - map := PathMap.add p1 (ref (Paths [p])) !map) - env; - !map - end + printing_map := PathMap.add p1 (ref (Paths [p])) !printing_map) + env in + printing_cont := [cont]; end let wrap_printing_env env f = @@ -347,10 +358,14 @@ let best_type_path p = then (p, Id) else let (p', s) = normalize_type_path !printing_env p in - let p'' = - try get_best_path (PathMap.find p' (Lazy.force !printing_map)) - with Not_found -> p' - in + let get_path () = get_best_path (PathMap.find p' !printing_map) in + while !printing_cont <> [] && + try ignore (get_path ()); false with Not_found -> true + do + printing_cont := List.map snd (Env.run_iter_cont !printing_cont); + incr printing_depth; + done; + let p'' = try get_path () with Not_found -> p' in (* Format.eprintf "%a = %a -> %a@." path p path p' path p''; *) (p'', s) @@ -437,7 +452,7 @@ let aliasable ty = match ty.desc with Tvar _ | Tunivar _ | Tpoly _ -> false | Tconstr (p, _, _) -> - (match best_type_path p with (_, Nth _) -> false | _ -> true) + not (is_nth (snd (best_type_path p))) | _ -> true let namable_row row = @@ -525,7 +540,7 @@ let reset_and_mark_loops_list tyl = (* Disabled in classic mode when printing an unification error *) let print_labels = ref true let print_label ppf l = - if !print_labels && l <> "" || is_optional l then fprintf ppf "%s:" l + if !print_labels && l <> Nolabel || is_optional l then fprintf ppf "%s:" (string_of_label l) let rec tree_of_typexp sch ty = let ty = repr ty in @@ -541,7 +556,7 @@ let rec tree_of_typexp sch ty = | Tarrow(l, ty1, ty2, _) -> let pr_arrow l ty1 ty2 = let lab = - if !print_labels && l <> "" || is_optional l then l else "" + if !print_labels || is_optional l then string_of_label l else "" in let t1 = if is_optional l then @@ -556,12 +571,10 @@ let rec tree_of_typexp sch ty = | Ttuple tyl -> Otyp_tuple (tree_of_typlist sch tyl) | Tconstr(p, tyl, abbrev) -> - begin match best_type_path p with - (_, Nth n) -> tree_of_typexp sch (List.nth tyl n) - | (p', s) -> - let tyl' = apply_subst s tyl in - Otyp_constr (tree_of_path p', tree_of_typlist sch tyl') - end + let p', s = best_type_path p in + let tyl' = apply_subst s tyl in + if is_nth s then tree_of_typexp sch (List.hd tyl') else + Otyp_constr (tree_of_path p', tree_of_typlist sch tyl') | Tvariant row -> let row = row_repr row in let fields = @@ -580,17 +593,22 @@ let rec tree_of_typexp sch ty = begin match row.row_name with | Some(p, tyl) when namable_row row -> let (p', s) = best_type_path p in - assert (s = Id); let id = tree_of_path p' in - let args = tree_of_typlist sch tyl in + let args = tree_of_typlist sch (apply_subst s tyl) in if row.row_closed && all_present then - Otyp_constr (id, args) + if is_nth s then List.hd args else Otyp_constr (id, args) else let non_gen = is_non_gen sch px in let tags = if all_present then None else Some (List.map fst present) in - Otyp_variant (non_gen, Ovar_name(id, args), - row.row_closed, tags) + let inh = + match args with + [Otyp_constr (i, a)] when is_nth s -> Ovar_name (i, a) + | _ -> + (* fallback case, should change outcometree... *) + Ovar_name (tree_of_path p, tree_of_typlist sch tyl) + in + Otyp_variant (non_gen, inh, row.row_closed, tags) | _ -> let non_gen = not (row.row_closed && all_present) && is_non_gen sch px in @@ -1040,7 +1058,7 @@ let rec tree_of_class_type sch params = in Octy_signature (self_ty, List.rev csil) | Cty_arrow (l, ty, cty) -> - let lab = if !print_labels && l <> "" || is_optional l then l else "" in + let lab = if !print_labels || is_optional l then string_of_label l else "" in let ty = if is_optional l then match (repr ty).desc with @@ -1150,7 +1168,7 @@ let dummy = let hide_rec_items = function | Sig_type(id, decl, rs) ::rem - when rs <> Trec_next && not !Clflags.real_paths -> + when rs = Trec_first && not !Clflags.real_paths -> let rec get_ids = function Sig_type (id, _, Trec_next) :: rem -> id :: get_ids rem @@ -1163,36 +1181,38 @@ let hide_rec_items = function ids !printing_env) | _ -> () -let rec tree_of_modtype = function +let rec tree_of_modtype ?(ellipsis=false) = function | Mty_ident p -> Omty_ident (tree_of_path p) | Mty_signature sg -> - Omty_signature (tree_of_signature sg) + Omty_signature (if ellipsis then [Osig_ellipsis] else tree_of_signature sg) | Mty_functor(param, ty_arg, ty_res) -> let res = - match ty_arg with None -> tree_of_modtype ty_res + match ty_arg with None -> tree_of_modtype ~ellipsis ty_res | Some mty -> - wrap_env (Env.add_module ~arg:true param mty) tree_of_modtype ty_res + wrap_env (Env.add_module ~arg:true param mty) (tree_of_modtype ~ellipsis) ty_res in - Omty_functor (Ident.name param, may_map tree_of_modtype ty_arg, res) + Omty_functor (Ident.name param, may_map (tree_of_modtype ~ellipsis:false) ty_arg, res) | Mty_alias p -> Omty_alias (tree_of_path p) and tree_of_signature sg = - wrap_env (fun env -> env) (tree_of_signature_rec !printing_env) sg + wrap_env (fun env -> env) (tree_of_signature_rec !printing_env false) sg -and tree_of_signature_rec env' = function +and tree_of_signature_rec env' in_type_group = function [] -> [] | item :: rem as items -> - begin match item with - Sig_type (_, _, rs) when rs <> Trec_next -> () - | _ -> set_printing_env env' - end; + let in_type_group = + match in_type_group, item with + true, Sig_type (_, _, Trec_next) -> true + | _, Sig_type (_, _, (Trec_not | Trec_first)) -> set_printing_env env'; true + | _ -> set_printing_env env'; false + in let (sg, rem) = filter_rem_sig item rem in hide_rec_items items; let trees = trees_of_sigitem item in let env' = Env.add_signature (item :: sg) env' in - trees @ tree_of_signature_rec env' rem + trees @ tree_of_signature_rec env' in_type_group rem and trees_of_sigitem = function | Sig_value(id, decl) -> @@ -1204,7 +1224,10 @@ and trees_of_sigitem = function | 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] + let ellipsis = + List.exists (function ({txt="..."}, Parsetree.PStr []) -> true | _ -> false) + md.md_attributes in + [tree_of_module id md.md_type rs ~ellipsis] | Sig_modtype(id, decl) -> [tree_of_modtype_declaration id decl] | Sig_class(id, decl, rs) -> @@ -1220,8 +1243,8 @@ and tree_of_modtype_declaration id decl = in Osig_modtype (Ident.name id, mty) -and tree_of_module id mty rs = - Osig_module (Ident.name id, tree_of_modtype mty, tree_of_rec rs) +and tree_of_module id ?ellipsis mty rs = + Osig_module (Ident.name id, tree_of_modtype ?ellipsis mty, tree_of_rec rs) let modtype ppf mty = !Oprint.out_module_type ppf (tree_of_modtype mty) let modtype_declaration id ppf decl = diff --git a/typing/printtyp.mli b/typing/printtyp.mli index 14b67cd054..9bbc7011a7 100644 --- a/typing/printtyp.mli +++ b/typing/printtyp.mli @@ -22,6 +22,7 @@ val tree_of_path: Path.t -> out_ident val path: formatter -> Path.t -> unit val string_of_path: Path.t -> string val raw_type_expr: formatter -> type_expr -> unit +val string_of_label: Asttypes.arg_label -> string val wrap_printing_env: Env.t -> (unit -> 'a) -> 'a (* Call the function using the environment for type path shortening *) @@ -50,7 +51,7 @@ 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 tree_of_module: Ident.t -> ?ellipsis:bool -> module_type -> rec_status -> out_sig_item val modtype: formatter -> module_type -> unit val signature: formatter -> signature -> unit val tree_of_modtype_declaration: diff --git a/typing/printtyped.ml b/typing/printtyped.ml index 5184b19e5d..8270b6d8a8 100644 --- a/typing/printtyped.ml +++ b/typing/printtyped.ml @@ -135,6 +135,11 @@ let string i ppf s = line i ppf "\"%s\"\n" s;; let string_loc i ppf s = line i ppf "\"%s\"\n" s.txt;; let bool i ppf x = line i ppf "%s\n" (string_of_bool x);; let label i ppf x = line i ppf "label=\"%s\"\n" x;; +let arg_label i ppf = function + | Nolabel -> line i ppf "Nolabel\n" + | Optional s -> line i ppf "Optional \"%s\"\n" s + | Labelled s -> line i ppf "Labelled \"%s\"\n" s +;; let attributes i ppf l = let i = i + 1 in @@ -150,25 +155,25 @@ let rec core_type i ppf x = attributes i ppf x.ctyp_attributes; let i = i+1 in match x.ctyp_desc with - | Ttyp_any -> line i ppf "Ptyp_any\n"; - | Ttyp_var (s) -> line i ppf "Ptyp_var %s\n" s; + | Ttyp_any -> line i ppf "Ttyp_any\n"; + | Ttyp_var (s) -> line i ppf "Ttyp_var %s\n" s; | Ttyp_arrow (l, ct1, ct2) -> - line i ppf "Ptyp_arrow\n"; - string i ppf l; + line i ppf "Ttyp_arrow\n"; + arg_label i ppf l; core_type i ppf ct1; core_type i ppf ct2; | Ttyp_tuple l -> - line i ppf "Ptyp_tuple\n"; + line i ppf "Ttyp_tuple\n"; list i core_type ppf l; | Ttyp_constr (li, _, l) -> - line i ppf "Ptyp_constr %a\n" fmt_path li; + line i ppf "Ttyp_constr %a\n" fmt_path li; list i core_type ppf l; | Ttyp_variant (l, closed, low) -> - line i ppf "Ptyp_variant closed=%a\n" fmt_closed_flag closed; + line i ppf "Ttyp_variant closed=%a\n" fmt_closed_flag closed; list i label_x_bool_x_core_type_list ppf l; option i (fun i -> list i string) ppf low | Ttyp_object (l, c) -> - line i ppf "Ptyp_object %a\n" fmt_closed_flag c; + line i ppf "Ttyp_object %a\n" fmt_closed_flag c; let i = i + 1 in List.iter (fun (s, attrs, t) -> @@ -178,17 +183,17 @@ let rec core_type i ppf x = ) l | Ttyp_class (li, _, l) -> - line i ppf "Ptyp_class %a\n" fmt_path li; + line i ppf "Ttyp_class %a\n" fmt_path li; list i core_type ppf l; | Ttyp_alias (ct, s) -> - line i ppf "Ptyp_alias \"%s\"\n" s; + line i ppf "Ttyp_alias \"%s\"\n" s; core_type i ppf ct; | Ttyp_poly (sl, ct) -> - line i ppf "Ptyp_poly%a\n" + line i ppf "Ttyp_poly%a\n" (fun ppf -> List.iter (fun x -> fprintf ppf " '%s" x)) sl; core_type i ppf ct; | Ttyp_package { pack_path = s; pack_fields = l } -> - line i ppf "Ptyp_package %a\n" fmt_path s; + line i ppf "Ttyp_package %a\n" fmt_path s; list i package_with ppf l; and package_with i ppf (s, t) = @@ -215,55 +220,55 @@ and pattern i ppf x = pattern i ppf { x with pat_extra = rem } | [] -> match x.pat_desc with - | Tpat_any -> line i ppf "Ppat_any\n"; - | Tpat_var (s,_) -> line i ppf "Ppat_var \"%a\"\n" fmt_ident s; + | Tpat_any -> line i ppf "Tpat_any\n"; + | Tpat_var (s,_) -> line i ppf "Tpat_var \"%a\"\n" fmt_ident s; | Tpat_alias (p, s,_) -> - line i ppf "Ppat_alias \"%a\"\n" fmt_ident s; + line i ppf "Tpat_alias \"%a\"\n" fmt_ident s; pattern i ppf p; - | Tpat_constant (c) -> line i ppf "Ppat_constant %a\n" fmt_constant c; + | Tpat_constant (c) -> line i ppf "Tpat_constant %a\n" fmt_constant c; | Tpat_tuple (l) -> - line i ppf "Ppat_tuple\n"; + line i ppf "Tpat_tuple\n"; list i pattern ppf l; | Tpat_construct (li, _, po) -> - line i ppf "Ppat_construct %a\n" fmt_longident li; + line i ppf "Tpat_construct %a\n" fmt_longident li; list i pattern ppf po; | Tpat_variant (l, po, _) -> - line i ppf "Ppat_variant \"%s\"\n" l; + line i ppf "Tpat_variant \"%s\"\n" l; option i pattern ppf po; | Tpat_record (l, c) -> - line i ppf "Ppat_record\n"; + line i ppf "Tpat_record\n"; list i longident_x_pattern ppf l; | Tpat_array (l) -> - line i ppf "Ppat_array\n"; + line i ppf "Tpat_array\n"; list i pattern ppf l; | Tpat_or (p1, p2, _) -> - line i ppf "Ppat_or\n"; + line i ppf "Tpat_or\n"; pattern i ppf p1; pattern i ppf p2; | Tpat_lazy p -> - line i ppf "Ppat_lazy\n"; + line i ppf "Tpat_lazy\n"; pattern i ppf p; and expression_extra i ppf x attrs = match x with | Texp_constraint ct -> - line i ppf "Pexp_constraint\n"; + line i ppf "Texp_constraint\n"; attributes i ppf attrs; core_type i ppf ct; | Texp_coerce (cto1, cto2) -> - line i ppf "Pexp_constraint\n"; + line i ppf "Texp_coerce\n"; attributes i ppf attrs; option i core_type ppf cto1; core_type i ppf cto2; | Texp_open (ovf, m, _, _) -> - line i ppf "Pexp_open %a \"%a\"\n" fmt_override_flag ovf fmt_path m; + line i ppf "Texp_open %a \"%a\"\n" fmt_override_flag ovf fmt_path m; attributes i ppf attrs; | Texp_poly cto -> - line i ppf "Pexp_poly\n"; + line i ppf "Texp_poly\n"; attributes i ppf attrs; option i core_type ppf cto; | Texp_newtype s -> - line i ppf "Pexp_newtype \"%s\"\n" s; + line i ppf "Texp_newtype \"%s\"\n" s; attributes i ppf attrs; and expression i ppf x = @@ -274,103 +279,103 @@ and expression i ppf x = (i+1) x.exp_extra in match x.exp_desc with - | Texp_ident (li,_,_) -> line i ppf "Pexp_ident %a\n" fmt_path li; - | Texp_instvar (_, li,_) -> line i ppf "Pexp_instvar %a\n" fmt_path li; - | Texp_constant (c) -> line i ppf "Pexp_constant %a\n" fmt_constant c; + | Texp_ident (li,_,_) -> line i ppf "Texp_ident %a\n" fmt_path li; + | Texp_instvar (_, li,_) -> line i ppf "Texp_instvar %a\n" fmt_path li; + | Texp_constant (c) -> line i ppf "Texp_constant %a\n" fmt_constant c; | Texp_let (rf, l, e) -> - line i ppf "Pexp_let %a\n" fmt_rec_flag rf; + line i ppf "Texp_let %a\n" fmt_rec_flag rf; list i value_binding ppf l; expression i ppf e; | Texp_function (p, l, _partial) -> - line i ppf "Pexp_function \"%s\"\n" p; -(* option i expression ppf eo; *) + line i ppf "Texp_function\n"; + arg_label i ppf p; list i case ppf l; | Texp_apply (e, l) -> - line i ppf "Pexp_apply\n"; + line i ppf "Texp_apply\n"; expression i ppf e; list i label_x_expression ppf l; | Texp_match (e, l1, l2, partial) -> - line i ppf "Pexp_match\n"; + line i ppf "Texp_match\n"; expression i ppf e; list i case ppf l1; list i case ppf l2; | Texp_try (e, l) -> - line i ppf "Pexp_try\n"; + line i ppf "Texp_try\n"; expression i ppf e; list i case ppf l; | Texp_tuple (l) -> - line i ppf "Pexp_tuple\n"; + line i ppf "Texp_tuple\n"; list i expression ppf l; | Texp_construct (li, _, eo) -> - line i ppf "Pexp_construct %a\n" fmt_longident li; + line i ppf "Texp_construct %a\n" fmt_longident li; list i expression ppf eo; | Texp_variant (l, eo) -> - line i ppf "Pexp_variant \"%s\"\n" l; + line i ppf "Texp_variant \"%s\"\n" l; option i expression ppf eo; | Texp_record (l, eo) -> - line i ppf "Pexp_record\n"; + line i ppf "Texp_record\n"; list i longident_x_expression ppf l; option i expression ppf eo; | Texp_field (e, li, _) -> - line i ppf "Pexp_field\n"; + line i ppf "Texp_field\n"; expression i ppf e; longident i ppf li; | Texp_setfield (e1, li, _, e2) -> - line i ppf "Pexp_setfield\n"; + line i ppf "Texp_setfield\n"; expression i ppf e1; longident i ppf li; expression i ppf e2; | Texp_array (l) -> - line i ppf "Pexp_array\n"; + line i ppf "Texp_array\n"; list i expression ppf l; | Texp_ifthenelse (e1, e2, eo) -> - line i ppf "Pexp_ifthenelse\n"; + line i ppf "Texp_ifthenelse\n"; expression i ppf e1; expression i ppf e2; option i expression ppf eo; | Texp_sequence (e1, e2) -> - line i ppf "Pexp_sequence\n"; + line i ppf "Texp_sequence\n"; expression i ppf e1; expression i ppf e2; | Texp_while (e1, e2) -> - line i ppf "Pexp_while\n"; + line i ppf "Texp_while\n"; expression i ppf e1; expression i ppf e2; | Texp_for (s, _, e1, e2, df, e3) -> - line i ppf "Pexp_for \"%a\" %a\n" fmt_ident s fmt_direction_flag df; + line i ppf "Texp_for \"%a\" %a\n" fmt_ident s fmt_direction_flag df; expression i ppf e1; expression i ppf e2; expression i ppf e3; | Texp_send (e, Tmeth_name s, eo) -> - line i ppf "Pexp_send \"%s\"\n" s; + line i ppf "Texp_send \"%s\"\n" s; expression i ppf e; option i expression ppf eo | Texp_send (e, Tmeth_val s, eo) -> - line i ppf "Pexp_send \"%a\"\n" fmt_ident s; + line i ppf "Texp_send \"%a\"\n" fmt_ident s; expression i ppf e; option i expression ppf eo - | Texp_new (li, _, _) -> line i ppf "Pexp_new %a\n" fmt_path li; + | Texp_new (li, _, _) -> line i ppf "Texp_new %a\n" fmt_path li; | Texp_setinstvar (_, s, _, e) -> - line i ppf "Pexp_setinstvar \"%a\"\n" fmt_path s; + line i ppf "Texp_setinstvar \"%a\"\n" fmt_path s; expression i ppf e; | Texp_override (_, l) -> - line i ppf "Pexp_override\n"; + line i ppf "Texp_override\n"; list i string_x_expression ppf l; | Texp_letmodule (s, _, me, e) -> - line i ppf "Pexp_letmodule \"%a\"\n" fmt_ident s; + line i ppf "Texp_letmodule \"%a\"\n" fmt_ident s; module_expr i ppf me; expression i ppf e; | Texp_assert (e) -> - line i ppf "Pexp_assert"; + line i ppf "Texp_assert"; expression i ppf e; | Texp_lazy (e) -> - line i ppf "Pexp_lazy"; + line i ppf "Texp_lazy"; expression i ppf e; | Texp_object (s, _) -> - line i ppf "Pexp_object"; + line i ppf "Texp_object"; class_structure i ppf s | Texp_pack me -> - line i ppf "Pexp_pack"; + line i ppf "Texp_pack"; module_expr i ppf me and value_description i ppf x = @@ -398,15 +403,15 @@ and type_declaration i ppf x = and type_kind i ppf x = match x with | Ttype_abstract -> - line i ppf "Ptype_abstract\n" + line i ppf "Ttype_abstract\n" | Ttype_variant l -> - line i ppf "Ptype_variant\n"; + line i ppf "Ttype_variant\n"; list (i+1) constructor_decl ppf l; | Ttype_record l -> - line i ppf "Ptype_record\n"; + line i ppf "Ttype_record\n"; list (i+1) label_decl ppf l; | Ttype_open -> - line i ppf "Ptype_open\n" + line i ppf "Ttype_open\n" and type_extension i ppf x = line i ppf "type_extension\n"; @@ -430,11 +435,11 @@ and extension_constructor i ppf x = and extension_constructor_kind i ppf x = match x with Text_decl(a, r) -> - line i ppf "Pext_decl\n"; + line i ppf "Text_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 ppf "Text_rebind\n"; line (i+1) ppf "%a\n" fmt_path p; and class_type i ppf x = @@ -443,13 +448,14 @@ and class_type i ppf x = let i = i+1 in match x.cltyp_desc with | Tcty_constr (li, _, l) -> - line i ppf "Pcty_constr %a\n" fmt_path li; + line i ppf "Tcty_constr %a\n" fmt_path li; list i core_type ppf l; | Tcty_signature (cs) -> - line i ppf "Pcty_signature\n"; + line i ppf "Tcty_signature\n"; class_signature i ppf cs; | Tcty_arrow (l, co, cl) -> - line i ppf "Pcty_arrow \"%s\"\n" l; + line i ppf "Tcty_arrow\n"; + arg_label i ppf l; core_type i ppf co; class_type i ppf cl; @@ -464,21 +470,21 @@ and class_type_field i ppf x = attributes i ppf x.ctf_attributes; match x.ctf_desc with | Tctf_inherit (ct) -> - line i ppf "Pctf_inherit\n"; + line i ppf "Tctf_inherit\n"; class_type i ppf ct; | Tctf_val (s, mf, vf, ct) -> - line i ppf "Pctf_val \"%s\" %a %a\n" s fmt_mutable_flag mf + line i ppf "Tctf_val \"%s\" %a %a\n" s fmt_mutable_flag mf fmt_virtual_flag vf; core_type (i+1) ppf ct; | Tctf_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 "Tctf_method \"%s\" %a %a\n" s fmt_private_flag pf fmt_virtual_flag vf; core_type (i+1) ppf ct; | Tctf_constraint (ct1, ct2) -> - line i ppf "Pctf_constraint\n"; + line i ppf "Tctf_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; + line i ppf "Tctf_attribute \"%s\"\n" s.txt; Printast.payload i ppf arg and class_description i ppf x = @@ -508,27 +514,27 @@ and class_expr i ppf x = let i = i+1 in match x.cl_desc with | Tcl_ident (li, _, l) -> - line i ppf "Pcl_constr %a\n" fmt_path li; + line i ppf "Tcl_ident %a\n" fmt_path li; list i core_type ppf l; | Tcl_structure (cs) -> - line i ppf "Pcl_structure\n"; + line i ppf "Tcl_structure\n"; class_structure i ppf cs; | Tcl_fun (l, p, _, ce, _) -> - line i ppf "Pcl_fun\n"; - label i ppf l; + line i ppf "Tcl_fun\n"; + arg_label i ppf l; pattern i ppf p; class_expr i ppf ce | Tcl_apply (ce, l) -> - line i ppf "Pcl_apply\n"; + line i ppf "Tcl_apply\n"; class_expr i ppf ce; list i label_x_expression ppf l; | Tcl_let (rf, l1, l2, ce) -> - line i ppf "Pcl_let %a\n" fmt_rec_flag rf; + line i ppf "Tcl_let %a\n" fmt_rec_flag rf; list i value_binding ppf l1; list i ident_x_loc_x_expression_def ppf l2; class_expr i ppf ce; | Tcl_constraint (ce, Some ct, _, _, _) -> - line i ppf "Pcl_constraint\n"; + line i ppf "Tcl_constraint\n"; class_expr i ppf ce; class_type i ppf ct | Tcl_constraint (ce, None, _, _, _) -> class_expr i ppf ce @@ -544,24 +550,24 @@ and class_field i ppf x = attributes i ppf x.cf_attributes; match x.cf_desc with | Tcf_inherit (ovf, ce, so, _, _) -> - line i ppf "Pcf_inherit %a\n" fmt_override_flag ovf; + line i ppf "Tcf_inherit %a\n" fmt_override_flag ovf; class_expr (i+1) ppf ce; option (i+1) string ppf so; | Tcf_val (s, mf, _, k, _) -> - line i ppf "Pcf_val \"%s\" %a\n" s.txt fmt_mutable_flag mf; + line i ppf "Tcf_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; + line i ppf "Tcf_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"; + line i ppf "Tcf_constraint\n"; core_type (i+1) ppf ct1; core_type (i+1) ppf ct2; | Tcf_initializer (e) -> - line i ppf "Pcf_initializer\n"; + line i ppf "Tcf_initializer\n"; expression (i+1) ppf e; | Tcf_attribute (s, arg) -> - line i ppf "Pcf_attribute \"%s\"\n" s.txt; + line i ppf "Tcf_attribute \"%s\"\n" s.txt; Printast.payload i ppf arg and class_field_kind i ppf = function @@ -587,21 +593,21 @@ and module_type i ppf x = attributes i ppf x.mty_attributes; let i = i+1 in match x.mty_desc with - | Tmty_ident (li,_) -> line i ppf "Pmty_ident %a\n" fmt_path li; - | Tmty_alias (li,_) -> line i ppf "Pmty_alias %a\n" fmt_path li; + | Tmty_ident (li,_) -> line i ppf "Tmty_ident %a\n" fmt_path li; + | Tmty_alias (li,_) -> line i ppf "Tmty_alias %a\n" fmt_path li; | Tmty_signature (s) -> - line i ppf "Pmty_signature\n"; + line i ppf "Tmty_signature\n"; signature i ppf s; | Tmty_functor (s, _, mt1, mt2) -> - line i ppf "Pmty_functor \"%a\"\n" fmt_ident s; + line i ppf "Tmty_functor \"%a\"\n" fmt_ident s; Misc.may (module_type i ppf) mt1; module_type i ppf mt2; | Tmty_with (mt, l) -> - line i ppf "Pmty_with\n"; + line i ppf "Tmty_with\n"; module_type i ppf mt; list i longident_x_with_constraint ppf l; | Tmty_typeof m -> - line i ppf "Pmty_typeof\n"; + line i ppf "Tmty_typeof\n"; module_expr i ppf m; and signature i ppf x = list i signature_item ppf x.sig_items @@ -611,45 +617,45 @@ and signature_item i ppf x = let i = i+1 in match x.sig_desc with | Tsig_value vd -> - line i ppf "Psig_value\n"; + line i ppf "Tsig_value\n"; value_description i ppf vd; - | Tsig_type l -> - line i ppf "Psig_type\n"; + | Tsig_type (rf, l) -> + line i ppf "Tsig_type %a\n" fmt_rec_flag rf; list i type_declaration ppf l; | Tsig_typext e -> - line i ppf "Psig_typext\n"; + line i ppf "Tsig_typext\n"; type_extension i ppf e; | Tsig_exception ext -> - line i ppf "Psig_exception\n"; + line i ppf "Tsig_exception\n"; extension_constructor i ppf ext | Tsig_module md -> - line i ppf "Psig_module \"%a\"\n" fmt_ident md.md_id; + line i ppf "Tsig_module \"%a\"\n" fmt_ident md.md_id; attributes i ppf md.md_attributes; module_type i ppf md.md_type | Tsig_recmodule decls -> - line i ppf "Psig_recmodule\n"; + line i ppf "Tsig_recmodule\n"; list i module_declaration ppf decls; | Tsig_modtype x -> - line i ppf "Psig_modtype \"%a\"\n" fmt_ident x.mtd_id; + line i ppf "Tsig_modtype \"%a\"\n" fmt_ident x.mtd_id; attributes i ppf x.mtd_attributes; modtype_declaration i ppf x.mtd_type | Tsig_open od -> - line i ppf "Psig_open %a %a\n" + line i ppf "Tsig_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"; + line i ppf "Tsig_include\n"; attributes i ppf incl.incl_attributes; module_type i ppf incl.incl_mod | Tsig_class (l) -> - line i ppf "Psig_class\n"; + line i ppf "Tsig_class\n"; list i class_description ppf l; | Tsig_class_type (l) -> - line i ppf "Psig_class_type\n"; + line i ppf "Tsig_class_type\n"; list i class_type_declaration ppf l; | Tsig_attribute (s, arg) -> - line i ppf "Psig_attribute \"%s\"\n" s.txt; + line i ppf "Tsig_attribute \"%s\"\n" s.txt; Printast.payload i ppf arg and module_declaration i ppf md = @@ -669,38 +675,38 @@ and modtype_declaration i ppf = function and with_constraint i ppf x = match x with | Twith_type (td) -> - line i ppf "Pwith_type\n"; + line i ppf "Twith_type\n"; type_declaration (i+1) ppf td; | Twith_typesubst (td) -> - line i ppf "Pwith_typesubst\n"; + line i ppf "Twith_typesubst\n"; type_declaration (i+1) ppf td; - | Twith_module (li,_) -> line i ppf "Pwith_module %a\n" fmt_path li; - | Twith_modsubst (li,_) -> line i ppf "Pwith_modsubst %a\n" fmt_path li; + | Twith_module (li,_) -> line i ppf "Twith_module %a\n" fmt_path li; + | Twith_modsubst (li,_) -> line i ppf "Twith_modsubst %a\n" fmt_path li; and module_expr i ppf x = line i ppf "module_expr %a\n" fmt_location x.mod_loc; attributes i ppf x.mod_attributes; let i = i+1 in match x.mod_desc with - | Tmod_ident (li,_) -> line i ppf "Pmod_ident %a\n" fmt_path li; + | Tmod_ident (li,_) -> line i ppf "Tmod_ident %a\n" fmt_path li; | Tmod_structure (s) -> - line i ppf "Pmod_structure\n"; + line i ppf "Tmod_structure\n"; structure i ppf s; | Tmod_functor (s, _, mt, me) -> - line i ppf "Pmod_functor \"%a\"\n" fmt_ident s; + line i ppf "Tmod_functor \"%a\"\n" fmt_ident s; Misc.may (module_type i ppf) mt; module_expr i ppf me; | Tmod_apply (me1, me2, _) -> - line i ppf "Pmod_apply\n"; + line i ppf "Tmod_apply\n"; module_expr i ppf me1; module_expr i ppf me2; | Tmod_constraint (me, _, Tmodtype_explicit mt, _) -> - line i ppf "Pmod_constraint\n"; + line i ppf "Tmod_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"; + line i ppf "Tmod_unpack\n"; expression i ppf e; and structure i ppf x = list i structure_item ppf x.str_items @@ -710,51 +716,51 @@ and structure_item i ppf x = let i = i+1 in match x.str_desc with | Tstr_eval (e, attrs) -> - line i ppf "Pstr_eval\n"; + line i ppf "Tstr_eval\n"; attributes i ppf attrs; expression i ppf e; | Tstr_value (rf, l) -> - line i ppf "Pstr_value %a\n" fmt_rec_flag rf; + line i ppf "Tstr_value %a\n" fmt_rec_flag rf; list i value_binding ppf l; | Tstr_primitive vd -> - line i ppf "Pstr_primitive\n"; + line i ppf "Tstr_primitive\n"; value_description i ppf vd; - | Tstr_type l -> - line i ppf "Pstr_type\n"; + | Tstr_type (rf, l) -> + line i ppf "Tstr_type %a\n" fmt_rec_flag rf; list i type_declaration ppf l; | Tstr_typext te -> - line i ppf "Pstr_typext\n"; + line i ppf "Tstr_typext\n"; type_extension i ppf te | Tstr_exception ext -> - line i ppf "Pstr_exception\n"; + line i ppf "Tstr_exception\n"; extension_constructor i ppf ext; | Tstr_module x -> - line i ppf "Pstr_module\n"; + line i ppf "Tstr_module\n"; module_binding i ppf x | Tstr_recmodule bindings -> - line i ppf "Pstr_recmodule\n"; + line i ppf "Tstr_recmodule\n"; list i module_binding ppf bindings | Tstr_modtype x -> - line i ppf "Pstr_modtype \"%a\"\n" fmt_ident x.mtd_id; + line i ppf "Tstr_modtype \"%a\"\n" fmt_ident x.mtd_id; attributes i ppf x.mtd_attributes; modtype_declaration i ppf x.mtd_type | Tstr_open od -> - line i ppf "Pstr_open %a %a\n" + line i ppf "Tstr_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); + line i ppf "Tstr_class\n"; + list i class_declaration ppf (List.map (fun (cl, _) -> cl) l); | Tstr_class_type (l) -> - line i ppf "Pstr_class_type\n"; + line i ppf "Tstr_class_type\n"; list i class_type_declaration ppf (List.map (fun (_, _, cl) -> cl) l); | Tstr_include incl -> - line i ppf "Pstr_include"; + line i ppf "Tstr_include"; 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; + line i ppf "Tstr_attribute \"%s\"\n" s.txt; Printast.payload i ppf arg and string_x_module_type i ppf (s, _, mty) = @@ -821,7 +827,8 @@ and longident_x_expression i ppf (li, _, e) = expression (i+1) ppf e; and label_x_expression i ppf (l, e, _) = - line i ppf "<label> \"%s\"\n" l; + line i ppf "<arg>\n"; + arg_label (i+1) ppf l; (match e with None -> () | Some e -> expression (i+1) ppf e) and ident_x_loc_x_expression_def i ppf (l,_, e) = diff --git a/typing/subst.ml b/typing/subst.ml index b6a0edbc5a..01780ed2ae 100644 --- a/typing/subst.ml +++ b/typing/subst.ml @@ -42,11 +42,22 @@ let remove_loc = let open Ast_mapper in {default_mapper with location = (fun _this _loc -> Location.none)} -let attrs s x = - if s.for_saving && not !Clflags.keep_locs - then remove_loc.Ast_mapper.attributes remove_loc x - else x +let is_not_doc = function + | ({Location.txt = "ocaml.doc"}, _) -> false + | ({Location.txt = "ocaml.text"}, _) -> false + | ({Location.txt = "doc"}, _) -> false + | ({Location.txt = "text"}, _) -> false + | _ -> true +let attrs s x = + let x = + if s.for_saving && not !Clflags.keep_docs then + List.filter is_not_doc x + else x + in + if s.for_saving && not !Clflags.keep_locs + then remove_loc.Ast_mapper.attributes remove_loc x + else x let rec module_path s = function Pident id as p -> @@ -315,7 +326,7 @@ let extension_constructor s ext = 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_attributes = attrs s ext.ext_attributes; ext_loc = if s.for_saving then Location.none else ext.ext_loc; } in cleanup_types (); @@ -333,8 +344,11 @@ 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_typext(id, _, _) | - Sig_class(id, _, _) | Sig_class_type(id, _, _)) :: sg -> + | (Sig_class(id, _, _) | Sig_class_type(id, _, _)) :: sg -> + (* cheat and pretend they are types cf. PR#6650 *) + let id' = Ident.rename id in + rename_bound_idents (add_type id (Pident id') s) (id' :: idents) sg + | (Sig_value(id, _) | Sig_typext(id, _, _)) :: sg -> let id' = Ident.rename id in rename_bound_idents s (id' :: idents) sg diff --git a/typing/subst.mli b/typing/subst.mli index a197f82f48..7f6870e939 100644 --- a/typing/subst.mli +++ b/typing/subst.mli @@ -51,6 +51,8 @@ val modtype: t -> module_type -> module_type val signature: t -> signature -> signature val modtype_declaration: t -> modtype_declaration -> modtype_declaration val module_declaration: t -> module_declaration -> module_declaration +val typexp : t -> Types.type_expr -> Types.type_expr +val class_signature: t -> class_signature -> class_signature (* Composition of substitutions: apply (compose s1 s2) x = apply s2 (apply s1 x) *) diff --git a/typing/tast_mapper.ml b/typing/tast_mapper.ml new file mode 100644 index 0000000000..7c7c774bb5 --- /dev/null +++ b/typing/tast_mapper.ml @@ -0,0 +1,668 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Alain Frisch, LexiFi *) +(* *) +(* Copyright 2015 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. *) +(* *) +(***********************************************************************) + +open Asttypes +open Typedtree + +(* TODO: add 'methods' for location, attribute, extension, + open_description, include_declaration, include_description *) + +type mapper = + { + case: mapper -> case -> case; + cases: mapper -> case list -> case list; + class_declaration: mapper -> class_declaration -> class_declaration; + class_description: mapper -> class_description -> class_description; + class_expr: mapper -> class_expr -> class_expr; + class_field: mapper -> class_field -> class_field; + 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_field: mapper -> class_type_field -> class_type_field; + env: mapper -> Env.t -> Env.t; + expr: mapper -> expression -> expression; + extension_constructor: mapper -> extension_constructor -> + extension_constructor; + module_binding: mapper -> module_binding -> module_binding; + module_coercion: mapper -> module_coercion -> module_coercion; + 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; + package_type: mapper -> package_type -> package_type; + pat: mapper -> pattern -> pattern; + row_field: mapper -> row_field -> row_field; + signature: mapper -> signature -> signature; + signature_item: mapper -> signature_item -> signature_item; + structure: mapper -> structure -> structure; + structure_item: mapper -> structure_item -> structure_item; + typ: mapper -> core_type -> core_type; + type_declaration: mapper -> type_declaration -> type_declaration; + type_declarations: mapper -> (rec_flag * type_declaration list) -> + (rec_flag * type_declaration list); + type_extension: mapper -> type_extension -> type_extension; + type_kind: mapper -> type_kind -> type_kind; + value_binding: mapper -> value_binding -> value_binding; + value_bindings: mapper -> (rec_flag * value_binding list) -> + (rec_flag * value_binding list); + value_description: mapper -> value_description -> value_description; + with_constraint: mapper -> with_constraint -> with_constraint; + } + +let id x = x +let tuple2 f1 f2 (x, y) = (f1 x, f2 y) +let tuple3 f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z) +let opt f = function None -> None | Some x -> Some (f x) + +let structure sub {str_items; str_type; str_final_env} = + { + str_items = List.map (sub.structure_item sub) str_items; + str_final_env = sub.env sub str_final_env; + str_type; + } + +let class_infos sub f x = + {x with + ci_params = List.map (tuple2 (sub.typ sub) id) x.ci_params; + ci_expr = f x.ci_expr; + } + +let module_type_declaration sub x = + let mtd_type = opt (sub.module_type sub) x.mtd_type in + {x with mtd_type} + +let module_declaration sub x = + let md_type = sub.module_type sub x.md_type in + {x with md_type} + +let include_infos f x = {x with incl_mod = f x.incl_mod} + +let class_type_declaration sub x = + class_infos sub (sub.class_type sub) x + +let class_declaration sub x = + class_infos sub (sub.class_expr sub) x + +let structure_item sub {str_desc; str_loc; str_env} = + let str_env = sub.env sub str_env in + let str_desc = + match str_desc with + | Tstr_eval (exp, attrs) -> Tstr_eval (sub.expr sub exp, attrs) + | Tstr_value (rec_flag, list) -> + let (rec_flag, list) = sub.value_bindings sub (rec_flag, list) in + Tstr_value (rec_flag, list) + | Tstr_primitive v -> Tstr_primitive (sub.value_description sub v) + | Tstr_type (rec_flag, list) -> + let (rec_flag, list) = sub.type_declarations sub (rec_flag, list) in + Tstr_type (rec_flag, list) + | Tstr_typext te -> Tstr_typext (sub.type_extension sub te) + | Tstr_exception ext -> Tstr_exception (sub.extension_constructor sub ext) + | Tstr_module mb -> Tstr_module (sub.module_binding sub mb) + | Tstr_recmodule list -> + Tstr_recmodule (List.map (sub.module_binding sub) list) + | Tstr_modtype x -> Tstr_modtype (sub.module_type_declaration sub x) + | Tstr_class list -> + Tstr_class + (List.map (tuple2 (sub.class_declaration sub) id) list) + | Tstr_class_type list -> + Tstr_class_type + (List.map (tuple3 id id (sub.class_type_declaration sub)) list) + | Tstr_include incl -> + Tstr_include (include_infos (sub.module_expr sub) incl) + | Tstr_open _ + | Tstr_attribute _ as d -> d + in + {str_desc; str_env; str_loc} + +let value_description sub x = + let val_desc = sub.typ sub x.val_desc in + {x with val_desc} + +let label_decl sub x = + let ld_type = sub.typ sub x.ld_type in + {x with ld_type} + +let constructor_args sub = function + | Cstr_tuple l -> Cstr_tuple (List.map (sub.typ sub) l) + | Cstr_record l -> Cstr_record (List.map (label_decl sub) l) + +let constructor_decl sub cd = + let cd_args = constructor_args sub cd.cd_args in + let cd_res = opt (sub.typ sub) cd.cd_res in + {cd with cd_args; cd_res} + +let type_kind sub = function + | Ttype_abstract -> Ttype_abstract + | Ttype_variant list -> Ttype_variant (List.map (constructor_decl sub) list) + | Ttype_record list -> Ttype_record (List.map (label_decl sub) list) + | Ttype_open -> Ttype_open + +let type_declaration sub x = + let typ_cstrs = + List.map + (tuple3 (sub.typ sub) (sub.typ sub) id) + x.typ_cstrs + in + let typ_kind = sub.type_kind sub x.typ_kind in + let typ_manifest = opt (sub.typ sub) x.typ_manifest in + let typ_params = List.map (tuple2 (sub.typ sub) id) x.typ_params in + {x with typ_cstrs; typ_kind; typ_manifest; typ_params} + +let type_declarations sub (rec_flag, list) = + (rec_flag, List.map (sub.type_declaration sub) list) + +let type_extension sub x = + let tyext_params = List.map (tuple2 (sub.typ sub) id) x.tyext_params in + let tyext_constructors = + List.map (sub.extension_constructor sub) x.tyext_constructors + in + {x with tyext_constructors; tyext_params} + +let extension_constructor sub x = + let ext_kind = + match x.ext_kind with + Text_decl(ctl, cto) -> + Text_decl(constructor_args sub ctl, opt (sub.typ sub) cto) + | Text_rebind _ as d -> d + in + {x with ext_kind} + +let pat sub x = + let extra = function + | Tpat_type _ + | Tpat_unpack as d -> d + | Tpat_constraint ct -> Tpat_constraint (sub.typ sub ct) + in + let pat_env = sub.env sub x.pat_env in + let pat_extra = List.map (tuple3 extra id id) x.pat_extra in + let pat_desc = + match x.pat_desc with + | Tpat_any + | Tpat_var _ + | Tpat_constant _ as d -> d + | Tpat_tuple l -> Tpat_tuple (List.map (sub.pat sub) l) + | Tpat_construct (loc, cd, l) -> + Tpat_construct (loc, cd, List.map (sub.pat sub) l) + | Tpat_variant (l, po, rd) -> Tpat_variant (l, opt (sub.pat sub) po, rd) + | Tpat_record (l, closed) -> + Tpat_record (List.map (tuple3 id id (sub.pat sub)) l, closed) + | Tpat_array l -> Tpat_array (List.map (sub.pat sub) l) + | Tpat_or (p1, p2, rd) -> + Tpat_or (sub.pat sub p1, sub.pat sub p2, rd) + | Tpat_alias (p, id, s) -> Tpat_alias (sub.pat sub p, id, s) + | Tpat_lazy p -> Tpat_lazy (sub.pat sub p) + in + {x with pat_extra; pat_desc; pat_env} + +let expr sub x = + let extra = function + | Texp_constraint cty -> + Texp_constraint (sub.typ sub cty) + | Texp_coerce (cty1, cty2) -> + Texp_coerce (opt (sub.typ sub) cty1, sub.typ sub cty2) + | Texp_open (ovf, path, loc, env) -> + Texp_open (ovf, path, loc, sub.env sub env) + | Texp_newtype _ as d -> d + | Texp_poly cto -> Texp_poly (opt (sub.typ sub) cto) + in + let exp_extra = List.map (tuple3 extra id id) x.exp_extra in + let exp_env = sub.env sub x.exp_env in + let exp_desc = + match x.exp_desc with + | Texp_ident _ + | Texp_constant _ as d -> d + | Texp_let (rec_flag, list, exp) -> + let (rec_flag, list) = sub.value_bindings sub (rec_flag, list) in + Texp_let (rec_flag, list, sub.expr sub exp) + | Texp_function (l, cases, p) -> + Texp_function (l, sub.cases sub cases, p) + | Texp_apply (exp, list) -> + Texp_apply ( + sub.expr sub exp, + List.map (tuple3 id (opt (sub.expr sub)) id) list + ) + | Texp_match (exp, cases, exn_cases, p) -> + Texp_match ( + sub.expr sub exp, + sub.cases sub cases, + sub.cases sub exn_cases, + p + ) + | Texp_try (exp, cases) -> + Texp_try ( + sub.expr sub exp, + sub.cases sub cases + ) + | Texp_tuple list -> + Texp_tuple (List.map (sub.expr sub) list) + | Texp_construct (lid, cd, args) -> + Texp_construct (lid, cd, List.map (sub.expr sub) args) + | Texp_variant (l, expo) -> + Texp_variant (l, opt (sub.expr sub) expo) + | Texp_record (list, expo) -> + Texp_record ( + List.map (tuple3 id id (sub.expr sub)) list, + opt (sub.expr sub) expo + ) + | Texp_field (exp, lid, ld) -> + Texp_field (sub.expr sub exp, lid, ld) + | Texp_setfield (exp1, lid, ld, exp2) -> + Texp_setfield ( + sub.expr sub exp1, + lid, + ld, + sub.expr sub exp2 + ) + | Texp_array list -> + Texp_array (List.map (sub.expr sub) list) + | Texp_ifthenelse (exp1, exp2, expo) -> + Texp_ifthenelse ( + sub.expr sub exp1, + sub.expr sub exp2, + opt (sub.expr sub) expo + ) + | Texp_sequence (exp1, exp2) -> + Texp_sequence ( + sub.expr sub exp1, + sub.expr sub exp2 + ) + | Texp_while (exp1, exp2) -> + Texp_while ( + sub.expr sub exp1, + sub.expr sub exp2 + ) + | Texp_for (id, p, exp1, exp2, dir, exp3) -> + Texp_for ( + id, + p, + sub.expr sub exp1, + sub.expr sub exp2, + dir, + sub.expr sub exp3 + ) + | Texp_send (exp, meth, expo) -> + Texp_send + ( + sub.expr sub exp, + meth, + opt (sub.expr sub) expo + ) + | Texp_new _ + | Texp_instvar _ as d -> d + | Texp_setinstvar (path1, path2, id, exp) -> + Texp_setinstvar ( + path1, + path2, + id, + sub.expr sub exp + ) + | Texp_override (path, list) -> + Texp_override ( + path, + List.map (tuple3 id id (sub.expr sub)) list + ) + | Texp_letmodule (id, s, mexpr, exp) -> + Texp_letmodule ( + id, + s, + sub.module_expr sub mexpr, + sub.expr sub exp + ) + | Texp_assert exp -> + Texp_assert (sub.expr sub exp) + | Texp_lazy exp -> + Texp_lazy (sub.expr sub exp) + | Texp_object (cl, sl) -> + Texp_object (sub.class_structure sub cl, sl) + | Texp_pack mexpr -> + Texp_pack (sub.module_expr sub mexpr) + in + {x with exp_extra; exp_desc; exp_env} + + +let package_type sub x = + let pack_fields = List.map (tuple2 id (sub.typ sub)) x.pack_fields in + {x with pack_fields} + +let signature sub x = + let sig_final_env = sub.env sub x.sig_final_env in + let sig_items = List.map (sub.signature_item sub) x.sig_items in + {x with sig_items; sig_final_env} + +let signature_item sub x = + let sig_env = sub.env sub x.sig_env in + let sig_desc = + match x.sig_desc with + | Tsig_value v -> + Tsig_value (sub.value_description sub v) + | Tsig_type (rec_flag, list) -> + let (rec_flag, list) = sub.type_declarations sub (rec_flag, list) in + Tsig_type (rec_flag, list) + | Tsig_typext te -> + Tsig_typext (sub.type_extension sub te) + | Tsig_exception ext -> + Tsig_exception (sub.extension_constructor sub ext) + | Tsig_module x -> + Tsig_module (sub.module_declaration sub x) + | Tsig_recmodule list -> + Tsig_recmodule (List.map (sub.module_declaration sub) list) + | Tsig_modtype x -> + Tsig_modtype (sub.module_type_declaration sub x) + | Tsig_include incl -> + Tsig_include (include_infos (sub.module_type sub) incl) + | Tsig_class list -> + Tsig_class (List.map (sub.class_description sub) list) + | Tsig_class_type list -> + Tsig_class_type + (List.map (sub.class_type_declaration sub) list) + | Tsig_open _ + | Tsig_attribute _ as d -> d + in + {x with sig_desc; sig_env} + +let class_description sub x = + class_infos sub (sub.class_type sub) x + +let module_type sub x = + let mty_env = sub.env sub x.mty_env in + let mty_desc = + match x.mty_desc with + | Tmty_ident _ + | Tmty_alias _ as d -> d + | Tmty_signature sg -> Tmty_signature (sub.signature sub sg) + | Tmty_functor (id, s, mtype1, mtype2) -> + Tmty_functor ( + id, + s, + opt (sub.module_type sub) mtype1, + sub.module_type sub mtype2 + ) + | Tmty_with (mtype, list) -> + Tmty_with ( + sub.module_type sub mtype, + List.map (tuple3 id id (sub.with_constraint sub)) list + ) + | Tmty_typeof mexpr -> + Tmty_typeof (sub.module_expr sub mexpr) + in + {x with mty_desc; mty_env} + +let with_constraint sub = function + | Twith_type decl -> Twith_type (sub.type_declaration sub decl) + | Twith_typesubst decl -> Twith_typesubst (sub.type_declaration sub decl) + | Twith_module _ + | Twith_modsubst _ as d -> d + +let module_coercion sub = function + | Tcoerce_none -> Tcoerce_none + | Tcoerce_functor (c1,c2) -> + Tcoerce_functor (sub.module_coercion sub c1, sub.module_coercion sub c2) + | Tcoerce_alias (p, c1) -> + Tcoerce_alias (p, sub.module_coercion sub c1) + | Tcoerce_structure (l1, l2) -> + let l1' = List.map (fun (i,c) -> i, sub.module_coercion sub c) l1 in + let l2' = List.map (fun (id,i,c) -> id, i, sub.module_coercion sub c) l2 in + Tcoerce_structure (l1', l2') + | Tcoerce_primitive pc -> + Tcoerce_primitive {pc with pc_env = sub.env sub pc.pc_env} + +let module_expr sub x = + let mod_env = sub.env sub x.mod_env in + let mod_desc = + match x.mod_desc with + | Tmod_ident _ as d -> d + | Tmod_structure st -> Tmod_structure (sub.structure sub st) + | Tmod_functor (id, s, mtype, mexpr) -> + Tmod_functor ( + id, + s, + opt (sub.module_type sub) mtype, + sub.module_expr sub mexpr + ) + | Tmod_apply (mexp1, mexp2, c) -> + Tmod_apply ( + sub.module_expr sub mexp1, + sub.module_expr sub mexp2, + sub.module_coercion sub c + ) + | Tmod_constraint (mexpr, mt, Tmodtype_implicit, c) -> + Tmod_constraint (sub.module_expr sub mexpr, mt, Tmodtype_implicit, + sub.module_coercion sub c) + | Tmod_constraint (mexpr, mt, Tmodtype_explicit mtype, c) -> + Tmod_constraint ( + sub.module_expr sub mexpr, + mt, + Tmodtype_explicit (sub.module_type sub mtype), + sub.module_coercion sub c + ) + | Tmod_unpack (exp, mty) -> + Tmod_unpack + ( + sub.expr sub exp, + mty + ) + in + {x with mod_desc; mod_env} + +let module_binding sub x = + let mb_expr = module_expr sub x.mb_expr in + {x with mb_expr} + +let class_expr sub x = + let cl_env = sub.env sub x.cl_env in + let cl_desc = + match x.cl_desc with + | Tcl_constraint (cl, clty, vals, meths, concrs) -> + Tcl_constraint ( + sub.class_expr sub cl, + opt (sub.class_type sub) clty, + vals, + meths, + concrs + ) + | Tcl_structure clstr -> + Tcl_structure (sub.class_structure sub clstr) + | Tcl_fun (label, pat, priv, cl, partial) -> + Tcl_fun ( + label, + sub.pat sub pat, + List.map (tuple3 id id (sub.expr sub)) priv, + sub.class_expr sub cl, + partial + ) + | Tcl_apply (cl, args) -> + Tcl_apply ( + sub.class_expr sub cl, + List.map (tuple3 id (opt (sub.expr sub)) id) args + ) + | Tcl_let (rec_flag, value_bindings, ivars, cl) -> + let (rec_flag, value_bindings) = sub.value_bindings sub (rec_flag, value_bindings) in + Tcl_let ( + rec_flag, + value_bindings, + List.map (tuple3 id id (sub.expr sub)) ivars, + sub.class_expr sub cl + ) + | Tcl_ident (path, lid, tyl) -> + Tcl_ident (path, lid, List.map (sub.typ sub) tyl) + in + {x with cl_desc; cl_env} + +let class_type sub x = + let cltyp_env = sub.env sub x.cltyp_env in + let cltyp_desc = + match x.cltyp_desc with + | Tcty_signature csg -> Tcty_signature (sub.class_signature sub csg) + | Tcty_constr (path, lid, list) -> + Tcty_constr ( + path, + lid, + List.map (sub.typ sub) list + ) + | Tcty_arrow (label, ct, cl) -> + Tcty_arrow + (label, + sub.typ sub ct, + sub.class_type sub cl + ) + in + {x with cltyp_desc; cltyp_env} + +let class_signature sub x = + let csig_self = sub.typ sub x.csig_self in + let csig_fields = List.map (sub.class_type_field sub) x.csig_fields in + {x with csig_self; csig_fields} + +let class_type_field sub x = + let ctf_desc = + match x.ctf_desc with + | Tctf_inherit ct -> + Tctf_inherit (sub.class_type sub ct) + | Tctf_val (s, mut, virt, ct) -> + Tctf_val (s, mut, virt, sub.typ sub ct) + | Tctf_method (s, priv, virt, ct) -> + Tctf_method (s, priv, virt, sub.typ sub ct) + | Tctf_constraint (ct1, ct2) -> + Tctf_constraint (sub.typ sub ct1, sub.typ sub ct2) + | Tctf_attribute _ as d -> d + in + {x with ctf_desc} + +let typ sub x = + let ctyp_env = sub.env sub x.ctyp_env in + let ctyp_desc = + match x.ctyp_desc with + | Ttyp_any + | Ttyp_var _ as d -> d + | Ttyp_arrow (label, ct1, ct2) -> + Ttyp_arrow (label, sub.typ sub ct1, sub.typ sub ct2) + | Ttyp_tuple list -> Ttyp_tuple (List.map (sub.typ sub) list) + | Ttyp_constr (path, lid, list) -> + Ttyp_constr (path, lid, List.map (sub.typ sub) list) + | Ttyp_object (list, closed) -> + Ttyp_object ( + List.map (tuple3 id id (sub.typ sub)) list, + closed + ) + | Ttyp_class (path, lid, list) -> + Ttyp_class + (path, + lid, + List.map (sub.typ sub) list + ) + | Ttyp_alias (ct, s) -> + Ttyp_alias (sub.typ sub ct, s) + | Ttyp_variant (list, closed, labels) -> + Ttyp_variant (List.map (sub.row_field sub) list, closed, labels) + | Ttyp_poly (sl, ct) -> + Ttyp_poly (sl, sub.typ sub ct) + | Ttyp_package pack -> + Ttyp_package (sub.package_type sub pack) + in + {x with ctyp_desc; ctyp_env} + +let class_structure sub x = + let cstr_self = sub.pat sub x.cstr_self in + let cstr_fields = List.map (sub.class_field sub) x.cstr_fields in + {x with cstr_self; cstr_fields} + +let row_field sub = function + | Ttag (label, attrs, b, list) -> + Ttag (label, attrs, b, List.map (sub.typ sub) list) + | Tinherit ct -> Tinherit (sub.typ sub ct) + +let class_field_kind sub = function + | Tcfk_virtual ct -> Tcfk_virtual (sub.typ sub ct) + | Tcfk_concrete (ovf, e) -> Tcfk_concrete (ovf, sub.expr sub e) + +let class_field sub x = + let cf_desc = + match x.cf_desc with + | Tcf_inherit (ovf, cl, super, vals, meths) -> + Tcf_inherit (ovf, sub.class_expr sub cl, super, vals, meths) + | Tcf_constraint (cty, cty') -> + Tcf_constraint ( + sub.typ sub cty, + sub.typ sub cty' + ) + | Tcf_val (s, mf, id, k, b) -> + Tcf_val (s, mf, id, class_field_kind sub k, b) + | Tcf_method (s, priv, k) -> + Tcf_method (s, priv, class_field_kind sub k) + | Tcf_initializer exp -> + Tcf_initializer (sub.expr sub exp) + | Tcf_attribute _ as d -> d + in + {x with cf_desc} + +let value_bindings sub (rec_flag, list) = + (rec_flag, List.map (sub.value_binding sub) list) + +let cases sub l = + List.map (sub.case sub) l + +let case sub {c_lhs; c_guard; c_rhs} = + { + c_lhs = sub.pat sub c_lhs; + c_guard = opt (sub.expr sub) c_guard; + c_rhs = sub.expr sub c_rhs; + } + +let value_binding sub x = + let vb_pat = sub.pat sub x.vb_pat in + let vb_expr = sub.expr sub x.vb_expr in + {x with vb_pat; vb_expr} + +let env _sub x = x + +let default = + { + case; + cases; + class_declaration; + class_description; + class_expr; + class_field; + class_signature; + class_structure; + class_type; + class_type_declaration; + class_type_field; + env; + expr; + extension_constructor; + module_binding; + module_coercion; + module_declaration; + module_expr; + module_type; + module_type_declaration; + package_type; + pat; + row_field; + signature; + signature_item; + structure; + structure_item; + typ; + type_declaration; + type_declarations; + type_extension; + type_kind; + value_binding; + value_bindings; + value_description; + with_constraint; + } diff --git a/typing/tast_mapper.mli b/typing/tast_mapper.mli new file mode 100644 index 0000000000..863145da02 --- /dev/null +++ b/typing/tast_mapper.mli @@ -0,0 +1,64 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Alain Frisch, LexiFi *) +(* *) +(* Copyright 2015 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. *) +(* *) +(***********************************************************************) + +open Asttypes +open Typedtree + +(** {2 A generic Typedtree mapper} *) + +type mapper = + { + case: mapper -> case -> case; + cases: mapper -> case list -> case list; + class_declaration: mapper -> class_declaration -> class_declaration; + class_description: mapper -> class_description -> class_description; + class_expr: mapper -> class_expr -> class_expr; + class_field: mapper -> class_field -> class_field; + 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_field: mapper -> class_type_field -> class_type_field; + env: mapper -> Env.t -> Env.t; + expr: mapper -> expression -> expression; + extension_constructor: mapper -> extension_constructor -> + extension_constructor; + module_binding: mapper -> module_binding -> module_binding; + module_coercion: mapper -> module_coercion -> module_coercion; + 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; + package_type: mapper -> package_type -> package_type; + pat: mapper -> pattern -> pattern; + row_field: mapper -> row_field -> row_field; + signature: mapper -> signature -> signature; + signature_item: mapper -> signature_item -> signature_item; + structure: mapper -> structure -> structure; + structure_item: mapper -> structure_item -> structure_item; + typ: mapper -> core_type -> core_type; + type_declaration: mapper -> type_declaration -> type_declaration; + type_declarations: mapper -> (rec_flag * type_declaration list) -> + (rec_flag * type_declaration list); + type_extension: mapper -> type_extension -> type_extension; + type_kind: mapper -> type_kind -> type_kind; + value_binding: mapper -> value_binding -> value_binding; + value_bindings: mapper -> (rec_flag * value_binding list) -> + (rec_flag * value_binding list); + value_description: mapper -> value_description -> value_description; + with_constraint: mapper -> with_constraint -> with_constraint; + } + + +val default: mapper diff --git a/typing/typeclass.ml b/typing/typeclass.ml index eb77462147..aeec7bf33c 100644 --- a/typing/typeclass.ml +++ b/typing/typeclass.ml @@ -23,7 +23,7 @@ type error = | Field_type_mismatch of string * string * (type_expr * type_expr) list | Structure_expected of class_type | Cannot_apply of class_type - | Apply_wrong_label of label + | Apply_wrong_label of arg_label | Pattern_type_clash of type_expr | Repeated_parameter | Unbound_class_2 of Longident.t @@ -153,23 +153,26 @@ let rec abbreviate_class_type path params cty = | Cty_arrow (l, ty, cty) -> Cty_arrow (l, ty, abbreviate_class_type path params cty) +(* Check that all type variables are generalizable *) +(* Use Env.empty to prevent expansion of recursively defined object types; + cf. typing-poly/poly.ml *) let rec closed_class_type = function Cty_constr (_, params, _) -> - List.for_all Ctype.closed_schema params + List.for_all (Ctype.closed_schema Env.empty) params | Cty_signature sign -> - Ctype.closed_schema sign.csig_self + Ctype.closed_schema Env.empty sign.csig_self && - Vars.fold (fun _ (_, _, ty) cc -> Ctype.closed_schema ty && cc) + Vars.fold (fun _ (_, _, ty) cc -> Ctype.closed_schema Env.empty ty && cc) sign.csig_vars true | Cty_arrow (_, ty, cty) -> - Ctype.closed_schema ty + Ctype.closed_schema Env.empty ty && closed_class_type cty let closed_class cty = - List.for_all Ctype.closed_schema cty.cty_params + List.for_all (Ctype.closed_schema Env.empty) cty.cty_params && closed_class_type cty.cty_type @@ -352,7 +355,7 @@ let type_constraint val_env sty sty' loc = let make_method loc cl_num expr = let open Ast_helper in let mkid s = mkloc s loc in - Exp.fun_ ~loc:expr.pexp_loc "" None + Exp.fun_ ~loc:expr.pexp_loc Nolabel None (Pat.alias ~loc (Pat.var ~loc (mkid "self-*")) (mkid ("self-" ^ cl_num))) expr @@ -498,6 +501,10 @@ and class_type env scty = | Pcty_arrow (l, sty, scty) -> let cty = transl_simple_type env false sty in let ty = cty.ctyp_type in + let ty = + if Btype.is_optional l + then Ctype.newty (Tconstr(Predef.path_option,[ty], ref Mnil)) + else ty in let clty = class_type env scty in let typ = Cty_arrow (l, ty, clty.cltyp_type) in cltyp (Tcty_arrow (l, cty, clty)) typ @@ -672,8 +679,10 @@ let rec class_field self_loc cl_num self_type meths vars let field = lazy begin + (* Read the generalized type *) + let (_, ty) = Meths.find lab.txt !meths in let meth_type = - Btype.newgenty (Tarrow("", self_type, ty, Cok)) in + Btype.newgenty (Tarrow(Nolabel, self_type, ty, Cok)) in Ctype.raise_nongen_level (); vars := vars_local; let texp = type_expect met_env meth_expr meth_type in @@ -698,7 +707,7 @@ let rec class_field self_loc cl_num self_type meths vars Ctype.raise_nongen_level (); let meth_type = Ctype.newty - (Tarrow ("", self_type, + (Tarrow (Nolabel, self_type, Ctype.instance_def Predef.type_unit, Cok)) in vars := vars_local; let texp = type_expect met_env expr meth_type in @@ -811,12 +820,16 @@ and class_structure cl_num final val_env met_env loc end; (* Typing of method bodies *) - if !Clflags.principal then - List.iter (fun (_,_,ty) -> Ctype.generalize_spine ty) methods; + (* if !Clflags.principal then *) begin + let ms = !meths in + (* Generalize the spine of methods accessed through self *) + Meths.iter (fun _ (_,ty) -> Ctype.generalize_spine ty) ms; + meths := + Meths.map (fun (id,ty) -> (id, Ctype.generic_instance val_env ty)) ms; + (* But keep levels correct on the type of self *) + Meths.iter (fun _ (_,ty) -> Ctype.unify val_env ty (Ctype.newvar ())) ms + end; let fields = List.map Lazy.force (List.rev fields) in - if !Clflags.principal then - List.iter (fun (_,_,ty) -> Ctype.unify val_env ty (Ctype.newvar ())) - methods; let meths = Meths.map (function (id, ty) -> id) !meths in (* Check for private methods made public *) @@ -944,7 +957,7 @@ and class_expr cl_num val_env met_env scl = | _ -> true in let partial = - Parmatch.check_partial pat.pat_loc + Typecore.check_partial val_env pat.pat_type pat.pat_loc [{c_lhs=pat; c_guard=None; c_rhs = (* Dummy expression *) @@ -988,10 +1001,14 @@ and class_expr cl_num val_env met_env scl = !Clflags.classic || let labels = nonopt_labels [] cl.cl_type in List.length labels = List.length sargs && - List.for_all (fun (l,_) -> l = "") sargs && - List.exists (fun l -> l <> "") labels && + List.for_all (fun (l,_) -> l = Nolabel) sargs && + List.exists (fun l -> l <> Nolabel) labels && begin - Location.prerr_warning cl.cl_loc Warnings.Labels_omitted; + Location.prerr_warning + cl.cl_loc + (Warnings.Labels_omitted + (List.map Printtyp.string_of_label + (List.filter ((<>) Nolabel) labels))); true end in @@ -1008,7 +1025,7 @@ and class_expr cl_num val_env met_env scl = (l', sarg0)::_, _ -> raise(Error(sarg0.pexp_loc, val_env, Apply_wrong_label l')) | _, (l', sarg0)::more_sargs -> - if l <> l' && l' <> "" then + if l <> l' && l' <> Nolabel then raise(Error(sarg0.pexp_loc, val_env, Apply_wrong_label l')) else ([], more_sargs, @@ -1028,7 +1045,7 @@ and class_expr cl_num val_env met_env scl = in if optional = Required && Btype.is_optional l' then Location.prerr_warning sarg0.pexp_loc - (Warnings.Nonoptional_label l); + (Warnings.Nonoptional_label (Printtyp.string_of_label l)); sargs, more_sargs, if optional = Required || Btype.is_optional l' then Some (type_argument val_env sarg0 ty ty0) @@ -1040,7 +1057,7 @@ and class_expr cl_num val_env met_env scl = with Not_found -> sargs, more_sargs, if Btype.is_optional l && - (List.mem_assoc "" sargs || List.mem_assoc "" more_sargs) + (List.mem_assoc Nolabel sargs || List.mem_assoc Nolabel more_sargs) then Some (option_none ty0 Location.none) else None @@ -1704,8 +1721,8 @@ let report_error env ppf = function "This class expression is not a class function, it cannot be applied" | Apply_wrong_label l -> let mark_label = function - | "" -> "out label" - | l -> sprintf " label ~%s" l in + | Nolabel -> "out label" + | l -> sprintf " label %s" (Btype.prefixed_label_name l) in fprintf ppf "This argument cannot be applied with%s" (mark_label l) | Pattern_type_clash ty -> (* XXX Trace *) diff --git a/typing/typeclass.mli b/typing/typeclass.mli index 8e8675fe76..d213221a84 100644 --- a/typing/typeclass.mli +++ b/typing/typeclass.mli @@ -81,7 +81,7 @@ type error = | Field_type_mismatch of string * string * (type_expr * type_expr) list | Structure_expected of class_type | Cannot_apply of class_type - | Apply_wrong_label of label + | Apply_wrong_label of arg_label | Pattern_type_clash of type_expr | Repeated_parameter | Unbound_class_2 of Longident.t diff --git a/typing/typecore.ml b/typing/typecore.ml index 2435493402..5134dc942e 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -27,23 +27,23 @@ type error = | Pattern_type_clash of (type_expr * type_expr) list | Or_pattern_type_clash of Ident.t * (type_expr * type_expr) list | Multiply_bound_variable of string - | Orpat_vars of Ident.t + | Orpat_vars of Ident.t * Ident.t list | Expr_type_clash of (type_expr * type_expr) list | Apply_non_function of type_expr - | Apply_wrong_label of label * type_expr + | Apply_wrong_label of arg_label * type_expr | Label_multiply_defined of string | Label_missing of Ident.t list | Label_not_mutable of Longident.t - | Wrong_name of string * type_expr * string * Path.t * Longident.t + | Wrong_name of string * type_expr * string * Path.t * string * string list | Name_type_mismatch of string * Longident.t * (Path.t * Path.t) * (Path.t * Path.t) list | Invalid_format of string - | Undefined_method of type_expr * string - | Undefined_inherited_method of string + | Undefined_method of type_expr * string * string list option + | Undefined_inherited_method of string * string list | Virtual_class of Longident.t | Private_type of type_expr | Private_label of Longident.t * type_expr - | Unbound_instance_variable of string + | Unbound_instance_variable of string * string list | Instance_variable_not_mutable of bool * string | Not_subtype of (type_expr * type_expr) list * (type_expr * type_expr) list | Outside_class @@ -51,7 +51,7 @@ type error = | Coercion_failure of type_expr * type_expr * (type_expr * type_expr) list * bool | Too_many_arguments of bool * type_expr - | Abstract_wrong_label of label * type_expr + | Abstract_wrong_label of arg_label * type_expr | Scoping_let_module of string * type_expr | Masked_instance_variable of Longident.t | Not_a_variant_type of Longident.t @@ -294,6 +294,7 @@ let extract_concrete_record env ty = let extract_concrete_variant env ty = match extract_concrete_typedecl env ty with (p0, p, {type_kind=Type_variant cstrs}) -> (p0, p, cstrs) + | (p0, p, {type_kind=Type_open}) -> (p0, p, []) | _ -> raise Not_found let extract_label_names sexp env ty = @@ -449,7 +450,9 @@ let enter_orpat_variables loc env p1_vs p2_vs = let p1_vs = sort_pattern_variables p1_vs and p2_vs = sort_pattern_variables p2_vs in - let rec unify_vars p1_vs p2_vs = match p1_vs, p2_vs with + let rec unify_vars p1_vs p2_vs = + let vars vs = List.map (fun (x,_t,_,_l,_a) -> x) vs in + match p1_vs, p2_vs with | (x1,t1,_,l1,a1)::rem1, (x2,t2,_,l2,a2)::rem2 when Ident.equal x1 x2 -> if x1==x2 then unify_vars rem1 rem2 @@ -463,13 +466,14 @@ let enter_orpat_variables loc env p1_vs p2_vs = (x2,x1)::unify_vars rem1 rem2 end | [],[] -> [] - | (x,_,_,_,_)::_, [] -> raise (Error (loc, env, Orpat_vars x)) - | [],(x,_,_,_,_)::_ -> raise (Error (loc, env, Orpat_vars x)) + | (x,_,_,_,_)::_, [] -> raise (Error (loc, env, Orpat_vars (x, vars p2_vs))) + | [],(y,_,_,_,_)::_ -> raise (Error (loc, env, Orpat_vars (y, vars p1_vs))) | (x,_,_,_,_)::_, (y,_,_,_,_)::_ -> - let min_var = - if Ident.name x < Ident.name y then x - else y in - raise (Error (loc, env, Orpat_vars min_var)) in + let err = + if Ident.name x < Ident.name y + then Orpat_vars (x, vars p2_vs) + else Orpat_vars (y, vars p1_vs) in + raise (Error (loc, env, err)) in unify_vars p1_vs p2_vs let rec build_as_type env p = @@ -595,6 +599,8 @@ let compare_type_path env tpath1 tpath2 = Path.same (expand_path env tpath1) (expand_path env tpath2) (* Records *) +let label_of_kind kind = + if kind = "record" then "field" else "constructor" module NameChoice(Name : sig type t @@ -602,23 +608,16 @@ module NameChoice(Name : sig val get_name: t -> string val get_type: t -> type_expr 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 let get_type_path env d = - match (get_type d).desc with + match (repr (get_type d)).desc with | Tconstr(p, _, _) -> p | _ -> assert false - let spellcheck ppf env p lid = - Typetexp.spellcheck_simple ppf fold - (fun d -> - if compare_type_path env p (get_type_path env d) - then get_name d else "") env lid - let lookup_from_type env tpath lid = let descrs = get_descrs (Env.find_type_descrs tpath env) in Env.mark_type_used env (Path.last tpath) (Env.find_type tpath env); @@ -627,8 +626,9 @@ end) = struct try List.find (fun nd -> get_name nd = s) descrs with Not_found -> + let names = List.map get_name descrs in raise (Error (lid.loc, env, - Wrong_name ("", newvar (), type_kind, tpath, lid.txt))) + Wrong_name ("", newvar (), type_kind, tpath, s, names))) end | _ -> raise Not_found @@ -672,10 +672,10 @@ end) = struct end | Some(tpath0, tpath, pr) -> let warn_pr () = - let kind = if type_kind = "record" then "field" else "constructor" in + let label = label_of_kind type_kind in warn lid.loc (Warnings.Not_principal - ("this type-based " ^ kind ^ " disambiguation")) + ("this type-based " ^ label ^ " disambiguation")) in try let lbl, use = disambiguate_by_type env tpath scope in @@ -731,8 +731,8 @@ end) = struct end let wrap_disambiguate kind ty f x = - try f x with Error (loc, env, Wrong_name (_,_,tk,tp,lid)) -> - raise (Error (loc, env, Wrong_name (kind,ty,tk,tp,lid))) + try f x with Error (loc, env, Wrong_name ("",_,tk,tp,name,valid_names)) -> + raise (Error (loc, env, Wrong_name (kind,ty,tk,tp,name,valid_names))) module Label = NameChoice (struct type t = label_description @@ -740,7 +740,6 @@ module Label = NameChoice (struct let get_name lbl = lbl.lbl_name let get_type lbl = lbl.lbl_res 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 @@ -896,7 +895,6 @@ module Constructor = NameChoice (struct let get_name cstr = cstr.cstr_name let get_type cstr = cstr.cstr_res let get_descrs = fst - let fold = Env.fold_constructors let unbound_name_error = Typetexp.unbound_constructor_error let in_env _ = true end) @@ -909,7 +907,7 @@ let unify_head_only loc env ty constr = | Tconstr(p,args,m) -> ty_res.desc <- Tconstr(p,List.map (fun _ -> newvar ()) args,m); enforce_constraints env ty_res; - unify_pat_types loc env ty ty_res + unify_pat_types loc env ty_res ty | _ -> assert false (* Typing of patterns *) @@ -1278,6 +1276,9 @@ let partial_pred ~lev env expected_ty constrs labels p = backtrack snap; None +let check_partial ?(lev=get_current_level ()) env expected_ty = + Parmatch.check_partial_gadt (partial_pred ~lev env expected_ty) + let rec iter3 f lst1 lst2 lst3 = match lst1,lst2,lst3 with | x1::xs1,x2::xs2,x3::xs3 -> @@ -1531,12 +1532,11 @@ let rec approx_type env sty = let rec type_approx env sexp = match sexp.pexp_desc with Pexp_let (_, _, e) -> type_approx env e - | Pexp_fun (p, _, _, e) when is_optional p -> - newty (Tarrow(p, type_option (newvar ()), type_approx env e, Cok)) - | Pexp_fun (p,_,_, e) -> - newty (Tarrow(p, newvar (), type_approx env e, Cok)) + | Pexp_fun (p, _, _, e) -> + let ty = if is_optional p then type_option (newvar ()) else newvar () in + newty (Tarrow(p, ty, type_approx env e, Cok)) | Pexp_function ({pc_rhs=e}::_) -> - newty (Tarrow("", newvar (), type_approx env e, Cok)) + newty (Tarrow(Nolabel, newvar (), type_approx env e, Cok)) | Pexp_match (_, {pc_rhs=e}::_) -> type_approx env e | Pexp_try (e, _) -> type_approx env e | Pexp_tuple l -> newty (Ttuple(List.map (type_approx env) l)) @@ -1641,7 +1641,7 @@ let create_package_type loc env (p, l) = let open Ast_helper in List.fold_left (fun sexp (name, loc) -> - Exp.letmodule ~loc:sexp.pexp_loc + Exp.letmodule ~loc:sexp.pexp_loc ~attrs:[mknoloc "#modulepat",PStr []] name (Mod.unpack ~loc (Exp.ident ~loc:name.loc (mkloc (Longident.Lident name.txt) name.loc))) @@ -1886,7 +1886,7 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected = exp_type = body.exp_type; exp_attributes = sexp.pexp_attributes; exp_env = env } - | Pexp_fun (l, Some default, spat, sexp) -> + | Pexp_fun (l, Some default, spat, sbody) -> assert(is_optional l); (* default allowed only with optional argument *) let open Ast_helper in let default_loc = default.pexp_loc in @@ -1908,21 +1908,19 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected = Exp.match_ ~loc (Exp.ident ~loc (mknoloc (Longident.Lident "*opt*"))) scases in - let sfun = - Exp.fun_ ~loc - l None - (Pat.var ~loc (mknoloc "*opt*")) - (Exp.let_ ~loc Nonrecursive ~attrs:[mknoloc "#default",PStr []] - [Vb.mk spat smatch] sexp) + let pat = Pat.var ~loc (mknoloc "*opt*") in + let body = + Exp.let_ ~loc Nonrecursive ~attrs:[mknoloc "#default",PStr []] + [Vb.mk spat smatch] sbody in - type_expect ?in_function env sfun ty_expected - (* TODO: keep attributes, call type_function directly *) - | Pexp_fun (l, None, spat, sexp) -> type_function ?in_function loc sexp.pexp_attributes env ty_expected - l [{pc_lhs=spat; pc_guard=None; pc_rhs=sexp}] + l [Exp.case pat body] + | Pexp_fun (l, None, spat, sbody) -> + type_function ?in_function loc sexp.pexp_attributes env ty_expected + l [Ast_helper.Exp.case spat sbody] | Pexp_function caselist -> type_function ?in_function - loc sexp.pexp_attributes env ty_expected "" caselist + loc sexp.pexp_attributes env ty_expected Nolabel caselist | Pexp_apply(sfunct, sargs) -> if sargs = [] then Syntaxerr.ill_formed_ast loc "Function application with no argument."; @@ -2364,10 +2362,12 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected = | Pexp_send (e, met) -> if !Clflags.principal then begin_def (); let obj = type_exp env e in + let obj_meths = ref None in begin try let (meth, exp, typ) = match obj.exp_desc with Texp_ident(path, _, {val_kind = Val_self (meths, _, _, privty)}) -> + obj_meths := Some meths; let (id, typ) = filter_self_method env met Private meths privty in @@ -2378,7 +2378,9 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected = | Texp_ident(path, lid, {val_kind = Val_anc (methods, cl_num)}) -> let method_id = begin try List.assoc met methods with Not_found -> - raise(Error(e.pexp_loc, env, Undefined_inherited_method met)) + let valid_methods = List.map fst methods in + raise(Error(e.pexp_loc, env, + Undefined_inherited_method (met, valid_methods))) end in begin match @@ -2387,11 +2389,12 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected = with (_, ({val_kind = Val_self (meths, _, _, privty)} as desc)), (path, _) -> + obj_meths := Some meths; let (_, typ) = filter_self_method env met Private meths privty in let method_type = newvar () in - let (obj_ty, res_ty) = filter_arrow env method_type "" in + let (obj_ty, res_ty) = filter_arrow env method_type Nolabel in unify env obj_ty desc.val_type; unify env res_ty (instance env typ); let exp = @@ -2405,13 +2408,13 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected = exp_type = method_type; exp_attributes = []; (* check *) exp_env = env}, - ["", + [ Nolabel, Some {exp_desc = Texp_ident(path, lid, desc); exp_loc = obj.exp_loc; exp_extra = []; exp_type = desc.val_type; exp_attributes = []; (* check *) exp_env = env}, - Required]) + Required ]) in (Tmeth_name met, Some (re {exp_desc = exp; exp_loc = loc; exp_extra = []; @@ -2454,7 +2457,21 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected = exp_attributes = sexp.pexp_attributes; exp_env = env } with Unify _ -> - raise(Error(e.pexp_loc, env, Undefined_method (obj.exp_type, met))) + let valid_methods = + match !obj_meths with + | Some meths -> + Some (Meths.fold (fun meth _meth_ty li -> meth::li) !meths []) + | None -> + match (expand_head env obj.exp_type).desc with + | Tobject (fields, _) -> + let (fields, _) = Ctype.flatten_fields fields in + let collect_fields li (meth, meth_kind, _meth_ty) = + if meth_kind = Fpresent then meth::li else li in + Some (List.fold_left collect_fields [] fields) + | _ -> None + in + raise(Error(e.pexp_loc, env, + Undefined_method (obj.exp_type, met, valid_methods))) end | Pexp_new cl -> let (cl_path, cl_decl) = Typetexp.find_class env loc cl.txt in @@ -2491,7 +2508,12 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected = raise(Error(loc, env, Instance_variable_not_mutable(false,lab.txt))) with Not_found -> - raise(Error(loc, env, Unbound_instance_variable lab.txt)) + let collect_vars name _path val_desc li = + match val_desc.val_kind with + | Val_ivar (Mutable, _) -> name::li + | _ -> li in + let valid_vars = Env.fold_values collect_vars None env [] in + raise(Error(loc, env, Unbound_instance_variable (lab.txt, valid_vars))) end | Pexp_override lst -> let _ = @@ -2518,7 +2540,8 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected = (Path.Pident id, lab, type_expect env snewval (instance env ty)) with Not_found -> - raise(Error(loc, env, Unbound_instance_variable lab.txt)) + let vars = Vars.fold (fun var _ li -> var::li) !vars [] in + raise(Error(loc, env, Unbound_instance_variable (lab.txt, vars))) end in let modifs = List.map type_override lst in @@ -2901,6 +2924,7 @@ and type_format loc str env = | 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 ] + | Any_ty rest -> mk_constr "Any_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 ] @@ -3020,6 +3044,10 @@ and type_format loc str env = mk_constr "Ignored_param" [ mk_ignored ign; mk_fmt rest ] | End_of_format -> mk_constr "End_of_format" [] + | Custom _ -> + (* Custom formatters have no syntax so they will never appear + in formats parsed from strings. *) + assert false in let legacy_behavior = not !Clflags.strict_formats in let Fmt_EBB fmt = fmt_ebb_of_string ~legacy_behavior str in @@ -3084,7 +3112,7 @@ 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 - not tvar && List.for_all ((=) "") ls + not tvar && List.for_all ((=) Nolabel) ls in let rec is_inferred sexp = match sexp.pexp_desc with @@ -3095,7 +3123,7 @@ and type_argument ?recarg env sarg ty_expected' ty_expected = | _ -> false in match expand_head env ty_expected' with - {desc = Tarrow("",ty_arg,ty_res,_); level = lv} when is_inferred sarg -> + {desc = Tarrow(Nolabel,ty_arg,ty_res,_); level = lv} when is_inferred sarg -> (* apply optional arguments when expected type is "" *) (* we must be very careful about not breaking the semantics *) if !Clflags.principal then begin_def (); @@ -3109,7 +3137,7 @@ and type_argument ?recarg env sarg ty_expected' ty_expected = | Tarrow (l,ty_arg,ty_fun,_) when is_optional l -> let ty = option_none (instance env ty_arg) sarg.pexp_loc in make_args ((l, Some ty, Optional) :: args) ty_fun - | Tarrow (l,_,ty_res',_) when l = "" || !Clflags.classic -> + | Tarrow (l,_,ty_res',_) when l = Nolabel || !Clflags.classic -> List.rev args, ty_fun, no_labels ty_res' | Tvar _ -> List.rev args, ty_fun, false | _ -> [], texp.exp_type, false @@ -3145,13 +3173,14 @@ and type_argument ?recarg env sarg ty_expected' ty_expected = {texp with exp_type = ty_res; exp_desc = Texp_apply (texp, - args @ ["", Some eta_var, Required])} + args @ [Nolabel, Some eta_var, Required])} in { texp with exp_type = ty_fun; exp_desc = - Texp_function("", [case eta_pat e], Total) } + Texp_function(Nolabel, [case eta_pat e], Total) } in Location.prerr_warning texp.exp_loc - (Warnings.Eliminated_optional_arguments (List.map (fun (l, _, _) -> l) args)); + (Warnings.Eliminated_optional_arguments + (List.map (fun (l, _, _) -> Printtyp.string_of_label l) args)); if warn then Location.prerr_warning texp.exp_loc (Warnings.Without_principality "eliminated optional argument"); if is_nonexpansive texp then func texp else @@ -3183,7 +3212,7 @@ and type_application env funct sargs = let ignored = ref [] in let rec type_unknown_args (args : - (Asttypes.label * (unit -> Typedtree.expression) option * + (Asttypes.arg_label * (unit -> Typedtree.expression) option * Typedtree.optional) list) omitted ty_fun = function [] -> @@ -3209,7 +3238,7 @@ and type_application env funct sargs = unify env ty_fun (newty (Tarrow(l1,t1,t2,Clink(ref Cunknown)))); (t1, t2) | Tarrow (l,t1,t2,_) when l = l1 - || !Clflags.classic && l1 = "" && not (is_optional l) -> + || !Clflags.classic && l1 = Nolabel && not (is_optional l) -> (t1, t2) | td -> let ty_fun = @@ -3242,9 +3271,13 @@ and type_application env funct sargs = not tvar && let labels = List.filter (fun l -> not (is_optional l)) ls in List.length labels = List.length sargs && - List.for_all (fun (l,_) -> l = "") sargs && - List.exists (fun l -> l <> "") labels && - (Location.prerr_warning funct.exp_loc Warnings.Labels_omitted; + List.for_all (fun (l,_) -> l = Nolabel) sargs && + List.exists (fun l -> l <> Nolabel) labels && + (Location.prerr_warning + funct.exp_loc + (Warnings.Labels_omitted + (List.map Printtyp.string_of_label + (List.filter ((<>) Nolabel) labels))); true) end in @@ -3271,7 +3304,7 @@ and type_application env funct sargs = raise(Error(sarg0.pexp_loc, env, Apply_wrong_label(l', ty_old))) | _, (l', sarg0) :: more_sargs -> - if l <> l' && l' <> "" then + if l <> l' && l' <> Nolabel then raise(Error(sarg0.pexp_loc, env, Apply_wrong_label(l', ty_fun'))) else @@ -3297,7 +3330,7 @@ and type_application env funct sargs = in if optional = Required && is_optional l' then Location.prerr_warning sarg0.pexp_loc - (Warnings.Nonoptional_label l); + (Warnings.Nonoptional_label (Printtyp.string_of_label l)); sargs, more_sargs, if optional = Required || is_optional l' then Some (fun () -> type_argument env sarg0 ty ty0) @@ -3311,7 +3344,7 @@ and type_application env funct sargs = with Not_found -> sargs, more_sargs, if optional = Optional && - (List.mem_assoc "" sargs || List.mem_assoc "" more_sargs) + (List.mem_assoc Nolabel sargs || List.mem_assoc Nolabel more_sargs) then begin may_warn funct.exp_loc (Warnings.Without_principality "eliminated optional argument"); @@ -3340,8 +3373,8 @@ and type_application env funct sargs = match funct.exp_desc, sargs with (* Special case for ignore: avoid discarding warning *) Texp_ident (_, _, {val_kind=Val_prim{Primitive.prim_name="%ignore"}}), - ["", sarg] -> - let ty_arg, ty_res = filter_arrow env (instance env funct.exp_type) "" in + [Nolabel, sarg] -> + let ty_arg, ty_res = filter_arrow env (instance env funct.exp_type) Nolabel in let exp = type_expect env sarg ty_arg in begin match (expand_head env exp.exp_type).desc with | Tarrow _ -> @@ -3350,7 +3383,7 @@ and type_application env funct sargs = add_delayed_check (fun () -> check_application_result env false exp) | _ -> () end; - (["", Some exp, Required], ty_res) + ([Nolabel, Some exp, Required], ty_res) | _ -> let ty = funct.exp_type in if ignore_labels then @@ -3574,7 +3607,7 @@ and type_cases ?in_function env ty_arg ty_res partial_flag loc caselist = end; let partial = if partial_flag then - Parmatch.check_partial_gadt (partial_pred ~lev env ty_arg) loc cases + check_partial ~lev env ty_arg loc cases else Partial in @@ -3727,7 +3760,7 @@ and type_let ?(check = fun s -> Warnings.Unused_var s) in let exp_list = List.map2 - (fun {pvb_expr=sexp; _} (pat, slot) -> + (fun {pvb_expr=sexp; pvb_attributes; _} (pat, slot) -> let sexp = if rec_flag = Recursive then wrap_unpacks sexp unpacks else sexp in if is_recursive then current_slot := slot; @@ -3740,11 +3773,16 @@ and type_let ?(check = fun s -> Warnings.Unused_var s) end_def (); generalize_structure ty' end; - let exp = type_expect exp_env sexp ty' in + let exp = + Typetexp.with_warning_attribute pvb_attributes (fun () -> + type_expect exp_env sexp ty') + in end_def (); check_univars env true "definition" exp pat.pat_type vars; {exp with exp_type = instance env exp.exp_type} - | _ -> type_expect exp_env sexp pat.pat_type) + | _ -> + Typetexp.with_warning_attribute pvb_attributes (fun () -> + type_expect exp_env sexp pat.pat_type)) spat_sexp_list pat_slot_list in current_slot := None; if is_recursive && not !rec_needed @@ -3752,7 +3790,8 @@ and type_let ?(check = fun s -> Warnings.Unused_var s) Location.prerr_warning (List.hd spat_sexp_list).pvb_pat.ppat_loc Warnings.Unused_rec_flag; List.iter2 - (fun pat exp -> ignore(Parmatch.check_partial pat.pat_loc [case pat exp])) + (fun pat exp -> + ignore(check_partial env pat.pat_type pat.pat_loc [case pat exp])) pat_list exp_list; end_def(); List.iter2 @@ -3809,6 +3848,14 @@ let type_expression env sexp = (* Error report *) +let spellcheck ppf unbound_name valid_names = + Misc.did_you_mean ppf (fun () -> + Misc.spellcheck valid_names unbound_name + ) + +let spellcheck_idents ppf unbound valid_idents = + spellcheck ppf (Ident.name unbound) (List.map Ident.name valid_idents) + open Format open Printtyp @@ -3842,9 +3889,10 @@ let report_error env ppf = function fprintf ppf "but on the right-hand side it has type") | Multiply_bound_variable name -> fprintf ppf "Variable %s is bound several times in this matching" name - | Orpat_vars id -> + | Orpat_vars (id, valid_idents) -> fprintf ppf "Variable %s must occur on both sides of this | pattern" - (Ident.name id) + (Ident.name id); + spellcheck_idents ppf id valid_idents | Expr_type_clash trace -> report_unification_error ppf env trace (function ppf -> @@ -3866,7 +3914,7 @@ let report_error env ppf = function end | Apply_wrong_label (l, ty) -> let print_label ppf = function - | "" -> fprintf ppf "without label" + | Nolabel -> fprintf ppf "without label" | l -> fprintf ppf "with label %s" (prefixed_label_name l) in @@ -3884,24 +3932,23 @@ let report_error env ppf = function print_labels labels | Label_not_mutable lid -> fprintf ppf "The record field %a is not mutable" longident lid - | Wrong_name (eorp, ty, kind, p, lid) -> + | Wrong_name (eorp, ty, kind, p, name, valid_names) -> reset_and_mark_loops ty; if Path.is_constructor_typath p then begin - fprintf ppf "@[The field %a is not part of the record \ + fprintf ppf "@[The field %s is not part of the record \ argument for the %a constructor@]" - longident lid + name 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@]" - (if kind = "record" then "field" else "constructor") - longident lid (*kind*) path p; - if kind = "record" then Label.spellcheck ppf env p lid - else Constructor.spellcheck ppf env p lid - end + fprintf ppf "The %s %s does not belong to type %a@]" + (label_of_kind kind) + name (*kind*) path p; + end; + spellcheck ppf name valid_names; | Name_type_mismatch (kind, lid, tp, tpl) -> - let name = if kind = "record" then "field" else "constructor" in + let name = label_of_kind kind in report_ambiguous_type_error ppf env tp tpl (function ppf -> fprintf ppf "The %s %a@ belongs to the %s type" @@ -3914,18 +3961,24 @@ let report_error env ppf = function name kind) | Invalid_format msg -> fprintf ppf "%s" msg - | Undefined_method (ty, me) -> + | Undefined_method (ty, me, valid_methods) -> reset_and_mark_loops ty; fprintf ppf "@[<v>@[This expression has type@;<1 2>%a@]@,\ - It has no method %s@]" type_expr ty me - | Undefined_inherited_method me -> - fprintf ppf "This expression has no method %s" me + It has no method %s@]" type_expr ty me; + begin match valid_methods with + | None -> () + | Some valid_methods -> spellcheck ppf me valid_methods + end + | Undefined_inherited_method (me, valid_methods) -> + fprintf ppf "This expression has no method %s" me; + spellcheck ppf me valid_methods; | Virtual_class cl -> fprintf ppf "Cannot instantiate the virtual class %a" longident cl - | Unbound_instance_variable v -> - fprintf ppf "Unbound instance variable %s" v + | Unbound_instance_variable (var, valid_vars) -> + fprintf ppf "Unbound instance variable %s" var; + spellcheck ppf var valid_vars; | Instance_variable_not_mutable (b, v) -> if b then fprintf ppf "The instance variable %s is not mutable" v @@ -3963,9 +4016,8 @@ let report_error env ppf = function end | 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" - (prefixed_label_name l) in + | Nolabel -> "but its first argument is not labelled" + | 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) diff --git a/typing/typecore.mli b/typing/typecore.mli index 4a450e344c..b6f9af2ac5 100644 --- a/typing/typecore.mli +++ b/typing/typecore.mli @@ -31,7 +31,7 @@ val type_let: val type_expression: Env.t -> Parsetree.expression -> Typedtree.expression val type_class_arg_pattern: - string -> Env.t -> Env.t -> label -> Parsetree.pattern -> + string -> Env.t -> Env.t -> arg_label -> Parsetree.pattern -> Typedtree.pattern * (Ident.t * string loc * Ident.t * type_expr) list * Env.t * Env.t val type_self_pattern: @@ -41,6 +41,9 @@ val type_self_pattern: (Ident.t * Asttypes.mutable_flag * Asttypes.virtual_flag * type_expr) Vars.t ref * Env.t * Env.t * Env.t +val check_partial: + ?lev:int -> Env.t -> type_expr -> + Location.t -> Typedtree.case list -> Typedtree.partial val type_expect: ?in_function:(Location.t * type_expr) -> Env.t -> Parsetree.expression -> type_expr -> Typedtree.expression @@ -69,23 +72,23 @@ type error = | Pattern_type_clash of (type_expr * type_expr) list | Or_pattern_type_clash of Ident.t * (type_expr * type_expr) list | Multiply_bound_variable of string - | Orpat_vars of Ident.t + | Orpat_vars of Ident.t * Ident.t list | Expr_type_clash of (type_expr * type_expr) list | Apply_non_function of type_expr - | Apply_wrong_label of label * type_expr + | Apply_wrong_label of arg_label * type_expr | Label_multiply_defined of string | Label_missing of Ident.t list | Label_not_mutable of Longident.t - | Wrong_name of string * type_expr * string * Path.t * Longident.t + | Wrong_name of string * type_expr * string * Path.t * string * string list | Name_type_mismatch of string * Longident.t * (Path.t * Path.t) * (Path.t * Path.t) list | Invalid_format of string - | Undefined_method of type_expr * string - | Undefined_inherited_method of string + | Undefined_method of type_expr * string * string list option + | Undefined_inherited_method of string * string list | Virtual_class of Longident.t | Private_type of type_expr | Private_label of Longident.t * type_expr - | Unbound_instance_variable of string + | Unbound_instance_variable of string * string list | Instance_variable_not_mutable of bool * string | Not_subtype of (type_expr * type_expr) list * (type_expr * type_expr) list | Outside_class @@ -93,7 +96,7 @@ type error = | Coercion_failure of type_expr * type_expr * (type_expr * type_expr) list * bool | Too_many_arguments of bool * type_expr - | Abstract_wrong_label of label * type_expr + | Abstract_wrong_label of arg_label * type_expr | Scoping_let_module of string * type_expr | Masked_instance_variable of Longident.t | Not_a_variant_type of Longident.t diff --git a/typing/typedecl.ml b/typing/typedecl.ml index 90c432bc52..ccca63a614 100644 --- a/typing/typedecl.ml +++ b/typing/typedecl.ml @@ -45,6 +45,7 @@ type error = | Bad_fixed_type of string | Unbound_type_var_ext of type_expr * extension_constructor | Varying_anonymous + | Val_in_structure open Typedtree @@ -522,7 +523,7 @@ let check_well_founded env loc path to_check ty = (* Will be detected by check_recursion *) Btype.backtrack snap in - check ty TypeSet.empty ty + Ctype.wrap_trace_gadt_instances env (check ty TypeSet.empty) ty let check_well_founded_manifest env loc path decl = if decl.type_manifest = None then () else @@ -984,8 +985,8 @@ let name_recursion sdecl id decl = else decl | _ -> decl -(* Translate a set of mutually recursive type declarations *) -let transl_type_decl env sdecl_list = +(* Translate a set of type declarations, mutually recursive or not *) +let transl_type_decl env rec_flag sdecl_list = (* Add dummy types for fixed rows *) let fixed_types = List.filter is_fixed_type sdecl_list in let sdecl_list = @@ -1012,29 +1013,35 @@ let transl_type_decl env sdecl_list = Ctype.init_def(Ident.current_time()); Ctype.begin_def(); (* Enter types. *) - let temp_env = List.fold_left2 enter_type env sdecl_list id_list in + let temp_env = + match rec_flag with + | Asttypes.Nonrecursive -> env + | Asttypes.Recursive -> List.fold_left2 enter_type env sdecl_list id_list + in (* Translate each declaration. *) let current_slot = ref None in let warn_unused = Warnings.is_active (Warnings.Unused_type_declaration "") in let id_slots id = - if not warn_unused then id, None - else - (* See typecore.ml for a description of the algorithm used - to detect unused declarations in a set of recursive definitions. *) - let slot = ref [] in - let td = Env.find_type (Path.Pident id) temp_env in - let name = Ident.name id in - Env.set_type_used_callback - name td - (fun old_callback -> - match !current_slot with - | Some slot -> slot := (name, td) :: !slot - | None -> - List.iter (fun (name, d) -> Env.mark_type_used env name d) - (get_ref slot); - old_callback () - ); - id, Some slot + match rec_flag with + | Asttypes.Recursive when warn_unused -> + (* See typecore.ml for a description of the algorithm used + to detect unused declarations in a set of recursive definitions. *) + let slot = ref [] in + let td = Env.find_type (Path.Pident id) temp_env in + let name = Ident.name id in + Env.set_type_used_callback + name td + (fun old_callback -> + match !current_slot with + | Some slot -> slot := (name, td) :: !slot + | None -> + List.iter (fun (name, d) -> Env.mark_type_used env name d) + (get_ref slot); + old_callback () + ); + id, Some slot + | Asttypes.Recursive | Asttypes.Nonrecursive -> + id, None in let transl_declaration name_sdecl (id, slot) = current_slot := slot; transl_declaration temp_env name_sdecl id in @@ -1052,9 +1059,13 @@ let transl_type_decl env sdecl_list = decls env in (* Update stubs *) - List.iter2 - (fun id sdecl -> update_type temp_env newenv id sdecl.ptype_loc) - id_list sdecl_list; + begin match rec_flag with + | Asttypes.Nonrecursive -> () + | Asttypes.Recursive -> + List.iter2 + (fun id sdecl -> update_type temp_env newenv id sdecl.ptype_loc) + id_list sdecl_list + end; (* Generalize type declarations. *) Ctype.end_def(); List.iter (fun (_, decl) -> generalize_decl decl) decls; @@ -1346,13 +1357,15 @@ let transl_value_decl env loc valdecl = let ty = cty.ctyp_type in let v = match valdecl.pval_prim with - [] -> + [] when Env.is_in_signature env -> { val_type = ty; val_kind = Val_reg; Types.val_loc = loc; val_attributes = valdecl.pval_attributes } + | [] -> + raise (Error(valdecl.pval_loc, Val_in_structure)) | decl -> let arity = Ctype.arity ty in let prim = Primitive.parse_declaration arity decl in - if arity = 0 && prim.prim_name.[0] <> '%' then + if arity = 0 && (prim.prim_name = "" || prim.prim_name.[0] <> '%') then raise(Error(valdecl.pval_type.ptyp_loc, Null_arity_external)); if !Clflags.native_code && prim.prim_arity > 5 @@ -1440,7 +1453,7 @@ let transl_with_constraint env id row_path orig_decl sdecl = let decl = name_recursion sdecl id decl in let decl = {decl with type_variance = - compute_variance_decl env false decl + compute_variance_decl env true decl (add_injectivity (List.map snd sdecl.ptype_params), sdecl.ptype_loc)} in Ctype.end_def(); generalize_decl decl; @@ -1699,6 +1712,8 @@ let report_error ppf = function fprintf ppf "@[%s@ %s@ %s@]" "In this GADT definition," "the variance of some parameter" "cannot be checked" + | Val_in_structure -> + fprintf ppf "Value declarations are only allowed in signatures" let () = Location.register_error_of_exn diff --git a/typing/typedecl.mli b/typing/typedecl.mli index 452674958b..34cb00be7a 100644 --- a/typing/typedecl.mli +++ b/typing/typedecl.mli @@ -16,7 +16,7 @@ open Types open Format val transl_type_decl: - Env.t -> Parsetree.type_declaration list -> + Env.t -> Asttypes.rec_flag -> Parsetree.type_declaration list -> Typedtree.type_declaration list * Env.t val transl_exception: @@ -82,6 +82,7 @@ type error = | Bad_fixed_type of string | Unbound_type_var_ext of type_expr * extension_constructor | Varying_anonymous + | Val_in_structure exception Error of Location.t * error diff --git a/typing/typedtree.ml b/typing/typedtree.ml index 52067415cc..2de31ddc24 100644 --- a/typing/typedtree.ml +++ b/typing/typedtree.ml @@ -74,8 +74,8 @@ and expression_desc = Texp_ident of Path.t * Longident.t loc * Types.value_description | Texp_constant of constant | 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_function of arg_label * case list * partial + | Texp_apply of expression * (arg_label * expression option * optional) list | Texp_match of expression * case list * case list * partial | Texp_try of expression * case list | Texp_tuple of expression list @@ -132,9 +132,9 @@ and class_expr_desc = Tcl_ident of Path.t * Longident.t loc * core_type list | Tcl_structure of class_structure | Tcl_fun of - label * pattern * (Ident.t * string loc * expression) list * class_expr * + arg_label * pattern * (Ident.t * string loc * expression) list * class_expr * partial - | Tcl_apply of class_expr * (label * expression option * optional) list + | Tcl_apply of class_expr * (arg_label * expression option * optional) list | Tcl_let of rec_flag * value_binding list * (Ident.t * string loc * expression) list * class_expr | Tcl_constraint of @@ -210,14 +210,14 @@ and structure_item_desc = Tstr_eval of expression * attributes | Tstr_value of rec_flag * value_binding list | Tstr_primitive of value_description - | Tstr_type of type_declaration list + | Tstr_type of rec_flag * type_declaration 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 open_description - | Tstr_class of (class_declaration * string list * virtual_flag) list + | Tstr_class of (class_declaration * string list) list | Tstr_class_type of (Ident.t * string loc * class_type_declaration) list | Tstr_include of include_declaration | Tstr_attribute of attribute @@ -244,7 +244,7 @@ and module_coercion = | Tcoerce_structure of (int * module_coercion) list * (Ident.t * int * module_coercion) list | Tcoerce_functor of module_coercion * module_coercion - | Tcoerce_primitive of Primitive.description + | Tcoerce_primitive of primitive_coercion | Tcoerce_alias of Path.t * module_coercion and module_type = @@ -263,6 +263,15 @@ and module_type_desc = | Tmty_typeof of module_expr | Tmty_alias of Path.t * Longident.t loc +(* Keep primitive type information for type-based lambda-code specialization *) +and primitive_coercion = + { + pc_desc: Primitive.description; + pc_type: type_expr; + pc_env: Env.t; + pc_loc : Location.t; + } + and signature = { sig_items : signature_item list; sig_type : Types.signature; @@ -276,7 +285,7 @@ and signature_item = and signature_item_desc = Tsig_value of value_description - | Tsig_type of type_declaration list + | Tsig_type of rec_flag * type_declaration list | Tsig_typext of type_extension | Tsig_exception of extension_constructor | Tsig_module of module_declaration @@ -345,7 +354,7 @@ and core_type = and core_type_desc = Ttyp_any | Ttyp_var of string - | Ttyp_arrow of label * core_type * core_type + | Ttyp_arrow of arg_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 * attributes * core_type) list * closed_flag @@ -433,9 +442,9 @@ 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_type: Types.extension_constructor; + ext_kind: extension_constructor_kind; + ext_loc: Location.t; ext_attributes: attribute list; } @@ -455,12 +464,12 @@ and class_type = and class_type_desc = Tcty_constr of Path.t * Longident.t loc * core_type list | Tcty_signature of class_signature - | Tcty_arrow of label * core_type * class_type + | Tcty_arrow of arg_label * core_type * class_type and class_signature = { - csig_self : core_type; - csig_fields : class_type_field list; - csig_type : Types.class_signature; + csig_self: core_type; + csig_fields: class_type_field list; + csig_type: Types.class_signature; } and class_type_field = { @@ -488,14 +497,14 @@ and class_type_declaration = and 'a class_infos = { ci_virt: virtual_flag; ci_params: (core_type * variance) list; - ci_id_name : string loc; + ci_id_name: string loc; ci_id_class: Ident.t; - ci_id_class_type : Ident.t; - ci_id_object : Ident.t; - ci_id_typesharp : Ident.t; + ci_id_class_type: Ident.t; + ci_id_object: Ident.t; + ci_id_typesharp: Ident.t; ci_expr: 'a; ci_decl: Types.class_declaration; - ci_type_decl : Types.class_type_declaration; + ci_type_decl: Types.class_type_declaration; ci_loc: Location.t; ci_attributes: attribute list; } diff --git a/typing/typedtree.mli b/typing/typedtree.mli index fa36dac8c4..736d9295c1 100644 --- a/typing/typedtree.mli +++ b/typing/typedtree.mli @@ -73,8 +73,8 @@ and expression_desc = Texp_ident of Path.t * Longident.t loc * Types.value_description | Texp_constant of constant | 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_function of arg_label * case list * partial + | Texp_apply of expression * (arg_label * expression option * optional) list | Texp_match of expression * case list * case list * partial | Texp_try of expression * case list | Texp_tuple of expression list @@ -131,9 +131,9 @@ and class_expr_desc = Tcl_ident of Path.t * Longident.t loc * core_type list | Tcl_structure of class_structure | Tcl_fun of - label * pattern * (Ident.t * string loc * expression) list * class_expr * + arg_label * pattern * (Ident.t * string loc * expression) list * class_expr * partial - | Tcl_apply of class_expr * (label * expression option * optional) list + | Tcl_apply of class_expr * (arg_label * expression option * optional) list | Tcl_let of rec_flag * value_binding list * (Ident.t * string loc * expression) list * class_expr | Tcl_constraint of @@ -209,14 +209,14 @@ and structure_item_desc = Tstr_eval of expression * attributes | Tstr_value of rec_flag * value_binding list | Tstr_primitive of value_description - | Tstr_type of type_declaration list + | Tstr_type of rec_flag * type_declaration 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 open_description - | Tstr_class of (class_declaration * string list * virtual_flag) list + | Tstr_class of (class_declaration * string list) list | Tstr_class_type of (Ident.t * string loc * class_type_declaration) list | Tstr_include of include_declaration | Tstr_attribute of attribute @@ -243,7 +243,7 @@ and module_coercion = | Tcoerce_structure of (int * module_coercion) list * (Ident.t * int * module_coercion) list | Tcoerce_functor of module_coercion * module_coercion - | Tcoerce_primitive of Primitive.description + | Tcoerce_primitive of primitive_coercion | Tcoerce_alias of Path.t * module_coercion and module_type = @@ -262,6 +262,14 @@ and module_type_desc = | Tmty_typeof of module_expr | Tmty_alias of Path.t * Longident.t loc +and primitive_coercion = + { + pc_desc: Primitive.description; + pc_type: type_expr; + pc_env: Env.t; + pc_loc : Location.t; + } + and signature = { sig_items : signature_item list; sig_type : Types.signature; @@ -275,7 +283,7 @@ and signature_item = and signature_item_desc = Tsig_value of value_description - | Tsig_type of type_declaration list + | Tsig_type of rec_flag * type_declaration list | Tsig_typext of type_extension | Tsig_exception of extension_constructor | Tsig_module of module_declaration @@ -344,7 +352,7 @@ and core_type = and core_type_desc = Ttyp_any | Ttyp_var of string - | Ttyp_arrow of label * core_type * core_type + | Ttyp_arrow of arg_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 * attributes * core_type) list * closed_flag @@ -455,7 +463,7 @@ and class_type = and class_type_desc = Tcty_constr of Path.t * Longident.t loc * core_type list | Tcty_signature of class_signature - | Tcty_arrow of label * core_type * class_type + | Tcty_arrow of arg_label * core_type * class_type and class_signature = { csig_self : core_type; diff --git a/typing/typedtreeIter.ml b/typing/typedtreeIter.ml index 28026b5987..8de50d711b 100644 --- a/typing/typedtreeIter.ml +++ b/typing/typedtreeIter.ml @@ -23,7 +23,6 @@ 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 @@ -50,7 +49,6 @@ 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 @@ -79,6 +77,11 @@ module type IteratorArgument = sig val leave_binding : value_binding -> unit val leave_bindings : rec_flag -> unit + val enter_type_declarations : rec_flag -> unit + val enter_type_declaration : type_declaration -> unit + val leave_type_declaration : type_declaration -> unit + val leave_type_declarations : rec_flag -> unit + end module MakeIterator(Iter : IteratorArgument) : sig @@ -133,7 +136,7 @@ module MakeIterator(Iter : IteratorArgument) : sig | Tstr_value (rec_flag, list) -> iter_bindings rec_flag list | Tstr_primitive vd -> iter_value_description vd - | Tstr_type list -> List.iter iter_type_declaration list + | Tstr_type (rf, list) -> iter_type_declarations rf list | Tstr_typext tyext -> iter_type_extension tyext | Tstr_exception ext -> iter_extension_constructor ext | Tstr_module x -> iter_module_binding x @@ -141,7 +144,7 @@ module MakeIterator(Iter : IteratorArgument) : sig | Tstr_modtype mtd -> iter_module_type_declaration mtd | Tstr_open _ -> () | Tstr_class list -> - List.iter (fun (ci, _, _) -> iter_class_declaration ci) list + List.iter (fun (ci, _) -> iter_class_declaration ci) list | Tstr_class_type list -> List.iter (fun (id, _, ct) -> iter_class_type_declaration ct) @@ -192,6 +195,11 @@ module MakeIterator(Iter : IteratorArgument) : sig option iter_core_type decl.typ_manifest; Iter.leave_type_declaration decl + and iter_type_declarations rec_flag decls = + Iter.enter_type_declarations rec_flag; + List.iter iter_type_declaration decls; + Iter.leave_type_declarations rec_flag + and iter_extension_constructor ext = Iter.enter_extension_constructor ext; begin match ext.ext_kind with @@ -356,8 +364,8 @@ module MakeIterator(Iter : IteratorArgument) : sig match item.sig_desc with Tsig_value vd -> iter_value_description vd - | Tsig_type list -> - List.iter iter_type_declaration list + | Tsig_type (rf, list) -> + iter_type_declarations rf list | Tsig_exception ext -> iter_extension_constructor ext | Tsig_typext tyext -> @@ -594,7 +602,6 @@ module DefaultIteratorArgument = struct let enter_structure _ = () let enter_value_description _ = () - let enter_type_declaration _ = () let enter_type_extension _ = () let enter_extension_constructor _ = () let enter_pattern _ = () @@ -622,7 +629,6 @@ module DefaultIteratorArgument = struct let leave_structure _ = () let leave_value_description _ = () - let leave_type_declaration _ = () let leave_type_extension _ = () let leave_extension_constructor _ = () let leave_pattern _ = () @@ -653,4 +659,9 @@ module DefaultIteratorArgument = struct let enter_bindings _ = () let leave_bindings _ = () - end + let enter_type_declaration _ = () + let leave_type_declaration _ = () + + let enter_type_declarations _ = () + let leave_type_declarations _ = () +end diff --git a/typing/typedtreeIter.mli b/typing/typedtreeIter.mli index 547fc5c34b..921afb7dbf 100644 --- a/typing/typedtreeIter.mli +++ b/typing/typedtreeIter.mli @@ -17,7 +17,6 @@ open Typedtree 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 @@ -44,7 +43,6 @@ 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 @@ -73,6 +71,11 @@ module type IteratorArgument = sig val leave_binding : value_binding -> unit val leave_bindings : rec_flag -> unit + val enter_type_declarations : rec_flag -> unit + val enter_type_declaration : type_declaration -> unit + val leave_type_declaration : type_declaration -> unit + val leave_type_declarations : rec_flag -> unit + end module MakeIterator : diff --git a/typing/typedtreeMap.ml b/typing/typedtreeMap.ml index 6b28cc8503..e6c05de591 100644 --- a/typing/typedtreeMap.ml +++ b/typing/typedtreeMap.ml @@ -117,8 +117,8 @@ module MakeMap(Map : MapArgument) = struct Tstr_value (rec_flag, map_bindings rec_flag list) | Tstr_primitive vd -> Tstr_primitive (map_value_description vd) - | Tstr_type list -> - Tstr_type (List.map map_type_declaration list) + | Tstr_type (rf, list) -> + Tstr_type (rf, List.map map_type_declaration list) | Tstr_typext tyext -> Tstr_typext (map_type_extension tyext) | Tstr_exception ext -> @@ -134,8 +134,8 @@ module MakeMap(Map : MapArgument) = struct | Tstr_class list -> let list = List.map - (fun (ci, string_list, virtual_flag) -> - map_class_declaration ci, string_list, virtual_flag) + (fun (ci, string_list) -> + map_class_declaration ci, string_list) list in Tstr_class list @@ -417,7 +417,7 @@ module MakeMap(Map : MapArgument) = struct match item.sig_desc with Tsig_value vd -> Tsig_value (map_value_description vd) - | Tsig_type list -> Tsig_type (List.map map_type_declaration list) + | Tsig_type (rf, list) -> Tsig_type (rf, List.map map_type_declaration list) | Tsig_typext tyext -> Tsig_typext (map_type_extension tyext) | Tsig_exception ext -> diff --git a/typing/typemod.ml b/typing/typemod.ml index bf3e1bfafc..b73bf0616e 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -120,15 +120,16 @@ let rec make_params n = function [] -> [] | _ :: l -> ("a" ^ string_of_int n) :: make_params (n+1) l -let make_next_first rs rem = - if rs = Trec_first then - match rem with - Sig_type (id, decl, Trec_next) :: rem -> - Sig_type (id, decl, Trec_first) :: rem - | Sig_module (id, mty, Trec_next) :: rem -> - Sig_module (id, mty, Trec_first) :: rem - | _ -> rem - else rem +let update_rec_next rs rem = + match rs with + Trec_next -> rem + | Trec_first | Trec_not -> + match rem with + Sig_type (id, decl, Trec_next) :: rem -> + Sig_type (id, decl, rs) :: rem + | Sig_module (id, mty, Trec_next) :: rem -> + Sig_module (id, mty, rs) :: rem + | _ -> rem let sig_item desc typ env loc = { Typedtree.sig_desc = desc; sig_loc = loc; sig_env = env @@ -211,7 +212,7 @@ let merge_constraint initial_env loc sg constr = check_type_decl env sdecl.ptype_loc id row_id newdecl decl rs rem; real_id := Some id; (Pident id, lid, Twith_typesubst tdecl), - make_next_first rs rem + update_rec_next rs rem | (Sig_module(id, md, rs) :: rem, [s], Pwith_module (_, lid')) when Ident.name id = s -> let path, md' = Typetexp.find_module initial_env loc lid'.txt in @@ -229,7 +230,7 @@ let merge_constraint initial_env loc sg constr = ignore(Includemod.modtypes env newmd.md_type md.md_type); real_id := Some id; (Pident id, lid, Twith_modsubst (path, lid')), - make_next_first rs rem + update_rec_next rs rem | (Sig_module(id, md, rs) :: rem, s :: namelist, _) when Ident.name id = s -> let ((path, path_loc, tcstr), newsg) = @@ -290,20 +291,25 @@ let map_rec fn decls rem = | [] -> rem | d1 :: dl -> fn Trec_first d1 :: map_end (fn Trec_next) dl rem -let map_rec' = map_rec -(* -let rec map_rec' fn decls rem = +let map_rec_type ~rec_flag fn decls rem = match decls with - | (id,_ as d1) :: dl when Btype.is_row_name (Ident.name id) -> - fn Trec_not d1 :: map_rec' fn dl rem - | _ -> map_rec fn decls rem -*) + | [] -> rem + | d1 :: dl -> + let first = + match rec_flag with + | Recursive -> Trec_first + | Nonrecursive -> Trec_not + in + fn first d1 :: map_end (fn Trec_next) dl rem -let rec map_rec'' fn decls rem = +let rec map_rec_type_with_row_types ~rec_flag fn decls rem = match decls with - | d1 :: dl when Btype.is_row_name (Ident.name d1.typ_id) -> - fn Trec_not d1 :: map_rec'' fn dl rem - | _ -> map_rec fn decls rem + | [] -> rem + | d1 :: dl -> + if Btype.is_row_name (Ident.name d1.typ_id) then + fn Trec_not d1 :: map_rec_type_with_row_types ~rec_flag fn dl rem + else + map_rec_type ~rec_flag fn decls rem (* Add type extension flags to extension contructors *) let map_ext fn exts rem = @@ -353,15 +359,15 @@ and approx_sig env ssg = [] -> [] | item :: srem -> match item.psig_desc with - | Psig_type sdecls -> + | Psig_type (rec_flag, sdecls) -> let decls = Typedecl.approx_type_decl env sdecls in let rem = approx_sig env srem in - map_rec' (fun rs (id, info) -> Sig_type(id, info, rs)) decls rem + map_rec_type ~rec_flag + (fun rs (id, info) -> Sig_type(id, info, rs)) decls rem | Psig_module pmd -> + let id = Ident.create pmd.pmd_name.txt in let md = approx_module_declaration env pmd in - let (id, newenv) = - Env.enter_module_declaration pmd.pmd_name.txt md env - in + let newenv = Env.enter_module_declaration id md env in Sig_module(id, md, Trec_not) :: approx_sig newenv srem | Psig_recmodule sdecls -> let decls = @@ -555,6 +561,7 @@ let rec transl_modtype env smty = (Mtype.freshen (Mty_signature final_sg)) env loc smty.pmty_attributes | Pmty_typeof smod -> + let env = Env.in_signature false env in let tmty, mty = !type_module_type_of_fwd env smod in mkmty (Tmty_typeof tmty) mty env loc smty.pmty_attributes | Pmty_extension ext -> @@ -571,20 +578,22 @@ and transl_signature env sg = match item.psig_desc with | Psig_value sdesc -> let (tdesc, newenv) = - Typedecl.transl_value_decl env item.psig_loc sdesc in + Typetexp.with_warning_attribute sdesc.pval_attributes (fun () -> + 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, Sig_value(tdesc.val_id, tdesc.val_val) :: rem, final_env - | Psig_type sdecls -> + | Psig_type (rec_flag, sdecls) -> List.iter (fun decl -> check_name check_type names decl.ptype_name) sdecls; - let (decls, newenv) = Typedecl.transl_type_decl env sdecls in + let (decls, newenv) = Typedecl.transl_type_decl env rec_flag sdecls in let (trem, rem, final_env) = transl_sig newenv srem in - mksig (Tsig_type decls) env loc :: trem, - map_rec'' (fun rs td -> - Sig_type(td.typ_id, td.typ_type, rs)) decls rem, + mksig (Tsig_type (rec_flag, decls)) env loc :: trem, + map_rec_type_with_row_types ~rec_flag + (fun rs td -> Sig_type(td.typ_id, td.typ_type, rs)) decls rem, final_env | Psig_typext styext -> List.iter @@ -608,15 +617,18 @@ and transl_signature env sg = final_env | Psig_module pmd -> check_name check_module names pmd.pmd_name; - let tmty = transl_modtype env pmd.pmd_type in + let id = Ident.create pmd.pmd_name.txt in + let tmty = + Typetexp.with_warning_attribute pmd.pmd_attributes (fun () -> + transl_modtype env pmd.pmd_type) + in let md = { md_type=tmty.mty_type; md_attributes=pmd.pmd_attributes; md_loc=pmd.pmd_loc; } in - let (id, newenv) = - Env.enter_module_declaration pmd.pmd_name.txt md env in + let newenv = Env.enter_module_declaration id md env in let (trem, rem, final_env) = transl_sig newenv srem in mksig (Tsig_module {md_id=id; md_name=pmd.pmd_name; md_type=tmty; md_loc=pmd.pmd_loc; @@ -642,7 +654,8 @@ and transl_signature env sg = final_env | Psig_modtype pmtd -> let newenv, mtd, sg = - transl_modtype_decl names env item.psig_loc pmtd + Typetexp.with_warning_attribute pmtd.pmtd_attributes (fun () -> + 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, @@ -655,7 +668,10 @@ and transl_signature env sg = rem, final_env | Psig_include sincl -> let smty = sincl.pincl_mod in - let tmty = transl_modtype env smty in + let tmty = + Typetexp.with_warning_attribute sincl.pincl_attributes (fun () -> + 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 @@ -668,7 +684,7 @@ and transl_signature env sg = incl_loc = sincl.pincl_loc; } in - let (trem, rem, final_env) = transl_sig newenv srem in + let (trem, rem, final_env) = transl_sig newenv srem in mksig (Tsig_include incl) env loc :: trem, sg @ rem, final_env @@ -721,7 +737,7 @@ and transl_signature env sg = 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 (trem, rem, final_env) = transl_sig (Env.in_signature true 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 (); @@ -764,7 +780,11 @@ and transl_recmodule_modtypes loc env sdecls = let transition env_c curr = List.map2 (fun pmd (id, id_loc, mty) -> - (id, id_loc, transl_modtype env_c pmd.pmd_type)) + let tmty = + Typetexp.with_warning_attribute pmd.pmd_attributes (fun () -> + transl_modtype env_c pmd.pmd_type) + in + (id, id_loc, tmty)) sdecls curr in let ids = List.map (fun x -> Ident.create x.pmd_name.txt) sdecls in let approx_env = @@ -823,34 +843,38 @@ let rec path_of_module mexp = path_of_module mexp | _ -> raise Not_a_path +let path_of_module mexp = + try Some (path_of_module mexp) with Not_a_path -> None + (* Check that all core type schemes in a structure are closed *) -let rec closed_modtype = function +let rec closed_modtype env = function Mty_ident p -> true | Mty_alias p -> true - | Mty_signature sg -> List.for_all closed_signature_item sg - | Mty_functor(id, param, body) -> closed_modtype body - -and closed_signature_item = function - Sig_value(id, desc) -> Ctype.closed_schema desc.val_type - | Sig_module(id, md, _) -> closed_modtype md.md_type + | Mty_signature sg -> + let env = Env.add_signature sg env in + List.for_all (closed_signature_item env) sg + | Mty_functor(id, param, body) -> + let env = Env.add_module ~arg:true id (Btype.default_mty param) env in + closed_modtype env body + +and closed_signature_item env = function + Sig_value(id, desc) -> Ctype.closed_schema env desc.val_type + | Sig_module(id, md, _) -> closed_modtype env md.md_type | _ -> true -let check_nongen_scheme env str = - match str.str_desc with - Tstr_value(rec_flag, pat_exp_list) -> - List.iter - (fun {vb_expr=exp} -> - if not (Ctype.closed_schema exp.exp_type) then - raise(Error(exp.exp_loc, env, Non_generalizable exp.exp_type))) - pat_exp_list - | Tstr_module {mb_expr=md;_} -> - if not (closed_modtype md.mod_type) then - raise(Error(md.mod_loc, env, Non_generalizable_module md.mod_type)) +let check_nongen_scheme env sig_item = + match sig_item with + Sig_value(_id, vd) -> + if not (Ctype.closed_schema env vd.val_type) then + raise (Error (vd.val_loc, env, Non_generalizable vd.val_type)) + | Sig_module (_id, md, _) -> + if not (closed_modtype env md.md_type) then + raise(Error(md.md_loc, env, Non_generalizable_module md.md_type)) | _ -> () -let check_nongen_schemes env str = - List.iter (check_nongen_scheme env) str +let check_nongen_schemes env sg = + List.iter (check_nongen_scheme env) sg (* Helpers for typing recursive modules *) @@ -1089,7 +1113,7 @@ let rec type_module ?(alias=false) sttn funct_body anchor env smod = mod_loc = smod.pmod_loc } | Pmod_apply(sfunct, sarg) -> let arg = type_module true funct_body None env sarg in - let path = try Some (path_of_module arg) with Not_a_path -> None in + let path = path_of_module arg in let funct = type_module (sttn && path <> None) funct_body None env sfunct in begin match Env.scrape_alias env funct.mod_type with @@ -1179,7 +1203,10 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = let type_str_item env srem {pstr_loc = loc; pstr_desc = desc} = match desc with | Pstr_eval (sexpr, attrs) -> - let expr = Typecore.type_expression env sexpr in + let expr = + Typetexp.with_warning_attribute attrs (fun () -> + Typecore.type_expression env sexpr) + in Tstr_eval (expr, attrs), [], env | Pstr_value(rec_flag, sdefs) -> let scope = @@ -1206,13 +1233,14 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = | Pstr_primitive sdesc -> let (desc, newenv) = Typedecl.transl_value_decl env loc sdesc in Tstr_primitive desc, [Sig_value(desc.val_id, desc.val_val)], newenv - | Pstr_type sdecls -> + | Pstr_type (rec_flag, sdecls) -> List.iter (fun decl -> check_name check_type names decl.ptype_name) sdecls; - let (decls, newenv) = Typedecl.transl_type_decl env sdecls in - Tstr_type decls, - map_rec'' (fun rs info -> Sig_type(info.typ_id, info.typ_type, rs)) + let (decls, newenv) = Typedecl.transl_type_decl env rec_flag sdecls in + Tstr_type (rec_flag, decls), + map_rec_type_with_row_types ~rec_flag + (fun rs info -> Sig_type(info.typ_id, info.typ_type, rs)) decls [], enrich_type_decls anchor decls env newenv | Pstr_typext styext -> @@ -1237,16 +1265,19 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = pmb_loc; } -> check_name check_module names name; + let id = Ident.create name.txt in (* create early for PR#6752 *) let modl = - type_module ~alias:true true funct_body - (anchor_submodule name.txt anchor) env smodl in + Typetexp.with_warning_attribute attrs (fun () -> + type_module ~alias:true true funct_body + (anchor_submodule name.txt anchor) env smodl) + in let md = { md_type = enrich_module_type anchor name.txt modl.mod_type env; md_attributes = attrs; md_loc = pmb_loc; } in - let (id, newenv) = Env.enter_module_declaration name.txt md env in + let newenv = Env.enter_module_declaration id md env in Tstr_module {mb_id=id; mb_name=name; mb_expr=modl; mb_attributes=attrs; mb_loc=pmb_loc; }, @@ -1285,8 +1316,9 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = List.map2 (fun {md_id=id; md_type=mty} (name, _, smodl, attrs, loc) -> let modl = - type_module true funct_body (anchor_recmodule id anchor) newenv - smodl in + Typetexp.with_warning_attribute attrs (fun () -> + type_module true funct_body (anchor_recmodule id anchor) newenv smodl) + in let mty' = enrich_module_type anchor (Ident.name id) modl.mod_type newenv in @@ -1320,7 +1352,8 @@ 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 names env loc pmtd + Typetexp.with_warning_attribute pmtd.pmtd_attributes (fun () -> + transl_modtype_decl names env loc pmtd) in Tstr_modtype mtd, [sg], newenv | Pstr_open sod -> @@ -1332,10 +1365,7 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = cl; let (classes, new_env) = Typeclass.class_declarations env cl in Tstr_class - (List.map (fun (i, _, d, _,_,_,_,_,_, s, m, c) -> - let vf = if d.cty_new = None then Virtual else Concrete in - (* (i, s, m, c, vf) *) (c, m, vf)) - classes), + (List.map (fun (_,_,_,_,_,_,_,_,_,_, m, c) -> (c, m)) classes), (* TODO: check with Jacques why this is here Tstr_class_type (List.map (fun (_,_, i, d, _,_,_,_,_,_,c) -> (i, c)) classes) :: @@ -1376,7 +1406,10 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = new_env | Pstr_include sincl -> let smodl = sincl.pincl_mod in - let modl = type_module true funct_body None env smodl in + let modl = + Typetexp.with_warning_attribute sincl.pincl_attributes (fun () -> + 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 @@ -1460,7 +1493,7 @@ let type_module_type_of env smod = (* PR#6307: expand aliases at root and submodules *) let mty = Mtype.remove_aliases env mty in (* PR#5036: must not contain non-generalized type variables *) - if not (closed_modtype mty) then + if not (closed_modtype env mty) then raise(Error(smod.pmod_loc, env, Non_generalizable_module mty)); tmty, mty @@ -1561,7 +1594,7 @@ let type_implementation sourcefile outputprefix modulename initial_env ast = (Cmt_format.Implementation str) (Some sourcefile) initial_env None; (str, coercion) end else begin - check_nongen_schemes finalenv str.str_items; + check_nongen_schemes finalenv sg; normalize_signature finalenv simple_sg; let coercion = Includemod.compunit initial_env sourcefile sg @@ -1622,7 +1655,7 @@ let package_units initial_env objfiles cmifile modulename = List.map (fun f -> let pref = chop_extensions f in - let modname = String.capitalize(Filename.basename pref) in + let modname = String.capitalize_ascii(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_safe_string sg) diff --git a/typing/typemod.mli b/typing/typemod.mli index 8895017885..25c1110006 100644 --- a/typing/typemod.mli +++ b/typing/typemod.mli @@ -31,13 +31,17 @@ val type_interface: val transl_signature: Env.t -> Parsetree.signature -> Typedtree.signature val check_nongen_schemes: - Env.t -> Typedtree.structure_item list -> unit + Env.t -> Types.signature -> unit val type_open_: ?toplevel:bool -> Asttypes.override_flag -> Env.t -> Location.t -> Longident.t Asttypes.loc -> Path.t * Env.t - +val modtype_of_package: + Env.t -> Location.t -> + Path.t -> Longident.t list -> type_expr list -> module_type val simplify_signature: signature -> signature +val path_of_module : Typedtree.module_expr -> Path.t option + val save_signature: string -> Typedtree.signature -> string -> string -> Env.t -> Types.signature_item list -> unit diff --git a/typing/types.ml b/typing/types.ml index 1aff7356fa..7f13df9183 100644 --- a/typing/types.ml +++ b/typing/types.ml @@ -23,7 +23,7 @@ type type_expr = and type_desc = Tvar of string option - | Tarrow of label * type_expr * type_expr * commutable + | Tarrow of arg_label * type_expr * type_expr * commutable | Ttuple of type_expr list | Tconstr of Path.t * type_expr list * abbrev_memo ref | Tobject of type_expr * (Path.t * type_expr list) option ref @@ -202,7 +202,7 @@ module Concr = Set.Make(OrderedString) type class_type = Cty_constr of Path.t * type_expr list * class_type | Cty_signature of class_signature - | Cty_arrow of label * type_expr * class_type + | Cty_arrow of arg_label * type_expr * class_type and class_signature = { csig_self: type_expr; @@ -264,9 +264,9 @@ and modtype_declaration = } and rec_status = - Trec_not (* not recursive *) + Trec_not (* first in a nonrecursive group *) | Trec_first (* first in a recursive group *) - | Trec_next (* not first in a recursive group *) + | Trec_next (* not first in a recursive/nonrecursive group *) and ext_status = Text_first (* first constructor of an extension *) diff --git a/typing/types.mli b/typing/types.mli index 0438f897b7..e0c1076d7a 100644 --- a/typing/types.mli +++ b/typing/types.mli @@ -23,7 +23,7 @@ type type_expr = and type_desc = Tvar of string option - | Tarrow of label * type_expr * type_expr * commutable + | Tarrow of arg_label * type_expr * type_expr * commutable | Ttuple of type_expr list | Tconstr of Path.t * type_expr list * abbrev_memo ref | Tobject of type_expr * (Path.t * type_expr list) option ref @@ -192,7 +192,7 @@ module Concr : Set.S with type elt = string type class_type = Cty_constr of Path.t * type_expr list * class_type | Cty_signature of class_signature - | Cty_arrow of label * type_expr * class_type + | Cty_arrow of arg_label * type_expr * class_type and class_signature = { csig_self: type_expr; @@ -254,9 +254,9 @@ and modtype_declaration = } and rec_status = - Trec_not (* not recursive *) + Trec_not (* first in a nonrecursive group *) | Trec_first (* first in a recursive group *) - | Trec_next (* not first in a recursive group *) + | Trec_next (* not first in a recursive/nonrecursive group *) and ext_status = Text_first (* first constructor in an extension *) diff --git a/typing/typetexp.ml b/typing/typetexp.ml index 523d435bca..0756f8dfe9 100644 --- a/typing/typetexp.ml +++ b/typing/typetexp.ml @@ -169,6 +169,17 @@ let warning_attribute attrs = ) attrs +let with_warning_attribute attrs f = + try + warning_enter_scope (); + warning_attribute attrs; + let ret = f () in + warning_leave_scope (); + ret + with exn -> + warning_leave_scope (); + raise exn + type variable_context = int * (string, type_expr) Tbl.t (* Local definitions *) @@ -240,6 +251,7 @@ let find_class env loc lid = r let find_value env loc lid = + Env.check_value_name (Longident.last lid) loc; let (path, decl) as r = find_component Env.lookup_value (fun lid -> Unbound_value lid) env loc lid in @@ -421,7 +433,12 @@ let rec transl_type env policy styp = | Ptyp_arrow(l, st1, st2) -> let cty1 = transl_type env policy st1 in let cty2 = transl_type env policy st2 in - let ty = newty (Tarrow(l, cty1.ctyp_type, cty2.ctyp_type, Cok)) in + let ty1 = cty1.ctyp_type in + let ty1 = + if Btype.is_optional l + then newty (Tconstr(Predef.path_option,[ty1], ref Mnil)) + else ty1 in + let ty = newty (Tarrow(l, ty1, cty2.ctyp_type, Cok)) in ctyp (Ttyp_arrow (l, cty1, cty2)) ty | Ptyp_tuple stl -> if List.length stl < 2 then @@ -859,60 +876,37 @@ open Format open Printtyp let spellcheck ppf fold env lid = - let cutoff = - match String.length (Longident.last lid) with - | 1 | 2 -> 0 - | 3 | 4 -> 1 - | 5 | 6 -> 2 - | _ -> 3 - in - let compare target head acc = - let (best_choice, best_dist) = acc in - match Misc.edit_distance target head cutoff with - | None -> (best_choice, best_dist) - | Some dist -> - let choice = - if dist < best_dist then [head] - else if dist = best_dist then head :: best_choice - else best_choice in - (choice, min dist best_dist) - in - let init = ([], max_int) in - let handle (choice, _dist) = - match List.rev choice with - | [] -> () - | last :: rev_rest -> - fprintf ppf "@\nHint: Did you mean %s%s%s?" - (String.concat ", " (List.rev rev_rest)) - (if rev_rest = [] then "" else " or ") - last - in - (* flush now to get the error report early, in the (unheard of) case - where the linear search would take a bit of time; in the worst - case, the user has seen the error, she can interrupt the process - before the spell-checking terminates. *) - fprintf ppf "@?"; + let choices ~path name = + let env = fold (fun x xs -> x::xs) path env [] in + Misc.spellcheck env name in match lid with | Longident.Lapply _ -> () | Longident.Lident s -> - handle (fold (compare s) None env init) + Misc.did_you_mean ppf (fun () -> choices ~path:None s) | Longident.Ldot (r, s) -> - handle (fold (compare s) (Some r) env init) - -let spellcheck_simple ppf fold extr = - spellcheck ppf (fun f -> fold (fun decl x -> f (extr decl) x)) + Misc.did_you_mean ppf (fun () -> choices ~path:(Some r) s) -let spellcheck ppf fold = - spellcheck ppf (fun f -> fold (fun s _ _ x -> f s x)) +let fold_descr fold get_name f = fold (fun descr acc -> f (get_name descr) acc) +let fold_simple fold4 f = fold4 (fun name _path _descr acc -> f name acc) -type cd = string list * int +let fold_values = fold_simple Env.fold_values +let fold_types = fold_simple Env.fold_types +let fold_modules = fold_simple Env.fold_modules +let fold_constructors = fold_descr Env.fold_constructors (fun d -> d.cstr_name) +let fold_labels = fold_descr Env.fold_labels (fun d -> d.lbl_name) +let fold_classs = fold_simple Env.fold_classs +let fold_modtypes = fold_simple Env.fold_modtypes +let fold_cltypes = fold_simple Env.fold_cltypes let report_error env ppf = function | Unbound_type_variable name -> + (* we don't use "spellcheck" here: the function that raises this + error seems not to be called anywhere, so it's unclear how it + should be handled *) fprintf ppf "Unbound type parameter %s@." name | Unbound_type_constructor lid -> fprintf ppf "Unbound type constructor %a" longident lid; - spellcheck ppf Env.fold_types env lid; + spellcheck ppf fold_types env lid; | Unbound_type_constructor_2 p -> fprintf ppf "The type constructor@ %a@ is not yet completely defined" path p @@ -977,26 +971,25 @@ let report_error env ppf = function s "Multiple occurences are not allowed." | Unbound_value lid -> fprintf ppf "Unbound value %a" longident lid; - spellcheck ppf Env.fold_values env lid; + spellcheck ppf fold_values env lid; | Unbound_module lid -> fprintf ppf "Unbound module %a" longident lid; - spellcheck ppf Env.fold_modules env lid; + spellcheck ppf fold_modules env lid; | Unbound_constructor lid -> fprintf ppf "Unbound constructor %a" longident lid; - spellcheck_simple ppf Env.fold_constructors (fun d -> d.cstr_name) - env lid; + spellcheck ppf fold_constructors 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; + spellcheck ppf fold_labels env lid; | Unbound_class lid -> fprintf ppf "Unbound class %a" longident lid; - spellcheck ppf Env.fold_classs env lid; + spellcheck ppf fold_classs env lid; | Unbound_modtype lid -> fprintf ppf "Unbound module type %a" longident lid; - spellcheck ppf Env.fold_modtypes env lid; + spellcheck ppf fold_modtypes env lid; | Unbound_cltype lid -> fprintf ppf "Unbound class type %a" longident lid; - spellcheck ppf Env.fold_cltypes env lid; + spellcheck ppf fold_cltypes env lid; | Ill_typed_functor_application lid -> fprintf ppf "Ill-typed functor application %a" longident lid | Illegal_reference_to_recursive_module -> diff --git a/typing/typetexp.mli b/typing/typetexp.mli index 7bff403f0f..b51d52f2f3 100644 --- a/typing/typetexp.mli +++ b/typing/typetexp.mli @@ -107,17 +107,12 @@ val find_class_type: val unbound_constructor_error: Env.t -> Longident.t Location.loc -> 'a val unbound_label_error: Env.t -> Longident.t Location.loc -> 'a -type cd -val spellcheck_simple: - Format.formatter -> - (('a -> cd -> cd) -> Longident.t option -> 'b -> cd -> cd) -> - ('a -> string) -> 'b -> Longident.t -> unit - val check_deprecated: Location.t -> Parsetree.attributes -> string -> unit val warning_enter_scope: unit -> unit val warning_leave_scope: unit -> unit val warning_attribute: Parsetree.attributes -> unit +val with_warning_attribute: Parsetree.attributes -> (unit -> 'a) -> 'a val error_of_extension: Parsetree.extension -> Location.error diff --git a/typing/untypeast.ml b/typing/untypeast.ml new file mode 100644 index 0000000000..4693ef157f --- /dev/null +++ b/typing/untypeast.ml @@ -0,0 +1,781 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Thomas Gazagnaire (OCamlPro), Fabrice Le Fessant (INRIA Saclay) *) +(* *) +(* Copyright 2007 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. *) +(* *) +(**************************************************************************) + +open Longident +open Asttypes +open Parsetree +open Ast_helper + +module T = Typedtree + +type mapper = { + attribute: mapper -> T.attribute -> attribute; + attributes: mapper -> T.attribute list -> attribute list; + case: mapper -> T.case -> case; + cases: mapper -> T.case list -> case list; + class_declaration: mapper -> T.class_declaration -> class_declaration; + class_description: mapper -> T.class_description -> class_description; + class_expr: mapper -> T.class_expr -> class_expr; + class_field: mapper -> T.class_field -> class_field; + class_signature: mapper -> T.class_signature -> class_signature; + class_structure: mapper -> T.class_structure -> class_structure; + class_type: mapper -> T.class_type -> class_type; + class_type_declaration: mapper -> T.class_type_declaration + -> class_type_declaration; + class_type_field: mapper -> T.class_type_field -> class_type_field; + constructor_declaration: mapper -> T.constructor_declaration + -> constructor_declaration; + expr: mapper -> T.expression -> expression; + extension_constructor: mapper -> T.extension_constructor + -> extension_constructor; + include_declaration: mapper -> T.include_declaration -> include_declaration; + include_description: mapper -> T.include_description -> include_description; + label_declaration: mapper -> T.label_declaration -> label_declaration; + location: mapper -> Location.t -> Location.t; + module_binding: mapper -> T.module_binding -> module_binding; + module_declaration: mapper -> T.module_declaration -> module_declaration; + module_expr: mapper -> T.module_expr -> module_expr; + module_type: mapper -> T.module_type -> module_type; + module_type_declaration: + mapper -> T.module_type_declaration -> module_type_declaration; + package_type: mapper -> T.package_type -> package_type; + open_description: mapper -> T.open_description -> open_description; + pat: mapper -> T.pattern -> pattern; + row_field: mapper -> T.row_field -> row_field; + signature: mapper -> T.signature -> signature; + signature_item: mapper -> T.signature_item -> signature_item; + structure: mapper -> T.structure -> structure; + structure_item: mapper -> T.structure_item -> structure_item; + typ: mapper -> T.core_type -> core_type; + type_declaration: mapper -> T.type_declaration -> type_declaration; + type_extension: mapper -> T.type_extension -> type_extension; + type_kind: mapper -> T.type_kind -> type_kind; + value_binding: mapper -> T.value_binding -> value_binding; + value_description: mapper -> T.value_description -> value_description; + with_constraint: + mapper -> (Path.t * Longident.t Location.loc * T.with_constraint) + -> with_constraint; +} + +open T + +(* +Some notes: + + * For Pexp_function, we cannot go back to the exact original version + when there is a default argument, because the default argument is + translated in the typer. The code, if printed, will not be parsable because + new generated identifiers are not correct. + + * For Pexp_apply, it is unclear whether arguments are reordered, especially + when there are optional arguments. + +*) + + +(** Utility functions. *) + +let string_is_prefix sub str = + let sublen = String.length sub in + String.length str >= sublen && String.sub str 0 sublen = sub + +let map_opt f = function None -> None | Some e -> Some (f e) + +let rec lident_of_path = function + | Path.Pident id -> Longident.Lident (Ident.name id) + | Path.Pdot (p, s, _) -> Longident.Ldot (lident_of_path p, s) + | Path.Papply (p1, p2) -> + Longident.Lapply (lident_of_path p1, lident_of_path p2) + +let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt} + +(** Try a name [$name$0], check if it's free, if not, increment and repeat. *) +let fresh_name s env = + let rec aux i = + let name = s ^ string_of_int i in + try + let _ = Env.lookup_value (Lident name) env in + name + with + | Not_found -> aux (i+1) + in + aux 0 + +(** Mapping functions. *) + +let attribute sub (s, p) = (map_loc sub s, p) +let attributes sub l = List.map (sub.attribute sub) l + +let structure sub str = + List.map (sub.structure_item sub) str.str_items + +let open_description sub od = + let loc = sub.location sub od.open_loc in + let attrs = sub.attributes sub od.open_attributes in + Opn.mk ~loc ~attrs + ~override:od.open_override + (map_loc sub od.open_txt) + +let structure_item sub item = + let loc = sub.location sub item.str_loc in + let desc = + match item.str_desc with + Tstr_eval (exp, attrs) -> Pstr_eval (sub.expr sub exp, attrs) + | Tstr_value (rec_flag, list) -> + Pstr_value (rec_flag, List.map (sub.value_binding sub) list) + | Tstr_primitive vd -> + Pstr_primitive (sub.value_description sub vd) + | Tstr_type (rec_flag, list) -> + Pstr_type (rec_flag, List.map (sub.type_declaration sub) list) + | Tstr_typext tyext -> + Pstr_typext (sub.type_extension sub tyext) + | Tstr_exception ext -> + Pstr_exception (sub.extension_constructor sub ext) + | Tstr_module mb -> + Pstr_module (sub.module_binding sub mb) + | Tstr_recmodule list -> + Pstr_recmodule (List.map (sub.module_binding sub) list) + | Tstr_modtype mtd -> + Pstr_modtype (sub.module_type_declaration sub mtd) + | Tstr_open od -> + Pstr_open (sub.open_description sub od) + | Tstr_class list -> + Pstr_class + (List.map + (fun (ci, _) -> sub.class_declaration sub ci) + list) + | Tstr_class_type list -> + Pstr_class_type + (List.map + (fun (_id, _name, ct) -> sub.class_type_declaration sub ct) + list) + | Tstr_include incl -> + Pstr_include (sub.include_declaration sub incl) + | Tstr_attribute x -> + Pstr_attribute x + in + Str.mk ~loc desc + +let value_description sub v = + let loc = sub.location sub v.val_loc in + let attrs = sub.attributes sub v.val_attributes in + Val.mk ~loc ~attrs + ~prim:v.val_prim + (map_loc sub v.val_name) + (sub.typ sub v.val_desc) + +let module_binding sub mb = + let loc = sub.location sub mb.mb_loc; in + let attrs = sub.attributes sub mb.mb_attributes in + Mb.mk ~loc ~attrs + (map_loc sub mb.mb_name) + (sub.module_expr sub mb.mb_expr) + +let type_parameter sub (ct, v) = (sub.typ sub ct, v) + +let type_declaration sub decl = + let loc = sub.location sub decl.typ_loc; in + let attrs = sub.attributes sub decl.typ_attributes in + Type.mk ~loc ~attrs + ~params:(List.map (type_parameter sub) decl.typ_params) + ~cstrs:( + List.map + (fun (ct1, ct2, loc) -> + (sub.typ sub ct1, sub.typ sub ct2, sub.location sub loc)) + decl.typ_cstrs) + ~kind:(sub.type_kind sub decl.typ_kind) + ~priv:decl.typ_private + ?manifest:(map_opt (sub.typ sub) decl.typ_manifest) + (map_loc sub decl.typ_name) + +let type_kind sub tk = match tk with + | Ttype_abstract -> Ptype_abstract + | Ttype_variant list -> + Ptype_variant (List.map (sub.constructor_declaration sub) list) + | Ttype_record list -> + Ptype_record (List.map (sub.label_declaration sub) list) + | Ttype_open -> Ptype_open + +let constructor_arguments sub = function + | Cstr_tuple l -> Pcstr_tuple (List.map (sub.typ sub) l) + | Cstr_record l -> Pcstr_record (List.map (sub.label_declaration sub) l) + +let constructor_declaration sub cd = + let loc = sub.location sub cd.cd_loc; in + let attrs = sub.attributes sub cd.cd_attributes in + Type.constructor ~loc ~attrs + ~args:(constructor_arguments sub cd.cd_args) + ?res:(map_opt (sub.typ sub) cd.cd_res) + (map_loc sub cd.cd_name) + +let label_declaration sub ld = + let loc = sub.location sub ld.ld_loc; in + let attrs = sub.attributes sub ld.ld_attributes in + Type.field ~loc ~attrs + ~mut:ld.ld_mutable + (map_loc sub ld.ld_name) + (sub.typ sub ld.ld_type) + +let type_extension sub tyext = + let attrs = sub.attributes sub tyext.tyext_attributes in + Te.mk ~attrs + ~params:(List.map (type_parameter sub) tyext.tyext_params) + ~priv:tyext.tyext_private + (map_loc sub tyext.tyext_txt) + (List.map (sub.extension_constructor sub) tyext.tyext_constructors) + +let extension_constructor sub ext = + let loc = sub.location sub ext.ext_loc; in + let attrs = sub.attributes sub ext.ext_attributes in + Te.constructor ~loc ~attrs + (map_loc sub ext.ext_name) + (match ext.ext_kind with + | Text_decl (args, ret) -> + Pext_decl (constructor_arguments sub args, + map_opt (sub.typ sub) ret) + | Text_rebind (_p, lid) -> Pext_rebind (map_loc sub lid) + ) + +let pattern sub pat = + let loc = sub.location sub pat.pat_loc; in + (* todo: fix attributes on extras *) + let attrs = sub.attributes sub pat.pat_attributes in + let desc = + match pat with + { pat_extra=[Tpat_unpack, _, _attrs]; pat_desc = Tpat_var (_,name); _ } -> + Ppat_unpack name + | { pat_extra=[Tpat_type (_path, lid), _, _attrs]; _ } -> + Ppat_type (map_loc sub lid) + | { pat_extra= (Tpat_constraint ct, _, _attrs) :: rem; _ } -> + Ppat_constraint (sub.pat sub { pat with pat_extra=rem }, + sub.typ sub ct) + | _ -> + match pat.pat_desc with + Tpat_any -> Ppat_any + | Tpat_var (id, name) -> + begin + match (Ident.name id).[0] with + 'A'..'Z' -> + Ppat_unpack name + | _ -> + Ppat_var name + end + + (* We transform (_ as x) in x if _ and x have the same location. + The compiler transforms (x:t) into (_ as x : t). + This avoids transforming a warning 27 into a 26. + *) + | Tpat_alias ({pat_desc = Tpat_any; pat_loc}, _id, name) + when pat_loc = pat.pat_loc -> + Ppat_var name + + | Tpat_alias (pat, _id, name) -> + Ppat_alias (sub.pat sub pat, name) + | Tpat_constant cst -> Ppat_constant cst + | Tpat_tuple list -> + Ppat_tuple (List.map (sub.pat sub) list) + | Tpat_construct (lid, _, args) -> + Ppat_construct (map_loc sub lid, + (match args with + [] -> None + | [arg] -> Some (sub.pat sub arg) + | args -> + Some + (Pat.tuple ~loc + (List.map (sub.pat sub) args) + ) + )) + | Tpat_variant (label, pato, _) -> + Ppat_variant (label, map_opt (sub.pat sub) pato) + | Tpat_record (list, closed) -> + Ppat_record (List.map (fun (lid, _, pat) -> + map_loc sub lid, sub.pat sub pat) list, closed) + | Tpat_array list -> Ppat_array (List.map (sub.pat sub) list) + | Tpat_or (p1, p2, _) -> Ppat_or (sub.pat sub p1, sub.pat sub p2) + | Tpat_lazy p -> Ppat_lazy (sub.pat sub p) + in + Pat.mk ~loc ~attrs desc + +let exp_extra sub (extra, loc, attrs) sexp = + let loc = sub.location sub loc; in + let attrs = sub.attributes sub attrs in + let desc = + match extra with + Texp_coerce (cty1, cty2) -> + Pexp_coerce (sexp, + map_opt (sub.typ sub) cty1, + sub.typ sub cty2) + | Texp_constraint cty -> + Pexp_constraint (sexp, sub.typ sub cty) + | Texp_open (ovf, _path, lid, _) -> + Pexp_open (ovf, map_loc sub lid, sexp) + | Texp_poly cto -> Pexp_poly (sexp, map_opt (sub.typ sub) cto) + | Texp_newtype s -> Pexp_newtype (s, sexp) + in + Exp.mk ~loc ~attrs desc + +let cases sub l = List.map (sub.case sub) l + +let case sub {c_lhs; c_guard; c_rhs} = + { + pc_lhs = sub.pat sub c_lhs; + pc_guard = map_opt (sub.expr sub) c_guard; + pc_rhs = sub.expr sub c_rhs; + } + +let value_binding sub vb = + let loc = sub.location sub vb.vb_loc; in + let attrs = sub.attributes sub vb.vb_attributes in + Vb.mk ~loc ~attrs + (sub.pat sub vb.vb_pat) + (sub.expr sub vb.vb_expr) + +let expression sub exp = + let loc = sub.location sub exp.exp_loc; in + let attrs = sub.attributes sub exp.exp_attributes in + let desc = + match exp.exp_desc with + Texp_ident (_path, lid, _) -> Pexp_ident (map_loc sub lid) + | Texp_constant cst -> Pexp_constant cst + | Texp_let (rec_flag, list, exp) -> + Pexp_let (rec_flag, + List.map (sub.value_binding sub) list, + sub.expr sub exp) + + (* Pexp_function can't have a label, so we split in 3 cases. *) + (* One case, no guard: It's a fun. *) + | Texp_function (label, [{c_lhs=p; c_guard=None; c_rhs=e}], _) -> + Pexp_fun (label, None, sub.pat sub p, sub.expr sub e) + (* No label: it's a function. *) + | Texp_function (Nolabel, cases, _) -> + Pexp_function (sub.cases sub cases) + (* Mix of both, we generate `fun ~label:$name$ -> match $name$ with ...` *) + | Texp_function (Labelled s | Optional s as label, cases, _) -> + let name = fresh_name s exp.exp_env in + Pexp_fun (label, None, Pat.var ~loc {loc;txt = name }, + Exp.match_ ~loc (Exp.ident ~loc {loc;txt= Lident name}) + (sub.cases sub cases)) + | Texp_apply (exp, list) -> + Pexp_apply (sub.expr sub exp, + List.fold_right (fun (label, expo, _) list -> + match expo with + None -> list + | Some exp -> (label, sub.expr sub exp) :: list + ) list []) + | Texp_match (exp, cases, exn_cases, _) -> + let merged_cases = sub.cases sub cases + @ List.map + (fun c -> + let uc = sub.case sub 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 (sub.expr sub exp, merged_cases) + | Texp_try (exp, cases) -> + Pexp_try (sub.expr sub exp, sub.cases sub cases) + | Texp_tuple list -> + Pexp_tuple (List.map (sub.expr sub) list) + | Texp_construct (lid, _, args) -> + Pexp_construct (map_loc sub lid, + (match args with + [] -> None + | [ arg ] -> Some (sub.expr sub arg) + | args -> + Some + (Exp.tuple ~loc (List.map (sub.expr sub) args)) + )) + | Texp_variant (label, expo) -> + Pexp_variant (label, map_opt (sub.expr sub) expo) + | Texp_record (list, expo) -> + Pexp_record (List.map (fun (lid, _, exp) -> + (map_loc sub lid, sub.expr sub exp) + ) list, + map_opt (sub.expr sub) expo) + | Texp_field (exp, lid, _label) -> + Pexp_field (sub.expr sub exp, map_loc sub lid) + | Texp_setfield (exp1, lid, _label, exp2) -> + Pexp_setfield (sub.expr sub exp1, map_loc sub lid, + sub.expr sub exp2) + | Texp_array list -> + Pexp_array (List.map (sub.expr sub) list) + | Texp_ifthenelse (exp1, exp2, expo) -> + Pexp_ifthenelse (sub.expr sub exp1, + sub.expr sub exp2, + map_opt (sub.expr sub) expo) + | Texp_sequence (exp1, exp2) -> + Pexp_sequence (sub.expr sub exp1, sub.expr sub exp2) + | Texp_while (exp1, exp2) -> + Pexp_while (sub.expr sub exp1, sub.expr sub exp2) + | Texp_for (_id, name, exp1, exp2, dir, exp3) -> + Pexp_for (name, + sub.expr sub exp1, sub.expr sub exp2, + dir, sub.expr sub exp3) + | Texp_send (exp, meth, _) -> + Pexp_send (sub.expr sub exp, match meth with + Tmeth_name name -> name + | Tmeth_val id -> Ident.name id) + | Texp_new (_path, lid, _) -> Pexp_new (map_loc sub lid) + | Texp_instvar (_, path, name) -> + Pexp_ident ({loc = sub.location sub name.loc ; txt = lident_of_path path}) + | Texp_setinstvar (_, _path, lid, exp) -> + Pexp_setinstvar (map_loc sub lid, sub.expr sub exp) + | Texp_override (_, list) -> + Pexp_override (List.map (fun (_path, lid, exp) -> + (map_loc sub lid, sub.expr sub exp) + ) list) + | Texp_letmodule (_id, name, mexpr, exp) -> + Pexp_letmodule (name, sub.module_expr sub mexpr, + sub.expr sub exp) + | Texp_assert exp -> Pexp_assert (sub.expr sub exp) + | Texp_lazy exp -> Pexp_lazy (sub.expr sub exp) + | Texp_object (cl, _) -> + Pexp_object (sub.class_structure sub cl) + | Texp_pack (mexpr) -> + Pexp_pack (sub.module_expr sub mexpr) + in + List.fold_right (exp_extra sub) exp.exp_extra + (Exp.mk ~loc ~attrs desc) + +let package_type sub pack = + (map_loc sub pack.pack_txt, + List.map (fun (s, ct) -> + (s, sub.typ sub ct)) pack.pack_fields) + +let module_type_declaration sub mtd = + let loc = sub.location sub mtd.mtd_loc; in + let attrs = sub.attributes sub mtd.mtd_attributes in + Mtd.mk ~loc ~attrs + ?typ:(map_opt (sub.module_type sub) mtd.mtd_type) + (map_loc sub mtd.mtd_name) + +let signature sub sg = + List.map (sub.signature_item sub) sg.sig_items + +let signature_item sub item = + let loc = sub.location sub item.sig_loc; in + let desc = + match item.sig_desc with + Tsig_value v -> + Psig_value (sub.value_description sub v) + | Tsig_type (rec_flag, list) -> + Psig_type (rec_flag, List.map (sub.type_declaration sub) list) + | Tsig_typext tyext -> + Psig_typext (sub.type_extension sub tyext) + | Tsig_exception ext -> + Psig_exception (sub.extension_constructor sub ext) + | Tsig_module md -> + Psig_module (sub.module_declaration sub md) + | Tsig_recmodule list -> + Psig_recmodule (List.map (sub.module_declaration sub) list) + | Tsig_modtype mtd -> + Psig_modtype (sub.module_type_declaration sub mtd) + | Tsig_open od -> + Psig_open (sub.open_description sub od) + | Tsig_include incl -> + Psig_include (sub.include_description sub incl) + | Tsig_class list -> + Psig_class (List.map (sub.class_description sub) list) + | Tsig_class_type list -> + Psig_class_type (List.map (sub.class_type_declaration sub) list) + | Tsig_attribute x -> + Psig_attribute x + in + Sig.mk ~loc desc + +let module_declaration sub md = + let loc = sub.location sub md.md_loc; in + let attrs = sub.attributes sub md.md_attributes in + Md.mk ~loc ~attrs + (map_loc sub md.md_name) + (sub.module_type sub md.md_type) + +let include_infos f sub incl = + let loc = sub.location sub incl.incl_loc; in + let attrs = sub.attributes sub incl.incl_attributes in + Incl.mk ~loc ~attrs + (f sub incl.incl_mod) + +let include_declaration sub = include_infos sub.module_expr sub +let include_description sub = include_infos sub.module_type sub + +let class_infos f sub ci = + let loc = sub.location sub ci.ci_loc; in + let attrs = sub.attributes sub ci.ci_attributes in + Ci.mk ~loc ~attrs + ~virt:ci.ci_virt + ~params:(List.map (type_parameter sub) ci.ci_params) + (map_loc sub ci.ci_id_name) + (f sub ci.ci_expr) + +let class_declaration sub = class_infos sub.class_expr sub +let class_description sub = class_infos sub.class_type sub +let class_type_declaration sub = class_infos sub.class_type sub + +let module_type sub mty = + let loc = sub.location sub mty.mty_loc; in + let attrs = sub.attributes sub mty.mty_attributes in + let desc = match mty.mty_desc with + Tmty_ident (_path, lid) -> Pmty_ident (map_loc sub lid) + | Tmty_alias (_path, lid) -> Pmty_alias (map_loc sub lid) + | Tmty_signature sg -> Pmty_signature (sub.signature sub sg) + | Tmty_functor (_id, name, mtype1, mtype2) -> + Pmty_functor (name, map_opt (sub.module_type sub) mtype1, + sub.module_type sub mtype2) + | Tmty_with (mtype, list) -> + Pmty_with (sub.module_type sub mtype, + List.map (sub.with_constraint sub) list) + | Tmty_typeof mexpr -> + Pmty_typeof (sub.module_expr sub mexpr) + in + Mty.mk ~loc ~attrs desc + +let with_constraint sub (_path, lid, cstr) = + match cstr with + | Twith_type decl -> + Pwith_type (map_loc sub lid, sub.type_declaration sub decl) + | Twith_module (_path, lid2) -> + Pwith_module (map_loc sub lid, map_loc sub lid2) + | Twith_typesubst decl -> Pwith_typesubst (sub.type_declaration sub decl) + | Twith_modsubst (_path, lid2) -> + Pwith_modsubst + ({loc = sub.location sub lid.loc; txt=Longident.last lid.txt}, + map_loc sub lid2) + +let module_expr sub mexpr = + let loc = sub.location sub mexpr.mod_loc; in + let attrs = sub.attributes sub mexpr.mod_attributes in + match mexpr.mod_desc with + Tmod_constraint (m, _, Tmodtype_implicit, _ ) -> + sub.module_expr sub m + | _ -> + let desc = match mexpr.mod_desc with + Tmod_ident (_p, lid) -> Pmod_ident (map_loc sub lid) + | Tmod_structure st -> Pmod_structure (sub.structure sub st) + | Tmod_functor (_id, name, mtype, mexpr) -> + Pmod_functor (name, Misc.may_map (sub.module_type sub) mtype, + sub.module_expr sub mexpr) + | Tmod_apply (mexp1, mexp2, _) -> + Pmod_apply (sub.module_expr sub mexp1, sub.module_expr sub mexp2) + | Tmod_constraint (mexpr, _, Tmodtype_explicit mtype, _) -> + Pmod_constraint (sub.module_expr sub mexpr, + sub.module_type sub mtype) + | Tmod_constraint (_mexpr, _, Tmodtype_implicit, _) -> + assert false + | Tmod_unpack (exp, _pack) -> + Pmod_unpack (sub.expr sub exp) + (* TODO , sub.package_type sub pack) *) + in + Mod.mk ~loc ~attrs desc + +let class_expr sub cexpr = + let loc = sub.location sub cexpr.cl_loc; in + let attrs = sub.attributes sub cexpr.cl_attributes in + let desc = match cexpr.cl_desc with + | Tcl_constraint ( { cl_desc = Tcl_ident (_path, lid, tyl); _ }, + None, _, _, _ ) -> + Pcl_constr (map_loc sub lid, + List.map (sub.typ sub) tyl) + | Tcl_structure clstr -> Pcl_structure (sub.class_structure sub clstr) + + | Tcl_fun (label, pat, _pv, cl, _partial) -> + Pcl_fun (label, None, sub.pat sub pat, sub.class_expr sub cl) + + | Tcl_apply (cl, args) -> + Pcl_apply (sub.class_expr sub cl, + List.fold_right (fun (label, expo, _) list -> + match expo with + None -> list + | Some exp -> (label, sub.expr sub exp) :: list + ) args []) + + | Tcl_let (rec_flat, bindings, _ivars, cl) -> + Pcl_let (rec_flat, + List.map (sub.value_binding sub) bindings, + sub.class_expr sub cl) + + | Tcl_constraint (cl, Some clty, _vals, _meths, _concrs) -> + Pcl_constraint (sub.class_expr sub cl, sub.class_type sub clty) + + | Tcl_ident _ -> assert false + | Tcl_constraint (_, None, _, _, _) -> assert false + in + Cl.mk ~loc ~attrs desc + +let class_type sub ct = + let loc = sub.location sub ct.cltyp_loc; in + let attrs = sub.attributes sub ct.cltyp_attributes in + let desc = match ct.cltyp_desc with + Tcty_signature csg -> Pcty_signature (sub.class_signature sub csg) + | Tcty_constr (_path, lid, list) -> + Pcty_constr (map_loc sub lid, List.map (sub.typ sub) list) + | Tcty_arrow (label, ct, cl) -> + Pcty_arrow (label, sub.typ sub ct, sub.class_type sub cl) + in + Cty.mk ~loc ~attrs desc + +let class_signature sub cs = + { + pcsig_self = sub.typ sub cs.csig_self; + pcsig_fields = List.map (sub.class_type_field sub) cs.csig_fields; + } + +let class_type_field sub ctf = + let loc = sub.location sub ctf.ctf_loc; in + let attrs = sub.attributes sub ctf.ctf_attributes in + let desc = match ctf.ctf_desc with + Tctf_inherit ct -> Pctf_inherit (sub.class_type sub ct) + | Tctf_val (s, mut, virt, ct) -> + Pctf_val (s, mut, virt, sub.typ sub ct) + | Tctf_method (s, priv, virt, ct) -> + Pctf_method (s, priv, virt, sub.typ sub ct) + | Tctf_constraint (ct1, ct2) -> + Pctf_constraint (sub.typ sub ct1, sub.typ sub ct2) + | Tctf_attribute x -> Pctf_attribute x + in + Ctf.mk ~loc ~attrs desc + +let core_type sub ct = + let loc = sub.location sub ct.ctyp_loc; in + let attrs = sub.attributes sub ct.ctyp_attributes in + let desc = match ct.ctyp_desc with + Ttyp_any -> Ptyp_any + | Ttyp_var s -> Ptyp_var s + | Ttyp_arrow (label, ct1, ct2) -> + Ptyp_arrow (label, sub.typ sub ct1, sub.typ sub ct2) + | Ttyp_tuple list -> Ptyp_tuple (List.map (sub.typ sub) list) + | Ttyp_constr (_path, lid, list) -> + Ptyp_constr (map_loc sub lid, + List.map (sub.typ sub) list) + | Ttyp_object (list, o) -> + Ptyp_object + (List.map (fun (s, a, t) -> (s, a, sub.typ sub t)) list, o) + | Ttyp_class (_path, lid, list) -> + Ptyp_class (map_loc sub lid, List.map (sub.typ sub) list) + | Ttyp_alias (ct, s) -> + Ptyp_alias (sub.typ sub ct, s) + | Ttyp_variant (list, bool, labels) -> + Ptyp_variant (List.map (sub.row_field sub) list, bool, labels) + | Ttyp_poly (list, ct) -> Ptyp_poly (list, sub.typ sub ct) + | Ttyp_package pack -> Ptyp_package (sub.package_type sub pack) + in + Typ.mk ~loc ~attrs desc + +let class_structure sub cs = + 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 = sub.pat sub (remove_self cs.cstr_self); + pcstr_fields = List.map (sub.class_field sub) cs.cstr_fields; + } + +let row_field sub rf = + match rf with + Ttag (label, attrs, bool, list) -> + Rtag (label, sub.attributes sub attrs, bool, List.map (sub.typ sub) list) + | Tinherit ct -> Rinherit (sub.typ sub ct) + +and is_self_pat = function + | { pat_desc = Tpat_alias(_pat, id, _) } -> + string_is_prefix "self-" (Ident.name id) + | _ -> false + +let class_field sub cf = + let loc = sub.location sub cf.cf_loc; in + let attrs = sub.attributes sub cf.cf_attributes in + let desc = match cf.cf_desc with + Tcf_inherit (ovf, cl, super, _vals, _meths) -> + Pcf_inherit (ovf, sub.class_expr sub cl, super) + | Tcf_constraint (cty, cty') -> + Pcf_constraint (sub.typ sub cty, sub.typ sub cty') + | Tcf_val (lab, mut, _, Tcfk_virtual cty, _) -> + Pcf_val (lab, mut, Cfk_virtual (sub.typ sub cty)) + | Tcf_val (lab, mut, _, Tcfk_concrete (o, exp), _) -> + Pcf_val (lab, mut, Cfk_concrete (o, sub.expr sub exp)) + | Tcf_method (lab, priv, Tcfk_virtual cty) -> + Pcf_method (lab, priv, Cfk_virtual (sub.typ sub cty)) + | Tcf_method (lab, priv, Tcfk_concrete (o, exp)) -> + let remove_fun_self = function + | { exp_desc = Texp_function(Nolabel, [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, sub.expr sub exp)) + | Tcf_initializer exp -> + let remove_fun_self = function + | { exp_desc = Texp_function(Nolabel, [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 (sub.expr sub exp) + | Tcf_attribute x -> Pcf_attribute x + in + Cf.mk ~loc ~attrs desc + +let location sub l = l + +let default_mapper = + { + attribute = attribute ; + attributes = attributes ; + structure = structure; + structure_item = structure_item; + module_expr = module_expr; + signature = signature; + signature_item = signature_item; + module_type = module_type; + with_constraint = with_constraint; + class_declaration = class_declaration; + class_expr = class_expr; + class_field = class_field; + class_structure = class_structure; + class_type = class_type; + class_type_field = class_type_field; + class_signature = class_signature; + class_type_declaration = class_type_declaration; + class_description = class_description; + type_declaration = type_declaration; + type_kind = type_kind; + typ = core_type; + type_extension = type_extension; + extension_constructor = extension_constructor; + value_description = value_description; + pat = pattern; + expr = expression; + module_declaration = module_declaration; + module_type_declaration = module_type_declaration; + module_binding = module_binding; + package_type = package_type ; + open_description = open_description; + include_description = include_description; + include_declaration = include_declaration; + value_binding = value_binding; + constructor_declaration = constructor_declaration; + label_declaration = label_declaration; + cases = cases; + case = case; + location = location; + row_field = row_field ; + } + +let untype_structure ?(mapper=default_mapper) structure = + mapper.structure mapper structure + +let untype_signature ?(mapper=default_mapper) signature = + mapper.signature mapper signature diff --git a/typing/untypeast.mli b/typing/untypeast.mli new file mode 100644 index 0000000000..702fe0cd73 --- /dev/null +++ b/typing/untypeast.mli @@ -0,0 +1,73 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Thomas Gazagnaire (OCamlPro), Fabrice Le Fessant (INRIA Saclay) *) +(* *) +(* Copyright 2007 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. *) +(* *) +(**************************************************************************) + +open Parsetree + +val lident_of_path : Path.t -> Longident.t + +type mapper = { + attribute: mapper -> Typedtree.attribute -> attribute; + attributes: mapper -> Typedtree.attribute list -> attribute list; + case: mapper -> Typedtree.case -> case; + cases: mapper -> Typedtree.case list -> case list; + class_declaration: mapper -> Typedtree.class_declaration -> class_declaration; + class_description: mapper -> Typedtree.class_description -> class_description; + class_expr: mapper -> Typedtree.class_expr -> class_expr; + class_field: mapper -> Typedtree.class_field -> class_field; + class_signature: mapper -> Typedtree.class_signature -> class_signature; + class_structure: mapper -> Typedtree.class_structure -> class_structure; + class_type: mapper -> Typedtree.class_type -> class_type; + class_type_declaration: mapper -> Typedtree.class_type_declaration + -> class_type_declaration; + class_type_field: mapper -> Typedtree.class_type_field -> class_type_field; + constructor_declaration: mapper -> Typedtree.constructor_declaration + -> constructor_declaration; + expr: mapper -> Typedtree.expression -> expression; + extension_constructor: mapper -> Typedtree.extension_constructor + -> extension_constructor; + include_declaration: + mapper -> Typedtree.include_declaration -> include_declaration; + include_description: + mapper -> Typedtree.include_description -> include_description; + label_declaration: + mapper -> Typedtree.label_declaration -> label_declaration; + location: mapper -> Location.t -> Location.t; + module_binding: mapper -> Typedtree.module_binding -> module_binding; + module_declaration: + mapper -> Typedtree.module_declaration -> module_declaration; + module_expr: mapper -> Typedtree.module_expr -> module_expr; + module_type: mapper -> Typedtree.module_type -> module_type; + module_type_declaration: + mapper -> Typedtree.module_type_declaration -> module_type_declaration; + package_type: mapper -> Typedtree.package_type -> package_type; + open_description: mapper -> Typedtree.open_description -> open_description; + pat: mapper -> Typedtree.pattern -> pattern; + row_field: mapper -> Typedtree.row_field -> row_field; + signature: mapper -> Typedtree.signature -> signature; + signature_item: mapper -> Typedtree.signature_item -> signature_item; + structure: mapper -> Typedtree.structure -> structure; + structure_item: mapper -> Typedtree.structure_item -> structure_item; + typ: mapper -> Typedtree.core_type -> core_type; + type_declaration: mapper -> Typedtree.type_declaration -> type_declaration; + type_extension: mapper -> Typedtree.type_extension -> type_extension; + type_kind: mapper -> Typedtree.type_kind -> type_kind; + value_binding: mapper -> Typedtree.value_binding -> value_binding; + value_description: mapper -> Typedtree.value_description -> value_description; + with_constraint: + mapper -> (Path.t * Longident.t Location.loc * Typedtree.with_constraint) + -> with_constraint; +} + +val default_mapper : mapper + +val untype_structure : ?mapper:mapper -> Typedtree.structure -> structure +val untype_signature : ?mapper:mapper -> Typedtree.signature -> signature diff --git a/utils/ccomp.ml b/utils/ccomp.ml index bbc8e3f0b3..a897ddc0d9 100644 --- a/utils/ccomp.ml +++ b/utils/ccomp.ml @@ -48,16 +48,20 @@ let quote_optfile = function | None -> "" | Some f -> Filename.quote f -let compile_file name = +let compile_file ~output_name name = command (Printf.sprintf - "%s -c %s %s %s %s" + "%s%s -c %s %s %s %s %s" (match !Clflags.c_compiler with | Some cc -> cc | None -> if !Clflags.native_code then Config.native_c_compiler else Config.bytecomp_c_compiler) + (match output_name with + | Some n -> " -o " ^ Filename.quote n + | None -> "") + (if !Clflags.debug then "-g" else "") (String.concat " " (List.rev !Clflags.all_ccopts)) (quote_prefixed "-I" (List.rev !Clflags.include_dirs)) (Clflags.std_include_flag "-I") @@ -97,14 +101,22 @@ type link_mode = | MainDll | Partial +let remove_Wl cclibs = + cclibs |> List.map (fun cclib -> + (* -Wl,-foo,bar -> -foo bar *) + if String.length cclib >= 4 && "-Wl," = String.sub cclib 0 4 then + String.map (function ',' -> ' ' | c -> c) + (String.sub cclib 4 (String.length cclib - 4)) + else cclib) + let call_linker mode output_name files extra = - let files = quote_files files in let cmd = if mode = Partial then - Printf.sprintf "%s%s %s %s" + Printf.sprintf "%s%s %s %s %s" Config.native_pack_linker (Filename.quote output_name) - files + (quote_prefixed "-L" !Config.load_path) + (quote_files (remove_Wl files)) extra else Printf.sprintf "%s -o %s %s %s %s %s %s %s" @@ -120,7 +132,7 @@ let call_linker mode output_name files extra = "" (*(Clflags.std_include_flag "-I")*) (quote_prefixed "-L" !Config.load_path) (String.concat " " (List.rev !Clflags.all_ccopts)) - files + (quote_files files) extra in command cmd = 0 diff --git a/utils/ccomp.mli b/utils/ccomp.mli index 63a190c339..897c2abbfa 100644 --- a/utils/ccomp.mli +++ b/utils/ccomp.mli @@ -14,7 +14,7 @@ val command: string -> int val run_command: string -> unit -val compile_file: string -> int +val compile_file: output_name:string option -> string -> int val create_archive: string -> string list -> int val expand_libname: string -> string val quote_files: string list -> string diff --git a/utils/clflags.ml b/utils/clflags.ml index 57834ccf91..4d2010af77 100644 --- a/utils/clflags.ml +++ b/utils/clflags.ml @@ -26,8 +26,10 @@ and debug = ref false (* -g *) and fast = ref false (* -unsafe *) and link_everything = ref false (* -linkall *) and custom_runtime = ref false (* -custom *) +and no_check_prims = ref false (* -no-check-prims *) and bytecode_compatible_32 = ref false (* -compat-32 *) and output_c_object = ref false (* -output-obj *) +and output_complete_object = ref false (* -output-complete-obj *) and all_ccopts = ref ([] : string list) (* -ccopt *) and classic = ref false (* -nolabels *) and nopervasives = ref false (* -nopervasives *) @@ -106,7 +108,12 @@ let std_include_dir () = let shared = ref false (* -shared *) let dlcode = ref true (* not -nodynlink *) +let pic_code = ref (match Config.architecture with (* -fPIC *) + | "amd64" -> true + | _ -> false) + let runtime_variant = ref "";; (* -runtime-variant *) +let keep_docs = ref false (* -keep-docs *) 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 7e51cf33db..e62dc8b848 100644 --- a/utils/clflags.mli +++ b/utils/clflags.mli @@ -23,8 +23,10 @@ val debug : bool ref val fast : bool ref val link_everything : bool ref val custom_runtime : bool ref +val no_check_prims : bool ref val bytecode_compatible_32 : bool ref val output_c_object : bool ref +val output_complete_object : bool ref val all_ccopts : string list ref val classic : bool ref val nopervasives : bool ref @@ -89,8 +91,10 @@ val std_include_flag : string -> string val std_include_dir : unit -> string list val shared : bool ref val dlcode : bool ref +val pic_code : bool ref val runtime_variant : string ref val force_slash : bool ref +val keep_docs : 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 c887ac2b4e..35e8c5b504 100644 --- a/utils/config.mlbuild +++ b/utils/config.mlbuild @@ -61,15 +61,15 @@ let mkexe = C.mkexe let mkmaindll = C.mkmaindll let exec_magic_number = "Caml1999X011" -and cmi_magic_number = "Caml1999I016" +and cmi_magic_number = "Caml1999I019" 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" -and ast_intf_magic_number = "Caml1999N015" +and ast_impl_magic_number = "Caml1999M019" +and ast_intf_magic_number = "Caml1999N018" and cmxs_magic_number = "Caml2007D001" -and cmt_magic_number = "Caml2012T002" +and cmt_magic_number = "Caml2012T006" let load_path = ref ([] : string list) diff --git a/utils/config.mlp b/utils/config.mlp index ce216cc1fd..f89f618eaf 100644 --- a/utils/config.mlp +++ b/utils/config.mlp @@ -49,15 +49,15 @@ let mkexe = "%%MKEXE%%" let mkmaindll = "%%MKMAINDLL%%" let exec_magic_number = "Caml1999X011" -and cmi_magic_number = "Caml1999I018" +and cmi_magic_number = "Caml1999I019" 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 ast_impl_magic_number = "Caml1999M019" +and ast_intf_magic_number = "Caml1999N018" and cmxs_magic_number = "Caml2007D002" -and cmt_magic_number = "Caml2012T005" +and cmt_magic_number = "Caml2012T006" let load_path = ref ([] : string list) diff --git a/utils/misc.ml b/utils/misc.ml index 2eb8088e77..82328ef26a 100644 --- a/utils/misc.ml +++ b/utils/misc.ml @@ -104,7 +104,7 @@ let find_in_path_rel path name = in try_dir path let find_in_path_uncap path name = - let uname = String.uncapitalize name in + let uname = String.uncapitalize_ascii name in let rec try_dir = function [] -> raise Not_found | dir::rem -> @@ -176,7 +176,9 @@ let no_overflow_add a b = (a lxor b) lor (a lxor (lnot (a+b))) < 0 let no_overflow_sub a b = (a lxor (lnot b)) lor (b lxor (a-b)) < 0 -let no_overflow_lsl a = min_int asr 1 <= a && a <= max_int asr 1 +let no_overflow_mul a b = b <> 0 && (a * b) / b = a + +let no_overflow_lsl a k = 0 <= k && k < Sys.word_size && min_int asr k <= a && a <= max_int asr k (* String operations *) @@ -202,6 +204,17 @@ let search_substring pat str start = else search (i+1) 0 in search start 0 +let replace_substring ~before ~after str = + let rec search acc curr = + match search_substring before str curr with + | next -> + let prefix = String.sub str curr (next - curr) in + search (prefix :: acc) (next + String.length before) + | exception Not_found -> + let suffix = String.sub str curr (String.length str - curr) in + List.rev (suffix :: acc) + in String.concat after (search [] 0) + let rev_split_words s = let rec split1 res i = if i >= String.length s then res else begin @@ -321,6 +334,39 @@ let edit_distance a b cutoff = else Some result end +let spellcheck env name = + let cutoff = + match String.length name with + | 1 | 2 -> 0 + | 3 | 4 -> 1 + | 5 | 6 -> 2 + | _ -> 3 + in + let compare target acc head = + match edit_distance target head cutoff with + | None -> acc + | Some dist -> + let (best_choice, best_dist) = acc in + if dist < best_dist then ([head], dist) + else if dist = best_dist then (head :: best_choice, dist) + else acc + in + fst (List.fold_left (compare name) ([], max_int) env) + +let did_you_mean ppf get_choices = + (* flush now to get the error report early, in the (unheard of) case + where the search in the get_choices function would take a bit of + time; in the worst case, the user has seen the error, she can + interrupt the process before the spell-checking terminates. *) + Format.fprintf ppf "@?"; + match get_choices () with + | [] -> () + | choices -> + let rest, last = split_last choices in + Format.fprintf ppf "@\nHint: Did you mean %s%s%s?" + (String.concat ", " rest) + (if rest = [] then "" else " or ") + last (* split a string [s] at every char [c], and return the list of sub-strings *) let split s c = @@ -341,3 +387,7 @@ let split s c = let cut_at s c = let pos = String.index s c in String.sub s 0 pos, String.sub s (pos+1) (String.length s - pos - 1) + + +module StringSet = Set.Make(struct type t = string let compare = compare end) +module StringMap = Map.Make(struct type t = string let compare = compare end) diff --git a/utils/misc.mli b/utils/misc.mli index 5168a6a913..1ff1d2cccf 100644 --- a/utils/misc.mli +++ b/utils/misc.mli @@ -80,9 +80,12 @@ val no_overflow_add: int -> int -> bool val no_overflow_sub: int -> int -> bool (* [no_overflow_add n1 n2] returns [true] if the computation of [n1 - n2] does not overflow. *) -val no_overflow_lsl: int -> bool - (* [no_overflow_add n] returns [true] if the computation of - [n lsl 1] does not overflow. *) +val no_overflow_mul: int -> int -> bool + (* [no_overflow_mul n1 n2] returns [true] if the computation of + [n1 * n2] does not overflow. *) +val no_overflow_lsl: int -> int -> bool + (* [no_overflow_lsl n k] returns [true] if the computation of + [n lsl k] does not overflow. *) val chop_extension_if_any: string -> string (* Like Filename.chop_extension but returns the initial file @@ -101,6 +104,10 @@ val search_substring: string -> string -> int -> int at offset [start] in [str]. Raise [Not_found] if [pat] does not occur. *) +val replace_substring: before:string -> after:string -> string -> string + (* [search_substring ~before ~after str] replaces all occurences + of [before] with [after] in [str] and returns the resulting string. *) + val rev_split_words: string -> string list (* [rev_split_words s] splits [s] in blank-separated words, and return the list of words in reverse order. *) @@ -144,6 +151,25 @@ val edit_distance : string -> string -> int -> int option other. The particular algorithm may change in the future. *) +val spellcheck : string list -> string -> string list +(** [spellcheck env name] takes a list of names [env] that exist in + the current environment and an erroneous [name], and returns a + list of suggestions taken from [env], that are close enough to + [name] that it may be a typo for one of them. *) + +val did_you_mean : Format.formatter -> (unit -> string list) -> unit +(** [did_you_mean ppf get_choices] hints that the user may have meant + one of the option returned by calling [get_choices]. It does nothing + if the returned list is empty. + + The [unit -> ...] thunking is meant to delay any potentially-slow + computation (typically computing edit-distance with many things + from the current environment) to when the hint message is to be + printed. You should print an understandable error message before + calling [did_you_mean], so that users get a clear notification of + the failure even if producing the hint is slow. +*) + val split : string -> char -> string list (** [String.split string char] splits the string [string] at every char [char], and returns the list of sub-strings between the chars. @@ -161,3 +187,9 @@ val cut_at : string -> char -> string * string Raise [Not_found] if the character does not appear in the string @since 4.01 *) + + +module StringSet: Set.S with type elt = string +module StringMap: Map.S with type key = string +(* TODO: replace all custom instantiations of StringSet/StringMap in various + compiler modules with this one. *) diff --git a/utils/warnings.ml b/utils/warnings.ml index 103789c4ed..b2d5e573cc 100644 --- a/utils/warnings.ml +++ b/utils/warnings.ml @@ -23,7 +23,7 @@ type t = | Deprecated of string (* 3 *) | Fragile_match of string (* 4 *) | Partial_application (* 5 *) - | Labels_omitted (* 6 *) + | Labels_omitted of string list (* 6 *) | Method_override of string list (* 7 *) | Partial_match of string (* 8 *) | Non_closed_record_pattern of string (* 9 *) @@ -67,6 +67,8 @@ type t = | Attribute_payload of string * string (* 47 *) | Eliminated_optional_arguments of string list (* 48 *) | No_cmi_file of string (* 49 *) + | Bad_docstring of bool (* 50 *) + | Expect_tailcall (* 51 *) ;; (* If you remove a warning, leave a hole in the numbering. NEVER change @@ -81,7 +83,7 @@ let number = function | Deprecated _ -> 3 | Fragile_match _ -> 4 | Partial_application -> 5 - | Labels_omitted -> 6 + | Labels_omitted _ -> 6 | Method_override _ -> 7 | Partial_match _ -> 8 | Non_closed_record_pattern _ -> 9 @@ -125,9 +127,11 @@ let number = function | Attribute_payload _ -> 47 | Eliminated_optional_arguments _ -> 48 | No_cmi_file _ -> 49 + | Bad_docstring _ -> 50 + | Expect_tailcall -> 51 ;; -let last_warning_number = 49 +let last_warning_number = 51 (* Must be the max number returned by the [number] function. *) let letter = function @@ -206,7 +210,7 @@ let parse_opt error active flags s = if i >= String.length s then () else match s.[i] with | 'A' .. 'Z' -> - List.iter set (letter (Char.lowercase s.[i])); + List.iter set (letter (Char.lowercase_ascii s.[i])); loop (i+1) | 'a' .. 'z' -> List.iter clear (letter s.[i]); @@ -223,7 +227,7 @@ let parse_opt error active flags s = for n = n1 to min n2 last_warning_number do myset n done; loop i | 'A' .. 'Z' -> - List.iter myset (letter (Char.lowercase s.[i])); + List.iter myset (letter (Char.lowercase_ascii s.[i])); loop (i+1) | 'a' .. 'z' -> List.iter myset (letter s.[i]); @@ -240,7 +244,7 @@ let parse_options errflag 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";; +let defaults_w = "+a-4-6-7-9-27-29-32..39-41..42-44-45-48-50";; let defaults_warn_error = "-a";; let () = parse_options false defaults_w;; @@ -258,8 +262,12 @@ let message = function | Partial_application -> "this function application is partial,\n\ maybe some arguments are missing." - | Labels_omitted -> - "labels were omitted in the application of this function." + | Labels_omitted [] -> assert false + | Labels_omitted [l] -> + "label " ^ l ^ " was omitted in the application of this function." + | Labels_omitted ls -> + "labels " ^ String.concat ", " ls ^ + " were omitted in the application of this function." | Method_override [lab] -> "the method " ^ lab ^ " is overridden." | Method_override (cname :: slist) -> @@ -384,6 +392,11 @@ let message = function (String.concat ", " sl) | No_cmi_file s -> "no cmi file was found in path for module " ^ s + | Bad_docstring unattached -> + if unattached then "unattached documentation comment (ignored)" + else "ambiguous documentation comment" + | Expect_tailcall -> + Printf.sprintf "expected tailcall" ;; let nerrors = ref 0;; @@ -391,19 +404,9 @@ let nerrors = ref 0;; let print ppf w = let msg = message w in let num = number w in - let newlines = ref 0 in - for i = 0 to String.length msg - 1 do - if msg.[i] = '\n' then incr newlines; - done; - 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_formatter_out_functions ppf out_functions; - if (!current).error.(num) then incr nerrors; - !newlines + if (!current).error.(num) then incr nerrors ;; exception Errors of int;; @@ -443,7 +446,7 @@ let descriptions = 19, "Type without principality."; 20, "Unused function argument."; 21, "Non-returning statement."; - 22, "Proprocessor warning."; + 22, "Preprocessor warning."; 23, "Useless record \"with\" clause."; 24, "Bad module name: the source file name is not a valid OCaml module \ name."; @@ -474,25 +477,27 @@ 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."; + 46, "Error in environment variable."; 47, "Illegal attribute payload."; 48, "Implicit elimination of optional arguments."; - 49, "Absent cmi file when looking up module alias."; + 49, "Missing cmi file when looking up module alias."; + 50, "Unexpected documentation comment."; + 51, "Warning on non-tail calls if @tailcall present"; ] ;; let help_warnings () = List.iter (fun (i, s) -> Printf.printf "%3i %s\n" i s) descriptions; - print_endline " A All warnings."; + print_endline " A all warnings"; for i = Char.code 'b' to Char.code 'z' do let c = Char.chr i in match letter c with | [] -> () | [n] -> - Printf.printf " %c Synonym for warning %i.\n" (Char.uppercase c) n + Printf.printf " %c Alias for warning %i.\n" (Char.uppercase_ascii c) n | l -> - Printf.printf " %c Set of warnings %s.\n" - (Char.uppercase c) + Printf.printf " %c warnings %s.\n" + (Char.uppercase_ascii c) (String.concat ", " (List.map string_of_int l)) done; exit 0 diff --git a/utils/warnings.mli b/utils/warnings.mli index edfd732c31..75d0a3d79d 100644 --- a/utils/warnings.mli +++ b/utils/warnings.mli @@ -18,7 +18,7 @@ type t = | Deprecated of string (* 3 *) | Fragile_match of string (* 4 *) | Partial_application (* 5 *) - | Labels_omitted (* 6 *) + | Labels_omitted of string list (* 6 *) | Method_override of string list (* 7 *) | Partial_match of string (* 8 *) | Non_closed_record_pattern of string (* 9 *) @@ -62,6 +62,8 @@ type t = | Attribute_payload of string * string (* 47 *) | Eliminated_optional_arguments of string list (* 48 *) | No_cmi_file of string (* 49 *) + | Bad_docstring of bool (* 50 *) + | Expect_tailcall (* 51 *) ;; val parse_options : bool -> string -> unit;; @@ -72,9 +74,7 @@ val is_error : t -> bool;; val defaults_w : string;; val defaults_warn_error : string;; -val print : formatter -> t -> int;; - (* returns the number of newlines in the printed string *) - +val print : formatter -> t -> unit;; exception Errors of int;; diff --git a/yacc/Makefile b/yacc/Makefile index f5b37e0008..e7acf86908 100644 --- a/yacc/Makefile +++ b/yacc/Makefile @@ -15,7 +15,7 @@ include ../config/Makefile CC=$(BYTECC) -CFLAGS=-O -DNDEBUG $(BYTECCCOMPOPTS) +CFLAGS=-DNDEBUG $(BYTECCCOMPOPTS) OBJS= closure.o error.o lalr.o lr0.o main.o mkpar.o output.o reader.o \ skeleton.o symtab.o verbose.o warshall.o diff --git a/yacc/Makefile.nt b/yacc/Makefile.nt index 32caa41e9d..9537365a5f 100644 --- a/yacc/Makefile.nt +++ b/yacc/Makefile.nt @@ -29,9 +29,7 @@ version.h : ../VERSION clean: rm -f *.$(O) ocamlyacc.exe *~ version.h -.SUFFIXES: .c .$(O) - -.c.$(O): +%.$(O): %.c $(BYTECC) -DNDEBUG -DNO_UNIX $(BYTECCCOMPOPTS) -c $< depend: |