New upstream version 4.06.0

diff --git a/.depend b/.depend
index b46b8e42a551daf55266455d2964399d98f60d8f..8efabcb0808a54707d9c430cf9d3c555e5292c59 100644 (file)
--- a/.depend
+++ b/.depend
@@ -6,11 +6,11 @@ utils/ccomp.cmo : utils/misc.cmi utils/config.cmi utils/clflags.cmi \
 utils/ccomp.cmx : utils/misc.cmx utils/config.cmx utils/clflags.cmx \
     utils/ccomp.cmi
 utils/ccomp.cmi :
-utils/clflags.cmo : utils/numbers.cmi utils/misc.cmi utils/config.cmi \
-    utils/arg_helper.cmi utils/clflags.cmi
-utils/clflags.cmx : utils/numbers.cmx utils/misc.cmx utils/config.cmx \
-    utils/arg_helper.cmx utils/clflags.cmi
-utils/clflags.cmi : utils/misc.cmi
+utils/clflags.cmo : utils/profile.cmi utils/numbers.cmi utils/misc.cmi \
+    utils/config.cmi utils/arg_helper.cmi utils/clflags.cmi
+utils/clflags.cmx : utils/profile.cmx utils/numbers.cmx utils/misc.cmx \
+    utils/config.cmx utils/arg_helper.cmx utils/clflags.cmi
+utils/clflags.cmi : utils/profile.cmi utils/misc.cmi
 utils/config.cmo : utils/config.cmi
 utils/config.cmx : utils/config.cmi
 utils/config.cmi :
@@ -23,9 +23,12 @@ utils/identifiable.cmi :
 utils/misc.cmo : utils/misc.cmi
 utils/misc.cmx : utils/misc.cmi
 utils/misc.cmi :
-utils/numbers.cmo : utils/identifiable.cmi utils/numbers.cmi
-utils/numbers.cmx : utils/identifiable.cmx utils/numbers.cmi
+utils/numbers.cmo : utils/misc.cmi utils/identifiable.cmi utils/numbers.cmi
+utils/numbers.cmx : utils/misc.cmx utils/identifiable.cmx utils/numbers.cmi
 utils/numbers.cmi : utils/identifiable.cmi
+utils/profile.cmo : utils/misc.cmi utils/profile.cmi
+utils/profile.cmx : utils/misc.cmx utils/profile.cmi
+utils/profile.cmi :
 utils/strongly_connected_components.cmo : utils/numbers.cmi utils/misc.cmi \
     utils/identifiable.cmi utils/strongly_connected_components.cmi
 utils/strongly_connected_components.cmx : utils/numbers.cmx utils/misc.cmx \
@@ -40,9 +43,6 @@ utils/tbl.cmi :
 utils/terminfo.cmo : utils/terminfo.cmi
 utils/terminfo.cmx : utils/terminfo.cmi
 utils/terminfo.cmi :
-utils/timings.cmo : utils/timings.cmi
-utils/timings.cmx : utils/timings.cmi
-utils/timings.cmi :
 utils/warnings.cmo : utils/misc.cmi utils/warnings.cmi
 utils/warnings.cmx : utils/misc.cmx utils/warnings.cmi
 utils/warnings.cmi :
@@ -83,13 +83,10 @@ parsing/attr_helper.cmx : parsing/parsetree.cmi parsing/location.cmx \
 parsing/attr_helper.cmi : parsing/parsetree.cmi parsing/location.cmi \
     parsing/asttypes.cmi
 parsing/builtin_attributes.cmo : utils/warnings.cmi parsing/parsetree.cmi \
-    parsing/location.cmi parsing/asttypes.cmi parsing/ast_iterator.cmi \
-    parsing/builtin_attributes.cmi
+    parsing/location.cmi parsing/asttypes.cmi parsing/builtin_attributes.cmi
 parsing/builtin_attributes.cmx : utils/warnings.cmx parsing/parsetree.cmi \
-    parsing/location.cmx parsing/asttypes.cmi parsing/ast_iterator.cmx \
-    parsing/builtin_attributes.cmi
-parsing/builtin_attributes.cmi : parsing/parsetree.cmi parsing/location.cmi \
-    parsing/ast_iterator.cmi
+    parsing/location.cmx parsing/asttypes.cmi parsing/builtin_attributes.cmi
+parsing/builtin_attributes.cmi : parsing/parsetree.cmi parsing/location.cmi
 parsing/depend.cmo : parsing/parsetree.cmi utils/misc.cmi \
     parsing/longident.cmi parsing/location.cmi utils/clflags.cmi \
     parsing/builtin_attributes.cmi parsing/asttypes.cmi parsing/depend.cmi
@@ -205,41 +202,44 @@ typing/env.cmi : utils/warnings.cmi typing/types.cmi typing/subst.cmi \
     typing/path.cmi parsing/longident.cmi parsing/location.cmi \
     typing/ident.cmi utils/consistbl.cmi typing/cmi_format.cmi \
     parsing/asttypes.cmi
-typing/envaux.cmo : typing/types.cmi typing/subst.cmi typing/printtyp.cmi \
-    typing/path.cmi utils/misc.cmi typing/ident.cmi typing/env.cmi \
-    parsing/asttypes.cmi typing/envaux.cmi
-typing/envaux.cmx : typing/types.cmx typing/subst.cmx typing/printtyp.cmx \
-    typing/path.cmx utils/misc.cmx typing/ident.cmx typing/env.cmx \
-    parsing/asttypes.cmi typing/envaux.cmi
+typing/envaux.cmo : typing/subst.cmi typing/printtyp.cmi typing/path.cmi \
+    typing/ident.cmi typing/env.cmi parsing/asttypes.cmi typing/envaux.cmi
+typing/envaux.cmx : typing/subst.cmx typing/printtyp.cmx typing/path.cmx \
+    typing/ident.cmx typing/env.cmx parsing/asttypes.cmi typing/envaux.cmi
 typing/envaux.cmi : typing/subst.cmi typing/path.cmi typing/env.cmi
 typing/ident.cmo : utils/identifiable.cmi typing/ident.cmi
 typing/ident.cmx : utils/identifiable.cmx typing/ident.cmi
 typing/ident.cmi : utils/identifiable.cmi
 typing/includeclass.cmo : typing/types.cmi typing/printtyp.cmi \
-    typing/ctype.cmi typing/includeclass.cmi
+    typing/path.cmi typing/ctype.cmi parsing/builtin_attributes.cmi \
+    typing/includeclass.cmi
 typing/includeclass.cmx : typing/types.cmx typing/printtyp.cmx \
-    typing/ctype.cmx typing/includeclass.cmi
-typing/includeclass.cmi : typing/types.cmi typing/env.cmi typing/ctype.cmi
+    typing/path.cmx typing/ctype.cmx parsing/builtin_attributes.cmx \
+    typing/includeclass.cmi
+typing/includeclass.cmi : typing/types.cmi parsing/location.cmi \
+    typing/env.cmi typing/ctype.cmi
 typing/includecore.cmo : typing/types.cmi typing/typedtree.cmi \
     typing/path.cmi typing/ident.cmi typing/env.cmi typing/ctype.cmi \
-    typing/btype.cmi parsing/asttypes.cmi typing/includecore.cmi
+    parsing/builtin_attributes.cmi typing/btype.cmi parsing/asttypes.cmi \
+    typing/includecore.cmi
 typing/includecore.cmx : typing/types.cmx typing/typedtree.cmx \
     typing/path.cmx typing/ident.cmx typing/env.cmx typing/ctype.cmx \
-    typing/btype.cmx parsing/asttypes.cmi typing/includecore.cmi
+    parsing/builtin_attributes.cmx typing/btype.cmx parsing/asttypes.cmi \
+    typing/includecore.cmi
 typing/includecore.cmi : typing/types.cmi typing/typedtree.cmi \
-    typing/ident.cmi typing/env.cmi
+    parsing/location.cmi typing/ident.cmi typing/env.cmi
 typing/includemod.cmo : typing/types.cmi typing/typedtree.cmi utils/tbl.cmi \
     typing/subst.cmi typing/printtyp.cmi typing/primitive.cmi typing/path.cmi \
     typing/mtype.cmi utils/misc.cmi parsing/location.cmi \
     typing/includecore.cmi typing/includeclass.cmi typing/ident.cmi \
     typing/env.cmi typing/ctype.cmi typing/cmt_format.cmi utils/clflags.cmi \
-    typing/includemod.cmi
+    parsing/builtin_attributes.cmi typing/btype.cmi typing/includemod.cmi
 typing/includemod.cmx : typing/types.cmx typing/typedtree.cmx utils/tbl.cmx \
     typing/subst.cmx typing/printtyp.cmx typing/primitive.cmx typing/path.cmx \
     typing/mtype.cmx utils/misc.cmx parsing/location.cmx \
     typing/includecore.cmx typing/includeclass.cmx typing/ident.cmx \
     typing/env.cmx typing/ctype.cmx typing/cmt_format.cmx utils/clflags.cmx \
-    typing/includemod.cmi
+    parsing/builtin_attributes.cmx typing/btype.cmx typing/includemod.cmi
 typing/includemod.cmi : typing/types.cmi typing/typedtree.cmi \
     typing/path.cmi parsing/location.cmi typing/includecore.cmi \
     typing/ident.cmi typing/env.cmi typing/ctype.cmi
@@ -263,14 +263,16 @@ typing/parmatch.cmo : utils/warnings.cmi typing/untypeast.cmi \
     typing/types.cmi typing/typedtreeIter.cmi typing/typedtree.cmi \
     typing/subst.cmi typing/predef.cmi typing/path.cmi parsing/parsetree.cmi \
     utils/misc.cmi parsing/longident.cmi parsing/location.cmi \
-    typing/ident.cmi typing/env.cmi typing/ctype.cmi typing/btype.cmi \
-    parsing/asttypes.cmi parsing/ast_helper.cmi typing/parmatch.cmi
+    typing/ident.cmi typing/env.cmi typing/ctype.cmi utils/config.cmi \
+    typing/btype.cmi parsing/asttypes.cmi parsing/ast_helper.cmi \
+    typing/parmatch.cmi
 typing/parmatch.cmx : utils/warnings.cmx typing/untypeast.cmx \
     typing/types.cmx typing/typedtreeIter.cmx typing/typedtree.cmx \
     typing/subst.cmx typing/predef.cmx typing/path.cmx parsing/parsetree.cmi \
     utils/misc.cmx parsing/longident.cmx parsing/location.cmx \
-    typing/ident.cmx typing/env.cmx typing/ctype.cmx typing/btype.cmx \
-    parsing/asttypes.cmi parsing/ast_helper.cmx typing/parmatch.cmi
+    typing/ident.cmx typing/env.cmx typing/ctype.cmx utils/config.cmx \
+    typing/btype.cmx parsing/asttypes.cmi parsing/ast_helper.cmx \
+    typing/parmatch.cmi
 typing/parmatch.cmi : typing/types.cmi typing/typedtree.cmi \
     parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \
     typing/env.cmi parsing/asttypes.cmi
@@ -284,12 +286,12 @@ typing/predef.cmx : typing/types.cmx typing/path.cmx parsing/parsetree.cmi \
     parsing/location.cmx typing/ident.cmx typing/btype.cmx \
     parsing/asttypes.cmi typing/predef.cmi
 typing/predef.cmi : typing/types.cmi typing/path.cmi typing/ident.cmi
-typing/primitive.cmo : utils/warnings.cmi parsing/parsetree.cmi \
-    typing/outcometree.cmi utils/misc.cmi parsing/location.cmi \
-    parsing/attr_helper.cmi typing/primitive.cmi
-typing/primitive.cmx : utils/warnings.cmx parsing/parsetree.cmi \
-    typing/outcometree.cmi utils/misc.cmx parsing/location.cmx \
-    parsing/attr_helper.cmx typing/primitive.cmi
+typing/primitive.cmo : parsing/parsetree.cmi typing/outcometree.cmi \
+    utils/misc.cmi parsing/location.cmi parsing/attr_helper.cmi \
+    typing/primitive.cmi
+typing/primitive.cmx : parsing/parsetree.cmi typing/outcometree.cmi \
+    utils/misc.cmx parsing/location.cmx parsing/attr_helper.cmx \
+    typing/primitive.cmi
 typing/primitive.cmi : parsing/parsetree.cmi typing/outcometree.cmi \
     parsing/location.cmi
 typing/printtyp.cmo : typing/types.cmi typing/primitive.cmi \
@@ -309,16 +311,18 @@ typing/printtyp.cmx : typing/types.cmx typing/primitive.cmx \
 typing/printtyp.cmi : typing/types.cmi typing/path.cmi \
     typing/outcometree.cmi parsing/longident.cmi typing/ident.cmi \
     typing/env.cmi parsing/asttypes.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
-typing/printtyped.cmx : typing/typedtree.cmx parsing/printast.cmx \
-    typing/path.cmx utils/misc.cmx parsing/longident.cmx parsing/location.cmx \
-    typing/ident.cmx parsing/asttypes.cmi typing/printtyped.cmi
+typing/printtyped.cmo : typing/types.cmi 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
+typing/printtyped.cmx : typing/types.cmx typing/typedtree.cmx \
+    parsing/printast.cmx typing/path.cmx utils/misc.cmx parsing/longident.cmx \
+    parsing/location.cmx typing/ident.cmx parsing/asttypes.cmi \
+    typing/printtyped.cmi
 typing/printtyped.cmi : typing/typedtree.cmi
-typing/stypes.cmo : typing/typedtree.cmi typing/printtyp.cmi \
+typing/stypes.cmo : typing/typedtree.cmi typing/printtyp.cmi utils/misc.cmi \
     parsing/location.cmi utils/clflags.cmi typing/annot.cmi typing/stypes.cmi
-typing/stypes.cmx : typing/typedtree.cmx typing/printtyp.cmx \
+typing/stypes.cmx : typing/typedtree.cmx typing/printtyp.cmx utils/misc.cmx \
     parsing/location.cmx utils/clflags.cmx typing/annot.cmi typing/stypes.cmi
 typing/stypes.cmi : typing/typedtree.cmi parsing/location.cmi \
     typing/annot.cmi
@@ -357,25 +361,25 @@ 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
 typing/typecore.cmo : utils/warnings.cmi typing/typetexp.cmi \
-    typing/types.cmi typing/typedtree.cmi typing/typedecl.cmi \
-    typing/subst.cmi typing/stypes.cmi typing/printtyp.cmi \
-    typing/primitive.cmi typing/predef.cmi typing/path.cmi \
-    parsing/parsetree.cmi typing/parmatch.cmi typing/oprint.cmi \
-    utils/misc.cmi parsing/longident.cmi parsing/location.cmi \
-    typing/ident.cmi typing/env.cmi typing/ctype.cmi typing/cmt_format.cmi \
-    utils/clflags.cmi parsing/builtin_attributes.cmi typing/btype.cmi \
-    parsing/asttypes.cmi parsing/ast_helper.cmi typing/annot.cmi \
-    typing/typecore.cmi
+    typing/types.cmi typing/typeopt.cmi typing/typedtree.cmi \
+    typing/typedecl.cmi typing/subst.cmi typing/stypes.cmi \
+    typing/printtyp.cmi typing/primitive.cmi typing/predef.cmi \
+    typing/path.cmi parsing/parsetree.cmi typing/parmatch.cmi \
+    typing/oprint.cmi utils/misc.cmi parsing/longident.cmi \
+    parsing/location.cmi typing/ident.cmi typing/env.cmi typing/ctype.cmi \
+    typing/cmt_format.cmi utils/clflags.cmi parsing/builtin_attributes.cmi \
+    typing/btype.cmi parsing/asttypes.cmi parsing/ast_helper.cmi \
+    typing/annot.cmi typing/typecore.cmi
 typing/typecore.cmx : utils/warnings.cmx typing/typetexp.cmx \
-    typing/types.cmx typing/typedtree.cmx typing/typedecl.cmx \
-    typing/subst.cmx typing/stypes.cmx typing/printtyp.cmx \
-    typing/primitive.cmx typing/predef.cmx typing/path.cmx \
-    parsing/parsetree.cmi typing/parmatch.cmx typing/oprint.cmx \
-    utils/misc.cmx parsing/longident.cmx parsing/location.cmx \
-    typing/ident.cmx typing/env.cmx typing/ctype.cmx typing/cmt_format.cmx \
-    utils/clflags.cmx parsing/builtin_attributes.cmx typing/btype.cmx \
-    parsing/asttypes.cmi parsing/ast_helper.cmx typing/annot.cmi \
-    typing/typecore.cmi
+    typing/types.cmx typing/typeopt.cmx typing/typedtree.cmx \
+    typing/typedecl.cmx typing/subst.cmx typing/stypes.cmx \
+    typing/printtyp.cmx typing/primitive.cmx typing/predef.cmx \
+    typing/path.cmx parsing/parsetree.cmi typing/parmatch.cmx \
+    typing/oprint.cmx utils/misc.cmx parsing/longident.cmx \
+    parsing/location.cmx typing/ident.cmx typing/env.cmx typing/ctype.cmx \
+    typing/cmt_format.cmx utils/clflags.cmx parsing/builtin_attributes.cmx \
+    typing/btype.cmx parsing/asttypes.cmi parsing/ast_helper.cmx \
+    typing/annot.cmi typing/typecore.cmi
 typing/typecore.cmi : typing/types.cmi typing/typedtree.cmi typing/path.cmi \
     parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \
     typing/ident.cmi typing/env.cmi parsing/asttypes.cmi typing/annot.cmi
@@ -430,8 +434,7 @@ typing/typemod.cmo : utils/warnings.cmi typing/typetexp.cmi typing/types.cmi \
     parsing/location.cmi typing/includemod.cmi typing/ident.cmi \
     typing/env.cmi typing/ctype.cmi utils/config.cmi typing/cmt_format.cmi \
     typing/cmi_format.cmi utils/clflags.cmi parsing/builtin_attributes.cmi \
-    typing/btype.cmi parsing/asttypes.cmi parsing/ast_iterator.cmi \
-    typing/annot.cmi typing/typemod.cmi
+    typing/btype.cmi parsing/asttypes.cmi typing/annot.cmi typing/typemod.cmi
 typing/typemod.cmx : utils/warnings.cmx typing/typetexp.cmx typing/types.cmx \
     typing/typedtree.cmx typing/typedecl.cmx typing/typecore.cmx \
     typing/typeclass.cmx typing/subst.cmx typing/stypes.cmx \
@@ -440,12 +443,21 @@ typing/typemod.cmx : utils/warnings.cmx typing/typetexp.cmx typing/types.cmx \
     parsing/location.cmx typing/includemod.cmx typing/ident.cmx \
     typing/env.cmx typing/ctype.cmx utils/config.cmx typing/cmt_format.cmx \
     typing/cmi_format.cmx utils/clflags.cmx parsing/builtin_attributes.cmx \
-    typing/btype.cmx parsing/asttypes.cmi parsing/ast_iterator.cmx \
-    typing/annot.cmi typing/typemod.cmi
+    typing/btype.cmx parsing/asttypes.cmi typing/annot.cmi typing/typemod.cmi
 typing/typemod.cmi : typing/types.cmi typing/typedtree.cmi typing/path.cmi \
     parsing/parsetree.cmi utils/misc.cmi parsing/longident.cmi \
     parsing/location.cmi typing/includemod.cmi typing/ident.cmi \
     typing/env.cmi typing/cmi_format.cmi parsing/asttypes.cmi
+typing/typeopt.cmo : typing/types.cmi typing/typedtree.cmi \
+    typing/typedecl.cmi typing/predef.cmi typing/path.cmi bytecomp/lambda.cmi \
+    typing/ident.cmi typing/env.cmi typing/ctype.cmi utils/config.cmi \
+    parsing/asttypes.cmi typing/typeopt.cmi
+typing/typeopt.cmx : typing/types.cmx typing/typedtree.cmx \
+    typing/typedecl.cmx typing/predef.cmx typing/path.cmx bytecomp/lambda.cmx \
+    typing/ident.cmx typing/env.cmx typing/ctype.cmx utils/config.cmx \
+    parsing/asttypes.cmi typing/typeopt.cmi
+typing/typeopt.cmi : typing/types.cmi typing/typedtree.cmi typing/path.cmi \
+    bytecomp/lambda.cmi typing/env.cmi
 typing/types.cmo : typing/primitive.cmi typing/path.cmi \
     parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \
     typing/ident.cmi parsing/asttypes.cmi typing/types.cmi
@@ -455,20 +467,18 @@ typing/types.cmx : typing/primitive.cmx typing/path.cmx \
 typing/types.cmi : typing/primitive.cmi typing/path.cmi \
     parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \
     typing/ident.cmi parsing/asttypes.cmi
-typing/typetexp.cmo : utils/warnings.cmi typing/types.cmi \
-    typing/typedtree.cmi utils/tbl.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 parsing/builtin_attributes.cmi \
-    typing/btype.cmi parsing/asttypes.cmi parsing/ast_helper.cmi \
-    typing/typetexp.cmi
-typing/typetexp.cmx : utils/warnings.cmx typing/types.cmx \
-    typing/typedtree.cmx utils/tbl.cmx typing/printtyp.cmx typing/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 parsing/builtin_attributes.cmx \
-    typing/btype.cmx parsing/asttypes.cmi parsing/ast_helper.cmx \
-    typing/typetexp.cmi
+typing/typetexp.cmo : typing/types.cmi typing/typedtree.cmi utils/tbl.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 \
+    parsing/builtin_attributes.cmi typing/btype.cmi parsing/asttypes.cmi \
+    parsing/ast_helper.cmi typing/typetexp.cmi
+typing/typetexp.cmx : typing/types.cmx typing/typedtree.cmx utils/tbl.cmx \
+    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 \
+    parsing/builtin_attributes.cmx typing/btype.cmx parsing/asttypes.cmi \
+    parsing/ast_helper.cmx typing/typetexp.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
@@ -493,24 +503,24 @@ bytecomp/bytegen.cmx : typing/types.cmx bytecomp/switch.cmx typing/subst.cmx \
     utils/config.cmx parsing/asttypes.cmi bytecomp/bytegen.cmi
 bytecomp/bytegen.cmi : bytecomp/lambda.cmi bytecomp/instruct.cmi
 bytecomp/bytelibrarian.cmo : utils/misc.cmi parsing/location.cmi \
-    utils/config.cmi bytecomp/cmo_format.cmi utils/clflags.cmi \
-    bytecomp/bytelink.cmi bytecomp/bytelibrarian.cmi
+    bytecomp/emitcode.cmi utils/config.cmi bytecomp/cmo_format.cmi \
+    utils/clflags.cmi bytecomp/bytelink.cmi bytecomp/bytelibrarian.cmi
 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/emitcode.cmx utils/config.cmx bytecomp/cmo_format.cmi \
+    utils/clflags.cmx bytecomp/bytelink.cmx bytecomp/bytelibrarian.cmi
 bytecomp/bytelibrarian.cmi :
 bytecomp/bytelink.cmo : utils/warnings.cmi bytecomp/symtable.cmi \
     bytecomp/opcodes.cmo utils/misc.cmi parsing/location.cmi \
     bytecomp/lambda.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/emitcode.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 \
     bytecomp/lambda.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/emitcode.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/bytelink.cmi : bytecomp/symtable.cmi bytecomp/cmo_format.cmi
 bytecomp/bytepackager.cmo : typing/typemod.cmi bytecomp/translmod.cmi \
     typing/subst.cmi bytecomp/printlambda.cmi typing/path.cmi utils/misc.cmi \
@@ -562,14 +572,14 @@ bytecomp/lambda.cmx : typing/types.cmx typing/primitive.cmx typing/path.cmx \
     parsing/asttypes.cmi bytecomp/lambda.cmi
 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.cmo : typing/types.cmi bytecomp/typeopt.cmi \
+bytecomp/matching.cmo : typing/types.cmi typing/typeopt.cmi \
     typing/typedtree.cmi bytecomp/switch.cmi bytecomp/printlambda.cmi \
     typing/primitive.cmi typing/predef.cmi typing/path.cmi \
     typing/parmatch.cmi utils/misc.cmi parsing/longident.cmi \
     parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi \
     utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi \
     bytecomp/matching.cmi
-bytecomp/matching.cmx : typing/types.cmx bytecomp/typeopt.cmx \
+bytecomp/matching.cmx : typing/types.cmx typing/typeopt.cmx \
     typing/typedtree.cmx bytecomp/switch.cmx bytecomp/printlambda.cmx \
     typing/primitive.cmx typing/predef.cmx typing/path.cmx \
     typing/parmatch.cmx utils/misc.cmx parsing/longident.cmx \
@@ -615,9 +625,9 @@ bytecomp/simplif.cmx : utils/warnings.cmx utils/tbl.cmx typing/stypes.cmx \
     bytecomp/simplif.cmi
 bytecomp/simplif.cmi : utils/misc.cmi parsing/location.cmi \
     bytecomp/lambda.cmi typing/ident.cmi
-bytecomp/switch.cmo : bytecomp/switch.cmi
-bytecomp/switch.cmx : bytecomp/switch.cmi
-bytecomp/switch.cmi :
+bytecomp/switch.cmo : parsing/location.cmi bytecomp/switch.cmi
+bytecomp/switch.cmx : parsing/location.cmx bytecomp/switch.cmi
+bytecomp/switch.cmi : parsing/location.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 utils/config.cmi \
@@ -640,26 +650,26 @@ bytecomp/translattribute.cmx : utils/warnings.cmx typing/typedtree.cmx \
     bytecomp/translattribute.cmi
 bytecomp/translattribute.cmi : typing/typedtree.cmi parsing/parsetree.cmi \
     parsing/location.cmi bytecomp/lambda.cmi
-bytecomp/translclass.cmo : typing/types.cmi bytecomp/typeopt.cmi \
+bytecomp/translclass.cmo : typing/types.cmi typing/typeopt.cmi \
     typing/typedtree.cmi bytecomp/translobj.cmi bytecomp/translcore.cmi \
     typing/path.cmi bytecomp/matching.cmi parsing/location.cmi \
     bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi utils/clflags.cmi \
     typing/btype.cmi parsing/asttypes.cmi bytecomp/translclass.cmi
-bytecomp/translclass.cmx : typing/types.cmx bytecomp/typeopt.cmx \
+bytecomp/translclass.cmx : typing/types.cmx typing/typeopt.cmx \
     typing/typedtree.cmx bytecomp/translobj.cmx bytecomp/translcore.cmx \
     typing/path.cmx bytecomp/matching.cmx parsing/location.cmx \
     bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx utils/clflags.cmx \
     typing/btype.cmx parsing/asttypes.cmi bytecomp/translclass.cmi
 bytecomp/translclass.cmi : typing/typedtree.cmi parsing/location.cmi \
     bytecomp/lambda.cmi typing/ident.cmi parsing/asttypes.cmi
-bytecomp/translcore.cmo : typing/types.cmi bytecomp/typeopt.cmi \
+bytecomp/translcore.cmo : typing/types.cmi typing/typeopt.cmi \
     typing/typedtree.cmi typing/typecore.cmi bytecomp/translobj.cmi \
     bytecomp/translattribute.cmi typing/primitive.cmi typing/predef.cmi \
     typing/path.cmi typing/parmatch.cmi utils/misc.cmi bytecomp/matching.cmi \
     parsing/longident.cmi parsing/location.cmi bytecomp/lambda.cmi \
     typing/ident.cmi typing/env.cmi utils/config.cmi utils/clflags.cmi \
     typing/btype.cmi parsing/asttypes.cmi bytecomp/translcore.cmi
-bytecomp/translcore.cmx : typing/types.cmx bytecomp/typeopt.cmx \
+bytecomp/translcore.cmx : typing/types.cmx typing/typeopt.cmx \
     typing/typedtree.cmx typing/typecore.cmx bytecomp/translobj.cmx \
     bytecomp/translattribute.cmx typing/primitive.cmx typing/predef.cmx \
     typing/path.cmx typing/parmatch.cmx utils/misc.cmx bytecomp/matching.cmx \
@@ -694,14 +704,6 @@ bytecomp/translobj.cmx : typing/primitive.cmx utils/misc.cmx \
     typing/ident.cmx typing/env.cmx utils/config.cmx utils/clflags.cmx \
     typing/btype.cmx parsing/asttypes.cmi bytecomp/translobj.cmi
 bytecomp/translobj.cmi : bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi
-bytecomp/typeopt.cmo : typing/types.cmi typing/typedtree.cmi \
-    typing/typedecl.cmi typing/predef.cmi typing/path.cmi bytecomp/lambda.cmi \
-    typing/ident.cmi typing/env.cmi typing/ctype.cmi bytecomp/typeopt.cmi
-bytecomp/typeopt.cmx : typing/types.cmx typing/typedtree.cmx \
-    typing/typedecl.cmx typing/predef.cmx typing/path.cmx bytecomp/lambda.cmx \
-    typing/ident.cmx typing/env.cmx typing/ctype.cmx bytecomp/typeopt.cmi
-bytecomp/typeopt.cmi : typing/types.cmi typing/typedtree.cmi typing/path.cmi \
-    bytecomp/lambda.cmi typing/env.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 \
@@ -719,34 +721,38 @@ asmcomp/afl_instrument.cmi : asmcomp/cmm.cmi
 asmcomp/arch.cmo : utils/config.cmi utils/clflags.cmi
 asmcomp/arch.cmx : utils/config.cmx utils/clflags.cmx
 asmcomp/asmgen.cmo : asmcomp/un_anf.cmi bytecomp/translmod.cmi \
-    utils/timings.cmi middle_end/base_types/symbol.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 \
+    middle_end/base_types/symbol.cmi asmcomp/split.cmi asmcomp/spill.cmi \
+    asmcomp/selection.cmi asmcomp/scheduling.cmi asmcomp/reload.cmi \
+    asmcomp/reg.cmi utils/profile.cmi asmcomp/proc.cmi asmcomp/printmach.cmi \
     asmcomp/printlinear.cmi asmcomp/printcmm.cmi asmcomp/printclambda.cmi \
     typing/primitive.cmi utils/misc.cmi asmcomp/mach.cmi parsing/location.cmi \
-    asmcomp/liveness.cmi middle_end/base_types/linkage_name.cmi \
-    asmcomp/linearize.cmi bytecomp/lambda.cmi asmcomp/interf.cmi \
+    asmcomp/liveness.cmi asmcomp/linscan.cmi \
+    middle_end/base_types/linkage_name.cmi asmcomp/linearize.cmi \
+    bytecomp/lambda.cmi asmcomp/interval.cmi asmcomp/interf.cmi \
     typing/ident.cmi asmcomp/flambda_to_clambda.cmi middle_end/flambda.cmi \
     asmcomp/emitaux.cmi asmcomp/emit.cmi asmcomp/deadcode.cmi \
     utils/config.cmi asmcomp/compilenv.cmi asmcomp/comballoc.cmi \
     asmcomp/coloring.cmi asmcomp/cmmgen.cmi asmcomp/cmm.cmi \
     asmcomp/closure.cmi utils/clflags.cmi asmcomp/clambda.cmi asmcomp/CSE.cmo \
-    asmcomp/build_export_info.cmi asmcomp/asmgen.cmi
+    asmcomp/build_export_info.cmi asmcomp/debug/available_regs.cmi \
+    asmcomp/asmgen.cmi
 asmcomp/asmgen.cmx : asmcomp/un_anf.cmx bytecomp/translmod.cmx \
-    utils/timings.cmx middle_end/base_types/symbol.cmx asmcomp/split.cmx \
-    asmcomp/spill.cmx asmcomp/selection.cmx asmcomp/scheduling.cmx \
-    asmcomp/reload.cmx asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/printmach.cmx \
+    middle_end/base_types/symbol.cmx asmcomp/split.cmx asmcomp/spill.cmx \
+    asmcomp/selection.cmx asmcomp/scheduling.cmx asmcomp/reload.cmx \
+    asmcomp/reg.cmx utils/profile.cmx asmcomp/proc.cmx asmcomp/printmach.cmx \
     asmcomp/printlinear.cmx asmcomp/printcmm.cmx asmcomp/printclambda.cmx \
     typing/primitive.cmx utils/misc.cmx asmcomp/mach.cmx parsing/location.cmx \
-    asmcomp/liveness.cmx middle_end/base_types/linkage_name.cmx \
-    asmcomp/linearize.cmx bytecomp/lambda.cmx asmcomp/interf.cmx \
+    asmcomp/liveness.cmx asmcomp/linscan.cmx \
+    middle_end/base_types/linkage_name.cmx asmcomp/linearize.cmx \
+    bytecomp/lambda.cmx asmcomp/interval.cmx asmcomp/interf.cmx \
     typing/ident.cmx asmcomp/flambda_to_clambda.cmx middle_end/flambda.cmx \
     asmcomp/emitaux.cmx asmcomp/emit.cmx asmcomp/deadcode.cmx \
     utils/config.cmx asmcomp/compilenv.cmx asmcomp/comballoc.cmx \
     asmcomp/coloring.cmx asmcomp/cmmgen.cmx asmcomp/cmm.cmx \
     asmcomp/closure.cmx utils/clflags.cmx asmcomp/clambda.cmx asmcomp/CSE.cmx \
-    asmcomp/build_export_info.cmx asmcomp/asmgen.cmi
-asmcomp/asmgen.cmi : utils/timings.cmi bytecomp/lambda.cmi typing/ident.cmi \
+    asmcomp/build_export_info.cmx asmcomp/debug/available_regs.cmx \
+    asmcomp/asmgen.cmi
+asmcomp/asmgen.cmi : bytecomp/lambda.cmi typing/ident.cmi \
     middle_end/flambda.cmi asmcomp/cmm.cmi middle_end/backend_intf.cmi
 asmcomp/asmlibrarian.cmo : utils/misc.cmi parsing/location.cmi \
     asmcomp/export_info.cmi utils/config.cmi asmcomp/compilenv.cmi \
@@ -757,19 +763,19 @@ asmcomp/asmlibrarian.cmx : utils/misc.cmx parsing/location.cmx \
     asmcomp/cmx_format.cmi utils/clflags.cmx asmcomp/clambda.cmx \
     utils/ccomp.cmx asmcomp/asmlink.cmx asmcomp/asmlibrarian.cmi
 asmcomp/asmlibrarian.cmi :
-asmcomp/asmlink.cmo : utils/timings.cmi bytecomp/runtimedef.cmi \
+asmcomp/asmlink.cmo : bytecomp/runtimedef.cmi utils/profile.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 : utils/timings.cmx bytecomp/runtimedef.cmx \
+asmcomp/asmlink.cmx : bytecomp/runtimedef.cmx utils/profile.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
 asmcomp/asmlink.cmi : asmcomp/cmx_format.cmi
 asmcomp/asmpackager.cmo : typing/typemod.cmi bytecomp/translmod.cmi \
-    utils/timings.cmi utils/misc.cmi middle_end/middle_end.cmi \
+    utils/profile.cmi utils/misc.cmi middle_end/middle_end.cmi \
     parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi \
     asmcomp/export_info_for_pack.cmi asmcomp/export_info.cmi typing/env.cmi \
     utils/config.cmi asmcomp/compilenv.cmi \
@@ -777,7 +783,7 @@ asmcomp/asmpackager.cmo : typing/typemod.cmi bytecomp/translmod.cmi \
     utils/clflags.cmi utils/ccomp.cmi asmcomp/asmlink.cmi asmcomp/asmgen.cmi \
     asmcomp/asmpackager.cmi
 asmcomp/asmpackager.cmx : typing/typemod.cmx bytecomp/translmod.cmx \
-    utils/timings.cmx utils/misc.cmx middle_end/middle_end.cmx \
+    utils/profile.cmx utils/misc.cmx middle_end/middle_end.cmx \
     parsing/location.cmx bytecomp/lambda.cmx typing/ident.cmx \
     asmcomp/export_info_for_pack.cmx asmcomp/export_info.cmx typing/env.cmx \
     utils/config.cmx asmcomp/compilenv.cmx \
@@ -901,7 +907,7 @@ asmcomp/compilenv.cmx : utils/warnings.cmx middle_end/base_types/symbol.cmx \
     middle_end/base_types/compilation_unit.cmx asmcomp/cmx_format.cmi \
     middle_end/base_types/closure_id.cmx utils/clflags.cmx \
     asmcomp/clambda.cmx asmcomp/compilenv.cmi
-asmcomp/compilenv.cmi : utils/timings.cmi middle_end/base_types/symbol.cmi \
+asmcomp/compilenv.cmi : middle_end/base_types/symbol.cmi \
     middle_end/base_types/set_of_closures_id.cmi \
     middle_end/base_types/linkage_name.cmi typing/ident.cmi \
     middle_end/flambda.cmi asmcomp/export_info.cmi \
@@ -981,8 +987,9 @@ asmcomp/flambda_to_clambda.cmo : middle_end/base_types/variable.cmi \
     middle_end/base_types/tag.cmi middle_end/base_types/symbol.cmi \
     middle_end/base_types/static_exception.cmi \
     middle_end/base_types/set_of_closures_id.cmi typing/primitive.cmi \
-    utils/numbers.cmi middle_end/base_types/mutable_variable.cmi \
-    utils/misc.cmi middle_end/base_types/linkage_name.cmi typing/ident.cmi \
+    middle_end/parameter.cmi utils/numbers.cmi \
+    middle_end/base_types/mutable_variable.cmi utils/misc.cmi \
+    middle_end/base_types/linkage_name.cmi typing/ident.cmi \
     middle_end/flambda_utils.cmi middle_end/flambda.cmi \
     asmcomp/export_info.cmi middle_end/debuginfo.cmi asmcomp/compilenv.cmi \
     asmcomp/closure_offsets.cmi middle_end/base_types/closure_id.cmi \
@@ -993,8 +1000,9 @@ asmcomp/flambda_to_clambda.cmx : middle_end/base_types/variable.cmx \
     middle_end/base_types/tag.cmx middle_end/base_types/symbol.cmx \
     middle_end/base_types/static_exception.cmx \
     middle_end/base_types/set_of_closures_id.cmx typing/primitive.cmx \
-    utils/numbers.cmx middle_end/base_types/mutable_variable.cmx \
-    utils/misc.cmx middle_end/base_types/linkage_name.cmx typing/ident.cmx \
+    middle_end/parameter.cmx utils/numbers.cmx \
+    middle_end/base_types/mutable_variable.cmx utils/misc.cmx \
+    middle_end/base_types/linkage_name.cmx typing/ident.cmx \
     middle_end/flambda_utils.cmx middle_end/flambda.cmx \
     asmcomp/export_info.cmx middle_end/debuginfo.cmx asmcomp/compilenv.cmx \
     asmcomp/closure_offsets.cmx middle_end/base_types/closure_id.cmx \
@@ -1025,6 +1033,11 @@ asmcomp/interf.cmo : asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/mach.cmi \
 asmcomp/interf.cmx : asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/mach.cmx \
     asmcomp/cmm.cmx asmcomp/interf.cmi
 asmcomp/interf.cmi : asmcomp/mach.cmi
+asmcomp/interval.cmo : asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/mach.cmi \
+    asmcomp/interval.cmi
+asmcomp/interval.cmx : asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/mach.cmx \
+    asmcomp/interval.cmi
+asmcomp/interval.cmi : asmcomp/reg.cmi asmcomp/mach.cmi
 asmcomp/linearize.cmo : asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \
     asmcomp/mach.cmi middle_end/debuginfo.cmi utils/config.cmi \
     asmcomp/cmm.cmi asmcomp/linearize.cmi
@@ -1033,6 +1046,11 @@ asmcomp/linearize.cmx : asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \
     asmcomp/cmm.cmx asmcomp/linearize.cmi
 asmcomp/linearize.cmi : asmcomp/reg.cmi asmcomp/mach.cmi \
     middle_end/debuginfo.cmi asmcomp/cmm.cmi
+asmcomp/linscan.cmo : asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/interval.cmi \
+    asmcomp/linscan.cmi
+asmcomp/linscan.cmx : asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/interval.cmx \
+    asmcomp/linscan.cmi
+asmcomp/linscan.cmi :
 asmcomp/liveness.cmo : asmcomp/reg.cmi asmcomp/proc.cmi \
     asmcomp/printmach.cmi utils/misc.cmi asmcomp/mach.cmi utils/config.cmi \
     asmcomp/cmm.cmi asmcomp/liveness.cmi
@@ -1040,11 +1058,16 @@ asmcomp/liveness.cmx : asmcomp/reg.cmx asmcomp/proc.cmx \
     asmcomp/printmach.cmx utils/misc.cmx asmcomp/mach.cmx utils/config.cmx \
     asmcomp/cmm.cmx asmcomp/liveness.cmi
 asmcomp/liveness.cmi : asmcomp/mach.cmi
-asmcomp/mach.cmo : asmcomp/reg.cmi middle_end/debuginfo.cmi asmcomp/cmm.cmi \
-    asmcomp/arch.cmo asmcomp/mach.cmi
-asmcomp/mach.cmx : asmcomp/reg.cmx middle_end/debuginfo.cmx asmcomp/cmm.cmx \
-    asmcomp/arch.cmx asmcomp/mach.cmi
-asmcomp/mach.cmi : asmcomp/reg.cmi middle_end/debuginfo.cmi asmcomp/cmm.cmi \
+asmcomp/mach.cmo : asmcomp/debug/reg_with_debug_info.cmi \
+    asmcomp/debug/reg_availability_set.cmi asmcomp/reg.cmi typing/ident.cmi \
+    middle_end/debuginfo.cmi asmcomp/cmm.cmi asmcomp/arch.cmo \
+    asmcomp/mach.cmi
+asmcomp/mach.cmx : asmcomp/debug/reg_with_debug_info.cmx \
+    asmcomp/debug/reg_availability_set.cmx asmcomp/reg.cmx typing/ident.cmx \
+    middle_end/debuginfo.cmx asmcomp/cmm.cmx asmcomp/arch.cmx \
+    asmcomp/mach.cmi
+asmcomp/mach.cmi : asmcomp/debug/reg_availability_set.cmi asmcomp/reg.cmi \
+    typing/ident.cmi middle_end/debuginfo.cmi asmcomp/cmm.cmi \
     asmcomp/arch.cmo
 asmcomp/printclambda.cmo : bytecomp/printlambda.cmi bytecomp/lambda.cmi \
     typing/ident.cmi asmcomp/clambda.cmi parsing/asttypes.cmi \
@@ -1067,12 +1090,16 @@ asmcomp/printlinear.cmx : asmcomp/printmach.cmx asmcomp/printcmm.cmx \
     asmcomp/mach.cmx asmcomp/linearize.cmx middle_end/debuginfo.cmx \
     asmcomp/printlinear.cmi
 asmcomp/printlinear.cmi : asmcomp/linearize.cmi
-asmcomp/printmach.cmo : asmcomp/reg.cmi asmcomp/proc.cmi \
-    asmcomp/printcmm.cmi asmcomp/mach.cmi middle_end/debuginfo.cmi \
-    utils/config.cmi asmcomp/cmm.cmi asmcomp/arch.cmo asmcomp/printmach.cmi
-asmcomp/printmach.cmx : asmcomp/reg.cmx asmcomp/proc.cmx \
-    asmcomp/printcmm.cmx asmcomp/mach.cmx middle_end/debuginfo.cmx \
-    utils/config.cmx asmcomp/cmm.cmx asmcomp/arch.cmx asmcomp/printmach.cmi
+asmcomp/printmach.cmo : asmcomp/debug/reg_availability_set.cmi \
+    asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/printcmm.cmi asmcomp/mach.cmi \
+    asmcomp/interval.cmi typing/ident.cmi middle_end/debuginfo.cmi \
+    utils/config.cmi asmcomp/cmm.cmi utils/clflags.cmi asmcomp/arch.cmo \
+    asmcomp/printmach.cmi
+asmcomp/printmach.cmx : asmcomp/debug/reg_availability_set.cmx \
+    asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/printcmm.cmx asmcomp/mach.cmx \
+    asmcomp/interval.cmx typing/ident.cmx middle_end/debuginfo.cmx \
+    utils/config.cmx asmcomp/cmm.cmx utils/clflags.cmx asmcomp/arch.cmx \
+    asmcomp/printmach.cmi
 asmcomp/printmach.cmi : asmcomp/reg.cmi asmcomp/mach.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 \
@@ -1133,22 +1160,23 @@ asmcomp/spacetime_profiling.cmx : asmcomp/selectgen.cmx asmcomp/proc.cmx \
     parsing/asttypes.cmi asmcomp/arch.cmx asmcomp/spacetime_profiling.cmi
 asmcomp/spacetime_profiling.cmi : asmcomp/selectgen.cmi
 asmcomp/spill.cmo : asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \
-    asmcomp/mach.cmi asmcomp/cmm.cmi asmcomp/spill.cmi
+    asmcomp/mach.cmi asmcomp/cmm.cmi utils/clflags.cmi asmcomp/spill.cmi
 asmcomp/spill.cmx : asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \
-    asmcomp/mach.cmx asmcomp/cmm.cmx asmcomp/spill.cmi
+    asmcomp/mach.cmx asmcomp/cmm.cmx utils/clflags.cmx asmcomp/spill.cmi
 asmcomp/spill.cmi : asmcomp/mach.cmi
 asmcomp/split.cmo : asmcomp/reg.cmi utils/misc.cmi asmcomp/mach.cmi \
     asmcomp/split.cmi
 asmcomp/split.cmx : asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \
     asmcomp/split.cmi
 asmcomp/split.cmi : asmcomp/mach.cmi
-asmcomp/strmatch.cmo : bytecomp/lambda.cmi typing/ident.cmi \
-    middle_end/debuginfo.cmi asmcomp/cmm.cmi parsing/asttypes.cmi \
-    asmcomp/arch.cmo asmcomp/strmatch.cmi
-asmcomp/strmatch.cmx : bytecomp/lambda.cmx typing/ident.cmx \
-    middle_end/debuginfo.cmx asmcomp/cmm.cmx parsing/asttypes.cmi \
-    asmcomp/arch.cmx asmcomp/strmatch.cmi
-asmcomp/strmatch.cmi : middle_end/debuginfo.cmi asmcomp/cmm.cmi
+asmcomp/strmatch.cmo : parsing/location.cmi bytecomp/lambda.cmi \
+    typing/ident.cmi middle_end/debuginfo.cmi asmcomp/cmm.cmi \
+    parsing/asttypes.cmi asmcomp/arch.cmo asmcomp/strmatch.cmi
+asmcomp/strmatch.cmx : parsing/location.cmx bytecomp/lambda.cmx \
+    typing/ident.cmx middle_end/debuginfo.cmx asmcomp/cmm.cmx \
+    parsing/asttypes.cmi asmcomp/arch.cmx asmcomp/strmatch.cmi
+asmcomp/strmatch.cmi : parsing/location.cmi middle_end/debuginfo.cmi \
+    asmcomp/cmm.cmi
 asmcomp/un_anf.cmo : bytecomp/semantics_of_primitives.cmi \
     asmcomp/printclambda.cmi utils/misc.cmi bytecomp/lambda.cmi \
     typing/ident.cmi middle_end/debuginfo.cmi utils/clflags.cmi \
@@ -1199,19 +1227,21 @@ middle_end/allocated_const.cmo : middle_end/allocated_const.cmi
 middle_end/allocated_const.cmx : middle_end/allocated_const.cmi
 middle_end/allocated_const.cmi :
 middle_end/augment_specialised_args.cmo : middle_end/base_types/variable.cmi \
-    middle_end/projection.cmi middle_end/pass_wrapper.cmi utils/misc.cmi \
-    middle_end/inlining_cost.cmi middle_end/inline_and_simplify_aux.cmi \
-    utils/identifiable.cmi middle_end/flambda_utils.cmi \
-    middle_end/flambda.cmi middle_end/debuginfo.cmi \
-    middle_end/base_types/closure_id.cmi utils/clflags.cmi \
-    middle_end/backend_intf.cmi middle_end/augment_specialised_args.cmi
+    middle_end/projection.cmi middle_end/pass_wrapper.cmi \
+    middle_end/parameter.cmi utils/misc.cmi middle_end/inlining_cost.cmi \
+    middle_end/inline_and_simplify_aux.cmi utils/identifiable.cmi \
+    middle_end/flambda_utils.cmi middle_end/flambda.cmi \
+    middle_end/debuginfo.cmi middle_end/base_types/closure_id.cmi \
+    utils/clflags.cmi middle_end/backend_intf.cmi \
+    middle_end/augment_specialised_args.cmi
 middle_end/augment_specialised_args.cmx : middle_end/base_types/variable.cmx \
-    middle_end/projection.cmx middle_end/pass_wrapper.cmx utils/misc.cmx \
-    middle_end/inlining_cost.cmx middle_end/inline_and_simplify_aux.cmx \
-    utils/identifiable.cmx middle_end/flambda_utils.cmx \
-    middle_end/flambda.cmx middle_end/debuginfo.cmx \
-    middle_end/base_types/closure_id.cmx utils/clflags.cmx \
-    middle_end/backend_intf.cmi middle_end/augment_specialised_args.cmi
+    middle_end/projection.cmx middle_end/pass_wrapper.cmx \
+    middle_end/parameter.cmx utils/misc.cmx middle_end/inlining_cost.cmx \
+    middle_end/inline_and_simplify_aux.cmx utils/identifiable.cmx \
+    middle_end/flambda_utils.cmx middle_end/flambda.cmx \
+    middle_end/debuginfo.cmx middle_end/base_types/closure_id.cmx \
+    utils/clflags.cmx middle_end/backend_intf.cmi \
+    middle_end/augment_specialised_args.cmi
 middle_end/augment_specialised_args.cmi : middle_end/base_types/variable.cmi \
     middle_end/projection.cmi middle_end/inlining_cost.cmi \
     middle_end/inline_and_simplify_aux.cmi middle_end/flambda.cmi
@@ -1221,12 +1251,12 @@ middle_end/backend_intf.cmi : middle_end/base_types/symbol.cmi \
 middle_end/closure_conversion.cmo : middle_end/base_types/variable.cmi \
     middle_end/base_types/tag.cmi middle_end/base_types/symbol.cmi \
     middle_end/base_types/static_exception.cmi bytecomp/simplif.cmi \
-    bytecomp/printlambda.cmi typing/predef.cmi utils/numbers.cmi \
-    middle_end/base_types/mutable_variable.cmi utils/misc.cmi \
-    parsing/location.cmi middle_end/base_types/linkage_name.cmi \
-    middle_end/lift_code.cmi bytecomp/lambda.cmi typing/ident.cmi \
-    middle_end/flambda_utils.cmi middle_end/flambda.cmi \
-    middle_end/debuginfo.cmi utils/config.cmi \
+    bytecomp/printlambda.cmi typing/predef.cmi middle_end/parameter.cmi \
+    utils/numbers.cmi middle_end/base_types/mutable_variable.cmi \
+    utils/misc.cmi parsing/location.cmi \
+    middle_end/base_types/linkage_name.cmi middle_end/lift_code.cmi \
+    bytecomp/lambda.cmi typing/ident.cmi middle_end/flambda_utils.cmi \
+    middle_end/flambda.cmi middle_end/debuginfo.cmi utils/config.cmi \
     middle_end/base_types/compilation_unit.cmi \
     middle_end/base_types/closure_id.cmi \
     middle_end/closure_conversion_aux.cmi utils/clflags.cmi \
@@ -1234,12 +1264,12 @@ middle_end/closure_conversion.cmo : middle_end/base_types/variable.cmi \
 middle_end/closure_conversion.cmx : middle_end/base_types/variable.cmx \
     middle_end/base_types/tag.cmx middle_end/base_types/symbol.cmx \
     middle_end/base_types/static_exception.cmx bytecomp/simplif.cmx \
-    bytecomp/printlambda.cmx typing/predef.cmx utils/numbers.cmx \
-    middle_end/base_types/mutable_variable.cmx utils/misc.cmx \
-    parsing/location.cmx middle_end/base_types/linkage_name.cmx \
-    middle_end/lift_code.cmx bytecomp/lambda.cmx typing/ident.cmx \
-    middle_end/flambda_utils.cmx middle_end/flambda.cmx \
-    middle_end/debuginfo.cmx utils/config.cmx \
+    bytecomp/printlambda.cmx typing/predef.cmx middle_end/parameter.cmx \
+    utils/numbers.cmx middle_end/base_types/mutable_variable.cmx \
+    utils/misc.cmx parsing/location.cmx \
+    middle_end/base_types/linkage_name.cmx middle_end/lift_code.cmx \
+    bytecomp/lambda.cmx typing/ident.cmx middle_end/flambda_utils.cmx \
+    middle_end/flambda.cmx middle_end/debuginfo.cmx utils/config.cmx \
     middle_end/base_types/compilation_unit.cmx \
     middle_end/base_types/closure_id.cmx \
     middle_end/closure_conversion_aux.cmx utils/clflags.cmx \
@@ -1301,7 +1331,7 @@ middle_end/flambda.cmo : middle_end/base_types/variable.cmi \
     middle_end/base_types/static_exception.cmi \
     middle_end/base_types/set_of_closures_origin.cmi \
     middle_end/base_types/set_of_closures_id.cmi middle_end/projection.cmi \
-    bytecomp/printlambda.cmi utils/numbers.cmi \
+    bytecomp/printlambda.cmi middle_end/parameter.cmi utils/numbers.cmi \
     middle_end/base_types/mutable_variable.cmi utils/misc.cmi \
     bytecomp/lambda.cmi utils/identifiable.cmi middle_end/debuginfo.cmi \
     middle_end/base_types/compilation_unit.cmi \
@@ -1313,7 +1343,7 @@ middle_end/flambda.cmx : middle_end/base_types/variable.cmx \
     middle_end/base_types/static_exception.cmx \
     middle_end/base_types/set_of_closures_origin.cmx \
     middle_end/base_types/set_of_closures_id.cmx middle_end/projection.cmx \
-    bytecomp/printlambda.cmx utils/numbers.cmx \
+    bytecomp/printlambda.cmx middle_end/parameter.cmx utils/numbers.cmx \
     middle_end/base_types/mutable_variable.cmx utils/misc.cmx \
     bytecomp/lambda.cmx utils/identifiable.cmx middle_end/debuginfo.cmx \
     middle_end/base_types/compilation_unit.cmx \
@@ -1325,8 +1355,9 @@ middle_end/flambda.cmi : middle_end/base_types/variable.cmi \
     middle_end/base_types/static_exception.cmi \
     middle_end/base_types/set_of_closures_origin.cmi \
     middle_end/base_types/set_of_closures_id.cmi middle_end/projection.cmi \
-    utils/numbers.cmi middle_end/base_types/mutable_variable.cmi \
-    bytecomp/lambda.cmi utils/identifiable.cmi middle_end/debuginfo.cmi \
+    middle_end/parameter.cmi utils/numbers.cmi \
+    middle_end/base_types/mutable_variable.cmi bytecomp/lambda.cmi \
+    utils/identifiable.cmi middle_end/debuginfo.cmi \
     middle_end/base_types/closure_id.cmi parsing/asttypes.cmi \
     middle_end/allocated_const.cmi
 middle_end/flambda_invariants.cmo : middle_end/base_types/variable.cmi \
@@ -1335,7 +1366,7 @@ middle_end/flambda_invariants.cmo : middle_end/base_types/variable.cmi \
     middle_end/base_types/static_exception.cmi \
     middle_end/base_types/set_of_closures_origin.cmi \
     middle_end/base_types/set_of_closures_id.cmi middle_end/projection.cmi \
-    bytecomp/printlambda.cmi utils/numbers.cmi \
+    bytecomp/printlambda.cmi middle_end/parameter.cmi utils/numbers.cmi \
     middle_end/base_types/mutable_variable.cmi utils/misc.cmi \
     bytecomp/lambda.cmi typing/ident.cmi middle_end/flambda_iterators.cmi \
     middle_end/flambda.cmi middle_end/debuginfo.cmi \
@@ -1348,7 +1379,7 @@ middle_end/flambda_invariants.cmx : middle_end/base_types/variable.cmx \
     middle_end/base_types/static_exception.cmx \
     middle_end/base_types/set_of_closures_origin.cmx \
     middle_end/base_types/set_of_closures_id.cmx middle_end/projection.cmx \
-    bytecomp/printlambda.cmx utils/numbers.cmx \
+    bytecomp/printlambda.cmx middle_end/parameter.cmx utils/numbers.cmx \
     middle_end/base_types/mutable_variable.cmx utils/misc.cmx \
     bytecomp/lambda.cmx typing/ident.cmx middle_end/flambda_iterators.cmx \
     middle_end/flambda.cmx middle_end/debuginfo.cmx \
@@ -1367,10 +1398,10 @@ middle_end/flambda_utils.cmo : middle_end/base_types/variable.cmi \
     middle_end/base_types/symbol.cmi bytecomp/switch.cmi \
     middle_end/base_types/static_exception.cmi \
     middle_end/base_types/set_of_closures_id.cmi middle_end/projection.cmi \
-    middle_end/base_types/mutable_variable.cmi utils/misc.cmi \
-    middle_end/base_types/linkage_name.cmi middle_end/flambda_iterators.cmi \
-    middle_end/flambda.cmi middle_end/debuginfo.cmi \
-    middle_end/base_types/compilation_unit.cmi \
+    middle_end/parameter.cmi middle_end/base_types/mutable_variable.cmi \
+    utils/misc.cmi middle_end/base_types/linkage_name.cmi bytecomp/lambda.cmi \
+    middle_end/flambda_iterators.cmi middle_end/flambda.cmi \
+    middle_end/debuginfo.cmi middle_end/base_types/compilation_unit.cmi \
     middle_end/base_types/closure_id.cmi middle_end/backend_intf.cmi \
     middle_end/allocated_const.cmi middle_end/flambda_utils.cmi
 middle_end/flambda_utils.cmx : middle_end/base_types/variable.cmx \
@@ -1378,10 +1409,10 @@ middle_end/flambda_utils.cmx : middle_end/base_types/variable.cmx \
     middle_end/base_types/symbol.cmx bytecomp/switch.cmx \
     middle_end/base_types/static_exception.cmx \
     middle_end/base_types/set_of_closures_id.cmx middle_end/projection.cmx \
-    middle_end/base_types/mutable_variable.cmx utils/misc.cmx \
-    middle_end/base_types/linkage_name.cmx middle_end/flambda_iterators.cmx \
-    middle_end/flambda.cmx middle_end/debuginfo.cmx \
-    middle_end/base_types/compilation_unit.cmx \
+    middle_end/parameter.cmx middle_end/base_types/mutable_variable.cmx \
+    utils/misc.cmx middle_end/base_types/linkage_name.cmx bytecomp/lambda.cmx \
+    middle_end/flambda_iterators.cmx middle_end/flambda.cmx \
+    middle_end/debuginfo.cmx middle_end/base_types/compilation_unit.cmx \
     middle_end/base_types/closure_id.cmx middle_end/backend_intf.cmi \
     middle_end/allocated_const.cmx middle_end/flambda_utils.cmi
 middle_end/flambda_utils.cmi : middle_end/base_types/variable.cmi \
@@ -1389,22 +1420,22 @@ middle_end/flambda_utils.cmi : middle_end/base_types/variable.cmi \
     middle_end/base_types/tag.cmi middle_end/base_types/symbol.cmi \
     bytecomp/switch.cmi middle_end/base_types/static_exception.cmi \
     middle_end/base_types/set_of_closures_id.cmi middle_end/projection.cmi \
-    middle_end/flambda.cmi middle_end/base_types/closure_id.cmi \
-    middle_end/backend_intf.cmi
+    middle_end/parameter.cmi middle_end/flambda.cmi \
+    middle_end/base_types/closure_id.cmi middle_end/backend_intf.cmi
 middle_end/freshening.cmo : middle_end/base_types/variable.cmi \
     middle_end/base_types/var_within_closure.cmi \
     middle_end/base_types/symbol.cmi \
     middle_end/base_types/static_exception.cmi middle_end/projection.cmi \
-    middle_end/base_types/mutable_variable.cmi utils/misc.cmi \
-    utils/identifiable.cmi middle_end/flambda_utils.cmi \
+    middle_end/parameter.cmi middle_end/base_types/mutable_variable.cmi \
+    utils/misc.cmi utils/identifiable.cmi middle_end/flambda_utils.cmi \
     middle_end/flambda_iterators.cmi middle_end/flambda.cmi \
     middle_end/base_types/closure_id.cmi middle_end/freshening.cmi
 middle_end/freshening.cmx : middle_end/base_types/variable.cmx \
     middle_end/base_types/var_within_closure.cmx \
     middle_end/base_types/symbol.cmx \
     middle_end/base_types/static_exception.cmx middle_end/projection.cmx \
-    middle_end/base_types/mutable_variable.cmx utils/misc.cmx \
-    utils/identifiable.cmx middle_end/flambda_utils.cmx \
+    middle_end/parameter.cmx middle_end/base_types/mutable_variable.cmx \
+    utils/misc.cmx utils/identifiable.cmx middle_end/flambda_utils.cmx \
     middle_end/flambda_iterators.cmx middle_end/flambda.cmx \
     middle_end/base_types/closure_id.cmx middle_end/freshening.cmi
 middle_end/freshening.cmi : middle_end/base_types/variable.cmi \
@@ -1415,18 +1446,18 @@ middle_end/freshening.cmi : middle_end/base_types/variable.cmi \
     middle_end/base_types/closure_id.cmi
 middle_end/inconstant_idents.cmo : middle_end/base_types/variable.cmi \
     middle_end/base_types/symbol.cmi \
-    middle_end/base_types/set_of_closures_id.cmi utils/numbers.cmi \
-    utils/misc.cmi bytecomp/lambda.cmi utils/identifiable.cmi \
-    middle_end/flambda_utils.cmi middle_end/flambda.cmi \
-    middle_end/base_types/compilation_unit.cmi \
+    middle_end/base_types/set_of_closures_id.cmi middle_end/parameter.cmi \
+    utils/numbers.cmi utils/misc.cmi bytecomp/lambda.cmi \
+    utils/identifiable.cmi middle_end/flambda_utils.cmi \
+    middle_end/flambda.cmi middle_end/base_types/compilation_unit.cmi \
     middle_end/base_types/closure_id.cmi middle_end/backend_intf.cmi \
     parsing/asttypes.cmi middle_end/inconstant_idents.cmi
 middle_end/inconstant_idents.cmx : middle_end/base_types/variable.cmx \
     middle_end/base_types/symbol.cmx \
-    middle_end/base_types/set_of_closures_id.cmx utils/numbers.cmx \
-    utils/misc.cmx bytecomp/lambda.cmx utils/identifiable.cmx \
-    middle_end/flambda_utils.cmx middle_end/flambda.cmx \
-    middle_end/base_types/compilation_unit.cmx \
+    middle_end/base_types/set_of_closures_id.cmx middle_end/parameter.cmx \
+    utils/numbers.cmx utils/misc.cmx bytecomp/lambda.cmx \
+    utils/identifiable.cmx middle_end/flambda_utils.cmx \
+    middle_end/flambda.cmx middle_end/base_types/compilation_unit.cmx \
     middle_end/base_types/closure_id.cmx middle_end/backend_intf.cmi \
     parsing/asttypes.cmi middle_end/inconstant_idents.cmi
 middle_end/inconstant_idents.cmi : middle_end/base_types/variable.cmi \
@@ -1449,16 +1480,17 @@ middle_end/inline_and_simplify.cmo : utils/warnings.cmi \
     middle_end/simplify_primitives.cmi middle_end/simple_value_approx.cmi \
     middle_end/remove_unused_arguments.cmi \
     middle_end/remove_free_vars_equal_to_args.cmi middle_end/projection.cmi \
-    typing/predef.cmi utils/misc.cmi parsing/location.cmi \
-    middle_end/lift_code.cmi bytecomp/lambda.cmi \
+    typing/predef.cmi middle_end/parameter.cmi utils/misc.cmi \
+    parsing/location.cmi middle_end/lift_code.cmi bytecomp/lambda.cmi \
     middle_end/invariant_params.cmi middle_end/inlining_stats.cmi \
     middle_end/inlining_decision.cmi middle_end/inlining_cost.cmi \
     middle_end/inline_and_simplify_aux.cmi typing/ident.cmi \
     middle_end/freshening.cmi middle_end/flambda_utils.cmi \
     middle_end/flambda.cmi middle_end/effect_analysis.cmi \
-    middle_end/debuginfo.cmi middle_end/base_types/closure_id.cmi \
-    utils/clflags.cmi middle_end/backend_intf.cmi \
-    middle_end/allocated_const.cmi middle_end/inline_and_simplify.cmi
+    middle_end/debuginfo.cmi utils/config.cmi \
+    middle_end/base_types/closure_id.cmi utils/clflags.cmi \
+    middle_end/backend_intf.cmi middle_end/allocated_const.cmi \
+    middle_end/inline_and_simplify.cmi
 middle_end/inline_and_simplify.cmx : utils/warnings.cmx \
     middle_end/base_types/variable.cmx \
     middle_end/base_types/var_within_closure.cmx \
@@ -1469,16 +1501,17 @@ middle_end/inline_and_simplify.cmx : utils/warnings.cmx \
     middle_end/simplify_primitives.cmx middle_end/simple_value_approx.cmx \
     middle_end/remove_unused_arguments.cmx \
     middle_end/remove_free_vars_equal_to_args.cmx middle_end/projection.cmx \
-    typing/predef.cmx utils/misc.cmx parsing/location.cmx \
-    middle_end/lift_code.cmx bytecomp/lambda.cmx \
+    typing/predef.cmx middle_end/parameter.cmx utils/misc.cmx \
+    parsing/location.cmx middle_end/lift_code.cmx bytecomp/lambda.cmx \
     middle_end/invariant_params.cmx middle_end/inlining_stats.cmx \
     middle_end/inlining_decision.cmx middle_end/inlining_cost.cmx \
     middle_end/inline_and_simplify_aux.cmx typing/ident.cmx \
     middle_end/freshening.cmx middle_end/flambda_utils.cmx \
     middle_end/flambda.cmx middle_end/effect_analysis.cmx \
-    middle_end/debuginfo.cmx middle_end/base_types/closure_id.cmx \
-    utils/clflags.cmx middle_end/backend_intf.cmi \
-    middle_end/allocated_const.cmx middle_end/inline_and_simplify.cmi
+    middle_end/debuginfo.cmx utils/config.cmx \
+    middle_end/base_types/closure_id.cmx utils/clflags.cmx \
+    middle_end/backend_intf.cmi middle_end/allocated_const.cmx \
+    middle_end/inline_and_simplify.cmi
 middle_end/inline_and_simplify.cmi : middle_end/base_types/variable.cmi \
     middle_end/inline_and_simplify_aux.cmi middle_end/flambda.cmi \
     middle_end/backend_intf.cmi
@@ -1488,8 +1521,9 @@ middle_end/inline_and_simplify_aux.cmo : middle_end/base_types/variable.cmi \
     middle_end/base_types/static_exception.cmi \
     middle_end/simple_value_approx.cmi \
     middle_end/base_types/set_of_closures_origin.cmi \
-    middle_end/projection.cmi middle_end/base_types/mutable_variable.cmi \
-    utils/misc.cmi middle_end/inlining_stats.cmi middle_end/inlining_cost.cmi \
+    middle_end/projection.cmi middle_end/parameter.cmi \
+    middle_end/base_types/mutable_variable.cmi utils/misc.cmi \
+    middle_end/inlining_stats.cmi middle_end/inlining_cost.cmi \
     middle_end/freshening.cmi middle_end/flambda.cmi middle_end/debuginfo.cmi \
     middle_end/base_types/compilation_unit.cmi \
     middle_end/base_types/closure_id.cmi utils/clflags.cmi \
@@ -1500,8 +1534,9 @@ middle_end/inline_and_simplify_aux.cmx : middle_end/base_types/variable.cmx \
     middle_end/base_types/static_exception.cmx \
     middle_end/simple_value_approx.cmx \
     middle_end/base_types/set_of_closures_origin.cmx \
-    middle_end/projection.cmx middle_end/base_types/mutable_variable.cmx \
-    utils/misc.cmx middle_end/inlining_stats.cmx middle_end/inlining_cost.cmx \
+    middle_end/projection.cmx middle_end/parameter.cmx \
+    middle_end/base_types/mutable_variable.cmx utils/misc.cmx \
+    middle_end/inlining_stats.cmx middle_end/inlining_cost.cmx \
     middle_end/freshening.cmx middle_end/flambda.cmx middle_end/debuginfo.cmx \
     middle_end/base_types/compilation_unit.cmx \
     middle_end/base_types/closure_id.cmx utils/clflags.cmx \
@@ -1527,20 +1562,20 @@ middle_end/inlining_cost.cmi : middle_end/projection.cmi \
     middle_end/flambda.cmi
 middle_end/inlining_decision.cmo : middle_end/base_types/variable.cmi \
     middle_end/base_types/var_within_closure.cmi \
-    middle_end/simple_value_approx.cmi utils/misc.cmi bytecomp/lambda.cmi \
-    middle_end/inlining_transforms.cmi middle_end/inlining_stats_types.cmi \
-    middle_end/inlining_cost.cmi middle_end/inline_and_simplify_aux.cmi \
-    middle_end/flambda_utils.cmi middle_end/flambda.cmi \
-    middle_end/find_recursive_functions.cmi \
+    middle_end/simple_value_approx.cmi middle_end/parameter.cmi \
+    utils/misc.cmi bytecomp/lambda.cmi middle_end/inlining_transforms.cmi \
+    middle_end/inlining_stats_types.cmi middle_end/inlining_cost.cmi \
+    middle_end/inline_and_simplify_aux.cmi middle_end/flambda_utils.cmi \
+    middle_end/flambda.cmi middle_end/find_recursive_functions.cmi \
     middle_end/base_types/closure_id.cmi utils/clflags.cmi \
     middle_end/inlining_decision.cmi
 middle_end/inlining_decision.cmx : middle_end/base_types/variable.cmx \
     middle_end/base_types/var_within_closure.cmx \
-    middle_end/simple_value_approx.cmx utils/misc.cmx bytecomp/lambda.cmx \
-    middle_end/inlining_transforms.cmx middle_end/inlining_stats_types.cmx \
-    middle_end/inlining_cost.cmx middle_end/inline_and_simplify_aux.cmx \
-    middle_end/flambda_utils.cmx middle_end/flambda.cmx \
-    middle_end/find_recursive_functions.cmx \
+    middle_end/simple_value_approx.cmx middle_end/parameter.cmx \
+    utils/misc.cmx bytecomp/lambda.cmx middle_end/inlining_transforms.cmx \
+    middle_end/inlining_stats_types.cmx middle_end/inlining_cost.cmx \
+    middle_end/inline_and_simplify_aux.cmx middle_end/flambda_utils.cmx \
+    middle_end/flambda.cmx middle_end/find_recursive_functions.cmx \
     middle_end/base_types/closure_id.cmx utils/clflags.cmx \
     middle_end/inlining_decision.cmi
 middle_end/inlining_decision.cmi : middle_end/base_types/variable.cmi \
@@ -1569,20 +1604,20 @@ middle_end/inlining_stats_types.cmx : middle_end/inlining_cost.cmx \
 middle_end/inlining_stats_types.cmi : middle_end/inlining_cost.cmi
 middle_end/inlining_transforms.cmo : middle_end/base_types/variable.cmi \
     middle_end/base_types/var_within_closure.cmi \
-    middle_end/simple_value_approx.cmi utils/misc.cmi bytecomp/lambda.cmi \
-    middle_end/inlining_cost.cmi middle_end/inline_and_simplify_aux.cmi \
-    middle_end/freshening.cmi middle_end/flambda_utils.cmi \
-    middle_end/flambda_iterators.cmi middle_end/flambda.cmi \
-    middle_end/base_types/compilation_unit.cmi \
+    middle_end/simple_value_approx.cmi middle_end/parameter.cmi \
+    utils/misc.cmi bytecomp/lambda.cmi middle_end/inlining_cost.cmi \
+    middle_end/inline_and_simplify_aux.cmi middle_end/freshening.cmi \
+    middle_end/flambda_utils.cmi middle_end/flambda_iterators.cmi \
+    middle_end/flambda.cmi middle_end/base_types/compilation_unit.cmi \
     middle_end/base_types/closure_id.cmi middle_end/backend_intf.cmi \
     middle_end/inlining_transforms.cmi
 middle_end/inlining_transforms.cmx : middle_end/base_types/variable.cmx \
     middle_end/base_types/var_within_closure.cmx \
-    middle_end/simple_value_approx.cmx utils/misc.cmx bytecomp/lambda.cmx \
-    middle_end/inlining_cost.cmx middle_end/inline_and_simplify_aux.cmx \
-    middle_end/freshening.cmx middle_end/flambda_utils.cmx \
-    middle_end/flambda_iterators.cmx middle_end/flambda.cmx \
-    middle_end/base_types/compilation_unit.cmx \
+    middle_end/simple_value_approx.cmx middle_end/parameter.cmx \
+    utils/misc.cmx bytecomp/lambda.cmx middle_end/inlining_cost.cmx \
+    middle_end/inline_and_simplify_aux.cmx middle_end/freshening.cmx \
+    middle_end/flambda_utils.cmx middle_end/flambda_iterators.cmx \
+    middle_end/flambda.cmx middle_end/base_types/compilation_unit.cmx \
     middle_end/base_types/closure_id.cmx middle_end/backend_intf.cmi \
     middle_end/inlining_transforms.cmi
 middle_end/inlining_transforms.cmi : middle_end/base_types/variable.cmi \
@@ -1591,15 +1626,17 @@ middle_end/inlining_transforms.cmi : middle_end/base_types/variable.cmi \
     middle_end/inline_and_simplify_aux.cmi middle_end/flambda.cmi \
     middle_end/debuginfo.cmi middle_end/base_types/closure_id.cmi
 middle_end/invariant_params.cmo : middle_end/base_types/variable.cmi \
-    middle_end/base_types/symbol.cmi middle_end/flambda_utils.cmi \
-    middle_end/flambda_iterators.cmi middle_end/flambda.cmi \
-    middle_end/base_types/closure_id.cmi utils/clflags.cmi \
-    middle_end/backend_intf.cmi middle_end/invariant_params.cmi
+    middle_end/base_types/symbol.cmi middle_end/parameter.cmi \
+    middle_end/flambda_utils.cmi middle_end/flambda_iterators.cmi \
+    middle_end/flambda.cmi middle_end/base_types/closure_id.cmi \
+    utils/clflags.cmi middle_end/backend_intf.cmi \
+    middle_end/invariant_params.cmi
 middle_end/invariant_params.cmx : middle_end/base_types/variable.cmx \
-    middle_end/base_types/symbol.cmx middle_end/flambda_utils.cmx \
-    middle_end/flambda_iterators.cmx middle_end/flambda.cmx \
-    middle_end/base_types/closure_id.cmx utils/clflags.cmx \
-    middle_end/backend_intf.cmi middle_end/invariant_params.cmi
+    middle_end/base_types/symbol.cmx middle_end/parameter.cmx \
+    middle_end/flambda_utils.cmx middle_end/flambda_iterators.cmx \
+    middle_end/flambda.cmx middle_end/base_types/closure_id.cmx \
+    utils/clflags.cmx middle_end/backend_intf.cmi \
+    middle_end/invariant_params.cmi
 middle_end/invariant_params.cmi : middle_end/base_types/variable.cmi \
     middle_end/flambda.cmi middle_end/backend_intf.cmi
 middle_end/lift_code.cmo : middle_end/base_types/variable.cmi \
@@ -1649,11 +1686,11 @@ middle_end/lift_let_to_initialize_symbol.cmx : \
 middle_end/lift_let_to_initialize_symbol.cmi : middle_end/flambda.cmi \
     middle_end/backend_intf.cmi
 middle_end/middle_end.cmo : utils/warnings.cmi \
-    middle_end/base_types/variable.cmi utils/timings.cmi \
-    middle_end/base_types/symbol.cmi middle_end/share_constants.cmi \
+    middle_end/base_types/variable.cmi middle_end/base_types/symbol.cmi \
+    middle_end/share_constants.cmi \
     middle_end/remove_unused_program_constructs.cmi \
     middle_end/remove_unused_closure_vars.cmi middle_end/ref_to_variables.cmi \
-    utils/misc.cmi parsing/location.cmi \
+    utils/profile.cmi utils/misc.cmi parsing/location.cmi \
     middle_end/lift_let_to_initialize_symbol.cmi \
     middle_end/lift_constants.cmi middle_end/lift_code.cmi \
     middle_end/inlining_cost.cmi middle_end/inline_and_simplify.cmi \
@@ -1663,11 +1700,11 @@ middle_end/middle_end.cmo : utils/warnings.cmi \
     middle_end/base_types/closure_id.cmi middle_end/closure_conversion.cmi \
     utils/clflags.cmi middle_end/backend_intf.cmi middle_end/middle_end.cmi
 middle_end/middle_end.cmx : utils/warnings.cmx \
-    middle_end/base_types/variable.cmx utils/timings.cmx \
-    middle_end/base_types/symbol.cmx middle_end/share_constants.cmx \
+    middle_end/base_types/variable.cmx middle_end/base_types/symbol.cmx \
+    middle_end/share_constants.cmx \
     middle_end/remove_unused_program_constructs.cmx \
     middle_end/remove_unused_closure_vars.cmx middle_end/ref_to_variables.cmx \
-    utils/misc.cmx parsing/location.cmx \
+    utils/profile.cmx utils/misc.cmx parsing/location.cmx \
     middle_end/lift_let_to_initialize_symbol.cmx \
     middle_end/lift_constants.cmx middle_end/lift_code.cmx \
     middle_end/inlining_cost.cmx middle_end/inline_and_simplify.cmx \
@@ -1676,8 +1713,14 @@ middle_end/middle_end.cmx : utils/warnings.cmx \
     middle_end/flambda.cmx middle_end/debuginfo.cmx \
     middle_end/base_types/closure_id.cmx middle_end/closure_conversion.cmx \
     utils/clflags.cmx middle_end/backend_intf.cmi middle_end/middle_end.cmi
-middle_end/middle_end.cmi : utils/timings.cmi bytecomp/lambda.cmi \
-    typing/ident.cmi middle_end/flambda.cmi middle_end/backend_intf.cmi
+middle_end/middle_end.cmi : bytecomp/lambda.cmi typing/ident.cmi \
+    middle_end/flambda.cmi middle_end/backend_intf.cmi
+middle_end/parameter.cmo : middle_end/base_types/variable.cmi \
+    utils/identifiable.cmi middle_end/parameter.cmi
+middle_end/parameter.cmx : middle_end/base_types/variable.cmx \
+    utils/identifiable.cmx middle_end/parameter.cmi
+middle_end/parameter.cmi : middle_end/base_types/variable.cmi \
+    utils/identifiable.cmi middle_end/base_types/compilation_unit.cmi
 middle_end/pass_wrapper.cmo : utils/clflags.cmi middle_end/pass_wrapper.cmi
 middle_end/pass_wrapper.cmx : utils/clflags.cmx middle_end/pass_wrapper.cmi
 middle_end/pass_wrapper.cmi :
@@ -1703,24 +1746,26 @@ middle_end/ref_to_variables.cmx : middle_end/base_types/variable.cmx \
 middle_end/ref_to_variables.cmi : middle_end/flambda.cmi
 middle_end/remove_free_vars_equal_to_args.cmo : \
     middle_end/base_types/variable.cmi middle_end/pass_wrapper.cmi \
-    middle_end/flambda_utils.cmi middle_end/flambda.cmi \
-    middle_end/remove_free_vars_equal_to_args.cmi
+    middle_end/parameter.cmi middle_end/flambda_utils.cmi \
+    middle_end/flambda.cmi middle_end/remove_free_vars_equal_to_args.cmi
 middle_end/remove_free_vars_equal_to_args.cmx : \
     middle_end/base_types/variable.cmx middle_end/pass_wrapper.cmx \
-    middle_end/flambda_utils.cmx middle_end/flambda.cmx \
-    middle_end/remove_free_vars_equal_to_args.cmi
+    middle_end/parameter.cmx middle_end/flambda_utils.cmx \
+    middle_end/flambda.cmx middle_end/remove_free_vars_equal_to_args.cmi
 middle_end/remove_free_vars_equal_to_args.cmi : middle_end/flambda.cmi
 middle_end/remove_unused_arguments.cmo : middle_end/base_types/variable.cmi \
-    middle_end/projection.cmi middle_end/invariant_params.cmi \
-    middle_end/flambda_utils.cmi middle_end/flambda_iterators.cmi \
-    middle_end/flambda.cmi middle_end/find_recursive_functions.cmi \
+    middle_end/projection.cmi middle_end/parameter.cmi \
+    middle_end/invariant_params.cmi middle_end/flambda_utils.cmi \
+    middle_end/flambda_iterators.cmi middle_end/flambda.cmi \
+    middle_end/find_recursive_functions.cmi \
     middle_end/base_types/compilation_unit.cmi \
     middle_end/base_types/closure_id.cmi utils/clflags.cmi \
     middle_end/remove_unused_arguments.cmi
 middle_end/remove_unused_arguments.cmx : middle_end/base_types/variable.cmx \
-    middle_end/projection.cmx middle_end/invariant_params.cmx \
-    middle_end/flambda_utils.cmx middle_end/flambda_iterators.cmx \
-    middle_end/flambda.cmx middle_end/find_recursive_functions.cmx \
+    middle_end/projection.cmx middle_end/parameter.cmx \
+    middle_end/invariant_params.cmx middle_end/flambda_utils.cmx \
+    middle_end/flambda_iterators.cmx middle_end/flambda.cmx \
+    middle_end/find_recursive_functions.cmx \
     middle_end/base_types/compilation_unit.cmx \
     middle_end/base_types/closure_id.cmx utils/clflags.cmx \
     middle_end/remove_unused_arguments.cmi
@@ -1728,15 +1773,15 @@ middle_end/remove_unused_arguments.cmi : middle_end/flambda.cmi \
     middle_end/backend_intf.cmi
 middle_end/remove_unused_closure_vars.cmo : \
     middle_end/base_types/variable.cmi \
-    middle_end/base_types/var_within_closure.cmi middle_end/flambda_utils.cmi \
-    middle_end/flambda_iterators.cmi middle_end/flambda.cmi \
-    middle_end/base_types/closure_id.cmi \
+    middle_end/base_types/var_within_closure.cmi middle_end/parameter.cmi \
+    middle_end/flambda_utils.cmi middle_end/flambda_iterators.cmi \
+    middle_end/flambda.cmi middle_end/base_types/closure_id.cmi \
     middle_end/remove_unused_closure_vars.cmi
 middle_end/remove_unused_closure_vars.cmx : \
     middle_end/base_types/variable.cmx \
-    middle_end/base_types/var_within_closure.cmx middle_end/flambda_utils.cmx \
-    middle_end/flambda_iterators.cmx middle_end/flambda.cmx \
-    middle_end/base_types/closure_id.cmx \
+    middle_end/base_types/var_within_closure.cmx middle_end/parameter.cmx \
+    middle_end/flambda_utils.cmx middle_end/flambda_iterators.cmx \
+    middle_end/flambda.cmx middle_end/base_types/closure_id.cmx \
     middle_end/remove_unused_closure_vars.cmi
 middle_end/remove_unused_closure_vars.cmi : middle_end/flambda.cmi
 middle_end/remove_unused_program_constructs.cmo : \
@@ -1758,8 +1803,8 @@ middle_end/share_constants.cmi : middle_end/flambda.cmi
 middle_end/simple_value_approx.cmo : middle_end/base_types/variable.cmi \
     middle_end/base_types/var_within_closure.cmi \
     middle_end/base_types/tag.cmi middle_end/base_types/symbol.cmi \
-    middle_end/base_types/set_of_closures_id.cmi utils/misc.cmi \
-    bytecomp/lambda.cmi middle_end/inlining_cost.cmi \
+    middle_end/base_types/set_of_closures_id.cmi middle_end/parameter.cmi \
+    utils/misc.cmi bytecomp/lambda.cmi middle_end/inlining_cost.cmi \
     middle_end/freshening.cmi middle_end/flambda_utils.cmi \
     middle_end/flambda.cmi middle_end/base_types/export_id.cmi \
     middle_end/effect_analysis.cmi middle_end/base_types/closure_id.cmi \
@@ -1767,8 +1812,8 @@ middle_end/simple_value_approx.cmo : middle_end/base_types/variable.cmi \
 middle_end/simple_value_approx.cmx : middle_end/base_types/variable.cmx \
     middle_end/base_types/var_within_closure.cmx \
     middle_end/base_types/tag.cmx middle_end/base_types/symbol.cmx \
-    middle_end/base_types/set_of_closures_id.cmx utils/misc.cmx \
-    bytecomp/lambda.cmx middle_end/inlining_cost.cmx \
+    middle_end/base_types/set_of_closures_id.cmx middle_end/parameter.cmx \
+    utils/misc.cmx bytecomp/lambda.cmx middle_end/inlining_cost.cmx \
     middle_end/freshening.cmx middle_end/flambda_utils.cmx \
     middle_end/flambda.cmx middle_end/base_types/export_id.cmx \
     middle_end/effect_analysis.cmx middle_end/base_types/closure_id.cmx \
@@ -1971,15 +2016,39 @@ middle_end/base_types/variable.cmx : utils/misc.cmx utils/identifiable.cmx \
     middle_end/base_types/variable.cmi
 middle_end/base_types/variable.cmi : utils/identifiable.cmi typing/ident.cmi \
     middle_end/base_types/compilation_unit.cmi
+asmcomp/debug/available_regs.cmo : asmcomp/debug/reg_with_debug_info.cmi \
+    asmcomp/debug/reg_availability_set.cmi asmcomp/reg.cmi asmcomp/proc.cmi \
+    asmcomp/printmach.cmi utils/misc.cmi asmcomp/mach.cmi typing/ident.cmi \
+    utils/clflags.cmi asmcomp/debug/available_regs.cmi
+asmcomp/debug/available_regs.cmx : asmcomp/debug/reg_with_debug_info.cmx \
+    asmcomp/debug/reg_availability_set.cmx asmcomp/reg.cmx asmcomp/proc.cmx \
+    asmcomp/printmach.cmx utils/misc.cmx asmcomp/mach.cmx typing/ident.cmx \
+    utils/clflags.cmx asmcomp/debug/available_regs.cmi
+asmcomp/debug/available_regs.cmi : asmcomp/mach.cmi
+asmcomp/debug/reg_availability_set.cmo : \
+    asmcomp/debug/reg_with_debug_info.cmi typing/ident.cmi \
+    asmcomp/debug/reg_availability_set.cmi
+asmcomp/debug/reg_availability_set.cmx : \
+    asmcomp/debug/reg_with_debug_info.cmx typing/ident.cmx \
+    asmcomp/debug/reg_availability_set.cmi
+asmcomp/debug/reg_availability_set.cmi : \
+    asmcomp/debug/reg_with_debug_info.cmi asmcomp/reg.cmi
+asmcomp/debug/reg_with_debug_info.cmo : asmcomp/reg.cmi typing/ident.cmi \
+    asmcomp/debug/reg_with_debug_info.cmi
+asmcomp/debug/reg_with_debug_info.cmx : asmcomp/reg.cmx typing/ident.cmx \
+    asmcomp/debug/reg_with_debug_info.cmi
+asmcomp/debug/reg_with_debug_info.cmi : asmcomp/reg.cmi typing/ident.cmi
 driver/compdynlink.cmi :
-driver/compenv.cmo : utils/warnings.cmi utils/misc.cmi parsing/location.cmi \
-    utils/config.cmi utils/clflags.cmi utils/ccomp.cmi driver/compenv.cmi
-driver/compenv.cmx : utils/warnings.cmx utils/misc.cmx parsing/location.cmx \
-    utils/config.cmx utils/clflags.cmx utils/ccomp.cmx driver/compenv.cmi
+driver/compenv.cmo : utils/warnings.cmi utils/profile.cmi utils/misc.cmi \
+    parsing/location.cmi utils/config.cmi utils/clflags.cmi utils/ccomp.cmi \
+    driver/compenv.cmi
+driver/compenv.cmx : utils/warnings.cmx utils/profile.cmx utils/misc.cmx \
+    parsing/location.cmx utils/config.cmx utils/clflags.cmx utils/ccomp.cmx \
+    driver/compenv.cmi
 driver/compenv.cmi :
 driver/compile.cmo : utils/warnings.cmi typing/typemod.cmi \
     typing/typedtree.cmi typing/typecore.cmi bytecomp/translmod.cmi \
-    utils/timings.cmi typing/stypes.cmi bytecomp/simplif.cmi \
+    typing/stypes.cmi bytecomp/simplif.cmi utils/profile.cmi \
     typing/printtyped.cmi typing/printtyp.cmi bytecomp/printlambda.cmi \
     bytecomp/printinstr.cmi parsing/printast.cmi parsing/pprintast.cmi \
     driver/pparse.cmi utils/misc.cmi bytecomp/lambda.cmi \
@@ -1988,7 +2057,7 @@ driver/compile.cmo : utils/warnings.cmi typing/typemod.cmi \
     bytecomp/bytegen.cmi parsing/builtin_attributes.cmi driver/compile.cmi
 driver/compile.cmx : utils/warnings.cmx typing/typemod.cmx \
     typing/typedtree.cmx typing/typecore.cmx bytecomp/translmod.cmx \
-    utils/timings.cmx typing/stypes.cmx bytecomp/simplif.cmx \
+    typing/stypes.cmx bytecomp/simplif.cmx utils/profile.cmx \
     typing/printtyped.cmx typing/printtyp.cmx bytecomp/printlambda.cmx \
     bytecomp/printinstr.cmx parsing/printast.cmx parsing/pprintast.cmx \
     driver/pparse.cmx utils/misc.cmx bytecomp/lambda.cmx \
@@ -2015,25 +2084,38 @@ driver/compplugin.cmi :
 driver/errors.cmo : parsing/location.cmi driver/errors.cmi
 driver/errors.cmx : parsing/location.cmx driver/errors.cmi
 driver/errors.cmi :
-driver/main.cmo : utils/warnings.cmi utils/timings.cmi utils/misc.cmi \
-    driver/main_args.cmi parsing/location.cmi utils/config.cmi \
-    driver/compplugin.cmi driver/compmisc.cmi driver/compile.cmi \
-    driver/compenv.cmi utils/clflags.cmi bytecomp/bytepackager.cmi \
-    bytecomp/bytelink.cmi bytecomp/bytelibrarian.cmi driver/main.cmi
-driver/main.cmx : utils/warnings.cmx utils/timings.cmx utils/misc.cmx \
-    driver/main_args.cmx parsing/location.cmx utils/config.cmx \
-    driver/compplugin.cmx driver/compmisc.cmx driver/compile.cmx \
-    driver/compenv.cmx utils/clflags.cmx bytecomp/bytepackager.cmx \
-    bytecomp/bytelink.cmx bytecomp/bytelibrarian.cmx driver/main.cmi
+driver/main.cmo : utils/warnings.cmi utils/profile.cmi utils/misc.cmi \
+    driver/makedepend.cmi driver/main_args.cmi parsing/location.cmi \
+    utils/config.cmi driver/compplugin.cmi driver/compmisc.cmi \
+    driver/compile.cmi driver/compenv.cmi utils/clflags.cmi \
+    bytecomp/bytepackager.cmi bytecomp/bytelink.cmi \
+    bytecomp/bytelibrarian.cmi driver/main.cmi
+driver/main.cmx : utils/warnings.cmx utils/profile.cmx utils/misc.cmx \
+    driver/makedepend.cmx driver/main_args.cmx parsing/location.cmx \
+    utils/config.cmx driver/compplugin.cmx driver/compmisc.cmx \
+    driver/compile.cmx driver/compenv.cmx utils/clflags.cmx \
+    bytecomp/bytepackager.cmx bytecomp/bytelink.cmx \
+    bytecomp/bytelibrarian.cmx driver/main.cmi
 driver/main.cmi :
-driver/main_args.cmo : utils/warnings.cmi utils/config.cmi utils/clflags.cmi \
-    driver/main_args.cmi
-driver/main_args.cmx : utils/warnings.cmx utils/config.cmx utils/clflags.cmx \
-    driver/main_args.cmi
+driver/main_args.cmo : utils/warnings.cmi utils/profile.cmi utils/config.cmi \
+    utils/clflags.cmi driver/main_args.cmi
+driver/main_args.cmx : utils/warnings.cmx utils/profile.cmx utils/config.cmx \
+    utils/clflags.cmx driver/main_args.cmi
 driver/main_args.cmi :
+driver/makedepend.cmo : driver/pparse.cmi parsing/parsetree.cmi \
+    parsing/parser.cmi parsing/parse.cmi utils/misc.cmi parsing/longident.cmi \
+    parsing/location.cmi parsing/lexer.cmi parsing/depend.cmi \
+    utils/config.cmi driver/compplugin.cmi driver/compenv.cmi \
+    utils/clflags.cmi driver/makedepend.cmi
+driver/makedepend.cmx : driver/pparse.cmx parsing/parsetree.cmi \
+    parsing/parser.cmx parsing/parse.cmx utils/misc.cmx parsing/longident.cmx \
+    parsing/location.cmx parsing/lexer.cmx parsing/depend.cmx \
+    utils/config.cmx driver/compplugin.cmx driver/compenv.cmx \
+    utils/clflags.cmx driver/makedepend.cmi
+driver/makedepend.cmi :
 driver/optcompile.cmo : utils/warnings.cmi typing/typemod.cmi \
     typing/typedtree.cmi typing/typecore.cmi bytecomp/translmod.cmi \
-    utils/timings.cmi typing/stypes.cmi bytecomp/simplif.cmi \
+    typing/stypes.cmi bytecomp/simplif.cmi utils/profile.cmi \
     typing/printtyped.cmi typing/printtyp.cmi bytecomp/printlambda.cmi \
     parsing/printast.cmi parsing/pprintast.cmi driver/pparse.cmi \
     utils/misc.cmi middle_end/middle_end.cmi bytecomp/lambda.cmi \
@@ -2042,7 +2124,7 @@ driver/optcompile.cmo : utils/warnings.cmi typing/typemod.cmi \
     parsing/builtin_attributes.cmi asmcomp/asmgen.cmi driver/optcompile.cmi
 driver/optcompile.cmx : utils/warnings.cmx typing/typemod.cmx \
     typing/typedtree.cmx typing/typecore.cmx bytecomp/translmod.cmx \
-    utils/timings.cmx typing/stypes.cmx bytecomp/simplif.cmx \
+    typing/stypes.cmx bytecomp/simplif.cmx utils/profile.cmx \
     typing/printtyped.cmx typing/printtyp.cmx bytecomp/printlambda.cmx \
     parsing/printast.cmx parsing/pprintast.cmx driver/pparse.cmx \
     utils/misc.cmx middle_end/middle_end.cmx bytecomp/lambda.cmx \
@@ -2053,26 +2135,28 @@ driver/optcompile.cmi : middle_end/backend_intf.cmi
 driver/opterrors.cmo : parsing/location.cmi driver/opterrors.cmi
 driver/opterrors.cmx : parsing/location.cmx driver/opterrors.cmi
 driver/opterrors.cmi :
-driver/optmain.cmo : utils/warnings.cmi utils/timings.cmi asmcomp/proc.cmi \
+driver/optmain.cmo : utils/warnings.cmi utils/profile.cmi asmcomp/proc.cmi \
     asmcomp/printmach.cmi driver/optcompile.cmi utils/misc.cmi \
-    driver/main_args.cmi parsing/location.cmi asmcomp/import_approx.cmi \
-    utils/config.cmi driver/compplugin.cmi driver/compmisc.cmi \
-    asmcomp/compilenv.cmi driver/compenv.cmi utils/clflags.cmi \
-    middle_end/backend_intf.cmi asmcomp/asmpackager.cmi asmcomp/asmlink.cmi \
-    asmcomp/asmlibrarian.cmi asmcomp/arch.cmo driver/optmain.cmi
-driver/optmain.cmx : utils/warnings.cmx utils/timings.cmx asmcomp/proc.cmx \
+    driver/makedepend.cmi driver/main_args.cmi parsing/location.cmi \
+    asmcomp/import_approx.cmi utils/config.cmi driver/compplugin.cmi \
+    driver/compmisc.cmi asmcomp/compilenv.cmi driver/compenv.cmi \
+    utils/clflags.cmi middle_end/backend_intf.cmi asmcomp/asmpackager.cmi \
+    asmcomp/asmlink.cmi asmcomp/asmlibrarian.cmi asmcomp/arch.cmo \
+    driver/optmain.cmi
+driver/optmain.cmx : utils/warnings.cmx utils/profile.cmx asmcomp/proc.cmx \
     asmcomp/printmach.cmx driver/optcompile.cmx utils/misc.cmx \
-    driver/main_args.cmx parsing/location.cmx asmcomp/import_approx.cmx \
-    utils/config.cmx driver/compplugin.cmx driver/compmisc.cmx \
-    asmcomp/compilenv.cmx driver/compenv.cmx utils/clflags.cmx \
-    middle_end/backend_intf.cmi asmcomp/asmpackager.cmx asmcomp/asmlink.cmx \
-    asmcomp/asmlibrarian.cmx asmcomp/arch.cmx driver/optmain.cmi
+    driver/makedepend.cmx driver/main_args.cmx parsing/location.cmx \
+    asmcomp/import_approx.cmx utils/config.cmx driver/compplugin.cmx \
+    driver/compmisc.cmx asmcomp/compilenv.cmx driver/compenv.cmx \
+    utils/clflags.cmx middle_end/backend_intf.cmi asmcomp/asmpackager.cmx \
+    asmcomp/asmlink.cmx asmcomp/asmlibrarian.cmx asmcomp/arch.cmx \
+    driver/optmain.cmi
 driver/optmain.cmi :
-driver/pparse.cmo : utils/timings.cmi parsing/parsetree.cmi \
+driver/pparse.cmo : utils/profile.cmi parsing/parsetree.cmi \
     parsing/parse.cmi utils/misc.cmi parsing/location.cmi utils/config.cmi \
     utils/clflags.cmi utils/ccomp.cmi parsing/ast_mapper.cmi \
     parsing/ast_invariants.cmi driver/pparse.cmi
-driver/pparse.cmx : utils/timings.cmx parsing/parsetree.cmi \
+driver/pparse.cmx : utils/profile.cmx parsing/parsetree.cmi \
     parsing/parse.cmx utils/misc.cmx parsing/location.cmx utils/config.cmx \
     utils/clflags.cmx utils/ccomp.cmx parsing/ast_mapper.cmx \
     parsing/ast_invariants.cmx driver/pparse.cmi
@@ -2106,46 +2190,46 @@ toplevel/opttopdirs.cmx : utils/warnings.cmx typing/types.cmx \
 toplevel/opttopdirs.cmi : parsing/longident.cmi
 toplevel/opttoploop.cmo : utils/warnings.cmi typing/types.cmi \
     typing/typemod.cmi typing/typedtree.cmi typing/typecore.cmi \
-    bytecomp/translmod.cmi utils/timings.cmi bytecomp/simplif.cmi \
-    asmcomp/proc.cmi typing/printtyped.cmi typing/printtyp.cmi \
-    bytecomp/printlambda.cmi parsing/printast.cmi typing/predef.cmi \
-    parsing/pprintast.cmi driver/pparse.cmi typing/path.cmi \
-    parsing/parsetree.cmi parsing/parse.cmi typing/outcometree.cmi \
-    typing/oprint.cmi utils/misc.cmi middle_end/middle_end.cmi \
-    parsing/longident.cmi parsing/location.cmi parsing/lexer.cmi \
-    bytecomp/lambda.cmi typing/includemod.cmi asmcomp/import_approx.cmi \
-    typing/ident.cmi toplevel/genprintval.cmi typing/env.cmi utils/config.cmi \
-    driver/compmisc.cmi asmcomp/compilenv.cmi driver/compdynlink.cmi \
-    utils/clflags.cmi typing/btype.cmi middle_end/backend_intf.cmi \
-    parsing/asttypes.cmi parsing/ast_helper.cmi asmcomp/asmlink.cmi \
-    asmcomp/asmgen.cmi asmcomp/arch.cmo toplevel/opttoploop.cmi
+    bytecomp/translmod.cmi bytecomp/simplif.cmi asmcomp/proc.cmi \
+    typing/printtyped.cmi typing/printtyp.cmi bytecomp/printlambda.cmi \
+    parsing/printast.cmi typing/predef.cmi parsing/pprintast.cmi \
+    driver/pparse.cmi typing/path.cmi parsing/parsetree.cmi parsing/parse.cmi \
+    typing/outcometree.cmi typing/oprint.cmi utils/misc.cmi \
+    middle_end/middle_end.cmi parsing/longident.cmi parsing/location.cmi \
+    parsing/lexer.cmi bytecomp/lambda.cmi typing/includemod.cmi \
+    asmcomp/import_approx.cmi typing/ident.cmi toplevel/genprintval.cmi \
+    typing/env.cmi utils/config.cmi driver/compmisc.cmi asmcomp/compilenv.cmi \
+    driver/compdynlink.cmi utils/clflags.cmi typing/btype.cmi \
+    middle_end/backend_intf.cmi parsing/asttypes.cmi parsing/ast_helper.cmi \
+    asmcomp/asmlink.cmi asmcomp/asmgen.cmi asmcomp/arch.cmo \
+    toplevel/opttoploop.cmi
 toplevel/opttoploop.cmx : utils/warnings.cmx typing/types.cmx \
     typing/typemod.cmx typing/typedtree.cmx typing/typecore.cmx \
-    bytecomp/translmod.cmx utils/timings.cmx bytecomp/simplif.cmx \
-    asmcomp/proc.cmx typing/printtyped.cmx typing/printtyp.cmx \
-    bytecomp/printlambda.cmx parsing/printast.cmx typing/predef.cmx \
-    parsing/pprintast.cmx driver/pparse.cmx typing/path.cmx \
-    parsing/parsetree.cmi parsing/parse.cmx typing/outcometree.cmi \
-    typing/oprint.cmx utils/misc.cmx middle_end/middle_end.cmx \
-    parsing/longident.cmx parsing/location.cmx parsing/lexer.cmx \
-    bytecomp/lambda.cmx typing/includemod.cmx asmcomp/import_approx.cmx \
-    typing/ident.cmx toplevel/genprintval.cmx typing/env.cmx utils/config.cmx \
-    driver/compmisc.cmx asmcomp/compilenv.cmx driver/compdynlink.cmi \
-    utils/clflags.cmx typing/btype.cmx middle_end/backend_intf.cmi \
-    parsing/asttypes.cmi parsing/ast_helper.cmx asmcomp/asmlink.cmx \
-    asmcomp/asmgen.cmx asmcomp/arch.cmx toplevel/opttoploop.cmi
+    bytecomp/translmod.cmx bytecomp/simplif.cmx asmcomp/proc.cmx \
+    typing/printtyped.cmx typing/printtyp.cmx bytecomp/printlambda.cmx \
+    parsing/printast.cmx typing/predef.cmx parsing/pprintast.cmx \
+    driver/pparse.cmx typing/path.cmx parsing/parsetree.cmi parsing/parse.cmx \
+    typing/outcometree.cmi typing/oprint.cmx utils/misc.cmx \
+    middle_end/middle_end.cmx parsing/longident.cmx parsing/location.cmx \
+    parsing/lexer.cmx bytecomp/lambda.cmx typing/includemod.cmx \
+    asmcomp/import_approx.cmx typing/ident.cmx toplevel/genprintval.cmx \
+    typing/env.cmx utils/config.cmx driver/compmisc.cmx asmcomp/compilenv.cmx \
+    driver/compdynlink.cmi utils/clflags.cmx typing/btype.cmx \
+    middle_end/backend_intf.cmi parsing/asttypes.cmi parsing/ast_helper.cmx \
+    asmcomp/asmlink.cmx asmcomp/asmgen.cmx asmcomp/arch.cmx \
+    toplevel/opttoploop.cmi
 toplevel/opttoploop.cmi : utils/warnings.cmi typing/types.cmi \
     typing/path.cmi parsing/parsetree.cmi typing/outcometree.cmi \
     parsing/longident.cmi parsing/location.cmi typing/env.cmi
 toplevel/opttopmain.cmo : utils/warnings.cmi asmcomp/printmach.cmi \
     toplevel/opttoploop.cmi toplevel/opttopdirs.cmi utils/misc.cmi \
     driver/main_args.cmi parsing/location.cmi utils/config.cmi \
-    driver/compplugin.cmi driver/compenv.cmi utils/clflags.cmi \
+    driver/compmisc.cmi driver/compenv.cmi utils/clflags.cmi \
     toplevel/opttopmain.cmi
 toplevel/opttopmain.cmx : utils/warnings.cmx asmcomp/printmach.cmx \
     toplevel/opttoploop.cmx toplevel/opttopdirs.cmx utils/misc.cmx \
     driver/main_args.cmx parsing/location.cmx utils/config.cmx \
-    driver/compplugin.cmx driver/compenv.cmx utils/clflags.cmx \
+    driver/compmisc.cmx driver/compenv.cmx utils/clflags.cmx \
     toplevel/opttopmain.cmi
 toplevel/opttopmain.cmi :
 toplevel/opttopstart.cmo : toplevel/opttopmain.cmi
@@ -2201,13 +2285,15 @@ toplevel/toploop.cmi : utils/warnings.cmi typing/types.cmi typing/path.cmi \
     parsing/parsetree.cmi typing/outcometree.cmi parsing/longident.cmi \
     parsing/location.cmi typing/env.cmi
 toplevel/topmain.cmo : utils/warnings.cmi toplevel/toploop.cmi \
-    toplevel/topdirs.cmi utils/misc.cmi driver/main_args.cmi \
-    parsing/location.cmi utils/config.cmi driver/compplugin.cmi \
-    driver/compenv.cmi utils/clflags.cmi toplevel/topmain.cmi
+    toplevel/topdirs.cmi utils/profile.cmi utils/misc.cmi \
+    driver/main_args.cmi parsing/location.cmi utils/config.cmi \
+    driver/compmisc.cmi driver/compenv.cmi utils/clflags.cmi \
+    toplevel/topmain.cmi
 toplevel/topmain.cmx : utils/warnings.cmx toplevel/toploop.cmx \
-    toplevel/topdirs.cmx utils/misc.cmx driver/main_args.cmx \
-    parsing/location.cmx utils/config.cmx driver/compplugin.cmx \
-    driver/compenv.cmx utils/clflags.cmx toplevel/topmain.cmi
+    toplevel/topdirs.cmx utils/profile.cmx utils/misc.cmx \
+    driver/main_args.cmx parsing/location.cmx utils/config.cmx \
+    driver/compmisc.cmx driver/compenv.cmx utils/clflags.cmx \
+    toplevel/topmain.cmi
 toplevel/topmain.cmi :
 toplevel/topstart.cmo : toplevel/topmain.cmi
 toplevel/topstart.cmx : toplevel/topmain.cmx

diff --git a/.gitattributes b/.gitattributes
index b3eabd77a813420da74b65494124dcbe843349fd..ecff398c34c51c4903a80894adf928a9032a30c7 100644 (file)
--- a/.gitattributes
+++ b/.gitattributes
@@ -16,6 +16,9 @@
 # Default behaviour, for if core.autocrlf isn't set
 * text=auto
 
+# Don't believe there's a way to wrap lines in .gitattributes
+.gitattributes ocaml-typo=long-line
+
 # Binary files
 /boot/ocamlc binary
 /boot/ocamllex binary
@@ -27,7 +30,12 @@
 # 'union' merge driver just unions textual content in case of conflict
 #   http://krlmlr.github.io/using-gitattributes-to-avoid-merge-conflicts/
 /.mailmap                merge=union
-/Changes                 merge=union
+
+
+# We tried using 'union' for Changes and it did not work:
+# instead of creating Changes conflict it would silently duplicate
+# the lines involved in the conflict, which is arguably worse
+#/Changes                 merge=union
 
 # No header for text files (would be too obtrusive).
 *.md                     ocaml-typo=missing-header
@@ -39,17 +47,21 @@ README*                  ocaml-typo=missing-header
 /Changes                 ocaml-typo=non-ascii,missing-header
 /INSTALL                 ocaml-typo=missing-header
 /LICENSE                 ocaml-typo=long-line,very-long-line,missing-header
-/appveyor.yml            ocaml-typo=long-line,very-long-line
+# appveyor_build.cmd only has missing-header because dra27 too lazy to update
+# check-typo to interpret Cmd-style comments!
+/appveyor_build.cmd      ocaml-typo=long-line,very-long-line,missing-header text eol=crlf
+/appveyor_build.sh       ocaml-typo=non-ascii
 
 
 asmcomp/*/emit.mlp       ocaml-typo=tab,long-line,unused-prop
-asmcomp/power/NOTES.md   ocaml-typo=missing-header,long-line
+asmcomp/power/NOTES.md   ocaml-typo=missing-header
 
 asmrun/i386.S            ocaml-typo=long-line
 
 config/gnu               ocaml-typo=prune
 
 emacs/*.el               ocaml-typo=long-line,unused-prop
+emacs/caml.el            ocaml-typo=long-line,unused-prop,missing-header
 emacs/COPYING            ocaml-typo=tab,non-printing,missing-header
 emacs/ocamltags.in       ocaml-typo=non-printing
 
@@ -72,6 +84,7 @@ otherlibs/win32unix/symlink.c     ocaml-typo=long-line
 stdlib/hashbang     ocaml-typo=white-at-eol,missing-lf
 
 testsuite/tests/**                        ocaml-typo=missing-header
+testsuite/tests/lib-unix/win-stat/fakeclock.c ocaml-typo=
 testsuite/tests/lib-bigarray-2/bigarrf.f  ocaml-typo=missing-header,tab
 testsuite/tests/misc-unsafe/almabench.ml  ocaml-typo=missing-header,long-line
 testsuite/typing                          ocaml-typo=missing-header
@@ -101,11 +114,11 @@ config/auto-aux/trycompile text eol=lf
 config/gnu/config.guess text eol=lf
 config/gnu/config.sub text eol=lf
 ocamldoc/remove_DEBUG text eol=lf
+ocamltest/getocamloptdefaultflags text eol=lf
 stdlib/Compflags text eol=lf
 stdlib/sharpbang text eol=lf
 tools/check-typo text eol=lf
 tools/ci-build text eol=lf
-tools/cleanup-header text eol=lf
 tools/msvs-promote-path text eol=lf
 tools/gdb-macros text eol=lf
 tools/magic text eol=lf
@@ -127,19 +140,25 @@ manual/tools/htmltbl text eol=lf
 manual/tools/htmlthread text eol=lf
 manual/tools/texexpand text eol=lf
 
-# Checking out the parsetree test files with \r\n endings causes all the
-# locations to change, so use \n endings only, even on Windows
+# Tests which include references spanning multiple lines fail with \r\n
+# endings, so use \n endings only, even on Windows.
 testsuite/tests/parsing/*.ml text eol=lf
-
-# Similarly, the docstring tests fail for the same reason on Windows
 testsuite/tests/docstrings/empty.ml text eol=lf
-
-# And w04.ml
+testsuite/tests/functors/functors.ml text eol=lf
+testsuite/tests/translprim/module_coercion.ml text eol=lf
 testsuite/tests/warnings/w04.ml text eol=lf
+testsuite/tests/warnings/w32.ml text eol=lf
 
 # These are forced to \n to allow the Cygwin testsuite to pass on a
 # Windows-checkout
 testsuite/tests/formatting/margins.ml text eol=lf
+testsuite/tests/letrec-disallowed/disallowed.ml text eol=lf
+testsuite/tests/letrec-disallowed/extension_constructor.ml text eol=lf
+testsuite/tests/letrec-disallowed/float_block.ml text eol=lf
+testsuite/tests/letrec-disallowed/generic_arrays.ml text eol=lf
+testsuite/tests/letrec-disallowed/module_constraints.ml text eol=lf
+testsuite/tests/letrec-disallowed/pr7215.ml text eol=lf
+testsuite/tests/lexing/uchar_esc.ml text eol=lf
 testsuite/tests/match-exception-warnings/exhaustiveness_warnings.ml text eol=lf
 testsuite/tests/typing-extension-constructor/test.ml text eol=lf
 testsuite/tests/typing-extensions/extensions.ml text eol=lf
@@ -161,9 +180,12 @@ testsuite/tests/typing-warnings/ambiguous_guarded_disjunction.ml text eol=lf
 testsuite/tests/typing-warnings/application.ml text eol=lf
 testsuite/tests/typing-warnings/coercions.ml text eol=lf
 testsuite/tests/typing-warnings/exhaustiveness.ml text eol=lf
+testsuite/tests/typing-warnings/pr6587.ml text eol=lf
 testsuite/tests/typing-warnings/pr6872.ml text eol=lf
 testsuite/tests/typing-warnings/pr7085.ml text eol=lf
 testsuite/tests/typing-warnings/pr7115.ml text eol=lf
+testsuite/tests/typing-warnings/pr7261.ml text eol=lf
 testsuite/tests/typing-warnings/pr7297.ml text eol=lf
+testsuite/tests/typing-warnings/pr7553.ml text eol=lf
 testsuite/tests/typing-warnings/records.ml text eol=lf
 testsuite/tests/typing-warnings/unused_types.ml text eol=lf

diff --git a/.gitignore b/.gitignore
index 04da75db71896d34b5e7867bbd21f875a05d25e1..3657bd9652d224b391c5054a3dda4f96efd5d257 100644 (file)
--- a/.gitignore
+++ b/.gitignore
@@ -27,12 +27,11 @@
 *.annot
 *.exe
 *.exe.manifest
-.depend
-.depend.nt
 .DS_Store
 *.out
 *.out.dSYM
 *.swp
+_ocamltest
 
 # local to root directory
 
@@ -61,6 +60,7 @@
 /asmrun/afl.c
 /asmrun/array.c
 /asmrun/backtrace.c
+/asmrun/bigarray.c
 /asmrun/callback.c
 /asmrun/compact.c
 /asmrun/compare.c
@@ -106,6 +106,8 @@
 /bytecomp/opcodes.ml
 
 /byterun/caml/jumptbl.h
+/byterun/caml/m.h
+/byterun/caml/s.h
 /byterun/primitives
 /byterun/prims.c
 /byterun/caml/opnames.h
@@ -120,8 +122,6 @@
 /byterun/*.d.c
 /byterun/*.pic.c
 
-/config/m.h
-/config/s.h
 /config/Makefile
 /config/auto-aux/hashbang4
 
@@ -173,8 +173,14 @@
 /ocamldoc/test_latex
 /ocamldoc/test
 
+/ocamltest/ocamltest
+/ocamltest/ocamltest.opt
+/ocamltest/ocamltest_config.ml
+/ocamltest/tsl_lexer.ml
+/ocamltest/tsl_parser.ml
+/ocamltest/tsl_parser.mli
+
 /otherlibs/dynlink/extract_crc
-/otherlibs/systhreads/thread.ml
 /otherlibs/threads/marshal.mli
 /otherlibs/threads/pervasives.mli
 /otherlibs/threads/unix.mli
@@ -188,7 +194,6 @@
 /otherlibs/win32unix/chmod.c
 /otherlibs/win32unix/cst2constr.c
 /otherlibs/win32unix/cstringv.c
-/otherlibs/win32unix/envir.c
 /otherlibs/win32unix/execv.c
 /otherlibs/win32unix/execve.c
 /otherlibs/win32unix/execvp.c
@@ -201,6 +206,7 @@
 /otherlibs/win32unix/getproto.c
 /otherlibs/win32unix/getserv.c
 /otherlibs/win32unix/gmtime.c
+/otherlibs/win32unix/mmap_ba.c
 /otherlibs/win32unix/putenv.c
 /otherlibs/win32unix/rmdir.c
 /otherlibs/win32unix/socketaddr.c
@@ -235,6 +241,7 @@
 /testsuite/**/*.native
 /testsuite/**/program
 /testsuite/**/_log
+/testsuite/failure.stamp
 
 /testsuite/_retries
 
@@ -246,7 +253,6 @@
 /testsuite/tests/asmcomp/*.out.manifest
 
 /testsuite/tests/basic/*.safe-string
-/testsuite/tests/basic/pr6322.ml
 
 /testsuite/tests/embedded/caml
 
@@ -270,8 +276,19 @@
 
 /testsuite/tests/lib-threads/*.byt
 
+/testsuite/tests/lib-unix/win-stat/*-file
+/testsuite/tests/lib-unix/win-symlink/link*
+/testsuite/tests/lib-unix/win-symlink/test.txt
+
+/testsuite/tests/lib-unix/win-symlink/link*
+/testsuite/tests/lib-unix/win-symlink/test.txt
+
 /testsuite/tests/opaque/*/*.mli
 
+/testsuite/tests/output_obj/*.bc.c
+/testsuite/tests/output_obj/*_stub
+/testsuite/tests/output_obj/*_stub
+
 /testsuite/tests/runtime-errors/*.bytecode
 
 /testsuite/tests/self-contained-toplevel/cached_cmi.ml
@@ -309,9 +326,27 @@
 /testsuite/tests/tool-lexyacc/grammar.mli
 /testsuite/tests/tool-lexyacc/grammar.ml
 
+/testsuite/tests/typing-misc/false.flat-float
+/testsuite/tests/typing-misc/true.flat-float
+/testsuite/tests/typing-misc/pr6939.ml
+
 /testsuite/tests/typing-multifile/a.ml
 /testsuite/tests/typing-multifile/b.ml
 /testsuite/tests/typing-multifile/c.ml
+/testsuite/tests/typing-multifile/d.mli
+/testsuite/tests/typing-multifile/e.ml
+/testsuite/tests/typing-multifile/f.ml
+/testsuite/tests/typing-multifile/g.ml
+/testsuite/tests/typing-multifile/test
+
+/testsuite/tests/typing-unboxed-types/false.flat-float
+/testsuite/tests/typing-unboxed-types/true.flat-float
+/testsuite/tests/typing-unboxed-types/test.ml.reference
+
+/testsuite/tests/translprim/false.flat-float
+/testsuite/tests/translprim/true.flat-float
+/testsuite/tests/translprim/array_spec.ml.reference
+/testsuite/tests/translprim/module_coercion.ml.reference
 
 /testsuite/tests/unboxed-primitive-args/main.ml
 /testsuite/tests/unboxed-primitive-args/stubs.c
@@ -321,6 +356,8 @@
 /testsuite/tests/warnings/w55.opt.opt_result
 /testsuite/tests/warnings/w58.opt.opt_result
 
+/testsuite/tests/win-unicode/symlink_tests.precheck
+
 /testsuite/tools/expect_test
 
 /tools/ocamldep

diff --git a/.mailmap b/.mailmap
index b4483d021cc4f0c6619fb7e9b81daf514270a9cb..772aac57ce425c3480d314bbf94fb2e0208de8db 100644 (file)
--- a/.mailmap
+++ b/.mailmap
@@ -14,6 +14,7 @@
 Alain Frisch <alain@frisch.fr> alainfrisch <alain@frisch.fr>
 <damien.doligez@inria.fr> <damien.doligez-inria.fr>
 <damien.doligez@inria.fr> <damien.doligez@gmail.com>
+Luc Maranget <luc.maranget@inria.fr>
 <luc.maranget@inria.fr> <Luc.Maranget@inria.fr>
 <luc.maranget@inria.fr> <maranget@pl-59086.rocq.inria.fr>
 <pierre.chambart@ocamlpro.com> <chambart@users.noreply.github.com>
@@ -25,6 +26,7 @@ Damien Doligez <damien.doligez@inria.fr> Some Name <some@name.com>
 Damien Doligez <damien.doligez@inria.fr> doligez <damien.doligez@inria.fr>
 Mohamed Iguernelala <mohamed.iguernelala@gmail.com>
 Jérémie Dimino <jdimino@janestreet.com>
+Jeremy Yallop <yallop@gmail.com> yallop <yallop@gmail.com>
 
 # The aliases below correspond to preference expressed by
 # contributors on the name under which they credited, for example
@@ -60,6 +62,7 @@ Florian Angeletti <octachron>
 Kenji Tokudome <pocarist>
 Philippe Veber <pveber>
 Valentin Gatien-Baron <sliquister>
+Valentin Gatien-Baron <valentin.gatienbaron@gmail.com>
 Stephen Dolan <stedolan>
 Junsong Li <lijunsong@mantis>
 Junsong Li <ljs.darkfish@gmail.com>
@@ -73,12 +76,22 @@ Thomas Leonard <talex@mantis>
 Thomas Leonard <talex5@github>
 Adrien Nader <adrien-n@github>
 Sébastien Hinderer <shindere@github>
+Sébastien Hinderer <Sebastien.Hinderer@inria.fr>
 Gabriel Scherer <gasche@github>
 Immanuel Litzroth <sdev@mantis>
 Jacques Le Normand <rathereasy@github>
+Konstantin Romanov <const-rs@github>
+Arseniy Alekseyev <aalekseyev@janestreet.com>
+Dwight Guth <dwight.guth@runtimeverification.com>
+Dwight Guth <dwightguth@github>
+Andreas Hauptmann <andreashauptmann@t-online.de> fdopen <andreashauptmann@t-online.de>
+Andreas Hauptmann <andreashauptmann@t-online.de> <fdopen@users.noreply.github.com>
+Hendrik Tews <hendrik@askra.de>
+Hugo Heuzard <hugo.heuzard@gmail.com>
+Miod Vallat <miod@mantis>
 
 # These contributors prefer to be referred to pseudonymously
-<whitequark@mantis> <whitequark@mantis>
+whitequark <whitequark@whitequark.org>
 <william@mantis> <william@mantis>
 tkob <ether4@gmail.com> tkob <ether4@gmail.com>
 ygrek <ygrek@autistici.org> ygrek <ygrek@autistici.org>

diff --git a/.merlin b/.merlin
index 38628a4744baa2b8119bc04b10981a88d5a664e9..096ee29751aae298d03b69c74c119ed384bb7e4b 100644 (file)
--- a/.merlin
+++ b/.merlin
@@ -54,3 +54,6 @@ B ./typing
 
 S ./utils
 B ./utils
+
+S ./ocamltest
+B ./ocamltest

diff --git a/.travis-ci.sh b/.travis-ci.sh
index 2722fef3fdc20b26e932a7bfde220ee25c80a937..f30d64dcb62984984e64026f5ac09d3cbf4214da 100755 (executable)
--- a/.travis-ci.sh
+++ b/.travis-ci.sh
@@ -1,3 +1,4 @@
+#!/bin/bash
 #**************************************************************************
 #*                                                                        *
 #*                                 OCaml                                  *
@@ -15,68 +16,70 @@
 
 PREFIX=~/local
 
+MAKE=make SHELL=dash
+
+# TRAVIS_COMMIT_RANGE has the form   <commit1>...<commit2>
+# TRAVIS_CUR_HEAD is <commit1>
+# TRAVIS_PR_HEAD is <commit2>
+#
+# The following diagram illustrates the relationship between
+# the commits:
+#
+#      (trunk)         (pr branch)
+#  TRAVIS_CUR_HEAD   TRAVIS_PR_HEAD
+#        |            /
+#       ...         ...
+#        |          /
+#  TRAVIS_MERGE_BASE
+#
+echo TRAVIS_COMMIT_RANGE=$TRAVIS_COMMIT_RANGE
+TRAVIS_CUR_HEAD=${TRAVIS_COMMIT_RANGE%%...*}
+TRAVIS_PR_HEAD=${TRAVIS_COMMIT_RANGE##*...}
+case $TRAVIS_EVENT_TYPE in
+   # If this is not a pull request then TRAVIS_COMMIT_RANGE may be empty.
+   pull_request)
+     TRAVIS_MERGE_BASE=$(git merge-base $TRAVIS_CUR_HEAD $TRAVIS_PR_HEAD);;
+esac
+
 BuildAndTest () {
-  case $XARCH in
-  i386)
+  mkdir -p $PREFIX
   cat<<EOF
 ------------------------------------------------------------------------
-This test builds the OCaml compiler distribution with your pull request,
-runs its testsuite, and then tries to install some important OCaml software
-(currently camlp4) on top of it.
+This test builds the OCaml compiler distribution with your pull request
+and runs its testsuite.
 
 Failing to build the compiler distribution, or testsuite failures are
 critical errors that must be understood and fixed before your pull
-request can be merged. The later installation attempts try to run
-bleeding-edge software, and failures can sometimes be out of your
-control.
+request can be merged.
 ------------------------------------------------------------------------
 EOF
-    mkdir -p $PREFIX
+  case $XARCH in
+  x64)
     ./configure --prefix $PREFIX -with-debug-runtime \
       -with-instrumented-runtime $CONFIG_ARG
-    export PATH=$PREFIX/bin:$PATH
-    make world.opt
-    make ocamlnat
-    (cd testsuite && make all)
-    (cd testsuite && make USE_RUNTIME="d" all)
-    make install
-    # check_all_arches checks tries to compile all backends in place,
-    # we need to redo (small parts of) world.opt afterwards
-    make check_all_arches
-    make world.opt
-    make manual-pregen
-    mkdir external-packages
-    cd external-packages
-    git clone git://github.com/ocaml/ocamlbuild
-    mkdir ocamlbuild-install
-    (cd ocamlbuild &&
-        make -f configure.make Makefile.config src/ocamlbuild_config.ml \
-          OCAMLBUILD_PREFIX=$PREFIX \
-          OCAMLBUILD_BINDIR=$PREFIX/bin \
-          OCAMLBUILD_LIBDIR=$PREFIX/lib \
-          OCAML_NATIVE=true \
-          OCAML_NATIVE_TOOLS=true &&
-        make all &&
-        make install)
-    git clone git://github.com/ocaml/camlp4 -b 4.05
-    (cd camlp4 &&
-     ./configure --bindir=$PREFIX/bin --libdir=$PREFIX/lib/ocaml \
-       --pkgdir=$PREFIX/lib/ocaml && \
-      make && make install)
-    # git clone git://github.com/ocaml/opam
-    # (cd opam && ./configure --prefix $PREFIX &&\
-    #   make lib-ext && make && 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 git://github.com/diml/utop
+    ;;
+  i386)
+    ./configure --prefix $PREFIX -with-debug-runtime \
+      -with-instrumented-runtime $CONFIG_ARG \
+      -host i686-pc-linux-gnu
     ;;
   *)
     echo unknown arch
     exit 1
     ;;
   esac
+
+  export PATH=$PREFIX/bin:$PATH
+  $MAKE world.opt
+  $MAKE ocamlnat
+  (cd testsuite && $MAKE all)
+  [ $XARCH =  "i386" ] ||  (cd testsuite && $MAKE USE_RUNTIME="d" all)
+  $MAKE install
+  $MAKE manual-pregen
+  # check_all_arches checks tries to compile all backends in place,
+  # we would need to redo (small parts of) world.opt afterwards to
+  # use the compiler again
+  $MAKE check_all_arches
 }
 
 CheckChangesModified () {
@@ -96,15 +99,16 @@ on the github pull request.
 ------------------------------------------------------------------------
 EOF
   # check that Changes has been modified
-  git diff $TRAVIS_COMMIT_RANGE --name-only --exit-code Changes > /dev/null \
-  && CheckNoChangesMessage || echo pass
+  git diff $TRAVIS_MERGE_BASE..$TRAVIS_PR_HEAD --name-only --exit-code Changes \
+    > /dev/null && CheckNoChangesMessage || echo pass
 }
 
 CheckNoChangesMessage () {
-  if test -n "$(git log --grep="[Nn]o [Cc]hange.* needed" --max-count=1 $TRAVIS_COMMIT_RANGE)"
+  API_URL=https://api.github.com/repos/$TRAVIS_REPO_SLUG/issues/$TRAVIS_PULL_REQUEST/labels
+  if test -n "$(git log --grep="[Nn]o [Cc]hange.* needed" --max-count=1 \
+    ${TRAVIS_MERGE_BASE}..${TRAVIS_PR_HEAD})"
   then echo pass
-  elif test -n "$(curl https://api.github.com/repos/$TRAVIS_REPO_SLUG/issues/$TRAVIS_PULL_REQUEST/labels \
-       | grep 'no-change-entry-needed')"
+  elif test -n "$(curl $API_URL | grep 'no-change-entry-needed')"
   then echo pass
   else exit 1
   fi
@@ -130,8 +134,8 @@ does *not* imply that your change is appropriately tested.
 ------------------------------------------------------------------------
 EOF
   # check that at least a file in testsuite/ has been modified
-  git diff $TRAVIS_COMMIT_RANGE --name-only --exit-code testsuite > /dev/null \
-  && exit 1 || echo pass
+  git diff $TRAVIS_MERGE_BASE..$TRAVIS_PR_HEAD --name-only --exit-code \
+    testsuite > /dev/null && exit 1 || echo pass
 }
 
 case $CI_KIND in

diff --git a/.travis.yml b/.travis.yml
index 40701ea467c528bf74389b8c46a38608f71edf38..3a220a6a44cc9bac4e73b9269baf894041292ef5 100644 (file)
--- a/.travis.yml
+++ b/.travis.yml
@@ -21,8 +21,26 @@ script: bash -ex .travis-ci.sh
 matrix:
   include:
   - env: CI_KIND=build XARCH=i386
-  - env: CI_KIND=build XARCH=i386 CONFIG_ARG=-flambda OCAMLRUNPARAM=b,v=0
+    addons:
+      apt:
+        packages:
+        - gcc:i386
+        - cpp:i386
+        - binutils:i386
+        - binutils-dev:i386
+        - libx11-dev:i386
+        - libc6-dev:i386
+  - env: CI_KIND=build XARCH=x64
+  - env: CI_KIND=build XARCH=x64 CONFIG_ARG=-flambda OCAMLRUNPARAM=b,v=0
   - env: CI_KIND=changes
   - env: CI_KIND=tests
   allow_failures:
   - env: CI_KIND=tests
+addons:
+  apt:
+    packages:
+    - binutils-dev
+
+notifications:
+  email:
+    - ocaml-ci-notifications@inria.fr

diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md
index fb6fabb3daf6bcdceaa61483e57b8bc42ff57e58..aae6f0ad835a7f24a860d150ac7b122ad7394990 100644 (file)
--- a/CONTRIBUTING.md
+++ b/CONTRIBUTING.md
@@ -35,6 +35,31 @@ proposals against the OCaml distribution. (Code changes, but also
 improvement to documentation or implementation comments, which are
 valuable changes on their own.)
 
+## Workflow
+
+All changes to the OCaml distribution need to be processed through the
+GitHub Pull Request (PR) system.  In order to propose a change, a
+contributor thus needs to have a GitHub account, fork the ocaml/ocaml
+repository, create a branch for the proposal on their fork and submit
+it as a Pull Request on the upstream repository.  (If you are not yet
+familiar with GitHub, don't worry, all these steps are actually quite
+easy!)
+
+The current rule is that a PR needs to get an explicit approval from
+one of the core maintainer in order to be merged.  Reviews by
+external contributors are very much appreciated.
+
+Since core maintainers cannot push directly without going through an
+approved PR, they need to be able to apply small changes to the
+contributed branches themselves.  Such changes include fixing
+conflicts, adjusting a Changelog entry, or applying some code changes
+required by the reviewers.  Contributors are thus strongly advised to
+check the [**Allow edits from maintainer**](
+https://help.github.com/articles/allowing-changes-to-a-pull-request-branch-created-from-a-fork/
+) flag on their PRs in the GitHub interface.  Failing to do so might
+significantly delay the inclusion of an otherwise perfectly ok
+contribution.
+
 
 ## Coding guidelines
 
@@ -176,12 +201,10 @@ Any user-visible change should have a `Changes` entry:
   from a commit message, but it should make sense to end-users
   reading release notes)
 
-- crediting the people that worked on the feature
-
-      The people that wrote the code should be credited of course,
-      but also substantial code reviews or design advice, and the
-      reporter of the bug (if applicable) or designer of the
-      feature request (if novel).
+- crediting the people that worked on the feature. The people that
+  wrote the code should be credited of course, but also substantial
+  code reviews or design advice, and the reporter of the bug
+  (if applicable) or designer of the feature request (if novel).
 
 - following the format
 

diff --git a/Changes b/Changes
index cc59f635ebb9a35f9958f3330e9ac9abc0d9bcaa..3f87e219b4ecd30bb10544141d966547fd78a2c7 100644 (file)
--- a/Changes
+++ b/Changes
@@ -1,3 +1,770 @@
+OCaml 4.06.0 (3 Nov 2017):
+--------------------------
+
+(Changes that can break existing programs are marked with a "*")
+
+### Language features:
+
+- MPR#6271, MPR#7529, GPR#1249: Support "let open M in ..."
+  in class expressions and class type expressions.
+  (Alain Frisch, reviews by Thomas Refis and Jacques Garrigue)
+
+- GPR#792: fix limitations of destructive substitutions, by
+  allowing "S with type t := type-expr",
+  "S with type M.t := type-expr", "S with module M.N := path"
+  (Valentin Gatien-Baron, review by Jacques Garrigue and Leo White)
+
+* GPR#1064, GPR#1392: extended indexing operators, add a new class of
+  user-defined indexing operators, obtained by adding at least
+  one operator character after the dot symbol to the standard indexing
+  operators: e,g ".%()", ".?[]", ".@{}<-":
+    let ( .%() ) = List.nth in [0; 1; 2].%(1)
+  After this change, functions or methods with an explicit polymorphic type
+  annotation and of which the first argument is optional now requires a space
+  between the dot and the question mark,
+  e.g. "<f:'a.?opt:int->unit>" must now be written "<f:'a. ?opt:int->unit>".
+  (Florian Angeletti, review by Damien Doligez and Gabriel Radanne)
+
+- GPR#1118: Support inherited field in object type expression
+    type t = < m : int >
+    type u = < n : int; t; k : int >
+  (Runhang Li, reivew by Jeremy Yallop, Leo White, Jacques Garrigue,
+   and Florian Angeletti)
+
+* GPR#1232: Support Unicode character escape sequences in string
+  literals via the \u{X+} syntax. These escapes are substituted by the
+  UTF-8 encoding of the Unicode character.
+  (Daniel Bünzli, review by Damien Doligez, Alain Frisch, Xavier
+  Leroy and Leo White)
+
+- GPR#1247: M.(::) construction for expressions
+  and patterns (plus fix printing of (::) in the toplevel)
+  (Florian Angeletti, review by Alain Frisch, Gabriel Scherer)
+
+* GPR#1252: The default mode is now safe-string, can be overridden
+  at configure time or at compile time.
+  (See GPR#1386 below for the configure-time options)
+  This breaks the code that uses the 'string' type as mutable
+  strings (instead of Bytes.t, introduced by 4.02 in 2014).
+  (Damien Doligez)
+
+* GPR#1253: Private extensible variants
+  This change breaks code relying on the undocumented ability to export
+  extension constructors for abstract type in signature. Briefly,
+    module type S = sig
+      type t
+      type t += A
+    end
+   must now be written
+    module type S = sig
+      type t = private ..
+      type t += A
+   end
+  (Leo White, review by Alain Frisch)
+
+- GPR#1333: turn off warning 40 by default
+  (Constructor or label name used out of scope)
+  (Leo White)
+
+- GPR#1348: accept anonymous type parameters in `with` constraints:
+    S with type _ t = int
+  (Valentin Gatien-Baron, report by Jeremy Yallop)
+
+### Type system
+
+- MPR#248, GPR#1225: unique names for weak type variables
+    # ref [];;
+    - : '_weak1 list ref = {contents = []}
+  (Florian Angeletti, review by Frédéric Bour, Jacques Garrigue,
+   Gabriel Radanne and Gabriel Scherer)
+
+* MPR#6738, MPR#7215, MPR#7231, GPR#556: Add a new check that 'let rec'
+  bindings are well formed.
+  (Jeremy Yallop, reviews by Stephen Dolan, Gabriel Scherer, Leo
+   White, and Damien Doligez)
+
+- GPR#1142: Mark assertions nonexpansive, so that 'assert false'
+  can be used as a placeholder for a polymorphic function.
+  (Stephen Dolan)
+
+### Standard library:
+
+- MPR#1771, MPR#7309, GPR#1026: Add update to maps. Allows to update a
+  binding in a map or create a new binding if the key had no binding
+    val update: key -> ('a option -> 'a option) -> 'a t -> 'a t
+  (Sébastien Briais, review by Daniel Buenzli, Alain Frisch and
+  Gabriel Scherer)
+
+- MPR#7515, GPR#1147: Arg.align now optionally uses the tab character '\t' to
+  separate the "unaligned" and "aligned" parts of the documentation string. If
+  tab is not present, then space is used as a fallback. Allows to have spaces in
+  the unaligned part, which is useful for Tuple options.
+  (Nicolas Ojeda Bar, review by Alain Frisch and Gabriel Scherer)
+
+* GPR#615: Format, add symbolic formatters that output symbolic
+  pretty-printing items. New fields have been added to the
+  formatter_out_functions record, thus this change will break any code building
+  such record from scratch.
+  When building Format.formatter_out_functions values redefinining the out_spaces field,
+  "{ fmt_out_funs with out_spaces = f; }" should be replaced by
+  "{ fmt_out_funs with out_spaces = f; out_indent = f; }" to maintain the old behavior.
+  (Richard Bonichon and Pierre Weis, review by Alain Frisch, original request by
+  Spiros Eliopoulos in GPR#506)
+
+* GPR#943: Fixed the divergence of the Pervasives module between the stdlib
+  and threads implementations.  In rare circumstances this can change the
+  behavior of existing applications: the implementation of Pervasives.close_out
+  used when compiling with thread support was inconsistent with the manual.
+  It will now not suppress exceptions escaping Pervasives.flush anymore.
+  Developers who want the old behavior should use Pervasives.close_out_noerr
+  instead.  The stdlib implementation, used by applications not compiled
+  with thread support, will now only suppress Sys_error exceptions in
+  Pervasives.flush_all.  This should allow exceedingly unlikely assertion
+  exceptions to escape, which could help reveal bugs in the standard library.
+  (Markus Mottl, review by Hezekiah M. Carty, Jeremie Dimino, Damien Doligez,
+  Alain Frisch, Xavier Leroy, Gabriel Scherer and Mark Shinwell)
+
+- GPR#1034: List.init : int -> (int -> 'a) -> 'a list
+  (Richard Degenne, review by David Allsopp, Thomas Braibant, Florian
+  Angeletti, Gabriel Scherer, Nathan Moreau, Alain Frisch)
+
+- GRP#1091 Add the Uchar.{bom,rep} constants.
+  (Daniel Bünzli, Alain Frisch)
+
+- GPR#1091: Add Buffer.add_utf_{8,16le,16be}_uchar to encode Uchar.t
+  values to the corresponding UTF-X transformation formats in Buffer.t
+  values.
+  (Daniel Bünzli, review by Damien Doligez, Max Mouratov)
+
+- GPR#1175: Bigarray, add a change_layout function to each Array[N]
+  submodules.
+  (Florian Angeletti)
+
+* GPR#1306: In the MSVC and Mingw ports, "Sys.rename src dst" no longer fails if
+  file "dst" exists, but replaces it with file "src", like in the other ports.
+  (Xavier Leroy)
+
+- GPR#1314: Format, use the optional width information
+  when formatting a boolean: "%8B", "%-8B" for example
+  (Xavier Clerc, review by Gabriel Scherer)
+
+- c9cc0f25138ce58e4f4e68c4219afe33e2a9d034: Resurrect tabulation boxes
+  in module Format. Rewrite/extend documentation of tabulation boxes.
+  (Pierre Weis)
+
+### Other libraries:
+
+- MPR#7564, GPR#1211: Allow forward slashes in the target of symbolic links
+  created by Unix.symlink under Windows.
+  (Nicolas Ojeda Bar, review by David Allsopp)
+
+* MPR#7640, GPR#1414: reimplementation of Unix.execvpe to fix issues
+  with the 4.05 implementation.  The main issue is that the current
+  directory was always searched (last), even if the current directory
+  is not listed in the PATH.
+  (Xavier Leroy, report by Louis Gesbert and Arseniy Alekseyev,
+   review by Ivan Gotovchits)
+
+- GPR#997, GPR#1077: Deprecate Bigarray.*.map_file and add Unix.map_file as a
+  first step towards moving Bigarray to the stdlib
+  (Jérémie Dimino and Xavier Leroy)
+
+* GPR#1178: remove the Num library for arbitrary-precision arithmetic.
+  It now lives as a separate project https://github.com/ocaml/num
+  with an OPAM package called "num".
+  (Xavier Leroy)
+
+- GPR#1217: Restrict Unix.environment in privileged contexts; add
+  Unix.unsafe_environment.
+  (Jeremy Yallop, review by Mark Shinwell, Nicolas Ojeda Bar,
+  Damien Doligez and Hannes Mehnert)
+
+- GPR#1321: Reimplement Unix.isatty on Windows. It no longer returns true for
+  the null device.
+  (David Allsopp)
+
+### Compiler user-interface and warnings:
+
+- MPR#7361, GPR#1248: support "ocaml.warning" in all attribute contexts, and
+  arrange so that "ocaml.ppwarning" is correctly scoped by surrounding
+  "ocaml.warning" attributes
+  (Alain Frisch, review by Florian Angeletti and Thomas Refis)
+
+- MPR#7444, GPR#1138: trigger deprecation warning when a "deprecated"
+  attribute is hidden by signature coercion
+  (Alain Frisch, report by bmillwood, review by Leo White)
+
+- MPR#7472: ensure .cmi files are created atomically,
+  to avoid corruption of .cmi files produced simultaneously by a run
+  of ocamlc and a run of ocamlopt.
+  (Xavier Leroy, from a suggestion by Gerd Stolpmann)
+
+* MPR#7514, GPR#1152: add -dprofile option, similar to -dtimings but
+  also displays memory allocation and consumption.
+  The corresponding addition of a new compiler-internal
+  Profile module may affect some users of
+  compilers-libs/ocamlcommon (by creating module conflicts).
+  (Valentin Gatien-Baron, report by Gabriel Scherer)
+
+- MPR#7620, GPR#1317: Typecore.force_delayed_checks does not run with -i option
+  (Jacques Garrigue, report by Jun Furuse)
+
+- MPR#7624: handle warning attributes placed on let bindings
+  (Xavier Clerc, report by dinosaure, review by Alain Frisch)
+
+- GPR#896: "-compat-32" is now taken into account when building .cmo/.cma
+  (Hugo Heuzard)
+
+- GPR#948: the compiler now reports warnings-as-errors by prefixing
+  them with "Error (warning ..):", instead of "Warning ..:" and
+  a trailing "Error: Some fatal warnings were triggered" message.
+  (Valentin Gatien-Baron, review by Alain Frisch)
+
+- GPR#1032: display the output of -dtimings as a hierarchy
+  (Valentin Gatien-Baron, review by Gabriel Scherer)
+
+- GPR#1114, GPR#1393, GPR#1429: refine the (ocamlc -config) information
+  on C compilers: the variables `{bytecode,native}_c_compiler` are deprecated
+  (the distinction is now mostly meaningless) in favor of a single
+  `c_compiler` variable combined with `ocaml{c,opt}_cflags`
+  and `ocaml{c,opt}_cppflags`.
+  (Sébastien Hinderer, Jeremy Yallop, Gabriel Scherer, review by
+   Adrien Nader and David Allsopp)
+
+* GPR#1189: allow MSVC ports to use -l option in ocamlmklib
+  (David Allsopp)
+
+- GPR#1332: fix ocamlc handling of "-output-complete-obj"
+  (François Bobot)
+
+- GPR#1336: -thread and -vmthread option information is propagated to
+  PPX rewriters.
+  (Jun Furuse, review by Alain Frisch)
+
+### Code generation and optimizations:
+
+- MPR#5324, GPR#375: An alternative Linear Scan register allocator for
+  ocamlopt, activated with the -linscan command-line flag. This
+  allocator represents a trade-off between worse generated code
+  performance for higher compilation speed (especially interesting in
+  some cases graph coloring is necessarily quadratic).
+  (Marcell Fischbach and Benedikt Meurer, adapted by Nicolas Ojeda
+  Bar, review by Nicolas Ojeda Bar and Alain Frisch)
+
+- MPR#6927, GPR#988: On macOS, when compiling bytecode stubs, plugins,
+  and shared libraries through -output-obj, generate dylibs instead of
+  bundles.
+  (whitequark)
+
+- MPR#7447, GPR#995: incorrect code generation for nested recursive bindings
+  (Leo White and Jeremy Yallop, report by Stephen Dolan)
+
+- MPR#7501, GPR#1089: Consider arrays of length zero as constants
+  when using Flambda.
+  (Pierre Chambart, review by Mark Shinwell and Leo White)
+
+- MPR#7531, GPR#1162: Erroneous code transformation at partial applications
+  (Mark Shinwell)
+
+- MPR#7614, GPR#1313: Ensure that inlining does not depend on the order
+  of symbols (flambda)
+  (Leo White, Xavier Clerc, report by Alex, review by Gabriel Scherer
+  and Pierre Chambart)
+
+- MPR#7616, GPR#1339: don't warn on mutation of zero size blocks.
+  (Leo White)
+
+- MPR#7631, GPR#1355: "-linscan" option crashes ocamlopt
+  (Xavier Clerc, report by Paul Steckler)
+
+- MPR#7642, GPR#1411: ARM port: wrong register allocation for integer
+  multiply on ARMv4 and ARMv5; possible wrong register allocation for
+  floating-point multiply and add on VFP and for floating-point
+  negation and absolute value on soft FP emulation.
+  (Xavier Leroy, report by Stéphane Glondu and Ximin Luo,
+   review and additional sightings by Mark Shinwell)
+
+* GPR#659: Remove support for SPARC native code generation
+  (Mark Shinwell)
+
+- GPR#850: Optimize away some physical equality
+  (Pierre Chambart, review by Mark Shinwell and Leo White)
+
+- GPR#856: Register availability analysis
+  (Mark Shinwell, Thomas Refis, review by Pierre Chambart)
+
+- GPR#1143: tweaked several allocation functions in the runtime by
+  checking for likely conditions before unlikely ones and eliminating
+  some redundant checks.
+  (Markus Mottl, review by Alain Frisch, Xavier Leroy, Gabriel Scherer,
+  Mark Shinwell and Leo White)
+
+- GPR#1183: compile curried functors to multi-argument functions
+  earlier in the compiler pipeline; correctly propagate [@@inline]
+  attributes on such functors; mark functor coercion veneers as
+  stubs.
+  (Mark Shinwell, review by Pierre Chambart and Leo White)
+
+- GPR#1195: Merge functions based on partiality rather than
+  Parmatch.irrefutable.
+  (Leo White, review by Thomas Refis, Alain Frisch and Gabriel Scherer)
+
+- GPR#1215: Improve compilation of short-circuit operators
+  (Leo White, review by Frédéric Bour and Mark Shinwell)
+
+- GPR#1250: illegal ARM64 assembly code generated for large combined allocations
+  (report and initial fix by Steve Walk, review and final fix by Xavier Leroy)
+
+- GPR#1271: Don't generate Ialloc instructions for closures that exceed
+  Max_young_wosize; instead allocate them on the major heap.  (Related
+  to GPR#1250.)
+  (Mark Shinwell)
+
+- GPR#1294: Add a configure-time option to remove the dynamic float array
+  optimization and add a floatarray type to let the user choose when to
+  flatten float arrays. Note that float-only records are unchanged: they
+  are still optimized by unboxing their fields.
+  (Damien Doligez, review by Alain Frisch and Mark Shinwell)
+
+- GPR#1304: Mark registers clobbered by PLT stubs as destroyed across
+  allocations.
+  (Mark Shinwell, Xavier Clerc, report and initial debugging by
+  Valentin Gatien-Baron)
+
+- GPR#1323: make sure that frame tables are generated in the data
+  section and not in the read-only data section, as was the case
+  before in the PPC and System-Z ports.  This avoids relocations in
+  the text segment of shared libraries and position-independent
+  executables generated by ocamlopt.
+  (Xavier Leroy, review by Mark Shinwell)
+
+- GPR#1330: when generating dynamically-linkable code on AArch64, always
+  reference symbols (even locally-defined ones) through the GOT.
+  (Mark Shinwell, review by Xavier Leroy)
+
+### Tools:
+
+- MPR#1956, GPR#973: tools/check-symbol-names checks for globally
+  linked names not namespaced with caml_
+  (Stephen Dolan)
+
+- MPR#6928, GPR#1103: ocamldoc, do not introduce an empty <h1> in index.html
+  when no -title has been provided
+  (Pierre Boutillier)
+
+- MPR#7048: ocamldoc, in -latex mode, don't escape Latin-1 accented letters
+  (Xavier Leroy, report by Hugo Herbelin)
+
+* MPR#7351: ocamldoc, use semantic tags rather than <br> tags in the html
+  backend
+  (Florian Angeletti, request and review by Daniel Bünzli )
+
+* MPR#7352, MPR#7353: ocamldoc, better paragraphs in html output
+  (Florian Angeletti, request by Daniel Bünzli)
+
+* MPR#7363, GPR#830: ocamldoc, start heading levels at {1 not {2 or {6.
+  This change modifies the mapping between ocamldoc heading level and
+  html heading level, breaking custom css style for ocamldoc.
+  (Florian Angeletti, request and review by Daniel Bünzli)
+
+* MPR#7478, GPR#1037: ocamldoc, do not use as a module preamble documentation
+  comments that occur after the first module element. This change may break
+  existing documenation. In particular, module preambles must now come before
+  any `open` statement.
+  (Florian Angeletti, review by David Allsopp and report by Daniel Bünzli)
+
+- MPR#7521, GPR#1159: ocamldoc, end generated latex file with a new line
+  (Florian Angeletti)
+
+- MPR#7575, GPR#1219: Switch compilers from -no-keep-locs
+  to -keep-locs by default: produced .cmi files will contain locations.
+  This provides better error messages. Note that, as a consequence,
+  .cmi digests now depend on the file path as given to the compiler.
+  (Daniel Bünzli)
+
+- MPR#7610, GPR#1346: caml.el (the Emacs editing mode) was cleaned up
+  and made compatible with Emacs 25.
+  (Stefan Monnier, Christophe Troestler)
+
+- MPR#7635, GPR#1383: ocamldoc, add an identifier to module
+  and module type elements
+  (Florian Angeletti, review by Yawar Amin and Gabriel Scherer)
+
+- GPR#681, GPR#1426: Introduce ocamltest, a new test driver for the
+  OCaml compiler testsuite
+  (Sébastien Hinderer, review by Damien Doligez)
+
+- GPR#1012: ocamlyacc, fix parsing of raw strings and nested comments, as well
+  as the handling of ' characters in identifiers.
+  (Demi Obenour)
+
+- GPR#1045: ocamldep, add a "-shared" option to generate dependencies
+  for native plugin files (i.e. .cmxs files)
+  (Florian Angeletti, suggestion by Sébastien Hinderer)
+
+- GPR#1078: add a subcommand "-depend" to "ocamlc" and "ocamlopt",
+  to behave as ocamldep. Should be used mostly to replace "ocamldep" in the
+  "boot" directory to reduce its size in the future.
+  (Fabrice Le Fessant)
+
+- GPR#1036: ocamlcmt (tools/read_cmt) is installed, converts .cmt to .annot
+  (Fabrice Le Fessant)
+
+- GPR#1180: Add support for recording numbers of direct and indirect
+  calls over the lifetime of a program when using Spacetime profiling
+  (Mark Shinwell)
+
+- GPR#1457, ocamldoc: restore label for exception in the latex backend
+  (omitted since 4.04.0)
+  (Florian Angeletti, review by Gabriel Scherer)
+
+### Toplevel:
+
+- MPR#7570: remove unusable -plugin option from the toplevel
+  (Florian Angeletti)
+
+- GPR#1041: -nostdlib no longer ignored by toplevel.
+  (David Allsopp, review by Xavier Leroy)
+
+- GPR#1231: improved printing of unicode texts in the toplevel,
+  unless OCAMLTOP_UTF_8 is set to false.
+  (Florian Angeletti, review by Daniel Bünzli, Xavier Leroy and
+   Gabriel Scherer)
+
+### Runtime system:
+
+* MPR#3771, GPR#153, GPR#1200, GPR#1357, GPR#1362, GPR#1363, GPR#1369, GPR#1398,
+  GPR#1446, GPR#1448: Unicode support for the Windows runtime.
+  (ygrek, Nicolas Ojeda Bar, review by Alain Frisch, David Allsopp, Damien
+  Doligez)
+
+* MPR#7594, GPR#1274, GPR#1368: String_val now returns 'const char*', not
+  'char*' when -safe-string is enabled at configure time.  New macro Bytes_val
+  for accessing bytes values.
+  (Jeremy Yallop, reviews by Mark Shinwell and Xavier Leroy)
+
+- GPR#71: The runtime can now be shut down gracefully by means of the new
+  caml_shutdown and caml_startup_pooled functions. The new 'c' flag in
+  OCAMLRUNPARAM enables shutting the runtime properly on process exit.
+  (Max Mouratov, review and discussion by Damien Doligez, Gabriel Scherer,
+  Mark Shinwell, Thomas Braibant, Stephen Dolan, Pierre Chambart,
+  François Bobot, Jacques Garrigue, David Allsopp, and Alain Frisch)
+
+- GPR#938, GPR#1170, GPR#1289: Stack overflow detection on 64-bit Windows
+  (Olivier Andrieu, tweaked by David Allsopp)
+
+- GPR#1070, GPR#1295: enable gcc typechecking for caml_alloc_sprintf,
+  caml_gc_message. Make caml_gc_message a variadic function. Fix many
+  caml_gc_message format strings.
+  (Olivier Andrieu, review and 32bit fix by David Allsopp)
+
+- GPR#1073: Remove statically allocated compare stack.
+  (Stephen Dolan)
+
+- GPR#1086: in Sys.getcwd, just fail instead of calling getwd()
+  if HAS_GETCWD is not set.
+  (Report and first fix by Sebastian Markbåge, final fix by Xavier Leroy,
+   review by MarK Shinwell)
+
+- GPR#1269: Remove 50ms delay at exit for programs using threads
+  (Valentin Gatien-Baron, review by Stephen Dolan)
+
+* GPR#1309: open files with O_CLOEXEC (or equivalent) in caml_sys_open, thus
+  unifying the semantics between Unix and Windows and also eliminating race
+  condition on Unix.
+  (David Allsopp, report by Andreas Hauptmann)
+
+- GPR#1326: Enable use of CFI directives in AArch64 and ARM runtime
+  systems' assembly code (asmrun/arm64.S).  Add CFI directives to enable
+  unwinding through [caml_c_call] and [caml_call_gc] with correct termination
+  of unwinding at [main].
+  (Mark Shinwell, review by Xavier Leroy and Gabriel Scherer, with thanks
+  to Daniel Bünzli and Fu Yong Quah for testing)
+
+- GPR#1338: Add "-g" for bytecode runtime system compilation
+  (Mark Shinwell)
+
+* GPR#1416, GPR#1444: switch the Windows 10 Console to UTF-8 encoding.
+  (David Allsopp, reviews by Nicolás Ojeda Bär and Xavier Leroy)
+
+### Manual and documentation:
+
+- MPR#6548: remove obsolete limitation in the description of private
+  type abbreviations
+  (Florian Angeletti, suggestion by Leo White)
+
+- MPR#6676, GPR#1110: move record notation to tutorial
+  (Florian Angeletti, review by Gabriel Scherer)
+
+- MPR#6676, GPR#1112: move local opens to tutorial
+  (Florian Angeletti)
+
+- MPR#6676, GPR#1153: move overriding class definitions to reference
+  manual and tutorial
+  (Florian Angeletti)
+
+- MPR#6709: document the associativity and precedence level of
+  pervasive operators
+  (Florian Angeletti, review by David Allsopp)
+
+- MPR#7254, GPR#1096: Rudimentary documentation of ocamlnat
+  (Mark Shinwell)
+
+- MPR#7281, GPR#1259: fix .TH macros in generated manpages
+  (Olaf Hering)
+
+- MPR#7507: Align the description of the printf conversion
+  specification "%g" with the ISO C90 description.
+  (Florian Angeletti, suggestion by Armaël Guéneau)
+
+- MPR#7551, GPR#1194 : make the final ";;" potentially optional in
+  caml_example
+  (Florian Angeletti, review and suggestion by Gabriel Scherer)
+
+- MPR#7588, GPR#1291: make format documentation predictable
+  (Florian Angeletti, review by Gabriel Radanne)
+
+- MPR#7604: Minor Ephemeron documentation fixes
+  (Miod Vallat, review by Florian Angeletti)
+
+- GPR#594: New chapter on polymorphism troubles:
+  weakly polymorphic types, polymorphic recursion,and higher-ranked
+  polymorphism.
+  (Florian Angeletti, review by Damien Doligez, Gabriel Scherer,
+   and Gerd Stolpmann)
+
+- GPR#1187: Minimal documentation for compiler plugins
+  (Florian Angeletti)
+
+- GPR#1202: Fix Typos in comments as well as basic grammar errors.
+  (JP Rodi, review and suggestions by David Allsopp, Max Mouratov,
+  Florian Angeletti, Xavier Leroy, Mark Shinwell and Damien Doligez)
+
+- GPR#1220: Fix "-keep-docs" option in ocamlopt manpage
+  (Etienne Millon)
+
+### Compiler distribution build system:
+
+- MPR#6373, GPR#1093: Suppress trigraph warnings from macOS assembler
+  (Mark Shinwell)
+
+- MPR#7639, GPR#1371: fix configure script for correct detection of
+  int64 alignment on Mac OS X 10.13 (High Sierra) and above; fix bug in
+  configure script relating to such detection.
+  (Mark Shinwell, report by John Whitington, review by Xavier Leroy)
+
+- GPR#558: enable shared library and natdynlink support on more Linux
+  platforms
+  (Felix Janda, Mark Shinwell)
+
+* GPR#1104: remove support for the NeXTStep platform
+  (Sébastien Hinderer)
+
+- GPR#1130: enable detection of IBM XL C compiler (one need to run configure
+  with "-cc <path to xlc compiler>"). Enable shared library support for
+  bytecode executables on AIX/xlc (tested on AIX 7.1, XL C 12).
+  To enable 64-bit, run both "configure" and "make world" with OBJECT_MODE=64.
+  (Konstantin Romanov, Enrique Naudon)
+
+- GPR#1203: speed up the manual build by using ocamldoc.opt
+  (Gabriel Scherer, review by Florian Angeletti)
+
+- GPR#1214: harden config/Makefile against '#' characters in PREFIX
+  (Gabriel Scherer, review by David Allsopp and Damien Doligez)
+
+- GPR#1216: move Compplugin and friends from BYTECOMP to COMP
+  (Leo White, review by Mark Shinwell)
+
+* GPR#1242: disable C plugins loading by default
+  (Alexey Egorov)
+
+- GPR#1275: correct configure test for Spacetime availability
+  (Mark Shinwell)
+
+- GPR#1278: discover presence of <sys/shm.h> during configure for afl runtime
+  (Hannes Mehnert)
+
+- GPR#1386: provide configure-time options to fine-tune the safe-string
+  options and default settings changed by GPR#1525.
+
+  The previous configure option -safe-string is now
+  renamed -force-safe-string.
+
+  At configure-time, -force-safe-string forces all module to use
+  immutable strings (this disables the per-file, compile-time
+  -unsafe-string option). The new default-(un)safe-string options
+  let you set the default choice for the per-file compile-time
+  option. (The new GPR#1252 behavior corresponds to having
+  -default-safe-string, while 4.05 and older had
+  -default-unsafe-string).
+
+  (Gabriel Scherer, review by Jacques-Pascal Deplaix and Damien Doligez)
+
+- GPR#1409: Fix to enable NetBSD/powerpc to work.
+  (Håvard Eidnes)
+
+### Internal/compiler-libs changes:
+
+- MPR#6826, GPR#828, GPR#834: improve compilation time for open
+  (Alain Frisch, review by Frédéric Bour and Jacques Garrigue)
+
+- MPR#7127, GPR#454, GPR#1058: in toplevel, print bytes and strip
+  strings longer than the size specified by the "print_length" directive
+  (Fabrice Le Fessant, initial PR by Junsong Li)
+
+- GPR#406: remove polymorphic comparison for Types.constructor_tag in compiler
+  (Dwight Guth, review by Gabriel Radanne, Damien Doligez, Gabriel Scherer,
+   Pierre Chambart, Mark Shinwell)
+
+- GRP#1119: Change Set (private) type to inline records.
+  (Albin Coquereau)
+
+* GPR#1127: move config/{m,s}.h to byterun/caml and install them.
+  User code should not have to include them directly since they are
+  included by other header files.
+  Previously {m,s}.h were not installed but they were substituted into
+  caml/config.h; they are now just #include-d by this file. This may
+  break some scripts relying on the (unspecified) presence of certain
+  #define in config.h instead of m.h and s.h -- they can be rewritten
+  to try to grep those files if they exist.
+  (Sébastien Hinderer)
+
+- GPR#1281: avoid formatter flushes inside exported printers in Location
+  (Florian Angeletti, review by Gabriel Scherer)
+
+### Bug fixes
+
+- MPR#5927: Type equality broken for conjunctive polymorphic variant tags
+  (Jacques Garrigue, report by Leo White)
+
+- MPR#6329, GPR#1437: Introduce padding word before "data_end" symbols
+  to ensure page table tests work correctly on an immediately preceding
+  block of zero size.
+  (Mark Shinwell, review by Xavier Leroy)
+
+- MPR#6587: only elide Pervasives from printed type paths in unambiguous context
+  (Florian Angeletti and Jacques Garrigue)
+
+- MPR#6934: nonrec misbehaves with GADTs
+  (Jacques Garrigue, report by Markus Mottl)
+
+- MPR#7070, GPR#1139: Unexported values can cause non-generalisable variables
+  error
+  (Leo White)
+
+- MPR#7261: Warn on type constraints in GADT declarations
+  (Jacques Garrigue, report by Fabrice Le Botlan)
+
+- MPR#7321: Private type in signature clashes with type definition via
+  functor instantiation
+  (Jacques Garrigue, report by Markus Mottl)
+
+- MPR#7372, GPR#834: fix type-checker bug with GADT and inline records
+  (Alain Frisch, review by Frédéric Bour and Jacques Garrigue)
+
+- MPR#7344: Inconsistent behavior with type annotations on let
+  (Jacques Garrigue, report by Leo White)
+
+- MPR#7468: possible GC problem in caml_alloc_sprintf
+  (Xavier Leroy, discovery by Olivier Andrieu)
+
+- MPR#7496: Fixed conjunctive polymorphic variant tags do not unify
+  with themselves
+  (Jacques Garrigue, report by Leo White)
+
+- MPR#7506: pprintast ignores attributes in tails of a list
+  (Alain Frisch, report by Kenichi Asai and Gabriel Scherer)
+
+- MPR#7513: List.compare_length_with mishandles negative numbers / overflow
+  (Fabrice Le Fessant, report by Jeremy Yallop)
+
+- MPR#7519: Incorrect rejection of program due to faux scope escape
+  (Jacques Garrigue, report by Markus Mottl)
+
+- MPR#7540, GPR#1179: Fixed setting of breakpoints within packed modules
+  for ocamldebug
+  (Hugo Herbelin, review by Gabriel Scherer, Damien Doligez)
+
+- MPR#7543: short-paths printtyp can fail on packed type error messages
+  (Florian Angeletti)
+
+- MPR#7553, GPR#1191: Prevent repeated warnings with recursive modules.
+  (Leo White, review by Josh Berdine and Alain Frisch)
+
+- MPR#7563, GPR#1210: code generation bug when a module alias and
+  an extension constructor have the same name in the same module
+  (Gabriel Scherer, report by Manuel Fähndrich,
+   review by Jacques Garrigue and Leo White)
+
+- MPR#7591, GPR#1257: on x86-64, frame table is not 8-aligned
+  (Xavier Leroy, report by Mantis user "voglerr", review by Gabriel Scherer)
+
+- MPR#7601, GPR#1320: It seems like a hidden non-generalized type variable
+  remains in some inferred signatures, which leads to strange errors
+  (Jacques Garrigue, report by Mandrikin)
+
+- MPR#7609: use-after-free memory corruption if a program debugged
+  under ocamldebug calls Pervasives.flush_all
+  (Xavier Leroy, report by Paul Steckler, review by Gabriel Scherer)
+
+- MPR#7612, GPR#1345: afl-instrumentation bugfix for classes.
+  (Stephen Dolan, review by Gabriel Scherer and David Allsopp)
+
+- MPR#7617, MPR#7618, GPR#1318: Ambiguous (mistakenly) type escaping the
+  scope of its equation
+  (Jacques Garrigue, report by Thomas Refis)
+
+- MPR#7619, GPR#1387: position of the optional last semi-column not included
+  in the position of the expression (same behavior as for lists)
+  (Christophe Raffalli, review by Gabriel Scherer)
+
+- MPR#7638: in the Windows Mingw64 port, multithreaded programs compiled
+  to bytecode could crash when raising an exception from C code.
+  This looks like a Mingw64 issue, which we work around with GCC builtins.
+  (Xavier Leroy)
+
+- MPR#7656, GPR#1423: false 'unused type/constructor/value' alarms
+  in the 4.06 development version
+  (Alain Frisch, review by Jacques Garrigue, report by Jacques-Pascal Deplaix)
+
+- MPR#7657, GPR#1424: ensures correct call-by-value semantics when
+  eta-expanding functions to eliminate optional arguments
+  (Alain Frisch, report by sliquister, review by Leo White and Jacques
+  Garrigue)
+
+- MPR#7658, GPR#1439: Fix Spacetime runtime system compilation with
+  -force-safe-string
+  (Mark Shinwell, report by Christoph Spiel, review by Gabriel Scherer)
+
+- GPR#1155: Fix a race condition with WAIT_NOHANG on Windows
+  (Jérémie Dimino and David Allsopp)
+
+- GPR#1199: Pretty-printing formatting cleanup in pprintast
+  (Ethan Aubin, suggestion by Gabriel Scherer, review by David Allsopp,
+  Florian Angeletti, and Gabriel Scherer)
+
+- GPR#1223: Fix corruption of the environment when using -short-paths
+  with the toplevel.
+  (Leo White, review by Alain Frisch)
+
+- GPR#1243: Fix pprintast for #... infix operators
+  (Alain Frisch, report by Omar Chebib)
+
+- GPR#1324: ensure that flambda warning are printed only once
+  (Xavier Clerc)
+
+- GPR#1329: Prevent recursive polymorphic variant names
+  (Jacques Garrigue, fix suggested by Leo White)
+
+- GPR#1308: Only treat pure patterns as inactive
+  (Leo White, review by Alain Frisch and Gabriel Scherer)
+
+- GPR#1390: fix the [@@unboxed] type check to accept parametrized types
+  (Leo White, review by Damien Doligez)
+
+- GPR#1407: Fix raw_spacetime_lib
+  (Leo White, review by Gabriel Scherer and Damien Doligez)
+
 OCaml 4.05.0 (13 Jul 2017):
 ---------------------------
 
@@ -64,6 +831,9 @@ OCaml 4.05.0 (13 Jul 2017):
 
 * MPR#7414, GPR#929: Soundness bug with non-generalized type variables and
   functors.
+  (compatibility: some code using module-global mutable state will
+   fail at compile-time and is fixed by adding extra annotations;
+   see the Mantis and Github discussions.)
   (Jacques Garrigue, report by Leo White)
 
 ### Compiler user-interface and warnings:
@@ -121,7 +891,8 @@ OCaml 4.05.0 (13 Jul 2017):
   (Xavier Leroy)
 
 - GPR#1015: add option "-plugin PLUGIN" to ocamldep too. Use compilerlibs
-  to build ocamldep.
+  to build ocamldep. Add option "-depend" to ocamlc/ocamlopt to behave
+  as ocamldep. Remove any use of ocamldep to build the distribution.
   (Fabrice Le Fessant)
 
 - GPR#1027: various improvements to -dtimings, mostly including time
@@ -266,6 +1037,10 @@ OCaml 4.05.0 (13 Jul 2017):
 - GPR#996: correctly update caml_top_of_stack in systhreads
   (Fabrice Le Fessant)
 
+- GPR#997, GPR#1077: Deprecate Bigarray.*.map_file and add Unix.map_file as a
+  first step towards moving Bigarray to the stdlib
+  (Jérémie Dimino and Xavier Leroy)
+
 ### Toplevel:
 
 - MPR#7060, GPR#1035: Print exceptions in installed custom printers
@@ -518,15 +1293,15 @@ The complete list of changes is listed below.
 - MPR#7443, GPR#990: spurious unused open warning with local open in patterns
   (Florian Angeletti, report by Gabriel Scherer)
 
-- MPR#7504: fix warning 8 with unconstrained records
-  (Florian Angeletti, report by John Whitington)
-
 - MPR#7456, GPR#1092: fix slow compilation on source files containing a lot
   of similar debugging information location entries
   (Mark Shinwell)
 
-- GPR#795: remove 256-character limitation on Sys.executable_name
-  (Xavier Leroy)
+- MPR#7504: fix warning 8 with unconstrained records
+  (Florian Angeletti, report by John Whitington)
+
+- MPR#7511, GPR#1133: Unboxed type with unboxed argument should not be accepted
+  (Damien Doligez, review by Jeremy Yallop and Leo White)
 
 - GPR#805, GPR#815, GPR#833: check for integer overflow in String.concat
   (Jeremy Yallop,
@@ -567,6 +1342,9 @@ The complete list of changes is listed below.
   (Mark Shinwell, Leo White, review by Xavier Leroy)
 
 * GPR#1088: Gc.minor_words now returns accurate numbers.
+  (compatibility: the .mli declaration of `Gc.minor_words`
+   and `Gc.get_minor_free` changed, which may break libraries
+   re-exporting these values.)
   (Stephen Dolan, review by Pierre Chambart and Xavier Leroy)
 
 OCaml 4.04.2 (23 Jun 2017):
@@ -580,10 +1358,6 @@ OCaml 4.04.2 (23 Jun 2017):
 OCaml 4.04.1 (14 Apr 2017):
 ---------------------------
 
-- PR#7501, GPR#1089: Consider arrays of length zero as constants
-  when using Flambda.
-  (Pierre Chambart, review by Mark Shinwell and Leo White)
-
 ### Standard library:
 
 - PR#7403, GPR#894: fix a bug in Set.map as introduced in 4.04.0
@@ -645,9 +1419,6 @@ OCaml 4.04.1 (14 Apr 2017):
     Bigarray.Genarray.change_layout.
   (Damien Doligez and Xavier Leroy, report by Liang Wang)
 
-- PR#7511, GPR#1133: Unboxed type with unboxed argument should not be accepted
-  (Damien Doligez, review by Jeremy Yallop and Leo White)
-
 - GPR#912: Fix segfault in Unix.create_process on Windows caused by wrong header
   configuration.
   (David Allsopp)
@@ -985,6 +1756,10 @@ OCaml 4.04.0 (4 Nov 2016):
   it now calls (nano)sleep for 0 seconds as in (< 4.03) versions.
   (Hannes Mehnert, review by Damien Doligez)
 
+- PR#7259 and GPR#603: flambda does not collapse pattern matching
+  in some cases
+  (Pierre Chambart, report by Reed Wilson, review by Mark Shinwell)
+
 - PR#7260: GADT + subtyping compile time crash
   (Jacques Garrigue, report by Nicolas Ojeda Bar)
 
@@ -1067,6 +1842,8 @@ OCaml 4.04.0 (4 Nov 2016):
 
 - GPR#880: Fix [@@inline] with default parameters in flambda (Leo White)
 
+* GPR#1353: add labels to BytesLabels.sub_string (Jacques Garrigue)
+
 ### Internal/compiler-libs changes:
 
 - PR#7200, GPR#539: Improve, fix, and add test for parsing/pprintast.ml

diff --git a/HACKING.adoc b/HACKING.adoc
index 44557b02da68a999c9dd9b1fb95800b0e38a63d2..9de68b54c680d08f5bf0a3b1442e9388e0fbc34f 100644 (file)
--- a/HACKING.adoc
+++ b/HACKING.adoc
@@ -1,4 +1,4 @@
-= Hacking the compiler 🐫
+= Hacking the compiler :camel:
 
 This document is a work-in-progress attempt to provide useful
 information for people willing to inspect or modify the compiler
@@ -58,8 +58,9 @@ newcomers. Here are various potential projects:
 * http://caml.inria.fr/mantis/view_all_bug_page.php[The OCaml
   bugtracker] contains reported bugs and feature requests. Some
   changes that should be accessible to newcomers are marked with the
-  tag
-  http://caml.inria.fr/mantis/search.php?project_id=1&sticky_issues=1&sortby=last_updated&dir=DESC&highlight_changed=24&hide_status_id=90&tag_string=junior_job[junior_job].
+  tag link:++http://caml.inria.fr/mantis/search.php?
+project_id=1&sticky_issues=1&sortby=last_updated&dir=DESC&highlight_changed=24&hide_status_id=90&tag_string=junior_job++[
+  junior_job].
 
 * The
   https://github.com/ocamllabs/compiler-hacking/wiki/Things-to-work-on[OCaml
@@ -109,8 +110,8 @@ Parses source files and produces an Abstract Syntax Tree (AST)
 link:parsing/HACKING.adoc[].
 
 The logic for Camlp4 and Ppx preprocessing is not in link:parsing/[],
-but in link:driver/[], see link:driver/pparse.mli[],
-link:driver/pparse.mli[].
+but in link:driver/[], see link:driver/pparse.mli[] and
+link:driver/pparse.ml[].
 
 ==== Typing -- link:typing/[]
 
@@ -132,6 +133,17 @@ independent and should not need further knowledge.
 link:otherlibs/[]:: External libraries such as `unix`, `threads`,
 `dynlink`, `str` and `bigarray`.
 
+Instructions for building the full reference manual are provided in
+link:manual/README.md[]. However, if you only modify the documentation
+comments in `.mli` files in the compiler codebase, you can observe the
+result by running
+
+----
+make html_doc
+----
+
+and then opening link:./ocamldoc/stdlib_html/index.html[] in a web browser.
+
 === Tools
 
 link:lex/[]:: The `ocamllex` lexer generator.
@@ -153,7 +165,6 @@ has excellent documentation.
   LICENSE::               license and copyright notice
   Makefile::              main Makefile
   Makefile.nt::           Windows Makefile (deprecated)
-  Makefile.shared::       common Makefile
   Makefile.tools::        used by manual/ and testsuite/ Makefiles
   README.adoc::           general information on the compiler distribution
   README.win32.adoc::     general information on the Windows ports of OCaml
@@ -224,6 +235,32 @@ found in link:INSTALL.adoc#bootstrap[INSTALL.adoc].
 
 ==== Github's CI: Travis and AppVeyor
 
+The script that is run on Travis continuous integration servers is
+link:.travis-ci.sh[]; its configuration can be found as
+a Travis configuration file in link:.travis.yml[].
+
+For example, if you want to reproduce the default build on your
+machine, you can use the configuration values and run command taken from
+link:.travis.yml[]:
+
+----
+CI_KIND=build XARCH=x64 bash -ex .travis-ci.sh
+----
+
+The scripts support two other kinds of tests (values of the
+`CI_KIND` variable) which both inspect the patch submitted as part of
+a pull request. `tests` checks that the testsuite has been modified
+(hopefully, improved) by the patch, and `changes` checks that the
+link:Changes[] file has been modified (hopefully to add a new entry).
+
+These tests rely on the `$TRAVIS_COMMIT_RANGE` variable which you can
+set explicitly to reproduce them locally.
+
+The `changes` check can be disabled by including "(no change
+entry needed)" in one of your commit messages -- but in general all
+patches submitted should come with a Changes entry; see the guidelines
+in link:CONTRIBUTING.md[].
+
 ==== INRIA's Continuous Integration (CI)
 
 INRIA provides a Jenkins continuous integration service that OCaml
@@ -235,26 +272,39 @@ PR.
 
 You do not need to be an INRIA employee to open an account on this
 jenkins service; anyone can create an account there to access build
-logs, enable email notifications, and manually restart builds. If you
-would like to do this but have trouble doing it, please contact Damien
-Doligez or Gabriel Scherer.
+logs and manually restart builds. If you
+would like to do this but have trouble doing it, please email
+ocaml-ci-admin@inria.fr
+
+To be notified by email of build failures, you can subscribe to the
+ocaml-ci-notifications@inria.fr mailing list by visiting
+https://sympa.inria.fr/sympa/info/ocaml-ci-notifications[its web page]
 
-==== Running INRIA's CI on a github Pull Request (PR)
+==== Running INRIA's CI on a publicly available git branch
 
-If you have suspicions that a PR may fail on exotic architectures
-(it touches the build system or the backend code generator,
+If you have suspicions that your changes may fail on exotic architectures
+(they touch the build system or the backend code generator,
 for example) and would like to get wider testing than github's CI
 provides, it is possible to manually start INRIA's CI on arbitrary git
-branches by pushing to a `precheck` branch of the main repository.
+branches even before opening a pull request as follows:
+
+1. Make sure you have an account on Inria's CI as described before.
+
+2. Make sure you have been added to the ocaml project.
+
+3. Prepare a branch with the code you'd like to test, say "mybranch". It
+is probably a good idea to make sure your branch is based on the latest
+trunk.
+
+4. Make your branch publicly available. For instance, you can fork
+OCaml's GitHub repository and then push "mybranch" to your fork.
 
-This is done by pushing to a specific github repository that the CI
-watches, namely
-link:https://github.com/ocaml/precheck[ocaml/precheck]. You thus need
-to have write/push/commit access to this repository to perform this operation.
+5. Visit https://ci.inria.fr/ocaml/job/precheck and log in. Click on
+"Build with parameters".
 
-Just checkout the commit/branch you want to test, then run
+6. Fill in the REPO_URL and BRANCH fields as appropriate and run the build.
 
- git push --force git@github.com:ocaml/precheck.git HEAD:trunk
+7. You should receive a bunch of e-mails with the build logs for each
+slave and each tested configuration (with and without flambda) attached.
 
-(This is the syntax to push the current `HEAD` state into the `trunk`
-reference on the specified remote.)
\ No newline at end of file
+Happy Hacking!

diff --git a/INSTALL.adoc b/INSTALL.adoc
index 835d21b98bc1f650575d1a3acc6cbfd12a408476..03a00b62295de56fb21c78a399a4619466135378 100644 (file)
--- a/INSTALL.adoc
+++ b/INSTALL.adoc
@@ -25,8 +25,8 @@
 
         ./configure
 +
-This generates the three configuration files `Makefile`, `m.h` and `s.h`
-in the `config/` subdirectory.
+This generates the three configuration files `config/Makefile`,
+`byterun/caml/m.h` and `byterun/caml/s.h`.
 +
 The `configure` script accepts the following options:
 +
@@ -183,10 +183,6 @@ On a 64-bit POWER architecture host running Linux, OCaml only operates in a
 
     ./configure -cc "acc -fast" -libs "-lucb"
 
-* For Sun Solaris on Sparc 64bit, to compile natively (32bit only)
-
-    ./configure -cc "gcc -m32" -as "as -32" -aspp "gcc -m32 -c"
-
 * For AIX 4.3 with the IBM compiler `xlc`:
 
     ./configure -cc "xlc_r -D_AIX43 -Wl,-bexpall,-brtl -qmaxmem=8192"
@@ -317,8 +313,9 @@ In the latter case, the destination directory defaults to the
 Read the "common problems" and "machine-specific hints" section at the end of
 this file.
 
-Check the files `m.h` and `s.h` in `config/`. Wrong endian-ness or alignment
-constraints in `m.h` will immediately crash the bytecode interpreter.
+Check the files `m.h` and `s.h` in `byterun/caml/`.
+Wrong endianness or alignment constraints in `machine.h` will
+immediately crash the bytecode interpreter.
 
 If you get a "segmentation violation" signal, check the limits on the stack size
 and data segment size (type `limit` under csh or `ulimit -a` under bash). Make

diff --git a/Makefile b/Makefile
index 92556ef4329b24c366a80ac871073e162e4a7f38..0875c0990e464f23b3339f4a760e74274ed08b9f 100644 (file)
--- a/Makefile
+++ b/Makefile
@@ -54,9 +54,10 @@ include stdlib/StdlibModules
 
 CAMLC=$(CAMLRUN) boot/ocamlc -g -nostdlib -I boot -use-prims byterun/primitives
 CAMLOPT=$(CAMLRUN) ./ocamlopt -g -nostdlib -I stdlib -I otherlibs/dynlink
-ARCHES=amd64 i386 arm arm64 power sparc s390x
+ARCHES=amd64 i386 arm arm64 power s390x
 INCLUDES=-I utils -I parsing -I typing -I bytecomp -I middle_end \
-        -I middle_end/base_types -I asmcomp -I driver -I toplevel
+        -I middle_end/base_types -I asmcomp -I asmcomp/debug \
+        -I driver -I toplevel
 
 COMPFLAGS=-strict-sequence -principal -absname -w +a-4-9-41-42-44-45-48 \
          -warn-error A \
@@ -69,12 +70,6 @@ else
 OCAML_NATDYNLINKOPTS = -ccopt "$(NATDYNLINKOPTS)"
 endif
 
-ifeq "$(strip $(BYTECCLINKOPTS))" ""
-OCAML_BYTECCLINKOPTS=
-else
-OCAML_BYTECCLINKOPTS = -ccopt "$(BYTECCLINKOPTS)"
-endif
-
 YACCFLAGS=-v --strict
 CAMLLEX=$(CAMLRUN) boot/ocamllex
 CAMLDEP=$(CAMLRUN) tools/ocamldep
@@ -84,7 +79,7 @@ OCAMLDOC_OPT=$(WITH_OCAMLDOC:=.opt)
 
 UTILS=utils/config.cmo utils/misc.cmo \
   utils/identifiable.cmo utils/numbers.cmo utils/arg_helper.cmo \
-  utils/clflags.cmo utils/tbl.cmo utils/timings.cmo \
+  utils/clflags.cmo utils/tbl.cmo utils/profile.cmo \
   utils/terminfo.cmo utils/ccomp.cmo utils/warnings.cmo \
   utils/consistbl.cmo \
   utils/strongly_connected_components.cmo \
@@ -110,27 +105,30 @@ TYPING=typing/ident.cmo typing/path.cmo \
   typing/tast_mapper.cmo \
   typing/cmt_format.cmo typing/untypeast.cmo \
   typing/includemod.cmo typing/typetexp.cmo typing/parmatch.cmo \
-  typing/stypes.cmo typing/typedecl.cmo typing/typecore.cmo \
+  typing/stypes.cmo typing/typedecl.cmo typing/typeopt.cmo typing/typecore.cmo \
   typing/typeclass.cmo \
   typing/typemod.cmo
 
 COMP=bytecomp/lambda.cmo bytecomp/printlambda.cmo \
   bytecomp/semantics_of_primitives.cmo \
-  bytecomp/typeopt.cmo bytecomp/switch.cmo bytecomp/matching.cmo \
+  bytecomp/switch.cmo bytecomp/matching.cmo \
   bytecomp/translobj.cmo bytecomp/translattribute.cmo \
   bytecomp/translcore.cmo \
   bytecomp/translclass.cmo bytecomp/translmod.cmo \
   bytecomp/simplif.cmo bytecomp/runtimedef.cmo \
+  bytecomp/meta.cmo bytecomp/opcodes.cmo \
+  bytecomp/bytesections.cmo bytecomp/dll.cmo \
+  bytecomp/symtable.cmo \
   driver/pparse.cmo driver/main_args.cmo \
-  driver/compenv.cmo driver/compmisc.cmo
+  driver/compenv.cmo driver/compmisc.cmo \
+  driver/compdynlink.cmo driver/compplugin.cmo driver/makedepend.cmo
+
 
 COMMON=$(UTILS) $(PARSING) $(TYPING) $(COMP)
 
-BYTECOMP=bytecomp/meta.cmo bytecomp/instruct.cmo bytecomp/bytegen.cmo \
-  bytecomp/printinstr.cmo bytecomp/opcodes.cmo bytecomp/emitcode.cmo \
-  bytecomp/bytesections.cmo bytecomp/dll.cmo bytecomp/symtable.cmo \
+BYTECOMP=bytecomp/instruct.cmo bytecomp/bytegen.cmo \
+  bytecomp/printinstr.cmo bytecomp/emitcode.cmo \
   bytecomp/bytelink.cmo bytecomp/bytelibrarian.cmo bytecomp/bytepackager.cmo \
-  driver/compdynlink.cmo driver/compplugin.cmo \
   driver/errors.cmo driver/compile.cmo
 
 ARCH_SPECIFIC =\
@@ -155,7 +153,9 @@ ASMCOMP=\
   $(ARCH_SPECIFIC_ASMCOMP) \
   asmcomp/arch.cmo \
   asmcomp/cmm.cmo asmcomp/printcmm.cmo \
-  asmcomp/reg.cmo asmcomp/mach.cmo asmcomp/proc.cmo \
+  asmcomp/reg.cmo asmcomp/debug/reg_with_debug_info.cmo \
+  asmcomp/debug/reg_availability_set.cmo \
+  asmcomp/mach.cmo asmcomp/proc.cmo \
   asmcomp/clambda.cmo asmcomp/printclambda.cmo \
   asmcomp/export_info.cmo \
   asmcomp/export_info_for_pack.cmo \
@@ -168,6 +168,7 @@ ASMCOMP=\
   asmcomp/un_anf.cmo \
   asmcomp/afl_instrument.cmo \
   asmcomp/strmatch.cmo asmcomp/cmmgen.cmo \
+  asmcomp/interval.cmo \
   asmcomp/printmach.cmo asmcomp/selectgen.cmo \
   asmcomp/spacetime_profiling.cmo asmcomp/selection.cmo \
   asmcomp/comballoc.cmo \
@@ -175,9 +176,11 @@ ASMCOMP=\
   asmcomp/liveness.cmo \
   asmcomp/spill.cmo asmcomp/split.cmo \
   asmcomp/interf.cmo asmcomp/coloring.cmo \
+  asmcomp/linscan.cmo \
   asmcomp/reloadgen.cmo asmcomp/reload.cmo \
   asmcomp/deadcode.cmo \
   asmcomp/printlinear.cmo asmcomp/linearize.cmo \
+  asmcomp/debug/available_regs.cmo \
   asmcomp/schedgen.cmo asmcomp/scheduling.cmo \
   asmcomp/branch_relaxation_intf.cmo \
   asmcomp/branch_relaxation.cmo \
@@ -203,6 +206,7 @@ MIDDLE_END=\
   middle_end/base_types/symbol.cmo \
   middle_end/pass_wrapper.cmo \
   middle_end/allocated_const.cmo \
+  middle_end/parameter.cmo \
   middle_end/projection.cmo \
   middle_end/flambda.cmo \
   middle_end/flambda_iterators.cmo \
@@ -293,7 +297,7 @@ ifeq "$(FLEXDLL_SUBMODULE_PRESENT)" ""
 else
   BOOT_FLEXLINK_CMD = FLEXLINK_CMD="../boot/ocamlrun ../flexdll/flexlink.exe"
   CAMLOPT := OCAML_FLEXLINK="boot/ocamlrun flexdll/flexlink.exe" $(CAMLOPT)
-  FLEXDLL_DIR=$(if $(wildcard flexdll/flexdll_*.$(O)),"+flexdll")
+  FLEXDLL_DIR=$(if $(wildcard flexdll/flexdll_*.$(O)),+flexdll)
 endif
 else
   FLEXDLL_DIR=
@@ -301,46 +305,64 @@ endif
 
 # The configuration file
 
-utils/config.ml: utils/config.mlp config/Makefile
-       sed -e 's|%%AFL_INSTRUMENT%%|$(AFL_INSTRUMENT)|' \
-           -e 's|%%ARCH%%|$(ARCH)|' \
-           -e 's|%%ARCMD%%|$(ARCMD)|' \
-           -e 's|%%ASM%%|$(ASM)|' \
-           -e 's|%%ASM_CFI_SUPPORTED%%|$(ASM_CFI_SUPPORTED)|' \
-           -e 's|%%BYTECCLIBS%%|$(BYTECCLIBS)|' \
-           -e 's|%%BYTECODE_C_COMPILER%%|$(BYTECODE_C_COMPILER)|' \
-           -e 's|%%BYTERUN%%|$(BYTERUN)|' \
-           -e 's|%%CCOMPTYPE%%|$(CCOMPTYPE)|' \
-           -e 's|%%CC_PROFILE%%|$(CC_PROFILE)|' \
-           -e 's|%%EXT_ASM%%|$(EXT_ASM)|' \
-           -e 's|%%EXT_DLL%%|$(EXT_DLL)|' \
-           -e 's|%%EXT_EXE%%|$(EXE)|' \
-           -e 's|%%EXT_LIB%%|$(EXT_LIB)|' \
-           -e 's|%%EXT_OBJ%%|$(EXT_OBJ)|' \
-           -e 's|%%FLAMBDA%%|$(FLAMBDA)|' \
-           -e 's|%%FLEXLINK_FLAGS%%|$(subst \,\\,$(FLEXLINK_FLAGS))|' \
-           -e 's|%%FLEXDLL_DIR%%|$(FLEXDLL_DIR)|' \
-           -e 's|%%HOST%%|$(HOST)|' \
-           -e 's|%%LIBDIR%%|$(LIBDIR)|' \
-           -e 's|%%LIBUNWIND_AVAILABLE%%|$(LIBUNWIND_AVAILABLE)|' \
-           -e 's|%%LIBUNWIND_LINK_FLAGS%%|$(LIBUNWIND_LINK_FLAGS)|' \
-           -e 's|%%MKDLL%%|$(subst \,\\,$(MKDLL))|' \
-           -e 's|%%MKEXE%%|$(subst \,\\,$(MKEXE))|' \
-           -e 's|%%MKMAINDLL%%|$(subst \,\\,$(MKMAINDLL))|' \
-           -e 's|%%MODEL%%|$(MODEL)|' \
-           -e 's|%%NATIVECCLIBS%%|$(NATIVECCLIBS)|' \
-           -e 's|%%NATIVE_C_COMPILER%%|$(NATIVE_C_COMPILER)|' \
-           -e 's|%%PACKLD%%|$(PACKLD)|' \
-           -e 's|%%PROFILING%%|$(PROFILING)|' \
-           -e 's|%%PROFINFO_WIDTH%%|$(PROFINFO_WIDTH)|' \
-           -e 's|%%RANLIBCMD%%|$(RANLIBCMD)|' \
-           -e 's|%%SAFE_STRING%%|$(SAFE_STRING)|' \
-           -e 's|%%SYSTEM%%|$(SYSTEM)|' \
-           -e 's|%%SYSTHREAD_SUPPORT%%|$(SYSTHREAD_SUPPORT)|' \
-           -e 's|%%TARGET%%|$(TARGET)|' \
-           -e 's|%%WITH_FRAME_POINTERS%%|$(WITH_FRAME_POINTERS)|' \
-           -e 's|%%WITH_PROFINFO%%|$(WITH_PROFINFO)|' \
-           -e 's|%%WITH_SPACETIME%%|$(WITH_SPACETIME)|' \
+# SUBST generates the sed substitution for the variable *named* in $1
+# SUBST_QUOTE does the same, adding double-quotes around non-empty strings
+#   (see FLEXDLL_DIR which must empty if FLEXDLL_DIR is empty but an OCaml
+#    string otherwise)
+SUBST_ESCAPE=$(subst ",\\",$(subst \,\\,$(if $2,$2,$($1))))
+SUBST=-e 's|%%$1%%|$(call SUBST_ESCAPE,$1,$2)|'
+SUBST_QUOTE2=-e 's|%%$1%%|$(if $2,"$2")|'
+SUBST_QUOTE=$(call SUBST_QUOTE2,$1,$(call SUBST_ESCAPE,$1,$2))
+FLEXLINK_LDFLAGS=$(if $(LDFLAGS), -link "$(LDFLAGS)")
+utils/config.ml: utils/config.mlp config/Makefile Makefile
+       sed $(call SUBST,AFL_INSTRUMENT) \
+           $(call SUBST,ARCH) \
+           $(call SUBST,ARCMD) \
+           $(call SUBST,ASM) \
+           $(call SUBST,ASM_CFI_SUPPORTED) \
+           $(call SUBST,BYTECCLIBS) \
+           $(call SUBST,BYTERUN) \
+           $(call SUBST,CC) \
+           $(call SUBST,CCOMPTYPE) \
+           $(call SUBST,CC_PROFILE) \
+           $(call SUBST,OUTPUTOBJ) \
+           $(call SUBST,EXT_ASM) \
+           $(call SUBST,EXT_DLL) \
+           $(call SUBST,EXE) \
+           $(call SUBST,EXT_LIB) \
+           $(call SUBST,EXT_OBJ) \
+           $(call SUBST,FLAMBDA) \
+           $(call SUBST,FLEXLINK_FLAGS) \
+           $(call SUBST_QUOTE,FLEXDLL_DIR) \
+           $(call SUBST,HOST) \
+           $(call SUBST,LIBDIR) \
+           $(call SUBST,LIBUNWIND_AVAILABLE) \
+           $(call SUBST,LIBUNWIND_LINK_FLAGS) \
+           $(call SUBST,MKDLL) \
+           $(call SUBST,MKEXE) \
+           $(call SUBST,FLEXLINK_LDFLAGS) \
+           $(call SUBST,MKMAINDLL) \
+           $(call SUBST,MODEL) \
+           $(call SUBST,NATIVECCLIBS) \
+           $(call SUBST,OCAMLC_CFLAGS) \
+           $(call SUBST,OCAMLC_CPPFLAGS) \
+           $(call SUBST,OCAMLOPT_CFLAGS) \
+           $(call SUBST,OCAMLOPT_CPPFLAGS) \
+           $(call SUBST,PACKLD) \
+           $(call SUBST,PROFILING) \
+           $(call SUBST,PROFINFO_WIDTH) \
+           $(call SUBST,RANLIBCMD) \
+           $(call SUBST,FORCE_SAFE_STRING) \
+           $(call SUBST,DEFAULT_SAFE_STRING) \
+           $(call SUBST,WINDOWS_UNICODE) \
+           $(call SUBST,SYSTEM) \
+           $(call SUBST,SYSTHREAD_SUPPORT) \
+           $(call SUBST,TARGET) \
+           $(call SUBST,WITH_FRAME_POINTERS) \
+           $(call SUBST,WITH_PROFINFO) \
+           $(call SUBST,WITH_SPACETIME) \
+           $(call SUBST,ENABLE_CALL_COUNTS) \
+           $(call SUBST,FLAT_FLOAT_ARRAY) \
            $< > $@
 
 ifeq "$(UNIX_OR_WIN32)" "unix"
@@ -460,13 +482,15 @@ opt.opt:
        $(MAKE) ocaml
        $(MAKE) opt-core
        $(MAKE) ocamlc.opt
-       $(MAKE) otherlibraries $(WITH_DEBUGGER) $(WITH_OCAMLDOC)
+       $(MAKE) otherlibraries $(WITH_DEBUGGER) $(WITH_OCAMLDOC) ocamltest
        $(MAKE) ocamlopt.opt
        $(MAKE) otherlibrariesopt
-       $(MAKE) ocamllex.opt ocamltoolsopt ocamltoolsopt.opt $(OCAMLDOC_OPT)
+       $(MAKE) ocamllex.opt ocamltoolsopt ocamltoolsopt.opt $(OCAMLDOC_OPT) \
+         ocamltest.opt
 else
 opt.opt: core opt-core ocamlc.opt all ocamlopt.opt ocamllex.opt \
-         ocamltoolsopt ocamltoolsopt.opt otherlibrariesopt $(OCAMLDOC_OPT)
+         ocamltoolsopt ocamltoolsopt.opt otherlibrariesopt $(OCAMLDOC_OPT) \
+         ocamltest.opt
 endif
 
 .PHONY: base.opt
@@ -477,7 +501,7 @@ base.opt:
        $(MAKE) ocaml
        $(MAKE) opt-core
        $(MAKE) ocamlc.opt
-       $(MAKE) otherlibraries $(WITH_DEBUGGER) $(WITH_OCAMLDOC)
+       $(MAKE) otherlibraries $(WITH_DEBUGGER) $(WITH_OCAMLDOC) ocamltest
        $(MAKE) ocamlopt.opt
        $(MAKE) otherlibrariesopt
 
@@ -509,7 +533,7 @@ coreboot:
 all: runtime
        $(MAKE) coreall
        $(MAKE) ocaml
-       $(MAKE) otherlibraries $(WITH_DEBUGGER) $(WITH_OCAMLDOC)
+       $(MAKE) otherlibraries $(WITH_DEBUGGER) $(WITH_OCAMLDOC) ocamltest
 
 # Bootstrap and rebuild the whole system.
 # The compilation of ocaml will fail if the runtime has changed.
@@ -551,6 +575,7 @@ flexdll/Makefile:
 .PHONY: flexdll
 flexdll: flexdll/Makefile flexlink
        $(MAKE) -C flexdll \
+            OCAML_CONFIG_FILE=../config/Makefile \
              MSVC_DETECT=0 CHAINS=$(FLEXDLL_CHAIN) NATDYNLINK=false support
 
 # Bootstrapping flexlink - leaves a bytecode image of flexlink.exe in flexdll/
@@ -560,8 +585,8 @@ flexlink: flexdll/Makefile
        cp byterun/ocamlrun$(EXE) boot/ocamlrun$(EXE)
        $(MAKE) -C stdlib COMPILER=../boot/ocamlc stdlib.cma std_exit.cmo
        cd stdlib && cp stdlib.cma std_exit.cmo *.cmi ../boot
-       $(MAKE) -C flexdll MSVC_DETECT=0 TOOLCHAIN=$(TOOLCHAIN) \
-         TOOLPREF=$(TOOLPREF) CHAINS=$(FLEXDLL_CHAIN) NATDYNLINK=false \
+       $(MAKE) -C flexdll MSVC_DETECT=0 OCAML_CONFIG_FILE=../config/Makefile \
+         CHAINS=$(FLEXDLL_CHAIN) NATDYNLINK=false \
          OCAMLOPT="../boot/ocamlrun ../boot/ocamlc -I ../boot" \
          flexlink.exe
        $(MAKE) -C byterun clean
@@ -572,7 +597,7 @@ flexlink.opt:
        cd flexdll && \
        mv flexlink.exe flexlink && \
        $(MAKE) OCAML_FLEXLINK="../boot/ocamlrun ./flexlink" MSVC_DETECT=0 \
-                  TOOLCHAIN=$(TOOLCHAIN) TOOLPREF=$(TOOLPREF) \
+                  OCAML_CONFIG_FILE=../config/Makefile \
                   OCAMLOPT="../ocamlopt.opt -I ../stdlib" flexlink.exe && \
        mv flexlink.exe flexlink.opt && \
        mv flexlink flexlink.exe
@@ -619,12 +644,16 @@ install:
            toplevel/topdirs.mli "$(INSTALL_LIBDIR)"
        $(MAKE) -C tools install
 ifeq "$(UNIX_OR_WIN32)" "unix" # Install manual pages only on Unix
-       $(MKDIR) "$(INSTALL_MANDIR)/man$(MANEXT)"
+       $(MKDIR) "$(INSTALL_MANDIR)/man$(PROGRAMS_MAN_SECTION)"
        -$(MAKE) -C man install
 endif
        for i in $(OTHERLIBRARIES); do \
          $(MAKE) -C otherlibs/$$i install || exit $$?; \
        done
+# Transitional: findlib 1.7.3 is confused if leftover num.cm? files remain
+# from an previous installation of OCaml before otherlibs/num was removed.
+       rm -f "$(INSTALL_LIBDIR)"/num.cm?
+# End transitional
        if test -n "$(WITH_OCAMLDOC)"; then \
          $(MAKE) -C ocamldoc install; \
        fi
@@ -675,8 +704,6 @@ installopt:
          cp -f flexdll/flexlink.opt "$(INSTALL_BINDIR)/flexlink$(EXE)" ; \
        fi
 
-
-
 .PHONY: installoptopt
 installoptopt:
        cp ocamlc.opt "$(INSTALL_BINDIR)/ocamlc.opt$(EXE)"
@@ -715,7 +742,7 @@ install-compiler-sources:
 # Run all tests
 
 .PHONY: tests
-tests: opt.opt
+tests: opt.opt ocamltest
        cd testsuite; $(MAKE) clean && $(MAKE) all
 
 # Make clean in the test suite
@@ -762,7 +789,7 @@ partialclean::
        rm -f compilerlibs/ocamloptcomp.cma
 
 ocamlopt: compilerlibs/ocamlcommon.cma compilerlibs/ocamloptcomp.cma \
-          compilerlibs/ocamlbytecomp.cma $(OPTSTART)
+          $(OPTSTART)
        $(CAMLC) $(LINKFLAGS) -o $@ $^
 
 partialclean::
@@ -853,8 +880,7 @@ partialclean::
 
 ocamlc.opt: compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlbytecomp.cmxa \
             $(BYTESTART:.cmo=.cmx)
-       $(CAMLOPT) $(LINKFLAGS) $(OCAML_BYTECCLINKOPTS) -o $@ \
-         $^ -cclib "$(BYTECCLIBS)"
+       $(CAMLOPT) $(LINKFLAGS) -o $@ $^ -cclib "$(BYTECCLIBS)"
 
 partialclean::
        rm -f ocamlc.opt
@@ -867,7 +893,6 @@ partialclean::
        rm -f compilerlibs/ocamloptcomp.cmxa compilerlibs/ocamloptcomp.$(A)
 
 ocamlopt.opt: compilerlibs/ocamlcommon.cmxa compilerlibs/ocamloptcomp.cmxa \
-              compilerlibs/ocamlbytecomp.cmxa  \
               $(OPTSTART:.cmo=.cmx)
        $(CAMLOPT) $(LINKFLAGS) -o $@ $^
 
@@ -955,9 +980,21 @@ clean::
        $(MAKE) -C byterun clean
        rm -f stdlib/libcamlrun.$(A)
 
+otherlibs_all := bigarray dynlink graph raw_spacetime_lib \
+  str systhreads threads unix win32graph win32unix
+subdirs := asmrun byterun debugger lex ocamldoc ocamltest stdlib tools \
+  $(addprefix otherlibs/, $(otherlibs_all))
+
 .PHONY: alldepend
-alldepend::
-       $(MAKE) -C byterun depend
+ifeq "$(TOOLCHAIN)" "msvc"
+alldepend:
+       $(error Dependencies cannot be regenerated using the MSVC ports)
+else
+alldepend: depend
+       for dir in $(subdirs); do \
+         $(MAKE) -C $$dir depend || exit; \
+       done
+endif
 
 # The runtime system for the native-code compiler
 
@@ -973,8 +1010,6 @@ stdlib/libasmrun.$(A): asmrun/libasmrun.$(A)
 clean::
        $(MAKE) -C asmrun clean
        rm -f stdlib/libasmrun.$(A)
-alldepend::
-       $(MAKE) -C asmrun depend
 
 # The standard library
 
@@ -993,9 +1028,6 @@ libraryopt:
 partialclean::
        $(MAKE) -C stdlib clean
 
-alldepend::
-       $(MAKE) -C stdlib depend
-
 # The lexer and parser generators
 
 .PHONY: ocamllex
@@ -1009,9 +1041,6 @@ ocamllex.opt: ocamlopt
 partialclean::
        $(MAKE) -C lex clean
 
-alldepend::
-       $(MAKE) -C lex depend
-
 .PHONY: ocamlyacc
 ocamlyacc:
        $(MAKE) -C yacc $(BOOT_FLEXLINK_CMD) all
@@ -1029,6 +1058,16 @@ ocamldoc: ocamlc ocamlyacc ocamllex otherlibraries
 ocamldoc.opt: ocamlc.opt ocamlyacc ocamllex
        $(MAKE) -C ocamldoc opt.opt
 
+# OCamltest
+ocamltest: ocamlc ocamlyacc ocamllex
+       $(MAKE) -C ocamltest
+
+ocamltest.opt: ocamlc.opt ocamlyacc ocamllex
+       $(MAKE) -C ocamltest ocamltest.opt$(EXE)
+
+partialclean::
+       $(MAKE) -C ocamltest clean
+
 # Documentation
 
 .PHONY: html_doc
@@ -1039,9 +1078,6 @@ html_doc: ocamldoc
 partialclean::
        $(MAKE) -C ocamldoc clean
 
-alldepend::
-       $(MAKE) -C ocamldoc depend
-
 # The extra libraries
 
 .PHONY: otherlibraries
@@ -1066,11 +1102,6 @@ clean::
          ($(MAKE) -C otherlibs/$$i clean); \
        done
 
-alldepend::
-       for i in $(OTHERLIBRARIES); do \
-         ($(MAKE) -C otherlibs/$$i depend); \
-       done
-
 # The replay debugger
 
 .PHONY: ocamldebugger
@@ -1080,14 +1111,11 @@ ocamldebugger: ocamlc ocamlyacc ocamllex otherlibraries
 partialclean::
        $(MAKE) -C debugger clean
 
-alldepend::
-       $(MAKE) -C debugger depend
-
 # Check that the stack limit is reasonable.
 ifeq "$(UNIX_OR_WIN32)" "unix"
 .PHONY: checkstack
 checkstack:
-       if $(MKEXE) -o tools/checkstack$(EXE) tools/checkstack.c; \
+       if $(MKEXE) $(OUTPUTEXE)tools/checkstack$(EXE) tools/checkstack.c; \
          then tools/checkstack$(EXE); \
          else :; \
        fi
@@ -1096,12 +1124,13 @@ endif
 
 # Lint @since and @deprecated annotations
 
+VERSIONS=$(shell git tag|grep '^[0-9]*.[0-9]*.[0-9]*$$'|grep -v '^[12].')
 .PHONY: lintapidiff
 lintapidiff:
        $(MAKE) -C tools lintapidiff.opt
        git ls-files -- 'otherlibs/*/*.mli' 'stdlib/*.mli' |\
            grep -Ev internal\|obj\|spacetime\|stdLabels\|moreLabels |\
-           tools/lintapidiff.opt $(shell git tag|grep '^[0-9]*.[0-9]*.[0-9]*$$'|grep -v '^[12].')
+           tools/lintapidiff.opt $(VERSIONS)
 
 # Make clean in the test suite
 
@@ -1156,9 +1185,6 @@ ocamltoolsopt.opt: ocamlc.opt ocamlyacc ocamllex.opt asmcomp/cmx_format.cmi \
 partialclean::
        $(MAKE) -C tools clean
 
-alldepend::
-       $(MAKE) -C tools depend
-
 ## Test compilation of backend-specific parts
 
 partialclean::
@@ -1271,7 +1297,7 @@ beforedepend:: bytecomp/opcodes.ml
 
 partialclean::
        for d in utils parsing typing bytecomp asmcomp middle_end \
-                middle_end/base_types driver toplevel tools; do \
+                middle_end/base_types asmcomp/debug driver toplevel tools; do \
          rm -f $$d/*.cm[ioxt] $$d/*.cmti $$d/*.annot $$d/*.$(S) \
            $$d/*.$(O) $$d/*.$(SO) $d/*~; \
        done
@@ -1280,24 +1306,19 @@ partialclean::
 .PHONY: depend
 depend: beforedepend
        (for d in utils parsing typing bytecomp asmcomp middle_end \
-        middle_end/base_types driver toplevel; \
-        do $(CAMLDEP) -slash $(DEPFLAGS) $$d/*.mli $$d/*.ml; \
+        middle_end/base_types asmcomp/debug driver toplevel; \
+        do $(CAMLDEP) -slash $(DEPFLAGS) $$d/*.mli $$d/*.ml || exit; \
         done) > .depend
        $(CAMLDEP) -slash $(DEPFLAGS) -native \
                -impl driver/compdynlink.mlopt >> .depend
        $(CAMLDEP) -slash $(DEPFLAGS) -bytecode \
                -impl driver/compdynlink.mlbyte >> .depend
 
-alldepend:: depend
-
 .PHONY: distclean
 distclean: clean
-       rm -f asmrun/.depend.nt byterun/.depend.nt \
-                   otherlibs/bigarray/.depend.nt  \
-                   otherlibs/str/.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
+       rm -f config/Makefile byterun/caml/m.h byterun/caml/s.h
        rm -f tools/*.bak
        rm -f ocaml ocamlc
        rm -f testsuite/_log

diff --git a/README.adoc b/README.adoc
index fe07edbba6adf349b6979401335a63a906b0806b..34ca38a06b1223816ee52c2b1ee36f17511bd132 100644 (file)
--- a/README.adoc
+++ b/README.adoc
@@ -1,3 +1,15 @@
+|=====
+| Branch `trunk` | Branch `4.05` | Branch `4.04`
+
+| image:https://travis-ci.org/ocaml/ocaml.svg?branch=trunk["TravisCI Build Status (trunk branch)",link="https://travis-ci.org/ocaml/ocaml"]
+  image:https://ci.appveyor.com/api/projects/status/github/ocaml/ocaml?branch=trunk&svg=true["AppVeyor Build Status (trunk branch)",link="https://ci.appveyor.com/project/avsm/ocaml"]
+| image:https://travis-ci.org/ocaml/ocaml.svg?branch=4.05["TravisCI Build Status (4.05 branch)",link="https://travis-ci.org/ocaml/ocaml"]
+  image:https://ci.appveyor.com/api/projects/status/github/ocaml/ocaml?branch=4.05&svg=true["AppVeyor Build Status (4.05 branch)",link="https://ci.appveyor.com/project/avsm/ocaml"]
+| image:https://travis-ci.org/ocaml/ocaml.svg?branch=4.04["TravisCI Build Status (4.04 branch)",link="https://travis-ci.org/ocaml/ocaml"]
+  image:https://ci.appveyor.com/api/projects/status/github/ocaml/ocaml?branch=4.04&svg=true["AppVeyor Build Status (4.04 branch)",link="https://ci.appveyor.com/project/avsm/ocaml"]
+
+|=====
+
 = README =
 
 == Overview
@@ -33,7 +45,6 @@ AMD64::              FreeBSD, OpenBSD, NetBSD
 IA32 (Pentium)::     NetBSD, OpenBSD, Solaris 9
 PowerPC::            NetBSD
 ARM::                NetBSD
-SPARC::              Solaris, Linux, NetBSD
 
 Other operating systems for the processors above have not been tested, but
 the compiler may work under other operating systems with little work.

diff --git a/README.win32.adoc b/README.win32.adoc
index e34b3346cbc6dd3bfb58a29c656e0fc8135b0ed8..57ef54fa5a1b3220360a0678a73e9167f03af050 100644 (file)
--- a/README.win32.adoc
+++ b/README.win32.adoc
@@ -73,9 +73,10 @@ https://github.com/alainfrisch/flexdll. A binary distribution is available;
 instructions on how to build FlexDLL from sources, including how to bootstrap
 FlexDLL and OCaml are given <<seflexdll,later in this document>>.  Unless you
 bootstrap FlexDLL, you will need to ensure that the directory to which you
-install FlexDLL is included in your `PATH` environment variable. Note: if you
-use Visual Studio 2015 or Visual Studio 2017, the binary distribution of
-FlexDLL will not work and you must build it from sources.
+install FlexDLL is included in your `PATH` environment variable. Note: binary
+distributions of FlexDLL are compatible only with Visual Studio 2013 and
+earlier; for Visual Studio 2015 and later, you will need to compile the C
+objects from source, or build ocaml using the flexdll target.
 
 The base bytecode system (ocamlc, ocaml, ocamllex, ocamlyacc, ...) of all three
 ports runs without any additional tools.
@@ -192,8 +193,8 @@ quickly as it will be unable to link `ocamlrun`.
 
 Now run:
 
-        cp config/m-nt.h config/m.h
-        cp config/s-nt.h config/s.h
+        cp config/m-nt.h byterun/caml/m.h
+        cp config/s-nt.h byterun/caml/s.h
 
 followed by:
 
@@ -263,8 +264,8 @@ the WinZip Options Window.)
 
 Now run:
 
-        cp config/m-nt.h config/m.h
-        cp config/s-nt.h config/s.h
+        cp config/m-nt.h byterun/caml/m.h
+        cp config/s-nt.h byterun/caml/s.h
 
 followed by:
 
@@ -326,12 +327,13 @@ done in one of three ways:
 OCaml is then compiled as normal for the port you require, except that before
 compiling `world`, you must compile `flexdll`, i.e.:
 
-  make flexdll world [bootstrap] opt opt.opt install
+  make flexdll world [bootstrap] opt opt.opt flexlink.opt install
 
+ * You should ignore the error messages that say ocamlopt was not found.
  * `make install` will install FlexDLL by placing `flexlink.exe`
    (and the default manifest file for the Microsoft port) in `bin/` and the
    FlexDLL object files in `lib/`.
- * If you don't include `make opt.opt`, `flexlink.exe` will be a
+ * If you don't include `make flexlink.opt`, `flexlink.exe` will be a
    bytecode program.  `make install` always installs the "best"
    `flexlink.exe` (i.e. there is never a `flexlink.opt.exe` installed).
  * If you have populated `flexdll/`, you *must* run
@@ -339,6 +341,55 @@ compiling `world`, you must compile `flexdll`, i.e.:
    installed FlexDLL, you must erase the contents of `flexdll/` before
    compiling.
 
+== Unicode support
+
+Prior to version 4.06, all filenames on the OCaml side were assumed
+to be encoded using the current 8-bit code page of the system.  Some
+Unicode filenames could thus not be represented.  Since version 4.06,
+OCaml adds to this legacy mode a new "Unicode" mode, where filenames
+are UTF-8 encoded strings.  In addition to filenames,
+this applies to environment variables and command-line arguments.
+
+The mode must be decided before building the system, by tweaking
+the `WINDOWS_UNICODE` variable in `config/Makefile`.  A value of 1
+enables the the new "Unicode" mode, while a value of 0 maintains
+the legacy mode.
+
+Technically, both modes use the Windows "wide" API, where filenames
+and other strings are made of 16-bit entities, usually interpreted as
+UTF-16 encoded strings.
+
+Some more details about the two modes:
+
+ * Unicode mode: OCaml strings are interpreted as being UTF-8 encoded
+   and translated to UTF-16 when calling Windows; strings returned by
+   Windows are interpreted as UTF-16 and translated to UTF-8 on their
+   way back to OCaml.  Additionally, an OCaml string which is not
+   valid UTF-8 will be interpreted as being in the current 8-bit code
+   page.  This fallback works well in practice, since the chances of
+   non-ASCII string encoded in the a 8-bit code page to be a valid
+   UTF-8 string are tiny.  This means that filenames
+   obtained from e.g. a 8-bit UI or database layer would continue to
+   work fine.  Application written for the legacy mode or older
+   versions of OCaml might still break if strings returned by
+   Windows (e.g. for `Sys.readdir`) are sent to components expecting
+   strings encoded in the current code page.
+
+ * Legacy mode: this mode emulates closely the behavior of OCaml <
+   4.06 and is thus the safest choice in terms of backward
+   compatibility.  In this mode, OCaml programs can only work with
+   filenames that can be encoded in the current code page, and the
+   same applies to ocaml tools themselves (ocamlc, ocamlopt, etc).
+
+The legacy mode will be deprecated and then removed in future versions
+of OCaml.  Users are thus strongly encouraged to use the Unicode mode
+and adapt their existing code bases accordingly.
+
+Note: in order for ocaml tools to support Unicode pathnames, it is
+necessary to use a version of FlexDLL which has itself been compiled
+with OCaml >= 4.06 in Unicode mode.  This is the case for binary distributions
+of FlexDLL starting from version 0.37 and above.
+
 == Trademarks
 
 Microsoft, Visual C++, Visual Studio and Windows are registered trademarks of

diff --git a/VERSION b/VERSION
index 6ca3825364036d680d8ebaf9c04ed774516437e0..1b7a77c879a897c44f03dab422e88b31631be9a9 100644 (file)
--- a/VERSION
+++ b/VERSION
@@ -1,4 +1,4 @@
-4.05.0
+4.06.0
 
 # The version string is the first line of this file.
 # It must be in the format described in stdlib/sys.mli

diff --git a/appveyor.yml b/appveyor.yml
index fbdb79ad7b770fc8bfcf2103471223ac6f6c0298..baa20dac579bf9c0a5a697f5fcac28656aa223cc 100644 (file)
--- a/appveyor.yml
+++ b/appveyor.yml
@@ -18,11 +18,6 @@ platform:
 
 image: Visual Studio 2015
 
-branches:
-  only:
-    - trunk
-    - 4.05
-
 # Do a shallow clone of the repo to speed up the build
 clone_depth: 1
 
@@ -31,51 +26,19 @@ environment:
     CYG_ROOT: C:/cygwin64
     CYG_MIRROR: http://mirrors.kernel.org/sourceware/cygwin/
     CYG_CACHE: C:/cygwin64/var/cache/setup
+    FLEXDLL_VERSION: 0.37
     OCAMLRUNPARAM: v=0,b
-    OCAMLROOT: "%PROGRAMFILES%/OCaml"
-    OCAMLROOT2: "%PROGRAMFILES%/OCaml-mingw32"
 
 cache:
   - C:\cygwin64\var\cache\setup
 
 install:
-  - mkdir "%OCAMLROOT%/bin/flexdll"
-  - appveyor DownloadFile "http://alain.frisch.fr/flexdll/flexdll-bin-0.35.zip" -FileName "flexdll.zip"
-  - appveyor DownloadFile "http://alain.frisch.fr/flexdll/flexdll-0.35.tar.gz" -FileName "flexdll.tar.gz"
-  - cinst 7zip.commandline
-  - mkdir flexdll-tmp
-  - cd flexdll-tmp
-  - 7za x -y ..\flexdll.zip
-  - for %%F in (flexdll.h flexlink.exe default_amd64.manifest) do copy %%F "%OCAMLROOT%\bin\flexdll"
-  - cd ..
-  # Make sure the Cygwin path comes before the Git one (otherwise
-  # cygpath behaves crazily), but after the MSVC one.
-  - set Path=C:\cygwin64\bin;%OCAMLROOT%\bin\flexdll;%Path%
-  - '%CYG_ROOT%\bin\bash -lc "cygcheck -dc cygwin"'
-  - '"%CYG_ROOT%\setup-x86_64.exe" -qgnNdO -R "%CYG_ROOT%" -s "%CYG_MIRROR%" -l "%CYG_CACHE%" -P diffutils -P make -P mingw64-i686-gcc-core >NUL'
-  - '%CYG_ROOT%\bin\bash -lc "cygcheck -dc cygwin"'
-  - set OCAML_PREV_PATH=%PATH%
-  - set OCAML_PREV_LIB=%LIB%
-  - set OCAML_PREV_INCLUDE=%INCLUDE%
-  - call "C:\Program Files (x86)\Microsoft Visual Studio 14.0\VC\bin\amd64\vcvars64.bat"
+# This is a hangover from monitoring effects of MPR#7452
+  - wmic cpu get name
+  - call "%APPVEYOR_BUILD_FOLDER%\appveyor_build.cmd" install
 
 build_script:
-  - "%CYG_ROOT%/bin/bash -lc \"echo 'eval $($APPVEYOR_BUILD_FOLDER/tools/msvs-promote-path)' >> ~/.bash_profile\""
-  - '%CYG_ROOT%/bin/bash -lc "$APPVEYOR_BUILD_FOLDER/appveyor_build.sh"'
-  - set PATH=%OCAML_PREV_PATH%
-  - set LIB=%OCAML_PREV_LIB%
-  - set INCLUDE=%OCAML_PREV_INCLUDE%
-  - call "C:\Program Files\Microsoft SDKs\Windows\v7.1\Bin\SetEnv.cmd" /x86
-  - '%CYG_ROOT%/bin/bash -lc "$APPVEYOR_BUILD_FOLDER/appveyor_build.sh msvc32-only"'
+  - call "%APPVEYOR_BUILD_FOLDER%\appveyor_build.cmd" build
 
 test_script:
-  - set PATH=%OCAML_PREV_PATH%
-  - set LIB=%OCAML_PREV_LIB%
-  - set INCLUDE=%OCAML_PREV_INCLUDE%
-  - call "C:\Program Files (x86)\Microsoft Visual Studio 14.0\VC\bin\amd64\vcvars64.bat"
-  - '%APPVEYOR_BUILD_FOLDER%\ocamlc.opt -version'
-  - set CAML_LD_LIBRARY_PATH=%OCAMLROOT%/lib/stublibs
-  - '%CYG_ROOT%/bin/bash -lc "cd $APPVEYOR_BUILD_FOLDER && make tests"'
-  - '%CYG_ROOT%/bin/bash -lc "cd $APPVEYOR_BUILD_FOLDER/../build-mingw32 && make tests"'
-  - '%CYG_ROOT%/bin/bash -lc "cd $APPVEYOR_BUILD_FOLDER && make install"'
-  - '%CYG_ROOT%/bin/bash -lc "cd $APPVEYOR_BUILD_FOLDER/../build-mingw32 && make install"'
+  - call "%APPVEYOR_BUILD_FOLDER%\appveyor_build.cmd" test

diff --git a/appveyor_build.cmd b/appveyor_build.cmd
new file mode 100644 (file)
index 0000000..76093da
--- /dev/null
+++ b/appveyor_build.cmd
@@ -0,0 +1,113 @@
+@rem ***********************************************************************
+@rem *                                                                     *
+@rem *                                 OCaml                               *
+@rem *                                                                     *
+@rem *                 David Allsopp, OCaml Labs, Cambridge.               *
+@rem *                                                                     *
+@rem *   Copyright 2017 MetaStack Solutions Ltd.                           *
+@rem *                                                                     *
+@rem *   All rights reserved.  This file is distributed under the terms of *
+@rem *   the GNU Lesser General Public License version 2.1, with the       *
+@rem *   special exception on linking described in the file LICENSE.       *
+@rem *                                                                     *
+@rem ***********************************************************************
+
+@rem BE CAREFUL ALTERING THIS FILE TO ENSURE THAT ERRORS PROPAGATE
+@rem IF A COMMAND SHOULD FAIL IT PROBABLY NEEDS TO END WITH
+@rem   || exit /b 1
+@rem BASICALLY, DO THE TESTING IN BASH...
+
+@rem Do not call setlocal!
+@echo off
+
+goto %1
+
+goto :EOF
+
+:SaveVars
+set OCAML_PREV_PATH=%PATH%
+set OCAML_PREV_LIB=%LIB%
+set OCAML_PREV_INCLUDE=%INCLUDE%
+goto :EOF
+
+:RestoreVars
+set PATH=%OCAML_PREV_PATH%
+set LIB=%OCAML_PREV_LIB%
+set INCLUDE=%OCAML_PREV_INCLUDE%
+goto :EOF
+
+:CheckPackage
+"%CYG_ROOT%\bin\bash.exe" -lc "cygcheck -dc %1" | findstr %1 > nul
+if %ERRORLEVEL% equ 1 (
+  echo Cygwin package %1 will be installed
+  set CYGWIN_INSTALL_PACKAGES=%CYGWIN_INSTALL_PACKAGES%,%1
+)
+goto :EOF
+
+:UpgradeCygwin
+if "%CYGWIN_INSTALL_PACKAGES%" neq "" "%CYG_ROOT%\setup-x86_64.exe" --quiet-mode --no-shortcuts --no-startmenu --no-desktop --only-site --root "%CYG_ROOT%" --site "%CYG_MIRROR%" --local-package-dir "%CYG_CACHE%" --packages %CYGWIN_INSTALL_PACKAGES:~1% > nul
+for %%P in (%CYGWIN_COMMANDS%) do "%CYG_ROOT%\bin\%%P.exe" --version > nul || set CYGWIN_UPGRADE_REQUIRED=1
+"%CYG_ROOT%\bin\bash.exe" -lc "cygcheck -dc %CYGWIN_PACKAGES%"
+if %CYGWIN_UPGRADE_REQUIRED% equ 1 (
+  echo Cygwin package upgrade required - please go and drink coffee
+  "%CYG_ROOT%\setup-x86_64.exe" --quiet-mode --no-shortcuts --no-startmenu --no-desktop --only-site --root "%CYG_ROOT%" --site "%CYG_MIRROR%" --local-package-dir "%CYG_CACHE%" --upgrade-also > nul
+  "%CYG_ROOT%\bin\bash.exe" -lc "cygcheck -dc %CYGWIN_PACKAGES%"
+)
+goto :EOF
+
+:install
+chcp 65001 > nul
+rem This must be kept in sync with appveyor_build.sh
+set BUILD_PREFIX=🐫реализация
+git worktree add "..\%BUILD_PREFIX%-msvc64" -b appveyor-build-msvc64
+git worktree add "..\%BUILD_PREFIX%-mingw32" -b appveyor-build-mingw32
+git worktree add "..\%BUILD_PREFIX%-msvc32" -b appveyor-build-msvc32
+cd "..\%BUILD_PREFIX%-mingw32"
+git submodule update --init flexdll
+
+cd "%APPVEYOR_BUILD_FOLDER%"
+appveyor DownloadFile "https://github.com/alainfrisch/flexdll/archive/0.37.tar.gz" -FileName "flexdll.tar.gz" || exit /b 1
+appveyor DownloadFile "https://github.com/alainfrisch/flexdll/releases/download/0.37/flexdll-bin-0.37.zip" -FileName "flexdll.zip" || exit /b 1
+rem flexdll.zip is processed here, rather than in appveyor_build.sh because the
+rem unzip command comes from MSYS2 (via Git for Windows) and it has to be
+rem invoked via cmd /c in a bash script which is weird(er).
+mkdir "%APPVEYOR_BUILD_FOLDER%\..\flexdll"
+move flexdll.zip "%APPVEYOR_BUILD_FOLDER%\..\flexdll"
+cd "%APPVEYOR_BUILD_FOLDER%\..\flexdll" && unzip -q flexdll.zip
+
+rem CYGWIN_PACKAGES is the list of required Cygwin packages (cygwin is included
+rem in the list just so that the Cygwin version is always displayed on the log).
+rem CYGWIN_COMMANDS is a corresponding command to run with --version to test
+rem whether the package works. This is used to verify whether the installation
+rem needs upgrading.
+set CYGWIN_PACKAGES=cygwin make diffutils mingw64-i686-gcc-core
+set CYGWIN_COMMANDS=cygcheck make diff i686-w64-mingw32-gcc
+
+set CYGWIN_INSTALL_PACKAGES=
+set CYGWIN_UPGRADE_REQUIRED=0
+
+for %%P in (%CYGWIN_PACKAGES%) do call :CheckPackage %%P
+call :UpgradeCygwin
+
+"%CYG_ROOT%\bin\bash.exe" -lec "$APPVEYOR_BUILD_FOLDER/appveyor_build.sh install" || exit /b 1
+
+call :SaveVars
+goto :EOF
+
+:build
+rem Run the msvc64 and mingw32 builds
+call "C:\Program Files (x86)\Microsoft Visual Studio 14.0\VC\bin\amd64\vcvars64.bat"
+"%CYG_ROOT%\bin\bash.exe" -lec "$APPVEYOR_BUILD_FOLDER/appveyor_build.sh" || exit /b 1
+
+rem Reconfigure the environment and run the msvc32 partial build
+call :RestoreVars
+call "C:\Program Files\Microsoft SDKs\Windows\v7.1\Bin\SetEnv.cmd" /x86
+"%CYG_ROOT%\bin\bash.exe" -lec "$APPVEYOR_BUILD_FOLDER/appveyor_build.sh msvc32-only" || exit /b 1
+goto :EOF
+
+:test
+rem Reconfigure the environment for the msvc64 build
+call :RestoreVars
+call "C:\Program Files (x86)\Microsoft Visual Studio 14.0\VC\bin\amd64\vcvars64.bat"
+"%CYG_ROOT%\bin\bash.exe" -lec "$APPVEYOR_BUILD_FOLDER/appveyor_build.sh test" || exit /b 1
+goto :EOF

diff --git a/appveyor_build.sh b/appveyor_build.sh
index e3c0454a30e7d866dd37a85e47d0d629438802f9..995553f1ba007d6d244db7bfce2a9943f1a6bb91 100644 (file)
--- a/appveyor_build.sh
+++ b/appveyor_build.sh
@@ -13,6 +13,8 @@
 #*                                                                        *
 #**************************************************************************
 
+BUILD_PID=0
+
 function run {
     NAME=$1
     shift
@@ -21,75 +23,103 @@ function run {
     CODE=$?
     if [ $CODE -ne 0 ]; then
         echo "-=-=- $NAME failed! -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-"
+        if [ $BUILD_PID -ne 0 ] ; then
+          kill -KILL $BUILD_PID 2>/dev/null
+          wait $BUILD_PID 2>/dev/null
+        fi
         exit $CODE
     else
         echo "-=-=- End of $NAME -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-"
     fi
 }
 
-PREFIX="C:/Program Files/OCaml"
-
-wmic cpu get name
-
-if [[ $1 = "msvc32-only" ]] ; then
-  cd $APPVEYOR_BUILD_FOLDER/flexdll-0.35
-  make MSVC_DETECT=0 CHAINS=msvc MSVC_FLAGS="-nologo -MD -D_CRT_NO_DEPRECATE -GS- -WX" support
-  cp flexdll*_msvc.obj "$PREFIX/bin/flexdll"
-
-  cd $APPVEYOR_BUILD_FOLDER/../build-msvc32
-  cp config/m-nt.h config/m.h
-  cp config/s-nt.h config/s.h
-
-  eval $(tools/msvs-promote-path)
-
-  PREFIX="C:/Program Files/OCaml-msmvc32"
-  echo "Edit config/Makefile to set PREFIX=$PREFIX"
-  sed -e "s|PREFIX=.*|PREFIX=$PREFIX|" -e "/\(BYTE\|NATIVE\)CCCOMPOPTS=./s/\r\?$/ -WX\0/" config/Makefile.msvc > config/Makefile
-
-  run "make world" make world
-  run "make runtimeopt" make runtimeopt
-  run "make -C otherlibs/systhreads libthreadsnat.lib" make -C otherlibs/systhreads libthreadsnat.lib
-
-  exit 0
-fi
-
-cd $APPVEYOR_BUILD_FOLDER
-
-git worktree add ../build-mingw32 -b appveyor-build-mingw32
-git worktree add ../build-msvc32 -b appveyor-build-msvc32
+function set_configuration {
+    cp config/m-nt.h byterun/caml/m.h
+    cp config/s-nt.h byterun/caml/s.h
 
-cd ../build-mingw32
-git submodule update --init flexdll
-
-cd $APPVEYOR_BUILD_FOLDER
-
-tar -xzf flexdll.tar.gz
-cd flexdll-0.35
-make MSVC_DETECT=0 CHAINS=msvc64 support
-cp flexdll*_msvc64.obj "$PREFIX/bin/flexdll"
-cd ..
-
-cp config/m-nt.h config/m.h
-cp config/s-nt.h config/s.h
-
-echo "Edit config/Makefile to set PREFIX=$PREFIX"
-sed -e "s|PREFIX=.*|PREFIX=$PREFIX|" -e "/\(BYTE\|NATIVE\)CCCOMPOPTS=./s/\r\?$/ -WX\0/" config/Makefile.msvc64 > config/Makefile
-#run "Content of config/Makefile" cat config/Makefile
-
-run "make world" make world
-run "make bootstrap" make bootstrap
-run "make opt" make opt
-run "make opt.opt" make opt.opt
-
-cd ../build-mingw32
-
-cp config/m-nt.h config/m.h
-cp config/s-nt.h config/s.h
-
-PREFIX="C:/Program Files/OCaml-mingw32"
-echo "Edit config/Makefile to set PREFIX=$PREFIX"
-sed -e "s|PREFIX=.*|PREFIX=$PREFIX|" -e "/\(BYTE\|NATIVE\)CCCOMPOPTS=./s/\r\?$/ -Werror\0/" config/Makefile.mingw > config/Makefile
-#run "Content of config/Makefile" cat config/Makefile
+    FILE=$(pwd | cygpath -f - -m)/config/Makefile
+    echo "Edit $FILE to set PREFIX=$2"
+    sed -e "/PREFIX=/s|=.*|=$2|" \
+        -e "/^ *CFLAGS *=/s/\r\?$/ $3\0/" \
+         config/Makefile.$1 > config/Makefile
+#    run "Content of $FILE" cat config/Makefile
+}
 
-run "make flexdll" make flexdll
-run "make world.opt" make world.opt
+APPVEYOR_BUILD_FOLDER=$(echo $APPVEYOR_BUILD_FOLDER| cygpath -f -)
+# These directory names are specified here, because getting UTF-8 correctly
+# through appveyor.yml -> Command Script -> Bash is quite painful...
+OCAMLROOT=$(echo $PROGRAMFILES/Бактріан🐫| cygpath -f - -m)
+
+# This must be kept in sync with appveyor_build.cmd
+BUILD_PREFIX=🐫реализация
+
+export PATH=$(echo $OCAMLROOT| cygpath -f -)/bin/flexdll:$PATH
+
+case "$1" in
+  install)
+    mkdir -p "$OCAMLROOT/bin/flexdll"
+    cd $APPVEYOR_BUILD_FOLDER/../flexdll
+    # msvc64 objects need to be compiled with VS2015, so are copied later from
+    # a source build.
+    for f in flexdll.h flexlink.exe flexdll*_msvc.obj default*.manifest ; do
+      cp $f "$OCAMLROOT/bin/flexdll/"
+    done
+    echo 'eval $($APPVEYOR_BUILD_FOLDER/tools/msvs-promote-path)' >> ~/.bash_profile
+    ;;
+  msvc32-only)
+    cd $APPVEYOR_BUILD_FOLDER/../$BUILD_PREFIX-msvc32
+
+    set_configuration msvc "$OCAMLROOT-msvc32" -WX
+
+    run "make world" make world
+    run "make runtimeopt" make runtimeopt
+    run "make -C otherlibs/systhreads libthreadsnat.lib" \
+         make -C otherlibs/systhreads libthreadsnat.lib
+
+    exit 0
+    ;;
+  test)
+    FULL_BUILD_PREFIX=$APPVEYOR_BUILD_FOLDER/../$BUILD_PREFIX
+    run "ocamlc.opt -version" $FULL_BUILD_PREFIX-msvc64/ocamlc.opt -version
+    run "test msvc64" make -C $FULL_BUILD_PREFIX-msvc64 tests
+    run "test mingw32" make -C $FULL_BUILD_PREFIX-mingw32 tests
+    run "install msvc64" make -C $FULL_BUILD_PREFIX-msvc64 install
+    run "install mingw32" make -C $FULL_BUILD_PREFIX-mingw32 install
+    ;;
+  *)
+    cd $APPVEYOR_BUILD_FOLDER/../$BUILD_PREFIX-msvc64
+
+    tar -xzf $APPVEYOR_BUILD_FOLDER/flexdll.tar.gz
+    cd flexdll-$FLEXDLL_VERSION
+    make MSVC_DETECT=0 CHAINS=msvc64 support
+    cp flexdll*_msvc64.obj "$OCAMLROOT/bin/flexdll/"
+    cd ..
+
+    set_configuration msvc64 "$OCAMLROOT" -WX
+
+    cd ../$BUILD_PREFIX-mingw32
+
+    set_configuration mingw "$OCAMLROOT-mingw32" -Werror
+
+    cd $APPVEYOR_BUILD_FOLDER/../$BUILD_PREFIX-msvc64
+
+    export TERM=ansi
+    script --quiet --return --command "make -C ../$BUILD_PREFIX-mingw32 flexdll world.opt" ../$BUILD_PREFIX-mingw32/build.log >/dev/null 2>/dev/null &
+    BUILD_PID=$!
+
+    run "make world" make world
+    run "make bootstrap" make bootstrap
+    run "make opt" make opt
+    run "make opt.opt" make opt.opt
+
+    set +e
+
+    # For an explanation of the sed command, see https://github.com/appveyor/ci/issues/1824
+    tail --pid=$BUILD_PID -n +1 -f ../$BUILD_PREFIX-mingw32/build.log | sed -e 's/\d027\[K//g' -e 's/\d027\[m/\d027[0m/g' -e 's/\d027\[01\([m;]\)/\d027[1\1/g' &
+    TAIL_PID=$!
+    wait $BUILD_PID
+    STATUS=$?
+    wait $TAIL_PID
+    exit $STATUS
+    ;;
+esac

diff --git a/asmcomp/CSEgen.ml b/asmcomp/CSEgen.ml
index 5ec6ebeb99128b1f79cd858aa1a1c4af97bfc356..7e585355628e8e5e73aab395ee00e55b7ee9ac5c 100644 (file)
--- a/asmcomp/CSEgen.ml
+++ b/asmcomp/CSEgen.ml
@@ -215,7 +215,7 @@ let insert_move srcs dsts i =
 
 class cse_generic = object (self)
 
-(* Default classification of operations.  Can be overriden in
+(* Default classification of operations.  Can be overridden in
    processor-specific files to classify specific operations better. *)
 
 method class_of_operation op =
@@ -235,6 +235,7 @@ method class_of_operation op =
   | Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf
   | Ifloatofint | Iintoffloat -> Op_pure
   | Ispecific _ -> Op_other
+  | Iname_for_debugger _ -> Op_pure
 
 (* Operations that are so cheap that it isn't worth factoring them. *)
 

diff --git a/asmcomp/amd64/arch.ml b/asmcomp/amd64/arch.ml
index 38fc2fb24dbf5b36e285c01c9d0e2115656c24d1..4b5789f13a5a91a623b3bdb2befa7d5394348d91 100644 (file)
--- a/asmcomp/amd64/arch.ml
+++ b/asmcomp/amd64/arch.ml
@@ -39,7 +39,7 @@ type specific_operation =
   | Ioffset_loc of int * addressing_mode (* Add a constant to a location *)
   | Ifloatarithmem of float_operation * addressing_mode
                                        (* Float arith operation with memory *)
-  | Ibswap of int                      (* endiannes conversion *)
+  | Ibswap of int                      (* endianness conversion *)
   | Isqrtf                             (* Float square root *)
   | Ifloatsqrtf of addressing_mode     (* Float square root from memory *)
 and float_operation =

diff --git a/asmcomp/amd64/emit.mlp b/asmcomp/amd64/emit.mlp
index c3f8692a85be8de6715c57addfbed8856af4531f..36ec47ed5911b513b6c2bc909af369cf9cf695ec 100644 (file)
--- a/asmcomp/amd64/emit.mlp
+++ b/asmcomp/amd64/emit.mlp
@@ -139,11 +139,6 @@ let mem__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)
@@ -745,6 +740,7 @@ let emit_instr fallthrough i =
       I.sqrtsd (arg i 0) (res i 0)
   | Lop(Ispecific(Ifloatsqrtf addr)) ->
       I.sqrtsd (addressing addr REAL8 i 0) (res i 0)
+  | Lop (Iname_for_debugger _) -> ()
   | Lreloadretaddr ->
       ()
   | Lreturn ->
@@ -1064,9 +1060,11 @@ let end_assembly() =
   emit_imp_table();
 
   D.data ();
+  D.qword (const 0);  (* PR#6329 *)
   emit_global_label "data_end";
-  D.long (const 0);
+  D.qword (const 0);
 
+  D.align 8;                            (* PR#7591 *)
   emit_global_label "frametable";
 
   let setcnt = ref 0 in

diff --git a/asmcomp/amd64/proc.ml b/asmcomp/amd64/proc.ml
index 0b2cc119cfc815dfcad2401435af76764a9d5b6e..cd21e5264d2053aec4ee9febbe6c177dffa86e1a 100644 (file)
--- a/asmcomp/amd64/proc.ml
+++ b/asmcomp/amd64/proc.ml
@@ -64,9 +64,16 @@ let win64 = Arch.win64
      xmm0 - xmm3: C function arguments
      rbx, rbp, rsi, rdi r12-r15 are preserved by C
      xmm6-xmm15 are preserved by C
-   Note (PR#5707): r11 should not be used for parameter passing, as it
-     can be destroyed by the dynamic loader according to SVR4 ABI.
-     Linux's dynamic loader also destroys r10.
+   Note (PR#5707, GPR#1304): PLT stubs (used for dynamic resolution of symbols
+     on Unix-like platforms) may clobber any register except those used for:
+       1. C parameter passing;
+       2. C return values;
+       3. C callee-saved registers.
+     This translates to the set { r10, r11 }.  These registers hence cannot
+     be used for OCaml parameter passing and must also be marked as
+     destroyed across [Ialloc] (otherwise a call to caml_call_gc@PLT might
+     clobber these two registers before the assembly stub saves them into
+     the GC regs block).
 *)
 
 let max_arguments_for_tailcalls = 10
@@ -129,10 +136,19 @@ let phys_reg n =
 
 let rax = phys_reg 0
 let rdx = phys_reg 4
+let r10 = phys_reg 10
+let r11 = phys_reg 11
 let r13 = phys_reg 9
 let rbp = phys_reg 12
 let rxmm15 = phys_reg 115
 
+let destroyed_by_plt_stub =
+  if not X86_proc.use_plt then [| |] else [| r10; r11 |]
+
+let num_destroyed_by_plt_stub = Array.length destroyed_by_plt_stub
+
+let destroyed_by_plt_stub_set = Reg.set_of_array destroyed_by_plt_stub
+
 let stack_slot slot ty =
   Reg.at_location ty (Stack slot)
 
@@ -157,7 +173,8 @@ let calling_conventions first_int last_int first_float last_float make_stack
         end else begin
           loc.(i) <- stack_slot (make_stack !ofs) ty;
           ofs := !ofs + size_int
-        end
+        end;
+        assert (not (Reg.Set.mem loc.(i) destroyed_by_plt_stub_set))
     | Float ->
         if !float <= last_float then begin
           loc.(i) <- phys_reg !float;
@@ -268,6 +285,15 @@ let destroyed_at_c_call =
        100;101;102;103;104;105;106;107;
        108;109;110;111;112;113;114;115])
 
+let destroyed_at_alloc =
+  let regs =
+    if Config.spacetime then
+      [| rax; loc_spacetime_node_hole |]
+    else
+      [| rax |]
+  in
+  Array.concat [regs; destroyed_by_plt_stub]
+
 let destroyed_at_oper = function
     Iop(Icall_ind _ | Icall_imm _ | Iextcall { alloc = true; }) ->
     all_phys_regs
@@ -275,9 +301,8 @@ let destroyed_at_oper = function
   | Iop(Iintop(Idiv | Imod)) | Iop(Iintop_imm((Idiv | Imod), _))
         -> [| rax; rdx |]
   | Iop(Istore(Single, _, _)) -> [| rxmm15 |]
-  | Iop(Ialloc _) when Config.spacetime
-        -> [| rax; loc_spacetime_node_hole |]
-  | Iop(Ialloc _ | Iintop(Imulh | Icomp _) | Iintop_imm((Icomp _), _))
+  | Iop(Ialloc _) -> destroyed_at_alloc
+  | Iop(Iintop(Imulh | Icomp _) | Iintop_imm((Icomp _), _))
         -> [| rax |]
   | Iop (Iintop (Icheckbound _)) when Config.spacetime ->
       [| loc_spacetime_node_hole |]
@@ -309,7 +334,10 @@ let max_register_pressure = function
         if fp then [| 3; 0 |] else  [| 4; 0 |]
   | Iintop(Idiv | Imod) | Iintop_imm((Idiv | Imod), _) ->
     if fp then [| 10; 16 |] else [| 11; 16 |]
-  | Ialloc _ | Iintop(Icomp _) | Iintop_imm((Icomp _), _) ->
+  | Ialloc _ ->
+    if fp then [| 11 - num_destroyed_by_plt_stub; 16 |]
+    else [| 12 - num_destroyed_by_plt_stub; 16 |]
+  | Iintop(Icomp _) | Iintop_imm((Icomp _), _) ->
     if fp then [| 11; 16 |] else [| 12; 16 |]
   | Istore(Single, _, _) ->
     if fp then [| 12; 15 |] else [| 13; 15 |]

diff --git a/asmcomp/arm/arch.ml b/asmcomp/arm/arch.ml
index 0bee7e1ee2efac9ebaa879f0ad69a56f9d52df2f..2ec00e011efa11a98fabf67903ade0bae11fdd25 100644 (file)
--- a/asmcomp/arm/arch.ml
+++ b/asmcomp/arm/arch.ml
@@ -122,7 +122,7 @@ type specific_operation =
   | Imulsubf      (* floating-point multiply and subtract *)
   | Inegmulsubf   (* floating-point negate, multiply and subtract *)
   | Isqrtf        (* floating-point square root *)
-  | Ibswap of int (* endianess conversion *)
+  | Ibswap of int (* endianness conversion *)
 
 and arith_operation =
     Ishiftadd

diff --git a/asmcomp/arm/emit.mlp b/asmcomp/arm/emit.mlp
index 0563828e0846666779027ebad2152fcb5149750e..1531cb7ad18615e2590f3f586bb107cbe61ba55f 100644 (file)
--- a/asmcomp/arm/emit.mlp
+++ b/asmcomp/arm/emit.mlp
@@ -283,7 +283,7 @@ let gotrel_literals = ref ([] : (label * label) list)
 (* Pending symbol literals *)
 let symbol_literals = ref ([] : (string * label) list)
 (* Total space (in words) occupied by pending literals *)
-let num_literals = ref 0
+let size_literals = ref 0
 
 (* Label a floating-point literal *)
 let float_literal f =
@@ -291,14 +291,14 @@ let float_literal f =
     List.assoc f !float_literals
   with Not_found ->
     let lbl = new_label() in
-    num_literals := !num_literals + 2;
+    size_literals := !size_literals + 2;
     float_literals := (f, lbl) :: !float_literals;
     lbl
 
 (* Label a GOTREL literal *)
 let gotrel_literal l =
   let lbl = new_label() in
-  num_literals := !num_literals + 1;
+  size_literals := !size_literals + 1;
   gotrel_literals := (l, lbl) :: !gotrel_literals;
   lbl
 
@@ -308,7 +308,7 @@ let symbol_literal s =
     List.assoc s !symbol_literals
   with Not_found ->
     let lbl = new_label() in
-    num_literals := !num_literals + 1;
+    size_literals := !size_literals + 1;
     symbol_literals := (s, lbl) :: !symbol_literals;
     lbl
 
@@ -337,7 +337,7 @@ let emit_literals() =
     gotrel_literals := [];
     symbol_literals := []
   end;
-  num_literals := 0
+  size_literals := 0
 
 (* Emit code to load the address of a symbol *)
 
@@ -609,6 +609,7 @@ let emit_instr i =
         let instr = name_for_int_operation op in
         `      {emit_string instr}     {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, #{emit_int n}\n`; 1
     | Lop(Iabsf | Inegf as op) when !fpu = Soft ->
+        assert (i.res.(0).loc = i.arg.(0).loc);
         let instr = (match op with
                        Iabsf -> "bic"
                      | Inegf -> "eor"
@@ -638,6 +639,7 @@ let emit_instr i =
         `      {emit_string instr}     {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
         1
     | Lop(Ispecific(Imuladdf | Inegmuladdf | Imulsubf | Inegmulsubf as op)) ->
+        assert (i.res.(0).loc = i.arg.(0).loc);
         let instr = (match op with
                        Imuladdf    -> "fmacd"
                      | Inegmuladdf -> "fnmacd"
@@ -675,6 +677,7 @@ let emit_instr i =
         | _ ->
             assert false
         end
+    | Lop (Iname_for_debugger _) -> 0
     | Lreloadretaddr ->
         let n = frame_size() in
         `      ldr     lr, [sp, #{emit_int(n-4)}]\n`; 1
@@ -755,26 +758,31 @@ let emit_instr i =
             tramtbl.(j) <- label i.next;
             `  .short  ({emit_label tramtbl.(j)}-.)/2+{emit_int j}\n`
           done;
+          let sz = ref (1 + (Array.length jumptbl + 1) / 2) in
           (* Generate the necessary trampolines *)
           for j = 0 to Array.length tramtbl - 1 do
-            if tramtbl.(j) <> jumptbl.(j) then
-              `{emit_label tramtbl.(j)}:       b       {emit_label jumptbl.(j)}\n`
-          done
+            if tramtbl.(j) <> jumptbl.(j) then begin
+              `{emit_label tramtbl.(j)}:       b       {emit_label jumptbl.(j)}\n`;
+              incr sz
+            end
+          done;
+          !sz
         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
             `  .word   {emit_label jumptbl.(j)}\n`
-          done
+          done;
+          2 + Array.length jumptbl
         end else begin
           (* Slightly slower, but position-independent *)
           `    add     pc, pc, {emit_reg i.arg.(0)}, lsl #2\n`;
           `    nop\n`;
           for j = 0 to Array.length jumptbl - 1 do
             `  b       {emit_label jumptbl.(j)}\n`
-          done
-        end;
-        2 + Array.length jumptbl
+          done;
+          2 + Array.length jumptbl
+        end
     | Lsetuptrap lbl ->
         `      bl      {emit_label lbl}\n`; 1
     | Lpushtrap ->
@@ -796,30 +804,48 @@ let emit_instr i =
           `    pop     \{trap_ptr, pc}\n`; 2
         end
 
+(* Upper bound on the size of the code sequence for a Linear instruction,
+   in 32-bit words. *)
+
+let max_instruction_size i =
+  match i.desc with
+  | Lswitch jumptbl ->
+      if !arch > ARMv6 && !thumb
+      then 1 + (Array.length jumptbl + 1) / 2 + Array.length jumptbl
+      else 2 + Array.length jumptbl
+  | _ ->
+      8   (* conservative upper bound; the true upper bound is probably 5 *)
+
 (* Emission of an instruction sequence *)
 
-let rec emit_all ninstr i =
+let rec emit_all ninstr fallthrough i =
+  (* ninstr = number of 32-bit code words emitted since last constant island *)
+  (* fallthrough is true if previous instruction can fall through *)
   if i.desc = Lend then () else begin
-    let n = emit_instr i in
-    let ninstr' = ninstr + n in
+    (* Make sure literals not yet emitted remain addressable,
+       or emit them in a new constant island. *)
     (* fldd can address up to +/-1KB, ldr can address up to +/-4KB *)
     let limit = (if !fpu >= VFPv2 && !float_literals <> []
                  then 127
                  else 511) in
-    let limit = limit - !num_literals in
-    if ninstr' >= limit - 64 && not(has_fallthrough i.desc) then begin
-      emit_literals();
-      emit_all 0 i.next
-    end else if !num_literals != 0 && ninstr' >= limit then begin
-      let lbl = new_label() in
-      `        b       {emit_label lbl}\n`;
-      emit_literals();
-      `{emit_label lbl}:\n`;
-      emit_all 0 i.next
-    end else
-      emit_all ninstr' i.next
+    let limit = limit - !size_literals - max_instruction_size i in
+    let ninstr' =
+      if ninstr >= limit - 64 && not fallthrough then begin
+        emit_literals();
+        0
+      end else if !size_literals != 0 && ninstr >= limit then begin
+        let lbl = new_label() in
+        `      b       {emit_label lbl}\n`;
+        emit_literals();
+        `{emit_label lbl}:\n`;
+        0
+      end else
+        ninstr in
+    let n = emit_instr i in
+    emit_all (ninstr' + n) (has_fallthrough i.desc) i.next
   end
 
+
 (* Emission of the profiling prelude *)
 
 let emit_profile() =
@@ -862,7 +888,7 @@ let fundecl fundecl =
     end
   end;
   `{emit_label !tailrec_entry_point}:\n`;
-  emit_all 0 fundecl.fun_body;
+  emit_all 0 true fundecl.fun_body;
   emit_literals();
   List.iter emit_call_gc !call_gc_sites;
   List.iter emit_call_bound_error !bound_error_sites;
@@ -929,6 +955,7 @@ let end_assembly () =
   `{emit_symbol lbl_end}:\n`;
   let lbl_end = Compilenv.make_symbol (Some "data_end") in
   `    .data\n`;
+  `    .long 0\n`;  (* PR#6329 *)
   `    .globl  {emit_symbol lbl_end}\n`;
   `{emit_symbol lbl_end}:\n`;
   `    .long   0\n`;

diff --git a/asmcomp/arm/proc.ml b/asmcomp/arm/proc.ml
index 64d9013fc940cf1e1a7f3431c8c134d79ef01a89..df9aaeef9dbfb6769b72c3f634a54b43083db236 100644 (file)
--- a/asmcomp/arm/proc.ml
+++ b/asmcomp/arm/proc.ml
@@ -42,7 +42,7 @@ let word_addressed = false
    Floating-point register map (VFPv{2,3}):
     d0 - d7               general purpose (not preserved)
     d8 - d15              general purpose (preserved)
-    d16 - d31             generat purpose (not preserved), VFPv3 only
+    d16 - d31             general purpose (not preserved), VFPv3 only
 *)
 
 let int_reg_name =

diff --git a/asmcomp/arm/reload.ml b/asmcomp/arm/reload.ml
index f6d9b881db960b647c396c695262d3a01f3642ee..f7b61498e5890877097c261ab53f0faa72b0a193 100644 (file)
--- a/asmcomp/arm/reload.ml
+++ b/asmcomp/arm/reload.ml
@@ -13,7 +13,45 @@
 (*                                                                        *)
 (**************************************************************************)
 
+open Arch
+open Mach
+
 (* Reloading for the ARM *)
 
+class reload = object
+
+inherit Reloadgen.reload_generic as super
+
+method! reload_operation op arg res =
+  let ((arg', res') as argres') = super#reload_operation op arg res in
+  match op with
+  | Iintop Imul | Ispecific Imuladd ->
+      (* On ARM v4 and v5, module [Selection] adds a second, dummy
+         result to multiplication instructions (mul and muladd).  This
+         second result is the same pseudoregister as the first
+         argument to the multiplication.  As shown in MPR#7642,
+         reloading must maintain this invariant.  Otherwise, the second
+         result and the first argument can end up in different registers,
+         and the second result can be used later, even though
+         it is not initialized. *)
+      if Array.length res' >= 2 then res'.(1) <- arg'.(0);
+      argres'
+  | Ispecific(Imuladdf | Inegmuladdf | Imulsubf | Inegmulsubf) ->
+      (* VFP float multiply-add instructions are "two-address" in the
+         sense that they must have [arg.(0) = res.(0)].
+         Preserve this invariant. *)
+      (arg', [|arg'.(0)|])
+  | Iabsf | Inegf when !fpu = Soft ->
+      (* Soft FP neg and abs also have a "two-address" constraint of sorts.
+         64-bit floats are represented by pairs of 32-bit integers,
+        hence there are two arguments and two results.
+        The code emitter assumes [arg.(0) = res.(0)] but supports
+        [arg.(1)] and [res.(1)] being in different registers. *)
+      res'.(0) <- arg'.(0);
+      argres'
+  | _ ->
+      argres'
+end
+
 let fundecl f =
-  (new Reloadgen.reload_generic)#fundecl f
+  (new reload)#fundecl f

diff --git a/asmcomp/arm64/arch.ml b/asmcomp/arm64/arch.ml
index 4eb8b9d94094a5e8caf3eb63e747551efc5d80bf..01362a5e63e316f63d453a91432fa4a4bca6418a 100644 (file)
--- a/asmcomp/arm64/arch.ml
+++ b/asmcomp/arm64/arch.ml
@@ -54,7 +54,7 @@ type specific_operation =
   | Imulsubf      (* floating-point multiply and subtract *)
   | Inegmulsubf   (* floating-point negate, multiply and subtract *)
   | Isqrtf        (* floating-point square root *)
-  | Ibswap of int (* endianess conversion *)
+  | Ibswap of int (* endianness conversion *)
 
 and arith_operation =
     Ishiftadd

diff --git a/asmcomp/arm64/emit.mlp b/asmcomp/arm64/emit.mlp
index f75646e123dd6e0414f281d4e8067911bca6abf8..ba97d813d59f2d5eb948ad863b5f832964eaab71 100644 (file)
--- a/asmcomp/arm64/emit.mlp
+++ b/asmcomp/arm64/emit.mlp
@@ -114,6 +114,7 @@ let emit_addressing addr r =
   | Iindexed ofs ->
       `[{emit_reg r}, #{emit_int ofs}]`
   | Ibased(s, ofs) ->
+      assert (not !Clflags.dlcode);  (* see selection.ml *)
       `[{emit_reg r}, #:lo12:{emit_symbol_offset s ofs}]`
 
 (* Record live pointers at call points *)
@@ -323,7 +324,7 @@ let emit_literals() =
 (* Emit code to load the address of a symbol *)
 
 let emit_load_symbol_addr dst s =
-  if (not !Clflags.dlcode) || Compilenv.symbol_in_current_unit s then begin
+  if not !Clflags.dlcode then begin
     `  adrp    {emit_reg dst}, {emit_symbol s}\n`;
     `  add     {emit_reg dst}, {emit_reg dst}, #:lo12:{emit_symbol s}\n`
   end else begin
@@ -439,8 +440,10 @@ module BR = Branch_relaxation.Make (struct
     | 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 {words = num_words}) when !fastcode_flag ->
+      if num_words <= 0xFFF then 4 else 5
+    | Lop (Ispecific (Ifar_alloc {words = num_words})) when !fastcode_flag ->
+      if num_words <= 0xFFF then 5 else 6
     | Lop (Ialloc { words = num_words; _ })
     | Lop (Ispecific (Ifar_alloc { words = num_words; _ })) ->
       begin match num_words with
@@ -466,6 +469,7 @@ module BR = Branch_relaxation.Make (struct
     | Lop (Ispecific (Imuladd | Imulsub)) -> 1
     | Lop (Ispecific (Ibswap 16)) -> 2
     | Lop (Ispecific (Ibswap _)) -> 1
+    | Lop (Iname_for_debugger _) -> 0
     | Lreloadretaddr -> 0
     | Lreturn -> epilogue_size ()
     | Llabel _ -> 0
@@ -518,8 +522,13 @@ let assembly_code_for_allocation ?label_after_call_gc i ~n ~far =
   if !fastcode_flag then begin
     let lbl_redo = new_label() in
     let lbl_call_gc = new_label() in
+    assert (n < 0x1_000_000);
+    let nl = n land 0xFFF and nh = n land 0xFFF_000 in
     `{emit_label lbl_redo}:`;
-    `  sub     {emit_reg reg_alloc_ptr}, {emit_reg reg_alloc_ptr}, #{emit_int n}\n`;
+    if nh <> 0 then
+      `        sub     {emit_reg reg_alloc_ptr}, {emit_reg reg_alloc_ptr}, #{emit_int nh}\n`;
+    if nl <> 0 then
+      `        sub     {emit_reg reg_alloc_ptr}, {emit_reg reg_alloc_ptr}, #{emit_int nl}\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
@@ -609,6 +618,7 @@ let emit_instr i =
           match addr with
           | Iindexed _ -> i.arg.(0)
           | Ibased(s, ofs) ->
+              assert (not !Clflags.dlcode);  (* see selection.ml *)
               `        adrp    {emit_reg reg_tmp1}, {emit_symbol_offset s ofs}\n`;
               reg_tmp1 in
         begin match size with
@@ -636,6 +646,7 @@ let emit_instr i =
           match addr with
           | Iindexed _ -> i.arg.(1)
           | Ibased(s, ofs) ->
+              assert (not !Clflags.dlcode);
               `        adrp    {emit_reg reg_tmp1}, {emit_symbol_offset s ofs}\n`;
               reg_tmp1 in
         begin match size with
@@ -758,6 +769,7 @@ let emit_instr i =
         | _ ->
             assert false
         end
+    | Lop (Iname_for_debugger _) -> ()
     | Lreloadretaddr ->
         ()
     | Lreturn ->
@@ -924,7 +936,15 @@ let fundecl fundecl =
 
 let emit_item = function
   | Cglobal_symbol s -> `      .globl  {emit_symbol s}\n`;
-  | Cdefine_symbol s -> `{emit_symbol s}:\n`
+  | Cdefine_symbol s ->
+    if !Clflags.dlcode then begin
+      (* GOT relocations against non-global symbols don't seem to work
+         properly: GOT entries are not created for the symbols and the
+         relocations evaluate to random other GOT entries.  For the moment
+         force all symbols to be global. *)
+      `        .globl  {emit_symbol s}\n`;
+    end;
+    `{emit_symbol s}:\n`
   | Cint8 n -> `       .byte   {emit_int n}\n`
   | Cint16 n -> `      .short  {emit_int n}\n`
   | Cint32 n -> `      .long   {emit_nativeint n}\n`
@@ -962,6 +982,7 @@ let end_assembly () =
   `{emit_symbol lbl_end}:\n`;
   let lbl_end = Compilenv.make_symbol (Some "data_end") in
   `    .data\n`;
+  `    .quad   0\n`;  (* PR#6329 *)
   `    .globl  {emit_symbol lbl_end}\n`;
   `{emit_symbol lbl_end}:\n`;
   `    .long   0\n`;

diff --git a/asmcomp/arm64/proc.ml b/asmcomp/arm64/proc.ml
index 94062bbf411646cc83b29095f3d56b5d08c1c686..30c69cb9e2bb6ba05278c80d1dbef11f456cc165 100644 (file)
--- a/asmcomp/arm64/proc.ml
+++ b/asmcomp/arm64/proc.ml
@@ -43,7 +43,7 @@ let word_addressed = false
    Floating-point register map:
     d0 - d7               general purpose (caller-save)
     d8 - d15              general purpose (callee-save)
-    d16 - d31             generat purpose (caller-save)
+    d16 - d31             general purpose (caller-save)
 *)
 
 let int_reg_name =

diff --git a/asmcomp/arm64/selection.ml b/asmcomp/arm64/selection.ml
index d8ea7f83bf8a392ad215d3517bcd54a36e967bf6..b714d0032cf59b552fefd2df0db175959c44e923 100644 (file)
--- a/asmcomp/arm64/selection.ml
+++ b/asmcomp/arm64/selection.ml
@@ -82,8 +82,8 @@ let inline_ops =
   [ "sqrt"; "caml_bswap16_direct"; "caml_int32_direct_bswap";
     "caml_int64_direct_bswap"; "caml_nativeint_direct_bswap" ]
 
-let use_direct_addressing symb =
-  (not !Clflags.dlcode) || Compilenv.symbol_in_current_unit symb
+let use_direct_addressing _symb =
+  not !Clflags.dlcode
 
 (* Instruction selection *)
 

diff --git a/asmcomp/asmgen.ml b/asmcomp/asmgen.ml
index 020732dd6684070578fb896b9ef5d03d9c1e2e5f..2d8dc3f809954c2794ce8259898581bbe66f6eb5 100644 (file)
--- a/asmcomp/asmgen.ml
+++ b/asmcomp/asmgen.ml
@@ -80,10 +80,18 @@ let rec regalloc ppf round fd =
     fatal_error(fd.Mach.fun_name ^
                 ": function too complex, cannot complete register allocation");
   dump_if ppf dump_live "Liveness analysis" fd;
-  Interf.build_graph fd;
-  if !dump_interf then Printmach.interferences ppf ();
-  if !dump_prefer then Printmach.preferences ppf ();
-  Coloring.allocate_registers();
+  if !use_linscan then begin
+    (* Linear Scan *)
+    Interval.build_intervals fd;
+    if !dump_interval then Printmach.intervals ppf ();
+    Linscan.allocate_registers()
+  end else begin
+    (* Graph Coloring *)
+    Interf.build_graph fd;
+    if !dump_interf then Printmach.interferences ppf ();
+    if !dump_prefer then Printmach.preferences ppf ();
+    Coloring.allocate_registers()
+  end;
   dump_if ppf dump_regalloc "After register allocation" fd;
   let (newfd, redo_regalloc) = Reload.fundecl fd in
   dump_if ppf dump_reload "After insertion of reloading code" newfd;
@@ -96,29 +104,29 @@ let (++) x f = f x
 let compile_fundecl (ppf : formatter) fd_cmm =
   Proc.init ();
   Reg.reset();
-  let build = Compilenv.current_build () in
   fd_cmm
-  ++ Timings.(accumulate_time (Selection build)) Selection.fundecl
+  ++ Profile.record ~accumulate:true "selection" Selection.fundecl
   ++ pass_dump_if ppf dump_selection "After instruction selection"
-  ++ Timings.(accumulate_time (Comballoc build)) Comballoc.fundecl
+  ++ Profile.record ~accumulate:true "comballoc" Comballoc.fundecl
   ++ pass_dump_if ppf dump_combine "After allocation combining"
-  ++ Timings.(accumulate_time (CSE build)) CSE.fundecl
+  ++ Profile.record ~accumulate:true "cse" CSE.fundecl
   ++ pass_dump_if ppf dump_cse "After CSE"
-  ++ Timings.(accumulate_time (Liveness build)) (liveness ppf)
-  ++ Timings.(accumulate_time (Deadcode build)) Deadcode.fundecl
+  ++ Profile.record ~accumulate:true "liveness" (liveness ppf)
+  ++ Profile.record ~accumulate:true "deadcode" Deadcode.fundecl
   ++ pass_dump_if ppf dump_live "Liveness analysis"
-  ++ Timings.(accumulate_time (Spill build)) Spill.fundecl
-  ++ Timings.(accumulate_time (Liveness build)) (liveness ppf)
+  ++ Profile.record ~accumulate:true "spill" Spill.fundecl
+  ++ Profile.record ~accumulate:true "liveness" (liveness ppf)
   ++ pass_dump_if ppf dump_spill "After spilling"
-  ++ Timings.(accumulate_time (Split build)) Split.fundecl
+  ++ Profile.record ~accumulate:true "split" Split.fundecl
   ++ pass_dump_if ppf dump_split "After live range splitting"
-  ++ Timings.(accumulate_time (Liveness build)) (liveness ppf)
-  ++ Timings.(accumulate_time (Regalloc build)) (regalloc ppf 1)
-  ++ Timings.(accumulate_time (Linearize build)) Linearize.fundecl
+  ++ Profile.record ~accumulate:true "liveness" (liveness ppf)
+  ++ Profile.record ~accumulate:true "regalloc" (regalloc ppf 1)
+  ++ Profile.record ~accumulate:true "available_regs" Available_regs.fundecl
+  ++ Profile.record ~accumulate:true "linearize" Linearize.fundecl
   ++ pass_dump_linear_if ppf dump_linear "Linearized code"
-  ++ Timings.(accumulate_time (Scheduling build)) Scheduling.fundecl
+  ++ Profile.record ~accumulate:true "scheduling" Scheduling.fundecl
   ++ pass_dump_linear_if ppf dump_scheduling "After instruction scheduling"
-  ++ Timings.(accumulate_time (Emit build)) Emit.fundecl
+  ++ Profile.record ~accumulate:true "emit" Emit.fundecl
 
 let compile_phrase ppf p =
   if !dump_cmm then fprintf ppf "%a@." Printcmm.phrase p;
@@ -137,7 +145,7 @@ let compile_genfuns ppf f =
        | _ -> ())
     (Cmmgen.generic_functions true [Compilenv.current_unit_infos ()])
 
-let compile_unit ~source_provenance _output_prefix asm_filename keep_asm
+let compile_unit _output_prefix asm_filename keep_asm
       obj_filename gen =
   let create_asm = keep_asm || not !Emitaux.binary_backend_available in
   Emitaux.create_asm_file := create_asm;
@@ -152,7 +160,7 @@ let compile_unit ~source_provenance _output_prefix asm_filename keep_asm
       raise exn
     end;
     let assemble_result =
-      Timings.(time (Assemble source_provenance))
+      Profile.record "assemble"
         (Proc.assemble_file asm_filename) obj_filename
     in
     if assemble_result <> 0
@@ -166,13 +174,12 @@ let set_export_info (ulambda, prealloc, structured_constants, export) =
   Compilenv.set_export_info export;
   (ulambda, prealloc, structured_constants)
 
-let end_gen_implementation ?toplevel ~source_provenance ppf
+let end_gen_implementation ?toplevel ppf
     (clambda:clambda_and_constants) =
   Emit.begin_assembly ();
   clambda
-  ++ Timings.(time (Cmm source_provenance)) Cmmgen.compunit
-  ++ Timings.(time (Compile_phrases source_provenance))
-       (List.iter (compile_phrase ppf))
+  ++ Profile.record "cmm" Cmmgen.compunit
+  ++ Profile.record "compile_phrases" (List.iter (compile_phrase ppf))
   ++ (fun () -> ());
   (match toplevel with None -> () | Some f -> compile_genfuns ppf f);
 
@@ -189,11 +196,11 @@ let end_gen_implementation ?toplevel ~source_provenance ppf
     );
   Emit.end_assembly ()
 
-let flambda_gen_implementation ?toplevel ~source_provenance ~backend ppf
+let flambda_gen_implementation ?toplevel ~backend ppf
     (program:Flambda.program) =
   let export = Build_export_info.build_export_info ~backend program in
   let (clambda, preallocated, constants) =
-    Timings.time (Flambda_pass ("backend", source_provenance)) (fun () ->
+    Profile.record_call "backend" (fun () ->
       (program, export)
       ++ Flambda_to_clambda.convert
       ++ flambda_raw_clambda_dump_if ppf
@@ -203,7 +210,7 @@ let flambda_gen_implementation ?toplevel ~source_provenance ~backend ppf
                 [Cmmgen.compunit_and_constants]. *)
            Un_anf.apply expr ~what:"init_code", preallocated_blocks,
            structured_constants, exported)
-      ++ set_export_info) ()
+      ++ set_export_info)
   in
   let constants =
     List.map (fun (symbol, definition) ->
@@ -212,10 +219,10 @@ let flambda_gen_implementation ?toplevel ~source_provenance ~backend ppf
           definition })
       (Symbol.Map.bindings constants)
   in
-  end_gen_implementation ?toplevel ~source_provenance ppf
+  end_gen_implementation ?toplevel ppf
     (clambda, preallocated, constants)
 
-let lambda_gen_implementation ?toplevel ~source_provenance ppf
+let lambda_gen_implementation ?toplevel ppf
     (lambda:Lambda.program) =
   let clambda = Closure.intro lambda.main_module_block_size lambda.code in
   let preallocated_block =
@@ -230,29 +237,29 @@ let lambda_gen_implementation ?toplevel ~source_provenance ppf
     clambda, [preallocated_block], []
   in
   raw_clambda_dump_if ppf clambda_and_constants;
-  end_gen_implementation ?toplevel ~source_provenance ppf clambda_and_constants
+  end_gen_implementation ?toplevel ppf clambda_and_constants
 
-let compile_implementation_gen ?toplevel ~source_provenance prefixname
+let compile_implementation_gen ?toplevel prefixname
     ~required_globals ppf gen_implementation program =
   let asmfile =
     if !keep_asm_file || !Emitaux.binary_backend_available
     then prefixname ^ ext_asm
     else Filename.temp_file "camlasm" ext_asm
   in
-  compile_unit ~source_provenance prefixname asmfile !keep_asm_file
+  compile_unit prefixname asmfile !keep_asm_file
       (prefixname ^ ext_obj) (fun () ->
         Ident.Set.iter Compilenv.require_global required_globals;
-        gen_implementation ?toplevel ~source_provenance ppf program)
+        gen_implementation ?toplevel ppf program)
 
-let compile_implementation_clambda ?toplevel ~source_provenance prefixname
+let compile_implementation_clambda ?toplevel prefixname
     ppf (program:Lambda.program) =
-  compile_implementation_gen ?toplevel ~source_provenance prefixname
+  compile_implementation_gen ?toplevel prefixname
     ~required_globals:program.Lambda.required_globals
     ppf lambda_gen_implementation program
 
-let compile_implementation_flambda ?toplevel ~source_provenance prefixname
+let compile_implementation_flambda ?toplevel prefixname
     ~required_globals ~backend ppf (program:Flambda.program) =
-  compile_implementation_gen ?toplevel ~source_provenance prefixname
+  compile_implementation_gen ?toplevel prefixname
     ~required_globals ppf (flambda_gen_implementation ~backend) program
 
 (* Error report *)

diff --git a/asmcomp/asmgen.mli b/asmcomp/asmgen.mli
index cc79edf9af17c4c32f1ef93ac1c637ef552b5a7a..e70ee5116df3301a0e6c5489646b9db2fc48dce1 100644 (file)
--- a/asmcomp/asmgen.mli
+++ b/asmcomp/asmgen.mli
@@ -17,7 +17,6 @@
 
 val compile_implementation_flambda :
     ?toplevel:(string -> bool) ->
-    source_provenance:Timings.source_provenance ->
     string ->
     required_globals:Ident.Set.t ->
     backend:(module Backend_intf.S) ->
@@ -25,7 +24,6 @@ val compile_implementation_flambda :
 
 val compile_implementation_clambda :
     ?toplevel:(string -> bool) ->
-    source_provenance:Timings.source_provenance ->
     string ->
     Format.formatter -> Lambda.program -> unit
 
@@ -38,7 +36,6 @@ val report_error: Format.formatter -> error -> unit
 
 
 val compile_unit:
-  source_provenance:Timings.source_provenance ->
   string(*prefixname*) ->
   string(*asm file*) -> bool(*keep asm*) ->
   string(*obj file*) -> (unit -> unit) -> unit

diff --git a/asmcomp/asmlink.ml b/asmcomp/asmlink.ml
index fee717871290a25ea69c7b48a7e29c0a49a21448..fe93e5e14b9dea98ad357e42a393eedeee2fe3c4 100644 (file)
--- a/asmcomp/asmlink.ml
+++ b/asmcomp/asmlink.ml
@@ -206,7 +206,7 @@ let scan_file obj_name tolink = match read_file obj_name with
 let make_startup_file ppf units_list =
   let compile_phrase p = Asmgen.compile_phrase ppf p in
   Location.input_name := "caml_startup"; (* set name of "current" input *)
-  Compilenv.reset ~source_provenance:Timings.Startup "_startup";
+  Compilenv.reset "_startup";
   (* set the name of the "current" compunit *)
   Emit.begin_assembly ();
   let name_list =
@@ -243,7 +243,7 @@ let make_startup_file ppf units_list =
 let make_shared_startup_file ppf units =
   let compile_phrase p = Asmgen.compile_phrase ppf p in
   Location.input_name := "caml_startup";
-  Compilenv.reset ~source_provenance:Timings.Startup "_shared_startup";
+  Compilenv.reset "_shared_startup";
   Emit.begin_assembly ();
   List.iter compile_phrase
     (Cmmgen.generic_functions true (List.map fst units));
@@ -260,28 +260,30 @@ let call_linker_shared file_list output_name =
   then raise(Error Linking_error)
 
 let link_shared ppf objfiles output_name =
-  let units_tolink = List.fold_right scan_file objfiles [] in
-  List.iter
-    (fun (info, file_name, crc) -> check_consistency file_name info crc)
-    units_tolink;
-  Clflags.ccobjs := !Clflags.ccobjs @ !lib_ccobjs;
-  Clflags.all_ccopts := !lib_ccopts @ !Clflags.all_ccopts;
-  let objfiles = List.rev (List.map object_file_name objfiles) @
-    (List.rev !Clflags.ccobjs) in
-
-  let startup =
-    if !Clflags.keep_startup_file || !Emitaux.binary_backend_available
-    then output_name ^ ".startup" ^ ext_asm
-    else Filename.temp_file "camlstartup" ext_asm in
-  let startup_obj = output_name ^ ".startup" ^ ext_obj in
-  Asmgen.compile_unit ~source_provenance:Timings.Startup output_name
-    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
+  Profile.record_call output_name (fun () ->
+    let units_tolink = List.fold_right scan_file objfiles [] in
+    List.iter
+      (fun (info, file_name, crc) -> check_consistency file_name info crc)
+      units_tolink;
+    Clflags.ccobjs := !Clflags.ccobjs @ !lib_ccobjs;
+    Clflags.all_ccopts := !lib_ccopts @ !Clflags.all_ccopts;
+    let objfiles = List.rev (List.map object_file_name objfiles) @
+      (List.rev !Clflags.ccobjs) in
+
+    let startup =
+      if !Clflags.keep_startup_file || !Emitaux.binary_backend_available
+      then output_name ^ ".startup" ^ ext_asm
+      else Filename.temp_file "camlstartup" ext_asm in
+    let startup_obj = output_name ^ ".startup" ^ ext_obj in
+    Asmgen.compile_unit output_name
+      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
@@ -313,38 +315,40 @@ let call_linker file_list startup_file output_name =
 (* Main entry point *)
 
 let link ppf objfiles output_name =
-  let stdlib =
-    if !Clflags.gprofile then "stdlib.p.cmxa" else "stdlib.cmxa" in
-  let stdexit =
-    if !Clflags.gprofile then "std_exit.p.cmx" else "std_exit.cmx" in
-  let objfiles =
-    if !Clflags.nopervasives then objfiles
-    else if !Clflags.output_c_object then stdlib :: objfiles
-    else stdlib :: (objfiles @ [stdexit]) in
-  let units_tolink = List.fold_right scan_file objfiles [] in
-  Array.iter remove_required Runtimedef.builtin_exceptions;
-  begin match extract_missing_globals() with
-    [] -> ()
-  | mg -> raise(Error(Missing_implementations mg))
-  end;
-  List.iter
-    (fun (info, file_name, crc) -> check_consistency file_name info crc)
-    units_tolink;
-  Clflags.ccobjs := !Clflags.ccobjs @ !lib_ccobjs;
-  Clflags.all_ccopts := !lib_ccopts @ !Clflags.all_ccopts;
-                                               (* put user's opts first *)
-  let startup =
-    if !Clflags.keep_startup_file || !Emitaux.binary_backend_available
-    then output_name ^ ".startup" ^ ext_asm
-    else Filename.temp_file "camlstartup" ext_asm in
-  let startup_obj = Filename.temp_file "camlstartup" ext_obj in
-  Asmgen.compile_unit ~source_provenance:Timings.Startup output_name
-    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)
+  Profile.record_call output_name (fun () ->
+    let stdlib =
+      if !Clflags.gprofile then "stdlib.p.cmxa" else "stdlib.cmxa" in
+    let stdexit =
+      if !Clflags.gprofile then "std_exit.p.cmx" else "std_exit.cmx" in
+    let objfiles =
+      if !Clflags.nopervasives then objfiles
+      else if !Clflags.output_c_object then stdlib :: objfiles
+      else stdlib :: (objfiles @ [stdexit]) in
+    let units_tolink = List.fold_right scan_file objfiles [] in
+    Array.iter remove_required Runtimedef.builtin_exceptions;
+    begin match extract_missing_globals() with
+      [] -> ()
+    | mg -> raise(Error(Missing_implementations mg))
+    end;
+    List.iter
+      (fun (info, file_name, crc) -> check_consistency file_name info crc)
+      units_tolink;
+    Clflags.ccobjs := !Clflags.ccobjs @ !lib_ccobjs;
+    Clflags.all_ccopts := !lib_ccopts @ !Clflags.all_ccopts;
+                                                 (* put user's opts first *)
+    let startup =
+      if !Clflags.keep_startup_file || !Emitaux.binary_backend_available
+      then output_name ^ ".startup" ^ ext_asm
+      else Filename.temp_file "camlstartup" ext_asm in
+    let startup_obj = Filename.temp_file "camlstartup" ext_obj in
+    Asmgen.compile_unit output_name
+      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 09db234b40f225155a5e6d6131b3c29a38a320d2..5a8c27944b61c593e60de6bfa9728b92693753fd 100644 (file)
--- a/asmcomp/asmpackager.ml
+++ b/asmcomp/asmpackager.ml
@@ -81,56 +81,55 @@ let check_units members =
 
 let make_package_object ppf members targetobj targetname coercion
       ~backend =
-  let objtemp =
-    if !Clflags.keep_asm_file
-    then Filename.remove_extension targetobj ^ ".pack" ^ Config.ext_obj
-    else
-      (* Put the full name of the module in the temporary file name
-         to avoid collisions with MSVC's link /lib in case of successive
-         packs *)
-      Filename.temp_file (Compilenv.make_symbol (Some "")) Config.ext_obj in
-  let components =
-    List.map
-      (fun m ->
-        match m.pm_kind with
-        | PM_intf -> None
-        | PM_impl _ -> Some(Ident.create_persistent m.pm_name))
-      members in
-  let module_ident = Ident.create_persistent targetname in
-  let source_provenance = Timings.Pack targetname in
-  let prefixname = Filename.remove_extension objtemp in
-  if Config.flambda then begin
-    let size, lam = Translmod.transl_package_flambda components coercion in
-    let flam =
-      Middle_end.middle_end ppf
-        ~source_provenance
-        ~prefixname
-        ~backend
-        ~size
-        ~filename:targetname
-        ~module_ident
-        ~module_initializer:lam
+  Profile.record_call (Printf.sprintf "pack(%s)" targetname) (fun () ->
+    let objtemp =
+      if !Clflags.keep_asm_file
+      then Filename.remove_extension targetobj ^ ".pack" ^ Config.ext_obj
+      else
+        (* Put the full name of the module in the temporary file name
+           to avoid collisions with MSVC's link /lib in case of successive
+           packs *)
+        Filename.temp_file (Compilenv.make_symbol (Some "")) Config.ext_obj in
+    let components =
+      List.map
+        (fun m ->
+          match m.pm_kind with
+          | PM_intf -> None
+          | PM_impl _ -> Some(Ident.create_persistent m.pm_name))
+        members in
+    let module_ident = Ident.create_persistent targetname in
+    let prefixname = Filename.remove_extension objtemp in
+    if Config.flambda then begin
+      let size, lam = Translmod.transl_package_flambda components coercion in
+      let flam =
+        Middle_end.middle_end ppf
+          ~prefixname
+          ~backend
+          ~size
+          ~filename:targetname
+          ~module_ident
+          ~module_initializer:lam
+      in
+      Asmgen.compile_implementation_flambda
+        prefixname ~backend ~required_globals:Ident.Set.empty ppf flam;
+    end else begin
+      let main_module_block_size, code =
+        Translmod.transl_store_package
+          components (Ident.create_persistent targetname) coercion in
+      Asmgen.compile_implementation_clambda
+        prefixname ppf { Lambda.code; main_module_block_size;
+                         module_ident; required_globals = Ident.Set.empty }
+    end;
+    let objfiles =
+      List.map
+        (fun m -> Filename.remove_extension m.pm_file ^ Config.ext_obj)
+        (List.filter (fun m -> m.pm_kind <> PM_intf) members) in
+    let ok =
+      Ccomp.call_linker Ccomp.Partial targetobj (objtemp :: objfiles) ""
     in
-    Asmgen.compile_implementation_flambda ~source_provenance
-      prefixname ~backend ~required_globals:Ident.Set.empty ppf flam;
-  end else begin
-    let main_module_block_size, code =
-      Translmod.transl_store_package
-        components (Ident.create_persistent targetname) coercion in
-    Asmgen.compile_implementation_clambda ~source_provenance
-      prefixname ppf { Lambda.code; main_module_block_size;
-                       module_ident; required_globals = Ident.Set.empty }
-  end;
-  let objfiles =
-    List.map
-      (fun m -> Filename.remove_extension m.pm_file ^ Config.ext_obj)
-      (List.filter (fun m -> m.pm_kind <> PM_intf) members) in
-  let ok =
-    Ccomp.call_linker Ccomp.Partial targetobj (objtemp :: objfiles) ""
-  in
-  remove_file objtemp;
-  if not ok then raise(Error Linking_error)
-
+    remove_file objtemp;
+    if not ok then raise(Error Linking_error)
+  )
 (* Make the .cmx file for the package *)
 
 let get_export_info ui =
@@ -248,8 +247,7 @@ let package_files ppf initial_env files targetcmx ~backend =
   (* Set the name of the current "input" *)
   Location.input_name := targetcmx;
   (* Set the name of the current compunit *)
-  Compilenv.reset ~source_provenance:(Timings.Pack targetname)
-    ?packname:!Clflags.for_package targetname;
+  Compilenv.reset ?packname:!Clflags.for_package targetname;
   try
     let coercion =
       Typemod.package_units initial_env files targetcmi targetname in

diff --git a/asmcomp/clambda.ml b/asmcomp/clambda.ml
index 7d21fcd82496461dd44067037d438d780a086b0e..b0fa607d2d27bda2fe1c142913c55a5b5e3a4454 100644 (file)
--- a/asmcomp/clambda.ml
+++ b/asmcomp/clambda.ml
@@ -46,7 +46,7 @@ and ulambda =
   | Ulet of mutable_flag * value_kind * Ident.t * ulambda * ulambda
   | Uletrec of (Ident.t * ulambda) list * ulambda
   | Uprim of primitive * ulambda list * Debuginfo.t
-  | Uswitch of ulambda * ulambda_switch
+  | Uswitch of ulambda * ulambda_switch * Debuginfo.t
   | Ustringswitch of ulambda * (string * ulambda) list * ulambda option
   | Ustaticfail of int * ulambda list
   | Ucatch of int * Ident.t list * ulambda * ulambda

diff --git a/asmcomp/clambda.mli b/asmcomp/clambda.mli
index 6a6bc1b2932d5eed4ababe7cf083f7ef9d7547eb..c2e5d137b763115e7cb53a13e8a83c3d0de4cc96 100644 (file)
--- a/asmcomp/clambda.mli
+++ b/asmcomp/clambda.mli
@@ -46,7 +46,7 @@ and ulambda =
   | Ulet of mutable_flag * value_kind * Ident.t * ulambda * ulambda
   | Uletrec of (Ident.t * ulambda) list * ulambda
   | Uprim of primitive * ulambda list * Debuginfo.t
-  | Uswitch of ulambda * ulambda_switch
+  | Uswitch of ulambda * ulambda_switch * Debuginfo.t
   | Ustringswitch of ulambda * (string * ulambda) list * ulambda option
   | Ustaticfail of int * ulambda list
   | Ucatch of int * Ident.t list * ulambda * ulambda

diff --git a/asmcomp/closure.ml b/asmcomp/closure.ml
index 1bdc4392e2da52959562416dcbb8e52702c3378f..e86ecb6bacc924d2116e74308bd76656c5b3e9e6 100644 (file)
--- a/asmcomp/closure.ml
+++ b/asmcomp/closure.ml
@@ -28,6 +28,7 @@ module Storer =
       type t = lambda
       type key = lambda
       let make_key =  Lambda.make_key
+      let compare_key = Pervasives.compare
     end)
 
 (* Auxiliaries for compiling functions *)
@@ -68,7 +69,7 @@ let occurs_var var u =
     | Uletrec(decls, body) ->
         List.exists (fun (_id, u) -> occurs u) decls || occurs body
     | Uprim(_p, args, _) -> List.exists occurs args
-    | Uswitch(arg, s) ->
+    | Uswitch(arg, s, _dbg) ->
         occurs arg ||
         occurs_array s.us_actions_consts || occurs_array s.us_actions_blocks
     | Ustringswitch(arg,sw,d) ->
@@ -159,7 +160,7 @@ let lambda_smaller lam threshold =
     | Uprim(prim, args, _) ->
         size := !size + prim_size prim args;
         lambda_list_size args
-    | Uswitch(lam, cases) ->
+    | Uswitch(lam, cases, _dbg) ->
         if Array.length cases.us_actions_consts > 1 then size := !size + 5 ;
         if Array.length cases.us_actions_blocks > 1 then size := !size + 5 ;
         lambda_size lam;
@@ -571,7 +572,7 @@ let rec substitute loc fpc sb ulam =
       let (res, _) =
         simplif_prim fpc p (sargs, List.map approx_ulam sargs) dbg in
       res
-  | Uswitch(arg, sw) ->
+  | Uswitch(arg, sw, dbg) ->
       let sarg = substitute loc fpc sb arg in
       let action =
         (* Unfortunately, we cannot easily deal with the
@@ -596,7 +597,8 @@ let rec substitute loc fpc sb ulam =
                       Array.map (substitute loc fpc sb) sw.us_actions_consts;
                     us_actions_blocks =
                       Array.map (substitute loc fpc sb) sw.us_actions_blocks;
-                  })
+                  },
+                  dbg)
       end
   | Ustringswitch(arg,sw,d) ->
       Ustringswitch
@@ -993,7 +995,7 @@ let rec close fenv cenv = function
       let dbg = Debuginfo.from_location loc in
       simplif_prim !Clflags.float_const_prop
                    p (close_list_approx fenv cenv args) dbg
-  | Lswitch(arg, sw) ->
+  | Lswitch(arg, sw, dbg) ->
       let fn fail =
         let (uarg, _) = close fenv cenv arg in
         let const_index, const_actions, fconst =
@@ -1006,7 +1008,9 @@ let rec close fenv cenv = function
              {us_index_consts = const_index;
               us_actions_consts = const_actions;
               us_index_blocks = block_index;
-              us_actions_blocks = block_actions})  in
+              us_actions_blocks = block_actions},
+             Debuginfo.from_location dbg)
+        in
         (fconst (fblock ulam),Value_unknown) in
 (* NB: failaction might get copied, thus it should be some Lstaticraise *)
       let fail = sw.sw_failaction in
@@ -1332,7 +1336,7 @@ let collect_exported_structured_constants a =
     | Ulet (_str, _kind, _, u1, u2) -> ulam u1; ulam u2
     | Uletrec (l, u) -> List.iter (fun (_, u) -> ulam u) l; ulam u
     | Uprim (_, ul, _) -> List.iter ulam ul
-    | Uswitch (u, sl) ->
+    | Uswitch (u, sl, _dbg) ->
         ulam u;
         Array.iter ulam sl.us_actions_consts;
         Array.iter ulam sl.us_actions_blocks

diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml
index 4ac4b40c63e330e4a0a9edad8aeed70060add4a1..ad1e58536ea051a9f21ba059e44bd8c555615821 100644 (file)
--- a/asmcomp/cmmgen.ml
+++ b/asmcomp/cmmgen.ml
@@ -244,8 +244,8 @@ let force_tag_int i dbg =
   match i with
     Cconst_int n ->
       int_const n
-  | Cop(Casr, [c; Cconst_int n], dbg) when n > 0 ->
-      Cop(Cor, [asr_int c (Cconst_int (n - 1)) dbg; Cconst_int 1], dbg)
+  | Cop(Casr, [c; Cconst_int n], dbg') when n > 0 ->
+      Cop(Cor, [asr_int c (Cconst_int (n - 1)) dbg'; Cconst_int 1], dbg)
   | c ->
       Cop(Cor, [lsl_int c (Cconst_int 1) dbg; Cconst_int 1], dbg)
 
@@ -262,13 +262,49 @@ let untag_int i dbg =
   | Cop(Cor, [c; Cconst_int 1], _) -> Cop(Casr, [c; Cconst_int 1], dbg)
   | c -> Cop(Casr, [c; Cconst_int 1], dbg)
 
-let if_then_else (cond, ifso, ifnot) =
+(* Description of the "then" and "else" continuations in [transl_if]. If
+   the "then" continuation is true and the "else" continuation is false then
+   we can use the condition directly as the result. Similarly, if the "then"
+   continuation is false and the "else" continuation is true then we can use
+   the negation of the condition directly as the result. *)
+type then_else =
+  | Then_true_else_false
+  | Then_false_else_true
+  | Unknown
+
+let invert_then_else = function
+  | Then_true_else_false -> Then_false_else_true
+  | Then_false_else_true -> Then_true_else_false
+  | Unknown -> Unknown
+
+let mk_if_then_else cond ifso ifnot =
   match cond with
   | Cconst_int 0 -> ifnot
   | Cconst_int 1 -> ifso
   | _ ->
     Cifthenelse(cond, ifso, ifnot)
 
+let mk_not dbg cmm =
+  match cmm with
+  | Cop(Caddi, [Cop(Clsl, [c; Cconst_int 1], _); Cconst_int 1], dbg') -> begin
+      match c with
+      | Cop(Ccmpi cmp, [c1; c2], dbg'') ->
+          tag_int (Cop(Ccmpi (negate_comparison cmp), [c1; c2], dbg'')) dbg'
+      | Cop(Ccmpa cmp, [c1; c2], dbg'') ->
+          tag_int (Cop(Ccmpa (negate_comparison cmp), [c1; c2], dbg'')) dbg'
+      | Cop(Ccmpf cmp, [c1; c2], dbg'') ->
+          tag_int (Cop(Ccmpf (negate_comparison cmp), [c1; c2], dbg'')) dbg'
+      | _ ->
+        (* 0 -> 3, 1 -> 1 *)
+        Cop(Csubi, [Cconst_int 3; Cop(Clsl, [c; Cconst_int 1], dbg)], dbg)
+    end
+  | Cconst_int 3 -> Cconst_int 1
+  | Cconst_int 1 -> Cconst_int 3
+  | c ->
+      (* 1 -> 3, 3 -> 1 *)
+      Cop(Csubi, [Cconst_int 4; c], dbg)
+
+
 (* Turning integer divisions into multiply-high then shift.
    The [division_parameters] function is used in module Emit for
    those target platforms that support this optimization. *)
@@ -505,8 +541,8 @@ let rec unbox_float dbg cmm =
   | Cifthenelse(cond, e1, e2) ->
       Cifthenelse(cond, unbox_float dbg e1, unbox_float dbg e2)
   | Csequence(e1, e2) -> Csequence(e1, unbox_float dbg e2)
-  | Cswitch(e, tbl, el, dbg) ->
-    Cswitch(e, tbl, Array.map (unbox_float dbg) el, dbg)
+  | Cswitch(e, tbl, el, dbg') ->
+    Cswitch(e, tbl, Array.map (unbox_float dbg) el, dbg')
   | Ccatch(rec_flag, handlers, body) ->
     map_ccatch (unbox_float dbg) rec_flag handlers body
   | Ctrywith(e1, id, e2) -> Ctrywith(unbox_float dbg e1, id, unbox_float dbg e2)
@@ -640,11 +676,11 @@ let array_indexing ?typ log2size ptr ofs dbg =
   | Cconst_int n ->
       let i = n asr 1 in
       if i = 0 then ptr else Cop(add, [ptr; Cconst_int(i lsl log2size)], dbg)
-  | Cop(Caddi, [Cop(Clsl, [c; Cconst_int 1], _); Cconst_int 1], _) ->
-      Cop(add, [ptr; lsl_const c log2size dbg], dbg)
-  | Cop(Caddi, [c; Cconst_int n], _) when log2size = 0 ->
+  | Cop(Caddi, [Cop(Clsl, [c; Cconst_int 1], _); Cconst_int 1], dbg') ->
+      Cop(add, [ptr; lsl_const c log2size dbg], dbg')
+  | Cop(Caddi, [c; Cconst_int n], dbg') when log2size = 0 ->
       Cop(add, [Cop(add, [ptr; untag_int c dbg], dbg); Cconst_int (n asr 1)],
-        dbg)
+        dbg')
   | Cop(Caddi, [c; Cconst_int n], _) ->
       Cop(add, [Cop(add, [ptr; lsl_const c (log2size - 1) dbg], dbg);
                     Cconst_int((n-1) lsl (log2size - 1))], dbg)
@@ -789,7 +825,12 @@ let rec expr_size env = function
       RHS_block (fundecls_size fundecls + List.length clos_vars)
   | Ulet(_str, _kind, id, exp, body) ->
       expr_size (Ident.add id (expr_size env exp) env) body
-  | Uletrec(_bindings, body) ->
+  | Uletrec(bindings, body) ->
+      let env =
+        List.fold_right
+          (fun (id, exp) env -> Ident.add id (expr_size env exp) env)
+          bindings env
+      in
       expr_size env body
   | Uprim(Pmakeblock _, args, _) ->
       RHS_block (List.length args)
@@ -797,6 +838,10 @@ let rec expr_size env = function
       RHS_block (List.length args)
   | Uprim(Pmakearray(Pfloatarray, _), args, _) ->
       RHS_floatblock (List.length args)
+  | Uprim(Pmakearray(Pgenarray, _), _, _) ->
+     (* Pgenarray is excluded from recursive bindings by the
+        check in Translcore.check_recursive_lambda *)
+     RHS_nonrec
   | Uprim (Pduprecord ((Record_regular | Record_inlined _), sz), _, _) ->
       RHS_block sz
   | Uprim (Pduprecord (Record_unboxed _, _), _, _) ->
@@ -910,12 +955,12 @@ let split_int64_for_32bit_target arg dbg =
 
 let rec unbox_int bi arg dbg =
   match arg with
-    Cop(Calloc, [_hdr; _ops; Cop(Clsl, [contents; Cconst_int 32], dbg')], dbg)
+    Cop(Calloc, [_hdr; _ops; Cop(Clsl, [contents; Cconst_int 32], dbg')], _dbg)
     when bi = Pint32 && size_int = 8 && big_endian ->
       (* Force sign-extension of low 32 bits *)
       Cop(Casr, [Cop(Clsl, [contents; Cconst_int 32], dbg'); Cconst_int 32],
         dbg)
-  | Cop(Calloc, [_hdr; _ops; contents], dbg)
+  | Cop(Calloc, [_hdr; _ops; contents], _dbg)
     when bi = Pint32 && size_int = 8 && not big_endian ->
       (* Force sign-extension of low 32 bits *)
       Cop(Casr, [Cop(Clsl, [contents; Cconst_int 32], dbg); Cconst_int 32], dbg)
@@ -925,8 +970,8 @@ let rec unbox_int bi arg dbg =
   | Cifthenelse(cond, e1, e2) ->
       Cifthenelse(cond, unbox_int bi e1 dbg, unbox_int bi e2 dbg)
   | Csequence(e1, e2) -> Csequence(e1, unbox_int bi e2 dbg)
-  | Cswitch(e, tbl, el, dbg) ->
-      Cswitch(e, tbl, Array.map (fun e -> unbox_int bi e dbg) el, dbg)
+  | Cswitch(e, tbl, el, dbg') ->
+      Cswitch(e, tbl, Array.map (fun e -> unbox_int bi e dbg) el, dbg')
   | Ccatch(rec_flag, handlers, body) ->
       map_ccatch (fun e -> unbox_int bi e dbg) rec_flag handlers body
   | Ctrywith(e1, id, e2) ->
@@ -1404,8 +1449,8 @@ struct
   let make_isout h arg = Cop (Ccmpa Clt, [h ; arg], Debuginfo.none)
   let make_isin h arg = Cop (Ccmpa Cge, [h ; arg], Debuginfo.none)
   let make_if cond ifso ifnot = Cifthenelse (cond, ifso, ifnot)
-  let make_switch arg cases actions =
-    make_switch arg cases actions Debuginfo.none
+  let make_switch loc arg cases actions =
+    make_switch arg cases actions (Debuginfo.from_location loc)
   let bind arg body = bind "switcher" arg body
 
   let make_catch handler = match handler with
@@ -1438,6 +1483,7 @@ module StoreExp =
       let make_key = function
         | Cexit (i,[]) -> Some i
         | _ -> None
+      let compare_key = Pervasives.compare
     end)
 
 module SwitcherBlocks = Switch.Make(SArgBlocks)
@@ -1445,7 +1491,7 @@ module SwitcherBlocks = Switch.Make(SArgBlocks)
 (* Int switcher, arg in [low..high],
    cases is list of individual cases, and is sorted by first component *)
 
-let transl_int_switch arg low high cases default = match cases with
+let transl_int_switch loc arg low high cases default = match cases with
 | [] -> assert false
 | _::_ ->
     let store = StoreExp.mk_store () in
@@ -1485,6 +1531,7 @@ let transl_int_switch arg low high cases default = match cases with
     bind "switcher" arg
       (fun a ->
         SwitcherBlocks.zyva
+          loc
           (low,high)
           a
           (Array.of_list inters) store)
@@ -1586,7 +1633,7 @@ let rec is_unboxed_number ~strict env e =
       end
   | Ulet (_, _, _, _, e) | Uletrec (_, e) | Usequence (_, e) ->
       is_unboxed_number ~strict env e
-  | Uswitch (_, switch) ->
+  | Uswitch (_, switch, _dbg) ->
       let k = Array.fold_left join No_result switch.us_actions_consts in
       Array.fold_left join k switch.us_actions_blocks
   | Ustringswitch (_, actions, default_opt) ->
@@ -1641,29 +1688,31 @@ let rec transl env e =
       List.iter (fun f -> Queue.add f functions) fundecls;
       Cconst_symbol lbl
   | Uclosure(fundecls, clos_vars) ->
-      let block_size =
-        fundecls_size fundecls + List.length clos_vars in
       let rec transl_fundecls pos = function
           [] ->
             List.map (transl env) clos_vars
         | f :: rem ->
             Queue.add f functions;
-            let header =
-              if pos = 0
-              then alloc_closure_header block_size f.dbg
-              else alloc_infix_header pos f.dbg in
-            if f.arity = 1 || f.arity = 0 then
-              header ::
-              Cconst_symbol f.label ::
-              int_const f.arity ::
-              transl_fundecls (pos + 3) rem
-            else
-              header ::
-              Cconst_symbol(curry_function f.arity) ::
-              int_const f.arity ::
-              Cconst_symbol f.label ::
-              transl_fundecls (pos + 4) rem in
-      Cop(Calloc, transl_fundecls 0 fundecls, Debuginfo.none)
+            let without_header =
+              if f.arity = 1 || f.arity = 0 then
+                Cconst_symbol f.label ::
+                int_const f.arity ::
+                transl_fundecls (pos + 3) rem
+              else
+                Cconst_symbol(curry_function f.arity) ::
+                int_const f.arity ::
+                Cconst_symbol f.label ::
+                transl_fundecls (pos + 4) rem
+            in
+            if pos = 0 then without_header
+            else (alloc_infix_header pos f.dbg) :: without_header
+      in
+      let dbg =
+        match fundecls with
+        | [] -> Debuginfo.none
+        | fundecl::_ -> fundecl.dbg
+      in
+      make_alloc dbg Obj.closure_tag (transl_fundecls 0 fundecls)
   | Uoffset(arg, offset) ->
       (* produces a valid Caml value, pointing just after an infix header *)
       let ptr = transl env arg in
@@ -1784,8 +1833,8 @@ let rec transl env e =
       end
 
   (* Control structures *)
-  | Uswitch(arg, s) ->
-      let dbg = Debuginfo.none in
+  | Uswitch(arg, s, dbg) ->
+      let loc = Debuginfo.to_location dbg in
       (* As in the bytecode interpreter, only matching against constants
          can be checked *)
       if Array.length s.us_index_blocks = 0 then
@@ -1795,15 +1844,15 @@ let rec transl env e =
           (Array.map (transl env) s.us_actions_consts)
           dbg
       else if Array.length s.us_index_consts = 0 then
-        transl_switch dbg env (get_tag (transl env arg) dbg)
+        transl_switch loc env (get_tag (transl env arg) dbg)
           s.us_index_blocks s.us_actions_blocks
       else
         bind "switch" (transl env arg) (fun arg ->
           Cifthenelse(
           Cop(Cand, [arg; Cconst_int 1], dbg),
-          transl_switch dbg env
+          transl_switch loc env
             (untag_int arg dbg) s.us_index_consts s.us_actions_consts,
-          transl_switch dbg env
+          transl_switch loc env
             (get_tag arg dbg) s.us_index_blocks s.us_actions_blocks))
   | Ustringswitch(arg,sw,d) ->
       let dbg = Debuginfo.none in
@@ -1819,43 +1868,10 @@ let rec transl env e =
       ccatch(nfail, ids, transl env body, transl env handler)
   | Utrywith(body, exn, handler) ->
       Ctrywith(transl env body, exn, transl env handler)
-  | Uifthenelse(Uprim(Pnot, [arg], _), ifso, ifnot) ->
-      transl env (Uifthenelse(arg, ifnot, ifso))
-  | Uifthenelse(cond, ifso, Ustaticfail (nfail, [])) ->
-      let dbg = Debuginfo.none in
-      exit_if_false dbg env cond (transl env ifso) nfail
-  | Uifthenelse(cond, Ustaticfail (nfail, []), ifnot) ->
-      let dbg = Debuginfo.none in
-      exit_if_true dbg env cond nfail (transl env ifnot)
-  | Uifthenelse(Uprim(Psequand, _, dbg) as cond, ifso, ifnot) ->
-      let raise_num = next_raise_count () in
-      make_catch
-        raise_num
-        (exit_if_false dbg env cond (transl env ifso) raise_num)
-        (transl env ifnot)
-  | Uifthenelse(Uprim(Psequor, _, dbg) as cond, ifso, ifnot) ->
-      let raise_num = next_raise_count () in
-      make_catch
-        raise_num
-        (exit_if_true dbg env cond raise_num (transl env ifnot))
-        (transl env ifso)
-  | Uifthenelse (Uifthenelse (cond, condso, condnot), ifso, ifnot) ->
-      let dbg = Debuginfo.none in
-      let num_true = next_raise_count () in
-      make_catch
-        num_true
-        (make_catch2
-           (fun shared_false ->
-             if_then_else
-               (test_bool dbg (transl env cond),
-                exit_if_true dbg env condso num_true shared_false,
-                exit_if_true dbg env condnot num_true shared_false))
-           (transl env ifnot))
-        (transl env ifso)
   | Uifthenelse(cond, ifso, ifnot) ->
       let dbg = Debuginfo.none in
-      if_then_else(test_bool dbg (transl env cond), transl env ifso,
-        transl env ifnot)
+      transl_if env cond dbg Unknown
+        (transl env ifso) (transl env ifnot)
   | Usequence(exp1, exp2) ->
       Csequence(remove_unit(transl env exp1), transl env exp2)
   | Uwhile(cond, body) ->
@@ -1864,8 +1880,9 @@ let rec transl env e =
       return_unit
         (ccatch
            (raise_num, [],
-            Cloop(exit_if_false dbg env cond
-                    (remove_unit(transl env body)) raise_num),
+            Cloop(transl_if env cond dbg Unknown
+                    (remove_unit(transl env body))
+                    (Cexit (raise_num,[]))),
             Ctuple []))
   | Ufor(id, low, high, dir, body) ->
       let dbg = Debuginfo.none in
@@ -1984,19 +2001,17 @@ and transl_prim_1 env p arg dbg =
   | Pnegint ->
       Cop(Csubi, [Cconst_int 2; transl env arg], dbg)
   | Pctconst c ->
-      let const_of_bool b = tag_int (Cconst_int (if b then 1 else 0)) dbg in
+      let const_of_bool b = int_const (if b then 1 else 0) in
       begin
         match c with
         | Big_endian -> const_of_bool Arch.big_endian
-        | Word_size -> tag_int (Cconst_int (8*Arch.size_int)) dbg
-        | Int_size -> tag_int (Cconst_int ((8*Arch.size_int) - 1)) dbg
-        | Max_wosize ->
-            tag_int (Cconst_int ((1 lsl ((8*Arch.size_int) - 10)) - 1 )) dbg
+        | Word_size -> int_const (8*Arch.size_int)
+        | Int_size -> int_const (8*Arch.size_int - 1)
+        | Max_wosize -> int_const ((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")
-        | Backend_type ->
-            tag_int (Cconst_int 0) dbg (* tag 0 is the same as Native here *)
+        | Backend_type -> int_const 0 (* tag 0 is the same as Native here *)
       end
   | Poffsetint n ->
       if no_overflow_lsl n 1 then
@@ -2045,7 +2060,8 @@ and transl_prim_1 env p arg dbg =
       end
   (* Boolean operations *)
   | Pnot ->
-      Cop(Csubi, [Cconst_int 4; transl env arg], dbg) (* 1 -> 3, 3 -> 1 *)
+      transl_if env arg dbg Then_false_else_true
+        (Cconst_pointer 1) (Cconst_pointer 3)
   (* Test integer/block *)
   | Pisint ->
       tag_int(Cop(Cand, [transl env arg; Cconst_int 1], dbg)) dbg
@@ -2106,15 +2122,16 @@ and transl_prim_2 env p arg1 arg2 dbg =
 
   (* Boolean operations *)
   | Psequand ->
-      if_then_else(test_bool dbg (transl env arg1),
-        transl env arg2, Cconst_int 1)
+      let dbg' = Debuginfo.none in
+      transl_sequand env arg1 dbg arg2 dbg' Then_true_else_false
+        (Cconst_pointer 3) (Cconst_pointer 1)
       (* let id = Ident.create "res1" in
       Clet(id, transl env arg1,
            Cifthenelse(test_bool dbg (Cvar id), transl env arg2, Cvar id)) *)
   | Psequor ->
-      if_then_else(test_bool dbg (transl env arg1),
-        Cconst_int 3, transl env arg2)
-
+      let dbg' = Debuginfo.none in
+      transl_sequor env arg1 dbg arg2 dbg' Then_true_else_false
+        (Cconst_pointer 3) (Cconst_pointer 1)
   (* Integer operations *)
   | Paddint ->
       decr_int(add_int (transl env arg1) (transl env arg2) dbg) dbg
@@ -2624,85 +2641,81 @@ and make_catch ncatch body handler = match body with
 | Cexit (nexit,[]) when nexit=ncatch -> handler
 | _ ->  ccatch (ncatch, [], body, handler)
 
-and make_catch2 mk_body handler = match handler with
-| Cexit (_,[])|Ctuple []|Cconst_int _|Cconst_pointer _ ->
-    mk_body handler
-| _ ->
+and is_shareable_cont exp =
+  match exp with
+  | Cexit (_,[]) -> true
+  | _ -> false
+
+and make_shareable_cont mk exp =
+  if is_shareable_cont exp then mk exp
+  else begin
     let nfail = next_raise_count () in
     make_catch
       nfail
-      (mk_body (Cexit (nfail,[])))
-      handler
-
-and exit_if_true dbg env cond nfail otherwise =
-  match cond with
-  | Uconst (Uconst_ptr 0) -> otherwise
-  | Uconst (Uconst_ptr 1) -> Cexit (nfail,[])
-  | Uifthenelse (arg1, Uconst (Uconst_ptr 1), arg2)
-  | Uprim(Psequor, [arg1; arg2], _) ->
-      exit_if_true dbg env arg1 nfail
-        (exit_if_true dbg env arg2 nfail otherwise)
-  | Uifthenelse (_, _, Uconst (Uconst_ptr 0))
-  | Uprim(Psequand, _, _) ->
-      begin match otherwise with
-      | Cexit (raise_num,[]) ->
-          exit_if_false dbg env cond (Cexit (nfail,[])) raise_num
-      | _ ->
-          let raise_num = next_raise_count () in
-          make_catch
-            raise_num
-            (exit_if_false dbg env cond (Cexit (nfail,[])) raise_num)
-            otherwise
-      end
-  | Uprim(Pnot, [arg], _) ->
-      exit_if_false dbg env arg otherwise nfail
-  | Uifthenelse (cond, ifso, ifnot) ->
-      make_catch2
-        (fun shared ->
-          if_then_else
-            (test_bool dbg (transl env cond),
-             exit_if_true dbg env ifso nfail shared,
-             exit_if_true dbg env ifnot nfail shared))
-        otherwise
-  | _ ->
-      if_then_else(test_bool dbg (transl env cond),
-        Cexit (nfail, []), otherwise)
+      (mk (Cexit (nfail,[])))
+      exp
+  end
 
-and exit_if_false dbg env cond otherwise nfail =
+and transl_if env cond dbg approx then_ else_ =
   match cond with
-  | Uconst (Uconst_ptr 0) -> Cexit (nfail,[])
-  | Uconst (Uconst_ptr 1) -> otherwise
-  | Uifthenelse (arg1, arg2, Uconst (Uconst_ptr 0))
-  | Uprim(Psequand, [arg1; arg2], _) ->
-      exit_if_false dbg env arg1
-        (exit_if_false dbg env arg2 otherwise nfail) nfail
-  | Uifthenelse (_, Uconst (Uconst_ptr 1), _)
-  | Uprim(Psequor, _, _) ->
-      begin match otherwise with
-      | Cexit (raise_num,[]) ->
-          exit_if_true dbg env cond raise_num (Cexit (nfail,[]))
-      | _ ->
-          let raise_num = next_raise_count () in
-          make_catch
-            raise_num
-            (exit_if_true dbg env cond raise_num (Cexit (nfail,[])))
-            otherwise
-      end
+  | Uconst (Uconst_ptr 0) -> else_
+  | Uconst (Uconst_ptr 1) -> then_
+  | Uifthenelse (arg1, arg2, Uconst (Uconst_ptr 0)) ->
+      let dbg' = Debuginfo.none in
+      transl_sequand env arg1 dbg' arg2 dbg approx then_ else_
+  | Uprim(Psequand, [arg1; arg2], dbg') ->
+      transl_sequand env arg1 dbg' arg2 dbg approx then_ else_
+  | Uifthenelse (arg1, Uconst (Uconst_ptr 1), arg2) ->
+      let dbg' = Debuginfo.none in
+      transl_sequor env arg1 dbg' arg2 dbg approx then_ else_
+  | Uprim(Psequor, [arg1; arg2], dbg') ->
+      transl_sequor env arg1 dbg' arg2 dbg approx then_ else_
   | Uprim(Pnot, [arg], _) ->
-      exit_if_true dbg env arg nfail otherwise
+      transl_if env arg dbg (invert_then_else approx) else_ then_
+  | Uifthenelse (Uconst (Uconst_ptr 1), ifso, _) ->
+      transl_if env ifso dbg approx then_ else_
+  | Uifthenelse (Uconst (Uconst_ptr 0), _, ifnot) ->
+      transl_if env ifnot dbg approx then_ else_
   | Uifthenelse (cond, ifso, ifnot) ->
-      make_catch2
-        (fun shared ->
-          if_then_else
-            (test_bool dbg (transl env cond),
-             exit_if_false dbg env ifso shared nfail,
-             exit_if_false dbg env ifnot shared nfail))
-        otherwise
-  | _ ->
-      if_then_else (test_bool dbg (transl env cond), otherwise,
-        Cexit (nfail, []))
+      make_shareable_cont
+        (fun shareable_then ->
+           make_shareable_cont
+             (fun shareable_else ->
+                mk_if_then_else
+                  (test_bool dbg (transl env cond))
+                  (transl_if env ifso dbg approx
+                     shareable_then shareable_else)
+                  (transl_if env ifnot dbg approx
+                     shareable_then shareable_else))
+             else_)
+        then_
+  | _ -> begin
+      match approx with
+      | Then_true_else_false ->
+          transl env cond
+      | Then_false_else_true ->
+          mk_not dbg (transl env cond)
+      | Unknown ->
+          mk_if_then_else (test_bool dbg (transl env cond)) then_ else_
+    end
 
-and transl_switch _dbg env arg index cases = match Array.length cases with
+and transl_sequand env arg1 dbg1 arg2 dbg2 approx then_ else_ =
+  make_shareable_cont
+    (fun shareable_else ->
+       transl_if env arg1 dbg1 Unknown
+         (transl_if env arg2 dbg2 approx then_ shareable_else)
+         shareable_else)
+    else_
+
+and transl_sequor env arg1 dbg1 arg2 dbg2 approx then_ else_ =
+  make_shareable_cont
+    (fun shareable_then ->
+       transl_if env arg1 dbg1 Unknown
+         shareable_then
+         (transl_if env arg2 dbg2 approx shareable_then else_))
+    then_
+
+and transl_switch loc env arg index cases = match Array.length cases with
 | 0 -> fatal_error "Cmmgen.transl_switch"
 | 1 -> transl env cases.(0)
 | _ ->
@@ -2735,6 +2748,7 @@ and transl_switch _dbg env arg index cases = match Array.length cases with
         bind "switcher" arg
           (fun a ->
             SwitcherBlocks.zyva
+              loc
               (0,n_index-1)
               a
               (Array.of_list inters) store)

diff --git a/asmcomp/compilenv.ml b/asmcomp/compilenv.ml
index a50c57f45de1d02d7c7908ebfdaa6f1621eeeb46..a13320310059ed5a706ac2f0234414cb21c96e21 100644 (file)
--- a/asmcomp/compilenv.ml
+++ b/asmcomp/compilenv.ml
@@ -41,8 +41,6 @@ let imported_sets_of_closures_table =
   (Set_of_closures_id.Tbl.create 10
    : Flambda.function_declarations option Set_of_closures_id.Tbl.t)
 
-let sourcefile = ref None
-
 module CstMap =
   Map.Make(struct
     type t = Clambda.ustructured_constant
@@ -116,11 +114,10 @@ let make_symbol ?(unitname = current_unit.ui_symbol) idopt =
 let current_unit_linkage_name () =
   Linkage_name.create (make_symbol ~unitname:current_unit.ui_symbol None)
 
-let reset ?packname ~source_provenance:file name =
+let reset ?packname name =
   Hashtbl.clear global_infos_table;
   Set_of_closures_id.Tbl.clear imported_sets_of_closures_table;
   let symbol = symbolname_for_pack packname name in
-  sourcefile := Some file;
   current_unit.ui_name <- name;
   current_unit.ui_symbol <- symbol;
   current_unit.ui_defines <- [symbol];
@@ -148,11 +145,6 @@ let current_unit_infos () =
 let current_unit_name () =
   current_unit.ui_name
 
-let current_build () =
-  match !sourcefile with
-  | None -> assert false
-  | Some v -> v
-
 let make_symbol ?(unitname = current_unit.ui_symbol) idopt =
   let prefix = "caml" ^ unitname in
   match idopt with

diff --git a/asmcomp/compilenv.mli b/asmcomp/compilenv.mli
index fa3cfc34309e6ceeb9b9883e00c5c34e26e075a8..98d5f024e31ea720664114e7d8f71524a4421c25 100644 (file)
--- a/asmcomp/compilenv.mli
+++ b/asmcomp/compilenv.mli
@@ -29,8 +29,7 @@ val imported_sets_of_closures_table
   : Flambda.function_declarations option Set_of_closures_id.Tbl.t
         (* flambda-only *)
 
-val reset: ?packname:string -> source_provenance:Timings.source_provenance ->
-        string -> unit
+val reset: ?packname:string -> string -> unit
         (* Reset the environment and record the name of the unit being
            compiled (arg).  Optional argument is [-for-pack] prefix. *)
 
@@ -48,10 +47,6 @@ val current_unit_linkage_name: unit -> Linkage_name.t
         (* Return the linkage_name of the unit being compiled.
            flambda-only *)
 
-val current_build: unit -> Timings.source_provenance
-        (* Return the kind of build source being compiled. If it is a
-           file compilation it also provides the filename. *)
-
 val current_unit: unit -> Compilation_unit.t
         (* flambda-only *)
 
@@ -94,7 +89,7 @@ val set_export_info: Export_info.t -> unit
         (* Record the informations of the unit being compiled
            flambda-only *)
 val approx_env: unit -> Export_info.t
-        (* Returns all the information loaded from extenal compilation units
+        (* Returns all the information loaded from external compilation units
            flambda-only *)
 val approx_for_global: Compilation_unit.t -> Export_info.t
         (* Loads the exported information declaring the compilation_unit
@@ -117,7 +112,7 @@ val function_label : Closure_id.t -> string
 
 val new_structured_constant:
   Clambda.ustructured_constant ->
-  shared:bool -> (* can be shared with another structually equal constant *)
+  shared:bool -> (* can be shared with another structurally equal constant *)
   string
 val structured_constants:
   unit -> Clambda.preallocated_constant list

diff --git a/asmcomp/debug/available_regs.ml b/asmcomp/debug/available_regs.ml
new file mode 100644 (file)
index 0000000..b95c641
--- /dev/null
+++ b/asmcomp/debug/available_regs.ml
@@ -0,0 +1,365 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*            Mark Shinwell and Thomas Refis, Jane Street Europe          *)
+(*                                                                        *)
+(*   Copyright 2013--2017 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+[@@@ocaml.warning "+a-4-9-30-40-41-42"]
+
+module M = Mach
+module R = Reg
+module RAS = Reg_availability_set
+module RD = Reg_with_debug_info
+
+(* This pass treats [avail_at_exit] like a "result" structure whereas the
+   equivalent in [Liveness] is like an "environment".  (Which means we need
+   to be careful not to throw away information about further-out catch
+   handlers collected in [avail_at_exit].) *)
+let avail_at_exit = Hashtbl.create 42
+let avail_at_raise = ref RAS.Unreachable
+
+let augment_availability_at_raise avail =
+  avail_at_raise := RAS.inter avail !avail_at_raise
+
+let check_invariants (instr : M.instruction) ~(avail_before : RAS.t) =
+  match avail_before with
+  | Unreachable -> ()
+  | Ok avail_before ->
+    (* Every register that is live across an instruction should also be
+       available before the instruction. *)
+    if not (R.Set.subset instr.live (RD.Set.forget_debug_info avail_before))
+    then begin
+      Misc.fatal_errorf "Live registers not a subset of available registers: \
+          live={%a} avail_before=%a missing={%a} insn=%a"
+        Printmach.regset instr.live
+        (RAS.print ~print_reg:Printmach.reg)
+        (RAS.Ok avail_before)
+        Printmach.regset (R.Set.diff instr.live
+          (RD.Set.forget_debug_info avail_before))
+        Printmach.instr ({ instr with M. next = M.end_instr (); })
+    end;
+    (* Every register that is an input to an instruction should be
+       available. *)
+    let args = R.set_of_array instr.arg in
+    let avail_before_fdi = RD.Set.forget_debug_info avail_before in
+    if not (R.Set.subset args avail_before_fdi) then begin
+      Misc.fatal_errorf "Instruction has unavailable input register(s): \
+          avail_before=%a avail_before_fdi={%a} inputs={%a} insn=%a"
+        (RAS.print ~print_reg:Printmach.reg) (RAS.Ok avail_before)
+        Printmach.regset avail_before_fdi
+        Printmach.regset args
+        Printmach.instr ({ instr with M. next = M.end_instr (); })
+    end
+
+(* [available_regs ~instr ~avail_before] calculates, given the registers
+   "available before" an instruction [instr], the registers that are available
+   both "across" and immediately after [instr].  This is a forwards dataflow
+   analysis.
+
+   "available before" can be thought of, at the assembly level, as the set of
+   registers available when the program counter is equal to the address of the
+   particular instruction under consideration (that is to say, immediately
+   prior to the instruction being executed).  Inputs to that instruction are
+   available at this point even if the instruction will clobber them.  Results
+   from the previous instruction are also available at this point.
+
+   "available across" is the registers available during the execution of
+   some particular instruction.  These are the registers "available before"
+   minus registers that may be clobbered or otherwise invalidated by the
+   instruction.  (The notion of "available across" is only useful for [Iop]
+   instructions.  Recall that some of these may expand into multiple
+   machine instructions including clobbers, e.g. for [Ialloc].)
+
+   The [available_before] and [available_across] fields of each instruction
+   is updated by this function.
+*)
+let rec available_regs (instr : M.instruction)
+      ~(avail_before : RAS.t) : RAS.t =
+  check_invariants instr ~avail_before;
+  instr.available_before <- avail_before;
+  let avail_across, avail_after =
+    let ok set = RAS.Ok set in
+    let unreachable = RAS.Unreachable in
+    match avail_before with
+    | Unreachable -> None, unreachable
+    | Ok avail_before ->
+      match instr.desc with
+      | Iend -> None, ok avail_before
+      | Ireturn -> None, unreachable
+      | Iop (Itailcall_ind _) | Iop (Itailcall_imm _) ->
+        Some (ok Reg_with_debug_info.Set.empty), unreachable
+      | Iop (Iname_for_debugger { ident; which_parameter; provenance;
+          is_assignment; }) ->
+        (* First forget about any existing debug info to do with [ident]
+           if the naming corresponds to an assignment operation. *)
+        let forgetting_ident =
+          if not is_assignment then
+            avail_before
+          else
+            RD.Set.map (fun reg ->
+                match RD.debug_info reg with
+                | None -> reg
+                | Some debug_info ->
+                  if Ident.same (RD.Debug_info.holds_value_of debug_info) ident
+                  then RD.clear_debug_info reg
+                  else reg)
+              avail_before
+        in
+        let avail_after = ref forgetting_ident in
+        let num_parts_of_value = Array.length instr.arg in
+        (* Add debug info about [ident], but only for registers that are known
+           to be available. *)
+        for part_of_value = 0 to num_parts_of_value - 1 do
+          let reg = instr.arg.(part_of_value) in
+          if RD.Set.mem_reg forgetting_ident reg then begin
+            let regd =
+              RD.create ~reg
+                ~holds_value_of:ident
+                ~part_of_value
+                ~num_parts_of_value
+                ~which_parameter
+                ~provenance
+            in
+            avail_after := RD.Set.add regd (RD.Set.filter_reg !avail_after reg)
+          end
+        done;
+        Some (ok avail_before), ok !avail_after
+      | Iop (Imove | Ireload | Ispill) ->
+        (* Moves are special: they enable us to propagate names.
+           No-op moves need to be handled specially---in this case, we may
+           learn that a given hard register holds the value of multiple
+           pseudoregisters (all of which have the same value).  This makes us
+           match up properly with [Liveness]. *)
+        let move_to_same_location =
+          let move_to_same_location = ref true in
+          for i = 0 to Array.length instr.arg - 1 do
+            let arg = instr.arg.(i) in
+            let res = instr.res.(i) in
+            (* Note that the register classes must be the same, so we don't
+                need to check that. *)
+            if arg.loc <> res.loc then begin
+              move_to_same_location := false
+            end
+          done;
+          !move_to_same_location
+        in
+        let made_unavailable =
+          if move_to_same_location then
+            RD.Set.empty
+          else
+            RD.Set.made_unavailable_by_clobber avail_before
+              ~regs_clobbered:instr.res
+              ~register_class:Proc.register_class
+        in
+        let results =
+          Array.map2 (fun arg_reg result_reg ->
+              match RD.Set.find_reg_exn avail_before arg_reg with
+              | exception Not_found ->
+                assert false  (* see second invariant in [check_invariants] *)
+              | arg_reg ->
+                RD.create_copying_debug_info ~reg:result_reg
+                  ~debug_info_from:arg_reg)
+            instr.arg instr.res
+        in
+        let avail_across = RD.Set.diff avail_before made_unavailable in
+        let avail_after = RD.Set.union avail_across (RD.Set.of_array results) in
+        Some (ok avail_across), ok avail_after
+      | Iop op ->
+        (* We split the calculation of registers that become unavailable after
+           a call into two parts.  First: anything that the target marks as
+           destroyed by the operation, combined with any registers that will
+           be clobbered by the operation writing out its results. *)
+        let made_unavailable_1 =
+          let regs_clobbered =
+            Array.append (Proc.destroyed_at_oper instr.desc) instr.res
+          in
+          RD.Set.made_unavailable_by_clobber avail_before ~regs_clobbered
+            ~register_class:Proc.register_class
+        in
+        (* Second: the cases of (a) allocations and (b) OCaml to OCaml function
+           calls.  In these cases, since the GC may run, registers always
+           become unavailable unless:
+           (a) they are "live across" the instruction; and/or
+           (b) they hold immediates and are assigned to the stack.
+           For the moment we assume that [Ispecific] instructions do not
+           run the GC. *)
+        (* CR-someday mshinwell: Consider factoring this out from here and
+           [Available_ranges.Make_ranges.end_pos_offset]. *)
+        let made_unavailable_2 =
+          match op with
+          | Icall_ind _ | Icall_imm _ | Ialloc _ ->
+            RD.Set.filter (fun reg ->
+                let holds_immediate = RD.holds_non_pointer reg in
+                let on_stack = RD.assigned_to_stack reg in
+                let live_across = Reg.Set.mem (RD.reg reg) instr.live in
+                let remains_available =
+                  live_across
+                    || (holds_immediate && on_stack)
+                in
+                not remains_available)
+              avail_before
+          | _ -> RD.Set.empty
+        in
+        let made_unavailable =
+          RD.Set.union made_unavailable_1 made_unavailable_2
+        in
+        let avail_across = RD.Set.diff avail_before made_unavailable in
+        if M.operation_can_raise op then begin
+          augment_availability_at_raise (ok avail_across)
+        end;
+        let avail_after =
+          RD.Set.union
+            (RD.Set.without_debug_info (Reg.set_of_array instr.res))
+            avail_across
+        in
+        Some (ok avail_across), ok avail_after
+      | Iifthenelse (_, ifso, ifnot) -> join [ifso; ifnot] ~avail_before
+      | Iswitch (_, cases) -> join (Array.to_list cases) ~avail_before
+      | Iloop body ->
+        let avail_after = ref (ok avail_before) in
+        begin try
+          while true do
+            let avail_after' =
+              RAS.inter !avail_after
+                (available_regs body ~avail_before:!avail_after)
+            in
+            if RAS.equal !avail_after avail_after' then begin
+              raise Exit
+              end;
+            avail_after := avail_after'
+          done
+        with Exit -> ()
+        end;
+        None, unreachable
+      | Icatch (recursive, handlers, body) ->
+        List.iter (fun (nfail, _handler) ->
+            (* In case there are nested [Icatch] expressions with the same
+               handler numbers, we rely on the [Hashtbl] shadowing
+               semantics. *)
+            Hashtbl.add avail_at_exit nfail unreachable)
+          handlers;
+        let avail_after_body =
+          available_regs body ~avail_before:(ok avail_before)
+        in
+        (* CR-someday mshinwell: Consider potential efficiency speedups
+           (see suggestions from @chambart on GPR#856). *)
+        let aux (nfail, handler) (nfail', avail_at_top_of_handler) =
+          assert (nfail = nfail');
+          available_regs handler ~avail_before:avail_at_top_of_handler
+        in
+        let aux_equal (nfail, avail_before_handler)
+              (nfail', avail_before_handler') =
+          assert (nfail = nfail');
+          RAS.equal avail_before_handler avail_before_handler'
+        in
+        let rec fixpoint avail_at_top_of_handlers =
+          let avail_after_handlers =
+            List.map2 aux handlers avail_at_top_of_handlers
+          in
+          let avail_at_top_of_handlers' =
+            List.map (fun (nfail, _handler) ->
+                match Hashtbl.find avail_at_exit nfail with
+                | exception Not_found -> assert false  (* see above *)
+                | avail_at_top_of_handler -> nfail, avail_at_top_of_handler)
+              handlers
+          in
+          match recursive with
+          | Nonrecursive -> avail_after_handlers
+          | Recursive ->
+            if List.for_all2 aux_equal avail_at_top_of_handlers
+              avail_at_top_of_handlers'
+            then avail_after_handlers
+            else fixpoint avail_at_top_of_handlers'
+        in
+        let init_avail_at_top_of_handlers =
+          List.map (fun (nfail, _handler) ->
+              match Hashtbl.find avail_at_exit nfail with
+              | exception Not_found -> assert false  (* see above *)
+              | avail_at_top_of_handler -> nfail, avail_at_top_of_handler)
+            handlers
+        in
+        let avail_after_handlers = fixpoint init_avail_at_top_of_handlers in
+        List.iter (fun (nfail, _handler) ->
+            Hashtbl.remove avail_at_exit nfail)
+          handlers;
+        let avail_after =
+          List.fold_left (fun avail_at_join avail_after_handler ->
+              RAS.inter avail_at_join avail_after_handler)
+            avail_after_body
+            avail_after_handlers
+        in
+        None, avail_after
+      | Iexit nfail ->
+        let avail_before = ok avail_before in
+        let avail_at_top_of_handler =
+          match Hashtbl.find avail_at_exit nfail with
+          | exception Not_found ->  (* also see top of [Icatch] clause above *)
+            Misc.fatal_errorf "Iexit %d not in scope of Icatch" nfail
+          | avail_at_top_of_handler -> avail_at_top_of_handler
+        in
+        let avail_at_top_of_handler =
+          RAS.inter avail_at_top_of_handler avail_before
+        in
+        Hashtbl.replace avail_at_exit nfail avail_at_top_of_handler;
+        None, unreachable
+      | Itrywith (body, handler) ->
+        let saved_avail_at_raise = !avail_at_raise in
+        avail_at_raise := unreachable;
+        let avail_before = ok avail_before in
+        let after_body = available_regs body ~avail_before in
+        let avail_before_handler =
+          match !avail_at_raise with
+          | Unreachable -> unreachable
+          | Ok avail_at_raise ->
+            let without_exn_bucket =
+              RD.Set.filter_reg avail_at_raise Proc.loc_exn_bucket
+            in
+            let with_anonymous_exn_bucket =
+              RD.Set.add (RD.create_without_debug_info ~reg:Proc.loc_exn_bucket)
+                without_exn_bucket
+            in
+            ok with_anonymous_exn_bucket
+        in
+        avail_at_raise := saved_avail_at_raise;
+        let avail_after =
+          RAS.inter after_body
+            (available_regs handler ~avail_before:avail_before_handler)
+        in
+        None, avail_after
+      | Iraise _ ->
+        let avail_before = ok avail_before in
+        augment_availability_at_raise avail_before;
+        None, unreachable
+  in
+  instr.available_across <- avail_across;
+  match instr.desc with
+  | Iend -> avail_after
+  | _ -> available_regs instr.next ~avail_before:avail_after
+
+and join branches ~avail_before =
+  let avail_before = RAS.Ok avail_before in
+  let avails = List.map (available_regs ~avail_before) branches in
+  let avail_after =
+    match avails with
+    | [] -> avail_before
+    | avail::avails -> List.fold_left RAS.inter avail avails
+  in
+  None, avail_after
+
+let fundecl (f : M.fundecl) =
+  if !Clflags.debug && !Clflags.debug_runavail then begin
+    assert (Hashtbl.length avail_at_exit = 0);
+    avail_at_raise := RAS.Unreachable;
+    let fun_args = R.set_of_array f.fun_args in
+    let avail_before = RAS.Ok (RD.Set.without_debug_info fun_args) in
+    ignore ((available_regs f.fun_body ~avail_before) : RAS.t);
+  end;
+  f

diff --git a/asmcomp/debug/available_regs.mli b/asmcomp/debug/available_regs.mli
new file mode 100644 (file)
index 0000000..d065d38
--- /dev/null
+++ b/asmcomp/debug/available_regs.mli
@@ -0,0 +1,18 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*            Mark Shinwell and Thomas Refis, Jane Street Europe          *)
+(*                                                                        *)
+(*   Copyright 2013--2017 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Available registers analysis used to determine which variables may be
+    shown in the debugger. *)
+
+val fundecl : Mach.fundecl -> Mach.fundecl

diff --git a/asmcomp/debug/reg_availability_set.ml b/asmcomp/debug/reg_availability_set.ml
new file mode 100644 (file)
index 0000000..832ff14
--- /dev/null
+++ b/asmcomp/debug/reg_availability_set.ml
@@ -0,0 +1,110 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                  Mark Shinwell, Jane Street Europe                     *)
+(*                                                                        *)
+(*   Copyright 2016--2017 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+[@@@ocaml.warning "+a-4-9-30-40-41-42"]
+
+module RD = Reg_with_debug_info
+
+type t =
+  | Ok of RD.Set.t
+  | Unreachable
+
+let inter regs1 regs2 =
+  match regs1, regs2 with
+  | Unreachable, _ -> regs2
+  | _, Unreachable -> regs1
+  | Ok avail1, Ok avail2 ->
+    let result =
+      RD.Set.fold (fun reg1 result ->
+          match RD.Set.find_reg_exn avail2 (RD.reg reg1) with
+          | exception Not_found -> result
+          | reg2 ->
+            let debug_info1 = RD.debug_info reg1 in
+            let debug_info2 = RD.debug_info reg2 in
+            let debug_info =
+              match debug_info1, debug_info2 with
+              | None, None -> None
+              (* Example for this next case: the value of a mutable variable x
+                 is copied into another variable y; then there is a conditional
+                 where on one branch x is assigned and on the other branch it
+                 is not.  This means that on the former branch we have
+                 forgotten about y holding the value of x; but we have not on
+                 the latter.  At the join point we must have forgotten the
+                 information. *)
+              | None, Some _ | Some _, None -> None
+              | Some debug_info1, Some debug_info2 ->
+                if RD.Debug_info.compare debug_info1 debug_info2 = 0 then
+                  Some debug_info1
+                else
+                  None
+            in
+            let reg =
+              RD.create_with_debug_info ~reg:(RD.reg reg1)
+                ~debug_info
+            in
+            RD.Set.add reg result)
+        avail1
+        RD.Set.empty
+    in
+    Ok result
+
+let equal t1 t2 =
+  match t1, t2 with
+  | Unreachable, Unreachable -> true
+  | Unreachable, Ok _ | Ok _, Unreachable -> false
+  | Ok regs1, Ok regs2 -> RD.Set.equal regs1 regs2
+
+let canonicalise availability =
+  match availability with
+  | Unreachable -> Unreachable
+  | Ok availability ->
+    let regs_by_ident = Ident.Tbl.create 42 in
+    RD.Set.iter (fun reg ->
+        match RD.debug_info reg with
+        | None -> ()
+        | Some debug_info ->
+          let name = RD.Debug_info.holds_value_of debug_info in
+          if not (Ident.persistent name) then begin
+            match Ident.Tbl.find regs_by_ident name with
+            | exception Not_found -> Ident.Tbl.add regs_by_ident name reg
+            | (reg' : RD.t) ->
+              (* We prefer registers that are assigned to the stack since
+                 they probably give longer available ranges (less likely to
+                 be clobbered). *)
+              match RD.location reg, RD.location reg' with
+              | Reg _, Stack _
+              | Reg _, Reg _
+              | Stack _, Stack _
+              | _, Unknown
+              | Unknown, _ -> ()
+              | Stack _, Reg _ ->
+                Ident.Tbl.remove regs_by_ident name;
+                Ident.Tbl.add regs_by_ident name reg
+          end)
+      availability;
+    let result =
+      Ident.Tbl.fold (fun _ident reg availability ->
+          RD.Set.add reg availability)
+        regs_by_ident
+        RD.Set.empty
+    in
+    Ok result
+
+let print ~print_reg ppf = function
+  | Unreachable -> Format.fprintf ppf "<unreachable>"
+  | Ok availability ->
+    Format.fprintf ppf "{%a}"
+      (Format.pp_print_list ~pp_sep:(fun ppf () -> Format.fprintf ppf ",@ ")
+        (Reg_with_debug_info.print ~print_reg))
+      (RD.Set.elements availability)

diff --git a/asmcomp/debug/reg_availability_set.mli b/asmcomp/debug/reg_availability_set.mli
new file mode 100644 (file)
index 0000000..ba24a02
--- /dev/null
+++ b/asmcomp/debug/reg_availability_set.mli
@@ -0,0 +1,37 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                  Mark Shinwell, Jane Street Europe                     *)
+(*                                                                        *)
+(*   Copyright 2016--2017 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Register availability sets. *)
+
+type t =
+  | Ok of Reg_with_debug_info.Set.t
+  | Unreachable
+
+val inter : t -> t -> t
+(** Intersection of availabilities. *)
+
+val canonicalise : t -> t
+(** Return a subset of the given availability set which contains no registers
+    that are not associated with debug info (and holding values of
+    non-persistent identifiers); and where no two registers share the same
+    location. *)
+
+val equal : t -> t -> bool
+
+val print
+   : print_reg:(Format.formatter -> Reg.t -> unit)
+  -> Format.formatter
+  -> t
+  -> unit
+(** For debugging purposes only. *)

diff --git a/asmcomp/debug/reg_with_debug_info.ml b/asmcomp/debug/reg_with_debug_info.ml
new file mode 100644 (file)
index 0000000..e6ff836
--- /dev/null
+++ b/asmcomp/debug/reg_with_debug_info.ml
@@ -0,0 +1,198 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                  Mark Shinwell, Jane Street Europe                     *)
+(*                                                                        *)
+(*   Copyright 2016--2017 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+[@@@ocaml.warning "+a-4-9-30-40-41-42"]
+
+module Debug_info = struct
+  type t = {
+    holds_value_of : Ident.t;
+    part_of_value : int;
+    num_parts_of_value : int;
+    which_parameter : int option;
+    provenance : unit option;
+  }
+
+  let compare t1 t2 =
+    let c = Ident.compare t1.holds_value_of t2.holds_value_of in
+    if c <> 0 then c
+    else
+      Pervasives.compare
+        (t1.part_of_value, t1.num_parts_of_value, t1.which_parameter)
+        (t2.part_of_value, t2.num_parts_of_value, t2.which_parameter)
+
+  let holds_value_of t = t.holds_value_of
+  let part_of_value t = t.part_of_value
+  let num_parts_of_value t = t.num_parts_of_value
+  let which_parameter t = t.which_parameter
+  let provenance t = t.provenance
+
+  let print ppf t =
+    Format.fprintf ppf "%a" Ident.print t.holds_value_of;
+    if not (t.part_of_value = 0 && t.num_parts_of_value = 1) then begin
+      Format.fprintf ppf "(%d/%d)" t.part_of_value t.num_parts_of_value
+    end;
+    begin match t.which_parameter with
+    | None -> ()
+    | Some index -> Format.fprintf ppf "[P%d]" index
+    end
+end
+
+module T = struct
+  type t = {
+    reg : Reg.t;
+    debug_info : Debug_info.t option;
+  }
+
+  module Order = struct
+    type t = Reg.t
+    let compare (t1 : t) (t2 : t) = t1.stamp - t2.stamp
+  end
+
+  let compare t1 t2 =
+    Order.compare t1.reg t2.reg
+end
+
+include T
+
+type reg_with_debug_info = t
+
+let create ~reg ~holds_value_of ~part_of_value ~num_parts_of_value
+      ~which_parameter ~provenance =
+  assert (num_parts_of_value >= 1);
+  assert (part_of_value >= 0 && part_of_value < num_parts_of_value);
+  assert (match which_parameter with None -> true | Some index -> index >= 0);
+  let debug_info : Debug_info.t =
+    { holds_value_of;
+      part_of_value;
+      num_parts_of_value;
+      which_parameter;
+      provenance;
+    }
+  in
+  { reg;
+    debug_info = Some debug_info;
+  }
+
+let create_with_debug_info ~reg ~debug_info =
+  { reg;
+    debug_info;
+  }
+
+let create_without_debug_info ~reg =
+  { reg;
+    debug_info = None;
+  }
+
+let create_copying_debug_info ~reg ~debug_info_from =
+  { reg;
+    debug_info = debug_info_from.debug_info;
+  }
+
+let reg t = t.reg
+let location t = t.reg.loc
+
+let holds_pointer t =
+  match t.reg.typ with
+  | Addr | Val -> true
+  | Int | Float -> false
+
+let holds_non_pointer t = not (holds_pointer t)
+
+let assigned_to_stack t =
+  match t.reg.loc with
+  | Stack _ -> true
+  | Reg _ | Unknown -> false
+
+let regs_at_same_location (reg1 : Reg.t) (reg2 : Reg.t) ~register_class =
+  (* We need to check the register classes too: two locations both saying
+     "stack offset N" might actually be different physical locations, for
+     example if one is of class "Int" and another "Float" on amd64.
+     [register_class] will be [Proc.register_class], but cannot be here,
+     due to a circular dependency. *)
+  reg1.loc = reg2.loc
+    && register_class reg1 = register_class reg2
+
+let at_same_location t (reg : Reg.t) ~register_class =
+  regs_at_same_location t.reg reg ~register_class
+
+let debug_info t = t.debug_info
+
+let clear_debug_info t =
+  { t with debug_info = None; }
+
+module Order_distinguishing_names_and_locations = struct
+  type nonrec t = t
+
+  let compare t1 t2 =
+    match t1.debug_info, t2.debug_info with
+    | None, None -> 0
+    | None, Some _ -> -1
+    | Some _, None -> 1
+    | Some di1, Some di2 ->
+      let c = Ident.compare di1.holds_value_of di2.holds_value_of in
+      if c <> 0 then c
+      else Pervasives.compare t1.reg.loc t2.reg.loc
+end
+
+module Set_distinguishing_names_and_locations =
+  Set.Make (Order_distinguishing_names_and_locations)
+
+module Map_distinguishing_names_and_locations =
+  Map.Make (Order_distinguishing_names_and_locations)
+
+module Set = struct
+  include Set.Make (T)
+
+  let of_array elts =
+    of_list (Array.to_list elts)
+
+  let forget_debug_info t =
+    fold (fun t acc -> Reg.Set.add (reg t) acc) t Reg.Set.empty
+
+  let without_debug_info regs =
+    Reg.Set.fold (fun reg acc -> add (create_without_debug_info ~reg) acc)
+      regs
+      empty
+
+  let made_unavailable_by_clobber t ~regs_clobbered ~register_class =
+    Reg.Set.fold (fun reg acc ->
+        let made_unavailable =
+          filter (fun reg' ->
+              regs_at_same_location reg'.reg reg ~register_class)
+            t
+        in
+        union made_unavailable acc)
+      (Reg.set_of_array regs_clobbered)
+      (* ~init:*)empty
+
+  let mem_reg t (reg : Reg.t) =
+    exists (fun t -> t.reg.stamp = reg.stamp) t
+
+  let filter_reg t (reg : Reg.t) =
+    filter (fun t -> t.reg.stamp <> reg.stamp) t
+
+  (* CR-someday mshinwell: Well, it looks like we should have used a map.
+     mshinwell: Also see @chambart's suggestion on GPR#856. *)
+  let find_reg_exn t (reg : Reg.t) =
+    match elements (filter (fun t -> t.reg.stamp = reg.stamp) t) with
+    | [] -> raise Not_found
+    | [reg] -> reg
+    | _ -> assert false
+end
+
+let print ~print_reg ppf t =
+  match t.debug_info with
+  | None -> Format.fprintf ppf "%a" print_reg t.reg
+  | Some debug_info ->
+    Format.fprintf ppf "%a(%a)" print_reg t.reg Debug_info.print debug_info

diff --git a/asmcomp/debug/reg_with_debug_info.mli b/asmcomp/debug/reg_with_debug_info.mli
new file mode 100644 (file)
index 0000000..2f0599d
--- /dev/null
+++ b/asmcomp/debug/reg_with_debug_info.mli
@@ -0,0 +1,112 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                  Mark Shinwell, Jane Street Europe                     *)
+(*                                                                        *)
+(*   Copyright 2016--2017 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Registers equipped with information used for generating debugging
+    information. *)
+
+module Debug_info : sig
+  type t
+
+  val compare : t -> t -> int
+
+  val holds_value_of : t -> Ident.t
+  (** The identifier that the register holds (part of) the value of. *)
+
+  val part_of_value : t -> int
+  val num_parts_of_value : t -> int
+
+  val which_parameter : t -> int option
+  (** If the register corresponds to a function parameter, the value returned
+      is the zero-based index of said parameter; otherwise it is [None]. *)
+
+  val provenance : t -> unit option
+end
+
+type t
+
+type reg_with_debug_info = t
+
+val create
+   : reg:Reg.t
+  -> holds_value_of:Ident.t
+  -> part_of_value:int
+  -> num_parts_of_value:int
+  -> which_parameter:int option
+  -> provenance:unit option
+  -> t
+
+val create_with_debug_info : reg:Reg.t -> debug_info:Debug_info.t option -> t
+
+val create_without_debug_info : reg:Reg.t -> t
+
+val create_copying_debug_info : reg:Reg.t -> debug_info_from:t -> t
+
+val reg : t -> Reg.t
+val location : t -> Reg.location
+val debug_info : t -> Debug_info.t option
+
+val at_same_location : t -> Reg.t -> register_class:(Reg.t -> int) -> bool
+(** [at_same_location t reg] holds iff the register [t] corresponds to
+    the same (physical or pseudoregister) location as the register [reg],
+    which is not equipped with debugging information.
+    [register_class] should be [Proc.register_class].
+*)
+
+val holds_pointer : t -> bool
+val holds_non_pointer : t -> bool
+
+val assigned_to_stack : t -> bool
+(** [assigned_to_stack t] holds iff the location of [t] is a hard stack
+    slot. *)
+
+val clear_debug_info : t -> t
+
+module Set_distinguishing_names_and_locations
+  : Set.S with type elt = t
+
+module Map_distinguishing_names_and_locations
+  : Map.S with type key = t
+
+module Set : sig
+  include Set.S with type elt = t
+
+  val of_array : reg_with_debug_info array -> t
+
+  val mem_reg : t -> Reg.t -> bool
+
+  val find_reg_exn : t -> Reg.t -> reg_with_debug_info
+
+  val filter_reg : t -> Reg.t -> t
+
+  val forget_debug_info : t -> Reg.Set.t
+
+  val without_debug_info : Reg.Set.t -> t
+
+  val made_unavailable_by_clobber
+     : t
+    -> regs_clobbered:Reg.t array
+    -> register_class:(Reg.t -> int)
+    -> t
+  (** [made_unavailable_by_clobber t ~regs_clobbered ~register_class] returns
+      the largest subset of [t] whose locations do not overlap with any
+      registers in [regs_clobbered].  (Think of [t] as a set of available
+      registers.)
+      [register_class] should always be [Proc.register_class]. *)
+end
+
+val print
+   : print_reg:(Format.formatter -> Reg.t -> unit)
+  -> Format.formatter
+  -> t
+  -> unit

diff --git a/asmcomp/emitaux.ml b/asmcomp/emitaux.ml
index 22173f4d096fc302d82a422ff13d73ecd9de5c5d..9fd925d35c108c7e338c90e58985b09524abc3b3 100644 (file)
--- a/asmcomp/emitaux.ml
+++ b/asmcomp/emitaux.ml
@@ -273,7 +273,7 @@ let reset_debug_info () =
   file_pos_nums := [];
   file_pos_num_cnt := 1
 
-(* We only diplay .file if the file has not been seen before. We
+(* We only display .file if the file has not been seen before. We
    display .loc for every instruction. *)
 let emit_debug_info_gen dbg file_emitter loc_emitter =
   if is_cfi_enabled () &&

diff --git a/asmcomp/flambda_to_clambda.ml b/asmcomp/flambda_to_clambda.ml
index 01a6be7d047b7ee715287a54d713d1a4b55d99a5..b9d2beb9b70f6e04e96dcccd89a6650d4f3336d5 100644 (file)
--- a/asmcomp/flambda_to_clambda.ml
+++ b/asmcomp/flambda_to_clambda.ml
@@ -279,7 +279,8 @@ let rec to_clambda t env (flam : Flambda.t) : Clambda.ulambda =
           us_actions_consts = const_actions;
           us_index_blocks = block_index;
           us_actions_blocks = block_actions;
-        })
+        },
+        Debuginfo.none)  (* debug info will be added by GPR#855 *)
     in
     (* Check that the [failaction] may be duplicated.  If this is not the
        case, share it through a static raise / static catch. *)
@@ -510,7 +511,7 @@ and to_clambda_set_of_closures t env
     in
     let env_body, params =
       List.fold_right (fun var (env, params) ->
-          let id, env = Env.add_fresh_ident env var in
+          let id, env = Env.add_fresh_ident env (Parameter.var var) in
           env, id :: params)
         function_decl.params (env, [])
     in
@@ -550,7 +551,7 @@ and to_clambda_closed_set_of_closures t env symbol
     in
     let env_body, params =
       List.fold_right (fun var (env, params) ->
-          let id, env = Env.add_fresh_ident env var in
+          let id, env = Env.add_fresh_ident env (Parameter.var var) in
           env, id :: params)
         function_decl.params (env, [])
     in

diff --git a/asmcomp/i386/emit.mlp b/asmcomp/i386/emit.mlp
index 94c3d03553990a536293ea21fa8b4275d6e95418..0d984d5dd4186f72e0a79ffb1347c7c91b217372 100644 (file)
--- a/asmcomp/i386/emit.mlp
+++ b/asmcomp/i386/emit.mlp
@@ -795,6 +795,7 @@ let emit_instr fallthrough i =
       if Array.length i.arg = 2 && is_tos i.arg.(1) then
         I.fxch st1;
       emit_floatspecial s
+  | Lop (Iname_for_debugger _) -> ()
   | Lreloadretaddr ->
       ()
   | Lreturn ->
@@ -1046,6 +1047,7 @@ let end_assembly() =
   emit_global_label "code_end";
 
   D.data ();
+  D.long (const 0);  (* PR#6329 *)
   emit_global_label "data_end";
   D.long (const 0);
 

diff --git a/asmcomp/interval.ml b/asmcomp/interval.ml
new file mode 100644 (file)
index 0000000..01f49a3
--- /dev/null
+++ b/asmcomp/interval.ml
@@ -0,0 +1,189 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                    Marcell Fischbach, University of Siegen             *)
+(*                     Benedikt Meurer, University of Siegen              *)
+(*                                                                        *)
+(*   Copyright 2011 Lehrstuhl für Compilerbau und Softwareanalyse,        *)
+(*     Universität Siegen.                                                *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Live intervals for the linear scan register allocator. *)
+
+open Mach
+open Reg
+
+type range =
+  {
+    mutable rbegin: int;
+    mutable rend: int;
+  }
+
+type t =
+  {
+    mutable reg: Reg.t;
+    mutable ibegin: int;
+    mutable iend: int;
+    mutable ranges: range list;
+  }
+
+type kind =
+    Result
+  | Argument
+  | Live
+
+let interval_list = ref ([] : t list)
+let fixed_interval_list = ref ([] : t list)
+let all_intervals() = !interval_list
+let all_fixed_intervals() = !fixed_interval_list
+
+(* Check if two intervals overlap *)
+
+let overlap i0 i1 =
+  let rec overlap_ranges rl0 rl1 =
+    match rl0, rl1 with
+      r0 :: rl0', r1 :: rl1' ->
+        if r0.rend >= r1.rbegin && r1.rend >= r0.rbegin then true
+        else if r0.rend < r1.rend then overlap_ranges rl0' rl1
+        else if r0.rend > r1.rend then overlap_ranges rl0 rl1'
+        else overlap_ranges rl0' rl1'
+    | _ -> false in
+  overlap_ranges i0.ranges i1.ranges
+
+let is_live i pos =
+  let rec is_live_in_ranges = function
+    [] -> false
+  | r :: rl -> if pos < r.rbegin then false
+               else if pos <= r.rend then true
+               else is_live_in_ranges rl in
+  is_live_in_ranges i.ranges
+
+let remove_expired_ranges i pos =
+  let rec filter = function
+    [] -> []
+  | r :: rl' as rl -> if pos < r.rend then rl
+               else filter rl' in
+  i.ranges <- filter i.ranges
+
+let update_interval_position intervals pos kind reg =
+  let i = intervals.(reg.stamp) in
+  let on = pos lsl 1 in
+  let off = on + 1 in
+  let rbegin = (match kind with Result -> off | _ -> on) in
+  let rend = (match kind with Argument -> on | _ -> off) in
+  if i.iend = 0 then begin
+    i.ibegin <- rbegin;
+    i.reg <- reg;
+    i.ranges <- [{rbegin = rbegin; rend = rend}]
+  end else begin
+    let r = List.hd i.ranges in
+    let ridx = r.rend asr 1 in
+    if pos - ridx <= 1 then
+      r.rend <- rend
+    else
+      i.ranges <- {rbegin = rbegin; rend = rend} :: i.ranges
+  end;
+  i.iend <- rend
+
+let update_interval_position_by_array intervals regs pos kind =
+  Array.iter (update_interval_position intervals pos kind) regs
+
+let update_interval_position_by_set intervals regs pos kind =
+  Set.iter (update_interval_position intervals pos kind) regs
+
+let update_interval_position_by_instr intervals instr pos =
+  update_interval_position_by_array intervals instr.arg pos Argument;
+  update_interval_position_by_array intervals instr.res pos Result;
+  update_interval_position_by_set intervals instr.live pos Live
+
+let insert_destroyed_at_oper intervals instr pos =
+  let destroyed = Proc.destroyed_at_oper instr.desc in
+  if Array.length destroyed > 0 then
+    update_interval_position_by_array intervals destroyed pos Result
+
+let insert_destroyed_at_raise intervals pos =
+  let destroyed = Proc.destroyed_at_raise in
+  if Array.length destroyed > 0 then
+    update_interval_position_by_array intervals destroyed pos Result
+
+(* Build all intervals.
+   The intervals will be expanded by one step at the start and end
+   of a basic block. *)
+
+let build_intervals fd =
+  let intervals = Array.init
+                    (Reg.num_registers())
+                    (fun _ -> {
+                      reg = Reg.dummy;
+                      ibegin = 0;
+                      iend = 0;
+                      ranges = []; }) in
+  let pos = ref 0 in
+  let rec walk_instruction i =
+    incr pos;
+    update_interval_position_by_instr intervals i !pos;
+    begin match i.desc with
+      Iend -> ()
+    | Iop(Icall_ind _ | Icall_imm _ | Iextcall{alloc = true; _}
+          | Itailcall_ind _ | Itailcall_imm _) ->
+        walk_instruction i.next
+    | Iop _ ->
+        insert_destroyed_at_oper intervals i !pos;
+        walk_instruction i.next
+    | Ireturn ->
+        insert_destroyed_at_oper intervals i !pos;
+        walk_instruction i.next
+    | Iifthenelse(_, ifso, ifnot) ->
+        insert_destroyed_at_oper intervals i !pos;
+        walk_instruction ifso;
+        walk_instruction ifnot;
+        walk_instruction i.next
+    | Iswitch(_, cases) ->
+        insert_destroyed_at_oper intervals i !pos;
+        Array.iter walk_instruction cases;
+        walk_instruction i.next
+    | Iloop body ->
+        insert_destroyed_at_oper intervals i !pos;
+        walk_instruction body;
+        walk_instruction i.next
+    | Icatch(_, handlers, body) ->
+        insert_destroyed_at_oper intervals i !pos;
+        List.iter (fun (_, i) -> walk_instruction i) handlers;
+        walk_instruction body;
+        walk_instruction i.next
+    | Iexit _ ->
+        insert_destroyed_at_oper intervals i !pos;
+        walk_instruction i.next
+    | Itrywith(body, handler) ->
+        insert_destroyed_at_oper intervals i !pos;
+        walk_instruction body;
+        insert_destroyed_at_raise intervals !pos;
+        walk_instruction handler;
+        walk_instruction i.next
+    | Iraise _ ->
+        walk_instruction i.next
+    end in
+  walk_instruction fd.fun_body;
+  (* Generate the interval and fixed interval lists *)
+  interval_list := [];
+  fixed_interval_list := [];
+  Array.iter
+    (fun i ->
+      if i.iend != 0 then begin
+        i.ranges <- List.rev i.ranges;
+        begin match i.reg.loc with
+          Reg _ ->
+            fixed_interval_list := i :: !fixed_interval_list
+        | _ ->
+            interval_list := i :: !interval_list
+        end
+      end)
+    intervals;
+  (* Sort the intervals according to their start position *)
+  interval_list := List.sort (fun i0 i1 -> i0.ibegin - i1.ibegin) !interval_list

diff --git a/asmcomp/interval.mli b/asmcomp/interval.mli
new file mode 100644 (file)
index 0000000..2b42bf3
--- /dev/null
+++ b/asmcomp/interval.mli
@@ -0,0 +1,38 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                    Marcell Fischbach, University of Siegen             *)
+(*                     Benedikt Meurer, University of Siegen              *)
+(*                                                                        *)
+(*   Copyright 2011 Lehrstuhl für Compilerbau und Softwareanalyse,        *)
+(*     Universität Siegen.                                                *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Live intervals for the linear scan register allocator. *)
+
+type range =
+  {
+    mutable rbegin: int;
+    mutable rend: int;
+  }
+
+type t =
+  {
+    mutable reg: Reg.t;
+    mutable ibegin: int;
+    mutable iend: int;
+    mutable ranges: range list;
+  }
+
+val all_intervals: unit -> t list
+val all_fixed_intervals: unit -> t list
+val overlap: t -> t -> bool
+val is_live: t -> int -> bool
+val remove_expired_ranges: t -> int -> unit
+val build_intervals: Mach.fundecl -> unit

diff --git a/asmcomp/linscan.ml b/asmcomp/linscan.ml
new file mode 100644 (file)
index 0000000..26b8b72
--- /dev/null
+++ b/asmcomp/linscan.ml
@@ -0,0 +1,198 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                    Marcell Fischbach, University of Siegen             *)
+(*                     Benedikt Meurer, University of Siegen              *)
+(*                                                                        *)
+(*   Copyright 2011 Lehrstuhl für Compilerbau und Softwareanalyse,        *)
+(*     Universität Siegen.                                                *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Linear scan register allocation. *)
+
+open Interval
+open Reg
+
+(* Live intervals per register class *)
+
+type class_intervals =
+  {
+    mutable ci_fixed: Interval.t list;
+    mutable ci_active: Interval.t list;
+    mutable ci_inactive: Interval.t list;
+  }
+
+let active = Array.init Proc.num_register_classes (fun _ -> {
+  ci_fixed = [];
+  ci_active = [];
+  ci_inactive = []
+})
+
+(* Insert interval into list sorted by end position *)
+
+let rec insert_interval_sorted i = function
+    [] -> [i]
+  | j :: _ as il when j.iend <= i.iend -> i :: il
+  | j :: il -> j :: insert_interval_sorted i il
+
+let rec release_expired_fixed pos = function
+    i :: il when i.iend >= pos ->
+      Interval.remove_expired_ranges i pos;
+      i :: release_expired_fixed pos il
+  | _ -> []
+
+let rec release_expired_active ci pos = function
+    i :: il when i.iend >= pos ->
+      Interval.remove_expired_ranges i pos;
+      if Interval.is_live i pos then
+        i :: release_expired_active ci pos il
+      else begin
+        ci.ci_inactive <- insert_interval_sorted i ci.ci_inactive;
+        release_expired_active ci pos il
+      end
+  | _ -> []
+
+let rec release_expired_inactive ci pos = function
+    i :: il when i.iend >= pos ->
+      Interval.remove_expired_ranges i pos;
+      if not (Interval.is_live i pos) then
+        i :: release_expired_inactive ci pos il
+      else begin
+        ci.ci_active <- insert_interval_sorted i ci.ci_active;
+        release_expired_inactive ci pos il
+      end
+  | _ -> []
+
+(* Allocate a new stack slot to the interval. *)
+
+let allocate_stack_slot i =
+  let cl = Proc.register_class i.reg in
+  let ss = Proc.num_stack_slots.(cl) in
+  Proc.num_stack_slots.(cl) <- succ ss;
+  i.reg.loc <- Stack(Local ss);
+  i.reg.spill <- true
+
+(* Find a register for the given interval and assigns this register.
+   The interval is added to active. Raises Not_found if no free registers
+   left. *)
+
+let allocate_free_register i =
+  begin match i.reg.loc, i.reg.spill with
+    Unknown, true ->
+      (* Allocate a stack slot for the already spilled interval *)
+      allocate_stack_slot i
+  | Unknown, _ ->
+      (* We need to allocate a register to this interval somehow *)
+      let cl = Proc.register_class i.reg in
+      begin match Proc.num_available_registers.(cl) with
+        0 ->
+          (* There are no registers available for this class *)
+          raise Not_found
+      | rn ->
+          let ci = active.(cl) in
+          let r0 = Proc.first_available_register.(cl) in
+          (* Create register mask for this class
+             note: if frame pointers are enabled then some registers may have
+                   indexes that are off-bounds; we hence protect write accesses
+                   below (given that the assign function will not consider such
+                   registers) *)
+          let regmask = Array.make rn true in
+          (* Remove all assigned registers from the register mask *)
+          List.iter
+            (function
+              {reg = {loc = Reg r}} ->
+                if r - r0 < rn then regmask.(r - r0) <- false
+            | _ -> ())
+            ci.ci_active;
+          (* Remove all overlapping registers from the register mask *)
+          let remove_bound_overlapping = function
+              {reg = {loc = Reg r}} as j ->
+                if (r - r0 < rn) && regmask.(r - r0) && Interval.overlap j i then
+                regmask.(r - r0) <- false
+            | _ -> () in
+          List.iter remove_bound_overlapping ci.ci_inactive;
+          List.iter remove_bound_overlapping ci.ci_fixed;
+          (* Assign the first free register (if any) *)
+          let rec assign r =
+            if r = rn then
+              raise Not_found
+            else if regmask.(r) then begin
+              (* Assign the free register and insert the
+                 current interval into the active list *)
+              i.reg.loc <- Reg (r0 + r);
+              i.reg.spill <- false;
+              ci.ci_active <- insert_interval_sorted i ci.ci_active
+            end else
+              assign (succ r) in
+          assign 0
+      end
+  | _ -> ()
+  end
+
+let allocate_blocked_register i =
+  let cl = Proc.register_class i.reg in
+  let ci = active.(cl) in
+  match ci.ci_active with
+  | ilast :: il when
+      ilast.iend > i.iend &&
+      (* Last interval in active is the last interval, so spill it. *)
+      let chk r = r.reg.loc = ilast.reg.loc && Interval.overlap r i in
+      (* But only if its physical register is admissible for the current
+         interval. *)
+      not (List.exists chk ci.ci_fixed || List.exists chk ci.ci_inactive)
+    ->
+      begin match ilast.reg.loc with Reg _ -> () | _ -> assert false end;
+      (* Use register from last interval for current interval *)
+      i.reg.loc <- ilast.reg.loc;
+      (* Remove the last interval from active and insert the current *)
+      ci.ci_active <- insert_interval_sorted i il;
+      (* Now get a new stack slot for the spilled register *)
+      allocate_stack_slot ilast
+  | _ ->
+      (* Either the current interval is last and we have to spill it,
+         or there are no registers at all in the register class (i.e.
+         floating point class on i386). *)
+      allocate_stack_slot i
+
+let walk_interval i =
+  let pos = i.ibegin land (lnot 0x01) in
+  (* Release all intervals that have been expired at the current position *)
+  Array.iter
+    (fun ci ->
+      ci.ci_fixed <- release_expired_fixed pos ci.ci_fixed;
+      ci.ci_active <- release_expired_active ci pos ci.ci_active;
+      ci.ci_inactive <- release_expired_inactive ci pos ci.ci_inactive)
+    active;
+  try
+    (* Allocate free register (if any) *)
+    allocate_free_register i
+  with
+    Not_found ->
+      (* No free register, need to decide which interval to spill *)
+      allocate_blocked_register i
+
+let allocate_registers() =
+  (* Initialize the stack slots and interval lists *)
+  for cl = 0 to Proc.num_register_classes - 1 do
+    (* Start with empty interval lists *)
+    active.(cl) <- {
+      ci_fixed = [];
+      ci_active = [];
+      ci_inactive = []
+    };
+    Proc.num_stack_slots.(cl) <- 0
+  done;
+  (* Add all fixed intervals (sorted by end position) *)
+  List.iter
+    (fun i ->
+      let ci = active.(Proc.register_class i.reg) in
+      ci.ci_fixed <- insert_interval_sorted i ci.ci_fixed)
+    (Interval.all_fixed_intervals());
+  (* Walk all the intervals within the list *)
+  List.iter walk_interval (Interval.all_intervals())

diff --git a/asmcomp/linscan.mli b/asmcomp/linscan.mli
new file mode 100644 (file)
index 0000000..b978eeb
--- /dev/null
+++ b/asmcomp/linscan.mli
@@ -0,0 +1,19 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                    Marcell Fischbach, University of Siegen             *)
+(*                     Benedikt Meurer, University of Siegen              *)
+(*                                                                        *)
+(*   Copyright 2011 Lehrstuhl für Compilerbau und Softwareanalyse,        *)
+(*     Universität Siegen.                                                *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Linear scan register allocation. *)
+
+val allocate_registers: unit -> unit

diff --git a/asmcomp/liveness.ml b/asmcomp/liveness.ml
index e289b4648f023cc87d9c14f5d89dba90e316577d..9791e8c5ce59206da9269ca7159be4b752b88d4c 100644 (file)
--- a/asmcomp/liveness.ml
+++ b/asmcomp/liveness.ml
@@ -62,10 +62,12 @@ let rec live i finally =
         let across_after = Reg.diff_set_array after i.res in
         let across =
           match op with
-          | Icall_ind _ | Icall_imm _ | Iextcall _
+          | Icall_ind _ | Icall_imm _ | Iextcall _ | Ialloc _
           | Iintop (Icheckbound _) | Iintop_imm(Icheckbound _, _) ->
               (* The function call may raise an exception, branching to the
-                 nearest enclosing try ... with. Similarly for bounds checks.
+                 nearest enclosing try ... with. Similarly for bounds checks
+                 and allocation (for the latter: finalizers may throw
+                 exceptions, as may signal handlers).
                  Hence, everything that must be live at the beginning of
                  the exception handler must also be live across this instr. *)
                Reg.Set.union across_after !live_at_raise
@@ -113,14 +115,8 @@ let rec live i finally =
         Reg.Set.equal before_handler before_handler'
       in
       let live_at_exit_before = !live_at_exit in
-      let live_at_exit_add before_handlers =
-        List.map (fun (nfail, before_handler) ->
-            (nfail, before_handler))
-          before_handlers
-      in
       let rec fixpoint before_handlers =
-        let live_at_exit_add = live_at_exit_add before_handlers in
-        live_at_exit := live_at_exit_add @ !live_at_exit;
+        live_at_exit := before_handlers @ !live_at_exit;
         let before_handlers' = List.map2 aux handlers before_handlers in
         live_at_exit := live_at_exit_before;
         match rec_flag with
@@ -138,7 +134,7 @@ let rec live i finally =
       (* We could use handler.live instead of Reg.Set.empty as the initial
          value but we would need to clean the live field before doing the
          analysis (to remove remnants of previous passes). *)
-      live_at_exit := (live_at_exit_add before_handler) @ !live_at_exit;
+      live_at_exit := before_handler @ !live_at_exit;
       let before_body = live body at_join in
       live_at_exit := live_at_exit_before;
       i.live <- before_body;

diff --git a/asmcomp/mach.ml b/asmcomp/mach.ml
index 2808448bd79ffb974a4242af2386728cf7bdc312..cfed637300dc1a7566d9ac2685d3da1222fc9dc0 100644 (file)
--- a/asmcomp/mach.ml
+++ b/asmcomp/mach.ml
@@ -59,6 +59,8 @@ type operation =
   | Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf
   | Ifloatofint | Iintoffloat
   | Ispecific of Arch.specific_operation
+  | Iname_for_debugger of { ident : Ident.t; which_parameter : int option;
+      provenance : unit option; is_assignment : bool; }
 
 type instruction =
   { desc: instruction_desc;
@@ -66,7 +68,10 @@ type instruction =
     arg: Reg.t array;
     res: Reg.t array;
     dbg: Debuginfo.t;
-    mutable live: Reg.Set.t }
+    mutable live: Reg.Set.t;
+    mutable available_before: Reg_availability_set.t;
+    mutable available_across: Reg_availability_set.t option;
+  }
 
 and instruction_desc =
     Iend
@@ -102,7 +107,10 @@ let rec dummy_instr =
     arg = [||];
     res = [||];
     dbg = Debuginfo.none;
-    live = Reg.Set.empty }
+    live = Reg.Set.empty;
+    available_before = Reg_availability_set.Ok Reg_with_debug_info.Set.empty;
+    available_across = None;
+  }
 
 let end_instr () =
   { desc = Iend;
@@ -110,14 +118,23 @@ let end_instr () =
     arg = [||];
     res = [||];
     dbg = Debuginfo.none;
-    live = Reg.Set.empty }
+    live = Reg.Set.empty;
+    available_before = Reg_availability_set.Ok Reg_with_debug_info.Set.empty;
+    available_across = None;
+  }
 
 let instr_cons d a r n =
   { desc = d; next = n; arg = a; res = r;
-    dbg = Debuginfo.none; live = Reg.Set.empty }
+    dbg = Debuginfo.none; live = Reg.Set.empty;
+    available_before = Reg_availability_set.Ok Reg_with_debug_info.Set.empty;
+    available_across = None;
+  }
 
 let instr_cons_debug d a r dbg n =
-  { desc = d; next = n; arg = a; res = r; dbg = dbg; live = Reg.Set.empty }
+  { desc = d; next = n; arg = a; res = r; dbg = dbg; live = Reg.Set.empty;
+    available_before = Reg_availability_set.Ok Reg_with_debug_info.Set.empty;
+    available_across = None;
+  }
 
 let rec instr_iter f i =
   match i.desc with
@@ -175,7 +192,15 @@ let spacetime_node_hole_pointer_is_live_before insn =
     | Imove | Ispill | Ireload | Iconst_int _ | Iconst_float _
     | Iconst_symbol _ | Istackoffset _ | Iload _ | Istore _
     | Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf
-    | Ifloatofint | Iintoffloat -> false
+    | Ifloatofint | Iintoffloat
+    | Iname_for_debugger _ -> false
     end
   | Iend | Ireturn | Iifthenelse _ | Iswitch _ | Iloop _ | Icatch _
   | Iexit _ | Itrywith _ | Iraise _ -> false
+
+let operation_can_raise op =
+  match op with
+  | Icall_ind _ | Icall_imm _ | Iextcall _
+  | Iintop (Icheckbound _) | Iintop_imm (Icheckbound _, _)
+  | Ialloc _ -> true
+  | _ -> false

diff --git a/asmcomp/mach.mli b/asmcomp/mach.mli
index f97834d7909d9350063e0ef5a258e08e986860dc..784bba625a9edb36d00a41ebf45b8e6b7eb25bbd 100644 (file)
--- a/asmcomp/mach.mli
+++ b/asmcomp/mach.mli
@@ -69,6 +69,14 @@ type operation =
   | Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf
   | Ifloatofint | Iintoffloat
   | Ispecific of Arch.specific_operation
+  | Iname_for_debugger of { ident : Ident.t; which_parameter : int option;
+      provenance : unit option; is_assignment : bool; }
+    (** [Iname_for_debugger] has the following semantics:
+        (a) The argument register(s) is/are deemed to contain the value of the
+            given identifier.
+        (b) If [is_assignment] is [true], any information about other [Reg.t]s
+            that have been previously deemed to hold the value of that
+            identifier is forgotten. *)
 
 type instruction =
   { desc: instruction_desc;
@@ -76,7 +84,10 @@ type instruction =
     arg: Reg.t array;
     res: Reg.t array;
     dbg: Debuginfo.t;
-    mutable live: Reg.Set.t }
+    mutable live: Reg.Set.t;
+    mutable available_before: Reg_availability_set.t;
+    mutable available_across: Reg_availability_set.t option;
+  }
 
 and instruction_desc =
     Iend
@@ -123,3 +134,5 @@ val instr_cons_debug:
 val instr_iter: (instruction -> unit) -> instruction -> unit
 
 val spacetime_node_hole_pointer_is_live_before : instruction -> bool
+
+val operation_can_raise : operation -> bool

diff --git a/asmcomp/power/emit.mlp b/asmcomp/power/emit.mlp
index 5abc5f851fb34329974b546133afcbb59aad6ed2..0ab36376c148be104f74816a686664ed513e920f 100644 (file)
--- a/asmcomp/power/emit.mlp
+++ b/asmcomp/power/emit.mlp
@@ -475,6 +475,7 @@ module BR = Branch_relaxation.Make (struct
     | Lop(Ifloatofint) -> 9
     | Lop(Iintoffloat) -> 4
     | Lop(Ispecific _) -> 1
+    | Lop (Iname_for_debugger _) -> 0
     | Lreloadretaddr -> 2
     | Lreturn -> 2
     | Llabel _ -> 0
@@ -819,6 +820,7 @@ let emit_instr i =
     | Lop(Ispecific sop) ->
         let instr = name_for_specific sop in
         `      {emit_string instr}     {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(2)}\n`
+    | Lop (Iname_for_debugger _) -> ()
     | Lreloadretaddr ->
         `      {emit_string lg}        11, {emit_int(retaddr_offset())}(1)\n`;
         `      mtlr    11\n`
@@ -1193,10 +1195,11 @@ let end_assembly() =
   emit_string data_space;
   let lbl_end = Compilenv.make_symbol (Some "data_end") in
   declare_global_data lbl_end;
+  `    {emit_string datag}     0\n`;  (* PR#6329 *)
   `{emit_symbol lbl_end}:\n`;
   `    {emit_string datag}     0\n`;
   (* Emit the frame descriptors *)
-  emit_string rodata_space;
+  emit_string data_space;  (* not rodata_space because it contains relocations *)
   let lbl = Compilenv.make_symbol (Some "frametable") in
   declare_global_data lbl;
   `{emit_symbol lbl}:\n`;

diff --git a/asmcomp/printclambda.ml b/asmcomp/printclambda.ml
index c4a790a2aab5f550bbe8e280732cb9e2db0a8b4a..c353b3df80964960a697c886406739e9b3120a21 100644 (file)
--- a/asmcomp/printclambda.ml
+++ b/asmcomp/printclambda.ml
@@ -117,7 +117,7 @@ and lam ppf = function
       let lams ppf largs =
         List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
       fprintf ppf "@[<2>(%a%a)@]" Printlambda.primitive prim lams largs
-  | Uswitch(larg, sw) ->
+  | Uswitch(larg, sw, _dbg) ->
       let print_case tag index i ppf =
         for j = 0 to Array.length index - 1 do
           if index.(j) = i then fprintf ppf "case %s %i:" tag j

diff --git a/asmcomp/printmach.ml b/asmcomp/printmach.ml
index f45dbb8fcfc83f4ced1bcb8dc5f8e6b30a9434a8..cd7e8a77a2f50732dae6713da22eff49d579d35e 100644 (file)
--- a/asmcomp/printmach.ml
+++ b/asmcomp/printmach.ml
@@ -19,6 +19,7 @@ open Format
 open Cmm
 open Reg
 open Mach
+open Interval
 
 let reg ppf r =
   if not (Reg.anonymous r) then
@@ -156,6 +157,13 @@ let operation op arg ppf res =
   | Idivf -> fprintf ppf "%a /f %a" reg arg.(0) reg arg.(1)
   | Ifloatofint -> fprintf ppf "floatofint %a" reg arg.(0)
   | Iintoffloat -> fprintf ppf "intoffloat %a" reg arg.(0)
+  | Iname_for_debugger { ident; which_parameter; } ->
+    fprintf ppf "name_for_debugger %a%s=%a"
+      Ident.print ident
+      (match which_parameter with
+        | None -> ""
+        | Some index -> sprintf "[P%d]" index)
+      reg arg.(0)
   | Ispecific op ->
       Arch.print_specific_operation reg op ppf arg
 
@@ -164,6 +172,16 @@ let rec instr ppf i =
     fprintf ppf "@[<1>{%a" regsetaddr i.live;
     if Array.length i.arg > 0 then fprintf ppf "@ +@ %a" regs i.arg;
     fprintf ppf "}@]@,";
+    if !Clflags.dump_avail then begin
+      let module RAS = Reg_availability_set in
+      fprintf ppf "@[<1>AB={%a}" (RAS.print ~print_reg:reg) i.available_before;
+      begin match i.available_across with
+      | None -> ()
+      | Some available_across ->
+        fprintf ppf ",AA={%a}" (RAS.print ~print_reg:reg) available_across
+      end;
+      fprintf ppf "@]@,"
+    end
   end;
   begin match i.desc with
   | Iend -> ()
@@ -242,6 +260,18 @@ let interferences ppf () =
   fprintf ppf "*** Interferences@.";
   List.iter (interference ppf) (Reg.all_registers())
 
+let interval ppf i =
+  let interv ppf =
+    List.iter
+      (fun r -> fprintf ppf "@ [%d;%d]" r.rbegin r.rend)
+      i.ranges in
+  fprintf ppf "@[<2>%a:%t@]@." reg i.reg interv
+
+let intervals ppf () =
+  fprintf ppf "*** Intervals@.";
+  List.iter (interval ppf) (Interval.all_fixed_intervals());
+  List.iter (interval ppf) (Interval.all_intervals())
+
 let preference ppf r =
   let prefs ppf =
     List.iter

diff --git a/asmcomp/printmach.mli b/asmcomp/printmach.mli
index fb7411a6a267522f92eab601873ed21857d24354..13a794647c0aec09894d2a62a6f1023e37311232 100644 (file)
--- a/asmcomp/printmach.mli
+++ b/asmcomp/printmach.mli
@@ -27,6 +27,7 @@ val instr: formatter -> Mach.instruction -> unit
 val fundecl: formatter -> Mach.fundecl -> unit
 val phase: string -> formatter -> Mach.fundecl -> unit
 val interferences: formatter -> unit -> unit
+val intervals: formatter -> unit -> unit
 val preferences: formatter -> unit -> unit
 
 val print_live: bool ref

diff --git a/asmcomp/s390x/emit.mlp b/asmcomp/s390x/emit.mlp
index 0579bfd47c51d274eb34ffe566304dbcb3d086f8..3487005ec62b34d57c0fc776110d9bf58314e3c9 100644 (file)
--- a/asmcomp/s390x/emit.mlp
+++ b/asmcomp/s390x/emit.mlp
@@ -526,6 +526,7 @@ let emit_instr i =
         assert (i.arg.(2).loc = i.res.(0).loc);
         let instr = name_for_specific sop in
         `      {emit_string instr}     {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`
+    | Lop (Iname_for_debugger _) -> ()
     | Lreloadretaddr ->
         let n = frame_size() in
         `      lg      %r14, {emit_int(n - size_addr)}(%r15)\n`
@@ -735,10 +736,11 @@ let end_assembly() =
   `    .align  8\n`;
   let lbl_end = Compilenv.make_symbol (Some "data_end") in
   declare_global_data lbl_end;
+  `    .quad   0\n`;  (* PR#6329 *)
   `{emit_symbol lbl_end}:\n`;
   `    .quad   0\n`;
   (* Emit the frame descriptors *)
-  emit_string rodata_space;
+  emit_string data_space;  (* not rodata because relocations inside *)
   `    .align  8\n`;
   let lbl = Compilenv.make_symbol (Some "frametable") in
   declare_global_data lbl;

diff --git a/asmcomp/s390x/proc.ml b/asmcomp/s390x/proc.ml
index a8bd2cbf74d533523b5dbf8a709bcc431cce4a3b..78f13bffb4e0934cea5a298d8be596d969f10033 100644 (file)
--- a/asmcomp/s390x/proc.ml
+++ b/asmcomp/s390x/proc.ml
@@ -33,7 +33,7 @@ let word_addressed = false
     0                   temporary, null register for some operations (volatile)
     1                   temporary (volatile)
     2 - 5               function arguments and results (volatile)
-    6                   function arguments and results (persevered by C)
+    6                   function arguments and results (preserved by C)
     7 - 9               general purpose, preserved by C
     10                  allocation limit (preserved by C)
     11                  allocation pointer (preserved by C)

diff --git a/asmcomp/schedgen.ml b/asmcomp/schedgen.ml
index 440fe2f0f80cf1f546d9dec8e935b02e5bdb960f..c640f7f7c8e8915e4b1894f1fa201d931aa3b844 100644 (file)
--- a/asmcomp/schedgen.ml
+++ b/asmcomp/schedgen.ml
@@ -114,7 +114,7 @@ let rec longest_path critical_outputs node =
       [] ->
         node.length <-
           if is_critical critical_outputs node.instr.res
-          || node.instr.desc = Lreloadretaddr (* alway critical *)
+          || node.instr.desc = Lreloadretaddr (* always critical *)
           then node.delay
           else 0
     | sons ->
@@ -337,7 +337,7 @@ method private reschedule ready_queue date cont =
         (* Remove node from queue *)
         let new_queue = ref (remove_instr node ready_queue) in
         (* Update the start date and number of ancestors emitted of
-           all descendents of this node. Enter those that become ready
+           all descendants of this node. Enter those that become ready
            in the queue. *)
         let issue_cycles = self#instr_issue_cycles node.instr in
         List.iter

diff --git a/asmcomp/selectgen.ml b/asmcomp/selectgen.ml
index 7cd8cd5c300647bdb7c789045555fd535e64a80c..1158fc0d063cb53cd859856e3df89edbe72073d2 100644 (file)
--- a/asmcomp/selectgen.ml
+++ b/asmcomp/selectgen.ml
@@ -738,7 +738,8 @@ method emit_expr (env:environment) exp =
                   loc_arg (Proc.loc_external_results rd) in
               self#insert_move_results loc_res rd stack_ofs;
               Some rd
-          | Ialloc { words = _; spacetime_index; label_after_call_gc; } ->
+          | Ialloc { words; spacetime_index; label_after_call_gc; } ->
+              assert (words <= Config.max_young_wosize);
               let rd = self#regs_for typ_val in
               let size = size_expr env (Ctuple new_args) in
               let op =

diff --git a/asmcomp/selectgen.mli b/asmcomp/selectgen.mli
index 6ab3c21586063535e9ac31de1188ba56123c7b68..3cd24787eeb3b07607f97b0413758c0851a81c52 100644 (file)
--- a/asmcomp/selectgen.mli
+++ b/asmcomp/selectgen.mli
@@ -112,7 +112,7 @@ class virtual selector_generic : object
   (* informs the code emitter that the current function may call
      a C function that never returns; by default, does nothing.
 
-     It is unecessary to save the stack pointer in this situation
+     It is unnecessary to save the stack pointer in this situation
      (which is the main purpose of tracking leaf functions) but some
      architectures still need to ensure that the stack is properly
      aligned when the C function is called. This is achieved by

diff --git a/asmcomp/spacetime_profiling.ml b/asmcomp/spacetime_profiling.ml
index b6786c1dc2989e8104a9a38023e993aade726408..b118e6a46de8776365a97961e9fdb28dc9128567 100644 (file)
--- a/asmcomp/spacetime_profiling.ml
+++ b/asmcomp/spacetime_profiling.ml
@@ -4,7 +4,7 @@
 (*                                                                        *)
 (*           Mark Shinwell and Leo White, Jane Street Europe              *)
 (*                                                                        *)
-(*   Copyright 2015--2016 Jane Street Group LLC                           *)
+(*   Copyright 2015--2017 Jane Street Group LLC                           *)
 (*                                                                        *)
 (*   All rights reserved.  This file is distributed under the terms of    *)
 (*   the GNU Lesser General Public License version 2.1, with the          *)
@@ -31,7 +31,12 @@ let something_was_instrumented () =
 let next_index_within_node ~part_of_shape ~label =
   let index = !index_within_node in
   begin match part_of_shape with
-  | Mach.Direct_call_point _ | Mach.Indirect_call_point ->
+  | Mach.Direct_call_point _ ->
+    incr index_within_node;
+    if Config.enable_call_counts then begin
+      incr index_within_node
+    end
+  | Mach.Indirect_call_point ->
     incr index_within_node
   | Mach.Allocation_point ->
     incr index_within_node;
@@ -220,7 +225,24 @@ let code_for_call ~node ~callee ~is_tail ~label =
        (hard) node hole pointer register immediately before the call.
        (That move is inserted in [Selectgen].) *)
     match callee with
-    | Direct _callee -> Cvar place_within_node
+    | Direct _callee ->
+      if Config.enable_call_counts then begin
+        let count_addr = Ident.create "call_count_addr" in
+        let count = Ident.create "call_count" in
+        Clet (count_addr,
+          Cop (Caddi, [Cvar place_within_node; Cconst_int Arch.size_addr], dbg),
+          Clet (count,
+            Cop (Cload (Word_int, Asttypes.Mutable), [Cvar count_addr], dbg),
+            Csequence (
+              Cop (Cstore (Word_int, Lambda.Assignment),
+                (* Adding 2 really means adding 1; the count is encoded
+                   as an OCaml integer. *)
+                [Cvar count_addr; Cop (Caddi, [Cvar count; Cconst_int 2], dbg)],
+                dbg),
+              Cvar place_within_node)))
+      end else begin
+        Cvar place_within_node
+      end
     | Indirect callee ->
       let caller_node =
         if is_tail then node

diff --git a/asmcomp/sparc/CSE.ml b/asmcomp/sparc/CSE.ml
deleted file mode 100644 (file)
index 7d246ba..0000000
--- a/asmcomp/sparc/CSE.ml
+++ /dev/null
@@ -1,33 +0,0 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                 OCaml                                  *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Gallium, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 2014 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
-(* CSE for Sparc *)
-
-open Mach
-open CSEgen
-
-class cse = object
-
-inherit cse_generic (* as super *)
-
-method! is_cheap_operation op =
-  match op with
-  | Iconst_int n -> n <= 4095n && n >= -4096n
-  | _ -> false
-
-end
-
-let fundecl f =
-  (new cse)#fundecl f

diff --git a/asmcomp/sparc/NOTES.md b/asmcomp/sparc/NOTES.md
deleted file mode 100644 (file)
index 18c3db4..0000000
--- a/asmcomp/sparc/NOTES.md
+++ /dev/null
@@ -1,17 +0,0 @@
-# Supported platforms
-
-SPARC v8 and up, in 32-bit mode.
-
-Operating systems: Solaris, Linux
-  (abandoned since major Linux distributions no longer support SPARC).
-
-Status of this port: nearly abandoned
-  (no hardware or virtual machine available for testing).
-
-# Reference documents
-
-* Instruction set architecture:
-  _The SPARC Architecture Manual_ version 8.
-* ELF application binary interface:
-  _System V Application Binary Interface,
-   SPARC Processor Supplement_

diff --git a/asmcomp/sparc/arch.ml b/asmcomp/sparc/arch.ml
deleted file mode 100644 (file)
index 1f7e2ab..0000000
--- a/asmcomp/sparc/arch.ml
+++ /dev/null
@@ -1,83 +0,0 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                 OCaml                                  *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
-(* Specific operations for the Sparc processor *)
-
-open Format
-
-(* SPARC V8 adds multiply and divide.
-   SPARC V9 adds double precision float operations, conditional
-   move, and more instructions that are only useful in 64 bit mode.
-   Sun calls 32 bit V9 "V8+". *)
-type arch_version = SPARC_V7 | SPARC_V8 | SPARC_V9
-
-let arch_version = ref SPARC_V7
-
-let command_line_options =
-  [ "-march=v8", Arg.Unit (fun () -> arch_version := SPARC_V8),
-        " Generate code for SPARC V8 processors";
-    "-march=v9", Arg.Unit (fun () -> arch_version := SPARC_V9),
-        " Generate code for SPARC V9 processors" ]
-
-type specific_operation = unit          (* None worth mentioning *)
-
-let spacetime_node_hole_pointer_is_live_before _specific_op = false
-
-(* Addressing modes *)
-
-type addressing_mode =
-    Ibased of string * int              (* symbol + displ *)
-  | Iindexed of int                     (* reg + displ *)
-
-(* Sizes, endianness *)
-
-let big_endian = true
-
-let size_addr = 4
-let size_int = 4
-let size_float = 8
-
-let allow_unaligned_access = false
-
-(* Behavior of division *)
-
-let division_crashes_on_overflow = false
-
-(* Operations on addressing modes *)
-
-let identity_addressing = Iindexed 0
-
-let offset_addressing addr delta =
-  match addr with
-    Ibased(s, n) -> Ibased(s, n + delta)
-  | Iindexed n -> Iindexed(n + delta)
-
-let num_args_addressing = function
-    Ibased _ -> 0
-  | Iindexed _ -> 1
-
-(* Printing operations and addressing modes *)
-
-let print_addressing printreg addr ppf arg =
-  match addr with
-  | Ibased(s, n) ->
-      let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in
-      fprintf ppf "\"%s\"%s" s idx
-  | Iindexed n ->
-      let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in
-      fprintf ppf "%a%s" printreg arg.(0) idx
-
-let print_specific_operation _printreg _op _ppf _arg =
-  Misc.fatal_error "Arch_sparc.print_specific_operation"

diff --git a/asmcomp/sparc/emit.mlp b/asmcomp/sparc/emit.mlp
deleted file mode 100644 (file)
index a4a50f9..0000000
--- a/asmcomp/sparc/emit.mlp
+++ /dev/null
@@ -1,771 +0,0 @@
-#2 "asmcomp/sparc/emit.mlp"
-(**************************************************************************)
-(*                                                                        *)
-(*                                 OCaml                                  *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
-(* Emission of Sparc assembly code *)
-
-open Misc
-open Cmm
-open Arch
-open Proc
-open Reg
-open Mach
-open Linearize
-open Emitaux
-
-(* Solaris vs. the other ports *)
-
-let solaris = Config.system = "solaris"
-
-(* Tradeoff between code size and code speed *)
-
-let fastcode_flag = ref true
-
-(* Layout of the stack *)
-(* Always keep the stack 8-aligned.
-   Always leave 96 bytes at the bottom of the stack *)
-
-let stack_offset = ref 0
-
-let frame_size () =
-  let size =
-    !stack_offset +
-    4 * num_stack_slots.(0) + 8 * num_stack_slots.(1) +
-    (if !contains_calls then 4 else 0) in
-  Misc.align size 8
-
-let slot_offset loc cl =
-  match loc with
-    Incoming n -> frame_size() + n + 96
-  | Local n ->
-      if cl = 0
-      then !stack_offset + num_stack_slots.(1) * 8 + n * 4 + 96
-      else !stack_offset + n * 8 + 96
-  | Outgoing n -> n + 96
-
-(* Return the other register in a register pair *)
-
-let next_in_pair = function
-    {loc = Reg r; typ = (Int | Addr | Val)} -> phys_reg (r + 1)
-  | {loc = Reg r; typ = Float} -> phys_reg (r + 16)
-  | _ -> fatal_error "Emit.next_in_pair"
-
-(* Symbols are prefixed with _ under SunOS *)
-
-let symbol_prefix =
-  if Config.system = "sunos" then "_" else ""
-
-let emit_symbol s =
-  if String.length s >= 1 && s.[0] = '.'
-  then emit_string s
-  else begin emit_string symbol_prefix; Emitaux.emit_symbol '$' s end
-
-let emit_size lbl =
-  if Config.system = "solaris" then
-    `  .size   {emit_symbol lbl},.-{emit_symbol lbl}\n`
-
-let rodata () =
-  if Config.system = "solaris" (* || Config.system = "linux" *)
-  (* || Config.system = "gnu" *) then
-    `  .section \".rodata\"\n`
-  else
-    `  .data\n`
-
-(* Check if an integer or native integer is an immediate operand *)
-
-let is_immediate n =
-  n <= 4095 && n >= -4096
-
-let is_native_immediate n =
-  n <= Nativeint.of_int 4095 && n >= Nativeint.of_int (-4096)
-
-(* Output a label *)
-
-let label_prefix =
-  if Config.system = "sunos" then "L" else ".L"
-
-let emit_label lbl =
-  emit_string label_prefix; emit_int lbl
-
-(* Output a pseudo-register *)
-
-let emit_reg r =
-  match r.loc with
-    Reg r -> emit_string (register_name r)
-  | _ -> fatal_error "Emit.emit_reg"
-
-(* Output a stack reference *)
-
-let emit_stack r =
-  match r.loc with
-    Stack s ->
-      let ofs = slot_offset s (register_class r) in `[%sp + {emit_int ofs}]`
-  | _ -> fatal_error "Emit.emit_stack"
-
-(* Output a load *)
-
-let emit_load instr addr arg dst =
-  match addr with
-    Ibased(s, 0) ->
-        `      sethi   %hi({emit_symbol s}), %g1\n`;
-        `      {emit_string instr}     [%g1 + %lo({emit_symbol s})], {emit_reg dst}\n`
-  | Ibased(s, ofs) ->
-        `      sethi   %hi({emit_symbol s} + {emit_int ofs}), %g1\n`;
-        `      {emit_string instr}     [%g1 + %lo({emit_symbol s} + {emit_int ofs})], {emit_reg dst}\n`
-  | Iindexed ofs ->
-      if is_immediate ofs then
-        `      {emit_string instr}     [{emit_reg arg.(0)} + {emit_int ofs}], {emit_reg dst}\n`
-      else begin
-        `      sethi   %hi({emit_int ofs}), %g1\n`;
-        `      or      %g1, %lo({emit_int ofs}), %g1\n`;
-        `      {emit_string instr}     [{emit_reg arg.(0)} + %g1], {emit_reg dst}\n`
-      end
-
-(* Output a store *)
-
-let emit_store instr addr arg src =
-  match addr with
-    Ibased(s, 0) ->
-        `      sethi   %hi({emit_symbol s}), %g1\n`;
-        `      {emit_string instr}     {emit_reg src}, [%g1 + %lo({emit_symbol s})]\n`
-  | Ibased(s, ofs) ->
-        `      sethi   %hi({emit_symbol s} + {emit_int ofs}), %g1\n`;
-        `      {emit_string instr}     {emit_reg src}, [%g1 + %lo({emit_symbol s} + {emit_int ofs})]\n`
-  | Iindexed ofs ->
-      if is_immediate ofs then
-        `      {emit_string instr}     {emit_reg src}, [{emit_reg arg.(1)} + {emit_int ofs}]\n`
-      else begin
-        `      sethi   %hi({emit_int ofs}), %g1\n`;
-        `      or      %g1, %lo({emit_int ofs}), %g1\n`;
-        `      {emit_string instr}     {emit_reg src}, [{emit_reg arg.(1)} + %g1]\n`
-      end
-
-(* Record live pointers at call points *)
-
-type frame_descr =
-  { fd_lbl: int;                        (* Return address *)
-    fd_frame_size: int;                 (* Size of stack frame *)
-    fd_live_offset: int list }          (* Offsets/regs of live addresses *)
-
-let frame_descriptors = ref([] : frame_descr list)
-
-let record_frame ?label live =
-  let lbl =
-    match label with
-    | None -> new_label()
-    | Some label -> label
-  in
-  let live_offset = ref [] in
-  Reg.Set.iter
-    (function
-      | {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
-      | {typ = Addr} as r ->
-          Misc.fatal_error ("bad GC root " ^ Reg.name r)
-      | _ -> ())
-    live;
-  live_offset := List.sort_uniq (-) !live_offset;
-  frame_descriptors :=
-    { fd_lbl = lbl;
-      fd_frame_size = frame_size();
-      fd_live_offset = !live_offset } :: !frame_descriptors;
-  `{emit_label lbl}:`
-
-let emit_frame fd =
-  `    .word   {emit_label fd.fd_lbl}\n`;
-  `    .half   {emit_int fd.fd_frame_size}\n`;
-  `    .half   {emit_int (List.length fd.fd_live_offset)}\n`;
-  List.iter
-    (fun n ->
-      `        .half   {emit_int n}\n`)
-    fd.fd_live_offset;
-  `    .align  4\n`
-
-(* Record floating-point constants *)
-
-let float_constants = ref ([] : (int * int64) list)
-
-let emit_float_constant (lbl, cst) =
-  rodata ();
-  `    .align  8\n`;
-  `{emit_label lbl}:`;
-  emit_float64_split_directive ".word" cst
-
-(* Emission of the profiling prelude *)
-let emit_profile () =
-  begin match Config.system with
-    "solaris" ->
-      let lbl = new_label() in
-      `        .section \".bss\"\n`;
-      `{emit_label lbl}:       .skip 4\n`;
-      `        .text\n`;
-      `        save    %sp,-96,%sp\n`;
-      `        sethi   %hi({emit_label lbl}),%o0\n`;
-      `        call    _mcount\n`;
-      `        or      %o0,%lo({emit_label lbl}),%o0\n`;
-      `        restore\n`
-  | _ -> ()
-  end
-
-(* Names of various instructions *)
-
-let name_for_int_operation = function
-    Iadd -> "add"
-  | Isub -> "sub"
-  | Iand -> "and"
-  | Ior -> "or"
-  | Ixor -> "xor"
-  | Ilsl -> "sll"
-  | Ilsr -> "srl"
-  | Iasr -> "sra"
-  | Imul -> "smul"
-  | _ -> Misc.fatal_error "Emit.name_for_int_operation"
-
-let name_for_float_operation = function
-    Inegf -> if !arch_version = SPARC_V9 then "fnegd" else "fnegs"
-  | Iabsf -> if !arch_version = SPARC_V9 then "fabsd" else "fabss"
-  | Iaddf -> "faddd"
-  | Isubf -> "fsubd"
-  | Imulf -> "fmuld"
-  | Idivf -> "fdivd"
-  | _ -> Misc.fatal_error "Emit.name_for_float_operation"
-
-let name_for_int_movcc = 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 -> "leu"  | Iunsigned Cgt -> "gu"
-  | Iunsigned Clt -> "lu"   | Iunsigned Cge -> "geu"
-
-let name_for_int_comparison = function
-    Isigned Ceq -> "be"      | Isigned Cne -> "bne"
-  | Isigned Cle -> "ble"     | Isigned Cgt -> "bg"
-  | Isigned Clt -> "bl"      | Isigned Cge -> "bge"
-  | Iunsigned Ceq -> "be"    | Iunsigned Cne -> "bne"
-  | Iunsigned Cle -> "bleu"  | Iunsigned Cgt -> "bgu"
-  | Iunsigned Clt -> "blu"   | Iunsigned Cge -> "bgeu"
-
-let name_for_float_comparison cmp neg =
-  match cmp with
-    Ceq -> if neg then "fbne" else "fbe"
-  | Cne -> if neg then "fbe" else "fbne"
-  | Cle -> if neg then "fbug" else "fble"
-  | Cgt -> if neg then "fbule" else "fbg"
-  | Clt -> if neg then "fbuge" else "fbl"
-  | Cge -> if neg then "fbul" else "fbge"
-
-(* Output the assembly code for an instruction *)
-
-let function_name = ref ""
-let tailrec_entry_point = ref 0
-let range_check_trap = ref 0
-
-let rec emit_instr i dslot =
-    match i.desc with
-      Lend -> ()
-    | Lop(Imove | Ispill | Ireload) ->
-        let src = i.arg.(0) and dst = i.res.(0) in
-        begin match (src, dst) with
-            {loc = Reg _; typ = (Int | Addr | Val)}, {loc = Reg _} ->
-              `        mov     {emit_reg src}, {emit_reg dst}\n`
-          | {loc = Reg _; typ = Float}, {loc = Reg _; typ = Float} ->
-              if !arch_version = SPARC_V9 then
-                `      fmovd   {emit_reg src}, {emit_reg dst}\n`
-              else begin
-                `      fmovs   {emit_reg src}, {emit_reg dst}\n`;
-                `      fmovs   {emit_reg(next_in_pair src)}, {emit_reg(next_in_pair dst)}\n`
-              end
-          | {loc = Reg _; typ = Float}, {loc = Reg _; typ = (Int | Addr | Val)} ->
-              (* This happens when calling C functions and passing a float arg
-                 in %o0...%o5 *)
-              `        sub     %sp, 8, %sp\n`;
-              `        std     {emit_reg src}, [%sp + 96]\n`;
-              `        ld      [%sp + 96], {emit_reg dst}\n`;
-              let dst2 = i.res.(1) in
-              begin match dst2 with
-                | {loc = Reg _; typ = Int} ->
-                    `  ld      [%sp + 100], {emit_reg dst2}\n`;
-                | {loc = Stack _; typ = Int} ->
-                    `  ld      [%sp + 100], %g1\n`;
-                    `  st      %g1, {emit_stack dst2}\n`;
-                | _ ->
-                    fatal_error "Emit: Imove Float [| _; _ |]"
-              end;
-              `        add     %sp, 8, %sp\n`
-          | {loc = Reg _; typ = (Int | Addr | Val)}, {loc = Stack _} ->
-              `        st      {emit_reg src}, {emit_stack dst}\n`
-          | {loc = Reg _; typ = Float}, {loc = Stack _} ->
-              `        std     {emit_reg src}, {emit_stack dst}\n`
-          | {loc = Stack _; typ = (Int | Addr | Val)}, {loc = Reg _} ->
-              `        ld      {emit_stack src}, {emit_reg dst}\n`
-          | {loc = Stack _; typ = Float}, {loc = Reg _} ->
-              `        ldd     {emit_stack src}, {emit_reg dst}\n`
-          | (_, _) ->
-              fatal_error "Emit: Imove"
-        end
-    | Lop(Iconst_int n) ->
-        if is_native_immediate n then
-          `    mov     {emit_nativeint n}, {emit_reg i.res.(0)}\n`
-        else begin
-          `    sethi   %hi({emit_nativeint n}), %g1\n`;
-          `    or      %g1, %lo({emit_nativeint n}), {emit_reg i.res.(0)}\n`
-        end
-    | Lop(Iconst_float f) ->
-        (* On UltraSPARC, the fzero instruction could be used to set a
-           floating point register pair to zero. *)
-        let lbl = new_label() in
-        float_constants := (lbl, f) :: !float_constants;
-        `      sethi   %hi({emit_label lbl}), %g1\n`;
-        `      ldd     [%g1 + %lo({emit_label lbl})], {emit_reg i.res.(0)}\n`
-    | Lop(Iconst_symbol s) ->
-        `      sethi   %hi({emit_symbol s}), %g1\n`;
-        `      or      %g1, %lo({emit_symbol s}), {emit_reg i.res.(0)}\n`
-    | Lop(Icall_ind { label_after; }) ->
-        `{record_frame i.live ~label:label_after}      call    {emit_reg i.arg.(0)}\n`;
-        fill_delay_slot dslot
-    | Lop(Icall_imm { func; label_after; }) ->
-        `{record_frame i.live ~label:label_after}      call    {emit_symbol func}\n`;
-        fill_delay_slot dslot
-    | Lop(Itailcall_ind { label_after = _; }) ->
-        let n = frame_size() in
-        if !contains_calls then
-          `    ld      [%sp + {emit_int(n - 4 + 96)}], %o7\n`;
-        `      jmp     {emit_reg i.arg.(0)}\n`;
-        `      add     %sp, {emit_int n}, %sp\n` (* in delay slot *)
-    | Lop(Itailcall_imm { func; label_after = _; }) ->
-        let n = frame_size() in
-        if func = !function_name then begin
-            `  b       {emit_label !tailrec_entry_point}\n`;
-            fill_delay_slot dslot
-        end else begin
-          if !contains_calls then
-            `  ld      [%sp + {emit_int(n - 4 + 96)}], %o7\n`;
-          `    sethi   %hi({emit_symbol func}), %g1\n`;
-          `    jmp     %g1 + %lo({emit_symbol func})\n`;
-          `    add     %sp, {emit_int n}, %sp\n` (* in delay slot *)
-        end
-    | Lop(Iextcall { func; alloc; label_after; }) ->
-        if alloc then begin
-          `    sethi   %hi({emit_symbol func}), %g2\n`;
-          `{record_frame i.live ~label:label_after}    call    {emit_symbol "caml_c_call"}\n`;
-          `    or      %g2, %lo({emit_symbol func}), %g2\n` (* in delay slot *)
-        end else begin
-          `    call    {emit_symbol func}\n`;
-          fill_delay_slot dslot
-        end
-    | Lop(Istackoffset n) ->
-        `      add     %sp, {emit_int (-n)}, %sp\n`;
-        stack_offset := !stack_offset + n
-    | Lop(Iload(chunk, addr)) ->
-        let dest = i.res.(0) in
-        begin match chunk with
-          Double_u ->
-            emit_load "ld" addr i.arg dest;
-            emit_load "ld" (offset_addressing addr 4) i.arg (next_in_pair dest)
-        | Single ->
-            emit_load "ld" addr i.arg dest;
-            `  fstod   {emit_reg dest}, {emit_reg dest}\n`
-        | _ ->
-            let loadinstr =
-              match chunk with
-                Byte_unsigned -> "ldub"
-              | Byte_signed -> "ldsb"
-              | Sixteen_unsigned -> "lduh"
-              | Sixteen_signed -> "ldsh"
-              | Double -> "ldd"
-              | _ -> "ld" in
-            emit_load loadinstr addr i.arg dest
-        end
-    | Lop(Istore(chunk, addr, _)) ->
-        let src = i.arg.(0) in
-        begin match chunk with
-          Double_u ->
-            emit_store "st" addr i.arg src;
-            emit_store "st" (offset_addressing addr 4) i.arg (next_in_pair src)
-        | Single ->
-            `  fdtos   {emit_reg src}, %f30\n`;
-            emit_store "st" addr i.arg (phys_reg 115) (* %f30 *)
-        | _ ->
-            let storeinstr =
-              match chunk with
-              | Byte_unsigned | Byte_signed -> "stb"
-              | Sixteen_unsigned | Sixteen_signed -> "sth"
-              | Double -> "std"
-              | _ -> "st" in
-            emit_store storeinstr addr i.arg src
-        end
-    | Lop(Ialloc { words = n; label_after_call_gc; }) ->
-        if !fastcode_flag then begin
-          let lbl_cont = new_label() in
-          if solaris then begin
-            `  sub     %l6, {emit_int n}, %l6\n`;
-            `  cmp     %l6, %l7\n`
-          end else begin
-            `  ld      [%l7], %g1\n`;
-            `  sub     %l6, {emit_int n}, %l6\n`;
-            `  cmp     %l6, %g1\n`
-          end;
-          `    bgeu    {emit_label lbl_cont}\n`;
-          `    add     %l6, 4, {emit_reg i.res.(0)}\n`; (* in delay slot *)
-          `{record_frame i.live ?label:label_after_call_gc}    call    {emit_symbol "caml_call_gc"}\n`;
-          `    mov     {emit_int n}, %g2\n`; (* in delay slot *)
-          `    add     %l6, 4, {emit_reg i.res.(0)}\n`;
-          `{emit_label lbl_cont}:\n`
-        end else begin
-          `{record_frame i.live}       call    {emit_symbol "caml_allocN"}\n`;
-          `    mov     {emit_int n}, %g2\n`; (* in delay slot *)
-          `    add     %l6, 4, {emit_reg i.res.(0)}\n`
-        end
-    | Lop(Iintop(Icomp cmp)) ->
-        `      cmp     {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
-        if !arch_version = SPARC_V9 then begin
-          let comp = name_for_int_movcc cmp in
-          `    mov     0, {emit_reg i.res.(0)}\n`;
-          `    mov{emit_string comp}   %icc, 1, {emit_reg i.res.(0)}\n`
-        end
-        else begin
-          let comp = name_for_int_comparison cmp
-          and lbl = new_label() in
-          `    {emit_string comp},a    {emit_label lbl}\n`;
-          `    mov     1, {emit_reg i.res.(0)}\n`;
-          `    mov     0, {emit_reg i.res.(0)}\n`;
-          `{emit_label lbl}:\n`
-        end
-    | Lop(Iintop (Icheckbound _)) ->
-        `      cmp     {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
-        if solaris then
-          `    tleu    5\n`            (* 5 = ST_RANGE_CHECK *)
-        else begin
-          if !range_check_trap = 0 then range_check_trap := new_label();
-          `    bleu    {emit_label !range_check_trap}\n`;
-          `    nop\n`                  (* delay slot *)
-        end
-    | Lop(Iintop Idiv) ->
-        `      sra     {emit_reg i.arg.(0)}, 31, %g1\n`;
-        `      wr      %g1, %y\n`;
-        `      sdiv    {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n`
-    | Lop(Iintop Imulh) ->
-        `      smul    {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, %g1\n`;
-        `      rd      %y, {emit_reg i.res.(0)}\n`
-    | Lop(Iintop op) ->
-        let instr = name_for_int_operation op in
-        `      {emit_string instr}     {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n`
-    | Lop(Iintop_imm(Ilsl, 1)) ->
-        (* UltraSPARC has two add units but only one shifter. *)
-        `      add     {emit_reg i.arg.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n`
-    | Lop(Iintop_imm(Icomp cmp, n)) ->
-        `      cmp     {emit_reg i.arg.(0)}, {emit_int n}\n`;
-        if !arch_version = SPARC_V9 then begin
-          let comp = name_for_int_movcc cmp in
-          `    mov     0, {emit_reg i.res.(0)}\n`;
-          `    mov{emit_string comp}   %icc, 1, {emit_reg i.res.(0)}\n`
-        end else begin
-          let comp = name_for_int_comparison cmp
-          and lbl = new_label() in
-          `    {emit_string comp},a    {emit_label lbl}\n`;
-          `    mov     1, {emit_reg i.res.(0)}\n`;
-          `    mov     0, {emit_reg i.res.(0)}\n`;
-          `{emit_label lbl}:\n`
-        end
-    | Lop(Iintop_imm(Icheckbound _, n)) ->
-        `      cmp     {emit_reg i.arg.(0)}, {emit_int n}\n`;
-        if solaris then
-          `    tleu    5\n`            (* 5 = ST_RANGE_CHECK *)
-        else begin
-          if !range_check_trap = 0 then range_check_trap := new_label();
-          `    bleu    {emit_label !range_check_trap}\n`;
-          `    nop\n`                  (* delay slot *)
-        end
-    | Lop(Iintop_imm(Imulh, n)) ->
-        `      smul    {emit_reg i.arg.(0)}, {emit_int n}, %g1\n`;
-        `      rd      %y, {emit_reg i.res.(0)}\n`
-    | Lop(Iintop_imm(op, n)) ->
-        let instr = name_for_int_operation op in
-        `      {emit_string instr}     {emit_reg i.arg.(0)}, {emit_int n}, {emit_reg i.res.(0)}\n`
-    | Lop(Inegf | Iabsf as op) ->
-        let instr = name_for_float_operation op in
-        `      {emit_string instr}     {emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n`;
-        if !arch_version <> SPARC_V9 then
-          `    fmovs   {emit_reg(next_in_pair i.arg.(0))}, {emit_reg(next_in_pair i.res.(0))}\n`
-    | Lop(Iaddf | Isubf | Imulf | Idivf as op) ->
-        let instr = name_for_float_operation op in
-        `      {emit_string instr}     {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n`
-    | Lop(Ifloatofint) ->
-        `      sub     %sp, 8, %sp\n`;
-        `      st      {emit_reg i.arg.(0)}, [%sp + 96]\n`;
-        `      ld      [%sp + 96], %f30\n`;
-        `      add     %sp, 8, %sp\n`;
-        `      fitod   %f30, {emit_reg i.res.(0)}\n`
-    | Lop(Iintoffloat) ->
-        `      fdtoi   {emit_reg i.arg.(0)}, %f30\n`;
-        `      sub     %sp, 8, %sp\n`;
-        `      st      %f30, [%sp + 96]\n`;
-        `      ld      [%sp + 96], {emit_reg i.res.(0)}\n`;
-        `      add     %sp, 8, %sp\n`
-    | Lop(Ispecific _) ->
-       assert false
-    | Lreloadretaddr ->
-        let n = frame_size() in
-        `      ld      [%sp + {emit_int(n - 4 + 96)}], %o7\n`
-    | Lreturn ->
-        let n = frame_size() in
-        `      retl\n`;
-        if n = 0 then
-          `    nop\n`
-        else
-          `    add     %sp, {emit_int n}, %sp\n`
-    | Llabel lbl ->
-        `{emit_label lbl}:\n`
-    | Lbranch lbl ->
-        `      b       {emit_label lbl}\n`;
-        fill_delay_slot dslot
-    | Lcondbranch(tst, lbl) ->
-        begin match tst with
-          Itruetest ->
-            `  tst     {emit_reg i.arg.(0)}\n`;
-            `  bne     {emit_label lbl}\n`
-        | Ifalsetest ->
-            `  tst     {emit_reg i.arg.(0)}\n`;
-            `  be      {emit_label lbl}\n`
-        | Iinttest cmp ->
-            let comp = name_for_int_comparison cmp in
-            `  cmp     {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
-            `  {emit_string comp}      {emit_label lbl}\n`
-        | Iinttest_imm(cmp, n) ->
-            let comp = name_for_int_comparison cmp in
-            `  cmp     {emit_reg i.arg.(0)}, {emit_int n}\n`;
-            `  {emit_string comp}      {emit_label lbl}\n`
-        | Ifloattest(cmp, neg) ->
-            let comp = name_for_float_comparison cmp neg in
-            `  fcmpd   {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
-            `  nop\n`;
-            `  {emit_string comp}      {emit_label lbl}\n`
-        | Ioddtest ->
-            `  andcc   {emit_reg i.arg.(0)}, 1, %g0\n`;
-            `  bne     {emit_label lbl}\n`
-        | Ieventest ->
-            `  andcc   {emit_reg i.arg.(0)}, 1, %g0\n`;
-            `  be      {emit_label lbl}\n`
-        end;
-        fill_delay_slot dslot
-  | Lcondbranch3(lbl0, lbl1, lbl2) ->
-        `      cmp     {emit_reg i.arg.(0)}, 1\n`;
-        begin match lbl0 with
-          None -> ()
-        | Some lbl -> `        bl      {emit_label lbl}\n      nop\n`
-        end;
-        begin match lbl1 with
-          None -> ()
-        | Some lbl -> `        be      {emit_label lbl}\n      nop\n`
-        end;
-        begin match lbl2 with
-          None -> ()
-        | Some lbl -> `        bg      {emit_label lbl}\n      nop\n`
-        end
-    | Lswitch jumptbl ->
-        let lbl_jumptbl = new_label() in
-        `      sethi   %hi({emit_label lbl_jumptbl}), %g1\n`;
-        `      or      %g1, %lo({emit_label lbl_jumptbl}), %g1\n`;
-        `      sll     {emit_reg i.arg.(0)}, 2, %g2\n`;
-        `      ld      [%g1 + %g2], %g1\n`;
-        `      jmp     %g1\n`;         (* poor scheduling *)
-        `      nop\n`;
-        `{emit_label lbl_jumptbl}:`;
-        for i = 0 to Array.length jumptbl - 1 do
-          `    .word   {emit_label jumptbl.(i)}\n`
-        done
-    | Lsetuptrap lbl ->
-        `      call    {emit_label lbl}\n`;
-        `      sub     %sp, 8, %sp\n`  (* in delay slot *)
-    | Lpushtrap ->
-        stack_offset := !stack_offset + 8;
-        `      st      %o7, [%sp + 96]\n`;
-        `      st      %l5, [%sp + 100]\n`;
-        `      mov     %sp, %l5\n`
-    | Lpoptrap ->
-        `      ld      [%sp + 100], %l5\n`;
-        `      add     %sp, 8, %sp\n`;
-        stack_offset := !stack_offset - 8
-    | Lraise _ ->
-        `      ld      [%l5 + 96], %g1\n`;
-        `      mov     %l5, %sp\n`;
-        `      ld      [%sp + 100], %l5\n`;
-        `      jmp     %g1 + 8\n`;
-        `      add     %sp, 8, %sp\n`
-
-and fill_delay_slot = function
-    None -> `  nop\n`
-  | Some i -> emit_instr i None
-
-(* Checks if a pseudo-instruction expands to exactly one machine instruction
-   that does not branch. *)
-
-let is_one_instr_op = function
-    Imulh | Idiv | Imod | Icomp _ | Icheckbound _ -> false
-  | _ -> true
-
-let is_one_instr i =
-  match i.desc with
-    Lop op ->
-      begin match op with
-        Imove | Ispill | Ireload ->
-          i.arg.(0).typ <> Float && i.res.(0).typ <> Float
-      | Iconst_int n -> is_native_immediate n
-      | Istackoffset _ -> true
-      | Iload(_, Iindexed n) -> i.res.(0).typ <> Float && is_immediate n
-      | Istore(_, Iindexed n, _) -> i.arg.(0).typ <> Float && is_immediate n
-      | Iintop(op) -> is_one_instr_op op
-      | Iintop_imm(op, _) -> is_one_instr_op op
-      | Iaddf | Isubf | Imulf | Idivf -> true
-      | Iabsf | Inegf -> !arch_version = SPARC_V9
-      | _ -> false
-      end
-  | _ -> false
-
-let no_interference res arg =
-  try
-    for i = 0 to Array.length arg - 1 do
-      for j = 0 to Array.length res - 1 do
-        if arg.(i).loc = res.(j).loc then raise Exit
-      done
-    done;
-    true
-  with Exit ->
-    false
-
-(* Emit a sequence of instructions, trying to fill delay slots for branches *)
-
-let rec emit_all i =
-  match i with
-    {desc = Lend} -> ()
-  | {next = {desc = Lop(Icall_imm _)
-  | Lop(Iextcall { alloc = false; }) | Lbranch _}}
-    when is_one_instr i ->
-      emit_instr i.next (Some i);
-      emit_all i.next.next
-  | {next = {desc = Lop(Itailcall_imm { func; _ })}}
-    when func = !function_name && is_one_instr i ->
-      emit_instr i.next (Some i);
-      emit_all i.next.next
-  | {next = {desc = Lop(Icall_ind _)}}
-    when is_one_instr i && no_interference i.res i.next.arg ->
-      emit_instr i.next (Some i);
-      emit_all i.next.next
-  | {next = {desc = Lcondbranch(_, _)}}
-    when is_one_instr i && no_interference i.res i.next.arg ->
-      emit_instr i.next (Some i);
-      emit_all i.next.next
-  | _ ->
-      emit_instr i None;
-      emit_all i.next
-
-(* Emission of a function declaration *)
-
-let fundecl fundecl =
-  function_name := fundecl.fun_name;
-  fastcode_flag := fundecl.fun_fast;
-  tailrec_entry_point := new_label();
-  range_check_trap := 0;
-  stack_offset := 0;
-  float_constants := [];
-  `    .text\n`;
-  `    .align  4\n`;
-  `    .global {emit_symbol fundecl.fun_name}\n`;
-  if Config.system = "solaris" then
-    `  .type   {emit_symbol fundecl.fun_name},#function\n`;
-  `{emit_symbol fundecl.fun_name}:\n`;
-  if !Clflags.gprofile then emit_profile();
-  let n = frame_size() in
-  if n > 0 then
-    `  sub     %sp, {emit_int n}, %sp\n`;
-  if !contains_calls then
-    `  st      %o7, [%sp + {emit_int(n - 4 + 96)}]\n`;
-  `{emit_label !tailrec_entry_point}:\n`;
-  emit_all fundecl.fun_body;
-  if !range_check_trap > 0 then begin
-    `{emit_label !range_check_trap}:\n`;
-    `  call    {emit_symbol "caml_ml_array_bound_error"}\n`;
-    `  nop\n`
-  end;
-  emit_size fundecl.fun_name;
-  List.iter emit_float_constant !float_constants
-
-(* Emission of data *)
-
-let emit_item = function
-    Cglobal_symbol s ->
-      `        .global {emit_symbol s}\n`;
-  | Cdefine_symbol s ->
-      `{emit_symbol s}:\n`
-  | Cint8 n ->
-      `        .byte   {emit_int n}\n`
-  | Cint16 n ->
-      `        .half   {emit_int n}\n`
-  | Cint32 n ->
-      `        .word   {emit_nativeint n}\n`
-  | Cint n ->
-      `        .word   {emit_nativeint n}\n`
-  | Csingle f ->
-      emit_float32_directive ".word" (Int32.bits_of_float f)
-  | Cdouble f ->
-      emit_float64_split_directive ".word" (Int64.bits_of_float f)
-  | Csymbol_address s ->
-      `        .word   {emit_symbol s}\n`
-  | Cstring s ->
-      emit_string_directive "  .ascii  " s
-  | Cskip n ->
-      if n > 0 then `  .skip   {emit_int n}\n`
-  | Calign n ->
-      `        .align  {emit_int n}\n`
-
-let data l =
-  `    .data\n`;
-  List.iter emit_item l
-
-(* Beginning / end of an assembly file *)
-
-let begin_assembly() =
-  let lbl_begin = Compilenv.make_symbol (Some "data_begin") in
-  `    .data\n`;
-  `    .global {emit_symbol lbl_begin}\n`;
-  `{emit_symbol lbl_begin}:\n`;
-  let lbl_begin = Compilenv.make_symbol (Some "code_begin") in
-  `    .text\n`;
-  `    .global {emit_symbol lbl_begin}\n`;
-  `{emit_symbol lbl_begin}:\n`
-
-let end_assembly() =
-  `    .text\n`;
-  let lbl_end = Compilenv.make_symbol (Some "code_end") in
-  `    .global {emit_symbol lbl_end}\n`;
-  `{emit_symbol lbl_end}:\n`;
-  `    .data\n`;
-  let lbl_end = Compilenv.make_symbol (Some "data_end") in
-  `    .global {emit_symbol lbl_end}\n`;
-  `{emit_symbol lbl_end}:\n`;
-  `    .word   0\n`;
-  let lbl = Compilenv.make_symbol (Some "frametable") in
-  rodata ();
-  `    .global {emit_symbol lbl}\n`;
-  if Config.system = "solaris" then
-    `  .type   {emit_symbol lbl},#object\n`;
-  `{emit_symbol lbl}:\n`;
-  `    .word   {emit_int (List.length !frame_descriptors)}\n`;
-  List.iter emit_frame !frame_descriptors;
-  emit_size lbl;
-  frame_descriptors := []

diff --git a/asmcomp/sparc/proc.ml b/asmcomp/sparc/proc.ml
deleted file mode 100644 (file)
index 04f3b19..0000000
--- a/asmcomp/sparc/proc.ml
+++ /dev/null
@@ -1,251 +0,0 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                 OCaml                                  *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
-(* Description of the Sparc processor *)
-
-open Misc
-open Cmm
-open Reg
-open Arch
-open Mach
-
-(* Instruction selection *)
-
-let word_addressed = false
-
-(* Registers available for register allocation *)
-
-(* Register map:
-    %o0 - %o5   0 - 5       function results, C functions args / res
-    %i0 - %i5   6 - 11      function arguments, preserved by C
-    %l0 - %l4   12 - 16     general purpose, preserved by C
-    %g3 - %g4   17 - 18     general purpose, not preserved by C
-
-    %l5                     exception pointer
-    %l6                     allocation pointer
-    %l7                     address of allocation limit
-
-    %g0                     always zero
-    %g1 - %g2               temporaries
-    %g5 - %g7               reserved for system libraries
-
-    %f0 - %f10  100 - 105   function arguments and results
-    %f12 - %f28 106 - 114   general purpose
-    %f30                    temporary *)
-
-let int_reg_name = [|
-  (* 0-5 *)   "%o0"; "%o1"; "%o2"; "%o3"; "%o4"; "%o5";
-  (* 6-11 *)  "%i0"; "%i1"; "%i2"; "%i3"; "%i4"; "%i5";
-  (* 12-16 *) "%l0"; "%l1"; "%l2"; "%l3"; "%l4";
-  (* 17-18 *) "%g3"; "%g4"
-|]
-
-let float_reg_name = [|
-  (* 100-105 *) "%f0"; "%f2"; "%f4"; "%f6"; "%f8"; "%f10";
-  (* 106-109 *) "%f12"; "%f14"; "%f16"; "%f18";
-  (* 110-114 *) "%f20"; "%f22"; "%f24"; "%f26"; "%f28";
-  (* 115 *)     "%f30";
-  (* Odd parts of register pairs *)
-  (* 116-121 *) "%f1"; "%f3"; "%f5"; "%f7"; "%f9"; "%f11";
-  (* 122-125 *) "%f13"; "%f15"; "%f17"; "%f19";
-  (* 126-130 *) "%f21"; "%f23"; "%f25"; "%f27"; "%f29";
-  (* 131 *)     "%f31"
-|]
-
-let num_register_classes = 2
-
-let register_class r =
-  match r.typ with
-  | Val | Int | Addr -> 0
-  | Float -> 1
-
-let num_available_registers = [| 19; 15 |]
-
-let first_available_register = [| 0; 100 |]
-
-let register_name r =
-  if r < 100 then int_reg_name.(r) else float_reg_name.(r - 100)
-
-let rotate_registers = true
-
-(* Representation of hard registers by pseudo-registers *)
-
-let hard_int_reg =
-  let v = Array.make 19 Reg.dummy in
-  for i = 0 to 18 do v.(i) <- Reg.at_location Int (Reg i) done;
-  v
-
-let hard_float_reg =
-  let v = Array.make 32 Reg.dummy in
-  for i = 0 to 31 do v.(i) <- Reg.at_location Float (Reg(100 + i)) done;
-  v
-
-let all_phys_regs =
-  Array.append hard_int_reg (Array.sub hard_float_reg 0 15)
-  (* No need to include the odd parts of float register pairs,
-     nor the temporary register %f30 *)
-
-let phys_reg n =
-  if n < 100 then hard_int_reg.(n) else hard_float_reg.(n - 100)
-
-let stack_slot slot ty =
-  Reg.at_location ty (Stack slot)
-
-let loc_spacetime_node_hole = Reg.dummy  (* Spacetime unsupported *)
-
-(* Calling conventions *)
-
-let calling_conventions first_int last_int first_float last_float make_stack
-                        arg =
-  let loc = Array.make (Array.length arg) Reg.dummy in
-  let int = ref first_int in
-  let float = ref first_float in
-  let ofs = ref 0 in
-  for i = 0 to Array.length arg - 1 do
-    match arg.(i).typ with
-    | Val | Int | Addr as ty ->
-        if !int <= last_int then begin
-          loc.(i) <- phys_reg !int;
-          incr int
-        end else begin
-          loc.(i) <- stack_slot (make_stack !ofs) ty;
-          ofs := !ofs + size_int
-        end
-    | Float ->
-        if !float <= last_float then begin
-          loc.(i) <- phys_reg !float;
-          incr float
-        end else begin
-          loc.(i) <- stack_slot (make_stack !ofs) Float;
-          ofs := !ofs + size_float
-        end
-  done;
-  (loc, Misc.align !ofs 8)         (* Keep stack 8-aligned *)
-
-let incoming ofs = Incoming ofs
-let outgoing ofs = Outgoing ofs
-let not_supported _ofs = fatal_error "Proc.loc_results: cannot call"
-
-let max_arguments_for_tailcalls = 10
-
-let loc_arguments arg =
-  calling_conventions 6 15 100 105 outgoing arg
-let loc_parameters arg =
-  let (loc, _ofs) = calling_conventions 6 15 100 105 incoming arg in loc
-let loc_results res =
-  let (loc, _ofs) = calling_conventions 0 5 100 105 not_supported res in loc
-
-(* On the Sparc, all arguments to C functions, even floating-point arguments,
-   are passed in %o0..%o5, then on the stack *)
-
-let loc_external_arguments arg =
-  let loc = Array.make (Array.length arg) [| |] in
-  let reg = ref 0 (* %o0 *) in
-  let ofs = ref (-4) in              (* start at sp + 92 = sp + 96 - 4 *)
-  let next_loc typ =
-    if !reg <= 5 (* %o5 *) then begin
-      assert (size_component typ = size_int);
-      let loc = phys_reg !reg in
-      incr reg;
-      loc
-    end else begin
-      let loc = stack_slot (outgoing !ofs) typ in
-      ofs := !ofs + size_component typ;
-      loc
-    end
-  in
-  for i = 0 to Array.length arg - 1 do
-    match arg.(i) with
-    | [| { typ = (Val | Int | Addr as typ) } |] ->
-      loc.(i) <- [| next_loc typ |]
-    | [| { typ = Float } |] ->
-      if !reg <= 5 then begin
-        let loc1 = next_loc Int in
-        let loc2 = next_loc Int in
-        loc.(i) <- [| loc1; loc2 |]
-      end else
-        loc.(i) <- [| next_loc Float |]
-    | [| { typ = Int }; { typ = Int } |] ->
-      (* int64 unboxed *)
-      let loc1 = next_loc Int in
-      let loc2 = next_loc Int in
-      loc.(i) <- [| loc1; loc2 |]
-    | _ ->
-      fatal_error "Proc.loc_external_arguments: cannot call"
-  done;
-  (* Keep stack 8-aligned *)
-  (loc, Misc.align (!ofs + 4) 8)
-
-let loc_external_results res =
-  let (loc, _ofs) = calling_conventions 0 1 100 100 not_supported res in loc
-
-let loc_exn_bucket = phys_reg 0         (* $o0 *)
-
-(* Volatile registers: none *)
-
-let regs_are_volatile _rs = false
-
-(* Registers destroyed by operations *)
-
-let destroyed_at_c_call = (* %l0-%l4, %i0-%i5 preserved *)
-  Array.of_list(List.map phys_reg
-    [0; 1; 2; 3; 4; 5; 17; 18;
-     100; 101; 102; 103; 104; 105; 106; 107;
-     108; 109; 110; 111; 112; 113; 114])
-
-let destroyed_at_oper = function
-    Iop(Icall_ind _ | Icall_imm _ | Iextcall { alloc = true; }) ->
-    all_phys_regs
-  | Iop(Iextcall { alloc = false; }) -> destroyed_at_c_call
-  | _ -> [||]
-
-let destroyed_at_raise = all_phys_regs
-
-(* Maximal register pressure *)
-
-let safe_register_pressure = function
-    Iextcall _ -> 0
-  | _ -> 15
-
-let max_register_pressure = function
-    Iextcall _ -> [| 11; 0 |]
-  | _ -> [| 19; 15 |]
-
-(* Pure operations (without any side effect besides updating their result
-   registers). *)
-
-let op_is_pure = function
-  | Icall_ind _ | Icall_imm _ | Itailcall_ind _ | Itailcall_imm _
-  | Iextcall _ | Istackoffset _ | Istore _ | Ialloc _
-  | Iintop(Icheckbound _) | Iintop_imm(Icheckbound _, _) -> false
-  | _ -> true
-
-(* Layout of the stack *)
-
-let num_stack_slots = [| 0; 0 |]
-let contains_calls = ref false
-
-(* Calling the assembler and the archiver *)
-
-let assemble_file infile outfile =
-  let asflags = begin match !arch_version with
-    SPARC_V7 -> " -o "
-  | SPARC_V8 -> " -xarch=v8 -o "
-  | SPARC_V9 -> " -xarch=v8plus -o "
-  end in
-  Ccomp.command (Config.asm ^ asflags ^
-                 Filename.quote outfile ^ " " ^ Filename.quote infile)
-
-let init () = ()

diff --git a/asmcomp/sparc/reload.ml b/asmcomp/sparc/reload.ml
deleted file mode 100644 (file)
index 356dc7f..0000000
--- a/asmcomp/sparc/reload.ml
+++ /dev/null
@@ -1,19 +0,0 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                 OCaml                                  *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
-(* Reloading for the Sparc *)
-
-let fundecl f =
-  (new Reloadgen.reload_generic)#fundecl f

diff --git a/asmcomp/sparc/scheduling.ml b/asmcomp/sparc/scheduling.ml
deleted file mode 100644 (file)
index c169b47..0000000
--- a/asmcomp/sparc/scheduling.ml
+++ /dev/null
@@ -1,63 +0,0 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                 OCaml                                  *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
-open Cmm
-open Mach
-
-(* Instruction scheduling for the Sparc *)
-
-class scheduler = object
-
-inherit Schedgen.scheduler_generic
-
-(* Latencies (in cycles). *)
-
-(* UltraSPARC issues two integer operations, plus a single load or store,
-   per cycle.  At most one of the integer instructions may be a shift.
-   Most integer operations have one cycle latency.  Unsigned loads take
-   two cycles.  Signed loads take three cycles.  Conditional moves have
-   two cycle latency and may not issue in the same cycle as any other
-   instruction.  Floating point issue rules are complicated, but in
-   general independent add and multiply can dual issue with four cycle
-   latency.  *)
-
-method oper_latency = function
-    Ireload -> 2
-  | Iload((Byte_signed|Sixteen_signed|Thirtytwo_signed), _) -> 3
-  | Iload(_, _) -> 2
-  | Iconst_float _ -> 2 (* turned into a load *)
-  | Inegf | Iabsf | Iaddf | Isubf | Imulf -> 4
-  | Idivf -> 15
-  | _ -> 1
-
-(* Issue cycles.  Rough approximations. *)
-
-method oper_issue_cycles = function
-    Iconst_float _ -> 2
-  | Iconst_symbol _ -> 2
-  | Ialloc _ -> 6
-  | Iintop(Icomp _) -> 4
-  | Iintop(Icheckbound _) -> 2
-  | Iintop_imm(Icomp _, _) -> 4
-  | Iintop_imm(Icheckbound _, _) -> 2
-  | Inegf -> 2
-  | Iabsf -> 2
-  | Ifloatofint -> 6
-  | Iintoffloat -> 6
-  | _ -> 1
-
-end
-
-let fundecl f = (new scheduler)#schedule_fundecl f

diff --git a/asmcomp/sparc/selection.ml b/asmcomp/sparc/selection.ml
deleted file mode 100644 (file)
index 1083aa3..0000000
--- a/asmcomp/sparc/selection.ml
+++ /dev/null
@@ -1,80 +0,0 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                 OCaml                                  *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1997 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
-(* Instruction selection for the Sparc processor *)
-
-open Cmm
-open Reg
-open Arch
-open Mach
-
-class selector = object (self)
-
-inherit Selectgen.selector_generic as super
-
-method is_immediate n = (n <= 4095) && (n >= -4096)
-
-method select_addressing _chunk = function
-    Cconst_symbol s ->
-      (Ibased(s, 0), Ctuple [])
-  | Cop((Caddv | Cadda), [Cconst_symbol s; Cconst_int n], _) ->
-      (Ibased(s, n), Ctuple [])
-  | Cop((Caddv | Cadda), [arg; Cconst_int n], _) ->
-      (Iindexed n, arg)
-  | Cop((Caddv | Cadda as op),
-        [arg1; Cop(Caddi, [arg2; Cconst_int n], _)], dbg) ->
-      (Iindexed n, Cop(op, [arg1; arg2], dbg))
-  | arg ->
-      (Iindexed 0, arg)
-
-method private iextcall (func, alloc) =
-  Iextcall { func; alloc; label_after = Cmm.new_label (); }
-
-method! select_operation op args dbg =
-  match (op, args) with
-  (* For SPARC V7 multiplication, division and modulus are turned into
-     calls to C library routines.
-     For SPARC V8 and V9, use hardware multiplication and division,
-     but C library routine for modulus. *)
-    (Cmuli, _) when !arch_version = SPARC_V7 ->
-      (self#iextcall(".umul", false), args)
-  | (Cdivi, _) when !arch_version = SPARC_V7 ->
-      (self#iextcall(".div", false), args)
-  | (Cmodi, _) ->
-      (self#iextcall(".rem", false), args)
-  | _ ->
-      super#select_operation op args dbg
-
-(* Override insert_move_args to deal correctly with floating-point
-   arguments being passed into pairs of integer registers. *)
-method! insert_move_args arg loc stacksize =
-  if stacksize <> 0 then self#insert (Iop(Istackoffset stacksize)) [||] [||];
-  let locpos = ref 0 in
-  for i = 0 to Array.length arg - 1 do
-    let src = arg.(i) in
-    let dst = loc.(!locpos) in
-    match (src, dst) with
-      ({typ = Float}, {typ = Int}) ->
-        let dst2 = loc.(!locpos + 1) in
-        self#insert (Iop Imove) [|src|] [|dst; dst2|];
-        locpos := !locpos + 2
-    | (_, _) ->
-        self#insert_move src dst;
-        incr locpos
-  done
-
-end
-
-let fundecl f = (new selector)#emit_fundecl f

diff --git a/asmcomp/spill.ml b/asmcomp/spill.ml
index cefef95e48fd39f38fa559866fa785e32e4164a9..a02b0c36fc38a97cba77c638dbe5359d72b5ef0f 100644 (file)
--- a/asmcomp/spill.ml
+++ b/asmcomp/spill.ml
@@ -151,8 +151,9 @@ let rec reload i before =
   | Iop op ->
       let new_before =
         (* Quick check to see if the register pressure is below the maximum *)
-        if Reg.Set.cardinal i.live + Array.length i.res <=
-           Proc.safe_register_pressure op
+        if !Clflags.use_linscan ||
+           (Reg.Set.cardinal i.live + Array.length i.res <=
+            Proc.safe_register_pressure op)
         then before
         else add_superpressure_regs op i.live i.res before in
       let after =
@@ -327,7 +328,7 @@ let rec spill i finally =
       let before1 = Reg.diff_set_array after i.res in
       let before =
         match i.desc with
-          Iop Icall_ind _ | Iop(Icall_imm _) | Iop(Iextcall _)
+          Iop Icall_ind _ | Iop(Icall_imm _) | Iop(Iextcall _) | Iop(Ialloc _)
         | Iop(Iintop (Icheckbound _)) | Iop(Iintop_imm((Icheckbound _), _)) ->
             Reg.Set.union before1 !spill_at_raise
         | _ ->

diff --git a/asmcomp/strmatch.ml b/asmcomp/strmatch.ml
index 983f5340a4ea395f8c38bebd9c8d2b710da907dd..3a60f2419d73c74369b5782957388d4cf079ee78 100644 (file)
--- a/asmcomp/strmatch.ml
+++ b/asmcomp/strmatch.ml
@@ -21,7 +21,7 @@ open Cmm
 module type I = sig
   val string_block_length : Cmm.expression -> Cmm.expression
   val transl_switch :
-      Cmm.expression -> int -> int ->
+      Location.t -> Cmm.expression -> int -> int ->
         (int * Cmm.expression) list -> Cmm.expression ->
           Cmm.expression
 end
@@ -334,7 +334,7 @@ module Make(I:I) = struct
 (*
   Switch according to pattern size
   Argument from_ind is the starting index, it can be zero
-  or one (when the swicth on the cell 0 has already been performed.
+  or one (when the switch on the cell 0 has already been performed.
   In that latter case pattern len is string length-1 and is corrected.
  *)
 
@@ -350,8 +350,8 @@ module Make(I:I) = struct
             (len,act))
           (by_size cases) in
       let id = gen_size_id () in
-      ignore dbg;
-      let switch = I.transl_switch (Cvar id) 1 max_int size_cases default in
+      let loc = Debuginfo.to_location dbg in
+      let switch = I.transl_switch loc (Cvar id) 1 max_int size_cases default in
       mk_let_size id str switch
 
 (*

diff --git a/asmcomp/strmatch.mli b/asmcomp/strmatch.mli
index 35bfc53503d555f79c9c45111f3728f0bb1c23d6..bf63d990337f4ff633797c46dd72685e8f4fdc59 100644 (file)
--- a/asmcomp/strmatch.mli
+++ b/asmcomp/strmatch.mli
@@ -18,7 +18,7 @@
 module type I = sig
   val string_block_length : Cmm.expression -> Cmm.expression
   val transl_switch :
-      Cmm.expression -> int -> int ->
+      Location.t -> Cmm.expression -> int -> int ->
         (int * Cmm.expression) list -> Cmm.expression ->
           Cmm.expression
 end

diff --git a/asmcomp/un_anf.ml b/asmcomp/un_anf.ml
index 9d373cab11ee0dc61c19d68a0fb1d89292df7eb4..bc8f9eb8146a37d7409c9e5360f67ce6225b8945 100644 (file)
--- a/asmcomp/un_anf.ml
+++ b/asmcomp/un_anf.ml
@@ -118,12 +118,13 @@ let make_ident_info (clam : Clambda.ulambda) : ident_info =
       List.iter loop args;
       ignore_debuginfo dbg
     | Uswitch (cond, { us_index_consts; us_actions_consts;
-          us_index_blocks; us_actions_blocks }) ->
+          us_index_blocks; us_actions_blocks }, dbg) ->
       loop cond;
       ignore_int_array us_index_consts;
       Array.iter loop us_actions_consts;
       ignore_int_array us_index_blocks;
-      Array.iter loop us_actions_blocks
+      Array.iter loop us_actions_blocks;
+      ignore_debuginfo dbg
     | Ustringswitch (cond, branches, default) ->
       loop cond;
       List.iter (fun (str, branch) ->
@@ -305,7 +306,7 @@ let let_bound_vars_that_can_be_moved ident_info (clam : Clambda.ulambda) =
       examine_argument_list args;
       ignore_debuginfo dbg
     | Uswitch (cond, { us_index_consts; us_actions_consts;
-          us_index_blocks; us_actions_blocks }) ->
+          us_index_blocks; us_actions_blocks }, dbg) ->
       examine_argument_list [cond];
       ignore_int_array us_index_consts;
       Array.iter (fun action ->
@@ -317,6 +318,7 @@ let let_bound_vars_that_can_be_moved ident_info (clam : Clambda.ulambda) =
           let_stack := [];
           loop action)
         us_actions_blocks;
+      ignore_debuginfo dbg;
       let_stack := []
     | Ustringswitch (cond, branches, default) ->
       examine_argument_list [cond];
@@ -330,8 +332,7 @@ let let_bound_vars_that_can_be_moved ident_info (clam : Clambda.ulambda) =
       let_stack := []
     | Ustaticfail (static_exn, args) ->
       ignore_int static_exn;
-      ignore_ulambda_list args;
-      let_stack := []
+      examine_argument_list args
     | Ucatch (static_exn, idents, body, handler) ->
       ignore_int static_exn;
       ignore_ident_list idents;
@@ -451,7 +452,7 @@ let rec substitute_let_moveable is_let_moveable env (clam : Clambda.ulambda)
   | Uprim (prim, args, dbg) ->
     let args = substitute_let_moveable_list is_let_moveable env args in
     Uprim (prim, args, dbg)
-  | Uswitch (cond, sw) ->
+  | Uswitch (cond, sw, dbg) ->
     let cond = substitute_let_moveable is_let_moveable env cond in
     let sw =
       { sw with
@@ -463,7 +464,7 @@ let rec substitute_let_moveable is_let_moveable env (clam : Clambda.ulambda)
             sw.us_actions_blocks;
       }
     in
-    Uswitch (cond, sw)
+    Uswitch (cond, sw, dbg)
   | Ustringswitch (cond, branches, default) ->
     let cond = substitute_let_moveable is_let_moveable env cond in
     let branches =
@@ -621,7 +622,7 @@ let rec un_anf_and_moveable ident_info env (clam : Clambda.ulambda)
       un_anf_and_moveable ident_info env body
     | Constant, _, true, false
     (* A constant expression bound to an unassigned identifier can replace any
-         occurances of the identifier. *)
+         occurrences of the identifier. *)
     | Moveable, true, true, false  ->
       (* A moveable expression bound to a linear unassigned [Ident.t]
          may replace the single occurrence of the identifier. *)
@@ -654,7 +655,7 @@ let rec un_anf_and_moveable ident_info env (clam : Clambda.ulambda)
       both_moveable args_moveable (primitive_moveable prim args ident_info)
     in
     Uprim (prim, args, dbg), moveable
-  | Uswitch (cond, sw) ->
+  | Uswitch (cond, sw, dbg) ->
     let cond = un_anf ident_info env cond in
     let sw =
       { sw with
@@ -662,7 +663,7 @@ let rec un_anf_and_moveable ident_info env (clam : Clambda.ulambda)
         us_actions_blocks = un_anf_array ident_info env sw.us_actions_blocks;
       }
     in
-    Uswitch (cond, sw), Fixed
+    Uswitch (cond, sw, dbg), Fixed
   | Ustringswitch (cond, branches, default) ->
     let cond = un_anf ident_info env cond in
     let branches =

diff --git a/asmcomp/x86_proc.ml b/asmcomp/x86_proc.ml
index 30b77af5c665e26261e02f80068ca5e5ea8906b4..897794b4a2e5c8ef7aca9580c75e616aeb9448c9 100644 (file)
--- a/asmcomp/x86_proc.ml
+++ b/asmcomp/x86_proc.ml
@@ -219,7 +219,6 @@ let string_of_rounding = function
   | 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)
@@ -233,6 +232,11 @@ let masm =
   | S_win32 | S_win64 -> true
   | _ -> false
 
+let use_plt =
+  match system with
+  | S_macosx | S_mingw64 | S_cygwin | S_win64 -> false
+  | _ -> !Clflags.dlcode
+
 (* 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.

diff --git a/asmcomp/x86_proc.mli b/asmcomp/x86_proc.mli
index 388420b2d9a89dee07df861e815113659e3e0664..e8aed9c115578a70cc7e3ae80fb9e61e6a544415 100644 (file)
--- a/asmcomp/x86_proc.mli
+++ b/asmcomp/x86_proc.mli
@@ -81,6 +81,9 @@ val system: system
 val masm: bool
 val windows:bool
 
+(** Whether calls need to go via the PLT. *)
+val use_plt : bool
+
 (** Support for plumbing a binary code emitter *)
 
 val register_internal_assembler: (asm_program -> string -> unit) -> unit

diff --git a/asmrun/.depend b/asmrun/.depend
index c2fa489b8414b043f9dd12870dc09e8fb0871749..2a253ebec2fa8802d9ea337d37c28e2deb8eeac2 100644 (file)
--- a/asmrun/.depend
+++ b/asmrun/.depend
@@ -1,296 +1,335 @@
-afl.o: afl.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/osdeps.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/minor_gc.h \
-  ../byterun/caml/address_class.h ../byterun/caml/stacks.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/signals.h ../byterun/caml/spacetime.h \
-  ../byterun/caml/io.h ../byterun/caml/stack.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/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/backtrace.h ../byterun/caml/exec.h \
-  ../byterun/caml/backtrace_prim.h ../byterun/caml/fail.h
-backtrace_prim.o: backtrace_prim.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/backtrace_prim.h \
-  ../byterun/caml/memory.h ../byterun/caml/gc.h \
+startup_aux.$(O): startup_aux.c ../byterun/caml/backtrace.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/config.h \
+  ../byterun/caml/m.h ../byterun/caml/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/stack.h
-callback.o: callback.c ../byterun/caml/callback.h \
+  ../byterun/caml/callback.h ../byterun/caml/osdeps.h \
+  ../byterun/caml/startup_aux.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/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
-clambda_checks.o: clambda_checks.c ../byterun/caml/mlvalues.h \
-  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
-  ../byterun/caml/../../config/s.h ../byterun/caml/misc.h
-compact.o: compact.c ../byterun/caml/address_class.h \
-  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
-  ../byterun/caml/../../config/s.h ../byterun/caml/misc.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/gc_ctrl.h \
-  ../byterun/caml/weak.h ../byterun/caml/compact.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
-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/m.h ../byterun/caml/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/major_gc.h ../byterun/caml/minor_gc.h \
+  ../byterun/caml/address_class.h ../byterun/caml/osdeps.h \
+  ../byterun/caml/printexc.h ../byterun/caml/stack.h \
+  ../byterun/caml/startup_aux.h ../byterun/caml/sys.h
+main.$(O): main.c ../byterun/caml/misc.h ../byterun/caml/config.h \
+  ../byterun/caml/m.h ../byterun/caml/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/sys.h ../byterun/caml/osdeps.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
-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/debugger.h ../byterun/caml/osdeps.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/mlvalues.h ../byterun/caml/dynlink.h \
+fail.$(O): fail.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/s.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/fail.h ../byterun/caml/io.h \
+  ../byterun/caml/gc.h ../byterun/caml/memory.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/signals.h \
+  ../byterun/caml/stack.h ../byterun/caml/roots.h \
+  ../byterun/caml/callback.h
+roots.$(O): roots.c ../byterun/caml/finalise.h ../byterun/caml/roots.h \
+  ../byterun/caml/misc.h ../byterun/caml/config.h ../byterun/caml/m.h \
+  ../byterun/caml/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/stack.h
+signals.$(O): signals.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/s.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 \
-  ../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/md5.h \
-  ../byterun/caml/memory.h ../byterun/caml/major_gc.h \
-  ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \
-  ../byterun/caml/address_class.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/major_gc.h \
-  ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \
-  ../byterun/caml/address_class.h ../byterun/caml/printexc.h \
-  ../byterun/caml/signals.h ../byterun/caml/stack.h \
-  ../byterun/caml/roots.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/compact.h \
-  ../byterun/caml/fail.h ../byterun/caml/finalise.h \
-  ../byterun/caml/roots.h ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/roots.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/m.h \
+  ../byterun/caml/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/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/osdeps.h ../byterun/caml/signals.h \
+  ../byterun/caml/signals_machdep.h signals_osdep.h \
+  ../byterun/caml/stack.h ../byterun/caml/spacetime.h \
+  ../byterun/caml/io.h
+misc.$(O): misc.c ../byterun/caml/config.h ../byterun/caml/m.h \
+  ../byterun/caml/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/reverse.h ../byterun/caml/stacks.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/osdeps.h ../byterun/caml/version.h
+freelist.$(O): freelist.c ../byterun/caml/config.h ../byterun/caml/m.h \
+  ../byterun/caml/s.h ../byterun/caml/freelist.h ../byterun/caml/misc.h \
   ../byterun/caml/mlvalues.h ../byterun/caml/gc.h \
   ../byterun/caml/gc_ctrl.h ../byterun/caml/memory.h \
   ../byterun/caml/major_gc.h ../byterun/caml/minor_gc.h \
   ../byterun/caml/address_class.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/backtrace.h ../byterun/caml/exec.h \
-  ../byterun/caml/compact.h ../byterun/caml/custom.h \
+major_gc.$(O): major_gc.c ../byterun/caml/compact.h ../byterun/caml/config.h \
+  ../byterun/caml/m.h ../byterun/caml/s.h ../byterun/caml/misc.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/custom.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/gc_ctrl.h ../byterun/caml/signals.h \
-  ../byterun/caml/stack.h ../byterun/caml/startup_aux.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/roots.h ../byterun/caml/globroots.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/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/weak.h
+minor_gc.$(O): minor_gc.c ../byterun/caml/custom.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/config.h \
+  ../byterun/caml/m.h ../byterun/caml/s.h ../byterun/caml/misc.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/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/md5.h ../byterun/caml/memory.h \
+  ../byterun/caml/gc_ctrl.h ../byterun/caml/signals.h \
+  ../byterun/caml/weak.h
+memory.$(O): memory.c ../byterun/caml/address_class.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/s.h \
+  ../byterun/caml/misc.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/memory.h ../byterun/caml/minor_gc.h \
+  ../byterun/caml/signals.h
+alloc.$(O): alloc.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/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/minor_gc.h ../byterun/caml/address_class.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/stacks.h
+compare.$(O): compare.c ../byterun/caml/custom.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/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
-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/mlvalues.h \
-  ../byterun/caml/custom.h ../byterun/caml/fail.h ../byterun/caml/io.h \
+ints.$(O): ints.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/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
+floats.$(O): floats.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/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/osdeps.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/stacks.h ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/reverse.h ../byterun/caml/stacks.h
+str.$(O): str.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/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
-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/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/mlvalues.h \
-  ../byterun/caml/custom.h ../byterun/caml/fail.h \
-  ../byterun/caml/finalise.h ../byterun/caml/roots.h \
+array.$(O): array.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/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/gc_ctrl.h ../byterun/caml/signals.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/signals.h ../byterun/caml/spacetime.h \
+  ../byterun/caml/io.h ../byterun/caml/stack.h
+io.$(O): io.c ../byterun/caml/config.h ../byterun/caml/m.h \
+  ../byterun/caml/s.h ../byterun/caml/alloc.h ../byterun/caml/misc.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/osdeps.h \
+  ../byterun/caml/signals.h ../byterun/caml/sys.h
+extern.$(O): extern.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/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/md5.h ../byterun/caml/memory.h \
   ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
   ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
   ../byterun/caml/reverse.h
-memory.o: memory.c ../byterun/caml/address_class.h \
-  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
-  ../byterun/caml/../../config/s.h ../byterun/caml/misc.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/memory.h ../byterun/caml/minor_gc.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/fail.h ../byterun/caml/fix_code.h \
-  ../byterun/caml/interp.h ../byterun/caml/intext.h ../byterun/caml/io.h \
+intern.$(O): intern.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/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/md5.h \
+  ../byterun/caml/memory.h ../byterun/caml/major_gc.h \
+  ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \
+  ../byterun/caml/address_class.h ../byterun/caml/reverse.h
+hash.$(O): hash.c ../byterun/caml/mlvalues.h ../byterun/caml/config.h \
+  ../byterun/caml/m.h ../byterun/caml/s.h ../byterun/caml/misc.h \
+  ../byterun/caml/custom.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
+sys.$(O): sys.c ../byterun/caml/config.h ../byterun/caml/m.h \
+  ../byterun/caml/s.h ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/debugger.h \
+  ../byterun/caml/fail.h ../byterun/caml/gc_ctrl.h ../byterun/caml/io.h \
+  ../byterun/caml/osdeps.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 ../byterun/caml/stacks.h \
+  ../byterun/caml/sys.h ../byterun/caml/version.h \
+  ../byterun/caml/callback.h ../byterun/caml/startup_aux.h
+parsing.$(O): parsing.c ../byterun/caml/config.h ../byterun/caml/m.h \
+  ../byterun/caml/s.h ../byterun/caml/mlvalues.h ../byterun/caml/misc.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/prims.h ../byterun/caml/stacks.h
-minor_gc.o: minor_gc.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/alloc.h
+gc_ctrl.$(O): gc_ctrl.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/s.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/backtrace.h \
+  ../byterun/caml/exec.h ../byterun/caml/compact.h \
+  ../byterun/caml/custom.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/gc_ctrl.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/stack.h ../byterun/caml/startup_aux.h
+terminfo.$(O): terminfo.c ../byterun/caml/config.h ../byterun/caml/m.h \
+  ../byterun/caml/s.h ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/fail.h ../byterun/caml/io.h
+md5.$(O): md5.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/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/reverse.h
+obj.$(O): obj.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/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/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/prims.h ../byterun/caml/spacetime.h \
+  ../byterun/caml/io.h ../byterun/caml/stack.h
+lexing.$(O): lexing.c ../byterun/caml/fail.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/s.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/stacks.h \
   ../byterun/caml/memory.h ../byterun/caml/gc.h \
-  ../byterun/caml/mlvalues.h ../byterun/caml/major_gc.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h
+unix.$(O): unix.c ../byterun/caml/config.h ../byterun/caml/m.h \
+  ../byterun/caml/s.h ../byterun/caml/fail.h ../byterun/caml/misc.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/version.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/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/signals.h ../byterun/caml/sys.h ../byterun/caml/io.h \
+  ../byterun/caml/alloc.h
+printexc.$(O): printexc.c ../byterun/caml/backtrace.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/config.h \
+  ../byterun/caml/m.h ../byterun/caml/s.h ../byterun/caml/misc.h \
+  ../byterun/caml/exec.h ../byterun/caml/callback.h \
+  ../byterun/caml/debugger.h ../byterun/caml/fail.h \
+  ../byterun/caml/printexc.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
+callback.$(O): callback.c ../byterun/caml/callback.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/config.h \
+  ../byterun/caml/m.h ../byterun/caml/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/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 ../byterun/caml/hooks.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/minor_gc.h ../byterun/caml/address_class.h
+weak.$(O): weak.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/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/minor_gc.h \
-  ../byterun/caml/address_class.h ../byterun/caml/prims.h \
-  ../byterun/caml/spacetime.h ../byterun/caml/io.h \
-  ../byterun/caml/stack.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/misc.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/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/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/weak.h
+compact.$(O): compact.c ../byterun/caml/address_class.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/s.h \
+  ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/finalise.h ../byterun/caml/roots.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/stack.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/fail.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/gc_ctrl.h \
+  ../byterun/caml/weak.h ../byterun/caml/compact.h
+finalise.$(O): finalise.c ../byterun/caml/callback.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/config.h \
+  ../byterun/caml/m.h ../byterun/caml/s.h ../byterun/caml/misc.h \
+  ../byterun/caml/compact.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/roots.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/signals.h
+custom.$(O): custom.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/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
+globroots.$(O): globroots.c ../byterun/caml/memory.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/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/roots.h ../byterun/caml/globroots.h
+backtrace_prim.$(O): backtrace_prim.c ../byterun/caml/alloc.h \
+  ../byterun/caml/misc.h ../byterun/caml/config.h ../byterun/caml/m.h \
+  ../byterun/caml/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/backtrace.h ../byterun/caml/exec.h \
+  ../byterun/caml/backtrace_prim.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/stack.h
+backtrace.$(O): backtrace.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/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 ../byterun/caml/stack.h ../byterun/caml/spacetime.h \
-  ../byterun/caml/io.h
-spacetime.o: spacetime.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/address_class.h ../byterun/caml/backtrace.h \
+  ../byterun/caml/exec.h ../byterun/caml/backtrace_prim.h \
+  ../byterun/caml/fail.h
+natdynlink.$(O): natdynlink.c ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/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/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 \
+  ../byterun/caml/hooks.h
+debugger.$(O): debugger.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/s.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/debugger.h \
+  ../byterun/caml/osdeps.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
+meta.$(O): meta.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/s.h \
+  ../byterun/caml/mlvalues.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/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/prims.h ../byterun/caml/stacks.h
+dynlink.$(O): dynlink.c ../byterun/caml/config.h ../byterun/caml/m.h \
+  ../byterun/caml/s.h ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/dynlink.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/osdeps.h ../byterun/caml/prims.h \
+  ../byterun/caml/signals.h
+clambda_checks.$(O): clambda_checks.c ../byterun/caml/mlvalues.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/s.h \
+  ../byterun/caml/misc.h
+spacetime.$(O): spacetime.c ../byterun/caml/config.h ../byterun/caml/m.h \
+  ../byterun/caml/s.h ../byterun/caml/alloc.h ../byterun/caml/misc.h \
   ../byterun/caml/mlvalues.h ../byterun/caml/backtrace_prim.h \
   ../byterun/caml/backtrace.h ../byterun/caml/exec.h \
   ../byterun/caml/fail.h ../byterun/caml/gc.h ../byterun/caml/intext.h \
@@ -300,377 +339,372 @@ spacetime.o: spacetime.c ../byterun/caml/config.h \
   ../byterun/caml/osdeps.h ../byterun/caml/roots.h \
   ../byterun/caml/signals.h ../byterun/caml/stack.h \
   ../byterun/caml/sys.h ../byterun/caml/spacetime.h
-spacetime_offline.o: spacetime_offline.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 \
+spacetime_snapshot.$(O): spacetime_snapshot.c ../byterun/caml/alloc.h \
+  ../byterun/caml/misc.h ../byterun/caml/config.h ../byterun/caml/m.h \
+  ../byterun/caml/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/backtrace_prim.h ../byterun/caml/backtrace.h \
+  ../byterun/caml/exec.h ../byterun/caml/custom.h ../byterun/caml/fail.h \
+  ../byterun/caml/gc.h ../byterun/caml/gc_ctrl.h \
   ../byterun/caml/intext.h ../byterun/caml/io.h \
   ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
   ../byterun/caml/memory.h ../byterun/caml/minor_gc.h \
   ../byterun/caml/address_class.h ../byterun/caml/roots.h \
   ../byterun/caml/signals.h ../byterun/caml/stack.h \
-  ../byterun/caml/sys.h ../byterun/caml/spacetime.h ../config/s.h
-spacetime_snapshot.o: spacetime_snapshot.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_prim.h \
-  ../byterun/caml/backtrace.h ../byterun/caml/exec.h \
-  ../byterun/caml/custom.h ../byterun/caml/fail.h ../byterun/caml/gc.h \
-  ../byterun/caml/gc_ctrl.h ../byterun/caml/intext.h \
-  ../byterun/caml/io.h ../byterun/caml/major_gc.h \
-  ../byterun/caml/freelist.h ../byterun/caml/memory.h \
+  ../byterun/caml/sys.h ../byterun/caml/spacetime.h
+spacetime_offline.$(O): spacetime_offline.c ../byterun/caml/alloc.h \
+  ../byterun/caml/misc.h ../byterun/caml/config.h ../byterun/caml/m.h \
+  ../byterun/caml/s.h ../byterun/caml/mlvalues.h ../byterun/caml/fail.h \
+  ../byterun/caml/gc.h ../byterun/caml/intext.h ../byterun/caml/io.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/memory.h ../byterun/caml/minor_gc.h \
+  ../byterun/caml/address_class.h ../byterun/caml/roots.h \
+  ../byterun/caml/signals.h ../byterun/caml/stack.h \
+  ../byterun/caml/sys.h ../byterun/caml/spacetime.h
+afl.$(O): afl.c ../byterun/caml/config.h ../byterun/caml/m.h \
+  ../byterun/caml/s.h ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/osdeps.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
+bigarray.$(O): bigarray.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/s.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/bigarray.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
+startup_aux.p.$(O): startup_aux.c ../byterun/caml/backtrace.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/config.h \
+  ../byterun/caml/m.h ../byterun/caml/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/roots.h ../byterun/caml/signals.h \
-  ../byterun/caml/stack.h ../byterun/caml/sys.h \
-  ../byterun/caml/spacetime.h
-startup.o: startup.c ../byterun/caml/callback.h \
+  ../byterun/caml/callback.h ../byterun/caml/osdeps.h \
+  ../byterun/caml/startup_aux.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/m.h ../byterun/caml/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/major_gc.h ../byterun/caml/minor_gc.h \
   ../byterun/caml/address_class.h ../byterun/caml/osdeps.h \
   ../byterun/caml/printexc.h ../byterun/caml/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/osdeps.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
-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/mlvalues.h \
-  ../byterun/caml/debugger.h ../byterun/caml/fail.h \
-  ../byterun/caml/gc_ctrl.h ../byterun/caml/instruct.h \
-  ../byterun/caml/io.h ../byterun/caml/osdeps.h \
-  ../byterun/caml/signals.h ../byterun/caml/stacks.h \
+main.p.$(O): main.c ../byterun/caml/misc.h ../byterun/caml/config.h \
+  ../byterun/caml/m.h ../byterun/caml/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/sys.h ../byterun/caml/osdeps.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
+fail.p.$(O): fail.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/s.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/fail.h ../byterun/caml/io.h \
+  ../byterun/caml/gc.h ../byterun/caml/memory.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/signals.h \
+  ../byterun/caml/stack.h ../byterun/caml/roots.h \
+  ../byterun/caml/callback.h
+roots.p.$(O): roots.c ../byterun/caml/finalise.h ../byterun/caml/roots.h \
+  ../byterun/caml/misc.h ../byterun/caml/config.h ../byterun/caml/m.h \
+  ../byterun/caml/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/stack.h
+signals.p.$(O): signals.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/s.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 \
-  ../byterun/caml/sys.h ../byterun/caml/version.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/mlvalues.h ../byterun/caml/fail.h ../byterun/caml/io.h
-unix.o: unix.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/mlvalues.h \
+  ../byterun/caml/roots.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/m.h \
+  ../byterun/caml/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/sys.h ../byterun/caml/io.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/minor_gc.h \
-  ../byterun/caml/address_class.h ../byterun/caml/weak.h
-afl.p.o: afl.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/osdeps.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/minor_gc.h \
-  ../byterun/caml/address_class.h ../byterun/caml/stacks.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/signals_machdep.h signals_osdep.h \
+  ../byterun/caml/stack.h ../byterun/caml/spacetime.h \
+  ../byterun/caml/io.h
+misc.p.$(O): misc.c ../byterun/caml/config.h ../byterun/caml/m.h \
+  ../byterun/caml/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 ../byterun/caml/spacetime.h \
-  ../byterun/caml/io.h ../byterun/caml/stack.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/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/osdeps.h ../byterun/caml/version.h
+freelist.p.$(O): freelist.c ../byterun/caml/config.h ../byterun/caml/m.h \
+  ../byterun/caml/s.h ../byterun/caml/freelist.h ../byterun/caml/misc.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/gc.h \
+  ../byterun/caml/gc_ctrl.h ../byterun/caml/memory.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/minor_gc.h \
+  ../byterun/caml/address_class.h
+major_gc.p.$(O): major_gc.c ../byterun/caml/compact.h ../byterun/caml/config.h \
+  ../byterun/caml/m.h ../byterun/caml/s.h ../byterun/caml/misc.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/custom.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/backtrace.h ../byterun/caml/exec.h \
-  ../byterun/caml/backtrace_prim.h ../byterun/caml/fail.h
-backtrace_prim.p.o: backtrace_prim.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/backtrace_prim.h \
-  ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/gc_ctrl.h ../byterun/caml/signals.h \
+  ../byterun/caml/weak.h
+minor_gc.p.$(O): minor_gc.c ../byterun/caml/custom.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/config.h \
+  ../byterun/caml/m.h ../byterun/caml/s.h ../byterun/caml/misc.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/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/gc_ctrl.h ../byterun/caml/signals.h \
+  ../byterun/caml/weak.h
+memory.p.$(O): memory.c ../byterun/caml/address_class.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/s.h \
+  ../byterun/caml/misc.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/memory.h ../byterun/caml/minor_gc.h \
+  ../byterun/caml/signals.h
+alloc.p.$(O): alloc.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/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/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/stacks.h
+compare.p.$(O): compare.c ../byterun/caml/custom.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/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
-clambda_checks.p.o: clambda_checks.c ../byterun/caml/mlvalues.h \
-  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
-  ../byterun/caml/../../config/s.h ../byterun/caml/misc.h
-compact.p.o: compact.c ../byterun/caml/address_class.h \
-  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
-  ../byterun/caml/../../config/s.h ../byterun/caml/misc.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/gc_ctrl.h \
-  ../byterun/caml/weak.h ../byterun/caml/compact.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 \
+ints.p.$(O): ints.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/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
-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 \
+floats.p.$(O): floats.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/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/reverse.h ../byterun/caml/stacks.h
+str.p.$(O): str.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/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
-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/debugger.h ../byterun/caml/osdeps.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/mlvalues.h ../byterun/caml/dynlink.h \
-  ../byterun/caml/fail.h ../byterun/caml/memory.h ../byterun/caml/gc.h \
+array.p.$(O): array.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/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/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/signals.h ../byterun/caml/spacetime.h \
+  ../byterun/caml/io.h ../byterun/caml/stack.h
+io.p.$(O): io.c ../byterun/caml/config.h ../byterun/caml/m.h \
+  ../byterun/caml/s.h ../byterun/caml/alloc.h ../byterun/caml/misc.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/osdeps.h \
+  ../byterun/caml/signals.h ../byterun/caml/sys.h
+extern.p.$(O): extern.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/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/md5.h ../byterun/caml/memory.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/reverse.h
+intern.p.$(O): intern.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/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/md5.h \
   ../byterun/caml/memory.h ../byterun/caml/major_gc.h \
   ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \
   ../byterun/caml/address_class.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/major_gc.h \
-  ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \
-  ../byterun/caml/address_class.h ../byterun/caml/printexc.h \
-  ../byterun/caml/signals.h ../byterun/caml/stack.h \
-  ../byterun/caml/roots.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/compact.h \
-  ../byterun/caml/fail.h ../byterun/caml/finalise.h \
-  ../byterun/caml/roots.h ../byterun/caml/memory.h ../byterun/caml/gc.h \
+hash.p.$(O): hash.c ../byterun/caml/mlvalues.h ../byterun/caml/config.h \
+  ../byterun/caml/m.h ../byterun/caml/s.h ../byterun/caml/misc.h \
+  ../byterun/caml/custom.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/hash.h
+sys.p.$(O): sys.c ../byterun/caml/config.h ../byterun/caml/m.h \
+  ../byterun/caml/s.h ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/debugger.h \
+  ../byterun/caml/fail.h ../byterun/caml/gc_ctrl.h ../byterun/caml/io.h \
+  ../byterun/caml/osdeps.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/reverse.h ../byterun/caml/stacks.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/mlvalues.h ../byterun/caml/gc.h \
-  ../byterun/caml/gc_ctrl.h ../byterun/caml/memory.h \
-  ../byterun/caml/major_gc.h ../byterun/caml/minor_gc.h \
-  ../byterun/caml/address_class.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/backtrace.h ../byterun/caml/exec.h \
-  ../byterun/caml/compact.h ../byterun/caml/custom.h \
-  ../byterun/caml/fail.h ../byterun/caml/finalise.h \
-  ../byterun/caml/roots.h ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/signals.h ../byterun/caml/stacks.h \
+  ../byterun/caml/sys.h ../byterun/caml/version.h \
+  ../byterun/caml/callback.h ../byterun/caml/startup_aux.h
+parsing.p.$(O): parsing.c ../byterun/caml/config.h ../byterun/caml/m.h \
+  ../byterun/caml/s.h ../byterun/caml/mlvalues.h ../byterun/caml/misc.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/alloc.h
+gc_ctrl.p.$(O): gc_ctrl.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/s.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/backtrace.h \
+  ../byterun/caml/exec.h ../byterun/caml/compact.h \
+  ../byterun/caml/custom.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/gc_ctrl.h ../byterun/caml/signals.h \
   ../byterun/caml/stack.h ../byterun/caml/startup_aux.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 \
+terminfo.p.$(O): terminfo.c ../byterun/caml/config.h ../byterun/caml/m.h \
+  ../byterun/caml/s.h ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/fail.h ../byterun/caml/io.h
+md5.p.$(O): md5.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/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/reverse.h
+obj.p.$(O): obj.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/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/minor_gc.h ../byterun/caml/address_class.h \
-  ../byterun/caml/roots.h ../byterun/caml/globroots.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/prims.h ../byterun/caml/spacetime.h \
+  ../byterun/caml/io.h ../byterun/caml/stack.h
+lexing.p.$(O): lexing.c ../byterun/caml/fail.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/s.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 \
-  ../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/md5.h ../byterun/caml/memory.h \
-  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
-  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.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/minor_gc.h ../byterun/caml/address_class.h
+unix.p.$(O): unix.c ../byterun/caml/config.h ../byterun/caml/m.h \
+  ../byterun/caml/s.h ../byterun/caml/fail.h ../byterun/caml/misc.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/sys.h ../byterun/caml/io.h \
+  ../byterun/caml/alloc.h
+printexc.p.$(O): printexc.c ../byterun/caml/backtrace.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/config.h \
+  ../byterun/caml/m.h ../byterun/caml/s.h ../byterun/caml/misc.h \
+  ../byterun/caml/exec.h ../byterun/caml/callback.h \
+  ../byterun/caml/debugger.h ../byterun/caml/fail.h \
+  ../byterun/caml/printexc.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
-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/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/osdeps.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/stacks.h ../byterun/caml/memory.h ../byterun/caml/gc.h \
+callback.p.$(O): callback.c ../byterun/caml/callback.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/config.h \
+  ../byterun/caml/m.h ../byterun/caml/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
-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/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 \
+weak.p.$(O): weak.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/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/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/weak.h
+compact.p.$(O): compact.c ../byterun/caml/address_class.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/s.h \
   ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \
-  ../byterun/caml/custom.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/gc_ctrl.h ../byterun/caml/signals.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/minor_gc.h ../byterun/caml/gc_ctrl.h \
+  ../byterun/caml/weak.h ../byterun/caml/compact.h
+finalise.p.$(O): finalise.c ../byterun/caml/callback.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/config.h \
+  ../byterun/caml/m.h ../byterun/caml/s.h ../byterun/caml/misc.h \
+  ../byterun/caml/compact.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/reverse.h
-memory.p.o: memory.c ../byterun/caml/address_class.h \
-  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
-  ../byterun/caml/../../config/s.h ../byterun/caml/misc.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/memory.h ../byterun/caml/minor_gc.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/fail.h ../byterun/caml/fix_code.h \
-  ../byterun/caml/interp.h ../byterun/caml/intext.h ../byterun/caml/io.h \
+custom.p.$(O): custom.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/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/memory.h ../byterun/caml/gc.h \
-  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
-  ../byterun/caml/prims.h ../byterun/caml/stacks.h
-minor_gc.p.o: minor_gc.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/finalise.h ../byterun/caml/roots.h \
-  ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h
+globroots.p.$(O): globroots.c ../byterun/caml/memory.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/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/gc_ctrl.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/memory.h ../byterun/caml/gc.h \
-  ../byterun/caml/mlvalues.h ../byterun/caml/major_gc.h \
+  ../byterun/caml/roots.h ../byterun/caml/globroots.h
+backtrace_prim.p.$(O): backtrace_prim.c ../byterun/caml/alloc.h \
+  ../byterun/caml/misc.h ../byterun/caml/config.h ../byterun/caml/m.h \
+  ../byterun/caml/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/backtrace.h ../byterun/caml/exec.h \
+  ../byterun/caml/backtrace_prim.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/version.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/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/address_class.h ../byterun/caml/stack.h
+backtrace.p.$(O): backtrace.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/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/backtrace.h \
+  ../byterun/caml/exec.h ../byterun/caml/backtrace_prim.h \
+  ../byterun/caml/fail.h
+natdynlink.p.$(O): natdynlink.c ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/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/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 \
+  ../byterun/caml/hooks.h
+debugger.p.$(O): debugger.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/s.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/debugger.h \
+  ../byterun/caml/osdeps.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/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 ../byterun/caml/hooks.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/minor_gc.h ../byterun/caml/address_class.h
+meta.p.$(O): meta.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/s.h \
+  ../byterun/caml/mlvalues.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/minor_gc.h \
-  ../byterun/caml/address_class.h ../byterun/caml/prims.h \
-  ../byterun/caml/spacetime.h ../byterun/caml/io.h \
-  ../byterun/caml/stack.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/misc.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/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/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/stack.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/fail.h \
-  ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/prims.h ../byterun/caml/stacks.h
+dynlink.p.$(O): dynlink.c ../byterun/caml/config.h ../byterun/caml/m.h \
+  ../byterun/caml/s.h ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/dynlink.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/roots.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 ../byterun/caml/stack.h ../byterun/caml/spacetime.h \
-  ../byterun/caml/io.h
-spacetime.p.o: spacetime.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/osdeps.h ../byterun/caml/prims.h \
+  ../byterun/caml/signals.h
+clambda_checks.p.$(O): clambda_checks.c ../byterun/caml/mlvalues.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/s.h \
+  ../byterun/caml/misc.h
+spacetime.p.$(O): spacetime.c ../byterun/caml/config.h ../byterun/caml/m.h \
+  ../byterun/caml/s.h ../byterun/caml/alloc.h ../byterun/caml/misc.h \
   ../byterun/caml/mlvalues.h ../byterun/caml/backtrace_prim.h \
   ../byterun/caml/backtrace.h ../byterun/caml/exec.h \
   ../byterun/caml/fail.h ../byterun/caml/gc.h ../byterun/caml/intext.h \
@@ -680,377 +714,372 @@ spacetime.p.o: spacetime.c ../byterun/caml/config.h \
   ../byterun/caml/osdeps.h ../byterun/caml/roots.h \
   ../byterun/caml/signals.h ../byterun/caml/stack.h \
   ../byterun/caml/sys.h ../byterun/caml/spacetime.h
-spacetime_offline.p.o: spacetime_offline.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 \
+spacetime_snapshot.p.$(O): spacetime_snapshot.c ../byterun/caml/alloc.h \
+  ../byterun/caml/misc.h ../byterun/caml/config.h ../byterun/caml/m.h \
+  ../byterun/caml/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/backtrace_prim.h ../byterun/caml/backtrace.h \
+  ../byterun/caml/exec.h ../byterun/caml/custom.h ../byterun/caml/fail.h \
+  ../byterun/caml/gc.h ../byterun/caml/gc_ctrl.h \
   ../byterun/caml/intext.h ../byterun/caml/io.h \
   ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
   ../byterun/caml/memory.h ../byterun/caml/minor_gc.h \
   ../byterun/caml/address_class.h ../byterun/caml/roots.h \
   ../byterun/caml/signals.h ../byterun/caml/stack.h \
-  ../byterun/caml/sys.h ../byterun/caml/spacetime.h ../config/s.h
-spacetime_snapshot.p.o: spacetime_snapshot.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_prim.h \
-  ../byterun/caml/backtrace.h ../byterun/caml/exec.h \
-  ../byterun/caml/custom.h ../byterun/caml/fail.h ../byterun/caml/gc.h \
-  ../byterun/caml/gc_ctrl.h ../byterun/caml/intext.h \
-  ../byterun/caml/io.h ../byterun/caml/major_gc.h \
-  ../byterun/caml/freelist.h ../byterun/caml/memory.h \
+  ../byterun/caml/sys.h ../byterun/caml/spacetime.h
+spacetime_offline.p.$(O): spacetime_offline.c ../byterun/caml/alloc.h \
+  ../byterun/caml/misc.h ../byterun/caml/config.h ../byterun/caml/m.h \
+  ../byterun/caml/s.h ../byterun/caml/mlvalues.h ../byterun/caml/fail.h \
+  ../byterun/caml/gc.h ../byterun/caml/intext.h ../byterun/caml/io.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/memory.h ../byterun/caml/minor_gc.h \
+  ../byterun/caml/address_class.h ../byterun/caml/roots.h \
+  ../byterun/caml/signals.h ../byterun/caml/stack.h \
+  ../byterun/caml/sys.h ../byterun/caml/spacetime.h
+afl.p.$(O): afl.c ../byterun/caml/config.h ../byterun/caml/m.h \
+  ../byterun/caml/s.h ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/osdeps.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
+bigarray.p.$(O): bigarray.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/s.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/bigarray.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
+startup_aux.d.$(O): startup_aux.c ../byterun/caml/backtrace.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/config.h \
+  ../byterun/caml/m.h ../byterun/caml/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/roots.h ../byterun/caml/signals.h \
-  ../byterun/caml/stack.h ../byterun/caml/sys.h \
-  ../byterun/caml/spacetime.h
-startup.p.o: startup.c ../byterun/caml/callback.h \
+  ../byterun/caml/callback.h ../byterun/caml/osdeps.h \
+  ../byterun/caml/startup_aux.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/m.h ../byterun/caml/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/major_gc.h ../byterun/caml/minor_gc.h \
   ../byterun/caml/address_class.h ../byterun/caml/osdeps.h \
   ../byterun/caml/printexc.h ../byterun/caml/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/osdeps.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
-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/mlvalues.h \
-  ../byterun/caml/debugger.h ../byterun/caml/fail.h \
-  ../byterun/caml/gc_ctrl.h ../byterun/caml/instruct.h \
-  ../byterun/caml/io.h ../byterun/caml/osdeps.h \
-  ../byterun/caml/signals.h ../byterun/caml/stacks.h \
+main.d.$(O): main.c ../byterun/caml/misc.h ../byterun/caml/config.h \
+  ../byterun/caml/m.h ../byterun/caml/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/sys.h ../byterun/caml/osdeps.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
+fail.d.$(O): fail.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/s.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/fail.h ../byterun/caml/io.h \
+  ../byterun/caml/gc.h ../byterun/caml/memory.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/signals.h \
+  ../byterun/caml/stack.h ../byterun/caml/roots.h \
+  ../byterun/caml/callback.h
+roots.d.$(O): roots.c ../byterun/caml/finalise.h ../byterun/caml/roots.h \
+  ../byterun/caml/misc.h ../byterun/caml/config.h ../byterun/caml/m.h \
+  ../byterun/caml/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/stack.h
+signals.d.$(O): signals.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/s.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 \
-  ../byterun/caml/sys.h ../byterun/caml/version.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/mlvalues.h ../byterun/caml/fail.h ../byterun/caml/io.h
-unix.p.o: unix.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/mlvalues.h \
+  ../byterun/caml/roots.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/m.h \
+  ../byterun/caml/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/sys.h ../byterun/caml/io.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/minor_gc.h \
-  ../byterun/caml/address_class.h ../byterun/caml/weak.h
-afl.d.o: afl.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/osdeps.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/minor_gc.h \
-  ../byterun/caml/address_class.h ../byterun/caml/stacks.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/signals.h ../byterun/caml/spacetime.h \
-  ../byterun/caml/io.h ../byterun/caml/stack.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/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/signals_machdep.h signals_osdep.h \
+  ../byterun/caml/stack.h ../byterun/caml/spacetime.h \
+  ../byterun/caml/io.h
+misc.d.$(O): misc.c ../byterun/caml/config.h ../byterun/caml/m.h \
+  ../byterun/caml/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/backtrace.h ../byterun/caml/exec.h \
-  ../byterun/caml/backtrace_prim.h ../byterun/caml/fail.h
-backtrace_prim.d.o: backtrace_prim.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/backtrace_prim.h \
-  ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/osdeps.h ../byterun/caml/version.h
+freelist.d.$(O): freelist.c ../byterun/caml/config.h ../byterun/caml/m.h \
+  ../byterun/caml/s.h ../byterun/caml/freelist.h ../byterun/caml/misc.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/gc.h \
+  ../byterun/caml/gc_ctrl.h ../byterun/caml/memory.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/minor_gc.h \
+  ../byterun/caml/address_class.h
+major_gc.d.$(O): major_gc.c ../byterun/caml/compact.h ../byterun/caml/config.h \
+  ../byterun/caml/m.h ../byterun/caml/s.h ../byterun/caml/misc.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/custom.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/stack.h
-callback.d.o: callback.c ../byterun/caml/callback.h \
+  ../byterun/caml/gc_ctrl.h ../byterun/caml/signals.h \
+  ../byterun/caml/weak.h
+minor_gc.d.$(O): minor_gc.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
-clambda_checks.d.o: clambda_checks.c ../byterun/caml/mlvalues.h \
-  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
-  ../byterun/caml/../../config/s.h ../byterun/caml/misc.h
-compact.d.o: compact.c ../byterun/caml/address_class.h \
-  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
-  ../byterun/caml/../../config/s.h ../byterun/caml/misc.h \
-  ../byterun/caml/mlvalues.h ../byterun/caml/finalise.h \
+  ../byterun/caml/m.h ../byterun/caml/s.h ../byterun/caml/misc.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/gc_ctrl.h \
-  ../byterun/caml/weak.h ../byterun/caml/compact.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/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/gc_ctrl.h ../byterun/caml/signals.h \
+  ../byterun/caml/weak.h
+memory.d.$(O): memory.c ../byterun/caml/address_class.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/s.h \
+  ../byterun/caml/misc.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/memory.h ../byterun/caml/minor_gc.h \
+  ../byterun/caml/signals.h
+alloc.d.$(O): alloc.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/s.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/custom.h \
   ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
-  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.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
-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/debugger.h ../byterun/caml/osdeps.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/mlvalues.h ../byterun/caml/dynlink.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/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/md5.h \
-  ../byterun/caml/memory.h ../byterun/caml/major_gc.h \
-  ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \
-  ../byterun/caml/address_class.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/major_gc.h \
+  ../byterun/caml/stacks.h
+compare.d.$(O): compare.c ../byterun/caml/custom.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/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/printexc.h \
-  ../byterun/caml/signals.h ../byterun/caml/stack.h \
-  ../byterun/caml/roots.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/compact.h \
-  ../byterun/caml/fail.h ../byterun/caml/finalise.h \
-  ../byterun/caml/roots.h ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/address_class.h
+ints.d.$(O): ints.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/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/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/minor_gc.h ../byterun/caml/address_class.h
+floats.d.$(O): floats.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/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/reverse.h ../byterun/caml/stacks.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/mlvalues.h ../byterun/caml/gc.h \
-  ../byterun/caml/gc_ctrl.h ../byterun/caml/memory.h \
-  ../byterun/caml/major_gc.h ../byterun/caml/minor_gc.h \
-  ../byterun/caml/address_class.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/backtrace.h ../byterun/caml/exec.h \
-  ../byterun/caml/compact.h ../byterun/caml/custom.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/gc_ctrl.h ../byterun/caml/signals.h \
-  ../byterun/caml/stack.h ../byterun/caml/startup_aux.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 \
+str.d.$(O): str.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/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/roots.h ../byterun/caml/globroots.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/minor_gc.h ../byterun/caml/address_class.h
+array.d.$(O): array.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/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/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/signals.h ../byterun/caml/spacetime.h \
+  ../byterun/caml/io.h ../byterun/caml/stack.h
+io.d.$(O): io.c ../byterun/caml/config.h ../byterun/caml/m.h \
+  ../byterun/caml/s.h ../byterun/caml/alloc.h ../byterun/caml/misc.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/osdeps.h \
+  ../byterun/caml/signals.h ../byterun/caml/sys.h
+extern.d.$(O): extern.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/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/md5.h ../byterun/caml/memory.h \
   ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
   ../byterun/caml/minor_gc.h ../byterun/caml/address_class.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 \
+intern.d.$(O): intern.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/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/md5.h \
+  ../byterun/caml/memory.h ../byterun/caml/major_gc.h \
   ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \
-  ../byterun/caml/address_class.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/mlvalues.h \
-  ../byterun/caml/custom.h ../byterun/caml/fail.h ../byterun/caml/io.h \
-  ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/address_class.h ../byterun/caml/reverse.h
+hash.d.$(O): hash.c ../byterun/caml/mlvalues.h ../byterun/caml/config.h \
+  ../byterun/caml/m.h ../byterun/caml/s.h ../byterun/caml/misc.h \
+  ../byterun/caml/custom.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/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/stacks.h ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/hash.h
+sys.d.$(O): sys.c ../byterun/caml/config.h ../byterun/caml/m.h \
+  ../byterun/caml/s.h ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/debugger.h \
+  ../byterun/caml/fail.h ../byterun/caml/gc_ctrl.h ../byterun/caml/io.h \
+  ../byterun/caml/osdeps.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/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/mlvalues.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/signals.h ../byterun/caml/stacks.h \
+  ../byterun/caml/sys.h ../byterun/caml/version.h \
+  ../byterun/caml/callback.h ../byterun/caml/startup_aux.h
+parsing.d.$(O): parsing.c ../byterun/caml/config.h ../byterun/caml/m.h \
+  ../byterun/caml/s.h ../byterun/caml/mlvalues.h ../byterun/caml/misc.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/alloc.h
+gc_ctrl.d.$(O): gc_ctrl.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/s.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/backtrace.h \
+  ../byterun/caml/exec.h ../byterun/caml/compact.h \
   ../byterun/caml/custom.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/gc_ctrl.h ../byterun/caml/signals.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/stack.h ../byterun/caml/startup_aux.h
+terminfo.d.$(O): terminfo.c ../byterun/caml/config.h ../byterun/caml/m.h \
+  ../byterun/caml/s.h ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/fail.h ../byterun/caml/io.h
+md5.d.$(O): md5.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/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/reverse.h
+obj.d.$(O): obj.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/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/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/prims.h ../byterun/caml/spacetime.h \
+  ../byterun/caml/io.h ../byterun/caml/stack.h
+lexing.d.$(O): lexing.c ../byterun/caml/fail.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/s.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 \
-  ../byterun/caml/reverse.h
-memory.d.o: memory.c ../byterun/caml/address_class.h \
-  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
-  ../byterun/caml/../../config/s.h ../byterun/caml/misc.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h
+unix.d.$(O): unix.c ../byterun/caml/config.h ../byterun/caml/m.h \
+  ../byterun/caml/s.h ../byterun/caml/fail.h ../byterun/caml/misc.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/sys.h ../byterun/caml/io.h \
+  ../byterun/caml/alloc.h
+printexc.d.$(O): printexc.c ../byterun/caml/backtrace.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/config.h \
+  ../byterun/caml/m.h ../byterun/caml/s.h ../byterun/caml/misc.h \
+  ../byterun/caml/exec.h ../byterun/caml/callback.h \
+  ../byterun/caml/debugger.h ../byterun/caml/fail.h \
+  ../byterun/caml/printexc.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
+callback.d.$(O): callback.c ../byterun/caml/callback.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/config.h \
+  ../byterun/caml/m.h ../byterun/caml/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
+weak.d.$(O): weak.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/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/memory.h ../byterun/caml/minor_gc.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/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/minor_gc.h ../byterun/caml/address_class.h \
-  ../byterun/caml/prims.h ../byterun/caml/stacks.h
-minor_gc.d.o: minor_gc.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/weak.h
+compact.d.$(O): compact.c ../byterun/caml/address_class.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/s.h \
+  ../byterun/caml/misc.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_ctrl.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/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/osdeps.h \
-  ../byterun/caml/version.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/minor_gc.h ../byterun/caml/gc_ctrl.h \
+  ../byterun/caml/weak.h ../byterun/caml/compact.h
+finalise.d.$(O): finalise.c ../byterun/caml/callback.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/config.h \
+  ../byterun/caml/m.h ../byterun/caml/s.h ../byterun/caml/misc.h \
+  ../byterun/caml/compact.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/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 ../byterun/caml/hooks.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/signals.h
+custom.d.$(O): custom.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/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/memory.h ../byterun/caml/minor_gc.h \
-  ../byterun/caml/address_class.h ../byterun/caml/prims.h \
-  ../byterun/caml/spacetime.h ../byterun/caml/io.h \
-  ../byterun/caml/stack.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/misc.h \
-  ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h
+globroots.d.$(O): globroots.c ../byterun/caml/memory.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/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/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/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/roots.h ../byterun/caml/globroots.h
+backtrace_prim.d.$(O): backtrace_prim.c ../byterun/caml/alloc.h \
+  ../byterun/caml/misc.h ../byterun/caml/config.h ../byterun/caml/m.h \
+  ../byterun/caml/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/backtrace.h ../byterun/caml/exec.h \
+  ../byterun/caml/backtrace_prim.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/globroots.h \
-  ../byterun/caml/stack.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/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/roots.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/address_class.h ../byterun/caml/stack.h
+backtrace.d.$(O): backtrace.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/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 ../byterun/caml/stack.h ../byterun/caml/spacetime.h \
-  ../byterun/caml/io.h
-spacetime.d.o: spacetime.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/address_class.h ../byterun/caml/backtrace.h \
+  ../byterun/caml/exec.h ../byterun/caml/backtrace_prim.h \
+  ../byterun/caml/fail.h
+natdynlink.d.$(O): natdynlink.c ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/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/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 \
+  ../byterun/caml/hooks.h
+debugger.d.$(O): debugger.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/s.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/debugger.h \
+  ../byterun/caml/osdeps.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
+meta.d.$(O): meta.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/s.h \
+  ../byterun/caml/mlvalues.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/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/prims.h ../byterun/caml/stacks.h
+dynlink.d.$(O): dynlink.c ../byterun/caml/config.h ../byterun/caml/m.h \
+  ../byterun/caml/s.h ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/dynlink.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/osdeps.h ../byterun/caml/prims.h \
+  ../byterun/caml/signals.h
+clambda_checks.d.$(O): clambda_checks.c ../byterun/caml/mlvalues.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/s.h \
+  ../byterun/caml/misc.h
+spacetime.d.$(O): spacetime.c ../byterun/caml/config.h ../byterun/caml/m.h \
+  ../byterun/caml/s.h ../byterun/caml/alloc.h ../byterun/caml/misc.h \
   ../byterun/caml/mlvalues.h ../byterun/caml/backtrace_prim.h \
   ../byterun/caml/backtrace.h ../byterun/caml/exec.h \
   ../byterun/caml/fail.h ../byterun/caml/gc.h ../byterun/caml/intext.h \
@@ -1060,377 +1089,372 @@ spacetime.d.o: spacetime.c ../byterun/caml/config.h \
   ../byterun/caml/osdeps.h ../byterun/caml/roots.h \
   ../byterun/caml/signals.h ../byterun/caml/stack.h \
   ../byterun/caml/sys.h ../byterun/caml/spacetime.h
-spacetime_offline.d.o: spacetime_offline.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 \
+spacetime_snapshot.d.$(O): spacetime_snapshot.c ../byterun/caml/alloc.h \
+  ../byterun/caml/misc.h ../byterun/caml/config.h ../byterun/caml/m.h \
+  ../byterun/caml/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/backtrace_prim.h ../byterun/caml/backtrace.h \
+  ../byterun/caml/exec.h ../byterun/caml/custom.h ../byterun/caml/fail.h \
+  ../byterun/caml/gc.h ../byterun/caml/gc_ctrl.h \
   ../byterun/caml/intext.h ../byterun/caml/io.h \
   ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
   ../byterun/caml/memory.h ../byterun/caml/minor_gc.h \
   ../byterun/caml/address_class.h ../byterun/caml/roots.h \
   ../byterun/caml/signals.h ../byterun/caml/stack.h \
-  ../byterun/caml/sys.h ../byterun/caml/spacetime.h ../config/s.h
-spacetime_snapshot.d.o: spacetime_snapshot.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_prim.h \
-  ../byterun/caml/backtrace.h ../byterun/caml/exec.h \
-  ../byterun/caml/custom.h ../byterun/caml/fail.h ../byterun/caml/gc.h \
-  ../byterun/caml/gc_ctrl.h ../byterun/caml/intext.h \
-  ../byterun/caml/io.h ../byterun/caml/major_gc.h \
-  ../byterun/caml/freelist.h ../byterun/caml/memory.h \
+  ../byterun/caml/sys.h ../byterun/caml/spacetime.h
+spacetime_offline.d.$(O): spacetime_offline.c ../byterun/caml/alloc.h \
+  ../byterun/caml/misc.h ../byterun/caml/config.h ../byterun/caml/m.h \
+  ../byterun/caml/s.h ../byterun/caml/mlvalues.h ../byterun/caml/fail.h \
+  ../byterun/caml/gc.h ../byterun/caml/intext.h ../byterun/caml/io.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
+  ../byterun/caml/memory.h ../byterun/caml/minor_gc.h \
+  ../byterun/caml/address_class.h ../byterun/caml/roots.h \
+  ../byterun/caml/signals.h ../byterun/caml/stack.h \
+  ../byterun/caml/sys.h ../byterun/caml/spacetime.h
+afl.d.$(O): afl.c ../byterun/caml/config.h ../byterun/caml/m.h \
+  ../byterun/caml/s.h ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/osdeps.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
+bigarray.d.$(O): bigarray.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/s.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/bigarray.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
+startup_aux.i.$(O): startup_aux.c ../byterun/caml/backtrace.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/config.h \
+  ../byterun/caml/m.h ../byterun/caml/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/roots.h ../byterun/caml/signals.h \
-  ../byterun/caml/stack.h ../byterun/caml/sys.h \
-  ../byterun/caml/spacetime.h
-startup.d.o: startup.c ../byterun/caml/callback.h \
+  ../byterun/caml/callback.h ../byterun/caml/osdeps.h \
+  ../byterun/caml/startup_aux.h
+startup.i.$(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/m.h ../byterun/caml/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/major_gc.h ../byterun/caml/minor_gc.h \
   ../byterun/caml/address_class.h ../byterun/caml/osdeps.h \
   ../byterun/caml/printexc.h ../byterun/caml/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/osdeps.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
-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/mlvalues.h \
-  ../byterun/caml/debugger.h ../byterun/caml/fail.h \
-  ../byterun/caml/gc_ctrl.h ../byterun/caml/instruct.h \
-  ../byterun/caml/io.h ../byterun/caml/osdeps.h \
-  ../byterun/caml/signals.h ../byterun/caml/stacks.h \
+main.i.$(O): main.c ../byterun/caml/misc.h ../byterun/caml/config.h \
+  ../byterun/caml/m.h ../byterun/caml/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/sys.h ../byterun/caml/osdeps.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/version.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/mlvalues.h ../byterun/caml/fail.h ../byterun/caml/io.h
-unix.d.o: unix.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/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/sys.h ../byterun/caml/io.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/minor_gc.h \
-  ../byterun/caml/address_class.h ../byterun/caml/weak.h
-afl.i.o: afl.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/osdeps.h
-alloc.i.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/minor_gc.h \
-  ../byterun/caml/address_class.h ../byterun/caml/stacks.h
-array.i.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/minor_gc.h ../byterun/caml/address_class.h
+fail.i.$(O): fail.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/s.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/fail.h ../byterun/caml/io.h \
+  ../byterun/caml/gc.h ../byterun/caml/memory.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/signals.h \
+  ../byterun/caml/stack.h ../byterun/caml/roots.h \
+  ../byterun/caml/callback.h
+roots.i.$(O): roots.c ../byterun/caml/finalise.h ../byterun/caml/roots.h \
+  ../byterun/caml/misc.h ../byterun/caml/config.h ../byterun/caml/m.h \
+  ../byterun/caml/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/stack.h
+signals.i.$(O): signals.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/s.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 \
-  ../byterun/caml/signals.h ../byterun/caml/spacetime.h \
-  ../byterun/caml/io.h ../byterun/caml/stack.h
-backtrace.i.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/roots.h ../byterun/caml/signals.h \
+  ../byterun/caml/signals_machdep.h ../byterun/caml/sys.h
+signals_asm.i.$(O): signals_asm.c ../byterun/caml/fail.h \
+  ../byterun/caml/misc.h ../byterun/caml/config.h ../byterun/caml/m.h \
+  ../byterun/caml/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/backtrace.h ../byterun/caml/exec.h \
-  ../byterun/caml/backtrace_prim.h ../byterun/caml/fail.h
-backtrace_prim.i.o: backtrace_prim.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/backtrace_prim.h \
-  ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/osdeps.h ../byterun/caml/signals.h \
+  ../byterun/caml/signals_machdep.h signals_osdep.h \
+  ../byterun/caml/stack.h ../byterun/caml/spacetime.h \
+  ../byterun/caml/io.h
+misc.i.$(O): misc.c ../byterun/caml/config.h ../byterun/caml/m.h \
+  ../byterun/caml/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/stack.h
-callback.i.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/osdeps.h ../byterun/caml/version.h
+freelist.i.$(O): freelist.c ../byterun/caml/config.h ../byterun/caml/m.h \
+  ../byterun/caml/s.h ../byterun/caml/freelist.h ../byterun/caml/misc.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/gc.h \
+  ../byterun/caml/gc_ctrl.h ../byterun/caml/memory.h \
+  ../byterun/caml/major_gc.h ../byterun/caml/minor_gc.h \
   ../byterun/caml/address_class.h
-clambda_checks.i.o: clambda_checks.c ../byterun/caml/mlvalues.h \
-  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
-  ../byterun/caml/../../config/s.h ../byterun/caml/misc.h
-compact.i.o: compact.c ../byterun/caml/address_class.h \
-  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
-  ../byterun/caml/../../config/s.h ../byterun/caml/misc.h \
-  ../byterun/caml/mlvalues.h ../byterun/caml/finalise.h \
+major_gc.i.$(O): major_gc.c ../byterun/caml/compact.h ../byterun/caml/config.h \
+  ../byterun/caml/m.h ../byterun/caml/s.h ../byterun/caml/misc.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/custom.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/gc_ctrl.h \
-  ../byterun/caml/weak.h ../byterun/caml/compact.h
-compare.i.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
-custom.i.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
-debugger.i.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/debugger.h ../byterun/caml/osdeps.h
-dynlink.i.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/mlvalues.h ../byterun/caml/dynlink.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/osdeps.h ../byterun/caml/prims.h \
-  ../byterun/caml/signals.h
-extern.i.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/md5.h \
-  ../byterun/caml/memory.h ../byterun/caml/major_gc.h \
-  ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \
-  ../byterun/caml/address_class.h ../byterun/caml/reverse.h
-fail.i.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/major_gc.h \
-  ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \
-  ../byterun/caml/address_class.h ../byterun/caml/printexc.h \
-  ../byterun/caml/signals.h ../byterun/caml/stack.h \
-  ../byterun/caml/roots.h ../byterun/caml/callback.h
-finalise.i.o: finalise.c ../byterun/caml/callback.h \
+  ../byterun/caml/gc_ctrl.h ../byterun/caml/signals.h \
+  ../byterun/caml/weak.h
+minor_gc.i.$(O): minor_gc.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/compact.h \
+  ../byterun/caml/m.h ../byterun/caml/s.h ../byterun/caml/misc.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/gc_ctrl.h ../byterun/caml/signals.h \
+  ../byterun/caml/weak.h
+memory.i.$(O): memory.c ../byterun/caml/address_class.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/s.h \
+  ../byterun/caml/misc.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/memory.h ../byterun/caml/minor_gc.h \
   ../byterun/caml/signals.h
-floats.i.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 \
+alloc.i.$(O): alloc.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/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/minor_gc.h ../byterun/caml/address_class.h \
-  ../byterun/caml/reverse.h ../byterun/caml/stacks.h
-freelist.i.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/mlvalues.h ../byterun/caml/gc.h \
-  ../byterun/caml/gc_ctrl.h ../byterun/caml/memory.h \
-  ../byterun/caml/major_gc.h ../byterun/caml/minor_gc.h \
+  ../byterun/caml/stacks.h
+compare.i.$(O): compare.c ../byterun/caml/custom.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/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
-gc_ctrl.i.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/backtrace.h ../byterun/caml/exec.h \
-  ../byterun/caml/compact.h ../byterun/caml/custom.h \
-  ../byterun/caml/fail.h ../byterun/caml/finalise.h \
-  ../byterun/caml/roots.h ../byterun/caml/memory.h ../byterun/caml/gc.h \
+ints.i.$(O): ints.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/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/gc_ctrl.h ../byterun/caml/signals.h \
-  ../byterun/caml/stack.h ../byterun/caml/startup_aux.h
-globroots.i.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/minor_gc.h ../byterun/caml/address_class.h
+floats.i.$(O): floats.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/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/roots.h ../byterun/caml/globroots.h
-hash.i.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/reverse.h ../byterun/caml/stacks.h
+str.i.$(O): str.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/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
+array.i.$(O): array.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/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/hash.h
-intern.i.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/signals.h ../byterun/caml/spacetime.h \
+  ../byterun/caml/io.h ../byterun/caml/stack.h
+io.i.$(O): io.c ../byterun/caml/config.h ../byterun/caml/m.h \
+  ../byterun/caml/s.h ../byterun/caml/alloc.h ../byterun/caml/misc.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/osdeps.h \
+  ../byterun/caml/signals.h ../byterun/caml/sys.h
+extern.i.$(O): extern.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/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/md5.h ../byterun/caml/memory.h \
   ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
   ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
   ../byterun/caml/reverse.h
-ints.i.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 \
+intern.i.$(O): intern.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/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/md5.h \
+  ../byterun/caml/memory.h ../byterun/caml/major_gc.h \
   ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \
-  ../byterun/caml/address_class.h
-io.i.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/mlvalues.h \
-  ../byterun/caml/custom.h ../byterun/caml/fail.h ../byterun/caml/io.h \
-  ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/address_class.h ../byterun/caml/reverse.h
+hash.i.$(O): hash.c ../byterun/caml/mlvalues.h ../byterun/caml/config.h \
+  ../byterun/caml/m.h ../byterun/caml/s.h ../byterun/caml/misc.h \
+  ../byterun/caml/custom.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/sys.h
-lexing.i.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/stacks.h ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/hash.h
+sys.i.$(O): sys.c ../byterun/caml/config.h ../byterun/caml/m.h \
+  ../byterun/caml/s.h ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/debugger.h \
+  ../byterun/caml/fail.h ../byterun/caml/gc_ctrl.h ../byterun/caml/io.h \
+  ../byterun/caml/osdeps.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.i.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/sys.h
-major_gc.i.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/mlvalues.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/signals.h ../byterun/caml/stacks.h \
+  ../byterun/caml/sys.h ../byterun/caml/version.h \
+  ../byterun/caml/callback.h ../byterun/caml/startup_aux.h
+parsing.i.$(O): parsing.c ../byterun/caml/config.h ../byterun/caml/m.h \
+  ../byterun/caml/s.h ../byterun/caml/mlvalues.h ../byterun/caml/misc.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/alloc.h
+gc_ctrl.i.$(O): gc_ctrl.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/s.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/backtrace.h \
+  ../byterun/caml/exec.h ../byterun/caml/compact.h \
   ../byterun/caml/custom.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/gc_ctrl.h ../byterun/caml/signals.h \
-  ../byterun/caml/weak.h
-md5.i.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/stack.h ../byterun/caml/startup_aux.h
+terminfo.i.$(O): terminfo.c ../byterun/caml/config.h ../byterun/caml/m.h \
+  ../byterun/caml/s.h ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/fail.h ../byterun/caml/io.h
+md5.i.$(O): md5.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/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/reverse.h
+obj.i.$(O): obj.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/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/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/prims.h ../byterun/caml/spacetime.h \
+  ../byterun/caml/io.h ../byterun/caml/stack.h
+lexing.i.$(O): lexing.c ../byterun/caml/fail.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/s.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 \
-  ../byterun/caml/reverse.h
-memory.i.o: memory.c ../byterun/caml/address_class.h \
-  ../byterun/caml/config.h ../byterun/caml/../../config/m.h \
-  ../byterun/caml/../../config/s.h ../byterun/caml/misc.h \
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h
+unix.i.$(O): unix.c ../byterun/caml/config.h ../byterun/caml/m.h \
+  ../byterun/caml/s.h ../byterun/caml/fail.h ../byterun/caml/misc.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/sys.h ../byterun/caml/io.h \
+  ../byterun/caml/alloc.h
+printexc.i.$(O): printexc.c ../byterun/caml/backtrace.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/config.h \
+  ../byterun/caml/m.h ../byterun/caml/s.h ../byterun/caml/misc.h \
+  ../byterun/caml/exec.h ../byterun/caml/callback.h \
+  ../byterun/caml/debugger.h ../byterun/caml/fail.h \
+  ../byterun/caml/printexc.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
+callback.i.$(O): callback.c ../byterun/caml/callback.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/config.h \
+  ../byterun/caml/m.h ../byterun/caml/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
+weak.i.$(O): weak.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/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/memory.h ../byterun/caml/minor_gc.h \
-  ../byterun/caml/signals.h
-meta.i.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/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/minor_gc.h ../byterun/caml/address_class.h \
-  ../byterun/caml/prims.h ../byterun/caml/stacks.h
-minor_gc.i.o: minor_gc.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/weak.h
+compact.i.$(O): compact.c ../byterun/caml/address_class.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/s.h \
+  ../byterun/caml/misc.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_ctrl.h ../byterun/caml/signals.h \
-  ../byterun/caml/weak.h
-misc.i.o: misc.c ../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/osdeps.h \
-  ../byterun/caml/version.h
-natdynlink.i.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/minor_gc.h ../byterun/caml/gc_ctrl.h \
+  ../byterun/caml/weak.h ../byterun/caml/compact.h
+finalise.i.$(O): finalise.c ../byterun/caml/callback.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/config.h \
+  ../byterun/caml/m.h ../byterun/caml/s.h ../byterun/caml/misc.h \
+  ../byterun/caml/compact.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/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 ../byterun/caml/hooks.h
-obj.i.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/signals.h
+custom.i.$(O): custom.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/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/memory.h ../byterun/caml/minor_gc.h \
-  ../byterun/caml/address_class.h ../byterun/caml/prims.h \
-  ../byterun/caml/spacetime.h ../byterun/caml/io.h \
-  ../byterun/caml/stack.h
-parsing.i.o: parsing.c ../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/minor_gc.h ../byterun/caml/address_class.h
+globroots.i.$(O): globroots.c ../byterun/caml/memory.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/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/alloc.h
-printexc.i.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/printexc.h
-roots.i.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/roots.h ../byterun/caml/globroots.h
+backtrace_prim.i.$(O): backtrace_prim.c ../byterun/caml/alloc.h \
+  ../byterun/caml/misc.h ../byterun/caml/config.h ../byterun/caml/m.h \
+  ../byterun/caml/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/backtrace.h ../byterun/caml/exec.h \
+  ../byterun/caml/backtrace_prim.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/globroots.h \
-  ../byterun/caml/stack.h
-signals.i.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/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/roots.h ../byterun/caml/signals.h \
-  ../byterun/caml/signals_machdep.h ../byterun/caml/sys.h
-signals_asm.i.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/address_class.h ../byterun/caml/stack.h
+backtrace.i.$(O): backtrace.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/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 ../byterun/caml/stack.h ../byterun/caml/spacetime.h \
-  ../byterun/caml/io.h
-spacetime.i.o: spacetime.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/address_class.h ../byterun/caml/backtrace.h \
+  ../byterun/caml/exec.h ../byterun/caml/backtrace_prim.h \
+  ../byterun/caml/fail.h
+natdynlink.i.$(O): natdynlink.c ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/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/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 \
+  ../byterun/caml/hooks.h
+debugger.i.$(O): debugger.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/s.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/debugger.h \
+  ../byterun/caml/osdeps.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
+meta.i.$(O): meta.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/s.h \
+  ../byterun/caml/mlvalues.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/minor_gc.h ../byterun/caml/address_class.h \
+  ../byterun/caml/prims.h ../byterun/caml/stacks.h
+dynlink.i.$(O): dynlink.c ../byterun/caml/config.h ../byterun/caml/m.h \
+  ../byterun/caml/s.h ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/dynlink.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/osdeps.h ../byterun/caml/prims.h \
+  ../byterun/caml/signals.h
+clambda_checks.i.$(O): clambda_checks.c ../byterun/caml/mlvalues.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/s.h \
+  ../byterun/caml/misc.h
+spacetime.i.$(O): spacetime.c ../byterun/caml/config.h ../byterun/caml/m.h \
+  ../byterun/caml/s.h ../byterun/caml/alloc.h ../byterun/caml/misc.h \
   ../byterun/caml/mlvalues.h ../byterun/caml/backtrace_prim.h \
   ../byterun/caml/backtrace.h ../byterun/caml/exec.h \
   ../byterun/caml/fail.h ../byterun/caml/gc.h ../byterun/caml/intext.h \
@@ -1440,81 +1464,37 @@ spacetime.i.o: spacetime.c ../byterun/caml/config.h \
   ../byterun/caml/osdeps.h ../byterun/caml/roots.h \
   ../byterun/caml/signals.h ../byterun/caml/stack.h \
   ../byterun/caml/sys.h ../byterun/caml/spacetime.h
-spacetime_offline.i.o: spacetime_offline.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 \
+spacetime_snapshot.i.$(O): spacetime_snapshot.c ../byterun/caml/alloc.h \
+  ../byterun/caml/misc.h ../byterun/caml/config.h ../byterun/caml/m.h \
+  ../byterun/caml/s.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/backtrace_prim.h ../byterun/caml/backtrace.h \
+  ../byterun/caml/exec.h ../byterun/caml/custom.h ../byterun/caml/fail.h \
+  ../byterun/caml/gc.h ../byterun/caml/gc_ctrl.h \
   ../byterun/caml/intext.h ../byterun/caml/io.h \
   ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \
   ../byterun/caml/memory.h ../byterun/caml/minor_gc.h \
   ../byterun/caml/address_class.h ../byterun/caml/roots.h \
   ../byterun/caml/signals.h ../byterun/caml/stack.h \
-  ../byterun/caml/sys.h ../byterun/caml/spacetime.h ../config/s.h
-spacetime_snapshot.i.o: spacetime_snapshot.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_prim.h \
-  ../byterun/caml/backtrace.h ../byterun/caml/exec.h \
-  ../byterun/caml/custom.h ../byterun/caml/fail.h ../byterun/caml/gc.h \
-  ../byterun/caml/gc_ctrl.h ../byterun/caml/intext.h \
-  ../byterun/caml/io.h ../byterun/caml/major_gc.h \
-  ../byterun/caml/freelist.h ../byterun/caml/memory.h \
-  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \
-  ../byterun/caml/roots.h ../byterun/caml/signals.h \
-  ../byterun/caml/stack.h ../byterun/caml/sys.h \
-  ../byterun/caml/spacetime.h
-startup.i.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/major_gc.h ../byterun/caml/minor_gc.h \
-  ../byterun/caml/address_class.h ../byterun/caml/osdeps.h \
-  ../byterun/caml/printexc.h ../byterun/caml/stack.h \
-  ../byterun/caml/startup_aux.h ../byterun/caml/sys.h
-startup_aux.i.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/osdeps.h \
-  ../byterun/caml/startup_aux.h
-str.i.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
-sys.i.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/mlvalues.h \
-  ../byterun/caml/debugger.h ../byterun/caml/fail.h \
-  ../byterun/caml/gc_ctrl.h ../byterun/caml/instruct.h \
-  ../byterun/caml/io.h ../byterun/caml/osdeps.h \
-  ../byterun/caml/signals.h ../byterun/caml/stacks.h \
-  ../byterun/caml/memory.h ../byterun/caml/gc.h \
+  ../byterun/caml/sys.h ../byterun/caml/spacetime.h
+spacetime_offline.i.$(O): spacetime_offline.c ../byterun/caml/alloc.h \
+  ../byterun/caml/misc.h ../byterun/caml/config.h ../byterun/caml/m.h \
+  ../byterun/caml/s.h ../byterun/caml/mlvalues.h ../byterun/caml/fail.h \
+  ../byterun/caml/gc.h ../byterun/caml/intext.h ../byterun/caml/io.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/version.h
-terminfo.i.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/mlvalues.h ../byterun/caml/fail.h ../byterun/caml/io.h
-unix.i.o: unix.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/mlvalues.h \
+  ../byterun/caml/memory.h ../byterun/caml/minor_gc.h \
+  ../byterun/caml/address_class.h ../byterun/caml/roots.h \
+  ../byterun/caml/signals.h ../byterun/caml/stack.h \
+  ../byterun/caml/sys.h ../byterun/caml/spacetime.h
+afl.i.$(O): afl.c ../byterun/caml/config.h ../byterun/caml/m.h \
+  ../byterun/caml/s.h ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \
+  ../byterun/caml/osdeps.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
+bigarray.i.$(O): bigarray.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/s.h \
+  ../byterun/caml/mlvalues.h ../byterun/caml/bigarray.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/osdeps.h ../byterun/caml/signals.h \
-  ../byterun/caml/sys.h ../byterun/caml/io.h
-weak.i.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/minor_gc.h \
-  ../byterun/caml/address_class.h ../byterun/caml/weak.h
+  ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h

diff --git a/asmrun/Makefile b/asmrun/Makefile
index aab82db028f5353e33eaedb2c0687e1aa5b934b5..62608a462ed24f292b5e16cf1e0e16060e7af75b 100644 (file)
--- a/asmrun/Makefile
+++ b/asmrun/Makefile
@@ -20,51 +20,51 @@ LINKEDFILES=misc.c freelist.c major_gc.c minor_gc.c memory.c alloc.c array.c \
   parsing.c gc_ctrl.c terminfo.c md5.c obj.c lexing.c printexc.c callback.c \
   weak.c compact.c finalise.c meta.c custom.c main.c globroots.c \
   $(UNIX_OR_WIN32).c dynlink.c signals.c debugger.c startup_aux.c \
-  backtrace.c afl.c
+  backtrace.c afl.c bigarray.c
 
-INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR)
+# The following variable stores the list of files for which dependencies
+# should be computed. It includes even the files that won't actually be
+# compiled on the platform where make depend is run
+sources := $(LINKEDFILES)
 
-CC=$(NATIVECC)
+INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR)
 
 ifeq "$(UNIX_OR_WIN32)" "win32"
 LN = cp
+sources += ../byterun/unix.c
 else
 LN = ln -s
+sources += ../byterun/win32.c
 endif
 
-FLAGS=\
-  -I../byterun \
-  -DNATIVE_CODE -DTARGET_$(ARCH)
+CPPFLAGS += -I../byterun -DNATIVE_CODE -DTARGET_$(ARCH)
 
 ifeq "$(UNIX_OR_WIN32)" "unix"
-FLAGS += -DMODEL_$(MODEL)
+CPPFLAGS += -DMODEL_$(MODEL)
 endif
 
-FLAGS += -DSYS_$(SYSTEM) \
-  $(NATIVECCCOMPOPTS) $(IFLEXDIR) \
-  $(LIBUNWIND_INCLUDE_FLAGS)
+CPPFLAGS += -DSYS_$(SYSTEM) $(IFLEXDIR) $(LIBUNWIND_INCLUDE_FLAGS)
+
+ifneq "$(CCOMPTYPE)" "msvc"
+CFLAGS += -g
+endif
 
 ifeq "$(TOOLCHAIN)" "msvc"
-DFLAGS=$(FLAGS) -DDEBUG
-PFLAGS=$(FLAGS) -DPROFILING $(NATIVECCPROFOPTS)
-OUTPUTOBJ = -Fo
+DFLAGS = $(CFLAGS) -DDEBUG
+PFLAGS=$(CFLAGS) -DPROFILING $(NATIVECCPROFOPTS)
 ASMOBJS=$(ARCH)nt.$(O)
 else
-DFLAGS=$(FLAGS) -g -DDEBUG
-PFLAGS=$(FLAGS) -pg -DPROFILING $(NATIVECCPROFOPTS)
-OUTPUTOBJ = -o
+DFLAGS = $(CFLAGS) -g -DDEBUG
+PFLAGS=$(CFLAGS) -pg -DPROFILING $(NATIVECCPROFOPTS)
 ASMOBJS=$(ARCH).$(O)
 endif
 
-IFLAGS=$(FLAGS) -DCAML_INSTR
-PICFLAGS=$(FLAGS) $(SHAREDCCCOMPOPTS)
+IFLAGS=$(CFLAGS) -DCAML_INSTR
+PICFLAGS=$(CFLAGS) $(SHAREDCCCOMPOPTS)
 
-ASPPFLAGS = -DSYS_$(SYSTEM)
+ASPPFLAGS = -DSYS_$(SYSTEM) -I../byterun
 ifeq "$(UNIX_OR_WIN32)" "unix"
 ASPPFLAGS += -DMODEL_$(MODEL)
-CFLAGS=$(FLAGS) -g
-else
-CFLAGS=$(FLAGS)
 endif
 
 COBJS=startup_aux.$(O) startup.$(O) main.$(O) fail.$(O)                \
@@ -77,7 +77,7 @@ COBJS=startup_aux.$(O) startup.$(O) main.$(O) fail.$(O)               \
   custom.$(O) globroots.$(O) backtrace_prim.$(O) backtrace.$(O)                \
   natdynlink.$(O) debugger.$(O) meta.$(O) dynlink.$(O)                 \
   clambda_checks.$(O) spacetime.$(O) spacetime_snapshot.$(O)           \
-  spacetime_offline.$(O) afl.$(O)
+  spacetime_offline.$(O) afl.$(O) bigarray.$(O)
 
 OBJS=$(COBJS) $(ASMOBJS)
 
@@ -135,19 +135,19 @@ $(LINKEDFILES): %.c: ../byterun/%.c
        $(LN) $< $@
 
 %.d.$(O): %.c
-       $(CC) -c $(DFLAGS) $(OUTPUTOBJ)$@ $<
+       $(CC) -c $(DFLAGS) $(CPPFLAGS) $(OUTPUTOBJ)$@ $<
 
 %.i.$(O): %.c
-       $(CC) -c $(IFLAGS) $(OUTPUTOBJ)$@ $<
+       $(CC) -c $(IFLAGS) $(CPPFLAGS) $(OUTPUTOBJ)$@ $<
 
 %.p.$(O): %.c
-       $(CC) -c $(PFLAGS) $(OUTPUTOBJ)$@ $<
+       $(CC) -c $(PFLAGS) $(CPPFLAGS) $(OUTPUTOBJ)$@ $<
 
 %.pic.$(O): %.c
-       $(CC) -c $(PICFLAGS) $(OUTPUTOBJ)$@ $<
+       $(CC) -c $(PICFLAGS) $(CPPFLAGS) $(OUTPUTOBJ)$@ $<
 
 %.$(O): %.c
-       $(CC) $(CFLAGS) -c $<
+       $(CC) -c $(CFLAGS) $(CPPFLAGS) $<
 
 %.o: %.S
        $(ASPP) $(ASPPFLAGS) -o $@ $< || \
@@ -177,21 +177,19 @@ clean:
 distclean: clean
        rm -r *~
 
-ifneq "$(TOOLCHAIN)" "msvc"
 .PHONY: depend
-depend: $(COBJS:.$(O)=.c) $(LINKEDFILES)
-       $(CC) -MM $(FLAGS) *.c > .depend
-       $(CC) -MM $(FLAGS) -DPROFILING *.c | sed -e 's/\.o/.p.o/' >> .depend
-       $(CC) -MM $(FLAGS) -DDEBUG *.c | sed -e 's/\.o/.d.o/' >> .depend
-       $(CC) -MM $(FLAGS) -DCAML_INSTR *.c | sed -e 's/\.o/.i.o/' >> .depend
+ifeq "$(TOOLCHAIN)" "msvc"
+depend:
+       $(error Dependencies cannot be regenerated using the MSVC ports)
+else
+depend: $(COBJS:.$(O)=.c) $(sources)
+       $(CC) -MM $(CFLAGS) $(CPPFLAGS) $^ | sed -e 's/\.o/.$$(O)/' > .depend
+       $(CC) -MM $(PFLAGS) $(CPPFLAGS) $^ | sed -e 's/\.o/.p.$$(O)/' \
+         >> .depend
+       $(CC) -MM $(DFLAGS) $(CPPFLAGS) $^ | sed -e 's/\.o/.d.$$(O)/' \
+         >> .depend
+       $(CC) -MM $(IFLAGS) $(CPPFLAGS) $^ | sed -e 's/\.o/.i.$$(O)/' \
+         >> .depend
 endif
 
-ifeq "$(UNIX_OR_WIN32)" "win32"
-.depend.nt: .depend
-       sed -e 's/\.o/.$(O)/g' .depend > .depend.nt
-
-include .depend.nt
-
-else
 include .depend
-endif

diff --git a/asmrun/amd64.S b/asmrun/amd64.S
index efb8fd9b58e31034d2cc2e75a723bc65805d2f81..237510dd9770f3a3902c4a69db31bfef61abd1b8 100644 (file)
--- a/asmrun/amd64.S
+++ b/asmrun/amd64.S
@@ -18,7 +18,7 @@
 
 /* PIC mode support based on contribution by Paul Stravers (see PR#4795) */
 
-#include "../config/m.h"
+#include "caml/m.h"
 
 #if defined(SYS_macosx)
 
@@ -260,9 +260,12 @@
    /* Calls from OCaml to C must reserve 32 bytes of extra stack space */
 #  define PREPARE_FOR_C_CALL subq $32, %rsp; CFI_ADJUST(32)
 #  define CLEANUP_AFTER_C_CALL addq $32, %rsp; CFI_ADJUST(-32)
+   /* Stack probing mustn't be larger than the page size */
+#  define STACK_PROBE_SIZE $4096
 #else
 #  define PREPARE_FOR_C_CALL
 #  define CLEANUP_AFTER_C_CALL
+#  define STACK_PROBE_SIZE $32768
 #endif
 
         .text
@@ -278,13 +281,11 @@ FUNCTION(G(caml_call_gc))
         CFI_STARTPROC
         RECORD_STACK_FRAME(0)
 LBL(caml_call_gc):
-#if !defined(SYS_mingw64) && !defined(SYS_cygwin)
     /* Touch the stack to trigger a recoverable segfault
        if insufficient space remains */
-        subq    $32768, %rsp
+        subq    STACK_PROBE_SIZE, %rsp
         movq    %rax, 0(%rsp)
-        addq    $32768, %rsp
-#endif
+        addq    STACK_PROBE_SIZE, %rsp
     /* Build array of registers, save it into caml_gc_regs */
 #ifdef WITH_FRAME_POINTERS
         ENTER_FUNCTION          ;
@@ -467,13 +468,11 @@ LBL(caml_c_call):
         STORE_VAR(%r13, caml_spacetime_trie_node_ptr)
 #endif
         subq    $8, %rsp; CFI_ADJUST(8) /* equivalent to pushq %r12 */
-#if !defined(SYS_mingw64) && !defined(SYS_cygwin)
     /* Touch the stack to trigger a recoverable segfault
        if insufficient space remains */
-        subq    $32768, %rsp
+        subq    STACK_PROBE_SIZE, %rsp
         movq    %rax, 0(%rsp)
-        addq    $32768, %rsp
-#endif
+        addq    STACK_PROBE_SIZE, %rsp
     /* Make the exception handler and alloc ptr available to the C code */
         STORE_VAR(%r15, caml_young_ptr)
         STORE_VAR(%r14, caml_exception_pointer)

diff --git a/asmrun/amd64nt.asm b/asmrun/amd64nt.asm
index 07ac45085d6e2e2d45de50c17cfa6db16d144840..c4534ea0b15dd17abff146dea92502fdff5af9ee 100644 (file)
--- a/asmrun/amd64nt.asm
+++ b/asmrun/amd64nt.asm
@@ -37,6 +37,11 @@
 
         .CODE
 
+        PUBLIC  caml_system__code_begin
+caml_system__code_begin:
+        ret  ; just one instruction, so that debuggers don't display
+             ; caml_system__code_begin instead of caml_call_gc
+
 ; Allocation
 
         PUBLIC  caml_call_gc
@@ -48,6 +53,11 @@ caml_call_gc:
         lea     rax, [rsp+8]
         mov     caml_bottom_of_stack, rax
 L105:
+    ; Touch the stack to trigger a recoverable segfault
+    ; if insufficient space remains
+        sub     rsp, 01000h
+        mov     [rsp], rax
+        add     rsp, 01000h
     ; Save caml_young_ptr, caml_exception_pointer
         mov     caml_young_ptr, r15
         mov     caml_exception_pointer, r14
@@ -202,6 +212,11 @@ caml_c_call:
         pop     r12
         mov     caml_last_return_address, r12
         mov     caml_bottom_of_stack, rsp
+    ; Touch the stack to trigger a recoverable segfault
+    ; if insufficient space remains
+        sub     rsp, 01000h
+        mov     [rsp], rax
+        add     rsp, 01000h
     ; Make the exception handler and alloc ptr available to the C code
         mov     caml_young_ptr, r15
         mov     caml_exception_pointer, r14
@@ -445,6 +460,9 @@ caml_ml_array_bound_error:
         lea     rax, caml_array_bound_error
         jmp     caml_c_call
 
+       PUBLIC caml_system__code_end
+caml_system__code_end:
+
         .DATA
         PUBLIC  caml_system__frametable
 caml_system__frametable LABEL QWORD

diff --git a/asmrun/arm.S b/asmrun/arm.S
index 8305cfe9f8d38d9348c63d1941d3877cad82d598..12bc4a1b99efc2cbb6bb70f49feb1e72b27714e3 100644 (file)
--- a/asmrun/arm.S
+++ b/asmrun/arm.S
@@ -17,6 +17,8 @@
 /* Asm part of the runtime system, ARM processor */
 /* Must be preprocessed by cpp */
 
+#include "caml/m.h"
+
         .syntax unified
         .text
 #if defined(SYS_linux_eabihf) && defined(MODEL_armv6)
@@ -87,10 +89,14 @@ alloc_limit     .req    r11
 #define CFI_STARTPROC .cfi_startproc
 #define CFI_ENDPROC .cfi_endproc
 #define CFI_ADJUST(n) .cfi_adjust_cfa_offset n
+#define CFI_REGISTER(r1,r2) .cfi_register r1,r2
+#define CFI_OFFSET(r,n) .cfi_offset r,n
 #else
 #define CFI_STARTPROC
 #define CFI_ENDPROC
 #define CFI_ADJUST(n)
+#define CFI_REGISTER(r1,r2)
+#define CFI_OFFSET(r,n)
 #endif
 
 /* Support for profiling with gprof */
@@ -128,6 +134,11 @@ caml_call_gc:
 #endif
     /* Save integer registers and return address on the stack */
         push    {r0-r7,r12,lr}; CFI_ADJUST(40)
+#if defined(SYS_linux_eabihf) || defined(SYS_netbsd)
+        CFI_OFFSET(lr, -68)
+#else
+        CFI_OFFSET(lr, -4)
+#endif
     /* Store pointer to saved integer registers in caml_gc_regs */
         ldr     r12, =caml_gc_regs
         str     sp, [r12]
@@ -265,6 +276,7 @@ caml_c_call:
         str     sp, [r6]
     /* Preserve return address in callee-save register r4 */
         mov     r4, lr
+        CFI_REGISTER(lr, r4)
     /* Make the exception handler alloc ptr available to the C code */
         ldr     r5, =caml_young_ptr
         ldr     r6, =caml_exception_pointer
@@ -302,6 +314,11 @@ caml_start_program:
 #endif
     /* Save return address and callee-save registers */
         push    {r4-r8,r10,r11,lr}; CFI_ADJUST(32)      /* 8-byte alignment */
+#if defined(SYS_linux_eabihf) || defined(SYS_netbsd)
+        CFI_OFFSET(lr, -68)
+#else
+        CFI_OFFSET(lr, -4)
+#endif
     /* Setup a callback link on the stack */
         sub     sp, sp, 16; CFI_ADJUST(16)              /* 8-byte alignment */
         ldr     r4, =caml_bottom_of_stack

diff --git a/asmrun/arm64.S b/asmrun/arm64.S
index 2115be3675a10a496e6c65a544955ad507ff9a05..dea5ab731e0998dee482e1d9fae8c3381bc4b754 100644 (file)
--- a/asmrun/arm64.S
+++ b/asmrun/arm64.S
@@ -16,6 +16,8 @@
 /* Asm part of the runtime system, ARM processor, 64-bit mode */
 /* Must be preprocessed by cpp */
 
+#include "caml/m.h"
+
 /* Special registers */
 
 #define TRAP_PTR x26
@@ -31,10 +33,14 @@
 #define CFI_STARTPROC .cfi_startproc
 #define CFI_ENDPROC .cfi_endproc
 #define CFI_ADJUST(n) .cfi_adjust_cfa_offset n
+#define CFI_REGISTER(r1,r2) .cfi_register r1,r2
+#define CFI_OFFSET(r,n) .cfi_offset r,n
 #else
 #define CFI_STARTPROC
 #define CFI_ENDPROC
 #define CFI_ADJUST(n)
+#define CFI_REGISTER(r1,r2)
+#define CFI_OFFSET(r,n)
 #endif
 
 /* Support for profiling with gprof */
@@ -91,6 +97,8 @@ caml_call_gc:
 .Lcaml_call_gc:
     /* Set up stack space, saving return address and frame pointer */
     /* (2 regs RA/GP, 24 allocatable int regs, 24 caller-save float regs) * 8 */
+        CFI_OFFSET(29, -400)
+        CFI_OFFSET(30, -392)
         stp     x29, x30, [sp, -400]!
         CFI_ADJUST(400)
         add     x29, sp, #0
@@ -296,6 +304,7 @@ caml_c_call:
         PROFILE
     /* Preserve return address in callee-save register x19 */
         mov     x19, x30
+        CFI_REGISTER(30, 19)
     /* Record lowest stack address and return address */
         STOREGLOBAL(x30, caml_last_return_address)
         add     TMP, sp, #0
@@ -329,6 +338,8 @@ caml_start_program:
 
 .Ljump_to_caml:
     /* Set up stack frame and save callee-save registers */
+        CFI_OFFSET(29, -160)
+        CFI_OFFSET(30, -152)
         stp     x29, x30, [sp, -160]!
         CFI_ADJUST(160)
         add     x29, sp, #0

diff --git a/asmrun/backtrace_prim.c b/asmrun/backtrace_prim.c
index 682e082e82b9eef7f6bfdd1096ef34babebb7e46..7691a7b4b0998f3e9be946002388cf0239148ed0 100644 (file)
--- a/asmrun/backtrace_prim.c
+++ b/asmrun/backtrace_prim.c
@@ -70,9 +70,9 @@ frame_descr * caml_next_frame_descriptor(uintnat * pc, char ** sp)
 }
 
 int caml_alloc_backtrace_buffer(void){
-  Assert(caml_backtrace_pos == 0);
-  caml_backtrace_buffer = malloc(BACKTRACE_BUFFER_SIZE
-                                 * sizeof(backtrace_slot));
+  CAMLassert(caml_backtrace_pos == 0);
+  caml_backtrace_buffer =
+    caml_stat_alloc_noexc(BACKTRACE_BUFFER_SIZE * sizeof(backtrace_slot));
   if (caml_backtrace_buffer == NULL) return -1;
   return 0;
 }
@@ -159,7 +159,7 @@ CAMLprim value caml_get_current_callstack(value max_frames_value)
 
     for (trace_pos = 0; trace_pos < trace_size; trace_pos++) {
       frame_descr * descr = caml_next_frame_descriptor(&pc, &sp);
-      Assert(descr != NULL);
+      CAMLassert(descr != NULL);
       Field(trace, trace_pos) = Val_backtrace_slot((backtrace_slot) descr);
     }
   }

diff --git a/asmrun/clambda_checks.c b/asmrun/clambda_checks.c
index 1d25ecbc4fe2ff7c27b4ca0c227857ab82bd0be5..bf1cb85ecf99155c89142e51729e35b67a3a282d 100644 (file)
--- a/asmrun/clambda_checks.c
+++ b/asmrun/clambda_checks.c
@@ -17,7 +17,6 @@
 /* Runtime checks to try to catch errors in code generation.
    See flambda_to_clambda.ml for more information. */
 
-#include <assert.h>
 #include <stdio.h>
 
 #include <caml/mlvalues.h>
@@ -46,9 +45,9 @@ value caml_check_value_is_closure(value v, value v_descr)
   }
   if (Tag_val(v) == Infix_tag) {
     v -= Infix_offset_val(v);
-    assert(Tag_val(v) == Closure_tag);
+    CAMLassert(Tag_val(v) == Closure_tag);
   }
-  assert(Wosize_val(v) >= 2);
+  CAMLassert(Wosize_val(v) >= 2);
 
   return orig_v;
 }
@@ -75,7 +74,7 @@ value caml_check_field_access(value v, value pos, value v_descr)
     v -= offset;
     pos += offset / sizeof(value);
   }
-  assert(Long_val(pos) >= 0);
+  CAMLassert(Long_val(pos) >= 0);
   if (Long_val(pos) >= Wosize_val(v)) {
     fprintf(stderr,
       "Access to field %" ARCH_INT64_PRINTF_FORMAT

diff --git a/asmrun/fail.c b/asmrun/fail.c
index d73cb88524cac5794db3a9a2547d8d8f4d614dd7..e2df8cb84f8f30f472edea908613b45c74818e94 100644 (file)
--- a/asmrun/fail.c
+++ b/asmrun/fail.c
@@ -100,7 +100,7 @@ void caml_raise_with_args(value tag, int nargs, value args[])
   value bucket;
   int i;
 
-  Assert(1 + nargs <= Max_young_wosize);
+  CAMLassert(1 + nargs <= Max_young_wosize);
   bucket = caml_alloc_small (1 + nargs, 0);
   Field(bucket, 0) = tag;
   for (i = 0; i < nargs; i++) Field(bucket, 1 + i) = args[i];

diff --git a/asmrun/i386.S b/asmrun/i386.S
index 9e0f2bdb921e51a748448faf822652bddc0c44a6..aa6a913747f249bf02fb08eb49f2e6cdf40cf17b 100644 (file)
--- a/asmrun/i386.S
+++ b/asmrun/i386.S
@@ -16,7 +16,7 @@
 /* Asm part of the runtime system, Intel 386 processor */
 /* Must be preprocessed by cpp */
 
-#include "../config/m.h"
+#include "caml/m.h"
 
 /* Linux/BSD with ELF binaries and Solaris do not prefix identifiers with _.
    Linux/BSD with a.out binaries and NextStep do. */

diff --git a/asmrun/natdynlink.c b/asmrun/natdynlink.c
index e2599e65fbda6993e5c8380accdac6678c5ca672..95626109eee974b4dbf54510cbc3bfb4c7f8425c 100644 (file)
--- a/asmrun/natdynlink.c
+++ b/asmrun/natdynlink.c
@@ -31,7 +31,7 @@
 
 #include "caml/hooks.h"
 
-CAMLexport void (*caml_natdynlink_hook)(void* handle, char* unit) = NULL;
+CAMLexport void (*caml_natdynlink_hook)(void* handle, const char* unit) = NULL;
 
 #include <stdio.h>
 #include <string.h>
@@ -44,8 +44,8 @@ static value Val_handle(void* handle) {
   return res;
 }
 
-static void *getsym(void *handle, char *module, char *name){
-  char *fullname = caml_strconcat(3, "caml", module, name);
+static void *getsym(void *handle, const char *module, const char *name){
+  char *fullname = caml_stat_strconcat(3, "caml", module, name);
   void *sym;
   sym = caml_dlsym (handle, fullname);
   /*  printf("%s => %lx\n", fullname, (uintnat) sym); */
@@ -69,11 +69,11 @@ CAMLprim value caml_natdynlink_open(value filename, value global)
   CAMLlocal3 (res, handle, header);
   void *sym;
   void *dlhandle;
-  char *p;
+  char_os *p;
 
   /* TODO: dlclose in case of error... */
 
-  p = caml_strdup(String_val(filename));
+  p = caml_stat_strdup_to_os(String_val(filename));
   caml_enter_blocking_section();
   dlhandle = caml_dlopen(p, 1, Int_val(global));
   caml_leave_blocking_section();
@@ -103,7 +103,7 @@ CAMLprim value caml_natdynlink_run(value handle_v, value symbol) {
   struct code_fragment * cf;
 
 #define optsym(n) getsym(handle,unit,n)
-  char *unit;
+  const char *unit;
   void (*entrypoint)(void);
 
   unit = String_val(symbol);
@@ -151,11 +151,11 @@ CAMLprim value caml_natdynlink_run_toplevel(value filename, value symbol)
   CAMLparam2 (filename, symbol);
   CAMLlocal3 (res, v, handle_v);
   void *handle;
-  char *p;
+  char_os *p;
 
   /* TODO: dlclose in case of error... */
 
-  p = caml_strdup(String_val(filename));
+  p = caml_stat_strdup_to_os(String_val(filename));
   caml_enter_blocking_section();
   handle = caml_dlopen(p, 1, 1);
   caml_leave_blocking_section();

diff --git a/asmrun/roots.c b/asmrun/roots.c
index 6307fd096ac7d37a00d7bc2c70f60532fb1f3a3b..c9526b2a63211eac182c10ed767cf4c77463a7e3 100644 (file)
--- a/asmrun/roots.c
+++ b/asmrun/roots.c
@@ -116,7 +116,7 @@ static void init_frame_descriptors(link *new_frametables)
   intnat tblsize, increase, i;
   link *tail = NULL;
 
-  Assert(new_frametables);
+  CAMLassert(new_frametables);
 
   tail = frametables_list_tail(new_frametables);
   increase = count_descriptors(new_frametables);

diff --git a/asmrun/s390x.S b/asmrun/s390x.S
index 0af419941090a8456787dfd6cc01917736d9f291..65923be0b5f41d3c2dd858da1cfdd55a3b9ab0c8 100644 (file)
--- a/asmrun/s390x.S
+++ b/asmrun/s390x.S
@@ -14,6 +14,22 @@
 /*   special exception on linking described in the file LICENSE.          */
 /*                                                                        */
 /**************************************************************************/
+
+#if defined(__PIC__)
+
+#define Addrglobal(reg,glob) \
+        lgrl    reg, glob@GOTENT
+#define Loadglobal(reg,glob) \
+        lgrl    %r1, glob@GOTENT; lg reg, 0(%r1)
+#define Storeglobal(reg,glob) \
+        lgrl    %r1, glob@GOTENT; stg reg, 0(%r1)
+#define Loadglobal32(reg,glob) \
+        lgrl    %r1, glob@GOTENT; lgf reg, 0(%r1)
+#define Storeglobal32(reg,glob) \
+        lgrl    %r1, glob@GOTENT; sty reg, 0(%r1)
+
+#else
+
 #define Addrglobal(reg,glob) \
         larl    reg, glob
 #define Loadglobal(reg,glob) \
@@ -25,6 +41,7 @@
 #define Storeglobal32(reg,glob) \
         strl   reg, glob
 
+#endif
 
         .section ".text"
 
@@ -246,10 +263,10 @@ caml_start_program:
 .L106:
         lg      %r5, 0(%r15)
         lg      %r6, 8(%r15)
-        lg      %r1, 16(%r15)
+        lg      %r0, 16(%r15)
         Storeglobal(%r5, caml_bottom_of_stack)
         Storeglobal(%r6, caml_last_return_address)
-        Storeglobal(%r1, caml_gc_regs)
+        Storeglobal(%r0, caml_gc_regs)
         la      %r15, 32(%r15)
 
     /* Update allocation pointer */
@@ -318,7 +335,7 @@ caml_ml_array_bound_error:
            the frame descriptor for the call site is not correct */
         Storeglobal(%r15, caml_bottom_of_stack)
         lay     %r15, -160(%r15)    /* Reserve stack space for C call */
-        larl    %r7, caml_array_bound_error
+        Addrglobal(%r7, caml_array_bound_error)
         j       .L101
         .globl  caml_system__code_end
 caml_system__code_end:

diff --git a/asmrun/signals_asm.c b/asmrun/signals_asm.c
index f124a076749119a5a4646f0df36914757d5baeb9..3895d752076a4f99a8adad3fd93e958c1de7ff97 100644 (file)
--- a/asmrun/signals_asm.c
+++ b/asmrun/signals_asm.c
@@ -158,21 +158,9 @@ int caml_set_signal_action(int signo, int action)
 /* Machine- and OS-dependent handling of bound check trap */
 
 #if defined(TARGET_power) \
-  || defined(TARGET_s390x) \
-  || (defined(TARGET_sparc) && defined(SYS_solaris))
+  || defined(TARGET_s390x)
 DECLARE_SIGNAL_HANDLER(trap_handler)
 {
-#if defined(SYS_solaris)
-  if (info->si_code != ILL_ILLTRP) {
-    /* Deactivate our exception handler and return. */
-    struct sigaction act;
-    act.sa_handler = SIG_DFL;
-    act.sa_flags = 0;
-    sigemptyset(&act.sa_mask);
-    sigaction(sig, &act, NULL);
-    return;
-  }
-#endif
 #if defined(SYS_rhapsody)
   /* Unblock SIGTRAP */
   { sigset_t mask;
@@ -262,14 +250,6 @@ DECLARE_SIGNAL_HANDLER(segv_handler)
 void caml_init_signals(void)
 {
   /* Bound-check trap handling */
-#if defined(TARGET_sparc) && defined(SYS_solaris)
-  { struct sigaction act;
-    sigemptyset(&act.sa_mask);
-    SET_SIGACT(act, trap_handler);
-    act.sa_flags |= SA_NODEFER;
-    sigaction(SIGILL, &act, NULL);
-  }
-#endif
 
 #if defined(TARGET_power)
   { struct sigaction act;
@@ -305,7 +285,4 @@ void caml_init_signals(void)
     if (sigaltstack(&stk, NULL) == 0) { sigaction(SIGSEGV, &act, NULL); }
   }
 #endif
-#if defined(_WIN32) && !defined(_WIN64)
-  caml_win32_overflow_detection();
-#endif
 }

diff --git a/asmrun/signals_osdep.h b/asmrun/signals_osdep.h
index 03196167157b2822d02e30262d0e5b5a758bca5a..d9bc8b18a29030438db8417455527ea7730b420e 100644 (file)
--- a/asmrun/signals_osdep.h
+++ b/asmrun/signals_osdep.h
@@ -303,27 +303,31 @@
   #define CONTEXT_YOUNG_PTR (context->regs->gpr[31])
   #define CONTEXT_SP (context->regs->gpr[1])
 
-/****************** s390x, ELF (Linux) */
-#elif defined(TARGET_s390x) && defined(SYS_elf)
+/****************** PowerPC, NetBSD */
+
+#elif defined(TARGET_power) && defined (SYS_netbsd)
 
+  #include <ucontext.h>
   #define DECLARE_SIGNAL_HANDLER(name) \
-    static void name(int sig, struct sigcontext * context)
+  static void name(int sig, siginfo_t * info, ucontext_t * context)
 
   #define SET_SIGACT(sigact,name) \
-     sigact.sa_handler = (void (*)(int)) (name); \
-     sigact.sa_flags = 0
+  sigact.sa_sigaction = (void (*)(int,siginfo_t *,void *)) (name); \
+  sigact.sa_flags = SA_SIGINFO
+
+  typedef long context_reg;
+  #define CONTEXT_PC (_UC_MACHINE_PC(context))
+  #define CONTEXT_EXCEPTION_POINTER (context->uc_mcontext.__gregs[_REG_R29])
+  #define CONTEXT_YOUNG_LIMIT (context->uc_mcontext.__gregs[_REG_R30])
+  #define CONTEXT_YOUNG_PTR (context->uc_mcontext.__gregs[_REG_R31])
+  #define CONTEXT_SP (_UC_MACHINE_SP(context))
+  #define CONTEXT_FAULTING_ADDRESS ((char *) info->si_addr)
 
-  typedef unsigned long context_reg;
-  #define CONTEXT_PC (context->sregs->regs.psw.addr)
-  #define CONTEXT_EXCEPTION_POINTER (context->sregs->regs.gprs[13])
-  #define CONTEXT_YOUNG_LIMIT (context->sregs->regs.gprs[10])
-  #define CONTEXT_YOUNG_PTR (context->sregs->regs.gprs[11])
-  #define CONTEXT_SP (context->sregs->regs.gprs[15])
 
-/****************** PowerPC, BSD */
+/****************** PowerPC, other BSDs */
 
 #elif defined(TARGET_power) && \
-    (defined(SYS_bsd) || defined(SYS_bsd_elf) || defined(SYS_netbsd))
+    (defined(SYS_bsd) || defined(SYS_bsd_elf))
 
   #define DECLARE_SIGNAL_HANDLER(name) \
     static void name(int sig, int code, struct sigcontext * context)
@@ -339,28 +343,22 @@
   #define CONTEXT_YOUNG_PTR (context->sc_frame.fixreg[31])
   #define CONTEXT_SP (context->sc_frame.fixreg[1])
 
-/****************** SPARC, Solaris */
-
-#elif defined(TARGET_sparc) && defined(SYS_solaris)
-
-  #include <ucontext.h>
+/****************** s390x, ELF (Linux) */
+#elif defined(TARGET_s390x) && defined(SYS_elf)
 
   #define DECLARE_SIGNAL_HANDLER(name) \
-    static void name(int sig, siginfo_t * info, ucontext_t * context)
+    static void name(int sig, struct sigcontext * context)
 
   #define SET_SIGACT(sigact,name) \
-     sigact.sa_sigaction = (void (*)(int,siginfo_t *,void *)) (name); \
-     sigact.sa_flags = SA_SIGINFO
+     sigact.sa_handler = (void (*)(int)) (name); \
+     sigact.sa_flags = 0
 
-  typedef long context_reg;
-  #define CONTEXT_PC (context->uc_mcontext.gregs[REG_PC])
-    /* Local register number N is saved on the stack N words
-       after the stack pointer */
-  #define CONTEXT_SP (context->uc_mcontext.gregs[REG_SP])
-  #define SPARC_L_REG(n) ((long *)(context->uc_mcontext.gregs[REG_SP]))[n]
-  #define CONTEXT_EXCEPTION_POINTER (SPARC_L_REG(5))
-  #define CONTEXT_YOUNG_LIMIT (SPARC_L_REG(7))
-  #define CONTEXT_YOUNG_PTR (SPARC_L_REG(6))
+  typedef unsigned long context_reg;
+  #define CONTEXT_PC (context->sregs->regs.psw.addr)
+  #define CONTEXT_EXCEPTION_POINTER (context->sregs->regs.gprs[13])
+  #define CONTEXT_YOUNG_LIMIT (context->sregs->regs.gprs[10])
+  #define CONTEXT_YOUNG_PTR (context->sregs->regs.gprs[11])
+  #define CONTEXT_SP (context->sregs->regs.gprs[15])
 
 /******************** Default */
 

diff --git a/asmrun/spacetime.c b/asmrun/spacetime.c
index e95cf687712e3467dc8f46f4ba55b532fc820df5..bf4b6f3c7a47c4095c290f1609df524c2ea482d7 100644 (file)
--- a/asmrun/spacetime.c
+++ b/asmrun/spacetime.c
@@ -103,7 +103,7 @@ static void reinitialise_free_node_block(void)
 {
   size_t index;
 
-  start_of_free_node_block = (char*) malloc(chunk_size);
+  start_of_free_node_block = (char*) caml_stat_alloc_noexc(chunk_size);
   end_of_free_node_block = start_of_free_node_block + chunk_size;
 
   for (index = 0; index < chunk_size / sizeof(value); index++) {
@@ -119,14 +119,26 @@ static void reinitialise_free_node_block(void)
 extern value val_process_id;
 #endif
 
-static uint32_t version_number = 0;
+enum {
+  FEATURE_CALL_COUNTS = 1,
+} features;
+
+static uint16_t version_number = 0;
 static uint32_t magic_number_base = 0xace00ace;
 
 static void caml_spacetime_write_magic_number_internal(struct channel* chan)
 {
-  value magic_number =
+  value magic_number;
+  uint16_t features = 0;
+
+#ifdef ENABLE_CALL_COUNTS
+  features |= FEATURE_CALL_COUNTS;
+#endif
+
+  magic_number =
     Val_long(((uint64_t) magic_number_base)
-             | (((uint64_t) version_number) << 32));
+             | (((uint64_t) version_number) << 32)
+             | (((uint64_t) features) << 48));
 
   Lock(chan);
   caml_output_val(chan, magic_number, Val_long(0));
@@ -213,14 +225,12 @@ void caml_spacetime_initialize(void)
         caml_secure_getenv("OCAML_SPACETIME_SNAPSHOT_DIR");
 
       if (user_specified_automatic_snapshot_dir == NULL) {
-#ifdef HAS_GETCWD
+#if defined(HAS_GETCWD)
         if (getcwd(cwd, sizeof(cwd)) == NULL) {
           dir_ok = 0;
         }
 #else
-        if (getwd(cwd) == NULL) {
-          dir_ok = 0;
-        }
+        dir_ok = 0;
 #endif
         if (dir_ok) {
           automatic_snapshot_dir = strdup(cwd);
@@ -255,7 +265,7 @@ void caml_spacetime_initialize(void)
 void caml_spacetime_register_shapes(void* dynlinked_table)
 {
   shape_table* table;
-  table = (shape_table*) malloc(sizeof(shape_table));
+  table = (shape_table*) caml_stat_alloc_noexc(sizeof(shape_table));
   if (table == NULL) {
     fprintf(stderr, "Out of memory whilst registering shape table");
     abort();
@@ -280,7 +290,7 @@ void caml_spacetime_register_thread(
 {
   per_thread* thr;
 
-  thr = (per_thread*) malloc(sizeof(per_thread));
+  thr = (per_thread*) caml_stat_alloc_noexc(sizeof(per_thread));
   if (thr == NULL) {
     fprintf(stderr, "Out of memory while registering thread for profiling\n");
     abort();
@@ -375,7 +385,7 @@ void save_trie (struct channel *chan, double time_override,
     thr = thr->next;
     num_marshalled++;
   }
-  Assert(num_marshalled == num_per_threads); */
+  CAMLassert(num_marshalled == num_per_threads); */
   caml_extern_allow_out_of_heap = 0;
 
   Unlock(chan);
@@ -404,23 +414,23 @@ c_node_type caml_spacetime_classify_c_node(c_node* node)
 
 c_node* caml_spacetime_c_node_of_stored_pointer(value node_stored)
 {
-  Assert(node_stored == Val_unit || Is_c_node(node_stored));
+  CAMLassert(node_stored == Val_unit || Is_c_node(node_stored));
   return (node_stored == Val_unit) ? NULL : (c_node*) Hp_val(node_stored);
 }
 
 c_node* caml_spacetime_c_node_of_stored_pointer_not_null(
       value node_stored)
 {
-  Assert(Is_c_node(node_stored));
+  CAMLassert(Is_c_node(node_stored));
   return (c_node*) Hp_val(node_stored);
 }
 
 value caml_spacetime_stored_pointer_of_c_node(c_node* c_node)
 {
   value node;
-  Assert(c_node != NULL);
+  CAMLassert(c_node != NULL);
   node = Val_hp(c_node);
-  Assert(Is_c_node(node));
+  CAMLassert(Is_c_node(node));
   return node;
 }
 
@@ -436,7 +446,7 @@ static value allocate_uninitialized_ocaml_node(int size_including_header)
   void* node;
   uintnat size;
 
-  Assert(size_including_header >= 3);
+  CAMLassert(size_including_header >= 3);
   node = caml_stat_alloc(sizeof(uintnat) * size_including_header);
 
   size = size_including_header * sizeof(value);
@@ -445,14 +455,14 @@ static value allocate_uninitialized_ocaml_node(int size_including_header)
   if (end_of_free_node_block - start_of_free_node_block < size) {
     reinitialise_free_node_block();
     node = (void*) start_of_free_node_block;
-    Assert(end_of_free_node_block - start_of_free_node_block >= size);
+    CAMLassert(end_of_free_node_block - start_of_free_node_block >= size);
   }
 
   start_of_free_node_block += size;
 
   /* We don't currently rely on [uintnat] alignment, but we do need some
      alignment, so just be sure. */
-  Assert (((uintnat) node) % sizeof(uintnat) == 0);
+  CAMLassert (((uintnat) node) % sizeof(uintnat) == 0);
   return Val_hp(node);
 }
 
@@ -471,7 +481,7 @@ static value find_tail_node(value node, void* callee)
   pc = Encode_node_pc(callee);
 
   do {
-    Assert(Is_ocaml_node(node));
+    CAMLassert(Is_ocaml_node(node));
     if (Node_pc(node) == pc) {
       found = node;
     }
@@ -497,7 +507,7 @@ CAMLprim value caml_spacetime_allocate_node(
      that tail called the current function.  (Such a value is necessary to
      be able to find the start of the caller's node, and hence its tail
      chain, so we as a tail-called callee can link ourselves in.) */
-  Assert(Is_tail_caller_node_encoded(node));
+  CAMLassert(Is_tail_caller_node_encoded(node));
 
   if (node != Val_unit) {
     value tail_node;
@@ -517,7 +527,7 @@ CAMLprim value caml_spacetime_allocate_node(
   node = allocate_uninitialized_ocaml_node(size_including_header);
   Hd_val(node) =
     Make_header(size_including_header - 1, OCaml_node_tag, Caml_black);
-  Assert((((uintnat) pc) % 1) == 0);
+  CAMLassert((((uintnat) pc) % 1) == 0);
   Node_pc(node) = Encode_node_pc(pc);
   /* If the callee was tail called, then the tail link field will link this
      new node into an existing tail chain.  Otherwise, it is initialized with
@@ -555,12 +565,12 @@ static c_node* allocate_c_node(void)
   if (end_of_free_node_block - start_of_free_node_block < sizeof(c_node)) {
     reinitialise_free_node_block();
     node = (c_node*) start_of_free_node_block;
-    Assert(end_of_free_node_block - start_of_free_node_block
+    CAMLassert(end_of_free_node_block - start_of_free_node_block
       >= sizeof(c_node));
   }
   start_of_free_node_block += sizeof(c_node);
 
-  Assert((sizeof(c_node) % sizeof(uintnat)) == 0);
+  CAMLassert((sizeof(c_node) % sizeof(uintnat)) == 0);
 
   /* CR-soon mshinwell: remove this and pad the structure properly */
   for (index = 0; index < sizeof(c_node) / sizeof(value); index++) {
@@ -569,7 +579,8 @@ static c_node* allocate_c_node(void)
 
   node->gc_header =
     Make_header(sizeof(c_node)/sizeof(uintnat) - 1, C_node_tag, Caml_black);
-  node->data.callee_node = Val_unit;
+  node->data.call.callee_node = Val_unit;
+  node->data.call.call_count = Val_long(0);
   node->next = Val_unit;
 
   return node;
@@ -583,7 +594,7 @@ static c_node* allocate_c_node(void)
    call (e.g. [List.map] when not inlined). */
 static void* last_indirect_node_hole_ptr_callee;
 static value* last_indirect_node_hole_ptr_node_hole;
-static value* last_indirect_node_hole_ptr_result;
+static call_point* last_indirect_node_hole_ptr_result;
 
 CAMLprim value* caml_spacetime_indirect_node_hole_ptr
       (void* callee, value* node_hole, value caller_node)
@@ -597,7 +608,11 @@ CAMLprim value* caml_spacetime_indirect_node_hole_ptr
 
   if (callee == last_indirect_node_hole_ptr_callee
       && node_hole == last_indirect_node_hole_ptr_node_hole) {
-    return last_indirect_node_hole_ptr_result;
+#ifdef ENABLE_CALL_COUNTS
+    last_indirect_node_hole_ptr_result->call_count =
+      Val_long (Long_val (last_indirect_node_hole_ptr_result->call_count) + 1);
+#endif
+    return &(last_indirect_node_hole_ptr_result->callee_node);
   }
 
   last_indirect_node_hole_ptr_callee = callee;
@@ -606,16 +621,20 @@ CAMLprim value* caml_spacetime_indirect_node_hole_ptr
   encoded_callee = Encode_c_node_pc_for_call(callee);
 
   while (*node_hole != Val_unit) {
-    Assert(((uintnat) *node_hole) % sizeof(value) == 0);
+    CAMLassert(((uintnat) *node_hole) % sizeof(value) == 0);
 
     c_node = caml_spacetime_c_node_of_stored_pointer_not_null(*node_hole);
 
-    Assert(c_node != NULL);
-    Assert(caml_spacetime_classify_c_node(c_node) == CALL);
+    CAMLassert(c_node != NULL);
+    CAMLassert(caml_spacetime_classify_c_node(c_node) == CALL);
 
     if (c_node->pc == encoded_callee) {
-      last_indirect_node_hole_ptr_result = &(c_node->data.callee_node);
-      return last_indirect_node_hole_ptr_result;
+#ifdef ENABLE_CALL_COUNTS
+      c_node->data.call.call_count =
+        Val_long (Long_val(c_node->data.call.call_count) + 1);
+#endif
+      last_indirect_node_hole_ptr_result = &(c_node->data.call);
+      return &(last_indirect_node_hole_ptr_result->callee_node);
     }
     else {
       node_hole = &c_node->next;
@@ -630,17 +649,21 @@ CAMLprim value* caml_spacetime_indirect_node_hole_ptr
        Perform the initialization equivalent to that emitted by
        [Spacetime.code_for_function_prologue] for direct tail call
        sites. */
-    c_node->data.callee_node = Encode_tail_caller_node(caller_node);
+    c_node->data.call.callee_node = Encode_tail_caller_node(caller_node);
   }
 
   *node_hole = caml_spacetime_stored_pointer_of_c_node(c_node);
 
-  Assert(((uintnat) *node_hole) % sizeof(value) == 0);
-  Assert(*node_hole != Val_unit);
+  CAMLassert(((uintnat) *node_hole) % sizeof(value) == 0);
+  CAMLassert(*node_hole != Val_unit);
 
-  last_indirect_node_hole_ptr_result = &(c_node->data.callee_node);
+#ifdef ENABLE_CALL_COUNTS
+  c_node->data.call.call_count =
+    Val_long (Long_val(c_node->data.call.call_count) + 1);
+#endif
+  last_indirect_node_hole_ptr_result = &(c_node->data.call);
 
-  return last_indirect_node_hole_ptr_result;
+  return &(last_indirect_node_hole_ptr_result->callee_node);
 }
 
 /* Some notes on why caml_call_gc doesn't need a distinguished node.
@@ -726,7 +749,8 @@ static NOINLINE void* find_trie_node_from_libunwind(int for_allocation,
       have_frames_already = 1;
     }
     else {
-      frames = (struct ext_table*) malloc(sizeof(struct ext_table));
+      frames =
+        (struct ext_table*) caml_stat_alloc_noexc(sizeof(struct ext_table));
       if (!frames) {
         caml_fatal_error("Not enough memory for ext_table allocation");
       }
@@ -786,7 +810,7 @@ static NOINLINE void* find_trie_node_from_libunwind(int for_allocation,
   for (frame = frames->size - 1; frame >= innermost_frame; frame--) {
     c_node_type expected_type;
     void* pc = frames->contents[frame];
-    Assert (pc != (void*) caml_last_return_address);
+    CAMLassert (pc != (void*) caml_last_return_address);
 
     if (!for_allocation) {
       expected_type = CALL;
@@ -814,8 +838,8 @@ static NOINLINE void* find_trie_node_from_libunwind(int for_allocation,
       int found = 0;
 
       node = caml_spacetime_c_node_of_stored_pointer_not_null(*node_hole);
-      Assert(node != NULL);
-      Assert(node->next == Val_unit
+      CAMLassert(node != NULL);
+      CAMLassert(node->next == Val_unit
         || (((uintnat) (node->next)) % sizeof(value) == 0));
 
       prev = NULL;
@@ -831,7 +855,7 @@ static NOINLINE void* find_trie_node_from_libunwind(int for_allocation,
         }
       }
       if (!found) {
-        Assert(prev != NULL);
+        CAMLassert(prev != NULL);
         node = allocate_c_node();
         node->pc = (expected_type == CALL ? Encode_c_node_pc_for_call(pc)
           : Encode_c_node_pc_for_alloc_point(pc));
@@ -842,11 +866,11 @@ static NOINLINE void* find_trie_node_from_libunwind(int for_allocation,
       }
     }
 
-    Assert(node != NULL);
+    CAMLassert(node != NULL);
 
-    Assert(caml_spacetime_classify_c_node(node) == expected_type);
-    Assert(pc_inside_c_node_matches(node, pc));
-    node_hole = &node->data.callee_node;
+    CAMLassert(caml_spacetime_classify_c_node(node) == expected_type);
+    CAMLassert(pc_inside_c_node_matches(node, pc));
+    node_hole = &node->data.call.callee_node;
   }
 
   if (must_initialise_node_for_allocation) {
@@ -877,14 +901,14 @@ static NOINLINE void* find_trie_node_from_libunwind(int for_allocation,
   }
 
   if (for_allocation) {
-    Assert(caml_spacetime_classify_c_node(node) == ALLOCATION);
-    Assert(caml_spacetime_c_node_of_stored_pointer(node->next) != node);
-    Assert(Profinfo_hd(node->data.allocation.profinfo) > 0);
+    CAMLassert(caml_spacetime_classify_c_node(node) == ALLOCATION);
+    CAMLassert(caml_spacetime_c_node_of_stored_pointer(node->next) != node);
+    CAMLassert(Profinfo_hd(node->data.allocation.profinfo) > 0);
     node->data.allocation.count =
       Val_long(Long_val(node->data.allocation.count) + (1 + wosize));
   }
 
-  Assert(node->next != (value) NULL);
+  CAMLassert(node->next != (value) NULL);
 
   return for_allocation ? (void*) node : (void*) node_hole;
 #else
@@ -928,7 +952,7 @@ void caml_spacetime_c_to_ocaml(void* ocaml_entry_point,
     node = allocate_uninitialized_ocaml_node(size_including_header);
     Hd_val(node) =
       Make_header(size_including_header - 1, OCaml_node_tag, Caml_black);
-    Assert((((uintnat) identifying_pc_for_caml_start_program) % 1) == 0);
+    CAMLassert((((uintnat) identifying_pc_for_caml_start_program) % 1) == 0);
     Node_pc(node) = Encode_node_pc(identifying_pc_for_caml_start_program);
     Tail_link(node) = node;
     Indirect_pc_linked_list(node, Node_num_header_words) = Val_unit;
@@ -939,14 +963,14 @@ void caml_spacetime_c_to_ocaml(void* ocaml_entry_point,
     /* If there is a node here already, it should never be an initialized
        (but as yet unused) tail call point, since calls from OCaml into C
        are never tail calls (and no C -> C call is marked as tail). */
-    Assert(!Is_tail_caller_node_encoded(node));
+    CAMLassert(!Is_tail_caller_node_encoded(node));
   }
 
-  Assert(Is_ocaml_node(node));
-  Assert(Decode_node_pc(Node_pc(node))
+  CAMLassert(Is_ocaml_node(node));
+  CAMLassert(Decode_node_pc(Node_pc(node))
     == identifying_pc_for_caml_start_program);
-  Assert(Tail_link(node) == node);
-  Assert(Wosize_val(node) == Node_num_header_words + Indirect_num_fields);
+  CAMLassert(Tail_link(node) == node);
+  CAMLassert(Wosize_val(node) == Node_num_header_words + Indirect_num_fields);
 
   /* Search the node to find the node hole corresponding to the indirect
      call to the OCaml function. */
@@ -955,7 +979,7 @@ void caml_spacetime_c_to_ocaml(void* ocaml_entry_point,
       ocaml_entry_point,
       &Indirect_pc_linked_list(node, Node_num_header_words),
       Val_unit);
-  Assert(*caml_spacetime_trie_node_ptr == Val_unit
+  CAMLassert(*caml_spacetime_trie_node_ptr == Val_unit
     || Is_ocaml_node(*caml_spacetime_trie_node_ptr));
 }
 
@@ -987,7 +1011,7 @@ CAMLprim uintnat caml_spacetime_generate_profinfo (void* profinfo_words,
      (which already has to be done in the OCaml-generated code run before
      this function). */
   node = (value) profinfo_words;
-  Assert(Alloc_point_profinfo(node, 0) == Val_unit);
+  CAMLassert(Alloc_point_profinfo(node, 0) == Val_unit);
 
   /* The profinfo value is stored shifted to reduce the number of
      instructions required on the OCaml side.  It also enables us to use
@@ -996,11 +1020,11 @@ CAMLprim uintnat caml_spacetime_generate_profinfo (void* profinfo_words,
   profinfo = Make_header_with_profinfo(
     index_within_node, Infix_tag, Caml_black, profinfo);
 
-  Assert(!Is_block(profinfo));
+  CAMLassert(!Is_block(profinfo));
   Alloc_point_profinfo(node, 0) = profinfo;
   /* The count is set to zero by the initialisation when the node was
      created (see above). */
-  Assert(Alloc_point_count(node, 0) == Val_long(0));
+  CAMLassert(Alloc_point_count(node, 0) == Val_long(0));
 
   /* Add the new allocation point into the linked list of all allocation
      points. */
@@ -1008,7 +1032,7 @@ CAMLprim uintnat caml_spacetime_generate_profinfo (void* profinfo_words,
     Alloc_point_next_ptr(node, 0) = (value) &caml_all_allocation_points->count;
   }
   else {
-    Assert(Alloc_point_next_ptr(node, 0) == Val_unit);
+    CAMLassert(Alloc_point_next_ptr(node, 0) == Val_unit);
   }
   caml_all_allocation_points = (allocation_point*) node;
 

diff --git a/asmrun/spacetime_offline.c b/asmrun/spacetime_offline.c
index 8191a3004c873d0e4e16be82f5ad15417e06ec71..fa93e5da9995f993699c05f173efeb590aaa6b98 100644 (file)
--- a/asmrun/spacetime_offline.c
+++ b/asmrun/spacetime_offline.c
@@ -36,7 +36,11 @@
 #include "caml/sys.h"
 #include "caml/spacetime.h"
 
-#include "../config/s.h"
+#include "caml/s.h"
+
+#define SPACETIME_PROFINFO_WIDTH 26
+#define Spacetime_profinfo_hd(hd) \
+  (Gen_profinfo_hd(SPACETIME_PROFINFO_WIDTH, hd))
 
 #ifdef ARCH_SIXTYFOUR
 
@@ -48,7 +52,7 @@
 c_node* caml_spacetime_offline_c_node_of_stored_pointer_not_null
           (value node_stored)
 {
-  Assert(Is_c_node(node_stored));
+  CAMLassert(Is_c_node(node_stored));
   return (c_node*) Hp_val(node_stored);
 }
 
@@ -60,8 +64,8 @@ c_node_type caml_spacetime_offline_classify_c_node(c_node* node)
 CAMLprim value caml_spacetime_compare_node(
       value node1, value node2)
 {
-  Assert(!Is_in_value_area(node1));
-  Assert(!Is_in_value_area(node2));
+  CAMLassert(!Is_in_value_area(node1));
+  CAMLassert(!Is_in_value_area(node2));
 
   if (node1 == node2) {
     return Val_long(0);
@@ -85,19 +89,19 @@ CAMLprim value caml_spacetime_node_num_header_words(value unit)
 
 CAMLprim value caml_spacetime_is_ocaml_node(value node)
 {
-  Assert(Is_ocaml_node(node) || Is_c_node(node));
+  CAMLassert(Is_ocaml_node(node) || Is_c_node(node));
   return Val_bool(Is_ocaml_node(node));
 }
 
 CAMLprim value caml_spacetime_ocaml_function_identifier(value node)
 {
-  Assert(Is_ocaml_node(node));
+  CAMLassert(Is_ocaml_node(node));
   return caml_copy_int64((uint64_t) Decode_node_pc(Node_pc(node)));
 }
 
 CAMLprim value caml_spacetime_ocaml_tail_chain(value node)
 {
-  Assert(Is_ocaml_node(node));
+  CAMLassert(Is_ocaml_node(node));
   return Tail_link(node);
 }
 
@@ -107,7 +111,7 @@ CAMLprim value caml_spacetime_classify_direct_call_point
   uintnat field;
   value callee_node;
 
-  Assert(Is_ocaml_node(node));
+  CAMLassert(Is_ocaml_node(node));
 
   field = Long_val(offset);
 
@@ -127,14 +131,14 @@ CAMLprim value caml_spacetime_ocaml_allocation_point_annotation
 {
   uintnat profinfo_shifted;
   profinfo_shifted = (uintnat) Alloc_point_profinfo(node, Long_val(offset));
-  return Val_long(Profinfo_hd(profinfo_shifted));
+  return Val_long(Spacetime_profinfo_hd(profinfo_shifted));
 }
 
 CAMLprim value caml_spacetime_ocaml_allocation_point_count
       (value node, value offset)
 {
   value count = Alloc_point_count(node, Long_val(offset));
-  Assert(!Is_block(count));
+  CAMLassert(!Is_block(count));
   return count;
 }
 
@@ -144,26 +148,32 @@ CAMLprim value caml_spacetime_ocaml_direct_call_point_callee_node
   return Direct_callee_node(node, Long_val(offset));
 }
 
+CAMLprim value caml_spacetime_ocaml_direct_call_point_call_count
+(value node, value offset)
+{
+  return Direct_call_count(node, Long_val(offset));
+}
+
 CAMLprim value caml_spacetime_ocaml_indirect_call_point_callees
       (value node, value offset)
 {
   value callees = Indirect_pc_linked_list(node, Long_val(offset));
-  Assert(Is_block(callees));
-  Assert(Is_c_node(callees));
+  CAMLassert(Is_block(callees));
+  CAMLassert(Is_c_node(callees));
   return callees;
 }
 
 CAMLprim value caml_spacetime_c_node_is_call(value node)
 {
   c_node* c_node;
-  Assert(node != (value) NULL);
-  Assert(Is_c_node(node));
+  CAMLassert(node != (value) NULL);
+  CAMLassert(Is_c_node(node));
   c_node = caml_spacetime_offline_c_node_of_stored_pointer_not_null(node);
   switch (caml_spacetime_offline_classify_c_node(c_node)) {
     case CALL: return Val_true;
     case ALLOCATION: return Val_false;
   }
-  Assert(0);
+  CAMLassert(0);
   return Val_unit;  /* silence compiler warning */
 }
 
@@ -171,18 +181,18 @@ CAMLprim value caml_spacetime_c_node_next(value node)
 {
   c_node* c_node;
 
-  Assert(node != (value) NULL);
-  Assert(Is_c_node(node));
+  CAMLassert(node != (value) NULL);
+  CAMLassert(Is_c_node(node));
   c_node = caml_spacetime_offline_c_node_of_stored_pointer_not_null(node);
-  Assert(c_node->next == Val_unit || Is_c_node(c_node->next));
+  CAMLassert(c_node->next == Val_unit || Is_c_node(c_node->next));
   return c_node->next;
 }
 
 CAMLprim value caml_spacetime_c_node_call_site(value node)
 {
   c_node* c_node;
-  Assert(node != (value) NULL);
-  Assert(Is_c_node(node));
+  CAMLassert(node != (value) NULL);
+  CAMLassert(Is_c_node(node));
   c_node = caml_spacetime_offline_c_node_of_stored_pointer_not_null(node);
   return caml_copy_int64((uint64_t) Decode_c_node_pc(c_node->pc));
 }
@@ -190,38 +200,51 @@ CAMLprim value caml_spacetime_c_node_call_site(value node)
 CAMLprim value caml_spacetime_c_node_callee_node(value node)
 {
   c_node* c_node;
-  Assert(node != (value) NULL);
-  Assert(Is_c_node(node));
+  CAMLassert(node != (value) NULL);
+  CAMLassert(Is_c_node(node));
   c_node = caml_spacetime_offline_c_node_of_stored_pointer_not_null(node);
-  Assert(caml_spacetime_offline_classify_c_node(c_node) == CALL);
+  CAMLassert(caml_spacetime_offline_classify_c_node(c_node) == CALL);
   /* This might be an uninitialised tail call point: for example if an OCaml
      callee was indirectly called but the callee wasn't instrumented (e.g. a
      leaf function that doesn't allocate). */
-  if (Is_tail_caller_node_encoded(c_node->data.callee_node)) {
+  if (Is_tail_caller_node_encoded(c_node->data.call.callee_node)) {
     return Val_unit;
   }
-  return c_node->data.callee_node;
+  return c_node->data.call.callee_node;
+}
+
+CAMLprim value caml_spacetime_c_node_call_count(value node)
+{
+  c_node* c_node;
+  CAMLassert(node != (value) NULL);
+  CAMLassert(Is_c_node(node));
+  c_node = caml_spacetime_offline_c_node_of_stored_pointer_not_null(node);
+  CAMLassert(caml_spacetime_offline_classify_c_node(c_node) == CALL);
+  if (Is_tail_caller_node_encoded(c_node->data.call.callee_node)) {
+    return Val_long(0);
+  }
+  return c_node->data.call.call_count;
 }
 
 CAMLprim value caml_spacetime_c_node_profinfo(value node)
 {
   c_node* c_node;
-  Assert(node != (value) NULL);
-  Assert(Is_c_node(node));
+  CAMLassert(node != (value) NULL);
+  CAMLassert(Is_c_node(node));
   c_node = caml_spacetime_offline_c_node_of_stored_pointer_not_null(node);
-  Assert(caml_spacetime_offline_classify_c_node(c_node) == ALLOCATION);
-  Assert(!Is_block(c_node->data.allocation.profinfo));
-  return Val_long(Profinfo_hd(c_node->data.allocation.profinfo));
+  CAMLassert(caml_spacetime_offline_classify_c_node(c_node) == ALLOCATION);
+  CAMLassert(!Is_block(c_node->data.allocation.profinfo));
+  return Val_long(Spacetime_profinfo_hd(c_node->data.allocation.profinfo));
 }
 
 CAMLprim value caml_spacetime_c_node_allocation_count(value node)
 {
   c_node* c_node;
-  Assert(node != (value) NULL);
-  Assert(Is_c_node(node));
+  CAMLassert(node != (value) NULL);
+  CAMLassert(Is_c_node(node));
   c_node = caml_spacetime_offline_c_node_of_stored_pointer_not_null(node);
-  Assert(caml_spacetime_offline_classify_c_node(c_node) == ALLOCATION);
-  Assert(!Is_block(c_node->data.allocation.count));
+  CAMLassert(caml_spacetime_offline_classify_c_node(c_node) == ALLOCATION);
+  CAMLassert(!Is_block(c_node->data.allocation.count));
   return c_node->data.allocation.count;
 }
 

diff --git a/asmrun/spacetime_snapshot.c b/asmrun/spacetime_snapshot.c
index 0f425e19530c26f6c1a44835b2180bd3f20b6b8b..a89b730aeb6ace963c293bd16d77e3f0cc6ebab9 100644 (file)
--- a/asmrun/spacetime_snapshot.c
+++ b/asmrun/spacetime_snapshot.c
@@ -88,7 +88,7 @@ static value allocate_outside_heap_with_tag(mlsize_t size_in_bytes, tag_t tag)
   /* CR-soon mshinwell: this function should live somewhere else */
   header_t* block;
 
-  Assert(size_in_bytes % sizeof(value) == 0);
+  CAMLassert(size_in_bytes % sizeof(value) == 0);
   block = caml_stat_alloc(sizeof(header_t) + size_in_bytes);
   *block = Make_header(size_in_bytes / sizeof(value), tag, Caml_black);
   return (value) &block[1];
@@ -96,7 +96,7 @@ static value allocate_outside_heap_with_tag(mlsize_t size_in_bytes, tag_t tag)
 
 static value allocate_outside_heap(mlsize_t size_in_bytes)
 {
-  Assert(size_in_bytes > 0);
+  CAMLassert(size_in_bytes > 0);
   return allocate_outside_heap_with_tag(size_in_bytes, 0);
 }
 
@@ -138,7 +138,7 @@ static value get_total_allocations(void)
     Field(v_total, 2) = v_total_allocations;
     v_total_allocations = v_total;
 
-    Assert (total->next == Val_unit
+    CAMLassert (total->next == Val_unit
       || (Is_block(total->next) && Tag_val(total->next) == Infix_tag));
     if (total->next == Val_unit) {
       total = NULL;
@@ -217,7 +217,7 @@ static value take_snapshot(double time_override, int use_time_override)
             words_scanned += Whsize_hd(hd);
             if (profinfo > 0 && profinfo < PROFINFO_MASK) {
               words_scanned_with_profinfo += Whsize_hd(hd);
-              Assert (raw_entries[profinfo].num_blocks >= 0);
+              CAMLassert (raw_entries[profinfo].num_blocks >= 0);
               if (raw_entries[profinfo].num_blocks == 0) {
                 num_distinct_profinfos++;
               }
@@ -229,7 +229,7 @@ static value take_snapshot(double time_override, int use_time_override)
           break;
       }
       hp += Bhsize_hd (hd);
-      Assert (hp <= limit);
+      CAMLassert (hp <= limit);
     }
 
     chunk = Chunk_next (chunk);
@@ -241,9 +241,9 @@ static value take_snapshot(double time_override, int use_time_override)
     entries = (snapshot_entries*) v_entries;
     target_index = 0;
     for (index = 0; index <= PROFINFO_MASK; index++) {
-      Assert(raw_entries[index].num_blocks >= 0);
+      CAMLassert(raw_entries[index].num_blocks >= 0);
       if (raw_entries[index].num_blocks > 0) {
-        Assert(target_index < num_distinct_profinfos);
+        CAMLassert(target_index < num_distinct_profinfos);
         entries->entries[target_index].profinfo = Val_long(index);
         entries->entries[target_index].num_blocks
           = Val_long(raw_entries[index].num_blocks);
@@ -256,9 +256,9 @@ static value take_snapshot(double time_override, int use_time_override)
     v_entries = Atom(0);
   }
 
-  Assert(sizeof(double) == sizeof(value));
+  CAMLassert(sizeof(double) == sizeof(value));
   v_time = allocate_outside_heap_with_tag(sizeof(double), Double_tag);
-  Double_field(v_time, 0) = time;
+  Store_double_val(v_time, time);
 
   v_snapshot = allocate_outside_heap(sizeof(snapshot));
   heap_snapshot = (snapshot*) v_snapshot;
@@ -356,7 +356,7 @@ copy_string_outside_heap(char const *s)
   Field (result, wosize - 1) = 0;
   offset_index = Bsize_wsize (wosize) - 1;
   Byte (result, offset_index) = offset_index - len;
-  memmove(String_val(result), s, len);
+  memmove(Bytes_val(result), s, len);
 
   return result;
 }
@@ -394,7 +394,7 @@ value caml_spacetime_timestamp(double time_override, int use_time_override)
   }
 
   v_time = allocate_outside_heap_with_tag(sizeof(double), Double_tag);
-  Double_field(v_time, 0) = time;
+  Store_double_val(v_time, time);
 
   return v_time;
 }
@@ -497,7 +497,7 @@ static void add_unit_to_shape_table(uint64_t *unit_table, value *list)
           break;
 
         default:
-          Assert(0);
+          CAMLassert(0);
           abort();  /* silence compiler warning */
       }
 
@@ -569,7 +569,6 @@ value caml_spacetime_shape_table(void)
 static value spacetime_disabled()
 {
   caml_failwith("Spacetime profiling not enabled");
-  Assert(0);  /* unreachable */
 }
 
 CAMLprim value caml_spacetime_take_snapshot(value ignored)

diff --git a/asmrun/sparc.S b/asmrun/sparc.S
deleted file mode 100644 (file)
index b46e71f..0000000
--- a/asmrun/sparc.S
+++ /dev/null
@@ -1,360 +0,0 @@
-/**************************************************************************/
-/*                                                                        */
-/*                                 OCaml                                  */
-/*                                                                        */
-/*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           */
-/*                                                                        */
-/*   Copyright 1996 Institut National de Recherche en Informatique et     */
-/*     en Automatique.                                                    */
-/*                                                                        */
-/*   All rights reserved.  This file is distributed under the terms of    */
-/*   the GNU Lesser General Public License version 2.1, with the          */
-/*   special exception on linking described in the file LICENSE.          */
-/*                                                                        */
-/**************************************************************************/
-
-/* Asm part of the runtime system for the Sparc processor.  */
-/* Must be preprocessed by cpp */
-
-#ifndef SYS_solaris
-#define INDIRECT_LIMIT
-#endif
-
-#define Exn_ptr %l5
-#define Alloc_ptr %l6
-#define Alloc_limit %l7
-
-#define Load(symb,reg)  sethi %hi(symb), %g1; ld [%g1 + %lo(symb)], reg
-#define Store(reg,symb) sethi %hi(symb), %g1; st reg, [%g1 + %lo(symb)]
-#define Address(symb,reg) sethi %hi(symb), reg; or reg, %lo(symb), reg
-
-/* Allocation functions */
-
-        .text
-
-        .global  caml_system__code_begin
-caml_system__code_begin:
-
-        .global caml_allocN
-        .global caml_call_gc
-
-/* Required size in %g2 */
-caml_allocN:
-#ifdef INDIRECT_LIMIT
-        ld      [Alloc_limit], %g1
-        sub     Alloc_ptr, %g2, Alloc_ptr
-        cmp     Alloc_ptr, %g1
-#else
-        sub     Alloc_ptr, %g2, Alloc_ptr
-        cmp     Alloc_ptr, Alloc_limit
-#endif
-        /*blu,pt  %icc, caml_call_gc*/
-        blu     caml_call_gc
-        nop
-        retl
-        nop
-
-/* Required size in %g2 */
-caml_call_gc:
-    /* Save exception pointer if GC raises */
-        Store(Exn_ptr, caml_exception_pointer)
-    /* Save current allocation pointer for debugging purposes */
-        Store(Alloc_ptr, caml_young_ptr)
-    /* Record lowest stack address */
-        Store(%sp, caml_bottom_of_stack)
-    /* Record last return address */
-        Store(%o7, caml_last_return_address)
-    /* Allocate space on stack for caml_context structure and float regs */
-        sub     %sp, 20*4 + 15*8, %sp
-    /* Save int regs on stack and save it into caml_gc_regs */
-L100:   add     %sp, 96 + 15*8, %g1
-        st      %o0, [%g1]
-        st      %o1, [%g1 + 0x4]
-        st      %o2, [%g1 + 0x8]
-        st      %o3, [%g1 + 0xc]
-        st      %o4, [%g1 + 0x10]
-        st      %o5, [%g1 + 0x14]
-        st      %i0, [%g1 + 0x18]
-        st      %i1, [%g1 + 0x1c]
-        st      %i2, [%g1 + 0x20]
-        st      %i3, [%g1 + 0x24]
-        st      %i4, [%g1 + 0x28]
-        st      %i5, [%g1 + 0x2c]
-        st      %l0, [%g1 + 0x30]
-        st      %l1, [%g1 + 0x34]
-        st      %l2, [%g1 + 0x38]
-        st      %l3, [%g1 + 0x3c]
-        st      %l4, [%g1 + 0x40]
-        st      %g3, [%g1 + 0x44]
-        st      %g4, [%g1 + 0x48]
-        st      %g2, [%g1 + 0x4C]       /* Save required size */
-        mov     %g1, %g2
-        Store(%g2, caml_gc_regs)
-    /* Save the floating-point registers */
-        add     %sp, 96, %g1
-        std     %f0, [%g1]
-        std     %f2, [%g1 + 0x8]
-        std     %f4, [%g1 + 0x10]
-        std     %f6, [%g1 + 0x18]
-        std     %f8, [%g1 + 0x20]
-        std     %f10, [%g1 + 0x28]
-        std     %f12, [%g1 + 0x30]
-        std     %f14, [%g1 + 0x38]
-        std     %f16, [%g1 + 0x40]
-        std     %f18, [%g1 + 0x48]
-        std     %f20, [%g1 + 0x50]
-        std     %f22, [%g1 + 0x58]
-        std     %f24, [%g1 + 0x60]
-        std     %f26, [%g1 + 0x68]
-        std     %f28, [%g1 + 0x70]
-    /* Call the garbage collector */
-        call    caml_garbage_collection
-        nop
-    /* Restore all regs used by the code generator */
-        add     %sp, 96 + 15*8, %g1
-        ld      [%g1], %o0
-        ld      [%g1 + 0x4], %o1
-        ld      [%g1 + 0x8], %o2
-        ld      [%g1 + 0xc], %o3
-        ld      [%g1 + 0x10], %o4
-        ld      [%g1 + 0x14], %o5
-        ld      [%g1 + 0x18], %i0
-        ld      [%g1 + 0x1c], %i1
-        ld      [%g1 + 0x20], %i2
-        ld      [%g1 + 0x24], %i3
-        ld      [%g1 + 0x28], %i4
-        ld      [%g1 + 0x2c], %i5
-        ld      [%g1 + 0x30], %l0
-        ld      [%g1 + 0x34], %l1
-        ld      [%g1 + 0x38], %l2
-        ld      [%g1 + 0x3c], %l3
-        ld      [%g1 + 0x40], %l4
-        ld      [%g1 + 0x44], %g3
-        ld      [%g1 + 0x48], %g4
-        ld      [%g1 + 0x4C], %g2     /* Recover desired size */
-        add     %sp, 96, %g1
-        ldd     [%g1], %f0
-        ldd     [%g1 + 0x8], %f2
-        ldd     [%g1 + 0x10], %f4
-        ldd     [%g1 + 0x18], %f6
-        ldd     [%g1 + 0x20], %f8
-        ldd     [%g1 + 0x28], %f10
-        ldd     [%g1 + 0x30], %f12
-        ldd     [%g1 + 0x38], %f14
-        ldd     [%g1 + 0x40], %f16
-        ldd     [%g1 + 0x48], %f18
-        ldd     [%g1 + 0x50], %f20
-        ldd     [%g1 + 0x58], %f22
-        ldd     [%g1 + 0x60], %f24
-        ldd     [%g1 + 0x68], %f26
-        ldd     [%g1 + 0x70], %f28
-    /* Reload alloc ptr */
-        Load(caml_young_ptr, Alloc_ptr)
-    /* Allocate space for block */
-#ifdef INDIRECT_LIMIT
-        ld      [Alloc_limit], %g1
-        sub     Alloc_ptr, %g2, Alloc_ptr
-        cmp     Alloc_ptr, %g1      /* Check that we have enough free space */
-#else
-        Load(caml_young_limit,Alloc_limit)
-        sub     Alloc_ptr, %g2, Alloc_ptr
-        cmp     Alloc_ptr, Alloc_limit
-#endif
-        blu     L100                /* If not, call GC again */
-        nop
-    /* Return to caller */
-        Load(caml_last_return_address, %o7)
-        retl
-        add     %sp, 20*4 + 15*8, %sp       /* in delay slot */
-
-/* Call a C function from Ocaml */
-
-        .global caml_c_call
-/* Function to call is in %g2 */
-caml_c_call:
-    /* Record lowest stack address and return address */
-        Store(%sp, caml_bottom_of_stack)
-        Store(%o7, caml_last_return_address)
-    /* Save the exception handler and alloc pointer */
-        Store(Exn_ptr, caml_exception_pointer)
-        sethi   %hi(caml_young_ptr), %g1
-    /* Call the C function */
-        call    %g2
-        st      Alloc_ptr, [%g1 + %lo(caml_young_ptr)]   /* in delay slot */
-    /* Reload return address */
-        Load(caml_last_return_address, %o7)
-    /* Reload alloc pointer */
-        sethi   %hi(caml_young_ptr), %g1
-    /* Return to caller */
-        retl
-        ld      [%g1 + %lo(caml_young_ptr)], Alloc_ptr   /* in delay slot */
-
-/* Start the Ocaml program */
-
-        .global caml_start_program
-caml_start_program:
-    /* Save all callee-save registers */
-        save    %sp, -96, %sp
-    /* Address of code to call */
-        Address(caml_program, %l2)
-
-    /* Code shared with caml_callback* */
-L108:
-    /* Set up a callback link on the stack. */
-        sub     %sp, 16, %sp
-        Load(caml_bottom_of_stack, %l0)
-        Load(caml_last_return_address, %l1)
-        Load(caml_gc_regs, %l3)
-        st      %l0, [%sp + 96]
-        st      %l1, [%sp + 100]
-    /* Set up a trap frame to catch exceptions escaping the Ocaml code */
-        call    L111
-        st      %l3, [%sp + 104]
-        b       L110
-        nop
-L111:   sub     %sp, 8, %sp
-        Load(caml_exception_pointer, Exn_ptr)
-        st      %o7, [%sp + 96]
-        st      Exn_ptr, [%sp + 100]
-        mov     %sp, Exn_ptr
-    /* Reload allocation pointers */
-        Load(caml_young_ptr, Alloc_ptr)
-#ifdef INDIRECT_LIMIT
-        Address(caml_young_limit, Alloc_limit)
-#else
-        Load(caml_young_limit, Alloc_limit)
-#endif
-    /* Call the Ocaml code */
-L109:   call    %l2
-        nop
-    /* Pop trap frame and restore caml_exception_pointer */
-        ld      [%sp + 100], Exn_ptr
-        add     %sp, 8, %sp
-        Store(Exn_ptr, caml_exception_pointer)
-    /* Pop callback link, restoring the global variables */
-L112:   ld      [%sp + 96], %l0
-        ld      [%sp + 100], %l1
-        ld      [%sp + 104], %l2
-        Store(%l0, caml_bottom_of_stack)
-        Store(%l1, caml_last_return_address)
-        Store(%l2, caml_gc_regs)
-        add     %sp, 16, %sp
-    /* Save allocation pointer */
-        Store(Alloc_ptr, caml_young_ptr)
-    /* Reload callee-save registers and return */
-        ret
-        restore %o0, 0, %o0     /* copy %o0 in this window to caller's %o0 */
-L110:
-    /* The trap handler */
-        Store(Exn_ptr, caml_exception_pointer)
-    /* Encode exception bucket as an exception result */
-        b       L112
-        or      %o0, 2, %o0
-
-/* Raise an exception from C */
-
-        .global caml_raise_exception
-caml_raise_exception:
-    /* Save exception bucket in a register outside the reg windows */
-        mov     %o0, %g2
-    /* Load exception pointer in a register outside the reg windows */
-        Load(caml_exception_pointer, %g3)
-    /* Pop some frames until the trap pointer is in the current frame. */
-        cmp     %g3, %fp
-        blt     L107                    /* if Exn_ptr < %fp, over */
-        nop
-L106:   restore
-        cmp     %fp, %g3                /* if %fp <= Exn_ptr, loop */
-        ble     L106
-        nop
-L107:
-    /* Reload allocation registers */
-        Load(caml_young_ptr, Alloc_ptr)
-#ifdef INDIRECT_LIMIT
-        Address(caml_young_limit, Alloc_limit)
-#else
-        Load(caml_young_limit, Alloc_limit)
-#endif
-    /* Branch to exception handler */
-        mov     %g3, %sp
-        ld      [%sp + 96], %g1
-        ld      [%sp + 100], Exn_ptr
-        add     %sp, 8, %sp
-        jmp     %g1 + 8
-    /* Restore bucket, in delay slot */
-        mov     %g2, %o0
-
-/* Callbacks C -> ML */
-
-        .global caml_callback_exn
-caml_callback_exn:
-    /* Save callee-save registers and return address */
-        save    %sp, -96, %sp
-    /* Initial shuffling of arguments */
-        mov     %i0, %g1
-        mov     %i1, %i0        /* first arg */
-        mov     %g1, %i1        /* environment */
-        b       L108
-        ld      [%g1], %l2      /* code pointer */
-
-        .global caml_callback2_exn
-caml_callback2_exn:
-    /* Save callee-save registers and return address */
-        save    %sp, -104, %sp
-    /* Initial shuffling of arguments */
-        mov     %i0, %g1
-        mov     %i1, %i0        /* first arg */
-        mov     %i2, %i1        /* second arg */
-        mov     %g1, %i2        /* environment */
-        sethi   %hi(caml_apply2), %l2
-        b       L108
-        or      %l2, %lo(caml_apply2), %l2
-
-        .global caml_callback3_exn
-caml_callback3_exn:
-    /* Save callee-save registers and return address */
-        save    %sp, -104, %sp
-    /* Initial shuffling of arguments */
-        mov     %i0, %g1
-        mov     %i1, %i0        /* first arg */
-        mov     %i2, %i1        /* second arg */
-        mov     %i3, %i2        /* third arg */
-        mov     %g1, %i3        /* environment */
-        sethi   %hi(caml_apply3), %l2
-        b       L108
-        or      %l2, %lo(caml_apply3), %l2
-
-#ifndef SYS_solaris
-/* Glue code to call [caml_array_bound_error] */
-
-        .global caml_ml_array_bound_error
-caml_ml_array_bound_error:
-        Address(caml_array_bound_error, %g2)
-        b       caml_c_call
-        nop
-#endif
-
-        .global caml_system__code_end
-caml_system__code_end:
-
-#ifdef SYS_solaris
-        .section ".rodata"
-#else
-        .data
-#endif
-        .global caml_system__frametable
-        .align  4               /* required for gas? */
-caml_system__frametable:
-        .word   1               /* one descriptor */
-        .word   L109            /* return address into callback */
-        .half   -1              /* negative frame size => use callback link */
-        .half   0               /* no roots */
-
-#ifdef SYS_solaris
-        .type caml_allocN, #function
-        .type caml_call_gc, #function
-        .type caml_c_call, #function
-        .type caml_start_program, #function
-        .type caml_raise_exception, #function
-        .type caml_system__frametable, #object
-#endif

diff --git a/asmrun/startup.c b/asmrun/startup.c
index 70bbc4369dc596c599b6103d627906e8f32bb61d..60dca0138368a1e615647b1d89e506f827c143b5 100644 (file)
--- a/asmrun/startup.c
+++ b/asmrun/startup.c
@@ -92,6 +92,9 @@ void (*caml_termination_hook)(void *) = NULL;
 extern value caml_start_program (void);
 extern void caml_init_ieee_floats (void);
 extern void caml_init_signals (void);
+#ifdef _WIN32
+extern void caml_win32_overflow_detection (void);
+#endif
 
 #if defined(_MSC_VER) && __STDC_SECURE_LIB__ >= 200411L
 
@@ -100,11 +103,24 @@ extern void caml_install_invalid_parameter_handler();
 
 #endif
 
-value caml_startup_exn(char **argv)
+value caml_startup_common(char_os **argv, int pooling)
 {
-  char * exe_name, * proc_self_exe;
+  char_os * exe_name, * proc_self_exe;
   char tos;
 
+  /* Determine options */
+#ifdef DEBUG
+  caml_verb_gc = 0x3F;
+#endif
+  caml_parse_ocamlrunparam();
+#ifdef DEBUG
+  caml_gc_message (-1, "### OCaml runtime: debug mode ###\n");
+#endif
+  if (caml_cleanup_on_exit)
+    pooling = 1;
+  if (!caml_startup_aux(pooling))
+    return Val_unit;
+
 #ifdef WITH_SPACETIME
   caml_spacetime_initialize();
 #endif
@@ -115,22 +131,18 @@ value caml_startup_exn(char **argv)
 #endif
   caml_init_custom_operations();
   caml_top_of_stack = &tos;
-#ifdef DEBUG
-  caml_verb_gc = 0x3F;
-#endif
-  caml_parse_ocamlrunparam();
-#ifdef DEBUG
-  caml_gc_message (-1, "### OCaml runtime: debug mode ###\n", 0);
-#endif
   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_major_window);
   init_static();
   caml_init_signals();
+#ifdef _WIN32
+  caml_win32_overflow_detection();
+#endif
   caml_init_backtrace();
   caml_debugger_init (); /* force debugger.o stub to be linked */
   exe_name = argv[0];
-  if (exe_name == NULL) exe_name = "";
+  if (exe_name == NULL) exe_name = _T("");
   proc_self_exe = caml_executable_name();
   if (proc_self_exe != NULL)
     exe_name = proc_self_exe;
@@ -144,16 +156,31 @@ value caml_startup_exn(char **argv)
   return caml_start_program();
 }
 
-void caml_startup(char **argv)
+value caml_startup_exn(char_os **argv)
 {
-  value res = caml_startup_exn(argv);
+  return caml_startup_common(argv, /* pooling */ 0);
+}
 
-  if (Is_exception_result(res)) {
+void caml_startup(char_os **argv)
+{
+  value res = caml_startup_exn(argv);
+  if (Is_exception_result(res))
     caml_fatal_uncaught_exception(Extract_exception(res));
-  }
 }
 
-void caml_main(char **argv)
+void caml_main(char_os **argv)
 {
   caml_startup(argv);
 }
+
+value caml_startup_pooled_exn(char_os **argv)
+{
+  return caml_startup_common(argv, /* pooling */ 1);
+}
+
+void caml_startup_pooled(char_os **argv)
+{
+  value res = caml_startup_pooled_exn(argv);
+  if (Is_exception_result(res))
+    caml_fatal_uncaught_exception(Extract_exception(res));
+}

diff --git a/boot/ocamlc b/boot/ocamlc
index 6096b0c99c3c605688c806fd2a6ee18afb0d1e98..95c6f59d5197c18f58c468294a37dd5a47101a10 100755 (executable)
Binary files a/boot/ocamlc and b/boot/ocamlc differ

diff --git a/boot/ocamldep b/boot/ocamldep
index fd39892fec88b0213d43d4019b2a2ff1ecb2c881..b59eabb31c18db40bd4c43030ba7e96c2abf89ad 100755 (executable)
Binary files a/boot/ocamldep and b/boot/ocamldep differ

diff --git a/boot/ocamllex b/boot/ocamllex
index b42a2f18ef4c4a945974f1fe7a9fea79238475eb..084dce874edfd9dec2e9ca3bc3f5089e54b5c2ca 100755 (executable)
Binary files a/boot/ocamllex and b/boot/ocamllex differ

diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml
index d8fb5c68078320786b9856bb036be4df8bb7c8ed..6368cdcaf77e686fd388520aec4635a66abf6b6a 100644 (file)
--- a/bytecomp/bytegen.ml
+++ b/bytecomp/bytegen.ml
@@ -142,7 +142,9 @@ let rec check_recordwith_updates id e =
   | _ -> false
 ;;
 
-let rec size_of_lambda = function
+let rec size_of_lambda env = function
+  | Lvar id ->
+      begin try Ident.find_same id env with Not_found -> RHS_nonrec end
   | Lfunction{params} as funct ->
       RHS_function (1 + IdentSet.cardinal(free_variables funct),
                     List.length params)
@@ -154,14 +156,23 @@ let rec size_of_lambda = function
       | Record_float -> RHS_floatblock size
       | Record_extension -> RHS_block (size + 1)
       end
-  | Llet(_str, _k, _id, _arg, body) -> size_of_lambda body
-  | Lletrec(_bindings, body) -> size_of_lambda body
+  | Llet(_str, _k, id, arg, body) ->
+      size_of_lambda (Ident.add id (size_of_lambda env arg) env) body
+  | Lletrec(bindings, body) ->
+      let env = List.fold_right
+        (fun (id, e) env -> Ident.add id (size_of_lambda env e) env)
+        bindings env
+      in
+      size_of_lambda env body
   | Lprim(Pmakeblock _, args, _) -> RHS_block (List.length args)
   | Lprim (Pmakearray ((Paddrarray|Pintarray), _), args, _) ->
       RHS_block (List.length args)
   | Lprim (Pmakearray (Pfloatarray, _), args, _) ->
       RHS_floatblock (List.length args)
-  | Lprim (Pmakearray (Pgenarray, _), _, _) -> assert false
+  | Lprim (Pmakearray (Pgenarray, _), _, _) ->
+     (* Pgenarray is excluded from recursive bindings by the
+        check in Translcore.check_recursive_lambda *)
+      RHS_nonrec
   | Lprim (Pduprecord ((Record_regular | Record_inlined _), size), _, _) ->
       RHS_block size
   | Lprim (Pduprecord (Record_unboxed _, _), _, _) ->
@@ -169,8 +180,8 @@ let rec size_of_lambda = function
   | Lprim (Pduprecord (Record_extension, size), _, _) ->
       RHS_block (size + 1)
   | Lprim (Pduprecord (Record_float, size), _, _) -> RHS_floatblock size
-  | Levent (lam, _) -> size_of_lambda lam
-  | Lsequence (_lam, lam') -> size_of_lambda lam'
+  | Levent (lam, _) -> size_of_lambda env lam
+  | Lsequence (_lam, lam') -> size_of_lambda env lam'
   | _ -> RHS_nonrec
 
 (**** Merging consecutive events ****)
@@ -365,16 +376,16 @@ let comp_primitive p args =
   | Pstring_set_64(_) -> Kccall("caml_string_set64", 3)
   | Parraylength _ -> Kvectlength
   | Parrayrefs Pgenarray -> Kccall("caml_array_get", 2)
-  | Parrayrefs Pfloatarray -> Kccall("caml_array_get_float", 2)
+  | Parrayrefs Pfloatarray -> Kccall("caml_floatarray_get", 2)
   | Parrayrefs _ -> Kccall("caml_array_get_addr", 2)
   | Parraysets Pgenarray -> Kccall("caml_array_set", 3)
-  | Parraysets Pfloatarray -> Kccall("caml_array_set_float", 3)
+  | Parraysets Pfloatarray -> Kccall("caml_floatarray_set", 3)
   | Parraysets _ -> Kccall("caml_array_set_addr", 3)
   | Parrayrefu Pgenarray -> Kccall("caml_array_unsafe_get", 2)
-  | Parrayrefu Pfloatarray -> Kccall("caml_array_unsafe_get_float", 2)
+  | Parrayrefu Pfloatarray -> Kccall("caml_floatarray_unsafe_get", 2)
   | Parrayrefu _ -> Kgetvectitem
   | Parraysetu Pgenarray -> Kccall("caml_array_unsafe_set", 3)
-  | Parraysetu Pfloatarray -> Kccall("caml_array_unsafe_set_float", 3)
+  | Parraysetu Pfloatarray -> Kccall("caml_floatarray_unsafe_set", 3)
   | Parraysetu _ -> Ksetvectitem
   | Pctconst c ->
      let const_name = match c with
@@ -435,6 +446,7 @@ let is_immed n = immed_min <= n && n <= immed_max
 module Storer =
   Switch.Store
     (struct type t = lambda type key = lambda
+      let compare_key = Pervasives.compare
       let make_key = Lambda.make_key end)
 
 (* Compile an expression.
@@ -543,7 +555,7 @@ let rec comp_expr env exp sz cont =
                        (add_pop ndecl cont)))
       end else begin
         let decl_size =
-          List.map (fun (id, exp) -> (id, exp, size_of_lambda exp)) decl in
+          List.map (fun (id, exp) -> (id, exp, size_of_lambda Ident.empty exp)) decl in
         let rec comp_init new_env sz = function
           | [] -> comp_nonrec new_env sz ndecl decl_size
           | (id, _exp, RHS_floatblock blocksize) :: rem ->
@@ -670,7 +682,7 @@ let rec comp_expr env exp sz cont =
       comp_expr env (Lprim (Pccall prim_obj_dup, [arg], loc)) sz cont
   | Lprim (Pduparray _, _, _) ->
       Misc.fatal_error "Bytegen.comp_expr: Pduparray takes exactly one arg"
-(* Integer first for enabling futher optimization (cf. emitcode.ml)  *)
+(* Integer first for enabling further optimization (cf. emitcode.ml)  *)
   | Lprim (Pintcomp c, [arg ; (Lconst _ as k)], _) ->
       let p = Pintcomp (commute_comparison c)
       and args = [k ; arg] in
@@ -755,7 +767,7 @@ let rec comp_expr env exp sz cont =
              (Kacc 1 :: Kpush :: Koffsetint offset :: Kassign 2 ::
               Kacc 1 :: Kintcomp Cneq :: Kbranchif lbl_loop ::
               Klabel lbl_exit :: add_const_unit (add_pop 2 cont))))
-  | Lswitch(arg, sw) ->
+  | Lswitch(arg, sw, _loc) ->
       let (branch, cont1) = make_branch cont in
       let c = ref (discard_dead_code cont1) in
 
@@ -860,6 +872,8 @@ let rec comp_expr env exp sz cont =
           let ev = event (Event_after ty) info in
           let cont1 = add_event ev cont in
           comp_expr env lam sz cont1
+      | Lev_module_definition _ ->
+          comp_expr env lam sz cont
       end
   | Lifused (_, exp) ->
       comp_expr env exp sz cont

diff --git a/bytecomp/bytelibrarian.ml b/bytecomp/bytelibrarian.ml
index a3ba3ba44846f54547fff4d6761ead652e36c591..a905801fe64456b12a5301095a9cd42716099e32 100644 (file)
--- a/bytecomp/bytelibrarian.ml
+++ b/bytecomp/bytelibrarian.ml
@@ -103,7 +103,9 @@ let create_archive ppf file_list lib_name =
         lib_ccopts = !Clflags.all_ccopts @ !lib_ccopts;
         lib_dllibs = !Clflags.dllibs @ !lib_dllibs } in
     let pos_toc = pos_out outchan in
-    output_value outchan toc;
+    Emitcode.marshal_to_channel_with_possibly_32bit_compat
+      ~filename:lib_name ~kind:"bytecode library"
+      outchan toc;
     seek_out outchan ofs_pos_toc;
     output_binary_int outchan pos_toc;
     close_out outchan

diff --git a/bytecomp/bytelink.ml b/bytecomp/bytelink.ml
index 8f82fc96d0342cff9f296e4137c1edef329a0028..3ed3e68c7a7c2057018200142d4811e95a227827 100644 (file)
--- a/bytecomp/bytelink.ml
+++ b/bytecomp/bytelink.ml
@@ -28,7 +28,6 @@ type error =
   | Custom_runtime
   | File_exists of string
   | Cannot_open_dll of string
-  | Not_compatible_32
   | Required_module_unavailable of string
 
 exception Error of error
@@ -365,13 +364,9 @@ let link_bytecode ppf tolink exec_name standalone =
     Symtable.output_primitive_names outchan;
     Bytesections.record outchan "PRIM";
     (* The table of global data *)
-    begin try
-      Marshal.to_channel outchan (Symtable.initial_global_table())
-          (if !Clflags.bytecode_compatible_32
-           then [Marshal.Compat_32] else [])
-    with Failure _ ->
-      raise (Error Not_compatible_32)
-    end;
+    Emitcode.marshal_to_channel_with_possibly_32bit_compat
+      ~filename:exec_name ~kind:"bytecode executable"
+      outchan (Symtable.initial_global_table());
     Bytesections.record outchan "DATA";
     (* The map of global identifiers *)
     Symtable.output_global_map outchan;
@@ -456,15 +451,13 @@ let link_bytecode_as_c ppf tolink outfile =
   begin try
     (* The bytecode *)
     output_string outchan "\
-#ifdef __cplusplus\
+#define CAML_INTERNALS\
+\n\
+\n#ifdef __cplusplus\
 \nextern \"C\" {\
 \n#endif\
 \n#include <caml/mlvalues.h>\
-\nCAMLextern void caml_startup_code(\
-\n           code_t code, asize_t code_size,\
-\n           char *data, asize_t data_size,\
-\n           char *section_table, asize_t section_table_size,\
-\n           char **argv);\n";
+\n#include <caml/startup.h>\n";
     output_string outchan "static int caml_code[] = {\n";
     Symtable.init();
     clear_crc_interfaces ();
@@ -494,18 +487,39 @@ let link_bytecode_as_c ppf tolink outfile =
     Symtable.output_primitive_table outchan;
     (* The entry point *)
     output_string outchan "\
-\nvoid caml_startup(char ** argv)\
+\nvoid caml_startup(char_os ** argv)\
+\n{\
+\n  caml_startup_code(caml_code, sizeof(caml_code),\
+\n                    caml_data, sizeof(caml_data),\
+\n                    caml_sections, sizeof(caml_sections),\
+\n                    /* pooling */ 0,\
+\n                    argv);\
+\n}\
+\n\
+\nvalue caml_startup_exn(char_os ** argv)\
+\n{\
+\n  return caml_startup_code_exn(caml_code, sizeof(caml_code),\
+\n                               caml_data, sizeof(caml_data),\
+\n                               caml_sections, sizeof(caml_sections),\
+\n                               /* pooling */ 0,\
+\n                               argv);\
+\n}\
+\n\
+\nvoid caml_startup_pooled(char_os ** argv)\
 \n{\
 \n  caml_startup_code(caml_code, sizeof(caml_code),\
 \n                    caml_data, sizeof(caml_data),\
 \n                    caml_sections, sizeof(caml_sections),\
+\n                    /* pooling */ 1,\
 \n                    argv);\
 \n}\
-\nvalue caml_startup_exn(char ** argv)\
+\n\
+\nvalue caml_startup_pooled_exn(char_os ** argv)\
 \n{\
 \n  return caml_startup_code_exn(caml_code, sizeof(caml_code),\
 \n                               caml_data, sizeof(caml_data),\
 \n                               caml_sections, sizeof(caml_sections),\
+\n                               /* pooling */ 1,\
 \n                               argv);\
 \n}\
 \n#ifdef __cplusplus\
@@ -605,22 +619,26 @@ let link ppf objfiles output_name =
       raise x
   end else begin
     let basename = Filename.chop_extension output_name in
+    let temps = ref [] in
     let c_file =
-      if !Clflags.output_complete_object
+      if !Clflags.output_complete_object && not (Filename.check_suffix output_name ".c")
       then Filename.temp_file "camlobj" ".c"
-      else basename ^ ".c"
-    and obj_file =
+      else begin
+        let f = basename ^ ".c" in
+        if Sys.file_exists f then raise(Error(File_exists f));
+        f
+      end
+    in
+    let obj_file =
       if !Clflags.output_complete_object
-      then Filename.temp_file "camlobj" Config.ext_obj
+      then (Filename.chop_extension c_file) ^ 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
+        if Ccomp.compile_file ~output: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
@@ -675,9 +693,6 @@ let report_error ppf = function
   | Cannot_open_dll file ->
       fprintf ppf "Error on dynamically loaded library: %a"
         Location.print_filename file
-  | Not_compatible_32 ->
-      fprintf ppf "Generated bytecode executable cannot be run\
-                  \ on a 32-bit platform"
   | Required_module_unavailable s ->
       fprintf ppf "Required module `%s' is unavailable" s
 

diff --git a/bytecomp/bytelink.mli b/bytecomp/bytelink.mli
index 42084fe7aa1d6c92abb9e5367a3e92017f09b2b3..56439e26cc3f08e6d3ad97a826d14e5db7f40853 100644 (file)
--- a/bytecomp/bytelink.mli
+++ b/bytecomp/bytelink.mli
@@ -32,7 +32,6 @@ type error =
   | Custom_runtime
   | File_exists of string
   | Cannot_open_dll of string
-  | Not_compatible_32
   | Required_module_unavailable of string
 
 exception Error of error

diff --git a/bytecomp/bytepackager.ml b/bytecomp/bytepackager.ml
index 94c1182138eb98cc26d619c8e9a3b6a40b106198..ac78c34436636952e3b8525957c2516292444ef2 100644 (file)
--- a/bytecomp/bytepackager.ml
+++ b/bytecomp/bytepackager.ml
@@ -266,7 +266,9 @@ let package_object_files ppf files targetfile targetname coercion =
         cu_force_link = !force_link;
         cu_debug = if pos_final > pos_debug then pos_debug else 0;
         cu_debugsize = pos_final - pos_debug } in
-    output_value oc compunit;
+    Emitcode.marshal_to_channel_with_possibly_32bit_compat
+      ~filename:targetfile ~kind:"bytecode unit"
+      oc compunit;
     seek_out oc pos_depl;
     output_binary_int oc pos_final;
     close_out oc

diff --git a/bytecomp/emitcode.ml b/bytecomp/emitcode.ml
index 5cdc620ef15b6eb03995cd33f7af5803c3e6b910..3c7f848a620279d2353db3a294401cde26fd512b 100644 (file)
--- a/bytecomp/emitcode.ml
+++ b/bytecomp/emitcode.ml
@@ -25,6 +25,28 @@ open Cmo_format
 
 module StringSet = Set.Make(String)
 
+type error = Not_compatible_32 of (string * string)
+exception Error of error
+
+(* marshal and possibly check 32bit compat *)
+let marshal_to_channel_with_possibly_32bit_compat ~filename ~kind outchan obj =
+  try
+    Marshal.to_channel outchan obj
+      (if !Clflags.bytecode_compatible_32
+       then [Marshal.Compat_32] else [])
+  with Failure _ ->
+    raise (Error (Not_compatible_32 (filename, kind)))
+
+
+let report_error ppf (file, kind) =
+  Format.fprintf ppf "Generated %s %S cannot be used on a 32-bit platform" kind file
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error (Not_compatible_32 info) -> Some (Location.error_of_printer_file report_error info)
+      | _ -> None
+    )
+
 (* Buffering of bytecode *)
 
 let out_buffer = ref(LongString.create 1024)
@@ -400,7 +422,9 @@ let to_file outchan unit_name objfile ~required_globals code =
   Btype.cleanup_abbrev ();              (* Remove any cached abbreviation
                                            expansion before saving *)
   let pos_compunit = pos_out outchan in
-  output_value outchan compunit;
+  marshal_to_channel_with_possibly_32bit_compat
+    ~filename:objfile ~kind:"bytecode unit"
+    outchan compunit;
   seek_out outchan pos_depl;
   output_binary_int outchan pos_compunit
 

diff --git a/bytecomp/emitcode.mli b/bytecomp/emitcode.mli
index 74a785ee0fbe160c85e759cf0a46382597ad41ea..414211cda324ee0104f4a11461ed9985e992f139 100644 (file)
--- a/bytecomp/emitcode.mli
+++ b/bytecomp/emitcode.mli
@@ -46,3 +46,5 @@ val to_packed_file:
              relocation information (reversed) *)
 
 val reset: unit -> unit
+
+val marshal_to_channel_with_possibly_32bit_compat : filename:string -> kind:string -> out_channel -> 'a -> unit

diff --git a/bytecomp/instruct.mli b/bytecomp/instruct.mli
index d56bbb7bff3d9f972c1550022fb78e8fd890de1a..e49edefdd778c44abf95a4fe75e46a4e541e47ba 100644 (file)
--- a/bytecomp/instruct.mli
+++ b/bytecomp/instruct.mli
@@ -29,7 +29,7 @@ type compilation_env =
    stack frame.
    The ce_heap component gives the positions of variables residing in the
    heap-allocated environment.
-   The ce_rec component associate offsets to identifiers for functions
+   The ce_rec component associates offsets to identifiers for functions
    bound by the same let rec as the current function.  The offsets
    are used by the OFFSETCLOSURE instruction to recover the closure
    pointer of the desired function from the env register (which

diff --git a/bytecomp/lambda.ml b/bytecomp/lambda.ml
index 9932e789e8ac0b94635a4a302913ad948de7473d..d6f91ef0b13bf8d8a773d2b4bb43156ff84d8571 100644 (file)
--- a/bytecomp/lambda.ml
+++ b/bytecomp/lambda.ml
@@ -227,7 +227,7 @@ type lambda =
   | Llet of let_kind * value_kind * Ident.t * lambda * lambda
   | Lletrec of (Ident.t * lambda) list * lambda
   | Lprim of primitive * lambda list * Location.t
-  | Lswitch of lambda * lambda_switch
+  | Lswitch of lambda * lambda_switch * Location.t
   | Lstringswitch of
       lambda * (string * lambda) list * lambda option * Location.t
   | Lstaticraise of int * lambda list
@@ -275,6 +275,7 @@ and lambda_event_kind =
   | Lev_after of Types.type_expr
   | Lev_function
   | Lev_pseudo
+  | Lev_module_definition of Ident.t
 
 type program =
   { module_ident : Ident.t;
@@ -339,8 +340,8 @@ let make_key e =
         Llet (str,k,y,ex,tr_rec (Ident.add x (Lvar y) env) e)
     | Lprim (p,es,_) ->
         Lprim (p,tr_recs env es, Location.none)
-    | Lswitch (e,sw) ->
-        Lswitch (tr_rec env e,tr_sw env sw)
+    | Lswitch (e,sw,loc) ->
+        Lswitch (tr_rec env e,tr_sw env sw,loc)
     | Lstringswitch (e,sw,d,_) ->
         Lstringswitch
           (tr_rec env e,
@@ -421,7 +422,7 @@ let iter f = function
       List.iter (fun (_id, exp) -> f exp) decl
   | Lprim(_p, args, _loc) ->
       List.iter f args
-  | Lswitch(arg, sw) ->
+  | Lswitch(arg, sw,_) ->
       f arg;
       List.iter (fun (_key, case) -> f case) sw.sw_consts;
       List.iter (fun (_key, case) -> f case) sw.sw_blocks;
@@ -531,11 +532,20 @@ let rec transl_normal_path = function
   | Papply _ ->
       fatal_error "Lambda.transl_path"
 
-(* Translation of value identifiers *)
+(* Translation of identifiers *)
 
-let transl_path ?(loc=Location.none) env path =
+let transl_module_path ?(loc=Location.none) env path =
   transl_normal_path (Env.normalize_path (Some loc) env path)
 
+let transl_value_path ?(loc=Location.none) env path =
+  transl_normal_path (Env.normalize_path_prefix (Some loc) env path)
+
+let transl_class_path = transl_value_path
+let transl_extension_path = transl_value_path
+
+(* compatibility alias, deprecated in the .mli *)
+let transl_path = transl_value_path
+
 (* Compile a sequence of expressions *)
 
 let rec make_sequence fn = function
@@ -563,11 +573,12 @@ let subst_lambda s lam =
   | Llet(str, k, id, arg, body) -> Llet(str, k, id, subst arg, subst body)
   | Lletrec(decl, body) -> Lletrec(List.map subst_decl decl, subst body)
   | Lprim(p, args, loc) -> Lprim(p, List.map subst args, loc)
-  | Lswitch(arg, sw) ->
+  | Lswitch(arg, sw, loc) ->
       Lswitch(subst arg,
               {sw with sw_consts = List.map subst_case sw.sw_consts;
                        sw_blocks = List.map subst_case sw.sw_blocks;
-                       sw_failaction = subst_opt  sw.sw_failaction; })
+                       sw_failaction = subst_opt  sw.sw_failaction; },
+              loc)
   | Lstringswitch (arg,cases,default,loc) ->
       Lstringswitch
         (subst arg,List.map subst_strcase cases,subst_opt default,loc)
@@ -614,14 +625,15 @@ let rec map f lam =
         Lletrec (List.map (fun (v, e) -> (v, map f e)) idel, map f e2)
     | Lprim (p, el, loc) ->
         Lprim (p, List.map (map f) el, loc)
-    | Lswitch (e, sw) ->
+    | Lswitch (e, sw, loc) ->
         Lswitch (map f e,
           { sw_numconsts = sw.sw_numconsts;
             sw_consts = List.map (fun (n, e) -> (n, map f e)) sw.sw_consts;
             sw_numblocks = sw.sw_numblocks;
             sw_blocks = List.map (fun (n, e) -> (n, map f e)) sw.sw_blocks;
             sw_failaction = Misc.may_map (map f) sw.sw_failaction;
-          })
+          },
+          loc)
     | Lstringswitch (e, sw, default, loc) ->
         Lstringswitch (
           map f e,
@@ -700,5 +712,13 @@ let lam_of_loc kind loc =
     Lconst (Const_immstring loc)
   | Loc_LINE -> Lconst (Const_base (Const_int lnum))
 
+let merge_inline_attributes attr1 attr2 =
+  match attr1, attr2 with
+  | Default_inline, _ -> Some attr2
+  | _, Default_inline -> Some attr1
+  | _, _ ->
+    if attr1 = attr2 then Some attr1
+    else None
+
 let reset () =
   raise_count := 0

diff --git a/bytecomp/lambda.mli b/bytecomp/lambda.mli
index 6a058857d0f280d01d196b92c89020f76bdc9235..fef608d4a7c27c37381d796bc501eb7b73375dd4 100644 (file)
--- a/bytecomp/lambda.mli
+++ b/bytecomp/lambda.mli
@@ -216,7 +216,7 @@ type function_kind = Curried | Tupled
 
 type let_kind = Strict | Alias | StrictOpt | Variable
 (* Meaning of kinds for let x = e in e':
-    Strict: e may have side-effets; always evaluate e first
+    Strict: e may have side-effects; always evaluate e first
       (If e is a simple expression, e.g. a variable or constant,
        we may still substitute e'[x/e].)
     Alias: e is pure, we can substitute e'[x/e] if x has 0 or 1 occurrences
@@ -245,7 +245,7 @@ type lambda =
   | Llet of let_kind * value_kind * Ident.t * lambda * lambda
   | Lletrec of (Ident.t * lambda) list * lambda
   | Lprim of primitive * lambda list * Location.t
-  | Lswitch of lambda * lambda_switch
+  | Lswitch of lambda * lambda_switch * Location.t
 (* switch on strings, clauses are sorted by string order,
    strings are pairwise distinct *)
   | Lstringswitch of
@@ -294,6 +294,7 @@ and lambda_event_kind =
   | Lev_after of Types.type_expr
   | Lev_function
   | Lev_pseudo
+  | Lev_module_definition of Ident.t
 
 type program =
   { module_ident : Ident.t;
@@ -328,6 +329,13 @@ val free_methods: lambda -> IdentSet.t
 
 val transl_normal_path: Path.t -> lambda   (* Path.t is already normal *)
 val transl_path: ?loc:Location.t -> Env.t -> Path.t -> lambda
+[@@ocaml.deprecated "use transl_{module,value,extension,class}_path instead"]
+
+val transl_module_path: ?loc:Location.t -> Env.t -> Path.t -> lambda
+val transl_value_path: ?loc:Location.t -> Env.t -> Path.t -> lambda
+val transl_extension_path: ?loc:Location.t -> Env.t -> Path.t -> lambda
+val transl_class_path: ?loc:Location.t -> Env.t -> Path.t -> lambda
+
 val make_sequence: ('a -> lambda) -> 'a list -> lambda
 
 val subst_lambda: lambda Ident.tbl -> lambda -> lambda
@@ -361,4 +369,9 @@ val patch_guarded : lambda -> lambda -> lambda
 val raise_kind: raise_kind -> string
 val lam_of_loc : loc_kind -> Location.t -> lambda
 
+val merge_inline_attributes
+   : inline_attribute
+  -> inline_attribute
+  -> inline_attribute option
+
 val reset: unit -> unit

diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml
index 8159cc518f5d8b39cfa31435bdf5572780d22a35..25a819cc8f27cad99f9a082a81d39a6dc8bf1ec4 100644 (file)
--- a/bytecomp/matching.ml
+++ b/bytecomp/matching.ml
@@ -450,7 +450,7 @@ let pretty_precompiled_res first nexts =
 
 
 
-(* Identifing some semantically equivalent lambda-expressions,
+(* Identifying some semantically equivalent lambda-expressions,
    Our goal here is also to
    find alpha-equivalent (simple) terms *)
 
@@ -467,6 +467,7 @@ module StoreExp =
     (struct
       type t = lambda
       type key = lambda
+      let compare_key = Pervasives.compare
       let make_key = Lambda.make_key
     end)
 
@@ -570,7 +571,7 @@ let up_ok (ps,act_p) l =
 
 
 (*
-   Simplify fonction normalize the first column of the match
+   The simplify function normalizes the first column of the match
      - records are expanded so that they possess all fields
      - aliases are removed and replaced by bindings in actions.
    However or-patterns are simplified differently,
@@ -1554,7 +1555,7 @@ let inline_lazy_force_switch arg loc =
                            ap_args=[varg];
                            ap_inlined=Default_inline;
                            ap_specialised=Default_specialise}) ];
-               sw_failaction = Some varg } ))))
+               sw_failaction = Some varg }, loc ))))
 
 let inline_lazy_force arg loc =
   if !Clflags.native_code then
@@ -1786,7 +1787,7 @@ let rec do_make_string_test_tree loc arg sw delta d =
     bind_sw
       (Lprim
          (prim_string_compare,
-          [arg; Lconst (Const_immstring s)], loc;))
+          [arg; Lconst (Const_immstring s)], loc))
       (fun r ->
         tree_way_test loc r
           (do_make_string_test_tree loc arg lt delta d)
@@ -1834,7 +1835,7 @@ let share_actions_tree sw d =
   let sw =
     List.map  (fun (cst,act) -> cst,store.Switch.act_store act) sw in
 
-(* Retrieve all actions, including potentiel default *)
+(* Retrieve all actions, including potential default *)
   let acts = store.Switch.act_get_shared () in
 
 (* Array of actual actions *)
@@ -1934,7 +1935,7 @@ module SArg = struct
   let make_isout h arg = Lprim (Pisout, [h ; arg],Location.none)
   let make_isin h arg = Lprim (Pnot,[make_isout h arg],Location.none)
   let make_if cond ifso ifnot = Lifthenelse (cond, ifso, ifnot)
-  let make_switch arg cases acts =
+  let make_switch loc arg cases acts =
     let l = ref [] in
     for i = Array.length cases-1 downto 0 do
       l := (i,acts.(cases.(i))) ::  !l
@@ -1942,7 +1943,7 @@ module SArg = struct
     Lswitch(arg,
             {sw_numconsts = Array.length cases ; sw_consts = !l ;
              sw_numblocks = 0 ; sw_blocks =  []  ;
-             sw_failaction = None})
+             sw_failaction = None}, loc)
   let make_catch  = make_catch_delayed
   let make_exit = make_exit
 
@@ -2105,7 +2106,7 @@ let as_interval_nofail l =
   | (i,act)::rem ->
       let act_index =
         (* In case there is some hole and that a switch is emitted,
-           action 0 will be used as the action of unreacheable
+           action 0 will be used as the action of unreachable
            cases (cf. switch.ml, make_switch).
            Hence, this action will be shared *)
         if some_hole rem then
@@ -2134,10 +2135,10 @@ let as_interval fail low high l =
   | None -> as_interval_nofail l
   | Some act -> as_interval_canfail act low high l)
 
-let call_switcher fail arg low high int_lambda_list =
+let call_switcher loc fail arg low high int_lambda_list =
   let edges, (cases, actions) =
     as_interval fail low high int_lambda_list in
-  Switcher.zyva edges arg cases actions
+  Switcher.zyva loc edges arg cases actions
 
 
 let rec list_as_pat = function
@@ -2239,13 +2240,13 @@ let combine_constant loc arg cst partial ctx def
         let int_lambda_list =
           List.map (function Const_int n, l -> n,l | _ -> assert false)
             const_lambda_list in
-        call_switcher fail arg min_int max_int int_lambda_list
+        call_switcher loc fail arg min_int max_int int_lambda_list
     | Const_char _ ->
         let int_lambda_list =
           List.map (function Const_char c, l -> (Char.code c, l)
             | _ -> assert false)
             const_lambda_list in
-        call_switcher fail arg 0 255 int_lambda_list
+        call_switcher loc fail arg 0 255 int_lambda_list
     | Const_string _ ->
 (* Note as the bytecode compiler may resort to dichotomic search,
    the clauses of stringswitch  are sorted with duplicates removed.
@@ -2335,9 +2336,8 @@ let combine_constructor loc arg ex_pat cstr partial ctx def
             let tests =
               List.fold_right
                 (fun (path, act) rem ->
-                   Lifthenelse(Lprim(Pintcomp Ceq,
-                                     [Lvar tag;
-                                      transl_path ex_pat.pat_env path], loc),
+                   let ext = transl_extension_path ex_pat.pat_env path in
+                   Lifthenelse(Lprim(Pintcomp Ceq, [Lvar tag; ext], loc),
                                act, rem))
                 nonconsts
                 default
@@ -2346,8 +2346,8 @@ let combine_constructor loc arg ex_pat cstr partial ctx def
       in
         List.fold_right
           (fun (path, act) rem ->
-             Lifthenelse(Lprim(Pintcomp Ceq,
-                               [arg; transl_path ex_pat.pat_env path], loc),
+             let ext = transl_extension_path ex_pat.pat_env path in
+             Lifthenelse(Lprim(Pintcomp Ceq, [arg; ext], loc),
                          act, rem))
           consts
           nonconst_lambda
@@ -2377,7 +2377,7 @@ let combine_constructor loc arg ex_pat cstr partial ctx def
               case *)
               Lifthenelse(arg, act2, act1)
           | (n,0,_,[])  -> (* The type defines constant constructors only *)
-              call_switcher fail_opt arg 0 (n-1) consts
+              call_switcher loc fail_opt arg 0 (n-1) consts
           | (n, _, _, _) ->
               let act0  =
                 (* = Some act when all non-const constructors match to act *)
@@ -2392,7 +2392,7 @@ let combine_constructor loc arg ex_pat cstr partial ctx def
               | Some act ->
                   Lifthenelse
                     (Lprim (Pisint, [arg], loc),
-                     call_switcher
+                     call_switcher loc
                        fail_opt arg
                        0 (n-1) consts,
                      act)
@@ -2404,7 +2404,7 @@ let combine_constructor loc arg ex_pat cstr partial ctx def
                      sw_failaction = fail_opt} in
                   let hs,sw = share_actions_sw sw in
                   let sw = reintroduce_fail sw in
-                  hs (Lswitch (arg,sw)) in
+                  hs (Lswitch (arg,sw,loc)) in
     lambda1, jumps_union local_jumps total1
   end
 
@@ -2413,14 +2413,14 @@ let make_test_sequence_variant_constant fail arg int_lambda_list =
     as_interval fail min_int max_int int_lambda_list in
   Switcher.test_sequence arg cases actions
 
-let call_switcher_variant_constant fail arg int_lambda_list =
-  call_switcher fail arg min_int max_int int_lambda_list
+let call_switcher_variant_constant loc fail arg int_lambda_list =
+  call_switcher loc fail arg min_int max_int int_lambda_list
 
 
 let call_switcher_variant_constr loc fail arg int_lambda_list =
   let v = Ident.create "variant" in
   Llet(Alias, Pgenval, v, Lprim(Pfield 0, [arg], loc),
-       call_switcher
+       call_switcher loc
          fail (Lvar v) min_int max_int int_lambda_list)
 
 let combine_variant loc row arg partial ctx def
@@ -2466,7 +2466,7 @@ let combine_variant loc row arg partial ctx def
           end
       | (_, _) ->
           let lam_const =
-            call_switcher_variant_constant
+            call_switcher_variant_constant loc
               fail arg consts
           and lam_nonconst =
             call_switcher_variant_constr loc
@@ -2482,7 +2482,7 @@ let combine_array loc arg kind partial ctx def
   let lambda1 =
     let newvar = Ident.create "len" in
     let switch =
-      call_switcher
+      call_switcher loc
         fail (Lvar newvar)
         0 max_int len_lambda_list in
     bind
@@ -2614,12 +2614,12 @@ let rec lower_bind v arg lam = match lam with
         Lifthenelse (cond, ifso, lower_bind v arg ifnot)
     | _,_,_ -> bind Alias v arg lam
     end
-| Lswitch (ls,({sw_consts=[i,act] ; sw_blocks = []} as sw))
+| Lswitch (ls,({sw_consts=[i,act] ; sw_blocks = []} as sw), loc)
     when not (approx_present v ls) ->
-      Lswitch (ls, {sw with sw_consts = [i,lower_bind v arg act]})
-| Lswitch (ls,({sw_consts=[] ; sw_blocks = [i,act]} as sw))
+      Lswitch (ls, {sw with sw_consts = [i,lower_bind v arg act]}, loc)
+| Lswitch (ls,({sw_consts=[] ; sw_blocks = [i,act]} as sw), loc)
     when not (approx_present v ls) ->
-      Lswitch (ls, {sw with sw_blocks = [i,lower_bind v arg act]})
+      Lswitch (ls, {sw with sw_blocks = [i,lower_bind v arg act]}, loc)
 | Llet (Alias, k, vv, lv, l) ->
     if approx_present v lv then
       bind Alias v arg lam
@@ -2687,7 +2687,7 @@ let rec name_pattern default = function
 let arg_to_var arg cls = match arg with
 | Lvar v -> v,arg
 | _ ->
-    let v = name_pattern "match" cls in
+    let v = name_pattern "*match*" cls in
     v,Lvar v
 
 
@@ -2813,7 +2813,7 @@ and compile_no_test divide up_ctx repr partial ctx to_match =
    or lazy pattern execute arbitrary code that may perform side effects
    and change the subject values.
 LM:
-   Lazy pattern was PR #5992, initial patch by lwp25.
+   Lazy pattern was PR#5992, initial patch by lpw25.
    I have  generalized the patch, so as to also find mutable fields.
 *)
 
@@ -3100,7 +3100,7 @@ let rec flatten_pat_line size p k = match p.pat_desc with
 | Tpat_tuple args -> args::k
 | Tpat_or (p1,p2,_) ->  flatten_pat_line size p1 (flatten_pat_line size p2 k)
 | Tpat_alias (p,_,_) -> (* Note: if this 'as' pat is here, then this is a
-                           useless binding, solves PR #3780 *)
+                           useless binding, solves PR#3780 *)
     flatten_pat_line size p k
 | _ -> fatal_error "Matching.flatten_pat_line"
 
@@ -3175,7 +3175,7 @@ let do_for_multiple_match loc paraml pat_act_list partial =
       let next, nexts = split_precompile None pm1 in
 
       let size = List.length paraml
-      and idl = List.map (fun _ -> Ident.create "match") paraml in
+      and idl = List.map (fun _ -> Ident.create "*match*") paraml in
       let args =  List.map (fun id -> Lvar id, Alias) idl in
 
       let flat_next = flatten_precompiled size args next
@@ -3207,12 +3207,12 @@ let do_for_multiple_match loc paraml pat_act_list partial =
   with Unused ->
     assert false (* ; partial_function loc () *)
 
-(* #PR4828: Believe it or not, the 'paraml' argument below
+(* PR#4828: Believe it or not, the 'paraml' argument below
    may not be side effect free. *)
 
 let param_to_var param = match param with
 | Lvar v -> v,None
-| _ -> Ident.create "match",Some param
+| _ -> Ident.create "*match*",Some param
 
 let bind_opt (v,eo) k = match eo with
 | None -> k

diff --git a/bytecomp/printlambda.ml b/bytecomp/printlambda.ml
index 36594f00e2e5d176fa2c4ac5fde5a27402b58a04..54a64bee2f6bb16c185b889ee6d0abcd4b856cb4 100644 (file)
--- a/bytecomp/printlambda.ml
+++ b/bytecomp/printlambda.ml
@@ -518,7 +518,7 @@ let rec lam ppf = function
       let lams ppf largs =
         List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
       fprintf ppf "@[<2>(%a%a)@]" primitive prim lams largs
-  | Lswitch(larg, sw) ->
+  | Lswitch(larg, sw, _loc) ->
       let switch ppf sw =
         let spc = ref false in
         List.iter
@@ -601,6 +601,8 @@ let rec lam ppf = function
        | Lev_after _  -> "after"
        | Lev_function -> "funct-body"
        | Lev_pseudo -> "pseudo"
+       | Lev_module_definition ident ->
+         Format.asprintf "module-defn(%a)" Ident.print ident
       in
       fprintf ppf "@[<2>(%s %s(%i)%s:%i-%i@ %a)@]" kind
               ev.lev_loc.Location.loc_start.Lexing.pos_fname

diff --git a/bytecomp/simplif.ml b/bytecomp/simplif.ml
index 7baf04b30fb4e51659043b57f3446d821c371c62..04176603d43e72fcbea111a34dd0b6fc063c2fed 100644 (file)
--- a/bytecomp/simplif.ml
+++ b/bytecomp/simplif.ml
@@ -47,7 +47,7 @@ let rec eliminate_ref id = function
       Lassign(id, Lprim(Poffsetint delta, [Lvar id], loc))
   | Lprim(p, el, loc) ->
       Lprim(p, List.map (eliminate_ref id) el, loc)
-  | Lswitch(e, sw) ->
+  | Lswitch(e, sw, loc) ->
       Lswitch(eliminate_ref id e,
         {sw_numconsts = sw.sw_numconsts;
          sw_consts =
@@ -56,7 +56,8 @@ let rec eliminate_ref id = function
          sw_blocks =
             List.map (fun (n, e) -> (n, eliminate_ref id e)) sw.sw_blocks;
          sw_failaction =
-            Misc.may_map (eliminate_ref id) sw.sw_failaction; })
+            Misc.may_map (eliminate_ref id) sw.sw_failaction; },
+        loc)
   | Lstringswitch(e, sw, default, loc) ->
       Lstringswitch
         (eliminate_ref id e,
@@ -118,7 +119,7 @@ let simplify_exits lam =
       List.iter (fun (_v, l) -> count l) bindings;
       count body
   | Lprim(_p, ll, _) -> List.iter count ll
-  | Lswitch(l, sw) ->
+  | Lswitch(l, sw, _loc) ->
       count_default sw ;
       count l;
       List.iter (fun (_, l) -> count l) sw.sw_consts;
@@ -134,7 +135,7 @@ let simplify_exits lam =
       end
   | Lstaticraise (i,ls) -> incr_exit i ; List.iter count ls
   | Lstaticcatch (l1,(i,[]),Lstaticraise (j,[])) ->
-      (* i will be replaced by j in l1, so each occurence of i in l1
+      (* i will be replaced by j in l1, so each occurrence of i in l1
          increases j's ref count *)
       count l1 ;
       let ic = count_exit i in
@@ -232,7 +233,7 @@ let simplify_exits lam =
 
       | _ -> Lprim(p, ll, loc)
      end
-  | Lswitch(l, sw) ->
+  | Lswitch(l, sw, loc) ->
       let new_l = simplif l
       and new_consts =  List.map (fun (n, e) -> (n, simplif e)) sw.sw_consts
       and new_blocks =  List.map (fun (n, e) -> (n, simplif e)) sw.sw_blocks
@@ -240,7 +241,8 @@ let simplify_exits lam =
       Lswitch
         (new_l,
          {sw with sw_consts = new_consts ; sw_blocks = new_blocks;
-                  sw_failaction = new_fail})
+                  sw_failaction = new_fail},
+         loc)
   | Lstringswitch(l,sw,d,loc) ->
       Lstringswitch
         (simplif l,List.map (fun (s,l) -> s,simplif l) sw,
@@ -379,7 +381,7 @@ let simplify_lets lam =
       List.iter (fun (_v, l) -> count bv l) bindings;
       count bv body
   | Lprim(_p, ll, _) -> List.iter (count bv) ll
-  | Lswitch(l, sw) ->
+  | Lswitch(l, sw, _loc) ->
       count_default bv sw ;
       count bv l;
       List.iter (fun (_, l) -> count bv l) sw.sw_consts;
@@ -498,7 +500,7 @@ let simplify_lets lam =
   | Lletrec(bindings, body) ->
       Lletrec(List.map (fun (v, l) -> (v, simplif l)) bindings, simplif body)
   | Lprim(p, ll, loc) -> Lprim(p, List.map simplif ll, loc)
-  | Lswitch(l, sw) ->
+  | Lswitch(l, sw, loc) ->
       let new_l = simplif l
       and new_consts =  List.map (fun (n, e) -> (n, simplif e)) sw.sw_consts
       and new_blocks =  List.map (fun (n, e) -> (n, simplif e)) sw.sw_blocks
@@ -506,7 +508,8 @@ let simplify_lets lam =
       Lswitch
         (new_l,
          {sw with sw_consts = new_consts ; sw_blocks = new_blocks;
-                  sw_failaction = new_fail})
+                  sw_failaction = new_fail},
+         loc)
   | Lstringswitch (l,sw,d,loc) ->
       Lstringswitch
         (simplif l,List.map (fun (s,l) -> s,simplif l) sw,
@@ -574,7 +577,7 @@ let rec emit_tail_infos is_tail lambda =
       emit_tail_infos is_tail arg2
   | Lprim (_, l, _) ->
       list_emit_tail_infos false l
-  | Lswitch (lam, sw) ->
+  | Lswitch (lam, sw, _loc) ->
       emit_tail_infos false lam;
       list_emit_tail_infos_fun snd is_tail sw.sw_consts;
       list_emit_tail_infos_fun snd is_tail sw.sw_blocks;

diff --git a/bytecomp/simplif.mli b/bytecomp/simplif.mli
index 4b0a3032f48449d74a97895427f8e3157799addd..a1e74b970e275a20f8dfc1d93be53991dd2f4ead 100644 (file)
--- a/bytecomp/simplif.mli
+++ b/bytecomp/simplif.mli
@@ -13,6 +13,8 @@
 (*                                                                        *)
 (**************************************************************************)
 
+(** Lambda simplification and lambda plugin hooks *)
+
 (* Elimination of useless Llet(Alias) bindings.
    Transformation of let-bound references into variables.
    Simplification over staticraise/staticcatch constructs.

diff --git a/bytecomp/switch.ml b/bytecomp/switch.ml
index fbde44521a730c23f1c591ce823ed1b68fb76e73..2e37323921b866ca68e98a17add099894cb1e4bc 100644 (file)
--- a/bytecomp/switch.ml
+++ b/bytecomp/switch.ml
@@ -27,12 +27,13 @@ exception Not_simple
 module type Stored = sig
   type t
   type key
+  val compare_key : key -> key -> int
   val make_key : t -> key option
 end
 
 module Store(A:Stored) = struct
   module AMap =
-    Map.Make(struct type t = A.key let compare = Pervasives.compare end)
+    Map.Make(struct type t = A.key let compare = A.compare_key end)
 
   type intern =
       { mutable map : (bool * int)  AMap.t ;
@@ -105,7 +106,7 @@ module type S =
    val make_isout : act -> act -> act
    val make_isin : act -> act -> act
    val make_if : act -> act -> act -> act
-   val make_switch : act -> int array -> act array -> act
+   val make_switch : Location.t -> act -> int array -> act array -> act
    val make_catch : act -> int * (act -> act)
    val make_exit : int -> act
  end
@@ -358,7 +359,7 @@ let make_key  cases =
 
 
 (*
-  Intervall test x in [l,h] works by checking x-l in [0,h-l]
+  Interval test x in [l,h] works by checking x-l in [0,h-l]
    * This may be false for arithmetic modulo 2^31
    * Subtracting l may change the relative ordering of values
      and invalid the invariant that matched values are given in
@@ -658,7 +659,7 @@ and enum top cases =
 (* Minimal density of switches *)
 let theta = ref 0.33333
 
-(* Minmal number of tests to make a switch *)
+(* Minimal number of tests to make a switch *)
 let switch_min = ref 3
 
 (* Particular case 0, 1, 2 *)
@@ -698,7 +699,7 @@ let dense {cases} i j =
    Adaptation of the correction to Bernstein
    ``Correction to `Producing Good Code for the Case Statement' ''
    S.K. Kannan and T.A. Proebsting
-   Software Practice and Exprience Vol. 24(2) 233 (Feb 1994)
+   Software Practice and Experience Vol. 24(2) 233 (Feb 1994)
 *)
 
 let comp_clusters s =
@@ -721,7 +722,7 @@ let comp_clusters s =
   min_clusters.(len-1),k
 
 (* Assume j > i *)
-let make_switch  {cases=cases ; actions=actions} i j =
+let make_switch loc {cases=cases ; actions=actions} i j =
   let ll,_,_ = cases.(i)
   and _,hh,_ = cases.(j) in
   let tbl = Array.make (hh-ll+1) 0
@@ -750,14 +751,14 @@ let make_switch  {cases=cases ; actions=actions} i j =
     t ;
   (fun ctx ->
     match -ll-ctx.off with
-    | 0 -> Arg.make_switch ctx.arg tbl acts
+    | 0 -> Arg.make_switch loc ctx.arg tbl acts
     | _ ->
         Arg.bind
           (Arg.make_offset ctx.arg (-ll-ctx.off))
-          (fun arg -> Arg.make_switch arg tbl acts))
+          (fun arg -> Arg.make_switch loc arg tbl acts))
 
 
-let make_clusters ({cases=cases ; actions=actions} as s) n_clusters k =
+let make_clusters loc ({cases=cases ; actions=actions} as s) n_clusters k =
   let len = Array.length cases in
   let r = Array.make n_clusters (0,0,0)
   and t = Hashtbl.create 17
@@ -790,7 +791,7 @@ let make_clusters ({cases=cases ; actions=actions} as s) n_clusters k =
     else (* assert i < j *)
       let l,_,_ = cases.(i)
       and _,h,_ = cases.(j) in
-      r.(ir) <- (l,h,add_index (make_switch s i j))
+      r.(ir) <- (l,h,add_index (make_switch loc s i j))
     end ;
     if i > 0 then zyva (i-1) (ir-1) in
 
@@ -801,7 +802,7 @@ let make_clusters ({cases=cases ; actions=actions} as s) n_clusters k =
 ;;
 
 
-let do_zyva (low,high) arg cases actions =
+let do_zyva loc (low,high) arg cases actions =
   let old_ok = !ok_inter in
   ok_inter := (abs low <= inter_limit && abs high <= inter_limit) ;
   if !ok_inter <> old_ok then Hashtbl.clear t ;
@@ -809,12 +810,12 @@ let do_zyva (low,high) arg cases actions =
   let s = {cases=cases ; actions=actions} in
 
 (*
-  Printf.eprintf "ZYVA: %b [low=%i,high=%i]\n" !ok_inter low high ;
+  Printf.eprintf "ZYVA: %B [low=%i,high=%i]\n" !ok_inter low high ;
   pcases stderr cases ;
   prerr_endline "" ;
 *)
   let n_clusters,k = comp_clusters s in
-  let clusters = make_clusters s n_clusters k in
+  let clusters = make_clusters loc s n_clusters k in
   c_test {arg=arg ; off=0} clusters
 
 let abstract_shared actions =
@@ -831,11 +832,11 @@ let abstract_shared actions =
       actions in
   !handlers,actions
 
-let zyva lh arg cases actions =
+let zyva loc 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)
+  hs (do_zyva loc lh arg cases actions)
 
 and test_sequence arg cases actions =
   assert (Array.length cases > 0) ;
@@ -848,7 +849,7 @@ and test_sequence arg cases actions =
     {cases=cases ;
     actions=Array.map (fun act -> (fun _ -> act)) actions} in
 (*
-  Printf.eprintf "SEQUENCE: %b\n" !ok_inter ;
+  Printf.eprintf "SEQUENCE: %B\n" !ok_inter ;
   pcases stderr cases ;
   prerr_endline "" ;
 *)

diff --git a/bytecomp/switch.mli b/bytecomp/switch.mli
index d0eadf0c50ecb6aacbc42cb268f3783b0085eb9d..2d0cfd7fcfadb0308c0d6532f14c6a3c788520fd 100644 (file)
--- a/bytecomp/switch.mli
+++ b/bytecomp/switch.mli
@@ -42,6 +42,7 @@ exception Not_simple
 module type Stored = sig
   type t
   type key
+  val compare_key : key -> key -> int
   val make_key : t -> key option
 end
 
@@ -78,7 +79,7 @@ module type S =
       make_switch arg cases acts
       NB:  cases is in the value form *)
     val make_switch :
-        act -> int array -> act array -> act
+        Location.t -> act -> int array -> act array -> act
    (* Build last minute sharing of action stuff *)
    val make_catch : act -> int * (act -> act)
    val make_exit : int -> act
@@ -94,13 +95,14 @@ module type S =
     - actions is an array of actions.
 
   All these arguments specify a switch construct and zyva
-  returns an action that performs the switch,
+  returns an action that performs the switch.
 *)
 module Make :
   functor (Arg : S) ->
     sig
 (* Standard entry point, sharing is tracked *)
       val zyva :
+          Location.t ->
           (int * int) ->
            Arg.act ->
            (int * int * int) array ->

diff --git a/bytecomp/symtable.ml b/bytecomp/symtable.ml
index d2936f41620b8b7dbbbbc5d12a3b9e962f1928f6..3af60fb0437add32c8950dc986570c707ff9d34e 100644 (file)
--- a/bytecomp/symtable.ml
+++ b/bytecomp/symtable.ml
@@ -220,7 +220,10 @@ let rec transl_const = function
         fields;
       block
   | Const_float_array fields ->
-      Obj.repr(Array.of_list(List.map (fun f -> float_of_string f) fields))
+      let res = Array.Floatarray.create (List.length fields) in
+      List.iteri (fun i f -> Array.Floatarray.set res i (float_of_string f))
+        fields;
+      Obj.repr res
 
 (* Build the initial table of globals *)
 

diff --git a/bytecomp/translattribute.ml b/bytecomp/translattribute.ml
index c2b42484d7d17e9324718fef7b54bc903d1b9a1c..68a0dc4a87c08d76fb7df749518704a9facf8fae 100644 (file)
--- a/bytecomp/translattribute.ml
+++ b/bytecomp/translattribute.ml
@@ -201,7 +201,7 @@ let get_and_remove_specialised_attribute e =
   let specialised = parse_specialise_attribute attr in
   specialised, { e with exp_attributes }
 
-(* It also remove the attribute from the expression, like
+(* It also removes the attribute from the expression, like
    get_inlined_attribute *)
 let get_tailcall_attribute e =
   let is_tailcall_attribute = function

diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml
index 2504a8703a0d812841e286ab7cb11111350867ba..d5ffd339197d13490922ebd190497d07ad8f94bc 100644 (file)
--- a/bytecomp/translclass.ml
+++ b/bytecomp/translclass.ml
@@ -22,7 +22,7 @@ open Translcore
 
 (* XXX Rajouter des evenements... | Add more events... *)
 
-type error = Illegal_class_expr | Tags of label * label
+type error = Tags of label * label
 
 exception Error of Location.t * error
 
@@ -195,7 +195,8 @@ let rec build_object_init cl_table obj params inh_init obj_init cl =
         build_object_init cl_table obj (vals @ params) inh_init obj_init cl
       in
       (inh_init, Translcore.transl_let rec_flag defs obj_init)
-  | Tcl_constraint (cl, _, _vals, _pub_meths, _concr_meths) ->
+  | Tcl_open (_, _, _, _, cl)
+  | Tcl_constraint (cl, _, _, _, _) ->
       build_object_init cl_table obj params inh_init obj_init cl
 
 let rec build_object_init_0 cl_table params cl copy_env subst_env top ids =
@@ -268,7 +269,7 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl =
     Tcl_ident ( path, _, _) ->
       begin match inh_init with
         (obj_init, _path')::inh_init ->
-          let lpath = transl_path ~loc:cl.cl_loc cl.cl_env path in
+          let lpath = transl_class_path ~loc:cl.cl_loc cl.cl_env path in
           (inh_init,
            Llet (Strict, Pgenval, obj_init,
                  mkappl(Lprim(Pfield 1, [lpath], Location.none), Lvar cla ::
@@ -386,16 +387,15 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl =
            Lsequence(mkappl (oo_prim "narrow", narrow_args),
                      cl_init))
       end
+  | Tcl_open (_, _, _, _, cl) ->
+      build_class_init cla cstr super inh_init cl_init msubst top cl
 
-let rec build_class_lets cl ids =
+let rec build_class_lets cl =
   match cl.cl_desc with
     Tcl_let (rec_flag, defs, _vals, cl') ->
-      let env, wrap = build_class_lets cl' [] in
+      let env, wrap = build_class_lets cl' in
       (env, fun x ->
-        let lam = Translcore.transl_let rec_flag defs (wrap x) in
-        (* Check recursion in toplevel let-definitions *)
-        if ids = [] || Translcore.check_recursive_lambda ids lam then lam
-        else raise(Error(cl.cl_loc, Illegal_class_expr)))
+          Translcore.transl_let rec_flag defs (wrap x))
   | _ ->
       (cl.cl_env, fun x -> x)
 
@@ -407,6 +407,7 @@ let rec get_class_meths cl =
   | Tcl_fun (_, _, _, cl, _)
   | Tcl_let (_, _, _, cl)
   | Tcl_apply (cl, _)
+  | Tcl_open (_, _, _, _, cl)
   | Tcl_constraint (cl, _, _, _, _) -> get_class_meths cl
 
 (*
@@ -452,6 +453,8 @@ let rec transl_class_rebind obj_init cl vf =
       in
       check_constraint cl.cl_type;
       (path, obj_init)
+  | Tcl_open (_, _, _, _, cl) ->
+      transl_class_rebind obj_init cl vf
 
 let rec transl_class_rebind_0 self obj_init cl vf =
   match cl.cl_desc with
@@ -462,7 +465,7 @@ let rec transl_class_rebind_0 self obj_init cl vf =
       let path, obj_init = transl_class_rebind obj_init cl vf in
       (path, lfunction [self] obj_init)
 
-let transl_class_rebind ids cl vf =
+let transl_class_rebind cl vf =
   try
     let obj_init = Ident.create "obj_init"
     and self = Ident.create "self" in
@@ -475,8 +478,6 @@ let transl_class_rebind ids cl vf =
               ap_specialised=Default_specialise}
     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));
     let id = (obj_init' = lfunction [self] obj_init0) in
     if id then transl_normal_path path else
 
@@ -619,7 +620,7 @@ open M
     env_init: parameterisation by the local environment
       (env -> params -> obj_init)
       (one for each combination of inherited class_init )
-    env: environnement local
+    env: local environment
    If ids=0 (immediate object), then only env_init is conserved.
 *)
 
@@ -631,14 +632,14 @@ let prerr_ids msg ids =
 
 let transl_class ids cl_id pub_meths cl vflag =
   (* First check if it is not only a rebind *)
-  let rebind = transl_class_rebind ids cl vflag in
+  let rebind = transl_class_rebind cl vflag in
   if rebind <> lambda_unit then rebind else
 
   (* Prepare for heavy environment handling *)
   let tables = Ident.create (Ident.name cl_id ^ "_tables") in
   let (top_env, req) = oo_add_class tables in
   let top = not req in
-  let cl_env, llets = build_class_lets cl ids in
+  let cl_env, llets = build_class_lets cl in
   let new_ids = if top then [] else Env.diff top_env cl_env in
   let env2 = Ident.create "env" in
   let meth_ids = get_class_meths cl in
@@ -773,7 +774,7 @@ let transl_class ids cl_id pub_meths cl vflag =
   if top && concrete then lclass lbody else
   if top then llets (lbody_virt lambda_unit) else
 
-  (* Now for the hard stuff: prepare for table cacheing *)
+  (* Now for the hard stuff: prepare for table caching *)
   let envs = Ident.create "envs"
   and cached = Ident.create "cached" in
   let lenvs =
@@ -842,16 +843,23 @@ let transl_class ids cl_id pub_meths cl vflag =
                              loc = Location.none;
                              params = [cla]; body = def_ids cla cl_init})
   in
+  let lupdate_cache =
+    if ids = [] then ldirect () else
+      if not concrete then lclass_virt () else
+        lclass (
+            mkappl (oo_prim "make_class_store",
+                    [transl_meth_list pub_meths;
+                     Lvar class_init; Lvar cached])) in
+  let lcheck_cache =
+    if !Clflags.native_code && !Clflags.afl_instrument then
+      (* When afl-fuzz instrumentation is enabled, ignore the cache
+         so that the program's behaviour does not change between runs *)
+      lupdate_cache
+    else
+      Lifthenelse(lfield cached 0, lambda_unit, lupdate_cache) in
   llets (
   lcache (
-  Lsequence(
-  Lifthenelse(lfield cached 0, lambda_unit,
-              if ids = [] then ldirect () else
-              if not concrete then lclass_virt () else
-              lclass (
-              mkappl (oo_prim "make_class_store",
-                      [transl_meth_list pub_meths;
-                       Lvar class_init; Lvar cached]))),
+  Lsequence(lcheck_cache,
   make_envs (
   if ids = [] then mkappl (lfield cached 0, [lenvs]) else
   Lprim(Pmakeblock(0, Immutable, None),
@@ -885,8 +893,6 @@ let () =
 open Format
 
 let report_error ppf = function
-  | Illegal_class_expr ->
-      fprintf ppf "This kind of recursive class expression is not allowed"
   | Tags (lab1, lab2) ->
       fprintf ppf "Method labels `%s' and `%s' are incompatible.@ %s"
         lab1 lab2 "Change one of them."

diff --git a/bytecomp/translclass.mli b/bytecomp/translclass.mli
index bbd21e93a2cc418cf16061f42f8f0980266a0f7f..4c4bed0f639dc367f12251b146a7aeb9357c961b 100644 (file)
--- a/bytecomp/translclass.mli
+++ b/bytecomp/translclass.mli
@@ -20,7 +20,7 @@ val transl_class :
   Ident.t list -> Ident.t ->
   string list -> class_expr -> Asttypes.virtual_flag -> lambda;;
 
-type error = Illegal_class_expr | Tags of string * string
+type error = Tags of string * string
 
 exception Error of Location.t * error
 

diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml
index 6748c159a3652f0e95f07484385bc78b502e9a13..216601e016c8bb2796aae745c8f367c1261ece94 100644 (file)
--- a/bytecomp/translcore.ml
+++ b/bytecomp/translcore.ml
@@ -25,9 +25,7 @@ open Typeopt
 open Lambda
 
 type error =
-    Illegal_letrec_pat
-  | Illegal_letrec_expr
-  | Free_super_var
+    Free_super_var
   | Unknown_builtin_primitive of string
   | Unreachable_reached
 
@@ -64,7 +62,7 @@ let transl_extension_constructor env path ext =
          Lprim (prim_fresh_oo_id, [Lconst (Const_base (Const_int 0))], loc)],
         loc)
   | Text_rebind(path, _lid) ->
-      transl_path ~loc env path
+      transl_extension_path ~loc env path
 
 (* Translation of primitives *)
 
@@ -162,6 +160,9 @@ let comparisons_table = create_hashtable 11 [
        false)
 ]
 
+let gen_array_kind =
+  if Config.flat_float_array then Pgenarray else Paddrarray
+
 let primitives_table = create_hashtable 57 [
   "%identity", Pidentity;
   "%bytes_to_string", Pbytes_to_string;
@@ -239,14 +240,19 @@ let primitives_table = create_hashtable 57 [
   "%bytes_safe_set", Pbytessets;
   "%bytes_unsafe_get", Pbytesrefu;
   "%bytes_unsafe_set", Pbytessetu;
-  "%array_length", Parraylength Pgenarray;
-  "%array_safe_get", Parrayrefs Pgenarray;
-  "%array_safe_set", Parraysets Pgenarray;
-  "%array_unsafe_get", Parrayrefu Pgenarray;
-  "%array_unsafe_set", Parraysetu Pgenarray;
-  "%obj_size", Parraylength Pgenarray;
-  "%obj_field", Parrayrefu Pgenarray;
-  "%obj_set_field", Parraysetu Pgenarray;
+  "%array_length", Parraylength gen_array_kind;
+  "%array_safe_get", Parrayrefs gen_array_kind;
+  "%array_safe_set", Parraysets gen_array_kind;
+  "%array_unsafe_get", Parrayrefu gen_array_kind;
+  "%array_unsafe_set", Parraysetu gen_array_kind;
+  "%obj_size", Parraylength gen_array_kind;
+  "%obj_field", Parrayrefu gen_array_kind;
+  "%obj_set_field", Parraysetu gen_array_kind;
+  "%floatarray_length", Parraylength Pfloatarray;
+  "%floatarray_safe_get", Parrayrefs Pfloatarray;
+  "%floatarray_safe_set", Parraysets Pfloatarray;
+  "%floatarray_unsafe_get", Parrayrefu Pfloatarray;
+  "%floatarray_unsafe_set", Parraysetu Pfloatarray;
   "%obj_is_int", Pisint;
   "%lazy_force", Plazyforce;
   "%nativeint_of_int", Pbintofint Pnativeint;
@@ -377,6 +383,28 @@ let specialize_comparison table env ty =
   | () when is_base_type env ty Predef.path_int64     -> int64comp
   | () -> gencomp
 
+(* The following function computes the greatest lower bound in the
+   semilattice of array kinds:
+          gen
+         /   \
+      addr   float
+       |
+      int
+   Note that the GLB is not guaranteed to exist, in which case we return
+   our first argument instead of raising a fatal error because, although
+   it cannot happen in a well-typed program, (ab)use of Obj.magic can
+   probably trigger it.
+*)
+let glb_array_type t1 t2 =
+  match t1, t2 with
+  | Pfloatarray, (Paddrarray | Pintarray)
+  | (Paddrarray | Pintarray), Pfloatarray -> t1
+
+  | Pgenarray, x | x, Pgenarray -> x
+  | Paddrarray, x | x, Paddrarray -> x
+  | Pintarray, Pintarray -> Pintarray
+  | Pfloatarray, Pfloatarray -> Pfloatarray
+
 (* Specialize a primitive from available type information,
    raise Not_found if primitive is unknown  *)
 
@@ -403,11 +431,16 @@ let specialize_primitive p env ty ~has_constant_constructor =
     match (p, params) with
       (Psetfield(n, _, init), [_p1; p2]) ->
         Psetfield(n, maybe_pointer_type env p2, init)
-    | (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)
+    | (Parraylength t, [p])   ->
+        Parraylength(glb_array_type t (array_type_kind env p))
+    | (Parrayrefu t, p1 :: _) ->
+        Parrayrefu(glb_array_type t (array_type_kind env p1))
+    | (Parraysetu t, p1 :: _) ->
+        Parraysetu(glb_array_type t (array_type_kind env p1))
+    | (Parrayrefs t, p1 :: _) ->
+        Parrayrefs(glb_array_type t (array_type_kind env p1))
+    | (Parraysets t, p1 :: _) ->
+        Parraysets(glb_array_type t (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
@@ -486,77 +519,6 @@ let transl_primitive_application loc prim env ty path args =
     add_used_primitive loc env path;
     Pccall prim
 
-
-(* To check the well-formedness of r.h.s. of "let rec" definitions *)
-
-let check_recursive_lambda idlist lam =
-  let rec check_top idlist = function
-    | Lvar v -> not (List.mem v idlist)
-    | Llet _ as lam when check_recursive_recordwith idlist lam ->
-        true
-    | Llet(_str, _k, id, arg, body) ->
-        check idlist arg && check_top (add_let id arg idlist) body
-    | Lletrec(bindings, body) ->
-        let idlist' = add_letrec bindings idlist in
-        List.for_all (fun (_id, arg) -> check idlist' arg) bindings &&
-        check_top idlist' body
-    | Lprim (Pmakearray (Pgenarray, _), _, _) -> false
-    | Lprim (Pmakearray (Pfloatarray, _), args, _) ->
-        List.for_all (check idlist) args
-    | Lsequence (lam1, lam2) -> check idlist lam1 && check_top idlist lam2
-    | Levent (lam, _) -> check_top idlist lam
-    | lam -> check idlist lam
-
-  and check idlist = function
-    | Lvar _ -> true
-    | Lfunction _ -> true
-    | Llet _ as lam when check_recursive_recordwith idlist lam ->
-        true
-    | Llet(_str, _k, id, arg, body) ->
-        check idlist arg && check (add_let id arg idlist) body
-    | Lletrec(bindings, body) ->
-        let idlist' = add_letrec bindings idlist in
-        List.for_all (fun (_id, arg) -> check idlist' arg) bindings &&
-        check idlist' body
-    | Lprim(Pmakeblock _, args, _) ->
-        List.for_all (check idlist) args
-    | Lprim (Pmakearray (Pfloatarray, _), _, _) -> false
-    | Lprim (Pmakearray _, args, _) ->
-        List.for_all (check idlist) args
-    | Lsequence (lam1, lam2) -> check idlist lam1 && check idlist lam2
-    | Levent (lam, _) -> check idlist lam
-    | lam ->
-        let fv = free_variables lam in
-        not (List.exists (fun id -> IdentSet.mem id fv) idlist)
-
-  and add_let id arg idlist =
-    let fv = free_variables arg in
-    if List.exists (fun id -> IdentSet.mem id fv) idlist
-    then id :: idlist
-    else idlist
-
-  and add_letrec bindings idlist =
-    List.fold_right (fun (id, arg) idl -> add_let id arg idl)
-                    bindings idlist
-
-  (* reverse-engineering the code generated by transl_record case 2 *)
-  (* If you change this, you probably need to change Bytegen.size_of_lambda. *)
-  and check_recursive_recordwith idlist = function
-    | Llet (Strict, _k, id1, Lprim (Pduprecord _, [e1], _), body) ->
-       check_top idlist e1
-       && check_recordwith_updates idlist id1 body
-    | _ -> false
-
-  and check_recordwith_updates idlist id1 = function
-    | Lsequence (Lprim ((Psetfield _ | Psetfloatfield _), [Lvar id2; e1], _),
-                 cont)
-        -> id2 = id1 && check idlist e1
-           && check_recordwith_updates idlist id1 cont
-    | Lvar id2 -> id2 = id1
-    | _ -> false
-
-  in check_top idlist lam
-
 (* To propagate structured constants *)
 
 exception Not_constant
@@ -730,7 +692,7 @@ and transl_exp0 e =
   | Texp_ident(_, _, {val_kind = Val_anc _}) ->
       raise(Error(e.exp_loc, Free_super_var))
   | Texp_ident(path, _, {val_kind = Val_reg | Val_self _}) ->
-      transl_path ~loc:e.exp_loc e.exp_env path
+      transl_value_path ~loc:e.exp_loc e.exp_env path
   | Texp_ident _ -> fatal_error "Translcore.transl_exp: bad Texp_ident"
   | Texp_constant cst ->
       Lconst(Const_base cst)
@@ -885,13 +847,13 @@ and transl_exp0 e =
           end
       | Cstr_extension(path, is_const) ->
           if is_const then
-            transl_path e.exp_env path
+            transl_extension_path e.exp_env path
           else
             Lprim(Pmakeblock(0, Immutable, Some (Pgenval :: shape)),
-                  transl_path e.exp_env path :: ll, e.exp_loc)
+                  transl_extension_path e.exp_env path :: ll, e.exp_loc)
       end
   | Texp_extension_constructor (_, path) ->
-      transl_path e.exp_env path
+      transl_extension_path e.exp_env path
   | Texp_variant(l, arg) ->
       let tag = Btype.hash_variant l in
       begin match arg with
@@ -1005,7 +967,7 @@ and transl_exp0 e =
   | Texp_new (cl, {Location.loc=loc}, _) ->
       Lapply{ap_should_be_tailcall=false;
              ap_loc=loc;
-             ap_func=Lprim(Pfield 0, [transl_path ~loc e.exp_env cl], loc);
+             ap_func=Lprim(Pfield 0, [transl_class_path ~loc e.exp_env cl], loc);
              ap_args=[lambda_unit];
              ap_inlined=Default_inline;
              ap_specialised=Default_specialise}
@@ -1029,10 +991,16 @@ and transl_exp0 e =
                             (Lvar cpy) path expr, rem))
              modifs
              (Lvar cpy))
-  | Texp_letmodule(id, _, modl, body) ->
-      Llet(Strict, Pgenval, id,
-           !transl_module Tcoerce_none None modl,
-           transl_exp body)
+  | Texp_letmodule(id, loc, modl, body) ->
+      let defining_expr =
+        Levent (!transl_module Tcoerce_none None modl, {
+          lev_loc = loc.loc;
+          lev_kind = Lev_module_definition id;
+          lev_repr = None;
+          lev_env = Env.summary Env.empty;
+        })
+      in
+      Llet(Strict, Pgenval, id, defining_expr, transl_exp body)
   | Texp_letexception(cd, body) ->
       Llet(Strict, Pgenval,
            cd.ext_id, transl_extension_constructor e.exp_env None cd,
@@ -1049,35 +1017,30 @@ and transl_exp0 e =
       (* when e needs no computation (constants, identifiers, ...), we
          optimize the translation just as Lazy.lazy_from_val would
          do *)
-      begin match e.exp_desc with
+      begin match Typeopt.classify_lazy_argument e with
+      | `Constant_or_function ->
         (* a constant expr of type <> float gets compiled as itself *)
-      | Texp_constant
-          ( Const_int _ | Const_char _ | Const_string _
-          | Const_int32 _ | Const_int64 _ | Const_nativeint _ )
-      | Texp_function _
-      | Texp_construct (_, {cstr_arity = 0}, _)
-        -> transl_exp e
-      | Texp_constant(Const_float _) ->
+         transl_exp e
+      | `Float -> 
           (* We don't need to wrap with Popaque: this forward
              block will never be shortcutted since it points to a float. *)
           Lprim(Pmakeblock(Obj.forward_tag, Immutable, None),
                 [transl_exp e], e.exp_loc)
-      | Texp_ident _ ->
-          (* CR-someday mshinwell: Consider adding a new primitive
-             that expresses the construction of forward_tag blocks.
-             We need to use [Popaque] here to prevent unsound
-             optimisation in Flambda, but the concept of a mutable
-             block doesn't really match what is going on here.  This
-             value may subsequently turn into an immediate... *)
-          if Typeopt.lazy_val_requires_forward e.exp_env e.exp_type
-          then
-            Lprim (Popaque,
-                   [Lprim(Pmakeblock(Obj.forward_tag, Immutable, None),
-                          [transl_exp e], e.exp_loc)],
-                   e.exp_loc)
-          else transl_exp e
-      (* other cases compile to a lazy block holding a function *)
-      | _ ->
+      | `Identifier `Forward_value ->
+         (* CR-someday mshinwell: Consider adding a new primitive
+            that expresses the construction of forward_tag blocks.
+            We need to use [Popaque] here to prevent unsound
+            optimisation in Flambda, but the concept of a mutable
+            block doesn't really match what is going on here.  This
+            value may subsequently turn into an immediate... *)
+         Lprim (Popaque,
+                [Lprim(Pmakeblock(Obj.forward_tag, Immutable, None),
+                       [transl_exp e], e.exp_loc)],
+                e.exp_loc)
+      | `Identifier `Other ->
+         transl_exp e
+      | `Other ->
+         (* other cases compile to a lazy block holding a function *)
          let fn = Lfunction {kind = Curried; params = [Ident.create "param"];
                              attr = default_function_attribute;
                              loc = e.exp_loc;
@@ -1213,7 +1176,7 @@ and transl_function loc untuplify_fn repr partial param cases =
     [{c_lhs=pat; c_guard=None;
       c_rhs={exp_desc = Texp_function { arg_label = _; param = param'; cases;
         partial = partial'; }} as exp}]
-    when Parmatch.fluid pat ->
+    when Parmatch.inactive ~partial pat ->
       let ((_, params), body) =
         transl_function exp.exp_loc false repr partial' param' cases in
       ((Curried, param :: params),
@@ -1262,7 +1225,7 @@ and transl_let rec_flag pat_expr_list body =
           (fun {vb_pat=pat} -> match pat.pat_desc with
               Tpat_var (id,_) -> id
             | Tpat_alias ({pat_desc=Tpat_any}, id,_) -> id
-            | _ -> raise(Error(pat.pat_loc, Illegal_letrec_pat)))
+            | _ -> assert false)
         pat_expr_list in
       let transl_case {vb_expr=expr; vb_attributes; vb_loc} id =
         let lam = transl_exp expr in
@@ -1274,8 +1237,6 @@ and transl_let rec_flag pat_expr_list body =
           Translattribute.add_specialise_attribute lam vb_loc
             vb_attributes
         in
-        if not (check_recursive_lambda idlist lam) then
-          raise(Error(expr.exp_loc, Illegal_letrec_expr));
         (id, lam) in
       Lletrec(List.map2 transl_case pat_expr_list idlist, body)
 
@@ -1344,7 +1305,7 @@ and transl_record loc env fields repres opt_init_expr =
               | Tconstr(p, _, _) -> p
               | _ -> assert false
             in
-            let slot = transl_path env path in
+            let slot = transl_extension_path env path in
             Lprim(Pmakeblock(0, mut, Some (Pgenval :: shape)), slot :: ll, loc)
     in
     begin match opt_init_expr with
@@ -1355,8 +1316,6 @@ and transl_record loc env fields repres opt_init_expr =
   end else begin
     (* Take a shallow copy of the init record, then mutate the fields
        of the copy *)
-    (* If you change anything here, you will likely have to change
-       [check_recursive_recordwith] in this file. *)
     let copy_id = Ident.create "newrecord" in
     let update_field cont (lbl, definition) =
       match definition with
@@ -1429,12 +1388,6 @@ let transl_let rec_flag pat_expr_list body =
 open Format
 
 let report_error ppf = function
-  | Illegal_letrec_pat ->
-      fprintf ppf
-        "Only variables are allowed as left-hand side of `let rec'"
-  | Illegal_letrec_expr ->
-      fprintf ppf
-        "This kind of expression is not allowed as right-hand side of `let rec'"
   | Free_super_var ->
       fprintf ppf
         "Ancestor names can only be used to select inherited methods"

diff --git a/bytecomp/translcore.mli b/bytecomp/translcore.mli
index fb5a506083c1e56b82035b23c1a7018d49adfe07..75c26f8d1e5ba46242b1bfd74306f37d84a43b4e 100644 (file)
--- a/bytecomp/translcore.mli
+++ b/bytecomp/translcore.mli
@@ -33,14 +33,10 @@ val transl_primitive: Location.t -> Primitive.description -> Env.t
 val transl_extension_constructor: Env.t -> Path.t option ->
   extension_constructor -> lambda
 
-val check_recursive_lambda: Ident.t list -> lambda -> bool
-
 val used_primitives: (Path.t, Location.t) Hashtbl.t
 
 type error =
-    Illegal_letrec_pat
-  | Illegal_letrec_expr
-  | Free_super_var
+    Free_super_var
   | Unknown_builtin_primitive of string
   | Unreachable_reached
 

diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml
index c7ce0a9ff19af6603526e721da598e375ae3b151..31557eed9e1d93d3cf2b59edbf97373bdffc837e 100644 (file)
--- a/bytecomp/translmod.ml
+++ b/bytecomp/translmod.ml
@@ -29,7 +29,7 @@ open Translclass
 
 type error =
   Circular_dependency of Ident.t
-
+| Conflicting_inline_attributes
 
 exception Error of Location.t * error
 
@@ -75,20 +75,8 @@ let rec apply_coercion loc strict restr arg =
         wrap_id_pos_list loc id_pos_list get_field lam)
   | Tcoerce_functor(cc_arg, cc_res) ->
       let param = Ident.create "funarg" in
-      name_lambda strict arg (fun id ->
-        Lfunction{kind = Curried; params = [param];
-                  attr = { default_function_attribute with
-                           is_a_functor = true };
-                  loc = loc;
-                  body = apply_coercion
-                           loc Strict cc_res
-                           (Lapply{ap_should_be_tailcall=false;
-                                   ap_loc=loc;
-                                   ap_func=Lvar id;
-                                   ap_args=[apply_coercion loc Alias cc_arg
-                                                           (Lvar param)];
-                                   ap_inlined=Default_inline;
-                                   ap_specialised=Default_specialise})})
+      let carg = apply_coercion loc Alias cc_arg (Lvar param) in
+      apply_coercion_result loc strict arg [param] [carg] cc_res
   | Tcoerce_primitive { pc_loc; pc_desc; pc_env; pc_type; } ->
       transl_primitive pc_loc pc_desc pc_env pc_type None
   | Tcoerce_alias (path, cc) ->
@@ -98,6 +86,29 @@ let rec apply_coercion loc strict restr arg =
 and apply_coercion_field loc get_field (pos, cc) =
   apply_coercion loc Alias cc (get_field pos)
 
+and apply_coercion_result loc strict funct params args cc_res =
+  match cc_res with
+  | Tcoerce_functor(cc_arg, cc_res) ->
+    let param = Ident.create "funarg" in
+    let arg = apply_coercion loc Alias cc_arg (Lvar param) in
+    apply_coercion_result loc strict funct
+      (param :: params) (arg :: args) cc_res
+  | _ ->
+    name_lambda strict funct (fun id ->
+      Lfunction{kind = Curried; params = List.rev params;
+                attr = { default_function_attribute with
+                         is_a_functor = true;
+                         stub = true; };
+                loc = loc;
+                body = apply_coercion
+                         loc Strict cc_res
+                         (Lapply{ap_should_be_tailcall=false;
+                                 ap_loc=loc;
+                                 ap_func=Lvar id;
+                                 ap_args=List.rev args;
+                                 ap_inlined=Default_inline;
+                                 ap_specialised=Default_specialise})})
+
 and wrap_id_pos_list loc id_pos_list get_field lam =
   let fv = free_variables lam in
   (*Format.eprintf "%a@." Printlambda.lambda lam;
@@ -160,7 +171,7 @@ let compose_coercions c1 c2 =
   c3
 *)
 
-(* Record the primitive declarations occuring in the module compiled *)
+(* Record the primitive declarations occurring in the module compiled *)
 
 let primitive_declarations = ref ([] : Primitive.description list)
 let record_primitive = function
@@ -312,8 +323,8 @@ let compile_recmodule compile_rhs bindings cont =
   eval_rec_bindings
     (reorder_rec_bindings
        (List.map
-          (fun {mb_id=id; mb_expr=modl; _} ->
-            (id, modl.mod_loc, init_shape modl, compile_rhs id modl))
+          (fun {mb_id=id; mb_expr=modl; mb_loc=loc; _} ->
+            (id, modl.mod_loc, init_shape modl, compile_rhs id modl loc))
           bindings))
     cont
 
@@ -342,51 +353,89 @@ let transl_class_bindings cl_list =
        (id, transl_class ids id meths cl vf))
      cl_list)
 
+(* Compile one or more functors, merging curried functors to produce
+   multi-argument functors.  Any [@inline] attribute on a functor that is
+   merged must be consistent with any other [@inline] attribute(s) on the
+   functor(s) being merged with.  Such an attribute will be placed on the
+   resulting merged functor. *)
+
+let merge_inline_attributes attr1 attr2 loc =
+  match Lambda.merge_inline_attributes attr1 attr2 with
+  | Some attr -> attr
+  | None -> raise (Error (loc, Conflicting_inline_attributes))
+
+let merge_functors mexp coercion root_path =
+  let rec merge mexp coercion path acc inline_attribute =
+    let finished = acc, mexp, path, coercion, inline_attribute in
+    match mexp.mod_desc with
+    | Tmod_functor (param, _, _, body) ->
+      let inline_attribute' =
+        Translattribute.get_inline_attribute mexp.mod_attributes
+      in
+      let arg_coercion, res_coercion =
+        match coercion with
+        | Tcoerce_none -> Tcoerce_none, Tcoerce_none
+        | Tcoerce_functor (arg_coercion, res_coercion) ->
+          arg_coercion, res_coercion
+        | _ -> fatal_error "Translmod.merge_functors: bad coercion"
+      in
+      let loc = mexp.mod_loc in
+      let path = functor_path path param in
+      let inline_attribute =
+        merge_inline_attributes inline_attribute inline_attribute' loc
+      in
+      merge body res_coercion path ((param, loc, arg_coercion) :: acc)
+        inline_attribute
+    | _ -> finished
+  in
+  merge mexp coercion root_path [] Default_inline
+
+let rec compile_functor mexp coercion root_path loc =
+  let functor_params_rev, body, body_path, res_coercion, inline_attribute =
+    merge_functors mexp coercion root_path
+  in
+  assert (List.length functor_params_rev >= 1);  (* cf. [transl_module] *)
+  let params, body =
+    List.fold_left (fun (params, body) (param, loc, arg_coercion) ->
+        let param' = Ident.rename param in
+        let arg = apply_coercion loc Alias arg_coercion (Lvar param') in
+        let params = param' :: params in
+        let body = Llet (Alias, Pgenval, param, arg, body) in
+        params, body)
+      ([], transl_module res_coercion body_path body)
+      functor_params_rev
+  in
+  Lfunction {
+    kind = Curried;
+    params;
+    attr = {
+      inline = inline_attribute;
+      specialise = Default_specialise;
+      is_a_functor = true;
+      stub = false;
+    };
+    loc;
+    body;
+  }
+
 (* Compile a module expression *)
 
-let rec transl_module cc rootpath mexp =
+and transl_module cc rootpath mexp =
   List.iter (Translattribute.check_attribute_on_module mexp)
     mexp.mod_attributes;
   let loc = mexp.mod_loc in
   match mexp.mod_type with
-    Mty_alias _ -> apply_coercion loc Alias cc lambda_unit
+    Mty_alias (Mta_absent, _) -> apply_coercion loc Alias cc lambda_unit
   | _ ->
       match mexp.mod_desc with
         Tmod_ident (path,_) ->
           apply_coercion loc Strict cc
-            (transl_path ~loc mexp.mod_env path)
+            (transl_module_path ~loc mexp.mod_env path)
       | Tmod_structure str ->
           fst (transl_struct loc [] cc rootpath str)
-      | Tmod_functor(param, _, _, body) ->
-          let bodypath = functor_path rootpath param in
-          let inline_attribute =
-            Translattribute.get_inline_attribute mexp.mod_attributes
-          in
-          oo_wrap mexp.mod_env true
-            (function
-              | Tcoerce_none ->
-                  Lfunction{kind = Curried; params = [param];
-                            attr = { inline = inline_attribute;
-                                     specialise = Default_specialise;
-                                     is_a_functor = true;
-                                     stub = false; };
-                            loc = loc;
-                            body = transl_module Tcoerce_none bodypath body}
-              | Tcoerce_functor(ccarg, ccres) ->
-                  let param' = Ident.create "funarg" in
-                  Lfunction{kind = Curried; params = [param'];
-                            attr = { inline = inline_attribute;
-                                     specialise = Default_specialise;
-                                     is_a_functor = true;
-                                     stub = false; };
-                            loc = loc;
-                            body = Llet(Alias, Pgenval, param,
-                                        apply_coercion loc Alias ccarg
-                                                       (Lvar param'),
-                                        transl_module ccres bodypath body)}
-              | _ ->
-                  fatal_error "Translmod.transl_module")
-            cc
+      | Tmod_functor _ ->
+          oo_wrap mexp.mod_env true (fun () ->
+            compile_functor mexp cc rootpath loc) ()
       | Tmod_apply(funct, arg, ccarg) ->
           let inlined_attribute, funct =
             Translattribute.get_and_remove_inlined_attribute_on_module funct
@@ -501,6 +550,14 @@ and transl_structure loc fields cc rootpath final_env = function
             Translattribute.add_inline_attribute module_body mb.mb_loc
                                                  mb.mb_attributes
           in
+          let module_body =
+            Levent (module_body, {
+              lev_loc = mb.mb_loc;
+              lev_kind = Lev_module_definition id;
+              lev_repr = None;
+              lev_env = Env.summary Env.empty;
+            })
+          in
           Llet(pure_module mb.mb_expr, Pgenval, id,
                module_body,
                body), size
@@ -513,8 +570,16 @@ and transl_structure loc fields cc rootpath final_env = function
           in
           let lam =
             compile_recmodule
-              (fun id modl ->
-                 transl_module Tcoerce_none (field_path rootpath id) modl)
+              (fun id modl loc ->
+                 let module_body =
+                   transl_module Tcoerce_none (field_path rootpath id) modl
+                 in
+                 Levent (module_body, {
+                   lev_loc = loc;
+                   lev_kind = Lev_module_definition id;
+                   lev_repr = None;
+                   lev_env = Env.summary Env.empty;
+                 }))
               bindings
               body
           in
@@ -851,7 +916,7 @@ let transl_store_structure glob map prims str =
         | Tstr_recmodule bindings ->
             let ids = List.map (fun mb -> mb.mb_id) bindings in
             compile_recmodule
-              (fun id modl ->
+              (fun id modl _loc ->
                  subst_lambda subst
                    (transl_module Tcoerce_none
                       (field_path rootpath id) modl))
@@ -1118,7 +1183,7 @@ let transl_toplevel_item item =
   | Tstr_recmodule bindings ->
       let idents = List.map (fun mb -> mb.mb_id) bindings in
       compile_recmodule
-        (fun id modl -> transl_module Tcoerce_none (Some(Pident id)) modl)
+        (fun id modl _loc -> transl_module Tcoerce_none (Some(Pident id)) modl)
         bindings
         (make_sequence toploop_setvalue_id idents)
   | Tstr_class cl_list ->
@@ -1256,6 +1321,9 @@ let report_error ppf = function
         "@[Cannot safely evaluate the definition@ \
          of the recursively-defined module %a@]"
         Printtyp.ident id
+  | Conflicting_inline_attributes ->
+      fprintf ppf
+        "@[Conflicting ``inline'' attributes@]"
 
 let () =
   Location.register_error_of_exn

diff --git a/bytecomp/translmod.mli b/bytecomp/translmod.mli
index f613a2f421a018f882de2e3ce03a5be269c956bf..1b86328d8aec2939843d8799f3b677e1e522a015 100644 (file)
--- a/bytecomp/translmod.mli
+++ b/bytecomp/translmod.mli
@@ -44,6 +44,7 @@ val primitive_declarations: Primitive.description list ref
 
 type error =
   Circular_dependency of Ident.t
+| Conflicting_inline_attributes
 
 exception Error of Location.t * error
 

diff --git a/bytecomp/translobj.ml b/bytecomp/translobj.ml
index 17560db23e9e0a3c2a1f27c3073e918f27433f4c..c3dd9793fe914a37d27015fc1ad607c08aec7ef1 100644 (file)
--- a/bytecomp/translobj.ml
+++ b/bytecomp/translobj.ml
@@ -114,7 +114,7 @@ let transl_label_init_flambda f =
   assert(Config.flambda);
   let method_cache_id = Ident.create "method_cache" in
   method_cache := Lvar method_cache_id;
-  (* Calling f (usualy Translmod.transl_struct) requires the
+  (* Calling f (usually Translmod.transl_struct) requires the
      method_cache variable to be initialised to be able to generate
      method accesses. *)
   let expr, size = f () in

diff --git a/bytecomp/typeopt.ml b/bytecomp/typeopt.ml
deleted file mode 100644 (file)
index 93b7ec6..0000000
--- a/bytecomp/typeopt.ml
+++ /dev/null
@@ -1,174 +0,0 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                 OCaml                                  *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, 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 GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
-(* Auxiliaries for type-based optimizations, e.g. array kinds *)
-
-open Path
-open Types
-open Typedtree
-open Lambda
-
-let scrape_ty env ty =
-  let ty = Ctype.expand_head_opt env (Ctype.correct_levels ty) in
-  match ty.desc with
-  | Tconstr (p, _, _) ->
-      begin match Env.find_type p env with
-      | {type_unboxed = {unboxed = true; _}; _} ->
-        begin match Typedecl.get_unboxed_type_representation env ty with
-        | None -> ty
-        | Some ty2 -> ty2
-        end
-      | _ -> ty
-      | exception Not_found -> ty
-      end
-  | _ -> ty
-
-let scrape env ty =
-  (scrape_ty env ty).desc
-
-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_type env ty =
-  if Ctype.maybe_pointer_type env ty then
-    Pointer
-  else
-    Immediate
-
-let maybe_pointer exp = maybe_pointer_type exp.exp_env exp.exp_type
-
-type classification =
-  | Int
-  | Float
-  | Lazy
-  | Addr  (* anything except a float or a lazy *)
-  | Any
-
-let classify env ty =
-  let ty = scrape_ty env ty in
-  if maybe_pointer_type env ty = Immediate then Int
-  else match ty.desc with
-  | Tvar _ | Tunivar _ ->
-      Any
-  | Tconstr (p, _args, _abbrev) ->
-      if Path.same p Predef.path_float then Float
-      else if Path.same p Predef.path_lazy_t then Lazy
-      else if Path.same p Predef.path_string
-           || Path.same p Predef.path_bytes
-           || Path.same p Predef.path_array
-           || Path.same p Predef.path_nativeint
-           || Path.same p Predef.path_int32
-           || Path.same p Predef.path_int64 then Addr
-      else begin
-        try
-          match (Env.find_type p env).type_kind with
-          | Type_abstract ->
-              Any
-          | Type_record _ | Type_variant _ | Type_open ->
-              Addr
-        with Not_found ->
-          (* This can happen due to e.g. missing -I options,
-             causing some .cmi files to be unavailable.
-             Maybe we should emit a warning. *)
-          Any
-      end
-  | Tarrow _ | Ttuple _ | Tpackage _ | Tobject _ | Tnil | Tvariant _ ->
-      Addr
-  | Tlink _ | Tsubst _ | Tpoly _ | Tfield _ ->
-      assert false
-
-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 ->
-      begin match classify env elt_ty with
-      | Any -> Pgenarray
-      | Float -> Pfloatarray
-      | Addr | Lazy -> Paddrarray
-      | Int -> Pintarray
-      end
-
-  | _ ->
-      (* This can happen with e.g. Obj.field *)
-      Pgenarray
-
-let array_kind exp = array_type_kind exp.exp_env exp.exp_type
-
-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
-  | Tconstr(Pdot(Pident mod_id, type_name, _), [], _)
-    when Ident.name mod_id = "Bigarray" ->
-      begin try List.assoc type_name tbl with Not_found -> dfl end
-  | _ ->
-      dfl
-
-let kind_table =
-  ["float32_elt", Pbigarray_float32;
-   "float64_elt", Pbigarray_float64;
-   "int8_signed_elt", Pbigarray_sint8;
-   "int8_unsigned_elt", Pbigarray_uint8;
-   "int16_signed_elt", Pbigarray_sint16;
-   "int16_unsigned_elt", Pbigarray_uint16;
-   "int32_elt", Pbigarray_int32;
-   "int64_elt", Pbigarray_int64;
-   "int_elt", Pbigarray_caml_int;
-   "nativeint_elt", Pbigarray_native_int;
-   "complex32_elt", Pbigarray_complex32;
-   "complex64_elt", Pbigarray_complex64]
-
-let layout_table =
-  ["c_layout", Pbigarray_c_layout;
-   "fortran_layout", Pbigarray_fortran_layout]
-
-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 env elt_type kind_table Pbigarray_unknown,
-       bigarray_decode_type env layout_type layout_table
-                            Pbigarray_unknown_layout)
-  | _ ->
-      (Pbigarray_unknown, Pbigarray_unknown_layout)
-
-let value_kind env ty =
-  match scrape env ty with
-  | Tconstr(p, _, _) when Path.same p Predef.path_int ->
-      Pintval
-  | Tconstr(p, _, _) when Path.same p Predef.path_char ->
-      Pintval
-  | Tconstr(p, _, _) when Path.same p Predef.path_float ->
-      Pfloatval
-  | Tconstr(p, _, _) when Path.same p Predef.path_int32 ->
-      Pboxedintval Pint32
-  | Tconstr(p, _, _) when Path.same p Predef.path_int64 ->
-      Pboxedintval Pint64
-  | Tconstr(p, _, _) when Path.same p Predef.path_nativeint ->
-      Pboxedintval Pnativeint
-  | _ ->
-      Pgenval
-
-
-let lazy_val_requires_forward env ty =
-  match classify env ty with
-  | Any | Float | Lazy -> true
-  | Addr | Int -> false

diff --git a/bytecomp/typeopt.mli b/bytecomp/typeopt.mli
deleted file mode 100644 (file)
index 6ac3bbc..0000000
--- a/bytecomp/typeopt.mli
+++ /dev/null
@@ -1,35 +0,0 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                 OCaml                                  *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, 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 GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
-(* 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 maybe_pointer_type : Env.t -> Types.type_expr
-  -> Lambda.immediate_or_pointer
-val maybe_pointer : Typedtree.expression -> Lambda.immediate_or_pointer
-
-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_type_kind_and_layout :
-      Env.t -> Types.type_expr -> Lambda.bigarray_kind * Lambda.bigarray_layout
-val value_kind : Env.t -> Types.type_expr -> Lambda.value_kind
-
-val lazy_val_requires_forward : Env.t -> Types.type_expr -> bool
-  (** Whether a forward block is needed for a lazy thunk on a value, i.e.
-      if the value can be represented as a float/forward/lazy *)

diff --git a/byterun/.depend b/byterun/.depend
index c177d13f20156be37a54b9882f8988d77b8c76e5..21a592ad69131b8ce8e773e3c53ef0d112a0c110 100644 (file)
--- a/byterun/.depend
+++ b/byterun/.depend
@@ -1,856 +1,807 @@
-afl.o: afl.c caml/misc.h caml/config.h caml/../../config/m.h \
-  caml/../../config/s.h caml/mlvalues.h caml/osdeps.h
-alloc.o: alloc.c caml/alloc.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/minor_gc.h caml/address_class.h caml/stacks.h
-array.o: array.c caml/alloc.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/signals.h caml/spacetime.h
-backtrace.o: backtrace.c caml/alloc.h caml/misc.h caml/config.h \
-  caml/../../config/m.h caml/../../config/s.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/backtrace.h caml/exec.h \
-  caml/backtrace_prim.h caml/fail.h
-backtrace_prim.o: backtrace_prim.c caml/config.h caml/../../config/m.h \
-  caml/../../config/s.h caml/mlvalues.h caml/misc.h caml/alloc.h \
-  caml/custom.h caml/io.h caml/instruct.h caml/intext.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/stacks.h caml/sys.h caml/backtrace.h caml/fail.h \
-  caml/backtrace_prim.h
-callback.o: callback.c caml/callback.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/interp.h caml/instruct.h \
-  caml/fix_code.h caml/stacks.h
-compact.o: compact.c caml/address_class.h caml/config.h \
-  caml/../../config/m.h caml/../../config/s.h caml/misc.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/gc_ctrl.h \
-  caml/weak.h caml/compact.h
-compare.o: compare.c caml/custom.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 \
+afl.$(O): afl.c caml/config.h caml/m.h caml/s.h caml/misc.h caml/mlvalues.h \
+  caml/osdeps.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \
   caml/minor_gc.h caml/address_class.h
-custom.o: custom.c caml/alloc.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
-debugger.o: debugger.c caml/alloc.h caml/misc.h caml/config.h \
-  caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \
-  caml/debugger.h caml/osdeps.h caml/fail.h caml/fix_code.h \
-  caml/instruct.h caml/intext.h caml/io.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/alloc.h caml/misc.h caml/mlvalues.h \
-  caml/dynlink.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/osdeps.h \
-  caml/prims.h caml/signals.h
-extern.o: extern.c caml/alloc.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/md5.h \
-  caml/memory.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \
-  caml/address_class.h caml/reverse.h
-fail.o: fail.c caml/alloc.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/major_gc.h \
-  caml/freelist.h caml/minor_gc.h caml/address_class.h caml/printexc.h \
-  caml/signals.h caml/stacks.h
-finalise.o: finalise.c caml/callback.h caml/mlvalues.h caml/config.h \
-  caml/../../config/m.h caml/../../config/s.h caml/misc.h caml/compact.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/signals.h
-fix_code.o: fix_code.c caml/config.h caml/../../config/m.h \
-  caml/../../config/s.h caml/debugger.h caml/misc.h caml/mlvalues.h \
-  caml/fix_code.h caml/instruct.h caml/intext.h caml/io.h caml/md5.h \
+alloc.$(O): alloc.c caml/alloc.h caml/misc.h caml/config.h caml/m.h caml/s.h \
+  caml/mlvalues.h caml/custom.h caml/major_gc.h caml/freelist.h \
+  caml/memory.h caml/gc.h caml/minor_gc.h caml/address_class.h \
+  caml/stacks.h
+array.$(O): array.c caml/alloc.h caml/misc.h caml/config.h caml/m.h caml/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/signals.h \
+  caml/spacetime.h
+backtrace.$(O): backtrace.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \
+  caml/s.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/backtrace.h \
+  caml/exec.h caml/backtrace_prim.h caml/fail.h
+backtrace_prim.$(O): backtrace_prim.c caml/config.h caml/m.h caml/s.h \
+  caml/mlvalues.h caml/misc.h caml/alloc.h caml/custom.h caml/io.h \
+  caml/instruct.h caml/intext.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/reverse.h
-floats.o: floats.c caml/alloc.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/reverse.h caml/stacks.h
-freelist.o: freelist.c caml/config.h caml/../../config/m.h \
-  caml/../../config/s.h caml/freelist.h caml/misc.h caml/mlvalues.h \
-  caml/gc.h caml/gc_ctrl.h caml/memory.h caml/major_gc.h caml/minor_gc.h \
-  caml/address_class.h
-gc_ctrl.o: gc_ctrl.c caml/alloc.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/compact.h caml/custom.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/gc_ctrl.h \
-  caml/signals.h caml/stacks.h caml/startup_aux.h
-globroots.o: globroots.c caml/memory.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/roots.h caml/globroots.h
-hash.o: hash.c caml/mlvalues.h caml/config.h caml/../../config/m.h \
-  caml/../../config/s.h caml/misc.h caml/custom.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 caml/alloc.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/md5.h caml/memory.h caml/major_gc.h caml/freelist.h \
-  caml/minor_gc.h caml/address_class.h caml/reverse.h
-interp.o: interp.c caml/alloc.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/minor_gc.h caml/address_class.h caml/prims.h caml/signals.h \
-  caml/stacks.h caml/startup_aux.h caml/jumptbl.h
-ints.o: ints.c caml/alloc.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/minor_gc.h caml/address_class.h caml/startup.h caml/stacks.h \
+  caml/sys.h caml/backtrace.h caml/fail.h caml/backtrace_prim.h
+bigarray.$(O): bigarray.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \
+  caml/s.h caml/mlvalues.h caml/bigarray.h caml/custom.h caml/fail.h \
+  caml/intext.h caml/io.h caml/hash.h caml/memory.h caml/gc.h \
+  caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h
+callback.$(O): callback.c caml/callback.h caml/mlvalues.h caml/config.h \
+  caml/m.h caml/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/interp.h caml/instruct.h caml/fix_code.h caml/stacks.h
+compact.$(O): compact.c caml/address_class.h caml/config.h caml/m.h caml/s.h \
+  caml/misc.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/gc_ctrl.h caml/weak.h caml/compact.h
+compare.$(O): compare.c caml/custom.h caml/mlvalues.h caml/config.h caml/m.h \
+  caml/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
+custom.$(O): custom.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \
+  caml/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
-io.o: io.c caml/config.h caml/../../config/m.h caml/../../config/s.h \
-  caml/alloc.h caml/misc.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/osdeps.h caml/signals.h \
-  caml/sys.h
-lexing.o: lexing.c caml/fail.h caml/misc.h caml/config.h \
-  caml/../../config/m.h caml/../../config/s.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/config.h caml/../../config/m.h \
-  caml/../../config/s.h caml/mlvalues.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/misc.h caml/mlvalues.h caml/custom.h \
-  caml/fail.h caml/finalise.h caml/roots.h caml/memory.h caml/gc.h \
+debugger.$(O): debugger.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \
+  caml/s.h caml/mlvalues.h caml/debugger.h caml/osdeps.h caml/memory.h \
+  caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \
+  caml/address_class.h caml/fail.h caml/fix_code.h caml/instruct.h \
+  caml/intext.h caml/io.h caml/stacks.h caml/sys.h
+dynlink.$(O): dynlink.c caml/config.h caml/m.h caml/s.h caml/alloc.h \
+  caml/misc.h caml/mlvalues.h caml/dynlink.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/osdeps.h caml/prims.h caml/signals.h
+extern.$(O): extern.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \
+  caml/s.h caml/mlvalues.h caml/custom.h caml/fail.h caml/gc.h \
+  caml/intext.h caml/io.h caml/md5.h caml/memory.h caml/major_gc.h \
+  caml/freelist.h caml/minor_gc.h caml/address_class.h caml/reverse.h
+fail.$(O): fail.c caml/alloc.h caml/misc.h caml/config.h caml/m.h caml/s.h \
+  caml/mlvalues.h caml/fail.h caml/io.h caml/gc.h caml/memory.h \
   caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \
-  caml/gc_ctrl.h caml/signals.h caml/weak.h
-md5.o: md5.c caml/alloc.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/reverse.h
-memory.o: memory.c caml/address_class.h caml/config.h \
-  caml/../../config/m.h caml/../../config/s.h caml/misc.h \
-  caml/mlvalues.h caml/fail.h caml/freelist.h caml/gc.h caml/gc_ctrl.h \
-  caml/major_gc.h caml/memory.h caml/minor_gc.h caml/signals.h
-meta.o: meta.c caml/alloc.h caml/misc.h caml/config.h \
-  caml/../../config/m.h caml/../../config/s.h caml/mlvalues.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/minor_gc.h caml/address_class.h caml/prims.h caml/stacks.h
-minor_gc.o: minor_gc.c caml/custom.h caml/mlvalues.h caml/config.h \
-  caml/../../config/m.h caml/../../config/s.h caml/misc.h caml/fail.h \
+  caml/printexc.h caml/signals.h caml/stacks.h
+finalise.$(O): finalise.c caml/callback.h caml/mlvalues.h caml/config.h \
+  caml/m.h caml/s.h caml/misc.h caml/compact.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/gc_ctrl.h \
-  caml/signals.h caml/weak.h
-misc.o: misc.c caml/config.h caml/../../config/m.h caml/../../config/s.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/osdeps.h \
-  caml/version.h
-obj.o: obj.c caml/alloc.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/minor_gc.h caml/address_class.h caml/prims.h caml/spacetime.h
-parsing.o: parsing.c caml/config.h caml/../../config/m.h \
-  caml/../../config/s.h caml/mlvalues.h caml/misc.h caml/memory.h \
-  caml/gc.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/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/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/printexc.h
-roots.o: roots.c caml/finalise.h caml/roots.h caml/misc.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/stacks.h
-signals.o: signals.c caml/alloc.h caml/misc.h caml/config.h \
-  caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \
-  caml/callback.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/roots.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/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 caml/osdeps.h caml/signals.h \
-  caml/signals_machdep.h
-spacetime.o: spacetime.c caml/fail.h caml/misc.h caml/config.h \
-  caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h
-stacks.o: stacks.c caml/config.h caml/../../config/m.h \
-  caml/../../config/s.h caml/fail.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/alloc.h caml/misc.h caml/mlvalues.h \
-  caml/backtrace.h caml/exec.h caml/callback.h caml/custom.h \
-  caml/debugger.h caml/dynlink.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/memory.h caml/gc.h caml/major_gc.h \
-  caml/minor_gc.h caml/address_class.h caml/osdeps.h caml/prims.h \
-  caml/printexc.h caml/reverse.h caml/signals.h caml/stacks.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/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/osdeps.h caml/startup_aux.h
-str.o: str.c caml/alloc.h caml/misc.h caml/config.h caml/../../config/m.h \
-  caml/../../config/s.h caml/mlvalues.h caml/fail.h
-sys.o: sys.c caml/config.h caml/../../config/m.h caml/../../config/s.h \
-  caml/alloc.h caml/misc.h caml/mlvalues.h caml/debugger.h caml/fail.h \
-  caml/gc_ctrl.h caml/instruct.h caml/io.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/version.h
-terminfo.o: terminfo.c caml/config.h caml/../../config/m.h \
-  caml/../../config/s.h caml/alloc.h caml/misc.h caml/mlvalues.h \
-  caml/fail.h caml/io.h
-unix.o: unix.c caml/config.h caml/../../config/m.h caml/../../config/s.h \
-  caml/fail.h caml/misc.h caml/mlvalues.h caml/memory.h caml/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/m.h caml/s.h caml/debugger.h \
+  caml/misc.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/osdeps.h caml/signals.h caml/sys.h caml/io.h
-weak.o: weak.c caml/alloc.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/minor_gc.h caml/address_class.h caml/weak.h
-afl.d.o: afl.c caml/misc.h caml/config.h caml/../../config/m.h \
-  caml/../../config/s.h caml/mlvalues.h caml/osdeps.h
-alloc.d.o: alloc.c caml/alloc.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/minor_gc.h caml/address_class.h caml/stacks.h
-array.d.o: array.c caml/alloc.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/signals.h caml/spacetime.h
-backtrace.d.o: backtrace.c caml/alloc.h caml/misc.h caml/config.h \
-  caml/../../config/m.h caml/../../config/s.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/backtrace.h caml/exec.h \
-  caml/backtrace_prim.h caml/fail.h
-backtrace_prim.d.o: backtrace_prim.c caml/config.h caml/../../config/m.h \
-  caml/../../config/s.h caml/mlvalues.h caml/misc.h caml/alloc.h \
-  caml/custom.h caml/io.h caml/instruct.h caml/intext.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/stacks.h caml/sys.h caml/backtrace.h caml/fail.h \
-  caml/backtrace_prim.h
-callback.d.o: callback.c caml/callback.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/interp.h caml/instruct.h \
-  caml/fix_code.h caml/stacks.h
-compact.d.o: compact.c caml/address_class.h caml/config.h \
-  caml/../../config/m.h caml/../../config/s.h caml/misc.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/gc_ctrl.h \
-  caml/weak.h caml/compact.h
-compare.d.o: compare.c caml/custom.h caml/mlvalues.h caml/config.h \
-  caml/../../config/m.h caml/../../config/s.h caml/misc.h caml/fail.h \
+  caml/reverse.h
+floats.$(O): floats.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \
+  caml/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/reverse.h caml/stacks.h
+freelist.$(O): freelist.c caml/config.h caml/m.h caml/s.h caml/freelist.h \
+  caml/misc.h caml/mlvalues.h caml/gc.h caml/gc_ctrl.h caml/memory.h \
+  caml/major_gc.h caml/minor_gc.h caml/address_class.h
+gc_ctrl.$(O): gc_ctrl.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \
+  caml/s.h caml/mlvalues.h caml/backtrace.h caml/exec.h caml/compact.h \
+  caml/custom.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/gc_ctrl.h caml/signals.h caml/stacks.h \
+  caml/startup_aux.h
+globroots.$(O): globroots.c caml/memory.h caml/config.h caml/m.h caml/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/roots.h caml/globroots.h
+hash.$(O): hash.c caml/mlvalues.h caml/config.h caml/m.h caml/s.h \
+  caml/misc.h caml/custom.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 caml/alloc.h caml/misc.h caml/config.h caml/m.h \
+  caml/s.h caml/mlvalues.h caml/callback.h caml/custom.h caml/fail.h \
+  caml/gc.h caml/intext.h caml/io.h caml/md5.h caml/memory.h \
+  caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \
+  caml/reverse.h
+interp.$(O): interp.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \
+  caml/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/minor_gc.h caml/address_class.h \
+  caml/prims.h caml/signals.h caml/stacks.h caml/startup_aux.h \
+  caml/jumptbl.h
+ints.$(O): ints.c caml/alloc.h caml/misc.h caml/config.h caml/m.h caml/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
-custom.d.o: custom.c caml/alloc.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
-debugger.d.o: debugger.c caml/alloc.h caml/misc.h caml/config.h \
-  caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \
-  caml/debugger.h caml/osdeps.h caml/fail.h caml/fix_code.h \
-  caml/instruct.h caml/intext.h caml/io.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/alloc.h caml/misc.h caml/mlvalues.h \
-  caml/dynlink.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/osdeps.h \
-  caml/prims.h caml/signals.h
-extern.d.o: extern.c caml/alloc.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/md5.h \
-  caml/memory.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \
+io.$(O): io.c caml/config.h caml/m.h caml/s.h caml/alloc.h caml/misc.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/osdeps.h caml/signals.h caml/sys.h
+lexing.$(O): lexing.c caml/fail.h caml/misc.h caml/config.h caml/m.h \
+  caml/s.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/config.h caml/m.h caml/s.h \
+  caml/mlvalues.h caml/sys.h caml/osdeps.h caml/memory.h caml/gc.h \
+  caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h
+major_gc.$(O): major_gc.c caml/compact.h caml/config.h caml/m.h caml/s.h \
+  caml/misc.h caml/mlvalues.h caml/custom.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/gc_ctrl.h caml/signals.h \
+  caml/weak.h
+md5.$(O): md5.c caml/alloc.h caml/misc.h caml/config.h caml/m.h caml/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/reverse.h
-fail.d.o: fail.c caml/alloc.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/major_gc.h \
-  caml/freelist.h caml/minor_gc.h caml/address_class.h caml/printexc.h \
-  caml/signals.h caml/stacks.h
-finalise.d.o: finalise.c caml/callback.h caml/mlvalues.h caml/config.h \
-  caml/../../config/m.h caml/../../config/s.h caml/misc.h caml/compact.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 \
+memory.$(O): memory.c caml/address_class.h caml/config.h caml/m.h caml/s.h \
+  caml/misc.h caml/mlvalues.h caml/fail.h caml/freelist.h caml/gc.h \
+  caml/gc_ctrl.h caml/major_gc.h caml/memory.h caml/minor_gc.h \
   caml/signals.h
-fix_code.d.o: fix_code.c caml/config.h caml/../../config/m.h \
-  caml/../../config/s.h caml/debugger.h caml/misc.h caml/mlvalues.h \
-  caml/fix_code.h caml/instruct.h caml/intext.h caml/io.h caml/md5.h \
+meta.$(O): meta.c caml/alloc.h caml/misc.h caml/config.h caml/m.h caml/s.h \
+  caml/mlvalues.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/minor_gc.h caml/address_class.h caml/prims.h \
+  caml/stacks.h
+minor_gc.$(O): minor_gc.c caml/custom.h caml/mlvalues.h caml/config.h \
+  caml/m.h caml/s.h caml/misc.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/reverse.h
-floats.d.o: floats.c caml/alloc.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/reverse.h caml/stacks.h
-freelist.d.o: freelist.c caml/config.h caml/../../config/m.h \
-  caml/../../config/s.h caml/freelist.h caml/misc.h caml/mlvalues.h \
-  caml/gc.h caml/gc_ctrl.h caml/memory.h caml/major_gc.h caml/minor_gc.h \
-  caml/address_class.h
-gc_ctrl.d.o: gc_ctrl.c caml/alloc.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/compact.h caml/custom.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/gc_ctrl.h \
-  caml/signals.h caml/stacks.h caml/startup_aux.h
-globroots.d.o: globroots.c caml/memory.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/roots.h caml/globroots.h
-hash.d.o: hash.c caml/mlvalues.h caml/config.h caml/../../config/m.h \
-  caml/../../config/s.h caml/misc.h caml/custom.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/instrtrace.h caml/mlvalues.h \
-  caml/config.h caml/../../config/m.h caml/../../config/s.h caml/misc.h \
-  caml/instruct.h caml/opnames.h caml/prims.h caml/stacks.h \
+  caml/minor_gc.h caml/address_class.h caml/gc_ctrl.h caml/signals.h \
+  caml/weak.h
+misc.$(O): misc.c caml/config.h caml/m.h caml/s.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/osdeps.h caml/version.h
+obj.$(O): obj.c caml/alloc.h caml/misc.h caml/config.h caml/m.h caml/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/minor_gc.h caml/address_class.h \
+  caml/prims.h caml/spacetime.h
+parsing.$(O): parsing.c caml/config.h caml/m.h caml/s.h caml/mlvalues.h \
+  caml/misc.h caml/memory.h caml/gc.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/config.h caml/m.h caml/s.h \
+  caml/misc.h caml/prims.h
+printexc.$(O): printexc.c caml/backtrace.h caml/mlvalues.h caml/config.h \
+  caml/m.h caml/s.h caml/misc.h caml/exec.h caml/callback.h \
+  caml/debugger.h caml/fail.h caml/printexc.h caml/memory.h caml/gc.h \
+  caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h
+roots.$(O): roots.c caml/finalise.h caml/roots.h caml/misc.h caml/config.h \
+  caml/m.h caml/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/stacks.h
+signals.$(O): signals.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \
+  caml/s.h caml/mlvalues.h caml/callback.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/roots.h caml/signals.h \
+  caml/signals_machdep.h caml/sys.h
+signals_byt.$(O): signals_byt.c caml/config.h caml/m.h caml/s.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 caml/osdeps.h \
+  caml/signals.h caml/signals_machdep.h
+spacetime.$(O): spacetime.c caml/fail.h caml/misc.h caml/config.h caml/m.h \
+  caml/s.h caml/mlvalues.h
+stacks.$(O): stacks.c caml/config.h caml/m.h caml/s.h caml/fail.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/m.h caml/s.h caml/alloc.h \
+  caml/misc.h caml/mlvalues.h caml/backtrace.h caml/exec.h \
+  caml/callback.h caml/custom.h caml/debugger.h caml/dynlink.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/memory.h \
+  caml/gc.h caml/major_gc.h caml/minor_gc.h caml/address_class.h \
+  caml/osdeps.h caml/prims.h caml/printexc.h caml/reverse.h \
+  caml/signals.h caml/stacks.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/config.h caml/m.h caml/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/callback.h caml/dynlink.h caml/osdeps.h \
+  caml/startup_aux.h
+str.$(O): str.c caml/alloc.h caml/misc.h caml/config.h caml/m.h caml/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
+sys.$(O): sys.c caml/config.h caml/m.h caml/s.h caml/alloc.h caml/misc.h \
+  caml/mlvalues.h caml/debugger.h caml/fail.h caml/gc_ctrl.h caml/io.h \
+  caml/osdeps.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 caml/stacks.h \
+  caml/sys.h caml/version.h caml/callback.h caml/startup_aux.h
+terminfo.$(O): terminfo.c caml/config.h caml/m.h caml/s.h caml/alloc.h \
+  caml/misc.h caml/mlvalues.h caml/fail.h caml/io.h
+unix.$(O): unix.c caml/config.h caml/m.h caml/s.h caml/fail.h caml/misc.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/osdeps.h \
+  caml/signals.h caml/sys.h caml/io.h caml/alloc.h
+weak.$(O): weak.c caml/alloc.h caml/misc.h caml/config.h caml/m.h caml/s.h \
+  caml/mlvalues.h caml/fail.h caml/major_gc.h caml/freelist.h \
+  caml/memory.h caml/gc.h caml/minor_gc.h caml/address_class.h \
+  caml/weak.h
+afl.d.$(O): afl.c caml/config.h caml/m.h caml/s.h caml/misc.h caml/mlvalues.h \
+  caml/osdeps.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \
+  caml/minor_gc.h caml/address_class.h
+alloc.d.$(O): alloc.c caml/alloc.h caml/misc.h caml/config.h caml/m.h caml/s.h \
+  caml/mlvalues.h caml/custom.h caml/major_gc.h caml/freelist.h \
+  caml/memory.h caml/gc.h caml/minor_gc.h caml/address_class.h \
+  caml/stacks.h
+array.d.$(O): array.c caml/alloc.h caml/misc.h caml/config.h caml/m.h caml/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/signals.h \
+  caml/spacetime.h
+backtrace.d.$(O): backtrace.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \
+  caml/s.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/backtrace.h \
+  caml/exec.h caml/backtrace_prim.h caml/fail.h
+backtrace_prim.d.$(O): backtrace_prim.c caml/config.h caml/m.h caml/s.h \
+  caml/mlvalues.h caml/misc.h caml/alloc.h caml/custom.h caml/io.h \
+  caml/instruct.h caml/intext.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_aux.h
-intern.d.o: intern.c caml/alloc.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/md5.h caml/memory.h caml/major_gc.h caml/freelist.h \
-  caml/minor_gc.h caml/address_class.h caml/reverse.h
-interp.d.o: interp.c caml/alloc.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/minor_gc.h caml/address_class.h caml/prims.h caml/signals.h \
-  caml/stacks.h caml/startup_aux.h
-ints.d.o: ints.c caml/alloc.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/minor_gc.h caml/address_class.h caml/startup.h caml/stacks.h \
+  caml/sys.h caml/backtrace.h caml/fail.h caml/backtrace_prim.h
+bigarray.d.$(O): bigarray.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \
+  caml/s.h caml/mlvalues.h caml/bigarray.h caml/custom.h caml/fail.h \
+  caml/intext.h caml/io.h caml/hash.h caml/memory.h caml/gc.h \
+  caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h
+callback.d.$(O): callback.c caml/callback.h caml/mlvalues.h caml/config.h \
+  caml/m.h caml/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/interp.h caml/instruct.h caml/fix_code.h caml/stacks.h
+compact.d.$(O): compact.c caml/address_class.h caml/config.h caml/m.h caml/s.h \
+  caml/misc.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/gc_ctrl.h caml/weak.h caml/compact.h
+compare.d.$(O): compare.c caml/custom.h caml/mlvalues.h caml/config.h caml/m.h \
+  caml/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
+custom.d.$(O): custom.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \
+  caml/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
-io.d.o: io.c caml/config.h caml/../../config/m.h caml/../../config/s.h \
-  caml/alloc.h caml/misc.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/osdeps.h caml/signals.h \
-  caml/sys.h
-lexing.d.o: lexing.c caml/fail.h caml/misc.h caml/config.h \
-  caml/../../config/m.h caml/../../config/s.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/config.h caml/../../config/m.h \
-  caml/../../config/s.h caml/mlvalues.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/misc.h caml/mlvalues.h caml/custom.h \
-  caml/fail.h caml/finalise.h caml/roots.h caml/memory.h caml/gc.h \
+debugger.d.$(O): debugger.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \
+  caml/s.h caml/mlvalues.h caml/debugger.h caml/osdeps.h caml/memory.h \
+  caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \
+  caml/address_class.h caml/fail.h caml/fix_code.h caml/instruct.h \
+  caml/intext.h caml/io.h caml/stacks.h caml/sys.h
+dynlink.d.$(O): dynlink.c caml/config.h caml/m.h caml/s.h caml/alloc.h \
+  caml/misc.h caml/mlvalues.h caml/dynlink.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/osdeps.h caml/prims.h caml/signals.h
+extern.d.$(O): extern.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \
+  caml/s.h caml/mlvalues.h caml/custom.h caml/fail.h caml/gc.h \
+  caml/intext.h caml/io.h caml/md5.h caml/memory.h caml/major_gc.h \
+  caml/freelist.h caml/minor_gc.h caml/address_class.h caml/reverse.h
+fail.d.$(O): fail.c caml/alloc.h caml/misc.h caml/config.h caml/m.h caml/s.h \
+  caml/mlvalues.h caml/fail.h caml/io.h caml/gc.h caml/memory.h \
   caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \
-  caml/gc_ctrl.h caml/signals.h caml/weak.h
-md5.d.o: md5.c caml/alloc.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/reverse.h
-memory.d.o: memory.c caml/address_class.h caml/config.h \
-  caml/../../config/m.h caml/../../config/s.h caml/misc.h \
-  caml/mlvalues.h caml/fail.h caml/freelist.h caml/gc.h caml/gc_ctrl.h \
-  caml/major_gc.h caml/memory.h caml/minor_gc.h caml/signals.h
-meta.d.o: meta.c caml/alloc.h caml/misc.h caml/config.h \
-  caml/../../config/m.h caml/../../config/s.h caml/mlvalues.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/minor_gc.h caml/address_class.h caml/prims.h caml/stacks.h
-minor_gc.d.o: minor_gc.c caml/custom.h caml/mlvalues.h caml/config.h \
-  caml/../../config/m.h caml/../../config/s.h caml/misc.h caml/fail.h \
+  caml/printexc.h caml/signals.h caml/stacks.h
+finalise.d.$(O): finalise.c caml/callback.h caml/mlvalues.h caml/config.h \
+  caml/m.h caml/s.h caml/misc.h caml/compact.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/gc_ctrl.h \
-  caml/signals.h caml/weak.h
-misc.d.o: misc.c caml/config.h caml/../../config/m.h caml/../../config/s.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/osdeps.h \
-  caml/version.h
-obj.d.o: obj.c caml/alloc.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/minor_gc.h caml/address_class.h caml/prims.h caml/spacetime.h
-parsing.d.o: parsing.c caml/config.h caml/../../config/m.h \
-  caml/../../config/s.h caml/mlvalues.h caml/misc.h caml/memory.h \
-  caml/gc.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/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/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/printexc.h
-roots.d.o: roots.c caml/finalise.h caml/roots.h caml/misc.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/stacks.h
-signals.d.o: signals.c caml/alloc.h caml/misc.h caml/config.h \
-  caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \
-  caml/callback.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/roots.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/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 caml/osdeps.h caml/signals.h \
-  caml/signals_machdep.h
-spacetime.d.o: spacetime.c caml/fail.h caml/misc.h caml/config.h \
-  caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h
-stacks.d.o: stacks.c caml/config.h caml/../../config/m.h \
-  caml/../../config/s.h caml/fail.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/alloc.h caml/misc.h caml/mlvalues.h \
-  caml/backtrace.h caml/exec.h caml/callback.h caml/custom.h \
-  caml/debugger.h caml/dynlink.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/memory.h caml/gc.h caml/major_gc.h \
-  caml/minor_gc.h caml/address_class.h caml/osdeps.h caml/prims.h \
-  caml/printexc.h caml/reverse.h caml/signals.h caml/stacks.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/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/osdeps.h caml/startup_aux.h
-str.d.o: str.c caml/alloc.h caml/misc.h caml/config.h caml/../../config/m.h \
-  caml/../../config/s.h caml/mlvalues.h caml/fail.h
-sys.d.o: sys.c caml/config.h caml/../../config/m.h caml/../../config/s.h \
-  caml/alloc.h caml/misc.h caml/mlvalues.h caml/debugger.h caml/fail.h \
-  caml/gc_ctrl.h caml/instruct.h caml/io.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/version.h
-terminfo.d.o: terminfo.c caml/config.h caml/../../config/m.h \
-  caml/../../config/s.h caml/alloc.h caml/misc.h caml/mlvalues.h \
-  caml/fail.h caml/io.h
-unix.d.o: unix.c caml/config.h caml/../../config/m.h caml/../../config/s.h \
-  caml/fail.h caml/misc.h caml/mlvalues.h caml/memory.h caml/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/m.h caml/s.h caml/debugger.h \
+  caml/misc.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/osdeps.h caml/signals.h caml/sys.h caml/io.h
-weak.d.o: weak.c caml/alloc.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/minor_gc.h caml/address_class.h caml/weak.h
-afl.i.o: afl.c caml/misc.h caml/config.h caml/../../config/m.h \
-  caml/../../config/s.h caml/mlvalues.h caml/osdeps.h
-alloc.i.o: alloc.c caml/alloc.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/minor_gc.h caml/address_class.h caml/stacks.h
-array.i.o: array.c caml/alloc.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/signals.h caml/spacetime.h
-backtrace.i.o: backtrace.c caml/alloc.h caml/misc.h caml/config.h \
-  caml/../../config/m.h caml/../../config/s.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/backtrace.h caml/exec.h \
-  caml/backtrace_prim.h caml/fail.h
-backtrace_prim.i.o: backtrace_prim.c caml/config.h caml/../../config/m.h \
-  caml/../../config/s.h caml/mlvalues.h caml/misc.h caml/alloc.h \
-  caml/custom.h caml/io.h caml/instruct.h caml/intext.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/stacks.h caml/sys.h caml/backtrace.h caml/fail.h \
-  caml/backtrace_prim.h
-callback.i.o: callback.c caml/callback.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/interp.h caml/instruct.h \
-  caml/fix_code.h caml/stacks.h
-compact.i.o: compact.c caml/address_class.h caml/config.h \
-  caml/../../config/m.h caml/../../config/s.h caml/misc.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/gc_ctrl.h \
-  caml/weak.h caml/compact.h
-compare.i.o: compare.c caml/custom.h caml/mlvalues.h caml/config.h \
-  caml/../../config/m.h caml/../../config/s.h caml/misc.h caml/fail.h \
+  caml/reverse.h
+floats.d.$(O): floats.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \
+  caml/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/reverse.h caml/stacks.h
+freelist.d.$(O): freelist.c caml/config.h caml/m.h caml/s.h caml/freelist.h \
+  caml/misc.h caml/mlvalues.h caml/gc.h caml/gc_ctrl.h caml/memory.h \
+  caml/major_gc.h caml/minor_gc.h caml/address_class.h
+gc_ctrl.d.$(O): gc_ctrl.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \
+  caml/s.h caml/mlvalues.h caml/backtrace.h caml/exec.h caml/compact.h \
+  caml/custom.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/gc_ctrl.h caml/signals.h caml/stacks.h \
+  caml/startup_aux.h
+globroots.d.$(O): globroots.c caml/memory.h caml/config.h caml/m.h caml/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/roots.h caml/globroots.h
+hash.d.$(O): hash.c caml/mlvalues.h caml/config.h caml/m.h caml/s.h \
+  caml/misc.h caml/custom.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/instrtrace.h caml/mlvalues.h \
+  caml/config.h caml/m.h caml/s.h caml/misc.h caml/instruct.h \
+  caml/opnames.h caml/prims.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/startup_aux.h
+intern.d.$(O): intern.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \
+  caml/s.h caml/mlvalues.h caml/callback.h caml/custom.h caml/fail.h \
+  caml/gc.h caml/intext.h caml/io.h caml/md5.h caml/memory.h \
+  caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \
+  caml/reverse.h
+interp.d.$(O): interp.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \
+  caml/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/minor_gc.h caml/address_class.h \
+  caml/prims.h caml/signals.h caml/stacks.h caml/startup_aux.h
+ints.d.$(O): ints.c caml/alloc.h caml/misc.h caml/config.h caml/m.h caml/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
-custom.i.o: custom.c caml/alloc.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
-debugger.i.o: debugger.c caml/alloc.h caml/misc.h caml/config.h \
-  caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \
-  caml/debugger.h caml/osdeps.h caml/fail.h caml/fix_code.h \
-  caml/instruct.h caml/intext.h caml/io.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.i.o: dynlink.c caml/config.h caml/../../config/m.h \
-  caml/../../config/s.h caml/alloc.h caml/misc.h caml/mlvalues.h \
-  caml/dynlink.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/osdeps.h \
-  caml/prims.h caml/signals.h
-extern.i.o: extern.c caml/alloc.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/md5.h \
-  caml/memory.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \
+io.d.$(O): io.c caml/config.h caml/m.h caml/s.h caml/alloc.h caml/misc.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/osdeps.h caml/signals.h caml/sys.h
+lexing.d.$(O): lexing.c caml/fail.h caml/misc.h caml/config.h caml/m.h \
+  caml/s.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/config.h caml/m.h caml/s.h \
+  caml/mlvalues.h caml/sys.h caml/osdeps.h caml/memory.h caml/gc.h \
+  caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h
+major_gc.d.$(O): major_gc.c caml/compact.h caml/config.h caml/m.h caml/s.h \
+  caml/misc.h caml/mlvalues.h caml/custom.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/gc_ctrl.h caml/signals.h \
+  caml/weak.h
+md5.d.$(O): md5.c caml/alloc.h caml/misc.h caml/config.h caml/m.h caml/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/reverse.h
-fail.i.o: fail.c caml/alloc.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/major_gc.h \
-  caml/freelist.h caml/minor_gc.h caml/address_class.h caml/printexc.h \
-  caml/signals.h caml/stacks.h
-finalise.i.o: finalise.c caml/callback.h caml/mlvalues.h caml/config.h \
-  caml/../../config/m.h caml/../../config/s.h caml/misc.h caml/compact.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 \
+memory.d.$(O): memory.c caml/address_class.h caml/config.h caml/m.h caml/s.h \
+  caml/misc.h caml/mlvalues.h caml/fail.h caml/freelist.h caml/gc.h \
+  caml/gc_ctrl.h caml/major_gc.h caml/memory.h caml/minor_gc.h \
   caml/signals.h
-fix_code.i.o: fix_code.c caml/config.h caml/../../config/m.h \
-  caml/../../config/s.h caml/debugger.h caml/misc.h caml/mlvalues.h \
-  caml/fix_code.h caml/instruct.h caml/intext.h caml/io.h caml/md5.h \
+meta.d.$(O): meta.c caml/alloc.h caml/misc.h caml/config.h caml/m.h caml/s.h \
+  caml/mlvalues.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/minor_gc.h caml/address_class.h caml/prims.h \
+  caml/stacks.h
+minor_gc.d.$(O): minor_gc.c caml/custom.h caml/mlvalues.h caml/config.h \
+  caml/m.h caml/s.h caml/misc.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/reverse.h
-floats.i.o: floats.c caml/alloc.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/reverse.h caml/stacks.h
-freelist.i.o: freelist.c caml/config.h caml/../../config/m.h \
-  caml/../../config/s.h caml/freelist.h caml/misc.h caml/mlvalues.h \
-  caml/gc.h caml/gc_ctrl.h caml/memory.h caml/major_gc.h caml/minor_gc.h \
-  caml/address_class.h
-gc_ctrl.i.o: gc_ctrl.c caml/alloc.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/compact.h caml/custom.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/gc_ctrl.h \
-  caml/signals.h caml/stacks.h caml/startup_aux.h
-globroots.i.o: globroots.c caml/memory.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/roots.h caml/globroots.h
-hash.i.o: hash.c caml/mlvalues.h caml/config.h caml/../../config/m.h \
-  caml/../../config/s.h caml/misc.h caml/custom.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.i.o: instrtrace.c
-intern.i.o: intern.c caml/alloc.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/md5.h caml/memory.h caml/major_gc.h caml/freelist.h \
-  caml/minor_gc.h caml/address_class.h caml/reverse.h
-interp.i.o: interp.c caml/alloc.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/minor_gc.h caml/address_class.h caml/prims.h caml/signals.h \
-  caml/stacks.h caml/startup_aux.h caml/jumptbl.h
-ints.i.o: ints.c caml/alloc.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/minor_gc.h caml/address_class.h caml/gc_ctrl.h caml/signals.h \
+  caml/weak.h
+misc.d.$(O): misc.c caml/config.h caml/m.h caml/s.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/osdeps.h caml/version.h
+obj.d.$(O): obj.c caml/alloc.h caml/misc.h caml/config.h caml/m.h caml/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/minor_gc.h caml/address_class.h \
+  caml/prims.h caml/spacetime.h
+parsing.d.$(O): parsing.c caml/config.h caml/m.h caml/s.h caml/mlvalues.h \
+  caml/misc.h caml/memory.h caml/gc.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/config.h caml/m.h caml/s.h \
+  caml/misc.h caml/prims.h
+printexc.d.$(O): printexc.c caml/backtrace.h caml/mlvalues.h caml/config.h \
+  caml/m.h caml/s.h caml/misc.h caml/exec.h caml/callback.h \
+  caml/debugger.h caml/fail.h caml/printexc.h caml/memory.h caml/gc.h \
+  caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h
+roots.d.$(O): roots.c caml/finalise.h caml/roots.h caml/misc.h caml/config.h \
+  caml/m.h caml/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/stacks.h
+signals.d.$(O): signals.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \
+  caml/s.h caml/mlvalues.h caml/callback.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
-io.i.o: io.c caml/config.h caml/../../config/m.h caml/../../config/s.h \
-  caml/alloc.h caml/misc.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/osdeps.h caml/signals.h \
-  caml/sys.h
-lexing.i.o: lexing.c caml/fail.h caml/misc.h caml/config.h \
-  caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \
-  caml/stacks.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \
+  caml/address_class.h caml/roots.h caml/signals.h \
+  caml/signals_machdep.h caml/sys.h
+signals_byt.d.$(O): signals_byt.c caml/config.h caml/m.h caml/s.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 caml/osdeps.h \
+  caml/signals.h caml/signals_machdep.h
+spacetime.d.$(O): spacetime.c caml/fail.h caml/misc.h caml/config.h caml/m.h \
+  caml/s.h caml/mlvalues.h
+stacks.d.$(O): stacks.c caml/config.h caml/m.h caml/s.h caml/fail.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/m.h caml/s.h caml/alloc.h \
+  caml/misc.h caml/mlvalues.h caml/backtrace.h caml/exec.h \
+  caml/callback.h caml/custom.h caml/debugger.h caml/dynlink.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/memory.h \
+  caml/gc.h caml/major_gc.h caml/minor_gc.h caml/address_class.h \
+  caml/osdeps.h caml/prims.h caml/printexc.h caml/reverse.h \
+  caml/signals.h caml/stacks.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/config.h caml/m.h caml/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/callback.h caml/dynlink.h caml/osdeps.h \
+  caml/startup_aux.h
+str.d.$(O): str.c caml/alloc.h caml/misc.h caml/config.h caml/m.h caml/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
+sys.d.$(O): sys.c caml/config.h caml/m.h caml/s.h caml/alloc.h caml/misc.h \
+  caml/mlvalues.h caml/debugger.h caml/fail.h caml/gc_ctrl.h caml/io.h \
+  caml/osdeps.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 caml/stacks.h \
+  caml/sys.h caml/version.h caml/callback.h caml/startup_aux.h
+terminfo.d.$(O): terminfo.c caml/config.h caml/m.h caml/s.h caml/alloc.h \
+  caml/misc.h caml/mlvalues.h caml/fail.h caml/io.h
+unix.d.$(O): unix.c caml/config.h caml/m.h caml/s.h caml/fail.h caml/misc.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/osdeps.h \
+  caml/signals.h caml/sys.h caml/io.h caml/alloc.h
+weak.d.$(O): weak.c caml/alloc.h caml/misc.h caml/config.h caml/m.h caml/s.h \
+  caml/mlvalues.h caml/fail.h caml/major_gc.h caml/freelist.h \
+  caml/memory.h caml/gc.h caml/minor_gc.h caml/address_class.h \
+  caml/weak.h
+afl.i.$(O): afl.c caml/config.h caml/m.h caml/s.h caml/misc.h caml/mlvalues.h \
+  caml/osdeps.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \
   caml/minor_gc.h caml/address_class.h
-main.i.o: main.c caml/misc.h caml/config.h caml/../../config/m.h \
-  caml/../../config/s.h caml/mlvalues.h caml/sys.h
-major_gc.i.o: major_gc.c caml/compact.h caml/config.h caml/../../config/m.h \
-  caml/../../config/s.h caml/misc.h caml/mlvalues.h caml/custom.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/gc_ctrl.h caml/signals.h caml/weak.h
-md5.i.o: md5.c caml/alloc.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 \
+alloc.i.$(O): alloc.c caml/alloc.h caml/misc.h caml/config.h caml/m.h caml/s.h \
+  caml/mlvalues.h caml/custom.h caml/major_gc.h caml/freelist.h \
+  caml/memory.h caml/gc.h caml/minor_gc.h caml/address_class.h \
+  caml/stacks.h
+array.i.$(O): array.c caml/alloc.h caml/misc.h caml/config.h caml/m.h caml/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/signals.h \
+  caml/spacetime.h
+backtrace.i.$(O): backtrace.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \
+  caml/s.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/backtrace.h \
+  caml/exec.h caml/backtrace_prim.h caml/fail.h
+backtrace_prim.i.$(O): backtrace_prim.c caml/config.h caml/m.h caml/s.h \
+  caml/mlvalues.h caml/misc.h caml/alloc.h caml/custom.h caml/io.h \
+  caml/instruct.h caml/intext.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/reverse.h
-memory.i.o: memory.c caml/address_class.h caml/config.h \
-  caml/../../config/m.h caml/../../config/s.h caml/misc.h \
-  caml/mlvalues.h caml/fail.h caml/freelist.h caml/gc.h caml/gc_ctrl.h \
-  caml/major_gc.h caml/memory.h caml/minor_gc.h caml/signals.h
-meta.i.o: meta.c caml/alloc.h caml/misc.h caml/config.h \
-  caml/../../config/m.h caml/../../config/s.h caml/mlvalues.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/minor_gc.h caml/address_class.h caml/prims.h caml/stacks.h
-minor_gc.i.o: minor_gc.c caml/custom.h caml/mlvalues.h caml/config.h \
-  caml/../../config/m.h caml/../../config/s.h caml/misc.h caml/fail.h \
+  caml/minor_gc.h caml/address_class.h caml/startup.h caml/stacks.h \
+  caml/sys.h caml/backtrace.h caml/fail.h caml/backtrace_prim.h
+bigarray.i.$(O): bigarray.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \
+  caml/s.h caml/mlvalues.h caml/bigarray.h caml/custom.h caml/fail.h \
+  caml/intext.h caml/io.h caml/hash.h caml/memory.h caml/gc.h \
+  caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h
+callback.i.$(O): callback.c caml/callback.h caml/mlvalues.h caml/config.h \
+  caml/m.h caml/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/interp.h caml/instruct.h caml/fix_code.h caml/stacks.h
+compact.i.$(O): compact.c caml/address_class.h caml/config.h caml/m.h caml/s.h \
+  caml/misc.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/gc_ctrl.h caml/weak.h caml/compact.h
+compare.i.$(O): compare.c caml/custom.h caml/mlvalues.h caml/config.h caml/m.h \
+  caml/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
+custom.i.$(O): custom.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \
+  caml/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
+debugger.i.$(O): debugger.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \
+  caml/s.h caml/mlvalues.h caml/debugger.h caml/osdeps.h caml/memory.h \
+  caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \
+  caml/address_class.h caml/fail.h caml/fix_code.h caml/instruct.h \
+  caml/intext.h caml/io.h caml/stacks.h caml/sys.h
+dynlink.i.$(O): dynlink.c caml/config.h caml/m.h caml/s.h caml/alloc.h \
+  caml/misc.h caml/mlvalues.h caml/dynlink.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/osdeps.h caml/prims.h caml/signals.h
+extern.i.$(O): extern.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \
+  caml/s.h caml/mlvalues.h caml/custom.h caml/fail.h caml/gc.h \
+  caml/intext.h caml/io.h caml/md5.h caml/memory.h caml/major_gc.h \
+  caml/freelist.h caml/minor_gc.h caml/address_class.h caml/reverse.h
+fail.i.$(O): fail.c caml/alloc.h caml/misc.h caml/config.h caml/m.h caml/s.h \
+  caml/mlvalues.h caml/fail.h caml/io.h caml/gc.h caml/memory.h \
+  caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \
+  caml/printexc.h caml/signals.h caml/stacks.h
+finalise.i.$(O): finalise.c caml/callback.h caml/mlvalues.h caml/config.h \
+  caml/m.h caml/s.h caml/misc.h caml/compact.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/gc_ctrl.h \
-  caml/signals.h caml/weak.h
-misc.i.o: misc.c caml/config.h caml/../../config/m.h caml/../../config/s.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/osdeps.h \
-  caml/version.h
-obj.i.o: obj.c caml/alloc.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/minor_gc.h caml/address_class.h caml/prims.h caml/spacetime.h
-parsing.i.o: parsing.c caml/config.h caml/../../config/m.h \
-  caml/../../config/s.h caml/mlvalues.h caml/misc.h caml/memory.h \
-  caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \
-  caml/address_class.h caml/alloc.h
-prims.i.o: prims.c caml/mlvalues.h caml/config.h caml/../../config/m.h \
-  caml/../../config/s.h caml/misc.h caml/prims.h
-printexc.i.o: printexc.c caml/backtrace.h caml/mlvalues.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/printexc.h
-roots.i.o: roots.c caml/finalise.h caml/roots.h caml/misc.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/stacks.h
-signals.i.o: signals.c caml/alloc.h caml/misc.h caml/config.h \
-  caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \
-  caml/callback.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/roots.h \
-  caml/signals.h caml/signals_machdep.h caml/sys.h
-signals_byt.i.o: signals_byt.c caml/config.h caml/../../config/m.h \
-  caml/../../config/s.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 caml/osdeps.h caml/signals.h \
-  caml/signals_machdep.h
-spacetime.i.o: spacetime.c caml/fail.h caml/misc.h caml/config.h \
-  caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h
-stacks.i.o: stacks.c caml/config.h caml/../../config/m.h \
-  caml/../../config/s.h caml/fail.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.i.o: startup.c caml/config.h caml/../../config/m.h \
-  caml/../../config/s.h caml/alloc.h caml/misc.h caml/mlvalues.h \
-  caml/backtrace.h caml/exec.h caml/callback.h caml/custom.h \
-  caml/debugger.h caml/dynlink.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/memory.h caml/gc.h caml/major_gc.h \
-  caml/minor_gc.h caml/address_class.h caml/osdeps.h caml/prims.h \
-  caml/printexc.h caml/reverse.h caml/signals.h caml/stacks.h caml/sys.h \
-  caml/startup.h caml/startup_aux.h caml/version.h
-startup_aux.i.o: startup_aux.c caml/backtrace.h caml/mlvalues.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/osdeps.h caml/startup_aux.h
-str.i.o: str.c caml/alloc.h caml/misc.h caml/config.h caml/../../config/m.h \
-  caml/../../config/s.h caml/mlvalues.h caml/fail.h
-sys.i.o: sys.c caml/config.h caml/../../config/m.h caml/../../config/s.h \
-  caml/alloc.h caml/misc.h caml/mlvalues.h caml/debugger.h caml/fail.h \
-  caml/gc_ctrl.h caml/instruct.h caml/io.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/version.h
-terminfo.i.o: terminfo.c caml/config.h caml/../../config/m.h \
-  caml/../../config/s.h caml/alloc.h caml/misc.h caml/mlvalues.h \
-  caml/fail.h caml/io.h
-unix.i.o: unix.c caml/config.h caml/../../config/m.h caml/../../config/s.h \
-  caml/fail.h caml/misc.h caml/mlvalues.h caml/memory.h caml/gc.h \
+  caml/freelist.h caml/minor_gc.h caml/address_class.h caml/signals.h
+fix_code.i.$(O): fix_code.c caml/config.h caml/m.h caml/s.h caml/debugger.h \
+  caml/misc.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/osdeps.h caml/signals.h caml/sys.h caml/io.h
-weak.i.o: weak.c caml/alloc.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/minor_gc.h caml/address_class.h caml/weak.h
-afl.pic.o: afl.c caml/misc.h caml/config.h caml/../../config/m.h \
-  caml/../../config/s.h caml/mlvalues.h caml/osdeps.h
-alloc.pic.o: alloc.c caml/alloc.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/minor_gc.h caml/address_class.h caml/stacks.h
-array.pic.o: array.c caml/alloc.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/signals.h caml/spacetime.h
-backtrace.pic.o: backtrace.c caml/alloc.h caml/misc.h caml/config.h \
-  caml/../../config/m.h caml/../../config/s.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/backtrace.h caml/exec.h \
-  caml/backtrace_prim.h caml/fail.h
-backtrace_prim.pic.o: backtrace_prim.c caml/config.h caml/../../config/m.h \
-  caml/../../config/s.h caml/mlvalues.h caml/misc.h caml/alloc.h \
-  caml/custom.h caml/io.h caml/instruct.h caml/intext.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/stacks.h caml/sys.h caml/backtrace.h caml/fail.h \
-  caml/backtrace_prim.h
-callback.pic.o: callback.c caml/callback.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/interp.h caml/instruct.h \
-  caml/fix_code.h caml/stacks.h
-compact.pic.o: compact.c caml/address_class.h caml/config.h \
-  caml/../../config/m.h caml/../../config/s.h caml/misc.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/gc_ctrl.h \
-  caml/weak.h caml/compact.h
-compare.pic.o: compare.c caml/custom.h caml/mlvalues.h caml/config.h \
-  caml/../../config/m.h caml/../../config/s.h caml/misc.h caml/fail.h \
+  caml/reverse.h
+floats.i.$(O): floats.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \
+  caml/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/reverse.h caml/stacks.h
+freelist.i.$(O): freelist.c caml/config.h caml/m.h caml/s.h caml/freelist.h \
+  caml/misc.h caml/mlvalues.h caml/gc.h caml/gc_ctrl.h caml/memory.h \
+  caml/major_gc.h caml/minor_gc.h caml/address_class.h
+gc_ctrl.i.$(O): gc_ctrl.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \
+  caml/s.h caml/mlvalues.h caml/backtrace.h caml/exec.h caml/compact.h \
+  caml/custom.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/gc_ctrl.h caml/signals.h caml/stacks.h \
+  caml/startup_aux.h
+globroots.i.$(O): globroots.c caml/memory.h caml/config.h caml/m.h caml/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/roots.h caml/globroots.h
+hash.i.$(O): hash.c caml/mlvalues.h caml/config.h caml/m.h caml/s.h \
+  caml/misc.h caml/custom.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.i.$(O): instrtrace.c
+intern.i.$(O): intern.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \
+  caml/s.h caml/mlvalues.h caml/callback.h caml/custom.h caml/fail.h \
+  caml/gc.h caml/intext.h caml/io.h caml/md5.h caml/memory.h \
+  caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \
+  caml/reverse.h
+interp.i.$(O): interp.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \
+  caml/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/minor_gc.h caml/address_class.h \
+  caml/prims.h caml/signals.h caml/stacks.h caml/startup_aux.h \
+  caml/jumptbl.h
+ints.i.$(O): ints.c caml/alloc.h caml/misc.h caml/config.h caml/m.h caml/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
-custom.pic.o: custom.c caml/alloc.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
-debugger.pic.o: debugger.c caml/alloc.h caml/misc.h caml/config.h \
-  caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \
-  caml/debugger.h caml/osdeps.h caml/fail.h caml/fix_code.h \
-  caml/instruct.h caml/intext.h caml/io.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/alloc.h caml/misc.h caml/mlvalues.h \
-  caml/dynlink.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/osdeps.h \
-  caml/prims.h caml/signals.h
-extern.pic.o: extern.c caml/alloc.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/md5.h \
-  caml/memory.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \
+io.i.$(O): io.c caml/config.h caml/m.h caml/s.h caml/alloc.h caml/misc.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/osdeps.h caml/signals.h caml/sys.h
+lexing.i.$(O): lexing.c caml/fail.h caml/misc.h caml/config.h caml/m.h \
+  caml/s.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.i.$(O): main.c caml/misc.h caml/config.h caml/m.h caml/s.h \
+  caml/mlvalues.h caml/sys.h caml/osdeps.h caml/memory.h caml/gc.h \
+  caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h
+major_gc.i.$(O): major_gc.c caml/compact.h caml/config.h caml/m.h caml/s.h \
+  caml/misc.h caml/mlvalues.h caml/custom.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/gc_ctrl.h caml/signals.h \
+  caml/weak.h
+md5.i.$(O): md5.c caml/alloc.h caml/misc.h caml/config.h caml/m.h caml/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/reverse.h
-fail.pic.o: fail.c caml/alloc.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/major_gc.h \
-  caml/freelist.h caml/minor_gc.h caml/address_class.h caml/printexc.h \
-  caml/signals.h caml/stacks.h
-finalise.pic.o: finalise.c caml/callback.h caml/mlvalues.h caml/config.h \
-  caml/../../config/m.h caml/../../config/s.h caml/misc.h caml/compact.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 \
+memory.i.$(O): memory.c caml/address_class.h caml/config.h caml/m.h caml/s.h \
+  caml/misc.h caml/mlvalues.h caml/fail.h caml/freelist.h caml/gc.h \
+  caml/gc_ctrl.h caml/major_gc.h caml/memory.h caml/minor_gc.h \
   caml/signals.h
-fix_code.pic.o: fix_code.c caml/config.h caml/../../config/m.h \
-  caml/../../config/s.h caml/debugger.h caml/misc.h caml/mlvalues.h \
-  caml/fix_code.h caml/instruct.h caml/intext.h caml/io.h caml/md5.h \
+meta.i.$(O): meta.c caml/alloc.h caml/misc.h caml/config.h caml/m.h caml/s.h \
+  caml/mlvalues.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/minor_gc.h caml/address_class.h caml/prims.h \
+  caml/stacks.h
+minor_gc.i.$(O): minor_gc.c caml/custom.h caml/mlvalues.h caml/config.h \
+  caml/m.h caml/s.h caml/misc.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/reverse.h
-floats.pic.o: floats.c caml/alloc.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/reverse.h caml/stacks.h
-freelist.pic.o: freelist.c caml/config.h caml/../../config/m.h \
-  caml/../../config/s.h caml/freelist.h caml/misc.h caml/mlvalues.h \
-  caml/gc.h caml/gc_ctrl.h caml/memory.h caml/major_gc.h caml/minor_gc.h \
+  caml/minor_gc.h caml/address_class.h caml/gc_ctrl.h caml/signals.h \
+  caml/weak.h
+misc.i.$(O): misc.c caml/config.h caml/m.h caml/s.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/osdeps.h caml/version.h
+obj.i.$(O): obj.c caml/alloc.h caml/misc.h caml/config.h caml/m.h caml/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/minor_gc.h caml/address_class.h \
+  caml/prims.h caml/spacetime.h
+parsing.i.$(O): parsing.c caml/config.h caml/m.h caml/s.h caml/mlvalues.h \
+  caml/misc.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \
+  caml/minor_gc.h caml/address_class.h caml/alloc.h
+prims.i.$(O): prims.c caml/mlvalues.h caml/config.h caml/m.h caml/s.h \
+  caml/misc.h caml/prims.h
+printexc.i.$(O): printexc.c caml/backtrace.h caml/mlvalues.h caml/config.h \
+  caml/m.h caml/s.h caml/misc.h caml/exec.h caml/callback.h \
+  caml/debugger.h caml/fail.h caml/printexc.h caml/memory.h caml/gc.h \
+  caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h
+roots.i.$(O): roots.c caml/finalise.h caml/roots.h caml/misc.h caml/config.h \
+  caml/m.h caml/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/stacks.h
+signals.i.$(O): signals.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \
+  caml/s.h caml/mlvalues.h caml/callback.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/roots.h caml/signals.h \
+  caml/signals_machdep.h caml/sys.h
+signals_byt.i.$(O): signals_byt.c caml/config.h caml/m.h caml/s.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 caml/osdeps.h \
+  caml/signals.h caml/signals_machdep.h
+spacetime.i.$(O): spacetime.c caml/fail.h caml/misc.h caml/config.h caml/m.h \
+  caml/s.h caml/mlvalues.h
+stacks.i.$(O): stacks.c caml/config.h caml/m.h caml/s.h caml/fail.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.i.$(O): startup.c caml/config.h caml/m.h caml/s.h caml/alloc.h \
+  caml/misc.h caml/mlvalues.h caml/backtrace.h caml/exec.h \
+  caml/callback.h caml/custom.h caml/debugger.h caml/dynlink.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/memory.h \
+  caml/gc.h caml/major_gc.h caml/minor_gc.h caml/address_class.h \
+  caml/osdeps.h caml/prims.h caml/printexc.h caml/reverse.h \
+  caml/signals.h caml/stacks.h caml/sys.h caml/startup.h \
+  caml/startup_aux.h caml/version.h
+startup_aux.i.$(O): startup_aux.c caml/backtrace.h caml/mlvalues.h \
+  caml/config.h caml/m.h caml/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/callback.h caml/dynlink.h caml/osdeps.h \
+  caml/startup_aux.h
+str.i.$(O): str.c caml/alloc.h caml/misc.h caml/config.h caml/m.h caml/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
+sys.i.$(O): sys.c caml/config.h caml/m.h caml/s.h caml/alloc.h caml/misc.h \
+  caml/mlvalues.h caml/debugger.h caml/fail.h caml/gc_ctrl.h caml/io.h \
+  caml/osdeps.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 caml/stacks.h \
+  caml/sys.h caml/version.h caml/callback.h caml/startup_aux.h
+terminfo.i.$(O): terminfo.c caml/config.h caml/m.h caml/s.h caml/alloc.h \
+  caml/misc.h caml/mlvalues.h caml/fail.h caml/io.h
+unix.i.$(O): unix.c caml/config.h caml/m.h caml/s.h caml/fail.h caml/misc.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/osdeps.h \
+  caml/signals.h caml/sys.h caml/io.h caml/alloc.h
+weak.i.$(O): weak.c caml/alloc.h caml/misc.h caml/config.h caml/m.h caml/s.h \
+  caml/mlvalues.h caml/fail.h caml/major_gc.h caml/freelist.h \
+  caml/memory.h caml/gc.h caml/minor_gc.h caml/address_class.h \
+  caml/weak.h
+afl.pic.$(O): afl.c caml/config.h caml/m.h caml/s.h caml/misc.h caml/mlvalues.h \
+  caml/osdeps.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \
+  caml/minor_gc.h caml/address_class.h
+alloc.pic.$(O): alloc.c caml/alloc.h caml/misc.h caml/config.h caml/m.h caml/s.h \
+  caml/mlvalues.h caml/custom.h caml/major_gc.h caml/freelist.h \
+  caml/memory.h caml/gc.h caml/minor_gc.h caml/address_class.h \
+  caml/stacks.h
+array.pic.$(O): array.c caml/alloc.h caml/misc.h caml/config.h caml/m.h caml/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/signals.h \
+  caml/spacetime.h
+backtrace.pic.$(O): backtrace.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \
+  caml/s.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/backtrace.h \
+  caml/exec.h caml/backtrace_prim.h caml/fail.h
+backtrace_prim.pic.$(O): backtrace_prim.c caml/config.h caml/m.h caml/s.h \
+  caml/mlvalues.h caml/misc.h caml/alloc.h caml/custom.h caml/io.h \
+  caml/instruct.h caml/intext.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/stacks.h \
+  caml/sys.h caml/backtrace.h caml/fail.h caml/backtrace_prim.h
+bigarray.pic.$(O): bigarray.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \
+  caml/s.h caml/mlvalues.h caml/bigarray.h caml/custom.h caml/fail.h \
+  caml/intext.h caml/io.h caml/hash.h caml/memory.h caml/gc.h \
+  caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h
+callback.pic.$(O): callback.c caml/callback.h caml/mlvalues.h caml/config.h \
+  caml/m.h caml/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/interp.h caml/instruct.h caml/fix_code.h caml/stacks.h
+compact.pic.$(O): compact.c caml/address_class.h caml/config.h caml/m.h caml/s.h \
+  caml/misc.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/gc_ctrl.h caml/weak.h caml/compact.h
+compare.pic.$(O): compare.c caml/custom.h caml/mlvalues.h caml/config.h caml/m.h \
+  caml/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
+custom.pic.$(O): custom.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \
+  caml/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
-gc_ctrl.pic.o: gc_ctrl.c caml/alloc.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/compact.h caml/custom.h caml/fail.h \
+debugger.pic.$(O): debugger.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \
+  caml/s.h caml/mlvalues.h caml/debugger.h caml/osdeps.h caml/memory.h \
+  caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \
+  caml/address_class.h caml/fail.h caml/fix_code.h caml/instruct.h \
+  caml/intext.h caml/io.h caml/stacks.h caml/sys.h
+dynlink.pic.$(O): dynlink.c caml/config.h caml/m.h caml/s.h caml/alloc.h \
+  caml/misc.h caml/mlvalues.h caml/dynlink.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/osdeps.h caml/prims.h caml/signals.h
+extern.pic.$(O): extern.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \
+  caml/s.h caml/mlvalues.h caml/custom.h caml/fail.h caml/gc.h \
+  caml/intext.h caml/io.h caml/md5.h caml/memory.h caml/major_gc.h \
+  caml/freelist.h caml/minor_gc.h caml/address_class.h caml/reverse.h
+fail.pic.$(O): fail.c caml/alloc.h caml/misc.h caml/config.h caml/m.h caml/s.h \
+  caml/mlvalues.h caml/fail.h caml/io.h caml/gc.h caml/memory.h \
+  caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \
+  caml/printexc.h caml/signals.h caml/stacks.h
+finalise.pic.$(O): finalise.c caml/callback.h caml/mlvalues.h caml/config.h \
+  caml/m.h caml/s.h caml/misc.h caml/compact.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/gc_ctrl.h \
-  caml/signals.h caml/stacks.h caml/startup_aux.h
-globroots.pic.o: globroots.c caml/memory.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/roots.h caml/globroots.h
-hash.pic.o: hash.c caml/mlvalues.h caml/config.h caml/../../config/m.h \
-  caml/../../config/s.h caml/misc.h caml/custom.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 caml/alloc.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/md5.h caml/memory.h caml/major_gc.h caml/freelist.h \
-  caml/minor_gc.h caml/address_class.h caml/reverse.h
-interp.pic.o: interp.c caml/alloc.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/minor_gc.h caml/address_class.h caml/prims.h caml/signals.h \
-  caml/stacks.h caml/startup_aux.h caml/jumptbl.h
-ints.pic.o: ints.c caml/alloc.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/freelist.h caml/minor_gc.h caml/address_class.h caml/signals.h
+fix_code.pic.$(O): fix_code.c caml/config.h caml/m.h caml/s.h caml/debugger.h \
+  caml/misc.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/reverse.h
+floats.pic.$(O): floats.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \
+  caml/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/reverse.h caml/stacks.h
+freelist.pic.$(O): freelist.c caml/config.h caml/m.h caml/s.h caml/freelist.h \
+  caml/misc.h caml/mlvalues.h caml/gc.h caml/gc_ctrl.h caml/memory.h \
+  caml/major_gc.h caml/minor_gc.h caml/address_class.h
+gc_ctrl.pic.$(O): gc_ctrl.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \
+  caml/s.h caml/mlvalues.h caml/backtrace.h caml/exec.h caml/compact.h \
+  caml/custom.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
-io.pic.o: io.c caml/config.h caml/../../config/m.h caml/../../config/s.h \
-  caml/alloc.h caml/misc.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/osdeps.h caml/signals.h \
-  caml/sys.h
-lexing.pic.o: lexing.c caml/fail.h caml/misc.h caml/config.h \
-  caml/../../config/m.h caml/../../config/s.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/config.h caml/../../config/m.h \
-  caml/../../config/s.h caml/mlvalues.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/misc.h caml/mlvalues.h caml/custom.h \
-  caml/fail.h caml/finalise.h caml/roots.h caml/memory.h caml/gc.h \
+  caml/address_class.h caml/gc_ctrl.h caml/signals.h caml/stacks.h \
+  caml/startup_aux.h
+globroots.pic.$(O): globroots.c caml/memory.h caml/config.h caml/m.h caml/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/roots.h caml/globroots.h
+hash.pic.$(O): hash.c caml/mlvalues.h caml/config.h caml/m.h caml/s.h \
+  caml/misc.h caml/custom.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 caml/alloc.h caml/misc.h caml/config.h caml/m.h \
+  caml/s.h caml/mlvalues.h caml/callback.h caml/custom.h caml/fail.h \
+  caml/gc.h caml/intext.h caml/io.h caml/md5.h caml/memory.h \
   caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \
-  caml/gc_ctrl.h caml/signals.h caml/weak.h
-md5.pic.o: md5.c caml/alloc.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/reverse.h
+interp.pic.$(O): interp.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \
+  caml/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/minor_gc.h caml/address_class.h \
+  caml/prims.h caml/signals.h caml/stacks.h caml/startup_aux.h \
+  caml/jumptbl.h
+ints.pic.$(O): ints.c caml/alloc.h caml/misc.h caml/config.h caml/m.h caml/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/reverse.h
-memory.pic.o: memory.c caml/address_class.h caml/config.h \
-  caml/../../config/m.h caml/../../config/s.h caml/misc.h \
-  caml/mlvalues.h caml/fail.h caml/freelist.h caml/gc.h caml/gc_ctrl.h \
-  caml/major_gc.h caml/memory.h caml/minor_gc.h caml/signals.h
-meta.pic.o: meta.c caml/alloc.h caml/misc.h caml/config.h \
-  caml/../../config/m.h caml/../../config/s.h caml/mlvalues.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/minor_gc.h caml/address_class.h caml/prims.h caml/stacks.h
-minor_gc.pic.o: minor_gc.c caml/custom.h caml/mlvalues.h caml/config.h \
-  caml/../../config/m.h caml/../../config/s.h caml/misc.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/gc_ctrl.h \
-  caml/signals.h caml/weak.h
-misc.pic.o: misc.c caml/config.h caml/../../config/m.h caml/../../config/s.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/osdeps.h \
-  caml/version.h
-obj.pic.o: obj.c caml/alloc.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/minor_gc.h caml/address_class.h caml/prims.h caml/spacetime.h
-parsing.pic.o: parsing.c caml/config.h caml/../../config/m.h \
-  caml/../../config/s.h caml/mlvalues.h caml/misc.h caml/memory.h \
-  caml/gc.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/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/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/printexc.h
-roots.pic.o: roots.c caml/finalise.h caml/roots.h caml/misc.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/stacks.h
-signals.pic.o: signals.c caml/alloc.h caml/misc.h caml/config.h \
-  caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h \
-  caml/callback.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/roots.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/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 caml/osdeps.h caml/signals.h \
-  caml/signals_machdep.h
-spacetime.pic.o: spacetime.c caml/fail.h caml/misc.h caml/config.h \
-  caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h
-stacks.pic.o: stacks.c caml/config.h caml/../../config/m.h \
-  caml/../../config/s.h caml/fail.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/alloc.h caml/misc.h caml/mlvalues.h \
-  caml/backtrace.h caml/exec.h caml/callback.h caml/custom.h \
-  caml/debugger.h caml/dynlink.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/memory.h caml/gc.h caml/major_gc.h \
-  caml/minor_gc.h caml/address_class.h caml/osdeps.h caml/prims.h \
-  caml/printexc.h caml/reverse.h caml/signals.h caml/stacks.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/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/osdeps.h caml/startup_aux.h
-str.pic.o: str.c caml/alloc.h caml/misc.h caml/config.h caml/../../config/m.h \
-  caml/../../config/s.h caml/mlvalues.h caml/fail.h
-sys.pic.o: sys.c caml/config.h caml/../../config/m.h caml/../../config/s.h \
-  caml/alloc.h caml/misc.h caml/mlvalues.h caml/debugger.h caml/fail.h \
-  caml/gc_ctrl.h caml/instruct.h caml/io.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/version.h
-terminfo.pic.o: terminfo.c caml/config.h caml/../../config/m.h \
-  caml/../../config/s.h caml/alloc.h caml/misc.h caml/mlvalues.h \
-  caml/fail.h caml/io.h
-unix.pic.o: unix.c caml/config.h caml/../../config/m.h caml/../../config/s.h \
-  caml/fail.h caml/misc.h caml/mlvalues.h caml/memory.h caml/gc.h \
+io.pic.$(O): io.c caml/config.h caml/m.h caml/s.h caml/alloc.h caml/misc.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/osdeps.h caml/signals.h caml/sys.h
+lexing.pic.$(O): lexing.c caml/fail.h caml/misc.h caml/config.h caml/m.h \
+  caml/s.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/config.h caml/m.h caml/s.h \
+  caml/mlvalues.h caml/sys.h caml/osdeps.h caml/memory.h caml/gc.h \
+  caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h
+major_gc.pic.$(O): major_gc.c caml/compact.h caml/config.h caml/m.h caml/s.h \
+  caml/misc.h caml/mlvalues.h caml/custom.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/gc_ctrl.h caml/signals.h \
+  caml/weak.h
+md5.pic.$(O): md5.c caml/alloc.h caml/misc.h caml/config.h caml/m.h caml/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/reverse.h
+memory.pic.$(O): memory.c caml/address_class.h caml/config.h caml/m.h caml/s.h \
+  caml/misc.h caml/mlvalues.h caml/fail.h caml/freelist.h caml/gc.h \
+  caml/gc_ctrl.h caml/major_gc.h caml/memory.h caml/minor_gc.h \
+  caml/signals.h
+meta.pic.$(O): meta.c caml/alloc.h caml/misc.h caml/config.h caml/m.h caml/s.h \
+  caml/mlvalues.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/minor_gc.h caml/address_class.h caml/prims.h \
+  caml/stacks.h
+minor_gc.pic.$(O): minor_gc.c caml/custom.h caml/mlvalues.h caml/config.h \
+  caml/m.h caml/s.h caml/misc.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/gc_ctrl.h caml/signals.h \
+  caml/weak.h
+misc.pic.$(O): misc.c caml/config.h caml/m.h caml/s.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/osdeps.h caml/version.h
+obj.pic.$(O): obj.c caml/alloc.h caml/misc.h caml/config.h caml/m.h caml/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/minor_gc.h caml/address_class.h \
+  caml/prims.h caml/spacetime.h
+parsing.pic.$(O): parsing.c caml/config.h caml/m.h caml/s.h caml/mlvalues.h \
+  caml/misc.h caml/memory.h caml/gc.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/config.h caml/m.h caml/s.h \
+  caml/misc.h caml/prims.h
+printexc.pic.$(O): printexc.c caml/backtrace.h caml/mlvalues.h caml/config.h \
+  caml/m.h caml/s.h caml/misc.h caml/exec.h caml/callback.h \
+  caml/debugger.h caml/fail.h caml/printexc.h caml/memory.h caml/gc.h \
+  caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h
+roots.pic.$(O): roots.c caml/finalise.h caml/roots.h caml/misc.h caml/config.h \
+  caml/m.h caml/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/osdeps.h caml/signals.h caml/sys.h caml/io.h
-weak.pic.o: weak.c caml/alloc.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/minor_gc.h caml/address_class.h caml/weak.h
+  caml/globroots.h caml/stacks.h
+signals.pic.$(O): signals.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \
+  caml/s.h caml/mlvalues.h caml/callback.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/roots.h caml/signals.h \
+  caml/signals_machdep.h caml/sys.h
+signals_byt.pic.$(O): signals_byt.c caml/config.h caml/m.h caml/s.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 caml/osdeps.h \
+  caml/signals.h caml/signals_machdep.h
+spacetime.pic.$(O): spacetime.c caml/fail.h caml/misc.h caml/config.h caml/m.h \
+  caml/s.h caml/mlvalues.h
+stacks.pic.$(O): stacks.c caml/config.h caml/m.h caml/s.h caml/fail.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/m.h caml/s.h caml/alloc.h \
+  caml/misc.h caml/mlvalues.h caml/backtrace.h caml/exec.h \
+  caml/callback.h caml/custom.h caml/debugger.h caml/dynlink.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/memory.h \
+  caml/gc.h caml/major_gc.h caml/minor_gc.h caml/address_class.h \
+  caml/osdeps.h caml/prims.h caml/printexc.h caml/reverse.h \
+  caml/signals.h caml/stacks.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/config.h caml/m.h caml/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/callback.h caml/dynlink.h caml/osdeps.h \
+  caml/startup_aux.h
+str.pic.$(O): str.c caml/alloc.h caml/misc.h caml/config.h caml/m.h caml/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
+sys.pic.$(O): sys.c caml/config.h caml/m.h caml/s.h caml/alloc.h caml/misc.h \
+  caml/mlvalues.h caml/debugger.h caml/fail.h caml/gc_ctrl.h caml/io.h \
+  caml/osdeps.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 caml/stacks.h \
+  caml/sys.h caml/version.h caml/callback.h caml/startup_aux.h
+terminfo.pic.$(O): terminfo.c caml/config.h caml/m.h caml/s.h caml/alloc.h \
+  caml/misc.h caml/mlvalues.h caml/fail.h caml/io.h
+unix.pic.$(O): unix.c caml/config.h caml/m.h caml/s.h caml/fail.h caml/misc.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/osdeps.h \
+  caml/signals.h caml/sys.h caml/io.h caml/alloc.h
+weak.pic.$(O): weak.c caml/alloc.h caml/misc.h caml/config.h caml/m.h caml/s.h \
+  caml/mlvalues.h caml/fail.h caml/major_gc.h caml/freelist.h \
+  caml/memory.h caml/gc.h caml/minor_gc.h caml/address_class.h \
+  caml/weak.h

diff --git a/byterun/Makefile b/byterun/Makefile
index 74aa3d06f5338b5c44be219e0d5cf74fd4ad6433..9b92a589e1e7ae85cb39375ba789117bb5b18a35 100644 (file)
--- a/byterun/Makefile
+++ b/byterun/Makefile
@@ -17,6 +17,7 @@ include ../config/Makefile
 
 INSTALL_BINDIR=$(DESTDIR)$(BINDIR)
 INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR)
+INSTALL_INCDIR=$(INSTALL_LIBDIR)/caml
 
 # The PROGRAMS (resp. LIBRARIES) variable list the files to build and
 # install as programs in $(INSTALL_BINDIR) (resp. libraries in
@@ -41,39 +42,40 @@ LIBRARIES += libcamlrun_pic.$(A) libcamlrun_shared.$(SO)
 endif
 endif
 
-CC=$(BYTECC)
-
 ifdef BOOTSTRAPPING_FLEXLINK
-CFLAGS=-DBOOTSTRAPPING_FLEXLINK
-else
-CFLAGS=
+CFLAGS += -DBOOTSTRAPPING_FLEXLINK
 endif
 
 # On Windows, OCAML_STDLIB_DIR needs to be defined dynamically
 
 ifeq "$(UNIX_OR_WIN32)" "win32"
-CFLAGS += -DOCAML_STDLIB_DIR='"$(LIBDIR)"'
+# OCAML_STDLIB_DIR needs to arrive in dynlink.c as a string which both gcc and
+# msvc are willing parse without warning. This means we can't pass UTF-8
+# directly since, as far as I can tell, cl can cope, but the pre-processor
+# can't. So the string needs to be directly translated to L"" form. To do this,
+# we take advantage of the fact that Cygwin uses GNU libiconv which includes a
+# Java pseudo-encoding which translates any UTF-8 sequences to \uXXXX (and,
+# unlike the C99 pseudo-encoding, emits two surrogate values when needed, rather
+# than \UXXXXXXXX). The \u is then translated to \x in order to accommodate
+# pre-Visual Studio 2013 compilers where \x is a non-standard alias for \u.
+OCAML_STDLIB_DIR = $(shell echo $(LIBDIR)| iconv -t JAVA | sed -e 's/\\u/\\x/g')
+CFLAGS += -DOCAML_STDLIB_DIR='L"$(OCAML_STDLIB_DIR)"'
 endif
 
-CFLAGS += $(IFLEXDIR) $(BYTECCCOMPOPTS)
+CFLAGS += $(IFLEXDIR)
+
+ifneq "$(CCOMPTYPE)" "msvc"
+CFLAGS += -g
+endif
 
 DFLAGS=$(CFLAGS) -DDEBUG
 IFLAGS=$(CFLAGS) -DCAML_INSTR
 PICFLAGS=$(CFLAGS) $(SHAREDCCCOMPOPTS)
 
-ifneq "$(CCOMPTYPE)" "msvc"
-DFLAGS += -g
-endif
-
-ifeq "$(CCOMPTYPE)" "msvc"
-OUTPUTOBJ=-Fo
-else
-OUTPUTOBJ=-o
-endif
 DBGO=d.$(O)
 
 ifeq "$(UNIX_OR_WIN32)" "win32"
-LIBS = $(call SYSLIB,ws2_32) $(EXTRALIBS)
+LIBS = $(BYTECCLIBS) $(EXTRALIBS)
 ifdef BOOTSTRAPPING_FLEXLINK
 MAKE_OCAMLRUN=$(MKEXE_BOOT)
 else
@@ -81,7 +83,7 @@ MAKE_OCAMLRUN = $(MKEXE) -o $(1) $(2)
 endif
 else
 LIBS = $(BYTECCLIBS)
-MAKE_OCAMLRUN = $(MKEXE) $(BYTECCLINKOPTS) -o $(1) $(2)
+MAKE_OCAMLRUN = $(MKEXE) $(LDFLAGS) -o $(1) $(2)
 endif
 
 PRIMS=\
@@ -97,7 +99,7 @@ OBJS=$(addsuffix .$(O), \
   compare ints floats str array io extern intern \
   hash sys meta parsing gc_ctrl terminfo md5 obj \
   lexing callback debugger weak compact finalise custom \
-  dynlink spacetime afl $(UNIX_OR_WIN32) main)
+  dynlink spacetime afl $(UNIX_OR_WIN32) bigarray main)
 
 DOBJS=$(OBJS:.$(O)=.$(DBGO)) instrtrace.$(DBGO)
 IOBJS=$(OBJS:.$(O)=.i.$(O))
@@ -114,11 +116,8 @@ ld.conf: ../config/Makefile
 install:
        cp $(PROGRAMS) "$(INSTALL_BINDIR)"
        cp $(LIBRARIES) "$(INSTALL_LIBDIR)"
-       mkdir -p "$(INSTALL_LIBDIR)/caml"
-       for i in caml/*.h; do \
-         sed -f ../tools/cleanup-header $$i \
-             > "$(INSTALL_LIBDIR)/$$i"; \
-       done
+       mkdir -p "$(INSTALL_INCDIR)"
+       cp caml/*.h "$(INSTALL_INCDIR)"
 
 # If primitives contain duplicated lines (e.g. because the code is defined
 # like
@@ -185,13 +184,13 @@ libcamlrun.$(A): $(OBJS)
        $(call MKLIB,$@, $^)
 
 ocamlrund$(EXE): prims.$(O) libcamlrund.$(A)
-       $(MKEXE) $(MKEXEDEBUGFLAG) $(BYTECCLINKOPTS) -o $@ $^ $(LIBS)
+       $(MKEXE) $(MKEXEDEBUGFLAG) -o $@ $^ $(LIBS)
 
 libcamlrund.$(A): $(DOBJS)
        $(call MKLIB,$@, $^)
 
 ocamlruni$(EXE): prims.$(O) libcamlruni.$(A)
-       $(MKEXE) $(BYTECCLINKOPTS) -o $@ $^ $(LIBS)
+       $(MKEXE) -o $@ $^ $(LIBS)
 
 libcamlruni.$(A): $(IOBJS)
        $(call MKLIB,$@, $^)
@@ -203,49 +202,27 @@ libcamlrun_shared.$(SO): $(PICOBJS)
        $(MKDLL) -o $@ $^ $(BYTECCLIBS)
 
 %.$(O): %.c
-       $(CC) $(CFLAGS) -c $<
+       $(CC) -c $(CFLAGS) $(CPPFLAGS) $<
 
 %.$(DBGO): %.c
-       $(CC) $(DFLAGS) -c $(OUTPUTOBJ)$@ $<
+       $(CC) -c $(DFLAGS) $(CPPFLAGS) $(OUTPUTOBJ)$@ $<
 
 %.i.$(O): %.c
-       $(CC) $(IFLAGS) -c $(OUTPUTOBJ)$@ $<
+       $(CC) -c $(IFLAGS) $(CPPFLAGS) $(OUTPUTOBJ)$@ $<
 
 %.pic.$(O): %.c
-       $(CC) $(PICFLAGS) -c $(OUTPUTOBJ)$@ $<
+       $(CC) -c $(PICFLAGS) $(CPPFLAGS) $(OUTPUTOBJ)$@ $<
 
-ifneq "$(TOOLCHAIN)" "msvc"
 .PHONY: 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) -DCAML_INSTR *.c | sed -e 's/\.o/.i.o/' \
-              >> .depend
-       -$(CC) -MM $(BYTECCCOMPOPTS) *.c | sed -e 's/\.o/.pic.o/' >> .depend
+ifeq "$(TOOLCHAIN)" "msvc"
+depend:
+       $(error Dependencies cannot be regenerated using the MSVC ports)
+else
+depend: prims.c caml/opnames.h caml/jumptbl.h caml/version.h
+       $(CC) -MM $(CFLAGS) $(CPPFLAGS) *.c | sed -e 's/\.o/.$$(O)/'>.$@
+       $(CC) -MM $(DFLAGS) $(CPPFLAGS) *.c | sed -e 's/\.o/.d.$$(O)/'>>.$@
+       $(CC) -MM $(IFLAGS) $(CPPFLAGS) *.c | sed -e 's/\.o/.i.$$(O)/'>>.$@
+       $(CC) -MM $(PICFLAGS) $(CPPFLAGS) *.c | sed -e 's/\.o/.pic.$$(O)/'>>.$@
 endif
 
-ifeq "$(UNIX_OR_WIN32)" "win32"
-.depend.nt: .depend
-       rm -f .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 -ne '/\.pic\.o/q' \
-           -e 's/^\(.*\)\.d\.o:/\1.$$(DBGO):/' \
-           -e 's/^\(.*\)\.o:/\1.$$(O):/' \
-           -e p \
-           .depend.win32 > .depend.nt
-       rm -f .depend.win32
-
-include .depend.nt
-
-else
 include .depend
-endif

diff --git a/byterun/afl.c b/byterun/afl.c
index bd87ce8d8af4cde19d99a413b7aa99460f13db13..324a3c34ab5e575dbaffd3994071dd6bbbc788df 100644 (file)
--- a/byterun/afl.c
+++ b/byterun/afl.c
@@ -13,9 +13,9 @@
 /**************************************************************************/
 
 /* Runtime support for afl-fuzz */
+#include "caml/config.h"
 
-/* Android's libc does not implement System V shared memory. */
-#if defined(_WIN32) || defined(__ANDROID__)
+#if !defined(HAS_SYS_SHM_H)
 
 #include "caml/mlvalues.h"
 
@@ -159,4 +159,4 @@ CAMLprim value caml_reset_afl_instrumentation(value full)
   return Val_unit;
 }
 
-#endif /* _WIN32 */
+#endif /* HAS_SYS_SHM_H */

diff --git a/byterun/alloc.c b/byterun/alloc.c
index 8894d6f5e6f603a71376a002087b8298dd841c15..e49fabd0174736e8c7142475dc42de76d4d4e09e 100644 (file)
--- a/byterun/alloc.c
+++ b/byterun/alloc.c
@@ -36,14 +36,16 @@ CAMLexport value caml_alloc (mlsize_t wosize, tag_t tag)
   value result;
   mlsize_t i;
 
-  Assert (tag < 256);
-  Assert (tag != Infix_tag);
-  if (wosize == 0){
-    result = Atom (tag);
-  }else if (wosize <= Max_young_wosize){
-    Alloc_small (result, wosize, tag);
-    if (tag < No_scan_tag){
-      for (i = 0; i < wosize; i++) Field (result, i) = Val_unit;
+  CAMLassert (tag < 256);
+  CAMLassert (tag != Infix_tag);
+  if (wosize <= Max_young_wosize){
+    if (wosize == 0){
+      result = Atom (tag);
+    }else{
+      Alloc_small (result, wosize, tag);
+      if (tag < No_scan_tag){
+        for (i = 0; i < wosize; i++) Field (result, i) = Val_unit;
+      }
     }
   }else{
     result = caml_alloc_shr (wosize, tag);
@@ -59,9 +61,9 @@ CAMLexport value caml_alloc_small (mlsize_t wosize, tag_t tag)
 {
   value result;
 
-  Assert (wosize > 0);
-  Assert (wosize <= Max_young_wosize);
-  Assert (tag < 256);
+  CAMLassert (wosize > 0);
+  CAMLassert (wosize <= Max_young_wosize);
+  CAMLassert (tag < 256);
   Alloc_small (result, wosize, tag);
   return result;
 }
@@ -75,9 +77,9 @@ CAMLexport value caml_alloc_small_with_my_or_given_profinfo (mlsize_t wosize,
   else {
     value result;
 
-    Assert (wosize > 0);
-    Assert (wosize <= Max_young_wosize);
-    Assert (tag < 256);
+    CAMLassert (wosize > 0);
+    CAMLassert (wosize <= Max_young_wosize);
+    CAMLassert (tag < 256);
     Alloc_small_with_profinfo (result, wosize, tag, profinfo);
     return result;
   }
@@ -108,6 +110,14 @@ CAMLexport value caml_alloc_string (mlsize_t len)
   return result;
 }
 
+/* [len] is a number of bytes (chars) */
+CAMLexport value caml_alloc_initialized_string (mlsize_t len, const char *p)
+{
+  value result = caml_alloc_string (len);
+  memcpy((char *)String_val(result), p, len);
+  return result;
+}
+
 /* [len] is a number of words.
    [mem] and [max] are relative (without unit).
 */
@@ -124,8 +134,7 @@ CAMLexport value caml_copy_string(char const *s)
   value res;
 
   len = strlen(s);
-  res = caml_alloc_string(len);
-  memmove(String_val(res), s, len);
+  res = caml_alloc_initialized_string(len, s);
   return res;
 }
 
@@ -138,38 +147,39 @@ CAMLexport value caml_alloc_array(value (*funct)(char const *),
 
   nbr = 0;
   while (arr[nbr] != 0) nbr++;
-  if (nbr == 0) {
-    CAMLreturn (Atom(0));
-  } else {
-    result = caml_alloc (nbr, 0);
-    for (n = 0; n < nbr; n++) {
-      /* The two statements below must be separate because of evaluation
-         order (don't take the address &Field(result, n) before
-         calling funct, which may cause a GC and move result). */
-      v = funct(arr[n]);
-      caml_modify(&Field(result, n), v);
-    }
-    CAMLreturn (result);
+  result = caml_alloc (nbr, 0);
+  for (n = 0; n < nbr; n++) {
+    /* The two statements below must be separate because of evaluation
+       order (don't take the address &Field(result, n) before
+       calling funct, which may cause a GC and move result). */
+    v = funct(arr[n]);
+    caml_modify(&Field(result, n), v);
   }
+  CAMLreturn (result);
 }
 
 /* [len] is a number of floats */
 CAMLprim value caml_alloc_float_array(mlsize_t len)
 {
+#ifdef FLAT_FLOAT_ARRAY
   mlsize_t wosize = len * Double_wosize;
   value result;
   /* For consistency with [caml_make_vect], which can't tell whether it should
      create a float array or not when the size is zero, the tag is set to
      zero when the size is zero. */
-  if (wosize == 0)
-    return Atom(0);
-  else if (wosize <= Max_young_wosize){
-    Alloc_small (result, wosize, Double_array_tag);
+  if (wosize <= Max_young_wosize){
+    if (wosize == 0)
+      return Atom(0);
+    else
+      Alloc_small (result, wosize, Double_array_tag);
   }else {
     result = caml_alloc_shr (wosize, Double_array_tag);
     result = caml_check_urgent_gc (result);
   }
   return result;
+#else
+  return caml_alloc (len, 0);
+#endif
 }
 
 
@@ -195,8 +205,6 @@ CAMLexport int caml_convert_flag_list(value list, int *flags)
 CAMLprim value caml_alloc_dummy(value size)
 {
   mlsize_t wosize = Long_val(size);
-
-  if (wosize == 0) return Atom(0);
   return caml_alloc (wosize, 0);
 }
 
@@ -211,8 +219,6 @@ CAMLprim value caml_alloc_dummy_function(value size,value arity)
 CAMLprim value caml_alloc_dummy_float (value size)
 {
   mlsize_t wosize = Long_val(size) * Double_wosize;
-
-  if (wosize == 0) return Atom(0);
   return caml_alloc (wosize, 0);
 }
 
@@ -223,14 +229,14 @@ CAMLprim value caml_update_dummy(value dummy, value newval)
 
   size = Wosize_val(newval);
   tag = Tag_val (newval);
-  Assert (size == Wosize_val(dummy));
-  Assert (tag < No_scan_tag || tag == Double_array_tag);
+  CAMLassert (size == Wosize_val(dummy));
+  CAMLassert (tag < No_scan_tag || tag == Double_array_tag);
 
   Tag_val(dummy) = tag;
   if (tag == Double_array_tag){
     size = Wosize_val (newval) / Double_wosize;
     for (i = 0; i < size; i++){
-      Store_double_field (dummy, i, Double_field (newval, i));
+      Store_double_flat_field (dummy, i, Double_flat_field (newval, i));
     }
   }else{
     for (i = 0; i < size; i++){

diff --git a/byterun/array.c b/byterun/array.c
index 11f2b51ad50bae045bff7ad02177524fd6a6fb87..5367532bb14d74879ad13d9ccacf43cfbc4cd825 100644 (file)
--- a/byterun/array.c
+++ b/byterun/array.c
@@ -29,11 +29,14 @@
 static const mlsize_t mlsize_t_max = -1;
 
 /* returns number of elements (either fields or floats) */
+/* [ 'a array -> int ] */
 CAMLexport mlsize_t caml_array_length(value array)
 {
+#ifdef FLAT_FLOAT_ARRAY
   if (Tag_val(array) == Double_array_tag)
     return Wosize_val(array) / Double_wosize;
   else
+#endif
     return Wosize_val(array);
 }
 
@@ -42,6 +45,12 @@ CAMLexport int caml_is_double_array(value array)
   return (Tag_val(array) == Double_array_tag);
 }
 
+/* Note: the OCaml types on the following primitives will work both with
+   and without the -no-flat-float-array configure-time option. If you
+   respect them, your C code should work in both configurations.
+*/
+
+/* [ 'a array -> int -> 'a ] where 'a != float */
 CAMLprim value caml_array_get_addr(value array, value index)
 {
   intnat idx = Long_val(index);
@@ -49,15 +58,17 @@ CAMLprim value caml_array_get_addr(value array, value index)
   return Field(array, idx);
 }
 
+/* [ float array -> int -> float ] */
 CAMLprim value caml_array_get_float(value array, value index)
 {
   intnat idx = Long_val(index);
+#ifdef FLAT_FLOAT_ARRAY
   double d;
   value res;
 
   if (idx < 0 || idx >= Wosize_val(array) / Double_wosize)
     caml_array_bound_error();
-  d = Double_field(array, idx);
+  d = Double_flat_field(array, idx);
 #define Setup_for_gc
 #define Restore_after_gc
   Alloc_small(res, Double_wosize, Double_tag);
@@ -65,16 +76,46 @@ CAMLprim value caml_array_get_float(value array, value index)
 #undef Restore_after_gc
   Store_double_val(res, d);
   return res;
+#else
+  CAMLassert (Tag_val (array) != Double_array_tag);
+  if (idx < 0 || idx >= Wosize_val(array)) caml_array_bound_error();
+  return Field(array, idx);
+#endif /* FLAT_FLOAT_ARRAY */
 }
 
+/* [ 'a array -> int -> 'a ] */
 CAMLprim value caml_array_get(value array, value index)
 {
+#ifdef FLAT_FLOAT_ARRAY
   if (Tag_val(array) == Double_array_tag)
     return caml_array_get_float(array, index);
-  else
-    return caml_array_get_addr(array, index);
+#else
+  CAMLassert (Tag_val(array) != Double_array_tag);
+#endif
+  return caml_array_get_addr(array, index);
+}
+
+/* [ floatarray -> int -> float ] */
+CAMLprim value caml_floatarray_get(value array, value index)
+{
+  intnat idx = Long_val(index);
+  double d;
+  value res;
+
+  CAMLassert (Tag_val(array) == Double_array_tag);
+  if (idx < 0 || idx >= Wosize_val(array) / Double_wosize)
+    caml_array_bound_error();
+  d = Double_flat_field(array, idx);
+#define Setup_for_gc
+#define Restore_after_gc
+  Alloc_small(res, Double_wosize, Double_tag);
+#undef Setup_for_gc
+#undef Restore_after_gc
+  Store_double_val(res, d);
+  return res;
 }
 
+/* [ 'a array -> int -> 'a -> unit ] where 'a != float */
 CAMLprim value caml_array_set_addr(value array, value index, value newval)
 {
   intnat idx = Long_val(index);
@@ -83,29 +124,56 @@ CAMLprim value caml_array_set_addr(value array, value index, value newval)
   return Val_unit;
 }
 
+/* [ float array -> int -> float -> unit ] */
 CAMLprim value caml_array_set_float(value array, value index, value newval)
 {
   intnat idx = Long_val(index);
+#ifdef FLAT_FLOAT_ARRAY
+  double d = Double_val (newval);
   if (idx < 0 || idx >= Wosize_val(array) / Double_wosize)
     caml_array_bound_error();
-  Store_double_field(array, idx, Double_val(newval));
+  Store_double_flat_field(array, idx, d);
+#else
+  CAMLassert (Tag_val (array) != Double_array_tag);
+  if (idx < 0 || idx >= Wosize_val(array)) caml_array_bound_error();
+  Modify(&Field(array, idx), newval);
+#endif
   return Val_unit;
 }
 
+/* [ 'a array -> int -> 'a -> unit ] */
 CAMLprim value caml_array_set(value array, value index, value newval)
 {
+#ifdef FLAT_FLOAT_ARRAY
   if (Tag_val(array) == Double_array_tag)
     return caml_array_set_float(array, index, newval);
-  else
-    return caml_array_set_addr(array, index, newval);
+#else
+  CAMLassert (Tag_val(array) != Double_array_tag);
+#endif
+  return caml_array_set_addr(array, index, newval);
+}
+
+/* [ floatarray -> int -> float -> unit ] */
+CAMLprim value caml_floatarray_set(value array, value index, value newval)
+{
+  intnat idx = Long_val(index);
+  double d = Double_val (newval);
+  CAMLassert (Tag_val(array) == Double_array_tag);
+  if (idx < 0 || idx >= Wosize_val(array) / Double_wosize)
+    caml_array_bound_error();
+  Store_double_flat_field(array, idx, d);
+  return Val_unit;
 }
 
+/* [ float array -> int -> float ] */
 CAMLprim value caml_array_unsafe_get_float(value array, value index)
 {
+  intnat idx = Long_val (index);
+#ifdef FLAT_FLOAT_ARRAY
   double d;
   value res;
 
-  d = Double_field(array, Long_val(index));
+  d = Double_flat_field(array, idx);
 #define Setup_for_gc
 #define Restore_after_gc
   Alloc_small(res, Double_wosize, Double_tag);
@@ -113,16 +181,43 @@ CAMLprim value caml_array_unsafe_get_float(value array, value index)
 #undef Restore_after_gc
   Store_double_val(res, d);
   return res;
+#else /* FLAT_FLOAT_ARRAY */
+  CAMLassert (Tag_val(array) != Double_array_tag);
+  return Field(array, idx);
+#endif /* FLAT_FLOAT_ARRAY */
 }
 
+/* [ 'a array -> int -> 'a ] */
 CAMLprim value caml_array_unsafe_get(value array, value index)
 {
+#ifdef FLAT_FLOAT_ARRAY
   if (Tag_val(array) == Double_array_tag)
     return caml_array_unsafe_get_float(array, index);
-  else
-    return Field(array, Long_val(index));
+#else
+  CAMLassert (Tag_val(array) != Double_array_tag);
+#endif
+  return Field(array, Long_val(index));
 }
 
+/* [ floatarray -> int -> float ] */
+CAMLprim value caml_floatarray_unsafe_get(value array, value index)
+{
+  intnat idx = Long_val(index);
+  double d;
+  value res;
+
+  CAMLassert (Tag_val(array) == Double_array_tag);
+  d = Double_flat_field(array, idx);
+#define Setup_for_gc
+#define Restore_after_gc
+  Alloc_small(res, Double_wosize, Double_tag);
+#undef Setup_for_gc
+#undef Restore_after_gc
+  Store_double_val(res, d);
+  return res;
+}
+
+/* [ 'a array -> int -> 'a -> unit ] where 'a != float */
 CAMLprim value caml_array_unsafe_set_addr(value array, value index,value newval)
 {
   intnat idx = Long_val(index);
@@ -130,35 +225,57 @@ CAMLprim value caml_array_unsafe_set_addr(value array, value index,value newval)
   return Val_unit;
 }
 
+/* [ float array -> int -> float -> unit ] */
 CAMLprim value caml_array_unsafe_set_float(value array,value index,value newval)
 {
-  Store_double_field(array, Long_val(index), Double_val(newval));
+  intnat idx = Long_val(index);
+#ifdef FLAT_FLOAT_ARRAY
+  double d = Double_val (newval);
+  Store_double_flat_field(array, idx, d);
+#else
+  Modify(&Field(array, idx), newval);
+#endif
   return Val_unit;
 }
 
+/* [ 'a array -> int -> 'a -> unit ] */
 CAMLprim value caml_array_unsafe_set(value array, value index, value newval)
 {
+#ifdef FLAT_FLOAT_ARRAY
   if (Tag_val(array) == Double_array_tag)
     return caml_array_unsafe_set_float(array, index, newval);
-  else
-    return caml_array_unsafe_set_addr(array, index, newval);
+#else
+  CAMLassert (Tag_val(array) != Double_array_tag);
+#endif
+  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)
+/* [ floatarray -> int -> float -> unit ] */
+CAMLprim value caml_floatarray_unsafe_set(value array, value index,value newval)
+{
+  intnat idx = Long_val(index);
+  double d = Double_val (newval);
+  Store_double_flat_field(array, idx, d);
+  return Val_unit;
+}
+
+/* [len] is a [value] representing number of floats. */
+/* [ int -> floatarray ] */
+CAMLprim value caml_floatarray_create(value len)
 {
   mlsize_t wosize = Long_val(len) * Double_wosize;
   value result;
-  if (wosize == 0)
-    return Atom(0);
-  else if (wosize <= Max_young_wosize){
+  if (wosize <= Max_young_wosize){
+    if (wosize == 0)
+      return Atom(0);
+    else
 #define Setup_for_gc
 #define Restore_after_gc
-    Alloc_small (result, wosize, Double_array_tag);
+      Alloc_small (result, wosize, Double_array_tag);
 #undef Setup_for_gc
 #undef Restore_after_gc
   }else if (wosize > Max_wosize)
-    caml_invalid_argument("Array.create_float");
+    caml_invalid_argument("Array.Floatarray.create");
   else {
     result = caml_alloc_shr (wosize, Double_array_tag);
     result = caml_check_urgent_gc (result);
@@ -166,37 +283,50 @@ CAMLprim value caml_make_float_vect(value len)
   return result;
 }
 
+/* [len] is a [value] representing number of floats */
+/* [ int -> float array ] */
+CAMLprim value caml_make_float_vect(value len)
+{
+#ifdef FLAT_FLOAT_ARRAY
+  return caml_floatarray_create (len);
+#else
+  return caml_alloc (Long_val (len), 0);
+#endif
+}
+
 /* [len] is a [value] representing number of words or floats */
 /* Spacetime profiling assumes that this function is only called from OCaml. */
 CAMLprim value caml_make_vect(value len, value init)
 {
   CAMLparam2 (len, init);
   CAMLlocal1 (res);
-  mlsize_t size, wsize, i;
-  double d;
+  mlsize_t size, i;
 
   size = Long_val(len);
   if (size == 0) {
     res = Atom(0);
-  }
-  else if (Is_block(init)
+#ifdef FLAT_FLOAT_ARRAY
+  } else if (Is_block(init)
            && Is_in_value_area(init)
            && Tag_val(init) == Double_tag) {
+    mlsize_t wsize;
+    double d;
     d = Double_val(init);
     wsize = size * Double_wosize;
     if (wsize > Max_wosize) caml_invalid_argument("Array.make");
     res = caml_alloc(wsize, Double_array_tag);
     for (i = 0; i < size; i++) {
-      Store_double_field(res, i, d);
+      Store_double_flat_field(res, i, d);
     }
+#endif
   } else {
-    if (size > Max_wosize) caml_invalid_argument("Array.make");
     if (size <= Max_young_wosize) {
       uintnat profinfo;
       Get_my_profinfo_with_cached_backtrace(profinfo, size);
       res = caml_alloc_small_with_my_or_given_profinfo(size, 0, profinfo);
       for (i = 0; i < size; i++) Field(res, i) = init;
     }
+    else if (size > Max_wosize) caml_invalid_argument("Array.make");
     else if (Is_block(init) && Is_young(init)) {
       /* We don't want to create so many major-to-minor references,
          so [init] is moved to the major heap by doing a minor GC. */
@@ -216,8 +346,15 @@ CAMLprim value caml_make_vect(value len, value init)
   CAMLreturn (res);
 }
 
+/* This primitive is used internally by the compiler to compile
+   explicit array expressions.
+   For float arrays when FLAT_FLOAT_ARRAY is true, it takes an array of
+   boxed floats and returns the corresponding flat-allocated [float array].
+   In all other cases, it just returns its argument unchanged.
+*/
 CAMLprim value caml_make_array(value init)
 {
+#ifdef FLAT_FLOAT_ARRAY
   CAMLparam1 (init);
   mlsize_t wsize, size, i;
   CAMLlocal2 (v, res);
@@ -240,11 +377,15 @@ CAMLprim value caml_make_array(value init)
         res = caml_check_urgent_gc(res);
       }
       for (i = 0; i < size; i++) {
-        Store_double_field(res, i, Double_val(Field(init, i)));
+        double d = Double_val(Field(init, i));
+        Store_double_flat_field(res, i, d);
       }
       CAMLreturn (res);
     }
   }
+#else
+  return init;
+#endif
 }
 
 /* Blitting */
@@ -255,6 +396,7 @@ CAMLprim value caml_array_blit(value a1, value ofs1, value a2, value ofs2,
   value * src, * dst;
   intnat count;
 
+#ifdef FLAT_FLOAT_ARRAY
   if (Tag_val(a2) == Double_array_tag) {
     /* Arrays of floats.  The values being copied are floats, not
        pointer, so we can do a direct copy.  memmove takes care of
@@ -264,6 +406,8 @@ CAMLprim value caml_array_blit(value a1, value ofs1, value a2, value ofs2,
             Long_val(n) * sizeof(double));
     return Val_unit;
   }
+#endif
+  CAMLassert (Tag_val(a2) != Double_array_tag);
   if (Is_young(a2)) {
     /* Arrays of values, destination is in young generation.
        Here too we can do a direct copy since this cannot create
@@ -308,22 +452,27 @@ static value caml_array_gather(intnat num_arrays,
 {
   CAMLparamN(arrays, num_arrays);
   value res;                    /* no need to register it as a root */
-  int isfloat;
-  mlsize_t i, size, wsize, count, pos;
+#ifdef FLAT_FLOAT_ARRAY
+  int isfloat = 0;
+  mlsize_t wsize;
+#endif
+  mlsize_t i, size, count, pos;
   value * src;
 
   /* Determine total size and whether result array is an array of floats */
   size = 0;
-  isfloat = 0;
   for (i = 0; i < num_arrays; i++) {
     if (mlsize_t_max - lengths[i] < size) caml_invalid_argument("Array.concat");
     size += lengths[i];
+#ifdef FLAT_FLOAT_ARRAY
     if (Tag_val(arrays[i]) == Double_array_tag) isfloat = 1;
+#endif
   }
   if (size == 0) {
     /* If total size = 0, just return empty array */
     res = Atom(0);
   }
+#ifdef FLAT_FLOAT_ARRAY
   else if (isfloat) {
     /* This is an array of floats.  We can use memcpy directly. */
     if (size > Max_wosize/Double_wosize) caml_invalid_argument("Array.concat");
@@ -335,12 +484,9 @@ static value caml_array_gather(intnat num_arrays,
              lengths[i] * sizeof(double));
       pos += lengths[i];
     }
-    Assert(pos == size);
-  }
-  else if (size > Max_wosize) {
-    /* Array of values, too big. */
-    caml_invalid_argument("Array.concat");
+    CAMLassert(pos == size);
   }
+#endif
   else if (size <= Max_young_wosize) {
     /* Array of values, small enough to fit in young generation.
        We can use memcpy directly. */
@@ -351,7 +497,11 @@ static value caml_array_gather(intnat num_arrays,
              lengths[i] * sizeof(value));
       pos += lengths[i];
     }
-    Assert(pos == size);
+    CAMLassert(pos == size);
+  }
+  else if (size > Max_wosize) {
+    /* Array of values, too big. */
+    caml_invalid_argument("Array.concat");
   } else {
     /* Array of values, must be allocated in old generation and filled
        using caml_initialize. */
@@ -363,7 +513,7 @@ static value caml_array_gather(intnat num_arrays,
         caml_initialize(&Field(res, pos), *src);
       }
     }
-    Assert(pos == size);
+    CAMLassert(pos == size);
 
     /* Many caml_initialize in a row can create a lot of old-to-young
        refs.  Give the minor GC a chance to run if it needs to. */
@@ -406,12 +556,12 @@ CAMLprim value caml_array_concat(value al)
     lengths = static_lengths;
   } else {
     arrays = caml_stat_alloc(n * sizeof(value));
-    offsets = malloc(n * sizeof(intnat));
+    offsets = caml_stat_alloc_noexc(n * sizeof(intnat));
     if (offsets == NULL) {
       caml_stat_free(arrays);
       caml_raise_out_of_memory();
     }
-    lengths = malloc(n * sizeof(value));
+    lengths = caml_stat_alloc_noexc(n * sizeof(value));
     if (lengths == NULL) {
       caml_stat_free(offsets);
       caml_stat_free(arrays);

diff --git a/byterun/backtrace_prim.c b/byterun/backtrace_prim.c
index 7a46e1d65aa8717784f6fb832945301c92b77916..e69b2568e7b984a97de19946c0236c1dd77bdb1c 100644 (file)
--- a/byterun/backtrace_prim.c
+++ b/byterun/backtrace_prim.c
@@ -46,7 +46,7 @@
 /* The table of debug information fragments */
 struct ext_table caml_debug_info;
 
-CAMLexport char * caml_cds_file = NULL;
+CAMLexport char_os * caml_cds_file = NULL;
 
 /* Location of fields in the Instruct.debug_event record */
 enum {
@@ -109,7 +109,7 @@ static int cmp_ev_info(const void *a, const void *b)
   return 0;
 }
 
-struct ev_info *process_debug_events(code_t code_start, value events_heap,
+static struct ev_info *process_debug_events(code_t code_start, value events_heap,
                                      mlsize_t *num_events)
 {
   CAMLparam1(events_heap);
@@ -126,7 +126,7 @@ struct ev_info *process_debug_events(code_t code_start, value events_heap,
   if (*num_events == 0)
       CAMLreturnT(struct ev_info *, NULL);
 
-  events = malloc(*num_events * sizeof(struct ev_info));
+  events = caml_stat_alloc_noexc(*num_events * sizeof(struct ev_info));
   if(events == NULL)
     caml_fatal_error ("caml_add_debug_info: out of memory");
 
@@ -142,7 +142,7 @@ struct ev_info *process_debug_events(code_t code_start, value events_heap,
 
       {
         uintnat fnsz = caml_string_length(Field(ev_start, POS_FNAME)) + 1;
-        events[j].ev_filename = (char*)malloc(fnsz);
+        events[j].ev_filename = (char*)caml_stat_alloc_noexc(fnsz);
         if(events[j].ev_filename == NULL)
           caml_fatal_error ("caml_add_debug_info: out of memory");
         memcpy(events[j].ev_filename,
@@ -162,7 +162,7 @@ struct ev_info *process_debug_events(code_t code_start, value events_heap,
     }
   }
 
-  Assert(j == *num_events);
+  CAMLassert(j == *num_events);
 
   qsort(events, *num_events, sizeof(struct ev_info), cmp_ev_info);
 
@@ -218,8 +218,9 @@ CAMLprim value caml_remove_debug_info(code_t start)
 }
 
 int caml_alloc_backtrace_buffer(void){
-  Assert(caml_backtrace_pos == 0);
-  caml_backtrace_buffer = malloc(BACKTRACE_BUFFER_SIZE * sizeof(code_t));
+  CAMLassert(caml_backtrace_pos == 0);
+  caml_backtrace_buffer =
+    caml_stat_alloc_noexc(BACKTRACE_BUFFER_SIZE * sizeof(code_t));
   if (caml_backtrace_buffer == NULL) return -1;
   return 0;
 }
@@ -310,7 +311,7 @@ CAMLprim value caml_get_current_callstack(value max_frames_value)
 
     for (trace_pos = 0; trace_pos < trace_size; trace_pos++) {
       code_t p = caml_next_frame_pointer(&sp, &trsp);
-      Assert(p != NULL);
+      CAMLassert(p != NULL);
       Field(trace, trace_pos) = Val_backtrace_slot(p);
     }
   }
@@ -324,16 +325,16 @@ CAMLprim value caml_get_current_callstack(value max_frames_value)
 #define O_BINARY 0
 #endif
 
-void read_main_debug_info(struct debug_info *di)
+static void read_main_debug_info(struct debug_info *di)
 {
   CAMLparam0();
   CAMLlocal3(events, evl, l);
-  char *exec_name;
+  char_os *exec_name;
   int fd, num_events, orig, i;
   struct channel *chan;
   struct exec_trailer trail;
 
-  Assert(di->already_read == 0);
+  CAMLassert(di->already_read == 0);
   di->already_read = 1;
 
   if (caml_cds_file != NULL) {

diff --git a/byterun/bigarray.c b/byterun/bigarray.c
new file mode 100644 (file)
index 0000000..a8991d0
--- /dev/null
+++ b/byterun/bigarray.c
@@ -0,0 +1,486 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*          Manuel Serrano and Xavier Leroy, INRIA Rocquencourt           */
+/*                                                                        */
+/*   Copyright 2000 Institut National de Recherche en Informatique et     */
+/*     en Automatique.                                                    */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+/* This file is an intermediate step in making the bigarray library
+   (in otherlibs/bigarray) a part of the standard library.
+   This file defines the basic allocation functions for bigarrays,
+   as well as the comparison, hashing and marshaling methods for
+   bigarrays.  The other bigarray primitives are still defined
+   in otherlibs/bigarray.  Memory-mapping a file as a bigarray
+   is being migrated to otherlibs/unix and otherlibs/win32unix. */
+
+#define CAML_INTERNALS
+
+#include <stddef.h>
+#include <stdarg.h>
+#include "caml/alloc.h"
+#include "caml/bigarray.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"
+
+/* Compute the number of elements of a big array */
+
+CAMLexport uintnat caml_ba_num_elts(struct caml_ba_array * b)
+{
+  uintnat num_elts;
+  int i;
+  num_elts = 1;
+  for (i = 0; i < b->num_dims; i++) num_elts = num_elts * b->dim[i];
+  return num_elts;
+}
+
+/* Size in bytes of a bigarray element, indexed by bigarray kind */
+
+CAMLexport int caml_ba_element_size[] =
+{ 4 /*FLOAT32*/, 8 /*FLOAT64*/,
+  1 /*SINT8*/, 1 /*UINT8*/,
+  2 /*SINT16*/, 2 /*UINT16*/,
+  4 /*INT32*/, 8 /*INT64*/,
+  sizeof(value) /*CAML_INT*/, sizeof(value) /*NATIVE_INT*/,
+  8 /*COMPLEX32*/, 16 /*COMPLEX64*/,
+  1 /*CHAR*/
+};
+
+/* Compute the number of bytes for the elements of a big array */
+
+CAMLexport uintnat caml_ba_byte_size(struct caml_ba_array * b)
+{
+  return caml_ba_num_elts(b)
+         * caml_ba_element_size[b->flags & CAML_BA_KIND_MASK];
+}
+
+/* Operation table for bigarrays */
+
+CAMLexport struct custom_operations caml_ba_ops = {
+  "_bigarray",
+  caml_ba_finalize,
+  caml_ba_compare,
+  caml_ba_hash,
+  caml_ba_serialize,
+  caml_ba_deserialize,
+  custom_compare_ext_default
+};
+
+/* Allocation of a big array */
+
+#define CAML_BA_MAX_MEMORY 1024*1024*1024
+/* 1 Gb -- after allocating that much, it's probably worth speeding
+   up the major GC */
+
+/* [caml_ba_alloc] will allocate a new bigarray object in the heap.
+   If [data] is NULL, the memory for the contents is also allocated
+   (with [malloc]) by [caml_ba_alloc].
+   [data] cannot point into the OCaml heap.
+   [dim] may point into an object in the OCaml heap.
+*/
+CAMLexport value
+caml_ba_alloc(int flags, int num_dims, void * data, intnat * dim)
+{
+  uintnat num_elts, asize, size;
+  int i;
+  value res;
+  struct caml_ba_array * b;
+  intnat dimcopy[CAML_BA_MAX_NUM_DIMS];
+
+  CAMLassert(num_dims >= 0 && num_dims <= CAML_BA_MAX_NUM_DIMS);
+  CAMLassert((flags & CAML_BA_KIND_MASK) <= CAML_BA_CHAR);
+  for (i = 0; i < num_dims; i++) dimcopy[i] = dim[i];
+  size = 0;
+  if (data == NULL) {
+    num_elts = 1;
+    for (i = 0; i < num_dims; i++) {
+      if (caml_umul_overflow(num_elts, dimcopy[i], &num_elts))
+        caml_raise_out_of_memory();
+    }
+    if (caml_umul_overflow(num_elts,
+                           caml_ba_element_size[flags & CAML_BA_KIND_MASK],
+                           &size))
+      caml_raise_out_of_memory();
+    data = malloc(size);
+    if (data == NULL && size != 0) caml_raise_out_of_memory();
+    flags |= CAML_BA_MANAGED;
+  }
+  asize = SIZEOF_BA_ARRAY + num_dims * sizeof(intnat);
+  res = caml_alloc_custom(&caml_ba_ops, asize, size, CAML_BA_MAX_MEMORY);
+  b = Caml_ba_array_val(res);
+  b->data = data;
+  b->num_dims = num_dims;
+  b->flags = flags;
+  b->proxy = NULL;
+  for (i = 0; i < num_dims; i++) b->dim[i] = dimcopy[i];
+  return res;
+}
+
+/* Same as caml_ba_alloc, but dimensions are passed as a list of
+   arguments */
+
+CAMLexport value caml_ba_alloc_dims(int flags, int num_dims, void * data, ...)
+{
+  va_list ap;
+  intnat dim[CAML_BA_MAX_NUM_DIMS];
+  int i;
+  value res;
+
+  CAMLassert(num_dims <= CAML_BA_MAX_NUM_DIMS);
+  va_start(ap, data);
+  for (i = 0; i < num_dims; i++) dim[i] = va_arg(ap, intnat);
+  va_end(ap);
+  res = caml_ba_alloc(flags, num_dims, data, dim);
+  return res;
+}
+
+/* Finalization of a big array */
+
+CAMLexport void caml_ba_finalize(value v)
+{
+  struct caml_ba_array * b = Caml_ba_array_val(v);
+
+  switch (b->flags & CAML_BA_MANAGED_MASK) {
+  case CAML_BA_EXTERNAL:
+    break;
+  case CAML_BA_MANAGED:
+    if (b->proxy == NULL) {
+      free(b->data);
+    } else {
+      if (-- b->proxy->refcount == 0) {
+        free(b->proxy->data);
+        free(b->proxy);
+      }
+    }
+    break;
+  case CAML_BA_MAPPED_FILE:
+    /* Bigarrays for mapped files use a different finalization method */
+  default:
+    CAMLassert(0);
+  }
+}
+
+/* Comparison of two big arrays */
+
+CAMLexport int caml_ba_compare(value v1, value v2)
+{
+  struct caml_ba_array * b1 = Caml_ba_array_val(v1);
+  struct caml_ba_array * b2 = Caml_ba_array_val(v2);
+  uintnat n, num_elts;
+  intnat flags1, flags2;
+  int i;
+
+  /* Compare kind & layout in case the arguments are of different types */
+  flags1 = b1->flags & (CAML_BA_KIND_MASK | CAML_BA_LAYOUT_MASK);
+  flags2 = b2->flags & (CAML_BA_KIND_MASK | CAML_BA_LAYOUT_MASK);
+  if (flags1 != flags2) return flags2 - flags1;
+  /* Compare number of dimensions */
+  if (b1->num_dims != b2->num_dims) return b2->num_dims - b1->num_dims;
+  /* Same number of dimensions: compare dimensions lexicographically */
+  for (i = 0; i < b1->num_dims; i++) {
+    intnat d1 = b1->dim[i];
+    intnat d2 = b2->dim[i];
+    if (d1 != d2) return d1 < d2 ? -1 : 1;
+  }
+  /* Same dimensions: compare contents lexicographically */
+  num_elts = caml_ba_num_elts(b1);
+
+#define DO_INTEGER_COMPARISON(type) \
+  { type * p1 = b1->data; type * p2 = b2->data; \
+    for (n = 0; n < num_elts; n++) { \
+      type e1 = *p1++; type e2 = *p2++; \
+      if (e1 < e2) return -1; \
+      if (e1 > e2) return 1; \
+    } \
+    return 0; \
+  }
+#define DO_FLOAT_COMPARISON(type) \
+  { type * p1 = b1->data; type * p2 = b2->data; \
+    for (n = 0; n < num_elts; n++) { \
+      type e1 = *p1++; type e2 = *p2++; \
+      if (e1 < e2) return -1; \
+      if (e1 > e2) return 1; \
+      if (e1 != e2) { \
+        caml_compare_unordered = 1; \
+        if (e1 == e1) return 1; \
+        if (e2 == e2) return -1; \
+      } \
+    } \
+    return 0; \
+  }
+
+  switch (b1->flags & CAML_BA_KIND_MASK) {
+  case CAML_BA_COMPLEX32:
+    num_elts *= 2; /*fallthrough*/
+  case CAML_BA_FLOAT32:
+    DO_FLOAT_COMPARISON(float);
+  case CAML_BA_COMPLEX64:
+    num_elts *= 2; /*fallthrough*/
+  case CAML_BA_FLOAT64:
+    DO_FLOAT_COMPARISON(double);
+  case CAML_BA_CHAR:
+    DO_INTEGER_COMPARISON(caml_ba_uint8);
+  case CAML_BA_SINT8:
+    DO_INTEGER_COMPARISON(caml_ba_int8);
+  case CAML_BA_UINT8:
+    DO_INTEGER_COMPARISON(caml_ba_uint8);
+  case CAML_BA_SINT16:
+    DO_INTEGER_COMPARISON(caml_ba_int16);
+  case CAML_BA_UINT16:
+    DO_INTEGER_COMPARISON(caml_ba_uint16);
+  case CAML_BA_INT32:
+    DO_INTEGER_COMPARISON(int32_t);
+  case CAML_BA_INT64:
+    DO_INTEGER_COMPARISON(int64_t);
+  case CAML_BA_CAML_INT:
+  case CAML_BA_NATIVE_INT:
+    DO_INTEGER_COMPARISON(intnat);
+  default:
+    CAMLassert(0);
+    return 0;                   /* should not happen */
+  }
+#undef DO_INTEGER_COMPARISON
+#undef DO_FLOAT_COMPARISON
+}
+
+/* Hashing of a bigarray */
+
+CAMLexport intnat caml_ba_hash(value v)
+{
+  struct caml_ba_array * b = Caml_ba_array_val(v);
+  intnat num_elts, n;
+  uint32_t h, w;
+  int i;
+
+  num_elts = 1;
+  for (i = 0; i < b->num_dims; i++) num_elts = num_elts * b->dim[i];
+  h = 0;
+
+  switch (b->flags & CAML_BA_KIND_MASK) {
+  case CAML_BA_CHAR:
+  case CAML_BA_SINT8:
+  case CAML_BA_UINT8: {
+    caml_ba_uint8 * p = b->data;
+    if (num_elts > 256) num_elts = 256;
+    for (n = 0; n + 4 <= num_elts; n += 4, p += 4) {
+      w = p[0] | (p[1] << 8) | (p[2] << 16) | (p[3] << 24);
+      h = caml_hash_mix_uint32(h, w);
+    }
+    w = 0;
+    switch (num_elts & 3) {
+    case 3: w  = p[2] << 16;    /* fallthrough */
+    case 2: w |= p[1] << 8;     /* fallthrough */
+    case 1: w |= p[0];
+            h = caml_hash_mix_uint32(h, w);
+    }
+    break;
+  }
+  case CAML_BA_SINT16:
+  case CAML_BA_UINT16: {
+    caml_ba_uint16 * p = b->data;
+    if (num_elts > 128) num_elts = 128;
+    for (n = 0; n + 2 <= num_elts; n += 2, p += 2) {
+      w = p[0] | (p[1] << 16);
+      h = caml_hash_mix_uint32(h, w);
+    }
+    if ((num_elts & 1) != 0)
+      h = caml_hash_mix_uint32(h, p[0]);
+    break;
+  }
+  case CAML_BA_INT32:
+  {
+    uint32_t * p = b->data;
+    if (num_elts > 64) num_elts = 64;
+    for (n = 0; n < num_elts; n++, p++) h = caml_hash_mix_uint32(h, *p);
+    break;
+  }
+  case CAML_BA_CAML_INT:
+  case CAML_BA_NATIVE_INT:
+  {
+    intnat * p = b->data;
+    if (num_elts > 64) num_elts = 64;
+    for (n = 0; n < num_elts; n++, p++) h = caml_hash_mix_intnat(h, *p);
+    break;
+  }
+  case CAML_BA_INT64:
+  {
+    int64_t * p = b->data;
+    if (num_elts > 32) num_elts = 32;
+    for (n = 0; n < num_elts; n++, p++) h = caml_hash_mix_int64(h, *p);
+    break;
+  }
+  case CAML_BA_COMPLEX32:
+    num_elts *= 2;              /* fallthrough */
+  case CAML_BA_FLOAT32:
+  {
+    float * p = b->data;
+    if (num_elts > 64) num_elts = 64;
+    for (n = 0; n < num_elts; n++, p++) h = caml_hash_mix_float(h, *p);
+    break;
+  }
+  case CAML_BA_COMPLEX64:
+    num_elts *= 2;              /* fallthrough */
+  case CAML_BA_FLOAT64:
+  {
+    double * p = b->data;
+    if (num_elts > 32) num_elts = 32;
+    for (n = 0; n < num_elts; n++, p++) h = caml_hash_mix_double(h, *p);
+    break;
+  }
+  }
+  return h;
+}
+
+static void caml_ba_serialize_longarray(void * data,
+                                        intnat num_elts,
+                                        intnat min_val, intnat max_val)
+{
+#ifdef ARCH_SIXTYFOUR
+  int overflow_32 = 0;
+  intnat * p, n;
+  for (n = 0, p = data; n < num_elts; n++, p++) {
+    if (*p < min_val || *p > max_val) { overflow_32 = 1; break; }
+  }
+  if (overflow_32) {
+    caml_serialize_int_1(1);
+    caml_serialize_block_8(data, num_elts);
+  } else {
+    caml_serialize_int_1(0);
+    for (n = 0, p = data; n < num_elts; n++, p++)
+      caml_serialize_int_4((int32_t) *p);
+  }
+#else
+  caml_serialize_int_1(0);
+  caml_serialize_block_4(data, num_elts);
+#endif
+}
+
+CAMLexport void caml_ba_serialize(value v,
+                              uintnat * wsize_32,
+                              uintnat * wsize_64)
+{
+  struct caml_ba_array * b = Caml_ba_array_val(v);
+  intnat num_elts;
+  int i;
+
+  /* Serialize header information */
+  caml_serialize_int_4(b->num_dims);
+  caml_serialize_int_4(b->flags & (CAML_BA_KIND_MASK | CAML_BA_LAYOUT_MASK));
+  /* On a 64-bit machine, if any of the dimensions is >= 2^32,
+     the size of the marshaled data will be >= 2^32 and
+     extern_value() will fail.  So, it is safe to write the dimensions
+     as 32-bit unsigned integers. */
+  for (i = 0; i < b->num_dims; i++) caml_serialize_int_4(b->dim[i]);
+  /* Compute total number of elements */
+  num_elts = 1;
+  for (i = 0; i < b->num_dims; i++) num_elts = num_elts * b->dim[i];
+  /* Serialize elements */
+  switch (b->flags & CAML_BA_KIND_MASK) {
+  case CAML_BA_CHAR:
+  case CAML_BA_SINT8:
+  case CAML_BA_UINT8:
+    caml_serialize_block_1(b->data, num_elts); break;
+  case CAML_BA_SINT16:
+  case CAML_BA_UINT16:
+    caml_serialize_block_2(b->data, num_elts); break;
+  case CAML_BA_FLOAT32:
+  case CAML_BA_INT32:
+    caml_serialize_block_4(b->data, num_elts); break;
+  case CAML_BA_COMPLEX32:
+    caml_serialize_block_4(b->data, num_elts * 2); break;
+  case CAML_BA_FLOAT64:
+  case CAML_BA_INT64:
+    caml_serialize_block_8(b->data, num_elts); break;
+  case CAML_BA_COMPLEX64:
+    caml_serialize_block_8(b->data, num_elts * 2); break;
+  case CAML_BA_CAML_INT:
+    caml_ba_serialize_longarray(b->data, num_elts, -0x40000000, 0x3FFFFFFF);
+    break;
+  case CAML_BA_NATIVE_INT:
+    caml_ba_serialize_longarray(b->data, num_elts, -0x80000000, 0x7FFFFFFF);
+    break;
+  }
+  /* Compute required size in OCaml heap.  Assumes struct caml_ba_array
+     is exactly 4 + num_dims words */
+  CAMLassert(SIZEOF_BA_ARRAY == 4 * sizeof(value));
+  *wsize_32 = (4 + b->num_dims) * 4;
+  *wsize_64 = (4 + b->num_dims) * 8;
+}
+
+static void caml_ba_deserialize_longarray(void * dest, intnat num_elts)
+{
+  int sixty = caml_deserialize_uint_1();
+#ifdef ARCH_SIXTYFOUR
+  if (sixty) {
+    caml_deserialize_block_8(dest, num_elts);
+  } else {
+    intnat * p, n;
+    for (n = 0, p = dest; n < num_elts; n++, p++)
+      *p = caml_deserialize_sint_4();
+  }
+#else
+  if (sixty)
+    caml_deserialize_error("input_value: cannot read bigarray "
+                      "with 64-bit OCaml ints");
+  caml_deserialize_block_4(dest, num_elts);
+#endif
+}
+
+CAMLexport uintnat caml_ba_deserialize(void * dst)
+{
+  struct caml_ba_array * b = dst;
+  int i, elt_size;
+  uintnat num_elts;
+
+  /* Read back header information */
+  b->num_dims = caml_deserialize_uint_4();
+  b->flags = caml_deserialize_uint_4() | CAML_BA_MANAGED;
+  b->proxy = NULL;
+  for (i = 0; i < b->num_dims; i++) b->dim[i] = caml_deserialize_uint_4();
+  /* Compute total number of elements */
+  num_elts = caml_ba_num_elts(b);
+  /* Determine element size in bytes */
+  if ((b->flags & CAML_BA_KIND_MASK) > CAML_BA_CHAR)
+    caml_deserialize_error("input_value: bad bigarray kind");
+  elt_size = caml_ba_element_size[b->flags & CAML_BA_KIND_MASK];
+  /* Allocate room for data */
+  b->data = malloc(elt_size * num_elts);
+  if (b->data == NULL)
+    caml_deserialize_error("input_value: out of memory for bigarray");
+  /* Read data */
+  switch (b->flags & CAML_BA_KIND_MASK) {
+  case CAML_BA_CHAR:
+  case CAML_BA_SINT8:
+  case CAML_BA_UINT8:
+    caml_deserialize_block_1(b->data, num_elts); break;
+  case CAML_BA_SINT16:
+  case CAML_BA_UINT16:
+    caml_deserialize_block_2(b->data, num_elts); break;
+  case CAML_BA_FLOAT32:
+  case CAML_BA_INT32:
+    caml_deserialize_block_4(b->data, num_elts); break;
+  case CAML_BA_COMPLEX32:
+    caml_deserialize_block_4(b->data, num_elts * 2); break;
+  case CAML_BA_FLOAT64:
+  case CAML_BA_INT64:
+    caml_deserialize_block_8(b->data, num_elts); break;
+  case CAML_BA_COMPLEX64:
+    caml_deserialize_block_8(b->data, num_elts * 2); break;
+  case CAML_BA_CAML_INT:
+  case CAML_BA_NATIVE_INT:
+    caml_ba_deserialize_longarray(b->data, num_elts); break;
+  }
+  /* PR#5516: use C99's flexible array types if possible */
+  return SIZEOF_BA_ARRAY + b->num_dims * sizeof(intnat);
+}

diff --git a/byterun/callback.c b/byterun/callback.c
index bef4b3df501e27be2a78a0fb9eafd09b40109344..9c479b3044375d7a5b86d96f926d38b5880ff7fa 100644 (file)
--- a/byterun/callback.c
+++ b/byterun/callback.c
@@ -69,7 +69,7 @@ CAMLexport value caml_callbackN_exn(value closure, int narg, value args[])
   opcode_t local_callback_code[7];
 #endif
 
-  Assert(narg + 4 <= 256);
+  CAMLassert(narg + 4 <= 256);
 
   caml_extern_sp -= narg + 4;
   for (i = 0; i < narg; i++) caml_extern_sp[i] = args[i]; /* arguments */
@@ -219,7 +219,7 @@ static unsigned int hash_value_name(char const *name)
 CAMLprim value caml_register_named_value(value vname, value val)
 {
   struct named_value * nv;
-  char * name = String_val(vname);
+  const char * name = String_val(vname);
   size_t namelen = strlen(name);
   unsigned int h = hash_value_name(name);
 

diff --git a/byterun/caml/address_class.h b/byterun/caml/address_class.h
index 36921e692510b59e60f4c0dc693b2e3847953982..85e22d32061f5a3e6c2a6dc592958c614bb6b701 100644 (file)
--- a/byterun/caml/address_class.h
+++ b/byterun/caml/address_class.h
@@ -26,7 +26,7 @@
    it might belong to. */
 
 #define Is_young(val) \
-  (Assert (Is_block (val)), \
+  (CAMLassert (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)

diff --git a/byterun/caml/alloc.h b/byterun/caml/alloc.h
index 5bd3d7ce7633f53d3f76bd93412164610d1c9ea7..81fff85821db03fb7aafb614374c887be1b11c6f 100644 (file)
--- a/byterun/caml/alloc.h
+++ b/byterun/caml/alloc.h
@@ -32,6 +32,7 @@ CAMLextern value caml_alloc_small (mlsize_t wosize, tag_t);
 CAMLextern value caml_alloc_tuple (mlsize_t wosize);
 CAMLextern value caml_alloc_float_array (mlsize_t len);
 CAMLextern value caml_alloc_string (mlsize_t len);  /* len in bytes (chars) */
+CAMLextern value caml_alloc_initialized_string (mlsize_t len, const char *);
 CAMLextern value caml_copy_string (char const *);
 CAMLextern value caml_copy_string_array (char const **);
 CAMLextern value caml_copy_double (double);
@@ -40,7 +41,11 @@ CAMLextern value caml_copy_int64 (int64_t);       /* defined in [ints.c] */
 CAMLextern value caml_copy_nativeint (intnat);  /* defined in [ints.c] */
 CAMLextern value caml_alloc_array (value (*funct) (char const *),
                                    char const ** array);
-CAMLextern value caml_alloc_sprintf(const char * format, ...);
+CAMLextern value caml_alloc_sprintf(const char * format, ...)
+#ifdef __GNUC__
+  __attribute__ ((format (printf, 1, 2)))
+#endif
+;
 
 CAMLextern value caml_alloc_with_profinfo (mlsize_t, tag_t, intnat);
 CAMLextern value caml_alloc_small_with_my_or_given_profinfo (

diff --git a/byterun/caml/backtrace.h b/byterun/caml/backtrace.h
index e9acf33cf489418ad5636f8cd4335a69dd0afea7..fc0baf2dfa24f1c77fadd88b1c587701509f6123 100644 (file)
--- a/byterun/caml/backtrace.h
+++ b/byterun/caml/backtrace.h
@@ -109,7 +109,7 @@ CAMLprim value caml_record_backtrace(value vflag);
 #ifndef NATIVE_CODE
 
 /* Path to the file containing debug information, if any, or NULL. */
-CAMLextern char * caml_cds_file;
+CAMLextern char_os * caml_cds_file;
 
 /* Primitive called _only_ by runtime to record unwinded frames to
  * backtrace.  A similar primitive exists for native code, but with a

diff --git a/byterun/caml/bigarray.h b/byterun/caml/bigarray.h
new file mode 100644 (file)
index 0000000..fc1fb14
--- /dev/null
+++ b/byterun/caml/bigarray.h
@@ -0,0 +1,134 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*          Manuel Serrano and Xavier Leroy, INRIA Rocquencourt           */
+/*                                                                        */
+/*   Copyright 2000 Institut National de Recherche en Informatique et     */
+/*     en Automatique.                                                    */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#ifndef CAML_BIGARRAY_H
+#define CAML_BIGARRAY_H
+
+#ifndef CAML_NAME_SPACE
+#include "compatibility.h"
+#endif
+#include "config.h"
+#include "mlvalues.h"
+
+typedef signed char caml_ba_int8;
+typedef unsigned char caml_ba_uint8;
+#if defined(HAS_STDINT_H)
+typedef int16_t caml_ba_int16;
+typedef uint16_t caml_ba_uint16;
+#elif SIZEOF_SHORT == 2
+typedef short caml_ba_int16;
+typedef unsigned short caml_ba_uint16;
+#else
+#error "No 16-bit integer type available"
+#endif
+
+#define CAML_BA_MAX_NUM_DIMS 16
+
+enum caml_ba_kind {
+  CAML_BA_FLOAT32,             /* Single-precision floats */
+  CAML_BA_FLOAT64,             /* Double-precision floats */
+  CAML_BA_SINT8,               /* Signed 8-bit integers */
+  CAML_BA_UINT8,               /* Unsigned 8-bit integers */
+  CAML_BA_SINT16,              /* Signed 16-bit integers */
+  CAML_BA_UINT16,              /* Unsigned 16-bit integers */
+  CAML_BA_INT32,               /* Signed 32-bit integers */
+  CAML_BA_INT64,               /* Signed 64-bit integers */
+  CAML_BA_CAML_INT,            /* OCaml-style integers (signed 31 or 63 bits) */
+  CAML_BA_NATIVE_INT,       /* Platform-native long integers (32 or 64 bits) */
+  CAML_BA_COMPLEX32,           /* Single-precision complex */
+  CAML_BA_COMPLEX64,           /* Double-precision complex */
+  CAML_BA_CHAR,                /* Characters */
+  CAML_BA_KIND_MASK = 0xFF     /* Mask for kind in flags field */
+};
+
+#define Caml_ba_kind_val(v) Int_val(v)
+
+#define Val_caml_ba_kind(k) Val_int(k)
+
+enum caml_ba_layout {
+  CAML_BA_C_LAYOUT = 0,           /* Row major, indices start at 0 */
+  CAML_BA_FORTRAN_LAYOUT = 0x100, /* Column major, indices start at 1 */
+  CAML_BA_LAYOUT_MASK = 0x100,    /* Mask for layout in flags field */
+  CAML_BA_LAYOUT_SHIFT = 8        /* Bit offset of layout flag */
+};
+
+#define Caml_ba_layout_val(v) (Int_val(v) << CAML_BA_LAYOUT_SHIFT)
+
+#define Val_caml_ba_layout(l) Val_int(l >> CAML_BA_LAYOUT_SHIFT)
+
+enum caml_ba_managed {
+  CAML_BA_EXTERNAL = 0,        /* Data is not allocated by OCaml */
+  CAML_BA_MANAGED = 0x200,     /* Data is allocated by OCaml */
+  CAML_BA_MAPPED_FILE = 0x400, /* Data is a memory mapped file */
+  CAML_BA_MANAGED_MASK = 0x600 /* Mask for "managed" bits in flags field */
+};
+
+struct caml_ba_proxy {
+  intnat refcount;              /* Reference count */
+  void * data;                  /* Pointer to base of actual data */
+  uintnat size;                 /* Size of data in bytes (if mapped file) */
+};
+
+struct caml_ba_array {
+  void * data;                /* Pointer to raw data */
+  intnat num_dims;            /* Number of dimensions */
+  intnat flags;  /* Kind of element array + memory layout + allocation status */
+  struct caml_ba_proxy * proxy; /* The proxy for sub-arrays, or NULL */
+  /* PR#5516: use C99's flexible array types if possible */
+#if (__STDC_VERSION__ >= 199901L)
+  intnat dim[]  /*[num_dims]*/; /* Size in each dimension */
+#else
+  intnat dim[1] /*[num_dims]*/; /* Size in each dimension */
+#endif
+};
+
+/* Size of struct caml_ba_array, in bytes, without dummy first dimension */
+#if (__STDC_VERSION__ >= 199901L)
+#define SIZEOF_BA_ARRAY sizeof(struct caml_ba_array)
+#else
+#define SIZEOF_BA_ARRAY (sizeof(struct caml_ba_array) - sizeof(intnat))
+#endif
+
+#define Caml_ba_array_val(v) ((struct caml_ba_array *) Data_custom_val(v))
+
+#define Caml_ba_data_val(v) (Caml_ba_array_val(v)->data)
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+CAMLextern value
+    caml_ba_alloc(int flags, int num_dims, void * data, intnat * dim);
+CAMLextern value caml_ba_alloc_dims(int flags, int num_dims, void * data,
+                                 ... /*dimensions, with type intnat */);
+CAMLextern uintnat caml_ba_byte_size(struct caml_ba_array * b);
+CAMLextern uintnat caml_ba_num_elts(struct caml_ba_array * b);
+
+#ifdef __cplusplus
+}
+#endif
+
+#ifdef CAML_INTERNALS
+
+CAMLextern int caml_ba_element_size[];
+CAMLextern void caml_ba_finalize(value v);
+CAMLextern int caml_ba_compare(value v1, value v2);
+CAMLextern intnat caml_ba_hash(value v);
+CAMLextern void caml_ba_serialize(value, uintnat *, uintnat *);
+CAMLextern uintnat caml_ba_deserialize(void * dst);
+
+#endif
+
+#endif /* CAML_BIGARRAY_H */

diff --git a/byterun/caml/callback.h b/byterun/caml/callback.h
index 147eb718114ac78dd353146bf4ae36a3ae2b9760..93208b7a1d59f6f46c58eed5f483ee92ffee374a 100644 (file)
--- a/byterun/caml/callback.h
+++ b/byterun/caml/callback.h
@@ -47,9 +47,12 @@ 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);
-CAMLextern value caml_startup_exn (char ** argv);
+CAMLextern void caml_main (char_os ** argv);
+CAMLextern void caml_startup (char_os ** argv);
+CAMLextern value caml_startup_exn (char_os ** argv);
+CAMLextern void caml_startup_pooled (char_os ** argv);
+CAMLextern value caml_startup_pooled_exn (char_os ** argv);
+CAMLextern void caml_shutdown (void);
 
 CAMLextern int caml_callback_depth;
 

diff --git a/byterun/caml/compact.h b/byterun/caml/compact.h
index 4f98fb12b7941416534c2e59d2a3a7635c3dfeca..e29d0e86f994f3cfc8dfa931eea906f28eddd1de 100644 (file)
--- a/byterun/caml/compact.h
+++ b/byterun/caml/compact.h
@@ -24,7 +24,7 @@
 
 void caml_compact_heap (void);
 void caml_compact_heap_maybe (void);
-void invert_root (value v, value *p);
+void caml_invert_root (value v, value *p);
 
 #endif /* CAML_INTERNALS */
 

diff --git a/byterun/caml/config.h b/byterun/caml/config.h
index a77b4e558288b34ccd5d0e130efd1fd58276a9a8..cee3e8bfa4a9fad0230d39a0ef8317d90b8b2305 100644 (file)
--- a/byterun/caml/config.h
+++ b/byterun/caml/config.h
@@ -16,15 +16,14 @@
 #ifndef CAML_CONFIG_H
 #define CAML_CONFIG_H
 
-/* <include ../config/m.h> */
-/* <include ../config/s.h> */
+/* <include m.h> */
+/* <include s.h> */
 /* <private> */
-#include "../../config/m.h"
-#include "../../config/s.h"
+#include "m.h"
+#include "s.h"
 #ifdef BOOTSTRAPPING_FLEXLINK
 #undef SUPPORT_DYNAMIC_LINKING
 #endif
-/* </private> */
 
 #ifndef CAML_NAME_SPACE
 #include "compatibility.h"
@@ -34,6 +33,10 @@
 #include <stdint.h>
 #endif
 
+#ifndef ARCH_SIZET_PRINTF_FORMAT
+#define ARCH_SIZET_PRINTF_FORMAT "z"
+#endif
+
 /* Types for 32-bit integers, 64-bit integers, and
    native integers (as wide as a pointer type) */
 
@@ -56,14 +59,14 @@
 #endif
 
 #ifndef ARCH_INT64_TYPE
-#if SIZEOF_LONGLONG == 8
-#define ARCH_INT64_TYPE long long
-#define ARCH_UINT64_TYPE unsigned long long
-#define ARCH_INT64_PRINTF_FORMAT "ll"
-#elif SIZEOF_LONG == 8
+#if SIZEOF_LONG == 8
 #define ARCH_INT64_TYPE long
 #define ARCH_UINT64_TYPE unsigned long
 #define ARCH_INT64_PRINTF_FORMAT "l"
+#elif SIZEOF_LONGLONG == 8
+#define ARCH_INT64_TYPE long long
+#define ARCH_UINT64_TYPE unsigned long long
+#define ARCH_INT64_PRINTF_FORMAT "ll"
 #else
 #error "No 64-bit integer type available"
 #endif

diff --git a/byterun/caml/dynlink.h b/byterun/caml/dynlink.h
index 0eed7e7fa1d112ac5fb3bd4ecdcaa382c0f39443..92f4e235db93798f1a8ca3b9cab51aefee4ad36b 100644 (file)
--- a/byterun/caml/dynlink.h
+++ b/byterun/caml/dynlink.h
@@ -25,9 +25,10 @@
 /* Build the table of primitives, given a search path, a list
    of shared libraries, and a list of primitive names
    (all three 0-separated in char arrays).
-   Abort the runtime system on error. */
-extern void caml_build_primitive_table(char * lib_path,
-                                       char * libs,
+   Abort the runtime system on error.
+   Calling this frees caml_shared_libs_path (not touching its contents). */
+extern void caml_build_primitive_table(char_os * lib_path,
+                                       char_os * libs,
                                        char * req_prims);
 
 /* The search path for shared libraries */
@@ -37,6 +38,9 @@ extern struct ext_table caml_shared_libs_path;
    Used for executables generated by ocamlc -output-obj. */
 extern void caml_build_primitive_table_builtin(void);
 
+/* Unload all the previously loaded shared libraries */
+extern void caml_free_shared_libs(void);
+
 #endif /* CAML_INTERNALS */
 
 #endif /* CAML_DYNLINK_H */

diff --git a/byterun/caml/fail.h b/byterun/caml/fail.h
index 3ae82b1e96c28d4c0c4549dfb508634418be7835..54907e4259a2f9716cf26c5abd87cdc932ee4c4a 100644 (file)
--- a/byterun/caml/fail.h
+++ b/byterun/caml/fail.h
@@ -44,6 +44,13 @@
 struct longjmp_buffer {
   sigjmp_buf buf;
 };
+#elif defined(__MINGW64__) && defined(__GNUC__) && __GNUC__ >= 4
+/* MPR#7638: issues with setjmp/longjmp in Mingw64, use GCC builtins instead */
+struct longjmp_buffer {
+  intptr_t buf[5];
+};
+#define sigsetjmp(buf,save) __builtin_setjmp(buf)
+#define siglongjmp(buf,val) __builtin_longjmp(buf,val)
 #else
 struct longjmp_buffer {
   jmp_buf buf;

diff --git a/byterun/caml/gc.h b/byterun/caml/gc.h
index c430afc04a2bbaf39888bcb069682009e36aaf54..a646a756bde2fd4b2e3b46f8056a8aca5cbfed4f 100644 (file)
--- a/byterun/caml/gc.h
+++ b/byterun/caml/gc.h
@@ -40,7 +40,7 @@
 
 /* This depends on the layout of the header.  See [mlvalues.h]. */
 #define Make_header(wosize, tag, color)                                       \
-      (/*Assert ((wosize) <= Max_wosize),*/                                   \
+      (/*CAMLassert ((wosize) <= Max_wosize),*/                                   \
        ((header_t) (((header_t) (wosize) << 10)                               \
                     + (color)                                                 \
                     + (tag_t) (tag)))                                         \

diff --git a/byterun/caml/hooks.h b/byterun/caml/hooks.h
index c9814263fd1362944e29d79c9d2274d1876eae7c..5877dd25b9b4da11173f20a4aa364c7ef560c66e 100644 (file)
--- a/byterun/caml/hooks.h
+++ b/byterun/caml/hooks.h
@@ -29,7 +29,7 @@ extern "C" {
 
 /* executed just before calling the entry point of a dynamically
    loaded native code module. */
-CAMLextern void (*caml_natdynlink_hook)(void* handle, char* unit);
+CAMLextern void (*caml_natdynlink_hook)(void* handle, const char* unit);
 
 #endif /* NATIVE_CODE */
 

diff --git a/byterun/caml/io.h b/byterun/caml/io.h
index f388bd9fb499e05206ba627234fcb2b9b3d36b5a..87de679e53ce7325eac7136715e2876b9fea06ec 100644 (file)
--- a/byterun/caml/io.h
+++ b/byterun/caml/io.h
@@ -55,8 +55,9 @@ struct channel {
 enum {
   CHANNEL_FLAG_FROM_SOCKET = 1,  /* For Windows */
 #if defined(NATIVE_CODE) && defined(WITH_SPACETIME)
-  CHANNEL_FLAG_BLOCKING_WRITE = 2,
+  CHANNEL_FLAG_BLOCKING_WRITE = 2, /* Don't release master lock when writing */
 #endif
+  CHANNEL_FLAG_MANAGED_BY_GC = 4,  /* Free and close using GC finalization */
 };
 
 /* For an output channel:

diff --git a/byterun/caml/major_gc.h b/byterun/caml/major_gc.h
index 98909c0ac80ae8eafdb95e15503bf0eb17e93da9..a6c42d9e38b9280b2cc0f80601b45f9a3b466841 100644 (file)
--- a/byterun/caml/major_gc.h
+++ b/byterun/caml/major_gc.h
@@ -55,7 +55,7 @@ extern uintnat caml_fl_wsz_at_phase_change;
 #define Subphase_mark_final 12
 /* Subphase_mark_final: At the start of this subphase register which
    value with an ocaml finalizer are not marked, the associated
-   finalizer will be run later. So we mark now these value as alive,
+   finalizer will be run later. So we mark now these values as alive,
    since they must be available for their finalizer.
   */
 
@@ -81,6 +81,15 @@ void major_collection (void);
 void caml_finish_major_cycle (void);
 void caml_set_major_window (int);
 
-#endif /* CAML_INTERNALS */
+/* Forces finalisation of all heap-allocated values,
+   disregarding both local and global roots.
+
+   Warning: finalisation is performed by means of forced sweeping, which may
+   result in pointers referencing nonexistent values; therefore the function
+   should only be used on runtime shutdown.
+*/
+void caml_finalise_heap (void);
+
+#endif /* CAML_INTERNALiS */
 
 #endif /* CAML_MAJOR_GC_H */

diff --git a/byterun/caml/memory.h b/byterun/caml/memory.h
index e366fd83d1596aea8ca0b602414ac6efbd73feb6..1ba489b240ec6c4884df7b8725c5dae8de27ca10 100644 (file)
--- a/byterun/caml/memory.h
+++ b/byterun/caml/memory.h
@@ -53,9 +53,6 @@ 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);
-CAMLextern void * caml_stat_alloc (asize_t);              /* Size in bytes. */
-CAMLextern void caml_stat_free (void *);
-CAMLextern void * caml_stat_resize (void *, asize_t);     /* Size in bytes. */
 CAMLextern int caml_init_alloc_for_heap (void);
 CAMLextern char *caml_alloc_for_heap (asize_t request);   /* Size in bytes. */
 CAMLextern void caml_free_for_heap (char *mem);
@@ -65,6 +62,120 @@ CAMLextern color_t caml_allocation_color (void *hp);
 
 CAMLextern int caml_huge_fallback_count;
 
+
+/* [caml_stat_*] functions below provide an interface to the static memory
+   manager built into the runtime, which can be used for managing static
+   (that is, non-moving) blocks of heap memory.
+
+   Function arguments that have type [caml_stat_block] must always be pointers
+   to blocks returned by the [caml_stat_*] functions below. Attempting to use
+   these functions on memory blocks allocated by a different memory manager
+   (e.g. the one from the C runtime) will cause undefined behaviour.
+*/
+typedef void* caml_stat_block;
+
+#ifdef CAML_INTERNALS
+
+/* The pool must be initialized with a call to [caml_stat_create_pool]
+   before it is possible to use any of the [caml_stat_*] functions below.
+
+   If the pool is not initialized, [caml_stat_*] functions will still work in
+   backward compatibility mode, becoming thin wrappers around [malloc] family
+   of functions. In this case, calling [caml_stat_destroy_pool] will not free
+   the claimed heap memory, resulting in leaks.
+*/
+CAMLextern void caml_stat_create_pool(void);
+
+/* [caml_stat_destroy_pool] frees all the heap memory claimed by the pool.
+
+   Once the pool is destroyed, [caml_stat_*] functions will continue to work
+   in backward compatibility mode, becoming thin wrappers around [malloc]
+   family of functions.
+*/
+CAMLextern void caml_stat_destroy_pool(void);
+
+#endif /* CAML_INTERNALS */
+
+/* [caml_stat_alloc(size)] allocates a memory block of the requested [size]
+   (in bytes) and returns a pointer to it. It throws an OCaml exception in case
+   the request fails, and so requires the runtime lock to be held.
+*/
+CAMLextern caml_stat_block caml_stat_alloc(asize_t);
+
+/* [caml_stat_alloc_noexc(size)] allocates a memory block of the requested [size]
+   (in bytes) and returns a pointer to it, or NULL in case the request fails.
+*/
+CAMLextern caml_stat_block caml_stat_alloc_noexc(asize_t);
+
+/* [caml_stat_alloc_aligned(size, modulo, block*)] allocates a memory block of
+   the requested [size] (in bytes), the starting address of which is aligned to
+   the provided [modulo] value. The function returns the aligned address, as
+   well as the unaligned [block] (as an output parameter). It throws an OCaml
+   exception in case the request fails, and so requires the runtime lock.
+*/
+CAMLextern void* caml_stat_alloc_aligned(asize_t, int modulo, caml_stat_block*);
+
+/* [caml_stat_alloc_aligned_noexc] is a variant of [caml_stat_alloc_aligned]
+   that returns NULL in case the request fails, and doesn't require the runtime
+   lock to be held.
+*/
+CAMLextern void* caml_stat_alloc_aligned_noexc(asize_t, int modulo,
+                                               caml_stat_block*);
+
+/* [caml_stat_calloc_noexc(num, size)] allocates a block of memory for an array
+   of [num] elements, each of them [size] bytes long, and initializes all its
+   bits to zero, effectively allocating a zero-initialized memory block of
+   [num * size] bytes. It returns NULL in case the request fails.
+*/
+CAMLextern caml_stat_block caml_stat_calloc_noexc(asize_t, asize_t);
+
+/* [caml_stat_free(block)] deallocates the provided [block]. */
+CAMLextern void caml_stat_free(caml_stat_block);
+
+/* [caml_stat_resize(block, size)] changes the size of the provided [block] to
+   [size] bytes. The function may move the memory block to a new location (whose
+   address is returned by the function). The content of the [block] is preserved
+   up to the smaller of the new and old sizes, even if the block is moved to a
+   new location. If the new size is larger, the value of the newly allocated
+   portion is indeterminate. The function throws an OCaml exception in case the
+   request fails, and so requires the runtime lock to be held.
+*/
+CAMLextern caml_stat_block caml_stat_resize(caml_stat_block, asize_t);
+
+/* [caml_stat_resize_noexc] is a variant of [caml_stat_resize] that returns NULL
+   in case the request fails, and doesn't require the runtime lock.
+*/
+CAMLextern caml_stat_block caml_stat_resize_noexc(caml_stat_block, asize_t);
+
+
+/* A [caml_stat_block] containing a NULL-terminated string */
+typedef char* caml_stat_string;
+
+/* [caml_stat_strdup(s)] returns a pointer to a heap-allocated string which is a
+   copy of the NULL-terminated string [s]. It throws an OCaml exception in case
+   the request fails, and so requires the runtime lock to be held.
+*/
+CAMLextern caml_stat_string caml_stat_strdup(const char *s);
+#ifdef _WIN32
+CAMLextern wchar_t* caml_stat_wcsdup(const wchar_t *s);
+#endif
+
+/* [caml_stat_strdup_noexc] is a variant of [caml_stat_strdup] that returns NULL
+   in case the request fails, and doesn't require the runtime lock.
+*/
+CAMLextern caml_stat_string caml_stat_strdup_noexc(const char *s);
+
+/* [caml_stat_strconcat(nargs, strings)] concatenates NULL-terminated [strings]
+   (an array of [char*] of size [nargs]) into a new string, dropping all NULLs,
+   except for the very last one. It throws an OCaml exception in case the
+   request fails, and so requires the runtime lock to be held.
+*/
+CAMLextern caml_stat_string caml_stat_strconcat(int n, ...);
+#ifdef _WIN32
+CAMLextern wchar_t* caml_stat_wcsconcat(int n, ...);
+#endif
+
+
 /* void caml_shrink_heap (char *);        Only used in compact.c */
 
 #ifdef CAML_INTERNALS
@@ -94,23 +205,23 @@ int caml_page_table_initialize(mlsize_t bytesize);
 #define DEBUG_clear(result, wosize)
 #endif
 
-#define Alloc_small_with_profinfo(result, wosize, tag, profinfo) do {       \
-                                                CAMLassert ((wosize) >= 1); \
-                                          CAMLassert ((tag_t) (tag) < 256); \
-                                 CAMLassert ((wosize) <= Max_young_wosize); \
-  caml_young_ptr -= Whsize_wosize (wosize);                                 \
-  if (caml_young_ptr < caml_young_trigger){                                 \
-    caml_young_ptr += Whsize_wosize (wosize);                               \
-    CAML_INSTR_INT ("force_minor/alloc_small@", 1);                         \
-    Setup_for_gc;                                                           \
-    caml_gc_dispatch ();                                                    \
-    Restore_after_gc;                                                       \
-    caml_young_ptr -= Whsize_wosize (wosize);                               \
-  }                                                                         \
-  Hd_hp (caml_young_ptr) =                                                  \
-    Make_header_with_profinfo ((wosize), (tag), Caml_black, profinfo);      \
-  (result) = Val_hp (caml_young_ptr);                                       \
-  DEBUG_clear ((result), (wosize));                                         \
+#define Alloc_small_with_profinfo(result, wosize, tag, profinfo) do { \
+  CAMLassert ((wosize) >= 1); \
+  CAMLassert ((tag_t) (tag) < 256); \
+  CAMLassert ((wosize) <= Max_young_wosize); \
+  caml_young_ptr -= Whsize_wosize (wosize); \
+  if (caml_young_ptr < caml_young_trigger){ \
+    caml_young_ptr += Whsize_wosize (wosize); \
+    CAML_INSTR_INT ("force_minor/alloc_small@", 1); \
+    Setup_for_gc; \
+    caml_gc_dispatch (); \
+    Restore_after_gc; \
+    caml_young_ptr -= Whsize_wosize (wosize); \
+  } \
+  Hd_hp (caml_young_ptr) = \
+    Make_header_with_profinfo ((wosize), (tag), Caml_black, profinfo); \
+  (result) = Val_hp (caml_young_ptr); \
+  DEBUG_clear ((result), (wosize)); \
 }while(0)
 
 #if defined(NATIVE_CODE) && defined(WITH_SPACETIME)

diff --git a/byterun/caml/minor_gc.h b/byterun/caml/minor_gc.h
index 7e15e6e07a92387e2cba8f9f7e7c30bf7461bcad..e08207521d9aa8d85a3a0edcfd01553edef8500d 100644 (file)
--- a/byterun/caml/minor_gc.h
+++ b/byterun/caml/minor_gc.h
@@ -99,7 +99,7 @@ static inline void add_to_ephe_ref_table (struct caml_ephe_ref_table *tbl,
   ephe_ref = tbl->ptr++;
   ephe_ref->ephe = ar;
   ephe_ref->offset = offset;
-  Assert(ephe_ref->offset < Wosize_val(ephe_ref->ephe));
+  CAMLassert(ephe_ref->offset < Wosize_val(ephe_ref->ephe));
 }
 
 static inline void add_to_custom_table (struct caml_custom_table *tbl, value v,

diff --git a/byterun/caml/misc.h b/byterun/caml/misc.h
index e953540f92130dd1c01cb01d0789a58b396a5234..d9a7b768f65d8eb06e96c5053073972b8629ca02 100644 (file)
--- a/byterun/caml/misc.h
+++ b/byterun/caml/misc.h
@@ -48,7 +48,7 @@ typedef char * addr;
    which supports both GCC/Clang and MSVC.
 
    Note: CAMLnoreturn is a different macro defined in memory.h,
-   to be used in function bodies rather than  aprototype attribute.
+   to be used in function bodies rather than as a prototype attribute.
 */
 #ifdef __GNUC__
   /* Works only in GCC 2.5 and later */
@@ -73,7 +73,7 @@ typedef char * addr;
 #define CAMLprim
 #define CAMLextern extern
 
-/* Weak function definitions that can be overriden by external libs */
+/* Weak function definitions that can be overridden by external libs */
 /* Conservatively restricted to ELF and MacOSX platforms */
 #if defined(__GNUC__) && (defined (__ELF__) || defined(__APPLE__))
 #define CAMLweakdef __attribute__((weak))
@@ -119,10 +119,124 @@ CAMLextern void caml_fatal_error_arg2 (char *fmt1, char *arg1,
                                        char *fmt2, char *arg2)
 CAMLnoreturn_end;
 
-/* Safe string operations */
+/* Detection of available C built-in functions, the Clang way. */
+
+#ifdef __has_builtin
+#define Caml_has_builtin(x) __has_builtin(x)
+#else
+#define Caml_has_builtin(x) 0
+#endif
+
+/* Integer arithmetic with overflow detection.
+   The functions return 0 if no overflow, 1 if overflow.
+   The result of the operation is always stored at [*res].
+   If no overflow is reported, this is the exact result.
+   If overflow is reported, this is the exact result modulo 2 to the word size.
+*/
+
+static inline int caml_uadd_overflow(uintnat a, uintnat b, uintnat * res)
+{
+#if __GNUC__ >= 5 || Caml_has_builtin(__builtin_add_overflow)
+  return __builtin_add_overflow(a, b, res);
+#else
+  uintnat c = a + b;
+  *res = c;
+  return c < a;
+#endif
+}
+
+static inline int caml_usub_overflow(uintnat a, uintnat b, uintnat * res)
+{
+#if __GNUC__ >= 5 || Caml_has_builtin(__builtin_sub_overflow)
+  return __builtin_sub_overflow(a, b, res);
+#else
+  uintnat c = a - b;
+  *res = c;
+  return a < b;
+#endif
+}
+
+#if __GNUC__ >= 5 || Caml_has_builtin(__builtin_mul_overflow)
+static inline int caml_umul_overflow(uintnat a, uintnat b, uintnat * res)
+{
+  return __builtin_mul_overflow(a, b, res);
+}
+#else
+extern int caml_umul_overflow(uintnat a, uintnat b, uintnat * res);
+#endif
+
+/* Windows Unicode support */
+
+#ifdef _WIN32
+
+typedef wchar_t char_os;
+
+#define _T(x) L ## x
+
+#define access_os _waccess
+#define open_os _wopen
+#define stat_os _wstati64
+#define unlink_os _wunlink
+#define rename_os caml_win32_rename
+#define chdir_os _wchdir
+#define getcwd_os _wgetcwd
+#define getenv_os _wgetenv
+#define system_os _wsystem
+#define rmdir_os _wrmdir
+#define utime_os _wutime
+#define putenv_os _wputenv
+#define chmod_os _wchmod
+#define execv_os _wexecv
+#define execve_os _wexecve
+#define execvp_os _wexecvp
+#define execvpe_os _wexecvpe
+#define strcmp_os wcscmp
+#define strlen_os wcslen
+#define sscanf_os swscanf
+
+#define caml_stat_strdup_os caml_stat_wcsdup
+#define caml_stat_strconcat_os caml_stat_wcsconcat
+
+#define caml_stat_strdup_to_os caml_stat_strdup_to_utf16
+#define caml_stat_strdup_of_os caml_stat_strdup_of_utf16
+#define caml_copy_string_of_os caml_copy_string_of_utf16
+
+#else /* _WIN32 */
+
+typedef char char_os;
+
+#define _T(x) x
+
+#define access_os access
+#define open_os open
+#define stat_os stat
+#define unlink_os unlink
+#define rename_os rename
+#define chdir_os chdir
+#define getcwd_os getcwd
+#define getenv_os getenv
+#define system_os system
+#define rmdir_os rmdir
+#define utime_os utime
+#define putenv_os putenv
+#define chmod_os chmod
+#define execv_os execv
+#define execve_os execve
+#define execvp_os execvp
+#define execvpe_os execvpe
+#define strcmp_os strcmp
+#define strlen_os strlen
+#define sscanf_os sscanf
+
+#define caml_stat_strdup_os caml_stat_strdup
+#define caml_stat_strconcat_os caml_stat_strconcat
+
+#define caml_stat_strdup_to_os caml_stat_strdup
+#define caml_stat_strdup_of_os caml_stat_strdup
+#define caml_copy_string_of_os caml_copy_string
+
+#endif /* _WIN32 */
 
-CAMLextern char * caml_strdup(const char * s);
-CAMLextern char * caml_strconcat(int n, ...); /* n args of const char * type */
 
 /* Use macros for some system calls being called from OCaml itself.
   These calls can be either traced for security reasons, or changed to
@@ -132,14 +246,14 @@ CAMLextern char * caml_strconcat(int n, ...); /* n args of const char * type */
 #ifndef CAML_WITH_CPLUGINS
 
 #define CAML_SYS_EXIT(retcode) exit(retcode)
-#define CAML_SYS_OPEN(filename,flags,perm) open(filename,flags,perm)
+#define CAML_SYS_OPEN(filename,flags,perm) open_os(filename,flags,perm)
 #define CAML_SYS_CLOSE(fd) close(fd)
-#define CAML_SYS_STAT(filename,st) stat(filename,st)
-#define CAML_SYS_UNLINK(filename) unlink(filename)
-#define CAML_SYS_RENAME(old_name,new_name) rename(old_name, new_name)
-#define CAML_SYS_CHDIR(dirname) chdir(dirname)
-#define CAML_SYS_GETENV(varname) getenv(varname)
-#define CAML_SYS_SYSTEM(command) system(command)
+#define CAML_SYS_STAT(filename,st) stat_os(filename,st)
+#define CAML_SYS_UNLINK(filename) unlink_os(filename)
+#define CAML_SYS_RENAME(old_name,new_name) rename_os(old_name, new_name)
+#define CAML_SYS_CHDIR(dirname) chdir_os(dirname)
+#define CAML_SYS_GETENV(varname) getenv_os(varname)
+#define CAML_SYS_SYSTEM(command) system_os(command)
 #define CAML_SYS_READ_DIRECTORY(dirname,tbl) caml_read_directory(dirname,tbl)
 
 #else
@@ -166,7 +280,7 @@ extern intnat (*caml_cplugins_prim)(int,intnat,intnat,intnat);
   caml_cplugins_prim(code,(intnat) (arg1),0,0)
 #define CAML_SYS_STRING_PRIM_1(code,prim,arg1)               \
   (caml_cplugins_prim == NULL) ? prim(arg1) :    \
-  (char*)caml_cplugins_prim(code,(intnat) (arg1),0,0)
+  (char_os*)caml_cplugins_prim(code,(intnat) (arg1),0,0)
 #define CAML_SYS_VOID_PRIM_1(code,prim,arg1)               \
   (caml_cplugins_prim == NULL) ? prim(arg1) :    \
   (void)caml_cplugins_prim(code,(intnat) (arg1),0,0)
@@ -180,21 +294,21 @@ extern intnat (*caml_cplugins_prim)(int,intnat,intnat,intnat);
 #define CAML_SYS_EXIT(retcode) \
   CAML_SYS_VOID_PRIM_1(CAML_CPLUGINS_EXIT,exit,retcode)
 #define CAML_SYS_OPEN(filename,flags,perm)                      \
-  CAML_SYS_PRIM_3(CAML_CPLUGINS_OPEN,open,filename,flags,perm)
+  CAML_SYS_PRIM_3(CAML_CPLUGINS_OPEN,open_os,filename,flags,perm)
 #define CAML_SYS_CLOSE(fd)                      \
   CAML_SYS_PRIM_1(CAML_CPLUGINS_CLOSE,close,fd)
 #define CAML_SYS_STAT(filename,st)                      \
-  CAML_SYS_PRIM_2(CAML_CPLUGINS_STAT,stat,filename,st)
+  CAML_SYS_PRIM_2(CAML_CPLUGINS_STAT,stat_os,filename,st)
 #define CAML_SYS_UNLINK(filename)                       \
-  CAML_SYS_PRIM_1(CAML_CPLUGINS_UNLINK,unlink,filename)
+  CAML_SYS_PRIM_1(CAML_CPLUGINS_UNLINK,unlink_os,filename)
 #define CAML_SYS_RENAME(old_name,new_name)                              \
-  CAML_SYS_PRIM_2(CAML_CPLUGINS_RENAME,rename,old_name,new_name)
+  CAML_SYS_PRIM_2(CAML_CPLUGINS_RENAME,rename_os,old_name,new_name)
 #define CAML_SYS_CHDIR(dirname)                         \
-  CAML_SYS_PRIM_1(CAML_CPLUGINS_CHDIR,chdir,dirname)
+  CAML_SYS_PRIM_1(CAML_CPLUGINS_CHDIR,chdir_os,dirname)
 #define CAML_SYS_GETENV(varname)                        \
-  CAML_SYS_STRING_PRIM_1(CAML_CPLUGINS_GETENV,getenv,varname)
+  CAML_SYS_STRING_PRIM_1(CAML_CPLUGINS_GETENV,getenv_os,varname)
 #define CAML_SYS_SYSTEM(command)                        \
-  CAML_SYS_PRIM_1(CAML_CPLUGINS_SYSTEM,system,command)
+  CAML_SYS_PRIM_1(CAML_CPLUGINS_SYSTEM,system_os,command)
 #define CAML_SYS_READ_DIRECTORY(dirname,tbl)                            \
   CAML_SYS_PRIM_2(CAML_CPLUGINS_READ_DIRECTORY,caml_read_directory,     \
                   dirname,tbl)
@@ -204,14 +318,14 @@ extern intnat (*caml_cplugins_prim)(int,intnat,intnat,intnat);
 struct cplugin_context {
   int api_version;
   int prims_bitmap;
-  char *exe_name;
-  char** argv;
-  char *plugin; /* absolute filename of plugin, do a copy if you need it ! */
+  char_os *exe_name;
+  char_os** argv;
+  char_os *plugin; /* absolute filename of plugin, do a copy if you need it ! */
   char *ocaml_version;
 /* end of CAML_CPLUGIN_CONTEXT_API version 0 */
 };
 
-extern void caml_cplugins_init(char * exe_name, char **argv);
+extern void caml_cplugins_init(char_os * exe_name, char_os **argv);
 
 /* A plugin MUST define a symbol "caml_cplugin_init" with the prototype:
 
@@ -237,24 +351,28 @@ 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);
 extern void caml_ext_table_clear(struct ext_table * tbl, int free_entries);
 
-CAMLextern int caml_read_directory(char * dirname, struct ext_table * contents);
+CAMLextern int caml_read_directory(char_os * dirname, struct ext_table * contents);
 
+/* Deprecated aliases */
+#define caml_aligned_malloc caml_stat_alloc_aligned_noexc
+#define caml_strdup caml_stat_strdup
+#define caml_strconcat caml_stat_strconcat
 
 #ifdef CAML_INTERNALS
 
 /* GC flags and messages */
 
 extern uintnat caml_verb_gc;
-void caml_gc_message (int, char *, uintnat);
+void caml_gc_message (int, char *, ...)
+#ifdef __GNUC__
+  __attribute__ ((format (printf, 2, 3)))
+#endif
+;
 
 /* Runtime warnings */
 extern uintnat caml_runtime_warnings;
 int caml_runtime_warnings_active(void);
 
-/* Memory routines */
-
-char *caml_aligned_malloc (asize_t bsize, int, void **);
-
 #ifdef DEBUG
 #ifdef ARCH_SIXTYFOUR
 #define Debug_tag(x) (0xD700D7D7D700D6D7ul \
@@ -271,8 +389,9 @@ char *caml_aligned_malloc (asize_t bsize, int, void **);
   04 -> fields deallocated by [caml_obj_truncate]
   10 -> uninitialised fields of minor objects
   11 -> uninitialised fields of major objects
-  15 -> uninitialised words of [caml_aligned_malloc] blocks
-  85 -> filler bytes of [caml_aligned_malloc]
+  15 -> uninitialised words of [caml_stat_alloc_aligned] blocks
+  85 -> filler bytes of [caml_stat_alloc_aligned]
+  99 -> the magic prefix of a memory block allocated by [caml_stat_alloc]
 
   special case (byte by byte):
   D7 -> uninitialised words of [caml_stat_alloc] blocks
@@ -285,6 +404,7 @@ char *caml_aligned_malloc (asize_t bsize, int, void **);
 #define Debug_uninit_major   Debug_tag (0x11)
 #define Debug_uninit_align   Debug_tag (0x15)
 #define Debug_filler_align   Debug_tag (0x85)
+#define Debug_pool_magic     Debug_tag (0x99)
 
 #define Debug_uninit_stat    0xD7
 
@@ -295,10 +415,6 @@ extern void caml_set_fields (intnat v, unsigned long, unsigned long);
 #endif /* DEBUG */
 
 
-#ifndef CAML_AVOID_CONFLICTS
-#define Assert CAMLassert
-#endif
-
 /* snprintf emulation for Win32 */
 
 #if defined(_WIN32) && !defined(_UCRT)
@@ -333,7 +449,7 @@ extern struct CAML_INSTR_BLOCK *CAML_INSTR_LOG;
 #define CAML_INSTR_ALLOC(t) do{                                     \
     if (caml_stat_minor_collections >= CAML_INSTR_STARTTIME         \
         && caml_stat_minor_collections < CAML_INSTR_STOPTIME){      \
-      t = malloc (sizeof (struct CAML_INSTR_BLOCK));                \
+      t = caml_stat_alloc_noexc (sizeof (struct CAML_INSTR_BLOCK)); \
       t->index = 0;                                                 \
       t->tag[0] = "";                                               \
       t->next = CAML_INSTR_LOG;                                     \

diff --git a/byterun/caml/mlvalues.h b/byterun/caml/mlvalues.h
index 04ff65a4856b16146b4481f773a5237bdb66cabc..ec30b20a1e179e6cdac9f9569b546b7d721a2cb8 100644 (file)
--- a/byterun/caml/mlvalues.h
+++ b/byterun/caml/mlvalues.h
@@ -104,23 +104,23 @@ bits  63        (64-P) (63-P)        10 9     8 7   0
 
 */
 
-#define PROFINFO_SHIFT (64 - PROFINFO_WIDTH)
-#define PROFINFO_MASK ((1ull << PROFINFO_WIDTH) - 1ull)
-
 #define Tag_hd(hd) ((tag_t) ((hd) & 0xFF))
+
+#define Gen_profinfo_shift(width) (64 - (width))
+#define Gen_profinfo_mask(width) ((1ull << (width)) - 1ull)
+#define Gen_profinfo_hd(width, hd) \
+  (((mlsize_t) ((hd) >> (Gen_profinfo_shift(width)))) \
+   & (Gen_profinfo_mask(width)))
+
 #ifdef WITH_PROFINFO
+#define PROFINFO_SHIFT (Gen_profinfo_shift(PROFINFO_WIDTH))
+#define PROFINFO_MASK (Gen_profinfo_mask(PROFINFO_WIDTH))
 #define Hd_no_profinfo(hd) ((hd) & ~(PROFINFO_MASK << PROFINFO_SHIFT))
 #define Wosize_hd(hd) ((mlsize_t) ((Hd_no_profinfo(hd)) >> 10))
+#define Profinfo_hd(hd) (Gen_profinfo_hd(PROFINFO_WIDTH, hd))
 #else
 #define Wosize_hd(hd) ((mlsize_t) ((hd) >> 10))
 #endif /* WITH_PROFINFO */
-#if defined(ARCH_SIXTYFOUR) && defined(WITH_PROFINFO)
-/* [Profinfo_hd] is used when the compiler is not configured for Spacetime
-   (e.g. when decoding profiles). */
-#define Profinfo_hd(hd) (((mlsize_t) ((hd) >> PROFINFO_SHIFT)) & PROFINFO_MASK)
-#else
-#define Profinfo_hd(hd) ((hd) & 0)
-#endif /* ARCH_SIXTYFOUR && WITH_PROFINFO */
 
 #define Hd_val(val) (((header_t *) (val)) [-1])        /* Also an l-value. */
 #define Hd_op(op) (Hd_val (op))                        /* Also an l-value. */
@@ -252,7 +252,12 @@ CAMLextern value caml_hash_variant(char const * tag);
 
 /* Strings. */
 #define String_tag 252
+#ifdef CAML_SAFE_STRING
+#define String_val(x) ((const char *) Bp_val(x))
+#else
 #define String_val(x) ((char *) Bp_val(x))
+#endif
+#define Bytes_val(x) ((unsigned char *) Bp_val(x))
 CAMLextern mlsize_t caml_string_length (value);   /* size in bytes */
 CAMLextern int caml_string_is_c_safe (value);
   /* true if string contains no '\0' null characters */
@@ -272,12 +277,48 @@ CAMLextern void caml_Store_double_val (value,double);
 
 /* Arrays of floating-point numbers. */
 #define Double_array_tag 254
-#define Double_field(v,i) Double_val((value)((double *)(v) + (i)))
-#define Store_double_field(v,i,d) do{ \
+
+/* The [_flat_field] macros are for [floatarray] values and float-only records.
+*/
+#define Double_flat_field(v,i) Double_val((value)((double *)(v) + (i)))
+#define Store_double_flat_field(v,i,d) do{ \
   mlsize_t caml__temp_i = (i); \
   double caml__temp_d = (d); \
   Store_double_val((value)((double *) (v) + caml__temp_i), caml__temp_d); \
 }while(0)
+
+/* The [_array_field] macros are for [float array]. */
+#ifdef FLAT_FLOAT_ARRAY
+  #define Double_array_field(v,i) Double_flat_field(v,i)
+  #define Store_double_array_field(v,i,d) Store_double_flat_field(v,i,d)
+#else
+  #define Double_array_field(v,i) Double_val (Field(v,i))
+  CAMLextern void caml_Store_double_array_field (value, mlsize_t, double);
+  #define Store_double_array_field(v,i,d) caml_Store_double_array_field (v,i,d)
+#endif
+
+/* The old [_field] macros are for backward compatibility only.
+   They work with [floatarray], float-only records, and [float array]. */
+#ifdef FLAT_FLOAT_ARRAY
+  #define Double_field(v,i) Double_flat_field(v,i)
+  #define Store_double_field(v,i,d) Store_double_flat_field(v,i,d)
+#else
+  static inline double Double_field (value v, mlsize_t i) {
+    if (Tag_val (v) == Double_array_tag){
+      return Double_flat_field (v, i);
+    }else{
+      return Double_array_field (v, i);
+    }
+  }
+  static inline void Store_double_field (value v, mlsize_t i, double d) {
+    if (Tag_val (v) == Double_array_tag){
+      Store_double_flat_field (v, i, d);
+    }else{
+      Store_double_array_field (v, i, d);
+    }
+  }
+#endif /* FLAT_FLOAT_ARRAY */
+
 CAMLextern mlsize_t caml_array_length (value);   /* size in items */
 CAMLextern int caml_is_double_array (value);   /* 0 is false, 1 is true */
 

diff --git a/byterun/caml/osdeps.h b/byterun/caml/osdeps.h
index bf9a48172f9c34d5ff8a482b6f347ea71758321f..bc75a7deda2015c377075d93b1c61630d54b5acd 100644 (file)
--- a/byterun/caml/osdeps.h
+++ b/byterun/caml/osdeps.h
@@ -18,9 +18,17 @@
 #ifndef CAML_OSDEPS_H
 #define CAML_OSDEPS_H
 
+#ifdef _WIN32
+extern unsigned short caml_win32_major;
+extern unsigned short caml_win32_minor;
+extern unsigned short caml_win32_build;
+extern unsigned short caml_win32_revision;
+#endif
+
 #ifdef CAML_INTERNALS
 
 #include "misc.h"
+#include "memory.h"
 
 /* Read at most [n] bytes from file descriptor [fd] into buffer [buf].
    [flags] indicates whether [fd] is a socket
@@ -39,19 +47,18 @@ extern int caml_read_fd(int fd, int flags, void * buf, int n);
 extern int caml_write_fd(int fd, int flags, void * buf, int n);
 
 /* Decompose the given path into a list of directories, and add them
-   to the given table.  Return the block to be freed later. */
-extern char * caml_decompose_path(struct ext_table * tbl, char * path);
+   to the given table. */
+extern char_os * caml_decompose_path(struct ext_table * tbl, char_os * path);
 
 /* Search the given file in the given list of directories.
-   If not found, return a copy of [name].  Result is allocated with
-   [caml_stat_alloc]. */
-extern char * caml_search_in_path(struct ext_table * path, char * name);
+   If not found, return a copy of [name]. */
+extern char_os * caml_search_in_path(struct ext_table * path, const char_os * name);
 
 /* Same, but search an executable name in the system path for executables. */
-CAMLextern char * caml_search_exe_in_path(char * name);
+CAMLextern char_os * caml_search_exe_in_path(const char_os * name);
 
 /* Same, but search a shared library in the given path. */
-extern char * caml_search_dll_in_path(struct ext_table * path, char * name);
+extern char_os * caml_search_dll_in_path(struct ext_table * path, const char_os * name);
 
 /* Open a shared library and return a handle on it.
    If [for_execution] is true, perform full symbol resolution and
@@ -62,16 +69,16 @@ extern char * caml_search_dll_in_path(struct ext_table * path, char * name);
    If [global] is true, symbols from the shared library can be used
    to resolve for other libraries to be opened later on.
    Return [NULL] on error. */
-extern void * caml_dlopen(char * libname, int for_execution, int global);
+extern void * caml_dlopen(char_os * libname, int for_execution, int global);
 
 /* Close a shared library handle */
 extern void caml_dlclose(void * handle);
 
 /* Look up the given symbol in the given shared library.
    Return [NULL] if not found, or symbol value if found. */
-extern void * caml_dlsym(void * handle, char * name);
+extern void * caml_dlsym(void * handle, const char * name);
 
-extern void * caml_globalsym(char * name);
+extern void * caml_globalsym(const char * name);
 
 /* Return an error message describing the most recent dynlink failure. */
 extern char * caml_dlerror(void);
@@ -79,17 +86,57 @@ extern char * caml_dlerror(void);
 /* Add to [contents] the (short) names of the files contained in
    the directory named [dirname].  No entries are added for [.] and [..].
    Return 0 on success, -1 on error; set errno in the case of error. */
-extern int caml_read_directory(char * dirname, struct ext_table * contents);
+extern int caml_read_directory(char_os * dirname, struct ext_table * contents);
 
 /* Recover executable name if possible (/proc/sef/exe under Linux,
    GetModuleFileName under Windows).  Return NULL on error,
    string allocated with [caml_stat_alloc] on success. */
-extern char * caml_executable_name(void);
+extern char_os * caml_executable_name(void);
 
 /* Secure version of [getenv]: returns NULL if the process has special
    privileges (setuid bit, setgid bit, capabilities).
 */
-extern char *caml_secure_getenv(char const *var);
+extern char_os *caml_secure_getenv(char_os const *var);
+
+#ifdef _WIN32
+
+extern int caml_win32_rename(const wchar_t *, const wchar_t *);
+
+extern void caml_probe_win32_version(void);
+extern void caml_setup_win32_terminal(void);
+extern void caml_restore_win32_terminal(void);
+
+/* Windows Unicode support */
+
+extern int win_multi_byte_to_wide_char(const char* s, int slen, wchar_t *out, int outlen);
+extern int win_wide_char_to_multi_byte(const wchar_t* s, int slen, char *out, int outlen);
+
+/* [caml_stat_strdup_to_utf16(s)] returns a NULL-terminated copy of [s],
+   re-encoded in UTF-16.  The encoding of [s] is assumed to be UTF-8 if
+   [caml_windows_unicode_runtime_enabled] is non-zero **and** [s] is valid
+   UTF-8, or the current Windows code page otherwise.
+
+   The returned string is allocated with [caml_stat_alloc], so it should be free
+   using [caml_stat_free].
+*/
+extern wchar_t* caml_stat_strdup_to_utf16(const char *s);
+
+/* [caml_stat_strdup_of_utf16(s)] returns a NULL-terminated copy of [s],
+   re-encoded in UTF-8 if [caml_windows_unicode_runtime_enabled] is non-zero or
+   the current Windows code page otherwise.
+
+   The returned string is allocated with [caml_stat_alloc], so it should be free
+   using [caml_stat_free].
+*/
+extern char* caml_stat_strdup_of_utf16(const wchar_t *s);
+
+/* [caml_copy_string_of_utf16(s)] returns an OCaml string containing a copy of
+   [s] re-encoded in UTF-8 if [caml_windows_unicode_runtime_enabled] is non-zero
+   or in the current code page otherwise.
+*/
+extern value caml_copy_string_of_utf16(const wchar_t *s);
+
+#endif /* _WIN32 */
 
 #endif /* CAML_INTERNALS */
 

diff --git a/byterun/caml/spacetime.h b/byterun/caml/spacetime.h
index 68bf1d20e0873afae48a410a6d69cf1f5c35be3a..df1193e2621d698f017dc88082d420ebaaf6289b 100644 (file)
--- a/byterun/caml/spacetime.h
+++ b/byterun/caml/spacetime.h
@@ -100,9 +100,11 @@ typedef enum {
 #define Alloc_point_next_ptr(node, offset) (Field(node, offset + 2))
 
 /* Direct call points (tail or non-tail) within OCaml nodes.
-   They just hold a pointer to the child node.  The call site and callee are
-   both recorded in the shape. */
+   They hold a pointer to the child node and (if the compiler was so
+   configured) a call count.
+   The call site and callee are both recorded in the shape. */
 #define Direct_callee_node(node,offset) (Field(node, offset))
+#define Direct_call_count(node,offset) (Field(node, offset + 1))
 #define Encode_call_point_pc(pc) (((value) pc) | 1)
 #define Decode_call_point_pc(pc) ((void*) (((value) pc) & ~((uintnat) 1)))
 
@@ -130,13 +132,18 @@ typedef struct {
   value next;
 } allocation_point;
 
+typedef struct {
+  value callee_node;
+  value call_count;
+} call_point;
+
 typedef struct {
   /* CR-soon mshinwell: delete [gc_header], all the offset arithmetic will
      then go away */
   uintnat gc_header;
   uintnat pc;           /* see above for encodings */
   union {
-    value callee_node;  /* for CALL */
+    call_point call;  /* for CALL */
     allocation_point allocation;  /* for ALLOCATION */
   } data;
   value next;           /* [Val_unit] for the end of the list */

diff --git a/byterun/caml/stack.h b/byterun/caml/stack.h
index fd9d528e9f0daf085b8e566bbd1321988562db6d..2668639865ecc889b5010f549cd9ec0801aed395 100644 (file)
--- a/byterun/caml/stack.h
+++ b/byterun/caml/stack.h
@@ -22,11 +22,6 @@
 
 /* Macros to access the stack frame */
 
-#ifdef TARGET_sparc
-#define Saved_return_address(sp) *((intnat *)((sp) + 92))
-#define Callback_link(sp) ((struct caml_context *)((sp) + 104))
-#endif
-
 #ifdef TARGET_i386
 #define Saved_return_address(sp) *((intnat *)((sp) - 4))
 #ifndef SYS_win32

diff --git a/byterun/caml/startup.h b/byterun/caml/startup.h
index 0c38dac0f1f28bfed1320466a3bfb9914b74c05c..2b26e9168a905788f2fb77cf489f9a554f5a4a25 100644 (file)
--- a/byterun/caml/startup.h
+++ b/byterun/caml/startup.h
@@ -21,23 +21,25 @@
 #include "mlvalues.h"
 #include "exec.h"
 
-CAMLextern void caml_main(char **argv);
+CAMLextern void caml_main(char_os **argv);
 
 CAMLextern void caml_startup_code(
            code_t code, asize_t code_size,
            char *data, asize_t data_size,
            char *section_table, asize_t section_table_size,
-           char **argv);
+           int pooling,
+           char_os **argv);
 
 CAMLextern value caml_startup_code_exn(
   code_t code, asize_t code_size,
   char *data, asize_t data_size,
   char *section_table, asize_t section_table_size,
-  char **argv);
+  int pooling,
+  char_os **argv);
 
 enum { FILE_NOT_FOUND = -1, BAD_BYTECODE  = -2 };
 
-extern int caml_attempt_open(char **name, struct exec_trailer *trail,
+extern int caml_attempt_open(char_os **name, struct exec_trailer *trail,
                              int do_open_script);
 extern void caml_read_section_descriptors(int fd, struct exec_trailer *trail);
 extern int32_t caml_seek_optional_section(int fd, struct exec_trailer *trail,

diff --git a/byterun/caml/startup_aux.h b/byterun/caml/startup_aux.h
index 203a47d73d17f5c244bcf7c429fedaee2d68d450..7286bc98a4cc4c0e3f9ebbceb3605215d042b8fa 100644 (file)
--- a/byterun/caml/startup_aux.h
+++ b/byterun/caml/startup_aux.h
@@ -30,9 +30,15 @@ extern uintnat caml_init_heap_wsz;
 extern uintnat caml_init_max_stack_wsz;
 extern uintnat caml_init_major_window;
 extern uintnat caml_trace_level;
+extern uintnat caml_cleanup_on_exit;
 
 extern void caml_parse_ocamlrunparam (void);
 
+/* Common entry point to caml_startup.
+   Returns 0 if the runtime is already initialized.
+   If [pooling] is 0, [caml_stat_*] functions will not be backed by a pool. */
+extern int caml_startup_aux (int pooling);
+
 #endif /* CAML_INTERNALS */
 
 #endif /* CAML_STARTUP_AUX_H */

diff --git a/byterun/caml/sys.h b/byterun/caml/sys.h
index e31e3cef9f18683258d2fa226f5499bf05f56981..0f372771503dcdc8842b70e0189033f1ce8f3191 100644 (file)
--- a/byterun/caml/sys.h
+++ b/byterun/caml/sys.h
@@ -29,12 +29,12 @@ extern "C" {
 CAMLextern void caml_sys_error (value);
 CAMLextern void caml_sys_io_error (value);
 CAMLextern double caml_sys_time_unboxed(value);
-CAMLextern void caml_sys_init (char * exe_name, char ** argv);
+CAMLextern void caml_sys_init (char_os * exe_name, char_os ** argv);
 CAMLextern value caml_sys_exit (value);
 extern double caml_sys_time_unboxed(value);
 CAMLextern value caml_sys_get_argv(value unit);
 
-extern char * caml_exe_name;
+extern char_os * caml_exe_name;
 
 #ifdef __cplusplus
 }

diff --git a/byterun/caml/weak.h b/byterun/caml/weak.h
index a716d2122f09ba3d25749916b1cf5c0a973f9ebb..a856386730549c1673b13a3189912621982f8e71 100644 (file)
--- a/byterun/caml/weak.h
+++ b/byterun/caml/weak.h
@@ -46,7 +46,7 @@ static inline void caml_ephe_clean (value v){
   int release_data = 0;
   mlsize_t size, i;
   header_t hd;
-                                    Assert(caml_gc_phase == Phase_clean);
+  CAMLassert(caml_gc_phase == Phase_clean);
 
   hd = Hd_val (v);
   size = Wosize_hd (hd);
@@ -82,7 +82,7 @@ static inline void caml_ephe_clean (value v){
         Field (v, 1) = caml_ephe_none;
       } else {
         /* The mark phase must have marked it */
-        Assert( !(Is_block (child) && Is_in_heap (child)
+        CAMLassert( !(Is_block (child) && Is_in_heap (child)
                   && Is_white_val (child)) );
       }
   }

diff --git a/byterun/compact.c b/byterun/compact.c
index 1d480692707777e24b42744df5bafc22c337cab7..7b7188ab80bc9425e8d414f91f9cd17972ecfe51 100644 (file)
--- a/byterun/compact.c
+++ b/byterun/compact.c
@@ -66,7 +66,7 @@ typedef uintnat word;
 static void invert_pointer_at (word *p)
 {
   word q = *p;
-                                            Assert (Ecolor ((intnat) p) == 0);
+  CAMLassert (Ecolor ((intnat) p) == 0);
 
   /* Use Ecolor (q) == 0 instead of Is_block (q) because q could be an
      inverted pointer for an infix header (with Ecolor == 2). */
@@ -88,7 +88,7 @@ static void invert_pointer_at (word *p)
         word *hp = (word *) Hp_val (val);
 
         while (Ecolor (*hp) == 0) hp = (word *) *hp;
-                                                   Assert (Ecolor (*hp) == 3);
+        CAMLassert (Ecolor (*hp) == 3);
         if (Tag_ehd (*hp) == Closure_tag){
           /* This is the first infix found in this block. */
           /* Save original header. */
@@ -98,7 +98,8 @@ static void invert_pointer_at (word *p)
           /* Change block header's tag to Infix_tag, and change its size
              to point to the infix list. */
           *hp = Make_ehd (Wosize_bhsize (q - val), Infix_tag, 3, (uintnat) 0);
-        }else{                            Assert (Tag_ehd (*hp) == Infix_tag);
+        }else{
+          CAMLassert (Tag_ehd (*hp) == Infix_tag);
           /* Point the last of this infix list to the current first infix
              list of the block. */
           *p = (word) &Field (val, Wosize_ehd (*hp)) | 1;
@@ -117,7 +118,7 @@ static void invert_pointer_at (word *p)
   }
 }
 
-void invert_root (value v, value *p)
+void caml_invert_root (value v, value *p)
 {
   invert_pointer_at ((word *) p);
 }
@@ -147,7 +148,8 @@ static char *compact_allocate (mlsize_t size)
   }
   chunk = compact_fl;
   while (Chunk_size (chunk) - Chunk_alloc (chunk) < size){
-    chunk = Chunk_next (chunk);                         Assert (chunk != NULL);
+    chunk = Chunk_next (chunk);
+    CAMLassert (chunk != NULL);
   }
   adr = chunk + Chunk_alloc (chunk);
   Chunk_alloc (chunk) += size;
@@ -157,8 +159,8 @@ static char *compact_allocate (mlsize_t size)
 static void do_compaction (void)
 {
   char *ch, *chend;
-                                          Assert (caml_gc_phase == Phase_idle);
-  caml_gc_message (0x10, "Compacting heap...\n", 0);
+  CAMLassert (caml_gc_phase == Phase_idle);
+  caml_gc_message (0x10, "Compacting heap...\n");
 
 #ifdef DEBUG
   caml_heap_check ();
@@ -178,7 +180,8 @@ static void do_compaction (void)
         if (Is_blue_hd (hd)){
           /* Free object.  Give it a string tag. */
           Hd_hp (p) = Make_ehd (sz, String_tag, 3, (uintnat) 0);
-        }else{                                      Assert (Is_white_hd (hd));
+        }else{
+          CAMLassert (Is_white_hd (hd));
           /* Live object.  Keep its tag. */
           Hd_hp (p) = Make_ehd (sz, Tag_hd (hd), 3, Profinfo_hd (hd));
         }
@@ -196,7 +199,7 @@ static void do_compaction (void)
     /* Invert roots first because the threads library needs some heap
        data structures to find its roots.  Fortunately, it doesn't need
        the headers (see above). */
-    caml_do_roots (invert_root, 1);
+    caml_do_roots (caml_invert_root, 1);
     /* The values to be finalised are not roots but should still be inverted */
     caml_final_invert_finalisable_values ();
 
@@ -287,7 +290,8 @@ static void do_compaction (void)
           if (t == Infix_tag){
             /* Get the original header of this block. */
             infixes = p + sz;
-            q = *infixes;                             Assert (Ecolor (q) == 2);
+            q = *infixes;
+            CAMLassert (Ecolor (q) == 2);
             while (Ecolor (q) != 3) q = * (word *) (q & ~(uintnat)3);
             sz = Whsize_ehd (q);
             t = Tag_ehd (q);
@@ -314,7 +318,8 @@ static void do_compaction (void)
                 next = * (word *) q;
                 * (word *) q = (word) Val_hp ((word *) newadr + (infixes - p));
                 q = next;
-              }                    Assert (Ecolor (q) == 1 || Ecolor (q) == 3);
+              }
+              CAMLassert (Ecolor (q) == 1 || Ecolor (q) == 3);
               /* No need to preserve any profinfo value on the [Infix_tag]
                  headers; the Spacetime profiling heap snapshot code doesn't
                  look at them. */
@@ -323,9 +328,10 @@ static void do_compaction (void)
             }
           }
           p += sz;
-        }else{                                        Assert (Ecolor (q) == 3);
+        }else{
+          CAMLassert (Ecolor (q) == 3);
           /* This is guaranteed only if caml_compact_heap was called after a
-             nonincremental major GC:       Assert (Tag_ehd (q) == String_tag);
+             nonincremental major GC:       CAMLassert (Tag_ehd (q) == String_tag);
           */
           /* No pointers to the header and no infix header:
              the object was free. */
@@ -355,7 +361,7 @@ static void do_compaction (void)
           memmove (newadr, p, sz);
           p += Wsize_bsize (sz);
         }else{
-          Assert (Color_hd (q) == Caml_blue);
+          CAMLassert (Color_hd (q) == Caml_blue);
           p += Whsize_hd (q);
         }
       }
@@ -411,7 +417,7 @@ static void do_compaction (void)
     }
   }
   ++ caml_stat_compactions;
-  caml_gc_message (0x10, "done.\n", 0);
+  caml_gc_message (0x10, "done.\n");
 }
 
 uintnat caml_percent_max;  /* used in gc_ctrl.c and memory.c */
@@ -468,7 +474,8 @@ void caml_compact_heap (void)
     /* Recompact. */
     char *chunk;
 
-    caml_gc_message (0x10, "Recompacting heap (target=%luk words)\n",
+    caml_gc_message (0x10, "Recompacting heap (target=%"
+                     ARCH_INTNAT_PRINTF_FORMAT "uk words)\n",
                      target_wsz / 1024);
 
     chunk = caml_alloc_for_heap (Bsize_wsize (target_wsz));
@@ -489,9 +496,9 @@ void caml_compact_heap (void)
       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_wsz == Wsize_bsize (Chunk_size (chunk)));
+    CAMLassert (caml_stat_heap_chunks == 1);
+    CAMLassert (Chunk_next (caml_heap_start) == NULL);
+    CAMLassert (caml_stat_heap_wsz == Wsize_bsize (Chunk_size (chunk)));
     CAML_INSTR_TIME (tmr, "compact/recompact");
   }
 }
@@ -507,7 +514,7 @@ void caml_compact_heap_maybe (void)
      We compact the heap if FP > caml_percent_max
   */
   float fw, fp;
-                                          Assert (caml_gc_phase == Phase_idle);
+  CAMLassert (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_clip_heap_chunk_wsz (0)) return;
@@ -537,7 +544,7 @@ void caml_compact_heap_maybe (void)
                           ARCH_INTNAT_PRINTF_FORMAT "u%%\n",
                    (uintnat) fp);
   if (fp >= caml_percent_max){
-    caml_gc_message (0x200, "Automatic compaction triggered.\n", 0);
+    caml_gc_message (0x200, "Automatic compaction triggered.\n");
     caml_empty_minor_heap ();  /* minor heap must be empty for compaction */
     caml_finish_major_cycle ();
 
@@ -549,7 +556,7 @@ void caml_compact_heap_maybe (void)
     if (fp >= caml_percent_max)
          caml_compact_heap ();
     else
-         caml_gc_message (0x200, "Automatic compaction aborted.\n", 0);
+         caml_gc_message (0x200, "Automatic compaction aborted.\n");
 
   }
 }

diff --git a/byterun/compare.c b/byterun/compare.c
index f34accd798225344cfeeccc3b49747eabd236166..382c9dfffa80eb4125c6c67d35d2fd6e2e7c4a0c 100644 (file)
--- a/byterun/compare.c
+++ b/byterun/compare.c
@@ -31,61 +31,78 @@
 
 struct compare_item { value * v1, * v2; mlsize_t count; };
 
-#define COMPARE_STACK_INIT_SIZE 256
+#define COMPARE_STACK_INIT_SIZE 8
+#define COMPARE_STACK_MIN_ALLOC_SIZE 32
 #define COMPARE_STACK_MAX_SIZE (1024*1024)
-
-static struct compare_item compare_stack_init[COMPARE_STACK_INIT_SIZE];
-
-static struct compare_item * compare_stack = compare_stack_init;
-static struct compare_item * compare_stack_limit = compare_stack_init
-                                                   + COMPARE_STACK_INIT_SIZE;
-
 CAMLexport int caml_compare_unordered;
 
+struct compare_stack {
+  struct compare_item init_stack[COMPARE_STACK_INIT_SIZE];
+  struct compare_item* stack;
+  struct compare_item* limit;
+};
+
 /* Free the compare stack if needed */
-static void compare_free_stack(void)
+static void compare_free_stack(struct compare_stack* stk)
 {
-  if (compare_stack != compare_stack_init) {
-    free(compare_stack);
-    /* Reinitialize the globals for next time around */
-    compare_stack = compare_stack_init;
-    compare_stack_limit = compare_stack + COMPARE_STACK_INIT_SIZE;
+  if (stk->stack != stk->init_stack) {
+    caml_stat_free(stk->stack);
+    stk->stack = NULL;
   }
 }
 
 /* Same, then raise Out_of_memory */
-static void compare_stack_overflow(void)
+static void compare_stack_overflow(struct compare_stack* stk)
 {
-  caml_gc_message (0x04, "Stack overflow in structural comparison\n", 0);
-  compare_free_stack();
+  caml_gc_message (0x04, "Stack overflow in structural comparison\n");
+  compare_free_stack(stk);
   caml_raise_out_of_memory();
 }
 
 /* Grow the compare stack */
-static struct compare_item * compare_resize_stack(struct compare_item * sp)
+static struct compare_item * compare_resize_stack(struct compare_stack* stk,
+                                                  struct compare_item * sp)
 {
-  asize_t newsize = 2 * (compare_stack_limit - compare_stack);
-  asize_t sp_offset = sp - compare_stack;
+  asize_t newsize;
+  asize_t sp_offset = sp - stk->stack;
   struct compare_item * newstack;
 
-  if (newsize >= COMPARE_STACK_MAX_SIZE) compare_stack_overflow();
-  if (compare_stack == compare_stack_init) {
-    newstack = malloc(sizeof(struct compare_item) * newsize);
-    if (newstack == NULL) compare_stack_overflow();
-    memcpy(newstack, compare_stack_init,
+  if (stk->stack == stk->init_stack) {
+    newsize = COMPARE_STACK_MIN_ALLOC_SIZE;
+    newstack = caml_stat_alloc_noexc(sizeof(struct compare_item) * newsize);
+    if (newstack == NULL) compare_stack_overflow(stk);
+    memcpy(newstack, stk->init_stack,
            sizeof(struct compare_item) * COMPARE_STACK_INIT_SIZE);
   } else {
-    newstack =
-      realloc(compare_stack, sizeof(struct compare_item) * newsize);
-    if (newstack == NULL) compare_stack_overflow();
+    newsize = 2 * (stk->limit - stk->stack);
+    if (newsize >= COMPARE_STACK_MAX_SIZE) compare_stack_overflow(stk);
+    newstack = caml_stat_resize_noexc(stk->stack,
+                                      sizeof(struct compare_item) * newsize);
+    if (newstack == NULL) compare_stack_overflow(stk);
   }
-  compare_stack = newstack;
-  compare_stack_limit = newstack + newsize;
+  stk->stack = newstack;
+  stk->limit = newstack + newsize;
   return newstack + sp_offset;
 }
 
+
+static intnat do_compare_val(struct compare_stack* stk,
+                             value v1, value v2, int total);
+
+static intnat compare_val(value v1, value v2, int total)
+{
+  struct compare_stack stk;
+  intnat res;
+  stk.stack = stk.init_stack;
+  stk.limit = stk.stack + COMPARE_STACK_INIT_SIZE;
+  res = do_compare_val(&stk, v1, v2, total);
+  compare_free_stack(&stk);
+  return res;
+}
+
 /* Structural comparison */
 
+
 #define LESS -1
 #define EQUAL 0
 #define GREATER 1
@@ -97,12 +114,13 @@ static struct compare_item * compare_resize_stack(struct compare_item * sp)
       < 0 and > UNORDERED v1 is less than v2
       UNORDERED           v1 and v2 cannot be compared */
 
-static intnat compare_val(value v1, value v2, int total)
+static intnat do_compare_val(struct compare_stack* stk,
+                             value v1, value v2, int total)
 {
   struct compare_item * sp;
   tag_t t1, t2;
 
-  sp = compare_stack;
+  sp = stk->stack;
   while (1) {
     if (v1 == v2 && total) goto next_item;
     if (Is_long(v1)) {
@@ -210,9 +228,9 @@ static intnat compare_val(value v1, value v2, int total)
       mlsize_t i;
       if (sz1 != sz2) return sz1 - sz2;
       for (i = 0; i < sz1; i++) {
-        double d1 = Double_field(v1, i);
-        double d2 = Double_field(v2, i);
-#ifdef LACKS_SANE_NAN
+        double d1 = Double_flat_field(v1, i);
+        double d2 = Double_flat_field(v2, i);
+  #ifdef LACKS_SANE_NAN
         if (isnan(d2)) {
           if (! total) return UNORDERED;
           if (isnan(d1)) break;
@@ -221,26 +239,26 @@ static intnat compare_val(value v1, value v2, int total)
           if (! total) return UNORDERED;
           return LESS;
         }
-#endif
+  #endif
         if (d1 < d2) return LESS;
         if (d1 > d2) return GREATER;
-#ifndef LACKS_SANE_NAN
+  #ifndef LACKS_SANE_NAN
         if (d1 != d2) {
           if (! total) return UNORDERED;
           /* See comment for Double_tag case */
           if (d1 == d1) return GREATER;
           if (d2 == d2) return LESS;
         }
-#endif
+  #endif
       }
       break;
     }
     case Abstract_tag:
-      compare_free_stack();
+      compare_free_stack(stk);
       caml_invalid_argument("compare: abstract value");
     case Closure_tag:
     case Infix_tag:
-      compare_free_stack();
+      compare_free_stack(stk);
       caml_invalid_argument("compare: functional value");
     case Object_tag: {
       intnat oid1 = Oid_val(v1);
@@ -258,7 +276,7 @@ static intnat compare_val(value v1, value v2, int total)
                ? LESS : GREATER;
       }
       if (compare == NULL) {
-        compare_free_stack();
+        compare_free_stack(stk);
         caml_invalid_argument("compare: abstract value");
       }
       caml_compare_unordered = 0;
@@ -276,7 +294,7 @@ static intnat compare_val(value v1, value v2, int total)
       /* Remember that we still have to compare fields 1 ... sz - 1 */
       if (sz1 > 1) {
         sp++;
-        if (sp >= compare_stack_limit) sp = compare_resize_stack(sp);
+        if (sp >= stk->limit) sp = compare_resize_stack(stk, sp);
         sp->v1 = &Field(v1, 1);
         sp->v2 = &Field(v2, 1);
         sp->count = sz1 - 1;
@@ -289,7 +307,7 @@ static intnat compare_val(value v1, value v2, int total)
     }
   next_item:
     /* Pop one more item to compare, if any */
-    if (sp == compare_stack) return EQUAL; /* we're done */
+    if (sp == stk->stack) return EQUAL; /* we're done */
     v1 = *((sp->v1)++);
     v2 = *((sp->v2)++);
     if (--(sp->count) == 0) sp--;
@@ -300,7 +318,6 @@ CAMLprim value caml_compare(value v1, value v2)
 {
   intnat res = compare_val(v1, v2, 1);
   /* Free stack if needed */
-  if (compare_stack != compare_stack_init) compare_free_stack();
   if (res < 0)
     return Val_int(LESS);
   else if (res > 0)
@@ -312,41 +329,35 @@ CAMLprim value caml_compare(value v1, value v2)
 CAMLprim value caml_equal(value v1, value v2)
 {
   intnat res = compare_val(v1, v2, 0);
-  if (compare_stack != compare_stack_init) compare_free_stack();
   return Val_int(res == 0);
 }
 
 CAMLprim value caml_notequal(value v1, value v2)
 {
   intnat res = compare_val(v1, v2, 0);
-  if (compare_stack != compare_stack_init) compare_free_stack();
   return Val_int(res != 0);
 }
 
 CAMLprim value caml_lessthan(value v1, value v2)
 {
   intnat res = compare_val(v1, v2, 0);
-  if (compare_stack != compare_stack_init) compare_free_stack();
   return Val_int(res < 0 && res != UNORDERED);
 }
 
 CAMLprim value caml_lessequal(value v1, value v2)
 {
   intnat res = compare_val(v1, v2, 0);
-  if (compare_stack != compare_stack_init) compare_free_stack();
   return Val_int(res <= 0 && res != UNORDERED);
 }
 
 CAMLprim value caml_greaterthan(value v1, value v2)
 {
   intnat res = compare_val(v1, v2, 0);
-  if (compare_stack != compare_stack_init) compare_free_stack();
   return Val_int(res > 0);
 }
 
 CAMLprim value caml_greaterequal(value v1, value v2)
 {
   intnat res = compare_val(v1, v2, 0);
-  if (compare_stack != compare_stack_init) compare_free_stack();
   return Val_int(res >= 0);
 }

diff --git a/byterun/custom.c b/byterun/custom.c
index 2198d62d798f264f7a45d6e4a9022ad075ad0207..f68eac9507727303132f58e50c7cb21224ab3d81 100644 (file)
--- a/byterun/custom.c
+++ b/byterun/custom.c
@@ -60,8 +60,8 @@ CAMLexport void caml_register_custom_operations(struct custom_operations * ops)
 {
   struct custom_operations_list * l =
     caml_stat_alloc(sizeof(struct custom_operations_list));
-  Assert(ops->identifier != NULL);
-  Assert(ops->deserialize != NULL);
+  CAMLassert(ops->identifier != NULL);
+  CAMLassert(ops->deserialize != NULL);
   l->ops = ops;
   l->next = custom_ops_table;
   custom_ops_table = l;
@@ -100,11 +100,13 @@ struct custom_operations * caml_final_custom_operations(final_fun fn)
 
 extern struct custom_operations caml_int32_ops,
                                 caml_nativeint_ops,
-                                caml_int64_ops;
+                                caml_int64_ops,
+                                caml_ba_ops;
 
 void caml_init_custom_operations(void)
 {
   caml_register_custom_operations(&caml_int32_ops);
   caml_register_custom_operations(&caml_nativeint_ops);
   caml_register_custom_operations(&caml_int64_ops);
+  caml_register_custom_operations(&caml_ba_ops);
 }

diff --git a/byterun/debugger.c b/byterun/debugger.c
index f40008726b4fddb5339901ae246fe0cf23d68f47..71536774713956f4bb4b6947bfc5c6bc27f49762 100644 (file)
--- a/byterun/debugger.c
+++ b/byterun/debugger.c
@@ -93,7 +93,7 @@ static int dbg_socket = -1;     /* The socket connected to the debugger */
 static struct channel * dbg_in; /* Input channel on the socket */
 static struct channel * dbg_out;/* Output channel on the socket */
 
-static char *dbg_addr = "(none)";
+static char *dbg_addr = NULL;
 
 static void open_connection(void)
 {
@@ -121,7 +121,7 @@ static void open_connection(void)
 #endif
   if (dbg_socket == -1 ||
       connect(dbg_socket, &sock_addr.s_gen, sock_addr_len) == -1){
-    caml_fatal_error_arg2 ("cannot connect to debugger at %s\n", dbg_addr,
+    caml_fatal_error_arg2 ("cannot connect to debugger at %s\n", (dbg_addr ? dbg_addr : "(none)"),
                            "error: %s\n", strerror (errno));
   }
 #ifdef _WIN32
@@ -164,6 +164,7 @@ static void winsock_cleanup(void)
 void caml_debugger_init(void)
 {
   char * address;
+  char_os * a;
   char * port, * p;
   struct hostent * host;
   int n;
@@ -173,8 +174,10 @@ void caml_debugger_init(void)
   Store_field(marshal_flags, 0, Val_int(1)); /* Marshal.Closures */
   Store_field(marshal_flags, 1, Val_emptylist);
 
-  address = caml_secure_getenv("CAML_DEBUG_SOCKET");
+  a = caml_secure_getenv(_T("CAML_DEBUG_SOCKET"));
+  address = a ? caml_stat_strdup_of_os(a) : NULL;
   if (address == NULL) return;
+  if (dbg_addr != NULL) caml_stat_free(dbg_addr);
   dbg_addr = address;
 
 #ifdef _WIN32
@@ -303,20 +306,20 @@ void caml_debugger(enum event_kind event)
     switch(caml_getch(dbg_in)) {
     case REQ_SET_EVENT:
       pos = caml_getword(dbg_in);
-      Assert (pos >= 0);
-      Assert (pos < caml_code_size);
+      CAMLassert (pos >= 0);
+      CAMLassert (pos < caml_code_size);
       caml_set_instruction(caml_start_code + pos / sizeof(opcode_t), EVENT);
       break;
     case REQ_SET_BREAKPOINT:
       pos = caml_getword(dbg_in);
-      Assert (pos >= 0);
-      Assert (pos < caml_code_size);
+      CAMLassert (pos >= 0);
+      CAMLassert (pos < caml_code_size);
       caml_set_instruction(caml_start_code + pos / sizeof(opcode_t), BREAK);
       break;
     case REQ_RESET_INSTR:
       pos = caml_getword(dbg_in);
-      Assert (pos >= 0);
-      Assert (pos < caml_code_size);
+      CAMLassert (pos >= 0);
+      CAMLassert (pos < caml_code_size);
       pos = pos / sizeof(opcode_t);
       caml_set_instruction(caml_start_code + pos, caml_saved_code[pos]);
       break;
@@ -411,7 +414,7 @@ void caml_debugger(enum event_kind event)
         caml_putch(dbg_out, 0);
         putval(dbg_out, Field(val, i));
       } else {
-        double d = Double_field(val, i);
+        double d = Double_flat_field(val, i);
         caml_putch(dbg_out, 1);
         caml_really_putblock(dbg_out, (char *) &d, 8);
       }

diff --git a/byterun/dynlink.c b/byterun/dynlink.c
index ed678df3a5e812bae372637f50d7ed95c13f62ab..7c339bf5158ed6344623cca8ea99d908b973f774 100644 (file)
--- a/byterun/dynlink.c
+++ b/byterun/dynlink.c
@@ -73,36 +73,43 @@ static c_primitive lookup_primitive(char * name)
 /* Parse the OCAML_STDLIB_DIR/ld.conf file and add the directories
    listed there to the search path */
 
-#define LD_CONF_NAME "ld.conf"
+#define LD_CONF_NAME _T("ld.conf")
 
-static char * parse_ld_conf(void)
+static char_os * parse_ld_conf(void)
 {
-  char * stdlib, * ldconfname, * config, * p, * q;
+  char_os * stdlib, * ldconfname, * wconfig, * p, * q;
+  char * config;
+#ifdef _WIN32
+  struct _stati64 st;
+#else
   struct stat st;
+#endif
   int ldconf, nread;
 
-  stdlib = caml_secure_getenv("OCAMLLIB");
-  if (stdlib == NULL) stdlib = caml_secure_getenv("CAMLLIB");
+  stdlib = caml_secure_getenv(_T("OCAMLLIB"));
+  if (stdlib == NULL) stdlib = caml_secure_getenv(_T("CAMLLIB"));
   if (stdlib == NULL) stdlib = OCAML_STDLIB_DIR;
-  ldconfname = caml_strconcat(3, stdlib, "/", LD_CONF_NAME);
-  if (stat(ldconfname, &st) == -1) {
+  ldconfname = caml_stat_strconcat_os(3, stdlib, _T("/"), LD_CONF_NAME);
+  if (stat_os(ldconfname, &st) == -1) {
     caml_stat_free(ldconfname);
     return NULL;
   }
-  ldconf = open(ldconfname, O_RDONLY, 0);
+  ldconf = open_os(ldconfname, O_RDONLY, 0);
   if (ldconf == -1)
     caml_fatal_error_arg("Fatal error: cannot read loader config file %s\n",
-                         ldconfname);
+                         caml_stat_strdup_of_os(ldconfname));
   config = caml_stat_alloc(st.st_size + 1);
   nread = read(ldconf, config, st.st_size);
   if (nread == -1)
     caml_fatal_error_arg
       ("Fatal error: error while reading loader config file %s\n",
-       ldconfname);
+       caml_stat_strdup_of_os(ldconfname));
   config[nread] = 0;
-  q = config;
-  for (p = config; *p != 0; p++) {
-    if (*p == '\n') {
+  wconfig = caml_stat_strdup_to_os(config);
+  caml_stat_free(config);
+  q = wconfig;
+  for (p = wconfig; *p != 0; p++) {
+    if (*p == _T('\n')) {
       *p = 0;
       caml_ext_table_add(&caml_shared_libs_path, q);
       q = p + 1;
@@ -111,24 +118,27 @@ static char * parse_ld_conf(void)
   if (q < p) caml_ext_table_add(&caml_shared_libs_path, q);
   close(ldconf);
   caml_stat_free(ldconfname);
-  return config;
+  return wconfig;
 }
 
 /* Open the given shared library and add it to shared_libs.
    Abort on error. */
-static void open_shared_lib(char * name)
+static void open_shared_lib(char_os * name)
 {
-  char * realname;
+  char_os * realname;
+  char * u8;
   void * handle;
 
   realname = caml_search_dll_in_path(&caml_shared_libs_path, name);
-  caml_gc_message(0x100, "Loading shared library %s\n",
-                  (uintnat) realname);
+  u8 = caml_stat_strdup_of_os(realname);
+  caml_gc_message(0x100, "Loading shared library %s\n", u8);
+  caml_stat_free(u8);
   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,
+    caml_fatal_error_arg2("Fatal error: cannot load shared library %s\n",
+                          caml_stat_strdup_of_os(name),
                           "Reason: %s\n", caml_dlerror());
   caml_ext_table_add(&shared_libs, handle);
   caml_stat_free(realname);
@@ -137,12 +147,13 @@ static void open_shared_lib(char * name)
 /* Build the table of primitives, given a search path and a list
    of shared libraries (both 0-separated in a char array).
    Abort the runtime system on error. */
-void caml_build_primitive_table(char * lib_path,
-                                char * libs,
+void caml_build_primitive_table(char_os * lib_path,
+                                char_os * libs,
                                 char * req_prims)
 {
-  char * tofree1, * tofree2;
-  char * p;
+  char_os * tofree1, * tofree2;
+  char_os * p;
+  char * q;
 
   /* Initialize the search path for dynamic libraries:
      - directories specified on the command line with the -I option
@@ -150,28 +161,28 @@ void caml_build_primitive_table(char * lib_path,
      - directories specified in the executable
      - directories specified in the file <stdlib>/ld.conf */
   tofree1 = caml_decompose_path(&caml_shared_libs_path,
-                                caml_secure_getenv("CAML_LD_LIBRARY_PATH"));
+                                caml_secure_getenv(_T("CAML_LD_LIBRARY_PATH")));
   if (lib_path != NULL)
-    for (p = lib_path; *p != 0; p += strlen(p) + 1)
+    for (p = lib_path; *p != 0; p += strlen_os(p) + 1)
       caml_ext_table_add(&caml_shared_libs_path, p);
   tofree2 = parse_ld_conf();
   /* Open the shared libraries */
   caml_ext_table_init(&shared_libs, 8);
   if (libs != NULL)
-    for (p = libs; *p != 0; p += strlen(p) + 1)
+    for (p = libs; *p != 0; p += strlen_os(p) + 1)
       open_shared_lib(p);
   /* Build the primitive table */
   caml_ext_table_init(&caml_prim_table, 0x180);
 #ifdef DEBUG
   caml_ext_table_init(&caml_prim_name_table, 0x180);
 #endif
-  for (p = req_prims; *p != 0; p += strlen(p) + 1) {
-    c_primitive prim = lookup_primitive(p);
+  for (q = req_prims; *q != 0; q += strlen(q) + 1) {
+    c_primitive prim = lookup_primitive(q);
     if (prim == NULL)
-          caml_fatal_error_arg("Fatal error: unknown C primitive `%s'\n", p);
+          caml_fatal_error_arg("Fatal error: unknown C primitive `%s'\n", q);
     caml_ext_table_add(&caml_prim_table, (void *) prim);
 #ifdef DEBUG
-    caml_ext_table_add(&caml_prim_name_table, strdup(p));
+    caml_ext_table_add(&caml_prim_name_table, caml_stat_strdup(q));
 #endif
   }
   /* Clean up */
@@ -194,11 +205,17 @@ void caml_build_primitive_table_builtin(void)
     caml_ext_table_add(&caml_prim_table, (void *) caml_builtin_cprim[i]);
 #ifdef DEBUG
     caml_ext_table_add(&caml_prim_name_table,
-                       strdup(caml_names_of_builtin_cprim[i]));
+                       caml_stat_strdup(caml_names_of_builtin_cprim[i]));
 #endif
   }
 }
 
+void caml_free_shared_libs(void)
+{
+  while (shared_libs.size > 0)
+    caml_dlclose(shared_libs.contents[--shared_libs.size]);
+}
+
 #endif /* NATIVE_CODE */
 
 /** dlopen interface for the bytecode linker **/
@@ -209,11 +226,11 @@ CAMLprim value caml_dynlink_open_lib(value mode, value filename)
 {
   void * handle;
   value result;
-  char * p;
+  char_os * p;
 
   caml_gc_message(0x100, "Opening shared library %s\n",
-                  (uintnat) String_val(filename));
-  p = caml_strdup(String_val(filename));
+                  String_val(filename));
+  p = caml_stat_strdup_to_os(String_val(filename));
   caml_enter_blocking_section();
   handle = caml_dlopen(p, Int_val(mode), 1);
   caml_leave_blocking_section();

diff --git a/byterun/extern.c b/byterun/extern.c
index 51240d0be9c61d1883252adc73ffd8df2cd86acb..adebc910b842e4f13b1ef0d33df31debd31fa175 100644 (file)
--- a/byterun/extern.c
+++ b/byterun/extern.c
@@ -103,7 +103,7 @@ static void free_extern_output(void);
 static void extern_free_stack(void)
 {
   if (extern_stack != extern_stack_init) {
-    free(extern_stack);
+    caml_stat_free(extern_stack);
     /* Reinitialize the globals for next time around */
     extern_stack = extern_stack_init;
     extern_stack_limit = extern_stack + EXTERN_STACK_INIT_SIZE;
@@ -118,13 +118,13 @@ static struct extern_item * extern_resize_stack(struct extern_item * sp)
 
   if (newsize >= EXTERN_STACK_MAX_SIZE) extern_stack_overflow();
   if (extern_stack == extern_stack_init) {
-    newstack = malloc(sizeof(struct extern_item) * newsize);
+    newstack = caml_stat_alloc_noexc(sizeof(struct extern_item) * newsize);
     if (newstack == NULL) extern_stack_overflow();
     memcpy(newstack, extern_stack_init,
            sizeof(struct extern_item) * EXTERN_STACK_INIT_SIZE);
   } else {
-    newstack =
-      realloc(extern_stack, sizeof(struct extern_item) * newsize);
+    newstack = caml_stat_resize_noexc(extern_stack,
+                                      sizeof(struct extern_item) * newsize);
     if (newstack == NULL) extern_stack_overflow();
   }
   extern_stack = newstack;
@@ -161,7 +161,7 @@ static void extern_replay_trail(void)
     }
     if (blk == &extern_trail_first) break;
     prevblk = blk->previous;
-    free(blk);
+    caml_stat_free(blk);
     blk = prevblk;
     lim = &(blk->entries[ENTRIES_PER_TRAIL_BLOCK]);
   }
@@ -179,7 +179,7 @@ static void extern_record_location(value obj)
 
   if (extern_flags & NO_SHARING) return;
   if (extern_trail_cur == extern_trail_limit) {
-    struct trail_block * new_block = malloc(sizeof(struct trail_block));
+    struct trail_block * new_block = caml_stat_alloc_noexc(sizeof(struct trail_block));
     if (new_block == NULL) extern_out_of_memory();
     new_block->previous = extern_trail_block;
     extern_trail_block = new_block;
@@ -211,7 +211,7 @@ static struct output_block * extern_output_first, * extern_output_block;
 static void init_extern_output(void)
 {
   extern_userprovided_output = NULL;
-  extern_output_first = malloc(sizeof(struct output_block));
+  extern_output_first = caml_stat_alloc_noexc(sizeof(struct output_block));
   if (extern_output_first == NULL) caml_raise_out_of_memory();
   extern_output_block = extern_output_first;
   extern_output_block->next = NULL;
@@ -233,7 +233,7 @@ static void free_extern_output(void)
   if (extern_userprovided_output != NULL) return;
   for (blk = extern_output_first; blk != NULL; blk = nextblk) {
     nextblk = blk->next;
-    free(blk);
+    caml_stat_free(blk);
   }
   extern_output_first = NULL;
   extern_free_stack();
@@ -252,7 +252,7 @@ static void grow_extern_output(intnat required)
     extra = 0;
   else
     extra = required;
-  blk = malloc(sizeof(struct output_block) + extra);
+  blk = caml_stat_alloc_noexc(sizeof(struct output_block) + extra);
   if (blk == NULL) extern_out_of_memory();
   extern_output_block->next = blk;
   extern_output_block = blk;
@@ -300,7 +300,7 @@ static void extern_failwith(char *msg)
 
 static void extern_stack_overflow(void)
 {
-  caml_gc_message (0x04, "Stack overflow in marshaling value\n", 0);
+  caml_gc_message (0x04, "Stack overflow in marshaling value\n");
   extern_replay_trail();
   free_extern_output();
   caml_raise_out_of_memory();
@@ -332,17 +332,17 @@ static inline void write(int c)
   *extern_ptr++ = c;
 }
 
-static void writeblock(char * data, intnat len)
+static void writeblock(const char * data, intnat len)
 {
   if (extern_ptr + len > extern_limit) grow_extern_output(len);
   memcpy(extern_ptr, data, len);
   extern_ptr += len;
 }
 
-static inline void writeblock_float8(double * data, intnat ndoubles)
+static inline void writeblock_float8(const double * data, intnat ndoubles)
 {
 #if ARCH_FLOAT_ENDIANNESS == 0x01234567 || ARCH_FLOAT_ENDIANNESS == 0x76543210
-  writeblock((char *) data, ndoubles * 8);
+  writeblock((const char *) data, ndoubles * 8);
 #else
   caml_serialize_block_float_8(data, ndoubles);
 #endif
@@ -421,7 +421,11 @@ static void extern_rec(value v)
       value f = Forward_val (v);
       if (Is_block (f)
           && (!Is_in_value_area(f) || Tag_val (f) == Forward_tag
-              || Tag_val (f) == Lazy_tag || Tag_val (f) == Double_tag)){
+              || Tag_val (f) == Lazy_tag
+#ifdef FLAT_FLOAT_ARRAY
+              || Tag_val (f) == Double_tag
+#endif
+              )){
         /* Do not short-circuit the pointer. */
       }else{
         v = f;
@@ -588,7 +592,7 @@ static void extern_rec(value v)
     if ((extern_flags & CLOSURES) == 0)
       extern_invalid_argument("output_value: functional value");
     writecode32(CODE_CODEPOINTER, (char *) v - cf->code_start);
-    writeblock((char *) cf->digest, 16);
+    writeblock((const char *)cf->digest, 16);
   } else {
     extern_invalid_argument("output_value: abstract value (outside heap)");
   }
@@ -674,7 +678,7 @@ void caml_output_val(struct channel *chan, value v, value flags)
   while (blk != NULL) {
     caml_really_putblock(chan, blk->data, blk->end - blk->data);
     nextblk = blk->next;
-    free(blk);
+    caml_stat_free(blk);
     blk = nextblk;
   }
 }
@@ -712,7 +716,7 @@ CAMLprim value caml_output_value_to_string(value v, value flags)
     memcpy(&Byte(res, ofs), blk->data, n);
     ofs += n;
     nextblk = blk->next;
-    free(blk);
+    caml_stat_free(blk);
     blk = nextblk;
   }
   return res;
@@ -762,7 +766,7 @@ CAMLexport void caml_output_value_to_malloc(value v, value flags,
 
   init_extern_output();
   data_len = extern_value(v, flags, header, &header_len);
-  res = malloc(header_len + data_len);
+  res = caml_stat_alloc_noexc(header_len + data_len);
   if (res == NULL) extern_out_of_memory();
   *buf = res;
   *len = header_len + data_len;

diff --git a/byterun/fail.c b/byterun/fail.c
index 6396aeb6096dc9ada8e806cea979a9b6b1f24eb0..6b4dee5fbb2e8daaaebc33ecee1df34e9658c079 100644 (file)
--- a/byterun/fail.c
+++ b/byterun/fail.c
@@ -65,7 +65,7 @@ CAMLexport void caml_raise_with_args(value tag, int nargs, value args[])
   value bucket;
   int i;
 
-  Assert(1 + nargs <= Max_young_wosize);
+  CAMLassert(1 + nargs <= Max_young_wosize);
   bucket = caml_alloc_small (1 + nargs, 0);
   Field(bucket, 0) = tag;
   for (i = 0; i < nargs; i++) Field(bucket, 1 + i) = args[i];

diff --git a/byterun/finalise.c b/byterun/finalise.c
index d5f1d4efa77fa40859acd07965fe050c29348146..9a41ff784ea10759ecea7cce7e23f2cd6c148961 100644 (file)
--- a/byterun/finalise.c
+++ b/byterun/finalise.c
@@ -72,8 +72,8 @@ 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)
-                                 + size * sizeof (struct final));
+  struct to_do *result = caml_stat_alloc_noexc (sizeof (struct to_do) +
+                                                size * sizeof (struct final));
   if (result == NULL) caml_fatal_error ("out of memory");
   result->next = NULL;
   result->size = size;
@@ -81,7 +81,7 @@ static void alloc_to_do (int size)
     to_do_hd = result;
     to_do_tl = result;
   }else{
-    Assert (to_do_tl->next == NULL);
+    CAMLassert (to_do_tl->next == NULL);
     to_do_tl->next = result;
     to_do_tl = result;
   }
@@ -95,10 +95,10 @@ static void generic_final_update (struct finalisable * final, int darken_value)
   uintnat i, j, k;
   uintnat todo_count = 0;
 
-  Assert (final->old <= final->young);
+  CAMLassert (final->old <= final->young);
   for (i = 0; i < final->old; i++){
-    Assert (Is_block (final->table[i].val));
-    Assert (Is_in_heap (final->table[i].val));
+    CAMLassert (Is_block (final->table[i].val));
+    CAMLassert (Is_in_heap (final->table[i].val));
     if (Is_white_val (final->table[i].val)){
       ++ todo_count;
     }
@@ -117,9 +117,9 @@ static void generic_final_update (struct finalisable * final, int darken_value)
     alloc_to_do (todo_count);
     j = k = 0;
     for (i = 0; i < final->old; i++){
-      Assert (Is_block (final->table[i].val));
-      Assert (Is_in_heap (final->table[i].val));
-      Assert (Tag_val (final->table[i].val) != Forward_tag);
+      CAMLassert (Is_block (final->table[i].val));
+      CAMLassert (Is_in_heap (final->table[i].val));
+      CAMLassert (Tag_val (final->table[i].val) != Forward_tag);
       if(Is_white_val (final->table[i].val)){
         /** dead */
         to_do_tl->item[k] = final->table[i];
@@ -178,16 +178,16 @@ void caml_final_do_calls (void)
   if (running_finalisation_function) return;
   if (to_do_hd != NULL){
     if (caml_finalise_begin_hook != NULL) (*caml_finalise_begin_hook) ();
-    caml_gc_message (0x80, "Calling finalisation functions.\n", 0);
+    caml_gc_message (0x80, "Calling finalisation functions.\n");
     while (1){
       while (to_do_hd != NULL && to_do_hd->size == 0){
         struct to_do *next_hd = to_do_hd->next;
-        free (to_do_hd);
+        caml_stat_free (to_do_hd);
         to_do_hd = next_hd;
         if (to_do_hd == NULL) to_do_tl = NULL;
       }
       if (to_do_hd == NULL) break;
-      Assert (to_do_hd->size > 0);
+      CAMLassert (to_do_hd->size > 0);
       -- to_do_hd->size;
       f = to_do_hd->item[to_do_hd->size];
       running_finalisation_function = 1;
@@ -205,7 +205,7 @@ void caml_final_do_calls (void)
       running_finalisation_function = 0;
       if (Is_exception_result (res)) caml_raise (Extract_exception (res));
     }
-    caml_gc_message (0x80, "Done calling finalisation functions.\n", 0);
+    caml_gc_message (0x80, "Done calling finalisation functions.\n");
     if (caml_finalise_end_hook != NULL) (*caml_finalise_end_hook) ();
   }
 }
@@ -223,12 +223,12 @@ void caml_final_do_roots (scanning_action f)
   uintnat i;
   struct to_do *todo;
 
-  Assert (finalisable_first.old <= finalisable_first.young);
+  CAMLassert (finalisable_first.old <= finalisable_first.young);
   for (i = 0; i < finalisable_first.young; i++){
     Call_action (f, finalisable_first.table[i].fun);
   };
 
-  Assert (finalisable_last.old <= finalisable_last.young);
+  CAMLassert (finalisable_last.old <= finalisable_last.young);
   for (i = 0; i < finalisable_last.young; i++){
     Call_action (f, finalisable_last.table[i].fun);
   };
@@ -241,7 +241,7 @@ void caml_final_do_roots (scanning_action f)
   }
 }
 
-/* Call invert_root on the values of the finalisable set. This is called
+/* Call caml_invert_root on the values of the finalisable set. This is called
    directly by the compactor.
 */
 void caml_final_invert_finalisable_values ()
@@ -250,13 +250,13 @@ void caml_final_invert_finalisable_values ()
 
   CAMLassert (finalisable_first.old <= finalisable_first.young);
   for (i = 0; i < finalisable_first.young; i++){
-    invert_root(finalisable_first.table[i].val,
+    caml_invert_root(finalisable_first.table[i].val,
                 &finalisable_first.table[i].val);
   };
 
   CAMLassert (finalisable_last.old <= finalisable_last.young);
   for (i = 0; i < finalisable_last.young; i++){
-    invert_root(finalisable_last.table[i].val,
+    caml_invert_root(finalisable_last.table[i].val,
                 &finalisable_last.table[i].val);
   };
 }
@@ -268,7 +268,7 @@ void caml_final_oldify_young_roots ()
 {
   uintnat i;
 
-  Assert (finalisable_first.old <= finalisable_first.young);
+  CAMLassert (finalisable_first.old <= finalisable_first.young);
   for (i = finalisable_first.old; i < finalisable_first.young; i++){
     caml_oldify_one(finalisable_first.table[i].fun,
                     &finalisable_first.table[i].fun);
@@ -276,7 +276,7 @@ void caml_final_oldify_young_roots ()
                     &finalisable_first.table[i].val);
   }
 
-  Assert (finalisable_last.old <= finalisable_last.young);
+  CAMLassert (finalisable_last.old <= finalisable_last.young);
   for (i = finalisable_last.old; i < finalisable_last.young; i++){
     caml_oldify_one(finalisable_last.table[i].fun,
                     &finalisable_last.table[i].fun);
@@ -289,10 +289,10 @@ static void generic_final_minor_update (struct finalisable * final)
   uintnat i, j, k;
   uintnat todo_count = 0;
 
-  Assert (final->old <= final->young);
+  CAMLassert (final->old <= final->young);
   for (i = final->old; i < final->young; i++){
-    Assert (Is_block (final->table[i].val));
-    Assert (Is_in_heap_or_young (final->table[i].val));
+    CAMLassert (Is_block (final->table[i].val));
+    CAMLassert (Is_in_heap_or_young (final->table[i].val));
     if (Is_young(final->table[i].val) && Hd_val(final->table[i].val) != 0){
       ++ todo_count;
     }
@@ -311,9 +311,9 @@ static void generic_final_minor_update (struct finalisable * final)
     k = 0;
     j = final->old;
     for (i = final->old; i < final->young; i++){
-      Assert (Is_block (final->table[i].val));
-      Assert (Is_in_heap_or_young (final->table[i].val));
-      Assert (Tag_val (final->table[i].val) != Forward_tag);
+      CAMLassert (Is_block (final->table[i].val));
+      CAMLassert (Is_in_heap_or_young (final->table[i].val));
+      CAMLassert (Tag_val (final->table[i].val) != Forward_tag);
       if(Is_young(final->table[j].val) && Hd_val(final->table[i].val) != 0){
         /** dead */
         to_do_tl->item[k] = final->table[i];
@@ -334,8 +334,8 @@ static void generic_final_minor_update (struct finalisable * final)
 
   /** update the minor value to the copied major value */
   for (i = final->old; i < final->young; i++){
-    Assert (Is_block (final->table[i].val));
-    Assert (Is_in_heap_or_young (final->table[i].val));
+    CAMLassert (Is_block (final->table[i].val));
+    CAMLassert (Is_in_heap_or_young (final->table[i].val));
     if (Is_young(final->table[i].val)) {
       CAMLassert (Hd_val(final->table[i].val) == 0);
       final->table[i].val = Field(final->table[i].val,0);
@@ -343,7 +343,7 @@ static void generic_final_minor_update (struct finalisable * final)
   }
 
   /** check invariant */
-  Assert (final->old <= final->young);
+  CAMLassert (final->old <= final->young);
   for (i = 0; i < final->young; i++){
     CAMLassert( Is_in_heap(final->table[i].val) );
   };
@@ -375,18 +375,20 @@ static void generic_final_register (struct finalisable *final, value f, value v)
   if (!Is_block (v)
       || !Is_in_heap_or_young(v)
       || Tag_val (v) == Lazy_tag
+#ifdef FLAT_FLOAT_ARRAY
       || Tag_val (v) == Double_tag
+#endif
       || Tag_val (v) == Forward_tag) {
     caml_invalid_argument ("Gc.finalise");
   }
-  Assert (final->old <= final->young);
+  CAMLassert (final->old <= final->young);
 
   if (final->young >= final->size){
     if (final->table == NULL){
       uintnat new_size = 30;
       final->table = caml_stat_alloc (new_size * sizeof (struct final));
-      Assert (final->old == 0);
-      Assert (final->young == 0);
+      CAMLassert (final->old == 0);
+      CAMLassert (final->young == 0);
       final->size = new_size;
     }else{
       uintnat new_size = final->size * 2;
@@ -395,7 +397,7 @@ static void generic_final_register (struct finalisable *final, value f, value v)
       final->size = new_size;
     }
   }
-  Assert (final->young < final->size);
+  CAMLassert (final->young < final->size);
   final->table[final->young].fun = f;
   if (Tag_val (v) == Infix_tag){
     final->table[final->young].offset = Infix_offset_val (v);

diff --git a/byterun/fix_code.c b/byterun/fix_code.c
index 09581cfae8e3d4ab33f02aad1eb444a94715c896..68f97c993e4d9baf69f9a5cc60cc53a9320832e9 100644 (file)
--- a/byterun/fix_code.c
+++ b/byterun/fix_code.c
@@ -163,7 +163,7 @@ void caml_thread_code (code_t code, asize_t len)
       p += l[instr];
     }
   }
-  Assert(p == code + len);
+  CAMLassert(p == code + len);
 }
 
 #else

diff --git a/byterun/floats.c b/byterun/floats.c
index 8792b2522c6939f7f6322783dff4b83f16296398..fe313c59f0343581be555f56d8b9bd897a8f4ca3 100644 (file)
--- a/byterun/floats.c
+++ b/byterun/floats.c
@@ -48,7 +48,7 @@ CAMLexport double caml_Double_val(value val)
 {
   union { value v[2]; double d; } buffer;
 
-  Assert(sizeof(double) == 2 * sizeof(value));
+  CAMLassert(sizeof(double) == 2 * sizeof(value));
   buffer.v[0] = Field(val, 0);
   buffer.v[1] = Field(val, 1);
   return buffer.d;
@@ -58,7 +58,7 @@ CAMLexport void caml_Store_double_val(value val, double dbl)
 {
   union { value v[2]; double d; } buffer;
 
-  Assert(sizeof(double) == 2 * sizeof(value));
+  CAMLassert(sizeof(double) == 2 * sizeof(value));
   buffer.d = dbl;
   Field(val, 0) = buffer.v[0];
   Field(val, 1) = buffer.v[1];
@@ -79,6 +79,18 @@ CAMLexport value caml_copy_double(double d)
   return res;
 }
 
+#ifndef FLAT_FLOAT_ARRAY
+CAMLexport void caml_Store_double_array_field(value val, mlsize_t i, double dbl)
+{
+  CAMLparam1 (val);
+  value d = caml_copy_double (dbl);
+
+  CAMLassert (Tag_val (val) != Double_array_tag);
+  caml_modify (&Field(val, i), d);
+  CAMLreturn0;
+}
+#endif /* ! FLAT_FLOAT_ARRAY */
+
 CAMLprim value caml_format_float(value fmt, value arg)
 {
   value res;
@@ -261,7 +273,8 @@ static int caml_float_of_hex(const char * s, double * res)
 CAMLprim value caml_float_of_string(value vs)
 {
   char parse_buffer[64];
-  char * buf, * src, * dst, * end;
+  char * buf, * dst, * end;
+  const char *src;
   mlsize_t len;
   int sign;
   double d;

diff --git a/byterun/freelist.c b/byterun/freelist.c
index 3633d77b9e23fbde9e7275a7eab2c0ee271e3942..26c1d9c44f2b1021ff8a47cf54851098f2d47d83 100644 (file)
--- a/byterun/freelist.c
+++ b/byterun/freelist.c
@@ -82,25 +82,25 @@ static void fl_check (void)
   cur = Next (prev);
   while (cur != Val_NULL){
     size_found += Whsize_bp (cur);
-    Assert (Is_in_heap (cur));
+    CAMLassert (Is_in_heap (cur));
     if (cur == fl_prev) prev_found = 1;
     if (policy == Policy_first_fit && Wosize_bp (cur) > sz){
       sz = Wosize_bp (cur);
       if (flp_found < flp_size){
-        Assert (Next (flp[flp_found]) == cur);
+        CAMLassert (Next (flp[flp_found]) == cur);
         ++ flp_found;
       }else{
-        Assert (beyond == Val_NULL || cur >= Next (beyond));
+        CAMLassert (beyond == Val_NULL || cur >= Next (beyond));
       }
     }
     if (cur == caml_fl_merge) merge_found = 1;
     prev = cur;
     cur = Next (prev);
   }
-  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_wsz);
+  if (policy == Policy_next_fit) CAMLassert (prev_found || fl_prev == Fl_head);
+  if (policy == Policy_first_fit) CAMLassert (flp_found == flp_size);
+  CAMLassert (merge_found || caml_fl_merge == Fl_head);
+  CAMLassert (size_found == caml_fl_cur_wsz);
 }
 
 #endif
@@ -123,11 +123,11 @@ 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);
+  CAMLassert (Whsize_hd (h) >= wh_sz);
   if (Wosize_hd (h) < wh_sz + 1){                        /* Cases 0 and 1. */
     caml_fl_cur_wsz -= Whsize_hd (h);
     Next (prev) = Next (cur);
-                  Assert (Is_in_heap (Next (prev)) || Next (prev) == Val_NULL);
+    CAMLassert (Is_in_heap (Next (prev)) || Next (prev) == Val_NULL);
     if (caml_fl_merge == cur) caml_fl_merge = prev;
 #ifdef DEBUG
     fl_last = Val_NULL;
@@ -191,8 +191,8 @@ header_t *caml_fl_allocate (mlsize_t wo_sz)
   header_t *result;
   int i;
   mlsize_t sz, prevsz;
-                                  Assert (sizeof (char *) == sizeof (value));
-                                  Assert (wo_sz >= 1);
+  CAMLassert (sizeof (char *) == sizeof (value));
+  CAMLassert (wo_sz >= 1);
 #ifdef CAML_INSTR
   if (wo_sz < 10){
     ++instr_size[wo_sz];
@@ -205,11 +205,12 @@ header_t *caml_fl_allocate (mlsize_t wo_sz)
 
   switch (policy){
   case Policy_next_fit:
-                                  Assert (fl_prev != Val_NULL);
+    CAMLassert (fl_prev != Val_NULL);
     /* Search from [fl_prev] to the end of the list. */
     prev = fl_prev;
     cur = Next (prev);
-    while (cur != Val_NULL){                         Assert (Is_in_heap (cur));
+    while (cur != Val_NULL){
+      CAMLassert (Is_in_heap (cur));
       if (Wosize_bp (cur) >= wo_sz){
         return allocate_block (Whsize_wosize (wo_sz), 0, prev, cur);
       }
@@ -299,10 +300,10 @@ header_t *caml_fl_allocate (mlsize_t wo_sz)
       prev = flp[flp_size - 1];
     }
     prevsz = Wosize_bp (Next (flp[FLP_MAX-1]));
-    Assert (prevsz < wo_sz);
+    CAMLassert (prevsz < wo_sz);
     cur = Next (prev);
     while (cur != Val_NULL){
-      Assert (Is_in_heap (cur));
+      CAMLassert (Is_in_heap (cur));
       sz = Wosize_bp (cur);
       if (sz < prevsz){
         beyond = cur;
@@ -317,7 +318,7 @@ header_t *caml_fl_allocate (mlsize_t wo_sz)
 
   update_flp: /* (i, sz) */
     /* The block at [i] was removed or reduced.  Update the table. */
-    Assert (0 <= i && i < flp_size + 1);
+    CAMLassert (0 <= i && i < flp_size + 1);
     if (i < flp_size){
       if (i > 0){
         prevsz = Wosize_bp (Next (flp[i-1]));
@@ -344,7 +345,7 @@ header_t *caml_fl_allocate (mlsize_t wo_sz)
             buf[j++] = prev;
             prevsz = sz;
             if (sz >= oldsz){
-              Assert (sz == oldsz);
+              CAMLassert (sz == oldsz);
               break;
             }
           }
@@ -380,7 +381,7 @@ header_t *caml_fl_allocate (mlsize_t wo_sz)
   break;
 
   default:
-    Assert (0);   /* unknown policy */
+    CAMLassert (0);   /* unknown policy */
     break;
   }
   return NULL;  /* NOT REACHED */
@@ -434,7 +435,7 @@ void caml_fl_reset (void)
     truncate_flp (Fl_head);
     break;
   default:
-    Assert (0);
+    CAMLassert (0);
     break;
   }
   caml_fl_cur_wsz = 0;
@@ -459,8 +460,8 @@ header_t *caml_fl_merge_block (value bp)
   cur = Next (prev);
   /* 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 == Val_NULL);
+  CAMLassert (prev < bp || prev == Fl_head);
+  CAMLassert (cur > bp || cur == Val_NULL);
 
   if (policy == Policy_first_fit) truncate_flp (prev);
 
@@ -505,7 +506,7 @@ header_t *caml_fl_merge_block (value bp)
 #ifdef DEBUG
     Hd_val (bp) = Debug_free_major;
 #endif
-    Assert (caml_fl_merge == prev);
+    CAMLassert (caml_fl_merge == prev);
   }else if (Wosize_hd (hd) != 0){
     Hd_val (bp) = Bluehd_hd (hd);
     Next (bp) = cur;
@@ -533,8 +534,8 @@ header_t *caml_fl_merge_block (value bp)
 */
 void caml_fl_add_blocks (value bp)
 {
-                                                   Assert (fl_last != Val_NULL);
-                                            Assert (Next (fl_last) == Val_NULL);
+  CAMLassert (fl_last != Val_NULL);
+  CAMLassert (Next (fl_last) == Val_NULL);
   caml_fl_cur_wsz += Whsize_bp (bp);
 
   if (bp > fl_last){
@@ -551,12 +552,13 @@ void caml_fl_add_blocks (value bp)
     prev = Fl_head;
     cur = Next (prev);
     while (cur != Val_NULL && cur < bp){
-      Assert (prev < bp || prev == Fl_head);
+      CAMLassert (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 == Val_NULL);
+    }
+    CAMLassert (prev < bp || prev == Fl_head);
+    CAMLassert (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],

diff --git a/byterun/gc_ctrl.c b/byterun/gc_ctrl.c
index bfc170a3b18efb1d6f3ce88cda42b96332593f64..1cec4a2540f5d39686cd92dead36c2ad52e42ee7 100644 (file)
--- a/byterun/gc_ctrl.c
+++ b/byterun/gc_ctrl.c
@@ -64,25 +64,25 @@ extern uintnat caml_allocation_policy;    /*        see freelist.c */
 /* Check that [v]'s header looks good.  [v] must be a block in the heap. */
 static void check_head (value v)
 {
-  Assert (Is_block (v));
-  Assert (Is_in_heap (v));
+  CAMLassert (Is_block (v));
+  CAMLassert (Is_in_heap (v));
 
-  Assert (Wosize_val (v) != 0);
-  Assert (Color_hd (Hd_val (v)) != Caml_blue);
-  Assert (Is_in_heap (v));
+  CAMLassert (Wosize_val (v) != 0);
+  CAMLassert (Color_hd (Hd_val (v)) != Caml_blue);
+  CAMLassert (Is_in_heap (v));
   if (Tag_val (v) == Infix_tag){
     int offset = Wsize_bsize (Infix_offset_val (v));
     value trueval = Val_op (&Field (v, -offset));
-    Assert (Tag_val (trueval) == Closure_tag);
-    Assert (Wosize_val (trueval) > offset);
-    Assert (Is_in_heap (&Field (trueval, Wosize_val (trueval) - 1)));
+    CAMLassert (Tag_val (trueval) == Closure_tag);
+    CAMLassert (Wosize_val (trueval) > offset);
+    CAMLassert (Is_in_heap (&Field (trueval, Wosize_val (trueval) - 1)));
   }else{
-    Assert (Is_in_heap (&Field (v, Wosize_val (v) - 1)));
+    CAMLassert (Is_in_heap (&Field (v, Wosize_val (v) - 1)));
   }
   if (Tag_val (v) ==  Double_tag){
-    Assert (Wosize_val (v) == Double_wosize);
+    CAMLassert (Wosize_val (v) == Double_wosize);
   }else if (Tag_val (v) == Double_array_tag){
-    Assert (Wosize_val (v) % Double_wosize == 0);
+    CAMLassert (Wosize_val (v) % Double_wosize == 0);
   }
 }
 
@@ -98,26 +98,26 @@ static void check_block (header_t *hp)
   case String_tag:
     break;
   case Double_tag:
-    Assert (Wosize_val (v) == Double_wosize);
+    CAMLassert (Wosize_val (v) == Double_wosize);
     break;
   case Double_array_tag:
-    Assert (Wosize_val (v) % Double_wosize == 0);
+    CAMLassert (Wosize_val (v) % Double_wosize == 0);
     break;
   case Custom_tag:
-    Assert (!Is_in_heap (Custom_ops_val (v)));
+    CAMLassert (!Is_in_heap (Custom_ops_val (v)));
     break;
 
   case Infix_tag:
-    Assert (0);
+    CAMLassert (0);
     break;
 
   default:
-    Assert (Tag_hp (hp) < No_scan_tag);
+    CAMLassert (Tag_hp (hp) < No_scan_tag);
     for (i = 0; i < Wosize_hp (hp); i++){
       f = Field (v, i);
       if (Is_block (f) && Is_in_heap (f)){
         check_head (f);
-        Assert (Color_val (f) != Caml_blue);
+        CAMLassert (Color_val (f) != Caml_blue);
       }
     }
   }
@@ -143,7 +143,7 @@ static value heap_stats (int returnstats)
   header_t cur_hd;
 
 #ifdef DEBUG
-  caml_gc_message (-1, "### OCaml runtime: heap check ###\n", 0);
+  caml_gc_message (-1, "### OCaml runtime: heap check ###\n");
 #endif
 
   while (chunk != NULL){
@@ -155,14 +155,14 @@ static value heap_stats (int returnstats)
     cur_hp = (header_t *) chunk;
     while (cur_hp < (header_t *) chunk_end){
       cur_hd = Hd_hp (cur_hp);
-      Assert (Next (cur_hp) <= (header_t *) chunk_end);
+      CAMLassert (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 == (header_t *) caml_gc_sweep_hp);
+          CAMLassert (prev_hp == NULL
+                      || Color_hp (prev_hp) != Caml_blue
+                      || cur_hp == (header_t *) caml_gc_sweep_hp);
         }else{
           if (caml_gc_phase == Phase_sweep
               && cur_hp >= (header_t *) caml_gc_sweep_hp){
@@ -181,7 +181,7 @@ static value heap_stats (int returnstats)
         }
         break;
       case Caml_gray: case Caml_black:
-        Assert (Wosize_hd (cur_hd) > 0);
+        CAMLassert (Wosize_hd (cur_hd) > 0);
         ++ live_blocks;
         live_words += Whsize_hd (cur_hd);
 #ifdef DEBUG
@@ -189,21 +189,23 @@ static value heap_stats (int returnstats)
 #endif
         break;
       case Caml_blue:
-        Assert (Wosize_hd (cur_hd) > 0);
+        CAMLassert (Wosize_hd (cur_hd) > 0);
         ++ free_blocks;
         free_words += Whsize_hd (cur_hd);
         if (Whsize_hd (cur_hd) > largest_free){
           largest_free = Whsize_hd (cur_hd);
         }
         /* not true any more with big heap chunks
-        Assert (prev_hp == NULL
-                || (Color_hp (prev_hp) != Caml_blue && Wosize_hp (prev_hp) > 0)
-                || cur_hp == caml_gc_sweep_hp);
-        Assert (Next (cur_hp) == chunk_end
-                || (Color_hp (Next (cur_hp)) != Caml_blue
-                    && Wosize_hp (Next (cur_hp)) > 0)
-                || (Whsize_hd (cur_hd) + Wosize_hp (Next (cur_hp)) > Max_wosize)
-                || Next (cur_hp) == caml_gc_sweep_hp);
+        CAMLassert (prev_hp == NULL
+                    || (Color_hp (prev_hp) != Caml_blue
+                        && Wosize_hp (prev_hp) > 0)
+                    || cur_hp == caml_gc_sweep_hp);
+        CAMLassert (Next (cur_hp) == chunk_end
+                    || (Color_hp (Next (cur_hp)) != Caml_blue 
+                       && Wosize_hp (Next (cur_hp)) > 0)
+                    || (Whsize_hd (cur_hd) + Wosize_hp (Next (cur_hp))
+                       > Max_wosize)
+                    || Next (cur_hp) == caml_gc_sweep_hp);
         */
         break;
       }
@@ -211,7 +213,8 @@ static value heap_stats (int returnstats)
       prev_hp = cur_hp;
 #endif
       cur_hp = Next (cur_hp);
-    }                             Assert (cur_hp == (header_t *) chunk_end);
+    }
+    CAMLassert (cur_hp == (header_t *) chunk_end);
     chunk = Chunk_next (chunk);
   }
 
@@ -219,8 +222,8 @@ static value heap_stats (int returnstats)
   caml_final_invariant_check();
 #endif
 
-  Assert (heap_chunks == caml_stat_heap_chunks);
-  Assert (live_words + free_words + fragments == caml_stat_heap_wsz);
+  CAMLassert (heap_chunks == caml_stat_heap_chunks);
+  CAMLassert (live_words + free_words + fragments == caml_stat_heap_wsz);
 
   if (returnstats){
     CAMLlocal1 (res);
@@ -270,7 +273,7 @@ CAMLprim value caml_gc_stat(value v)
 {
   value result;
   CAML_INSTR_SETUP (tmr, "");
-  Assert (v == Val_unit);
+  CAMLassert (v == Val_unit);
   result = heap_stats (1);
   CAML_INSTR_TIME (tmr, "explicit/gc_stat");
   return result;
@@ -412,31 +415,35 @@ CAMLprim value caml_gc_set(value v)
   newpf = norm_pfree (Long_val (Field (v, 2)));
   if (newpf != caml_percent_free){
     caml_percent_free = newpf;
-    caml_gc_message (0x20, "New space overhead: %d%%\n", caml_percent_free);
+    caml_gc_message (0x20, "New space overhead: %"
+                     ARCH_INTNAT_PRINTF_FORMAT "u%%\n", caml_percent_free);
   }
 
   newpm = norm_pmax (Long_val (Field (v, 4)));
   if (newpm != caml_percent_max){
     caml_percent_max = newpm;
-    caml_gc_message (0x20, "New max overhead: %d%%\n", caml_percent_max);
+    caml_gc_message (0x20, "New max overhead: %"
+                     ARCH_INTNAT_PRINTF_FORMAT "u%%\n", caml_percent_max);
   }
 
   newheapincr = Long_val (Field (v, 1));
   if (newheapincr != caml_major_heap_increment){
     caml_major_heap_increment = newheapincr;
     if (newheapincr > 1000){
-      caml_gc_message (0x20, "New heap increment size: %luk words\n",
+      caml_gc_message (0x20, "New heap increment size: %"
+                       ARCH_INTNAT_PRINTF_FORMAT "uk words\n",
                        caml_major_heap_increment/1024);
     }else{
-      caml_gc_message (0x20, "New heap increment size: %lu%%\n",
+      caml_gc_message (0x20, "New heap increment size: %"
+                       ARCH_INTNAT_PRINTF_FORMAT "u%%\n",
                        caml_major_heap_increment);
     }
   }
   oldpolicy = caml_allocation_policy;
   caml_set_allocation_policy (Long_val (Field (v, 6)));
   if (oldpolicy != caml_allocation_policy){
-    caml_gc_message (0x20, "New allocation policy: %d\n",
-                     caml_allocation_policy);
+    caml_gc_message (0x20, "New allocation policy: %"
+                     ARCH_INTNAT_PRINTF_FORMAT "u\n", caml_allocation_policy);
   }
 
   /* This field was added in 4.03.0. */
@@ -453,8 +460,8 @@ CAMLprim value caml_gc_set(value v)
        (thus invalidating [v]) and it can raise [Out_of_memory]. */
   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_gc_message (0x20, "New minor heap size: %"
+                     ARCH_SIZET_PRINTF_FORMAT "uk words\n", newminwsz / 1024);
     caml_set_minor_heap_size (Bsize_wsize (newminwsz));
   }
   CAML_INSTR_TIME (tmr, "explicit/gc_set");
@@ -464,7 +471,7 @@ CAMLprim value caml_gc_set(value v)
 CAMLprim value caml_gc_minor(value v)
 {
   CAML_INSTR_SETUP (tmr, "");
-  Assert (v == Val_unit);
+  CAMLassert (v == Val_unit);
   caml_request_minor_gc ();
   caml_gc_dispatch ();
   CAML_INSTR_TIME (tmr, "explicit/gc_minor");
@@ -481,7 +488,7 @@ static void test_and_compact (void)
                           ARCH_INTNAT_PRINTF_FORMAT "u%%\n",
                    (uintnat) fp);
   if (fp >= caml_percent_max){
-    caml_gc_message (0x200, "Automatic compaction triggered.\n", 0);
+    caml_gc_message (0x200, "Automatic compaction triggered.\n");
     caml_compact_heap ();
   }
 }
@@ -489,8 +496,8 @@ static void test_and_compact (void)
 CAMLprim value caml_gc_major(value v)
 {
   CAML_INSTR_SETUP (tmr, "");
-  Assert (v == Val_unit);
-  caml_gc_message (0x1, "Major GC cycle requested\n", 0);
+  CAMLassert (v == Val_unit);
+  caml_gc_message (0x1, "Major GC cycle requested\n");
   caml_empty_minor_heap ();
   caml_finish_major_cycle ();
   test_and_compact ();
@@ -502,8 +509,8 @@ CAMLprim value caml_gc_major(value v)
 CAMLprim value caml_gc_full_major(value v)
 {
   CAML_INSTR_SETUP (tmr, "");
-  Assert (v == Val_unit);
-  caml_gc_message (0x1, "Full major GC cycle requested\n", 0);
+  CAMLassert (v == Val_unit);
+  caml_gc_message (0x1, "Full major GC cycle requested\n");
   caml_empty_minor_heap ();
   caml_finish_major_cycle ();
   caml_final_do_calls ();
@@ -518,7 +525,7 @@ CAMLprim value caml_gc_full_major(value v)
 CAMLprim value caml_gc_major_slice (value v)
 {
   CAML_INSTR_SETUP (tmr, "");
-  Assert (Is_long (v));
+  CAMLassert (Is_long (v));
   caml_major_collection_slice (Long_val (v));
   CAML_INSTR_TIME (tmr, "explicit/gc_major_slice");
   return Val_long (0);
@@ -527,8 +534,8 @@ CAMLprim value caml_gc_major_slice (value v)
 CAMLprim value caml_gc_compaction(value v)
 {
   CAML_INSTR_SETUP (tmr, "");
-  Assert (v == Val_unit);
-  caml_gc_message (0x10, "Heap compaction requested\n", 0);
+  CAMLassert (v == Val_unit);
+  caml_gc_message (0x10, "Heap compaction requested\n");
   caml_empty_minor_heap ();
   caml_finish_major_cycle ();
   caml_final_do_calls ();
@@ -595,21 +602,27 @@ void caml_init_gc (uintnat minor_size, uintnat major_size,
   caml_percent_max = norm_pmax (percent_m);
   caml_init_major_heap (major_heap_size);
   caml_major_window = norm_window (window);
-  caml_gc_message (0x20, "Initial minor heap size: %luk words\n",
+  caml_gc_message (0x20, "Initial minor heap size: %"
+                   ARCH_SIZET_PRINTF_FORMAT "uk words\n",
                    caml_minor_heap_wsz / 1024);
-  caml_gc_message (0x20, "Initial major heap size: %luk bytes\n",
+  caml_gc_message (0x20, "Initial major heap size: %"
+                   ARCH_INTNAT_PRINTF_FORMAT "uk bytes\n",
                    major_heap_size / 1024);
-  caml_gc_message (0x20, "Initial space overhead: %lu%%\n", caml_percent_free);
-  caml_gc_message (0x20, "Initial max overhead: %lu%%\n", caml_percent_max);
+  caml_gc_message (0x20, "Initial space overhead: %"
+                   ARCH_INTNAT_PRINTF_FORMAT "u%%\n", caml_percent_free);
+  caml_gc_message (0x20, "Initial max overhead: %"
+                   ARCH_INTNAT_PRINTF_FORMAT "u%%\n", caml_percent_max);
   if (caml_major_heap_increment > 1000){
-    caml_gc_message (0x20, "Initial heap increment: %luk words\n",
+    caml_gc_message (0x20, "Initial heap increment: %"
+                     ARCH_INTNAT_PRINTF_FORMAT "uk words\n",
                      caml_major_heap_increment / 1024);
   }else{
-    caml_gc_message (0x20, "Initial heap increment: %lu%%\n",
+    caml_gc_message (0x20, "Initial heap increment: %"
+                     ARCH_INTNAT_PRINTF_FORMAT "u%%\n",
                      caml_major_heap_increment);
   }
-  caml_gc_message (0x20, "Initial allocation policy: %d\n",
-                   caml_allocation_policy);
+  caml_gc_message (0x20, "Initial allocation policy: %"
+                   ARCH_INTNAT_PRINTF_FORMAT "u\n", caml_allocation_policy);
   caml_gc_message (0x20, "Initial smoothing window: %d\n",
                    caml_major_window);
 }
@@ -633,16 +646,19 @@ extern int caml_parser_trace;
 
 CAMLprim value caml_runtime_parameters (value unit)
 {
+#define F_Z ARCH_INTNAT_PRINTF_FORMAT
+#define F_S ARCH_SIZET_PRINTF_FORMAT
+
   CAMLassert (unit == Val_unit);
   return caml_alloc_sprintf
-    ("a=%d,b=%d,H=%lu,i=%lu,l=%lu,o=%lu,O=%lu,p=%d,s=%lu,t=%lu,v=%lu,w=%d,W=%lu",
+    ("a=%d,b=%d,H=%"F_Z"u,i=%"F_Z"u,l=%"F_Z"u,o=%"F_Z"u,O=%"F_Z"u,p=%d,s=%"F_S"u,t=%"F_Z"u,v=%"F_Z"u,w=%d,W=%"F_Z"u",
      /* a */ (int) caml_allocation_policy,
      /* b */ caml_backtrace_active,
      /* h */ /* missing */ /* FIXME add when changed to min_heap_size */
      /* H */ caml_use_huge_pages,
      /* i */ caml_major_heap_increment,
 #ifdef NATIVE_CODE
-     /* l */ 0UL,
+     /* l */ (uintnat) 0,
 #else
      /* l */ caml_max_stack_size,
 #endif
@@ -656,6 +672,8 @@ CAMLprim value caml_runtime_parameters (value unit)
      /* w */ caml_major_window,
      /* W */ caml_runtime_warnings
      );
+#undef F_Z
+#undef F_S
 }
 
 /* Control runtime warnings */

diff --git a/byterun/globroots.c b/byterun/globroots.c
index 44493dbe2e96f09cc156be6719843394ac5f878b..f689723c205d3ae5d4d8b875afd71a6bb108d166 100644 (file)
--- a/byterun/globroots.c
+++ b/byterun/globroots.c
@@ -61,7 +61,7 @@ static int random_level(void)
      "less random" than the most significant bits with a modulus of 2^m,
      so consume most significant bits first */
   while ((r & 0xC0000000U) == 0xC0000000U) { level++; r = r << 2; }
-  Assert(level < NUM_LEVELS);
+  CAMLassert(level < NUM_LEVELS);
   return level;
 }
 
@@ -74,7 +74,7 @@ static void caml_insert_global_root(struct global_root_list * rootlist,
   struct global_root * e, * f;
   int i, new_level;
 
-  Assert(0 <= rootlist->level && rootlist->level < NUM_LEVELS);
+  CAMLassert(0 <= rootlist->level && rootlist->level < NUM_LEVELS);
 
   /* Init "cursor" to list head */
   e = (struct global_root *) rootlist;
@@ -115,7 +115,7 @@ static void caml_delete_global_root(struct global_root_list * rootlist,
   struct global_root * e, * f;
   int i;
 
-  Assert(0 <= rootlist->level && rootlist->level < NUM_LEVELS);
+  CAMLassert(0 <= rootlist->level && rootlist->level < NUM_LEVELS);
 
   /* Init "cursor" to list head */
   e = (struct global_root *) rootlist;
@@ -163,7 +163,7 @@ static void caml_empty_global_roots(struct global_root_list * rootlist)
   struct global_root * gr, * next;
   int i;
 
-  Assert(0 <= rootlist->level && rootlist->level < NUM_LEVELS);
+  CAMLassert(0 <= rootlist->level && rootlist->level < NUM_LEVELS);
 
   for (gr = rootlist->forward[0]; gr != NULL; /**/) {
     next = gr->forward[0];
@@ -187,7 +187,7 @@ struct global_root_list caml_global_roots_old = { NULL, { NULL, }, 0 };
 
 CAMLexport void caml_register_global_root(value *r)
 {
-  Assert (((intnat) r & 3) == 0);  /* compact.c demands this (for now) */
+  CAMLassert (((intnat) r & 3) == 0);  /* compact.c demands this (for now) */
   caml_insert_global_root(&caml_global_roots, r);
 }
 
@@ -203,7 +203,7 @@ CAMLexport void caml_remove_global_root(value *r)
 CAMLexport void caml_register_generational_global_root(value *r)
 {
   value v = *r;
-  Assert (((intnat) r & 3) == 0);  /* compact.c demands this (for now) */
+  CAMLassert (((intnat) r & 3) == 0);  /* compact.c demands this (for now) */
   if (Is_block(v)) {
     if (Is_young(v))
       caml_insert_global_root(&caml_global_roots_young, r);

diff --git a/byterun/hash.c b/byterun/hash.c
index f59c8fbc1b2dce81b83eaab8a20f99160d482163..f7d0d22233c65219d180fd48aa920e73ae6cad12 100644 (file)
--- a/byterun/hash.c
+++ b/byterun/hash.c
@@ -217,7 +217,7 @@ CAMLprim value caml_hash(value count, value limit, value seed, value obj)
         break;
       case Double_array_tag:
         for (i = 0, len = Wosize_val(v) / Double_wosize; i < len; i++) {
-          h = caml_hash_mix_double(h, Double_field(v, i));
+          h = caml_hash_mix_double(h, Double_flat_field(v, i));
           num--;
           if (num <= 0) break;
         }
@@ -280,39 +280,42 @@ CAMLprim value caml_hash(value count, value limit, value seed, value obj)
 
 /* The old implementation */
 
-static uintnat hash_accu;
-static intnat hash_univ_limit, hash_univ_count;
+struct hash_state {
+  uintnat accu;
+  intnat univ_limit, univ_count;
+};
 
-static void hash_aux(value obj);
+static void hash_aux(struct hash_state*, value obj);
 
 CAMLprim value caml_hash_univ_param(value count, value limit, value obj)
 {
-  hash_univ_limit = Long_val(limit);
-  hash_univ_count = Long_val(count);
-  hash_accu = 0;
-  hash_aux(obj);
-  return Val_long(hash_accu & 0x3FFFFFFF);
+  struct hash_state h;
+  h.univ_limit = Long_val(limit);
+  h.univ_count = Long_val(count);
+  h.accu = 0;
+  hash_aux(&h, obj);
+  return Val_long(h.accu & 0x3FFFFFFF);
   /* The & has two purposes: ensure that the return value is positive
      and give the same result on 32 bit and 64 bit architectures. */
 }
 
 #define Alpha 65599
 #define Beta 19
-#define Combine(new)  (hash_accu = hash_accu * Alpha + (new))
-#define Combine_small(new) (hash_accu = hash_accu * Beta + (new))
+#define Combine(new)  (h->accu = h->accu * Alpha + (new))
+#define Combine_small(new) (h->accu = h->accu * Beta + (new))
 
-static void hash_aux(value obj)
+static void hash_aux(struct hash_state* h, value obj)
 {
   unsigned char * p;
   mlsize_t i, j;
   tag_t tag;
 
-  hash_univ_limit--;
-  if (hash_univ_count < 0 || hash_univ_limit < 0) return;
+  h->univ_limit--;
+  if (h->univ_count < 0 || h->univ_limit < 0) return;
 
  again:
   if (Is_long(obj)) {
-    hash_univ_count--;
+    h->univ_count--;
     Combine(Long_val(obj));
     return;
   }
@@ -320,12 +323,12 @@ static void hash_aux(value obj)
   /* Pointers into the heap are well-structured blocks. So are atoms.
      We can inspect the block contents. */
 
-  Assert (Is_block (obj));
+  CAMLassert (Is_block (obj));
   if (Is_in_value_area(obj)) {
     tag = Tag_val(obj);
     switch (tag) {
     case String_tag:
-      hash_univ_count--;
+      h->univ_count--;
       i = caml_string_length(obj);
       for (p = &Byte_u(obj, 0); i > 0; i--, p++)
         Combine_small(*p);
@@ -333,7 +336,7 @@ static void hash_aux(value obj)
     case Double_tag:
       /* For doubles, we inspect their binary representation, LSB first.
          The results are consistent among all platforms with IEEE floats. */
-      hash_univ_count--;
+      h->univ_count--;
 #ifdef ARCH_BIG_ENDIAN
       for (p = &Byte_u(obj, sizeof(double) - 1), i = sizeof(double);
            i > 0;
@@ -346,7 +349,7 @@ static void hash_aux(value obj)
         Combine_small(*p);
       break;
     case Double_array_tag:
-      hash_univ_count--;
+      h->univ_count--;
       for (j = 0; j < Bosize_val(obj); j += sizeof(double)) {
 #ifdef ARCH_BIG_ENDIAN
       for (p = &Byte_u(obj, j + sizeof(double) - 1), i = sizeof(double);
@@ -365,29 +368,29 @@ static void hash_aux(value obj)
          Better do nothing. */
       break;
     case Infix_tag:
-      hash_aux(obj - Infix_offset_val(obj));
+      hash_aux(h, obj - Infix_offset_val(obj));
       break;
     case Forward_tag:
       obj = Forward_val (obj);
       goto again;
     case Object_tag:
-      hash_univ_count--;
+      h->univ_count--;
       Combine(Oid_val(obj));
       break;
     case Custom_tag:
       /* If no hashing function provided, do nothing */
       if (Custom_ops_val(obj)->hash != NULL) {
-        hash_univ_count--;
+        h->univ_count--;
         Combine(Custom_ops_val(obj)->hash(obj));
       }
       break;
     default:
-      hash_univ_count--;
+      h->univ_count--;
       Combine_small(tag);
       i = Wosize_val(obj);
       while (i != 0) {
         i--;
-        hash_aux(Field(obj, i));
+        hash_aux(h, Field(obj, i));
       }
       break;
     }

diff --git a/byterun/instrtrace.c b/byterun/instrtrace.c
index c2ad8348b413d9ab837b8217a64a470e6b37b3a5..824562e1974e3d8ad4e9963106cbef44d1aec4cc 100644 (file)
--- a/byterun/instrtrace.c
+++ b/byterun/instrtrace.c
@@ -181,7 +181,7 @@ void
 caml_trace_value_file (value v, code_t prog, int proglen, FILE * f)
 {
   int i;
-  fprintf (f, "%#lx", v);
+  fprintf (f, "%#" ARCH_INTNAT_PRINTF_FORMAT "x", v);
   if (!v)
     return;
   if (prog && v % sizeof (int) == 0
@@ -219,7 +219,7 @@ caml_trace_value_file (value v, code_t prog, int proglen, FILE * f)
     case Double_array_tag:
       fprintf (f, "=floatarray[s%d]", s);
       for (i = 0; i < ((s>0xf)?0xf:s); i++)
-        fprintf (f, " %g", Double_field (v, i));
+        fprintf (f, " %g", Double_flat_field (v, i));
       goto displayfields;
     case Abstract_tag:
       fprintf (f, "=abstract[s%d]", s);
@@ -239,7 +239,7 @@ caml_trace_value_file (value v, code_t prog, int proglen, FILE * f)
         };
         if (i > 0)
           putc (' ', f);
-        fprintf (f, "%#lx", Field (v, i));
+        fprintf (f, "%#" ARCH_INTNAT_PRINTF_FORMAT "x", Field (v, i));
       };
       if (s > 0)
         putc (')', f);

diff --git a/byterun/intern.c b/byterun/intern.c
index 9c6c4cea5568e1593b496abf4442aa164762c166..ba78846fd413227a9734f08069954936b7b27104 100644 (file)
--- a/byterun/intern.c
+++ b/byterun/intern.c
@@ -140,7 +140,7 @@ static void intern_init(void * src, void * input)
   /* This is asserted at the beginning of demarshaling primitives.
      If it fails, it probably means that an exception was raised
      without calling intern_cleanup() during the previous demarshaling. */
-  Assert (intern_input == NULL && intern_obj_table == NULL \
+  CAMLassert (intern_input == NULL && intern_obj_table == NULL \
      && intern_extra_block == NULL && intern_block == 0);
   intern_src = src;
   intern_input = input;
@@ -256,7 +256,7 @@ static struct intern_item * intern_stack_limit = intern_stack_init
 static void intern_free_stack(void)
 {
   if (intern_stack != intern_stack_init) {
-    free(intern_stack);
+    caml_stat_free(intern_stack);
     /* Reinitialize the globals for next time around */
     intern_stack = intern_stack_init;
     intern_stack_limit = intern_stack + INTERN_STACK_INIT_SIZE;
@@ -266,7 +266,7 @@ static void intern_free_stack(void)
 /* Same, then raise Out_of_memory */
 static void intern_stack_overflow(void)
 {
-  caml_gc_message (0x04, "Stack overflow in un-marshaling value\n", 0);
+  caml_gc_message (0x04, "Stack overflow in un-marshaling value\n");
   intern_free_stack();
   caml_raise_out_of_memory();
 }
@@ -279,13 +279,13 @@ static struct intern_item * intern_resize_stack(struct intern_item * sp)
 
   if (newsize >= INTERN_STACK_MAX_SIZE) intern_stack_overflow();
   if (intern_stack == intern_stack_init) {
-    newstack = malloc(sizeof(struct intern_item) * newsize);
+    newstack = caml_stat_alloc_noexc(sizeof(struct intern_item) * newsize);
     if (newstack == NULL) intern_stack_overflow();
     memcpy(newstack, intern_stack_init,
            sizeof(struct intern_item) * INTERN_STACK_INIT_SIZE);
   } else {
-    newstack =
-      realloc(intern_stack, sizeof(struct intern_item) * newsize);
+    newstack = caml_stat_resize_noexc(intern_stack,
+                                      sizeof(struct intern_item) * newsize);
     if (newstack == NULL) intern_stack_overflow();
   }
   intern_stack = newstack;
@@ -369,7 +369,7 @@ static void intern_rec(value *dest)
         intern_dest += 1 + size;
         /* For objects, we need to freshen the oid */
         if (tag == Object_tag) {
-          Assert(size >= 2);
+          CAMLassert(size >= 2);
           /* Request to read rest of the elements of the block */
           ReadItems(&Field(v, 2), size - 2);
           /* Request freshing OID */
@@ -400,7 +400,7 @@ static void intern_rec(value *dest)
       Field(v, size - 1) = 0;
       ofs_ind = Bsize_wsize(size) - 1;
       Byte(v, ofs_ind) = ofs_ind - len;
-      readblock(String_val(v), len);
+      readblock((char *)String_val(v), len);
     } else {
       switch(code) {
       case CODE_INT8:
@@ -424,9 +424,9 @@ static void intern_rec(value *dest)
       case CODE_SHARED8:
         ofs = read8u();
       read_shared:
-        Assert (ofs > 0);
-        Assert (ofs <= obj_counter);
-        Assert (intern_obj_table != NULL);
+        CAMLassert (ofs > 0);
+        CAMLassert (ofs <= obj_counter);
+        CAMLassert (intern_obj_table != NULL);
         v = intern_obj_table[obj_counter - ofs];
         break;
       case CODE_SHARED16:
@@ -552,7 +552,7 @@ static void intern_rec(value *dest)
   *dest = v;
   break;
   default:
-    Assert(0);
+    CAMLassert(0);
   }
   }
   /* We are done. Cleanup the stack and leave the function */
@@ -565,12 +565,12 @@ static void intern_alloc(mlsize_t whsize, mlsize_t num_objects,
   mlsize_t wosize;
 
   if (whsize == 0) {
-    Assert (intern_extra_block == NULL && intern_block == 0
+    CAMLassert (intern_extra_block == NULL && intern_block == 0
          && intern_obj_table == NULL);
     return;
   }
   wosize = Wosize_whsize(whsize);
-  if (wosize > Max_wosize || outside_heap) {
+  if (outside_heap || wosize > Max_wosize) {
     /* Round desired size up to next page */
     asize_t request =
       ((Bsize_wsize(whsize) + Page_size - 1) >> Page_log) << Page_log;
@@ -582,17 +582,19 @@ static void intern_alloc(mlsize_t whsize, mlsize_t num_objects,
     intern_color =
       outside_heap ? Caml_black : caml_allocation_color(intern_extra_block);
     intern_dest = (header_t *) intern_extra_block;
-    Assert (intern_block == 0);
+    CAMLassert (intern_block == 0);
   } else {
     /* this is a specialised version of caml_alloc from alloc.c */
-    if (wosize == 0){
-      intern_block = Atom (String_tag);
-    }else if (wosize <= Max_young_wosize){
-      intern_block = caml_alloc_small (wosize, String_tag);
+    if (wosize <= Max_young_wosize){
+      if (wosize == 0){
+        intern_block = Atom (String_tag);
+      } else {
+        intern_block = caml_alloc_small (wosize, String_tag);
+      }
     }else{
       intern_block = caml_alloc_shr_no_raise (wosize, String_tag);
       /* do not do the urgent_gc check here because it might darken
-         intern_block into gray and break the Assert 3 lines down */
+         intern_block into gray and break the intern_color assertion below */
       if (intern_block == 0) {
         intern_cleanup();
         caml_raise_out_of_memory();
@@ -600,19 +602,19 @@ static void intern_alloc(mlsize_t whsize, mlsize_t num_objects,
     }
     intern_header = Hd_val(intern_block);
     intern_color = Color_hd(intern_header);
-    Assert (intern_color == Caml_white || intern_color == Caml_black);
+    CAMLassert (intern_color == Caml_white || intern_color == Caml_black);
     intern_dest = (header_t *) Hp_val(intern_block);
-    Assert (intern_extra_block == NULL);
+    CAMLassert (intern_extra_block == NULL);
   }
   obj_counter = 0;
   if (num_objects > 0) {
-    intern_obj_table = (value *) malloc(num_objects * sizeof(value));
+    intern_obj_table = (value *) caml_stat_alloc_noexc(num_objects * sizeof(value));
     if (intern_obj_table == NULL) {
       intern_cleanup();
       caml_raise_out_of_memory();
     }
   } else
-    Assert(intern_obj_table == NULL);
+    CAMLassert(intern_obj_table == NULL);
 }
 
 static void intern_add_to_heap(mlsize_t whsize)
@@ -623,8 +625,8 @@ static void intern_add_to_heap(mlsize_t whsize)
     asize_t request = Chunk_size (intern_extra_block);
     header_t * end_extra_block =
       (header_t *) intern_extra_block + Wsize_bsize(request);
-    Assert(intern_block == 0);
-    Assert(intern_dest <= end_extra_block);
+    CAMLassert(intern_block == 0);
+    CAMLassert(intern_dest <= end_extra_block);
     if (intern_dest < end_extra_block){
       caml_make_free_blocks ((value *) intern_dest,
                              end_extra_block - intern_dest, 0, Caml_white);

diff --git a/byterun/interp.c b/byterun/interp.c
index 9b3e0ac22788c12fa78317b26f40da59605b8735..76e600c97e0f7d0fb80bc61b621796c879367e46 100644 (file)
--- a/byterun/interp.c
+++ b/byterun/interp.c
@@ -267,8 +267,8 @@ value caml_interprete(code_t prog, asize_t prog_size)
 #ifdef DEBUG
  next_instr:
   if (caml_icount-- == 0) caml_stop_here ();
-  Assert(sp >= caml_stack_low);
-  Assert(sp <= caml_stack_high);
+  CAMLassert(sp >= caml_stack_low);
+  CAMLassert(sp <= caml_stack_high);
 #endif
   goto *(void *)(jumptbl_base + *pc++); /* Jump to the first instruction */
 #else
@@ -276,7 +276,8 @@ value caml_interprete(code_t prog, asize_t prog_size)
 #ifdef DEBUG
     caml_bcodcount++;
     if (caml_icount-- == 0) caml_stop_here ();
-    if (caml_trace_level>1) printf("\n##%ld\n", caml_bcodcount);
+    if (caml_trace_level>1) printf("\n##%" ARCH_INTNAT_PRINTF_FORMAT "d\n",
+                                   caml_bcodcount);
     if (caml_trace_level>0) caml_disasm_instr(pc);
     if (caml_trace_level>1) {
       printf("env=");
@@ -285,8 +286,8 @@ value caml_interprete(code_t prog, asize_t prog_size)
       caml_trace_accu_sp_file(accu,sp,prog,prog_size,stdout);
       fflush(stdout);
     };
-    Assert(sp >= caml_stack_low);
-    Assert(sp <= caml_stack_high);
+    CAMLassert(sp >= caml_stack_low);
+    CAMLassert(sp <= caml_stack_high);
 #endif
     curr_instr = *pc++;
 
@@ -699,9 +700,9 @@ value caml_interprete(code_t prog, asize_t prog_size)
       } else {
         block = caml_alloc_shr(size * Double_wosize, Double_array_tag);
       }
-      Store_double_field(block, 0, Double_val(accu));
+      Store_double_flat_field(block, 0, Double_val(accu));
       for (i = 1; i < size; i++){
-        Store_double_field(block, i, Double_val(*sp));
+        Store_double_flat_field(block, i, Double_val(*sp));
         ++ sp;
       }
       accu = block;
@@ -721,7 +722,7 @@ value caml_interprete(code_t prog, asize_t prog_size)
     Instruct(GETFIELD):
       accu = Field(accu, *pc); pc++; Next;
     Instruct(GETFLOATFIELD): {
-      double d = Double_field(accu, *pc);
+      double d = Double_flat_field(accu, *pc);
       Alloc_small(accu, Double_wosize, Double_tag);
       Store_double_val(accu, d);
       pc++;
@@ -750,7 +751,7 @@ value caml_interprete(code_t prog, asize_t prog_size)
       pc++;
       Next;
     Instruct(SETFLOATFIELD):
-      Store_double_field(accu, *pc, Double_val(*sp));
+      Store_double_flat_field(accu, *pc, Double_val(*sp));
       accu = Val_unit;
       sp++;
       pc++;
@@ -759,6 +760,9 @@ value caml_interprete(code_t prog, asize_t prog_size)
 /* Array operations */
 
     Instruct(VECTLENGTH): {
+      /* Todo: when FLAT_FLOAT_ARRAY is false, this instruction should
+         be split into VECTLENGTH and FLOATVECTLENGTH because we know
+         statically which one it is. */
       mlsize_t size = Wosize_val(accu);
       if (Tag_val(accu) == Double_array_tag) size = size / Double_wosize;
       accu = Val_long(size);
@@ -801,11 +805,11 @@ value caml_interprete(code_t prog, asize_t prog_size)
       uint32_t sizes = *pc++;
       if (Is_block(accu)) {
         intnat index = Tag_val(accu);
-        Assert ((uintnat) index < (sizes >> 16));
+        CAMLassert ((uintnat) index < (sizes >> 16));
         pc += pc[(sizes & 0xFFFF) + index];
       } else {
         intnat index = Long_val(accu);
-        Assert ((uintnat) index < (sizes & 0xFFFF)) ;
+        CAMLassert ((uintnat) index < (sizes & 0xFFFF)) ;
         pc += pc[index];
       }
       Next;
@@ -1155,8 +1159,8 @@ void caml_prepare_bytecode(code_t prog, asize_t prog_size) {
   /* other implementations of the interpreter (such as an hypothetical
      JIT translator) might want to do something with a bytecode before
      running it */
-  Assert(prog);
-  Assert(prog_size>0);
+  CAMLassert(prog);
+  CAMLassert(prog_size>0);
   /* actually, the threading of the bytecode might be done here */
 }
 
@@ -1164,6 +1168,6 @@ void caml_release_bytecode(code_t prog, asize_t prog_size) {
   /* other implementations of the interpreter (such as an hypothetical
      JIT translator) might want to know when a bytecode is removed */
   /* check that we have a program */
-  Assert(prog);
-  Assert(prog_size>0);
+  CAMLassert(prog);
+  CAMLassert(prog_size>0);
 }

diff --git a/byterun/ints.c b/byterun/ints.c
index 16326395f08ad9ad8ec56535c3df87bf5c34c21f..a104a0ee9bd74a106531b8d2b99a03fb9ff4287b 100644 (file)
--- a/byterun/ints.c
+++ b/byterun/ints.c
@@ -25,10 +25,10 @@
 #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)
+static const char * parse_sign_and_base(const char * p,
+                                        /*out*/ int * base,
+                                        /*out*/ int * signedness,
+                                        /*out*/ int * sign)
 {
   *sign = 1;
   if (*p == '-') {
@@ -71,7 +71,7 @@ static int parse_digit(char c)
 
 static intnat parse_intnat(value s, int nbits, const char *errmsg)
 {
-  char * p;
+  const char * p;
   uintnat res, threshold;
   int sign, base, signedness, d;
 
@@ -565,7 +565,7 @@ CAMLprim value caml_int64_format(value fmt, value arg)
 
 CAMLprim value caml_int64_of_string(value s)
 {
-  char * p;
+  const char * p;
   uint64_t res, threshold;
   int sign, base, signedness, d;
 

diff --git a/byterun/io.c b/byterun/io.c
index b11eeccf18632f01027279a58219efb673830923..3d9560198a400b37c41cb788cf784d2b3cf84e32 100644 (file)
--- a/byterun/io.c
+++ b/byterun/io.c
@@ -100,7 +100,7 @@ CAMLexport struct channel * caml_open_descriptor_out(int fd)
 static void unlink_channel(struct channel *channel)
 {
   if (channel->prev == NULL) {
-    Assert (channel == caml_all_opened_channels);
+    CAMLassert (channel == caml_all_opened_channels);
     caml_all_opened_channels = caml_all_opened_channels->next;
     if (caml_all_opened_channels != NULL)
       caml_all_opened_channels->prev = NULL;
@@ -394,6 +394,7 @@ CAMLexport intnat caml_input_scan_line(struct channel *channel)
 CAMLexport void caml_finalize_channel(value vchan)
 {
   struct channel * chan = Channel(vchan);
+  if ((chan->flags & CHANNEL_FLAG_MANAGED_BY_GC) == 0) return;
   if (--chan->refcount > 0) return;
   if (caml_channel_mutex_free != NULL) (*caml_channel_mutex_free)(chan);
 
@@ -461,12 +462,16 @@ CAMLexport value caml_alloc_channel(struct channel *chan)
 
 CAMLprim value caml_ml_open_descriptor_in(value fd)
 {
-  return caml_alloc_channel(caml_open_descriptor_in(Int_val(fd)));
+  struct channel * chan = caml_open_descriptor_in(Int_val(fd));
+  chan->flags |= CHANNEL_FLAG_MANAGED_BY_GC;
+  return caml_alloc_channel(chan);
 }
 
 CAMLprim value caml_ml_open_descriptor_out(value fd)
 {
-  return caml_alloc_channel(caml_open_descriptor_out(Int_val(fd)));
+  struct channel * chan = caml_open_descriptor_out(Int_val(fd));
+  chan->flags |= CHANNEL_FLAG_MANAGED_BY_GC;
+  return caml_alloc_channel(chan);
 }
 
 CAMLprim value caml_ml_set_channel_name(value vchannel, value vname)
@@ -474,7 +479,7 @@ 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));
+    channel->name = caml_stat_strdup(String_val(vname));
   else
     channel->name = NULL;
   return Val_unit;

diff --git a/byterun/main.c b/byterun/main.c
index e773dd9bd540b6e991a14a7c1f35ca9502596868..5e5839fff7694046e353cc3fbb62ade09cebb7a2 100644 (file)
--- a/byterun/main.c
+++ b/byterun/main.c
@@ -21,19 +21,26 @@
 #include "caml/misc.h"
 #include "caml/mlvalues.h"
 #include "caml/sys.h"
+#include "caml/osdeps.h"
+#ifdef _WIN32
+#include <windows.h>
+#endif
 
-CAMLextern void caml_main (char **);
+CAMLextern void caml_main (char_os **);
 
 #ifdef _WIN32
-CAMLextern void caml_expand_command_line (int *, char ***);
-#endif
+CAMLextern void caml_expand_command_line (int *, wchar_t ***);
 
+int wmain(int argc, wchar_t **argv)
+#else
 int main(int argc, char **argv)
+#endif
 {
 #ifdef _WIN32
   /* Expand wildcards and diversions in command line */
   caml_expand_command_line(&argc, &argv);
 #endif
+
   caml_main(argv);
   caml_sys_exit(Val_int(0));
   return 0; /* not reached */

diff --git a/byterun/major_gc.c b/byterun/major_gc.c
index 5a3e4cb1a3a609f94cb254b60a4eff7de99e6b59..bfac0e4456fa151859d06d28a987d7c29603d130 100644 (file)
--- a/byterun/major_gc.c
+++ b/byterun/major_gc.c
@@ -123,15 +123,16 @@ static void realloc_gray_vals (void)
 {
   value *new;
 
-  Assert (gray_vals_cur == gray_vals_end);
+  CAMLassert (gray_vals_cur == gray_vals_end);
   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);
-    new = (value *) realloc ((char *) gray_vals,
-                             2 * gray_vals_size * sizeof (value));
+    new = (value *) caml_stat_resize_noexc ((char *) gray_vals,
+                                            2 * gray_vals_size *
+                                            sizeof (value));
     if (new == NULL){
-      caml_gc_message (0x08, "No room for growing gray_vals\n", 0);
+      caml_gc_message (0x08, "No room for growing gray_vals\n");
       gray_vals_cur = gray_vals;
       heap_is_pure = 0;
     }else{
@@ -185,9 +186,9 @@ void caml_darken (value v, value *p /* not used */)
 
 static void start_cycle (void)
 {
-  Assert (caml_gc_phase == Phase_idle);
-  Assert (gray_vals_cur == gray_vals);
-  caml_gc_message (0x01, "Starting new major GC cycle\n", 0);
+  CAMLassert (caml_gc_phase == Phase_idle);
+  CAMLassert (gray_vals_cur == gray_vals);
+  caml_gc_message (0x01, "Starting new major GC cycle\n");
   caml_darken_all_roots_start ();
   caml_gc_phase = Phase_mark;
   caml_gc_subphase = Subphase_mark_roots;
@@ -257,7 +258,11 @@ static inline value* mark_slice_darken(value *gray_vals_ptr, value v, int i,
       if ((in_ephemeron && Is_long(f)) ||
           (Is_block (f)
            && (!Is_in_value_area(f) || Tag_val (f) == Forward_tag
-               || Tag_val (f) == Lazy_tag || Tag_val (f) == Double_tag))){
+               || Tag_val (f) == Lazy_tag
+#ifdef FLAT_FLOAT_ARRAY
+               || Tag_val (f) == Double_tag
+#endif
+               ))){
         /* Do not short-circuit the pointer. */
       }else{
         /* The variable child is not changed because it must be mark alive */
@@ -303,7 +308,7 @@ static value* mark_ephe_aux (value *gray_vals_ptr, intnat *work,
 
   v = *ephes_to_check;
   hd = Hd_val(v);
-  Assert(Tag_val (v) == Abstract_tag);
+  CAMLassert(Tag_val (v) == Abstract_tag);
   data = Field(v,CAML_EPHE_DATA_OFFSET);
   if ( data != caml_ephe_none &&
        Is_block (data) && Is_in_heap (data) && Is_white_val (data)){
@@ -325,7 +330,11 @@ static value* mark_ephe_aux (value *gray_vals_ptr, intnat *work,
           if (Is_long (f) ||
               (Is_block (f) &&
                (!Is_in_value_area(f) || Tag_val (f) == Forward_tag
-                || Tag_val (f) == Lazy_tag || Tag_val (f) == Double_tag))){
+                || Tag_val (f) == Lazy_tag
+#ifdef FLAT_FLOAT_ARRAY
+                || Tag_val (f) == Double_tag
+#endif
+                ))){
             /* Do not short-circuit the pointer. */
           }else{
             Field (v, i) = key = f;
@@ -382,8 +391,8 @@ static void mark_slice (intnat work)
 #endif
   int slice_pointers = 0; /** gcc removes it when not in CAML_INSTR */
 
-  caml_gc_message (0x40, "Marking %ld words\n", work);
-  caml_gc_message (0x40, "Subphase = %ld\n", caml_gc_subphase);
+  caml_gc_message (0x40, "Marking %"ARCH_INTNAT_PRINTF_FORMAT"d words\n", work);
+  caml_gc_message (0x40, "Subphase = %d\n", caml_gc_subphase);
   gray_vals_ptr = gray_vals_cur;
   v = current_value;
   start = current_index;
@@ -395,7 +404,7 @@ static void mark_slice (intnat work)
     }
     if (v != 0){
       hd = Hd_val(v);
-      Assert (Is_gray_hd (hd));
+      CAMLassert (Is_gray_hd (hd));
       size = Wosize_hd (hd);
       end = start + work;
       if (Tag_hd (hd) < No_scan_tag){
@@ -440,7 +449,7 @@ static void mark_slice (intnat work)
         }
       }else{
         if (Is_gray_val (Val_hp (markhp))){
-          Assert (gray_vals_ptr == gray_vals);
+          CAMLassert (gray_vals_ptr == gray_vals);
           CAMLassert (v == 0 && start == 0);
           v = Val_hp (markhp);
         }
@@ -497,7 +506,7 @@ static void mark_slice (intnat work)
           work = 0;
       }
         break;
-      default: Assert (0);
+      default: CAMLassert (0);
       }
     }
   }
@@ -513,7 +522,8 @@ static void clean_slice (intnat work)
 {
   value v;
 
-  caml_gc_message (0x40, "Cleaning %ld words\n", work);
+  caml_gc_message (0x40, "Cleaning %"
+                   ARCH_INTNAT_PRINTF_FORMAT "d words\n", work);
   while (work > 0){
     v = *ephes_to_check;
     if (v != (value) NULL){
@@ -540,7 +550,8 @@ static void sweep_slice (intnat work)
   char *hp;
   header_t hd;
 
-  caml_gc_message (0x40, "Sweeping %ld words\n", work);
+  caml_gc_message (0x40, "Sweeping %"
+                   ARCH_INTNAT_PRINTF_FORMAT "d words\n", work);
   while (work > 0){
     if (caml_gc_sweep_hp < limit){
       hp = caml_gc_sweep_hp;
@@ -560,11 +571,11 @@ static void sweep_slice (intnat work)
         caml_fl_merge = Bp_hp (hp);
         break;
       default:          /* gray or black */
-        Assert (Color_hd (hd) == Caml_black);
+        CAMLassert (Color_hd (hd) == Caml_black);
         Hd_hp (hp) = Whitehd_hd (hd);
         break;
       }
-      Assert (caml_gc_sweep_hp <= limit);
+      CAMLassert (caml_gc_sweep_hp <= limit);
     }else{
       chunk = Chunk_next (chunk);
       if (chunk == NULL){
@@ -686,7 +697,8 @@ void caml_major_collection_slice (intnat howmuch)
   CAML_INSTR_INT ("major/work/extra#",
                   (uintnat) (caml_extra_heap_resources * 1000000));
 
-  caml_gc_message (0x40, "ordered work = %ld words\n", howmuch);
+  caml_gc_message (0x40, "ordered work = %"
+                   ARCH_INTNAT_PRINTF_FORMAT "d words\n", howmuch);
   caml_gc_message (0x40, "allocated_words = %"
                          ARCH_INTNAT_PRINTF_FORMAT "u\n",
                    caml_allocated_words);
@@ -764,21 +776,22 @@ void caml_major_collection_slice (intnat howmuch)
   }else{
     computed_work = (intnat) (p * caml_stat_heap_wsz * 5 / 3);
   }
-  caml_gc_message (0x40, "computed work = %ld words\n", computed_work);
+  caml_gc_message (0x40, "computed work = %"
+                   ARCH_INTNAT_PRINTF_FORMAT "d words\n", computed_work);
   if (caml_gc_phase == Phase_mark){
     CAML_INSTR_INT ("major/work/mark#", computed_work);
     mark_slice (computed_work);
     CAML_INSTR_TIME (tmr, mark_slice_name[caml_gc_subphase]);
-    caml_gc_message (0x02, "!", 0);
+    caml_gc_message (0x02, "!");
   }else if (caml_gc_phase == Phase_clean){
     clean_slice (computed_work);
-    caml_gc_message (0x02, "%%", 0);
+    caml_gc_message (0x02, "%%");
   }else{
-    Assert (caml_gc_phase == Phase_sweep);
+    CAMLassert (caml_gc_phase == Phase_sweep);
     CAML_INSTR_INT ("major/work/sweep#", computed_work);
     sweep_slice (computed_work);
     CAML_INSTR_TIME (tmr, "major/sweep");
-    caml_gc_message (0x02, "$", 0);
+    caml_gc_message (0x02, "$");
   }
 
   if (caml_gc_phase == Phase_idle){
@@ -818,9 +831,9 @@ void caml_finish_major_cycle (void)
   if (caml_gc_phase == Phase_idle) start_cycle ();
   while (caml_gc_phase == Phase_mark) mark_slice (LONG_MAX);
   while (caml_gc_phase == Phase_clean) clean_slice (LONG_MAX);
-  Assert (caml_gc_phase == Phase_sweep);
+  CAMLassert (caml_gc_phase == Phase_sweep);
   while (caml_gc_phase == Phase_sweep) sweep_slice (LONG_MAX);
-  Assert (caml_gc_phase == Phase_idle);
+  CAMLassert (caml_gc_phase == Phase_idle);
   caml_stat_major_words += caml_allocated_words;
   caml_allocated_words = 0;
 }
@@ -856,7 +869,7 @@ void caml_init_major_heap (asize_t heap_size)
 
   caml_stat_heap_wsz = caml_clip_heap_chunk_wsz (Wsize_bsize (heap_size));
   caml_stat_top_heap_wsz = caml_stat_heap_wsz;
-  Assert (Bsize_wsize (caml_stat_heap_wsz) % Page_size == 0);
+  CAMLassert (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)
@@ -878,7 +891,7 @@ void caml_init_major_heap (asize_t heap_size)
                          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));
+  gray_vals = (value *) caml_stat_alloc_noexc (gray_vals_size * sizeof (value));
   if (gray_vals == NULL)
     caml_fatal_error ("Fatal error: not enough memory for the gray cache.\n");
   gray_vals_cur = gray_vals;
@@ -904,3 +917,20 @@ void caml_set_major_window (int w){
   }
   caml_major_window = w;
 }
+
+void caml_finalise_heap (void)
+{
+  /* Finishing major cycle (all values become white) */
+  caml_empty_minor_heap ();
+  caml_finish_major_cycle ();
+  CAMLassert (caml_gc_phase == Phase_idle);
+
+  /* Finalising all values (by means of forced sweeping) */
+  caml_fl_init_merge ();
+  caml_gc_phase = Phase_sweep;
+  chunk = caml_heap_start;
+  caml_gc_sweep_hp = chunk;
+  limit = chunk + Chunk_size (chunk);
+  while (caml_gc_phase == Phase_sweep)
+    sweep_slice (LONG_MAX);
+}

diff --git a/byterun/memory.c b/byterun/memory.c
index 77d1b9e149571c4844b77c3fac73ec9e69403061..69a81611cbbf9962b8ecec08fa1211465f5064eb 100644 (file)
--- a/byterun/memory.c
+++ b/byterun/memory.c
@@ -17,6 +17,8 @@
 
 #include <stdlib.h>
 #include <string.h>
+#include <stdarg.h>
+#include <stddef.h>
 #include "caml/address_class.h"
 #include "caml/config.h"
 #include "caml/fail.h"
@@ -112,7 +114,8 @@ int caml_page_table_initialize(mlsize_t bytesize)
   }
   caml_page_table.mask = caml_page_table.size - 1;
   caml_page_table.occupancy = 0;
-  caml_page_table.entries = calloc(caml_page_table.size, sizeof(uintnat));
+  caml_page_table.entries =
+    caml_stat_calloc_noexc(caml_page_table.size, sizeof(uintnat));
   if (caml_page_table.entries == NULL)
     return -1;
   else
@@ -125,12 +128,13 @@ static int caml_page_table_resize(void)
   uintnat * new_entries;
   uintnat i, h;
 
-  caml_gc_message (0x08, "Growing page table to %lu entries\n",
+  caml_gc_message (0x08, "Growing page table to %"
+                   ARCH_INTNAT_PRINTF_FORMAT "u entries\n",
                    caml_page_table.size);
 
-  new_entries = calloc(2 * old.size, sizeof(uintnat));
+  new_entries = caml_stat_calloc_noexc(2 * old.size, sizeof(uintnat));
   if (new_entries == NULL) {
-    caml_gc_message (0x08, "No room for growing page table\n", 0);
+    caml_gc_message (0x08, "No room for growing page table\n");
     return -1;
   }
 
@@ -149,7 +153,7 @@ static int caml_page_table_resize(void)
     caml_page_table.entries[h] = e;
   }
 
-  free(old.entries);
+  caml_stat_free(old.entries);
   return 0;
 }
 
@@ -157,7 +161,7 @@ static int caml_page_table_modify(uintnat page, int toclear, int toset)
 {
   uintnat h;
 
-  Assert ((page & ~Page_mask) == 0);
+  CAMLassert ((page & ~Page_mask) == 0);
 
   /* Resize to keep load factor below 1/2 */
   if (caml_page_table.occupancy * 2 >= caml_page_table.size) {
@@ -202,7 +206,7 @@ static int caml_page_table_modify(uintnat page, int toclear, int toset)
   uintnat j = Pagetable_index2(page);
 
   if (caml_page_table[i] == caml_page_table_empty) {
-    unsigned char * new_tbl = calloc(Pagetable2_size, 1);
+    unsigned char * new_tbl = caml_stat_calloc_noexc(Pagetable2_size, 1);
     if (new_tbl == 0) return -1;
     caml_page_table[i] = new_tbl;
   }
@@ -276,8 +280,8 @@ char *caml_alloc_for_heap (asize_t request)
     void *block;
 
     request = ((request + Page_size - 1) >> Page_log) << Page_log;
-    mem = caml_aligned_malloc (request + sizeof (heap_chunk_head),
-                               sizeof (heap_chunk_head), &block);
+    mem = caml_stat_alloc_aligned_noexc (request + sizeof (heap_chunk_head),
+                                         sizeof (heap_chunk_head), &block);
     if (mem == NULL) return NULL;
     mem += sizeof (heap_chunk_head);
     Chunk_size (mem) = request;
@@ -307,7 +311,7 @@ void caml_free_for_heap (char *mem)
     CAMLassert (0);
 #endif
   }else{
-    free (Chunk_block (mem));
+    caml_stat_free (Chunk_block (mem));
   }
 }
 
@@ -328,7 +332,8 @@ int caml_add_to_heap (char *m)
   /* Should check the contents of the block. */
 #endif /* DEBUG */
 
-  caml_gc_message (0x04, "Growing heap to %luk bytes\n",
+  caml_gc_message (0x04, "Growing heap to %"
+                   ARCH_INTNAT_PRINTF_FORMAT "uk bytes\n",
                    (Bsize_wsize (caml_stat_heap_wsz) + Chunk_size (m)) / 1024);
 
   /* Register block in page table */
@@ -373,12 +378,12 @@ static value *expand_heap (mlsize_t request)
   value *mem, *hp, *prev;
   asize_t over_request, malloc_request, remain;
 
-  Assert (request <= Max_wosize);
+  CAMLassert (request <= Max_wosize);
   over_request = request + request / 100 * caml_percent_free;
   malloc_request = caml_clip_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);
+    caml_gc_message (0x04, "No room for growing heap\n");
     return NULL;
   }
   remain = Wsize_bsize (Chunk_size (mem));
@@ -407,7 +412,7 @@ static value *expand_heap (mlsize_t request)
       Hd_hp (hp) = Make_header_allocated_here (0, 0, Caml_white);
     }
   }
-  Assert (Wosize_hp (mem) >= request);
+  CAMLassert (Wosize_hp (mem) >= request);
   if (caml_add_to_heap ((char *) mem) != 0){
     caml_free_for_heap ((char *) mem);
     return NULL;
@@ -432,8 +437,9 @@ void caml_shrink_heap (char *chunk)
   if (chunk == caml_heap_start) return;
 
   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);
+  caml_gc_message (0x04, "Shrinking heap to %"
+                   ARCH_INTNAT_PRINTF_FORMAT "uk words\n",
+                   caml_stat_heap_wsz / 1024);
 
 #ifdef DEBUG
   {
@@ -464,7 +470,7 @@ color_t caml_allocation_color (void *hp)
       || (caml_gc_phase == Phase_sweep && (addr)hp >= (addr)caml_gc_sweep_hp)){
     return Caml_black;
   }else{
-    Assert (caml_gc_phase == Phase_idle
+    CAMLassert (caml_gc_phase == Phase_idle
             || (caml_gc_phase == Phase_sweep
                 && (addr)hp < (addr)caml_gc_sweep_hp));
     return Caml_white;
@@ -498,19 +504,19 @@ static inline value caml_alloc_shr_aux (mlsize_t wosize, tag_t tag,
     hp = caml_fl_allocate (wosize);
   }
 
-  Assert (Is_in_heap (Val_hp (hp)));
+  CAMLassert (Is_in_heap (Val_hp (hp)));
 
   /* Inline expansion of caml_allocation_color. */
   if (caml_gc_phase == Phase_mark || caml_gc_phase == Phase_clean
       || (caml_gc_phase == Phase_sweep && (addr)hp >= (addr)caml_gc_sweep_hp)){
     Hd_hp (hp) = Make_header_with_profinfo (wosize, tag, Caml_black, profinfo);
   }else{
-    Assert (caml_gc_phase == Phase_idle
+    CAMLassert (caml_gc_phase == Phase_idle
             || (caml_gc_phase == Phase_sweep
                 && (addr)hp < (addr)caml_gc_sweep_hp));
     Hd_hp (hp) = Make_header_with_profinfo (wosize, tag, Caml_white, profinfo);
   }
-  Assert (Hd_hp (hp)
+  CAMLassert (Hd_hp (hp)
     == Make_header_with_profinfo (wosize, tag, caml_allocation_color (hp),
                                   profinfo));
   caml_allocated_words += Whsize_wosize (wosize);
@@ -686,29 +692,316 @@ CAMLexport CAMLweakdef void caml_modify (value *fp, value val)
   }
 }
 
-/* [sz] is a number of bytes */
-CAMLexport void * caml_stat_alloc (asize_t sz)
+
+/* Global memory pool.
+
+   The pool is structured as a ring of blocks, where each block's header
+   contains two links: to the previous and to the next block. The data
+   structure allows for insertions and removals of blocks in constant time,
+   given that a pointer to the operated block is provided.
+
+   Initially, the pool contains a single block -- a pivot with no data, the
+   guaranteed existence of which makes for a more concise implementation.
+
+   The API functions that operate on the pool receive not pointers to the
+   block's header, but rather pointers to the block's "data" field. This
+   behaviour is required to maintain compatibility with the interfaces of
+   [malloc], [realloc], and [free] family of functions, as well as to hide
+   the implementation from the user.
+*/
+
+/* A type with the most strict alignment requirements */
+union max_align {
+  char c;
+  short s;
+  long l;
+  int i;
+  float f;
+  double d;
+  void *v;
+  void (*q)(void);
+};
+
+struct pool_block {
+#ifdef DEBUG
+  long magic;
+#endif
+  struct pool_block *next;
+  struct pool_block *prev;
+  union max_align data[1];  /* not allocated, used for alignment purposes */
+};
+
+#define SIZEOF_POOL_BLOCK offsetof(struct pool_block, data)
+
+static struct pool_block *pool = NULL;
+
+
+/* Returns a pointer to the block header, given a pointer to "data" */
+static struct pool_block* get_pool_block(caml_stat_block b)
+{
+  if (b == NULL)
+    return NULL;
+
+  else {
+    struct pool_block *pb =
+      (struct pool_block*)(((char*)b) - SIZEOF_POOL_BLOCK);
+#ifdef DEBUG
+    CAMLassert(pb->magic == Debug_pool_magic);
+#endif
+    return pb;
+  }
+}
+
+CAMLexport void caml_stat_create_pool(void)
+{
+  if (pool == NULL) {
+    pool = malloc(SIZEOF_POOL_BLOCK);
+    if (pool == NULL)
+      caml_fatal_error("Fatal error: out of memory.\n");
+#ifdef DEBUG
+    pool->magic = Debug_pool_magic;
+#endif
+    pool->next = pool;
+    pool->prev = pool;
+  }
+}
+
+CAMLexport void caml_stat_destroy_pool(void)
+{
+  if (pool != NULL) {
+    pool->prev->next = NULL;
+    while (pool != NULL) {
+      struct pool_block *next = pool->next;
+      free(pool);
+      pool = next;
+    }
+    pool = NULL;
+  }
+}
+
+/* [sz] and [modulo] are numbers of bytes */
+CAMLexport void* caml_stat_alloc_aligned_noexc(asize_t sz, int modulo,
+                                               caml_stat_block *b)
 {
-  void * result = malloc (sz);
+  char *raw_mem;
+  uintnat aligned_mem;
+  CAMLassert (modulo < Page_size);
+  raw_mem = (char *) caml_stat_alloc_noexc(sz + Page_size);
+  if (raw_mem == NULL) return NULL;
+  *b = raw_mem;
+  raw_mem += modulo;                /* Address to be aligned */
+  aligned_mem = (((uintnat) raw_mem / Page_size + 1) * Page_size);
+#ifdef DEBUG
+  {
+    uintnat *p;
+    uintnat *p0 = (void *) *b;
+    uintnat *p1 = (void *) (aligned_mem - modulo);
+    uintnat *p2 = (void *) (aligned_mem - modulo + sz);
+    uintnat *p3 = (void *) ((char *) *b + sz + Page_size);
+    for (p = p0; p < p1; p++) *p = Debug_filler_align;
+    for (p = p1; p < p2; p++) *p = Debug_uninit_align;
+    for (p = p2; p < p3; p++) *p = Debug_filler_align;
+  }
+#endif
+  return (char *) (aligned_mem - modulo);
+}
 
+/* [sz] and [modulo] are numbers of bytes */
+CAMLexport void* caml_stat_alloc_aligned(asize_t sz, int modulo,
+                                         caml_stat_block *b)
+{
+  void *result = caml_stat_alloc_aligned_noexc(sz, modulo, b);
   /* malloc() may return NULL if size is 0 */
-  if (result == NULL && sz != 0) caml_raise_out_of_memory ();
+  if ((result == NULL) && (sz != 0))
+    caml_raise_out_of_memory();
+  return result;
+}
+
+/* [sz] is a number of bytes */
+CAMLexport caml_stat_block caml_stat_alloc_noexc(asize_t sz)
+{
+  /* Backward compatibility mode */
+  if (pool == NULL)
+    return malloc(sz);
+  else {
+    struct pool_block *pb = malloc(sz + SIZEOF_POOL_BLOCK);
+    if (pb == NULL) return NULL;
 #ifdef DEBUG
-  memset (result, Debug_uninit_stat, sz);
+    memset(&(pb->data), Debug_uninit_stat, sz);
+    pb->magic = Debug_pool_magic;
 #endif
+
+    /* Linking the block into the ring */
+    pb->next = pool->next;
+    pb->prev = pool;
+    pool->next->prev = pb;
+    pool->next = pb;
+
+    return &(pb->data);
+  }
+}
+
+/* [sz] is a number of bytes */
+CAMLexport caml_stat_block caml_stat_alloc(asize_t sz)
+{
+  void *result = caml_stat_alloc_noexc(sz);
+  /* malloc() may return NULL if size is 0 */
+  if ((result == NULL) && (sz != 0))
+    caml_raise_out_of_memory();
   return result;
 }
 
-CAMLexport void caml_stat_free (void * blk)
+CAMLexport void caml_stat_free(caml_stat_block b)
 {
-  free (blk);
+  /* Backward compatibility mode */
+  if (pool == NULL)
+    free(b);
+  else {
+    struct pool_block *pb = get_pool_block(b);
+    if (pb == NULL) return;
+
+    /* Unlinking the block from the ring */
+    pb->prev->next = pb->next;
+    pb->next->prev = pb->prev;
+
+    free(pb);
+  }
 }
 
 /* [sz] is a number of bytes */
-CAMLexport void * caml_stat_resize (void * blk, asize_t sz)
+CAMLexport caml_stat_block caml_stat_resize_noexc(caml_stat_block b, asize_t sz)
 {
-  void * result = realloc (blk, sz);
+  /* Backward compatibility mode */
+  if (pool == NULL)
+    return realloc(b, sz);
+  else {
+    struct pool_block *pb = get_pool_block(b);
+    struct pool_block *pb_new = realloc(pb, sz + SIZEOF_POOL_BLOCK);
+    if (pb_new == NULL) return NULL;
+
+    /* Relinking the new block into the ring in place of the old one */
+    pb_new->prev->next = pb_new;
+    pb_new->next->prev = pb_new;
+
+    return &(pb_new->data);
+  }
+}
 
-  if (result == NULL) caml_raise_out_of_memory ();
+/* [sz] is a number of bytes */
+CAMLexport caml_stat_block caml_stat_resize(caml_stat_block b, asize_t sz)
+{
+  void *result = caml_stat_resize_noexc(b, sz);
+  if (result == NULL)
+    caml_raise_out_of_memory();
   return result;
 }
+
+/* [sz] is a number of bytes */
+CAMLexport caml_stat_block caml_stat_calloc_noexc(asize_t num, asize_t sz)
+{
+  uintnat total;
+  if (caml_umul_overflow(sz, num, &total))
+    return NULL;
+  else {
+    caml_stat_block result = caml_stat_alloc_noexc(total);
+    if (result != NULL)
+      memset(result, 0, total);
+    return result;
+  }
+}
+
+CAMLexport caml_stat_string caml_stat_strdup_noexc(const char *s)
+{
+  size_t slen = strlen(s);
+  caml_stat_block result = caml_stat_alloc_noexc(slen + 1);
+  if (result == NULL)
+    return NULL;
+  memcpy(result, s, slen + 1);
+  return result;
+}
+
+CAMLexport caml_stat_string caml_stat_strdup(const char *s)
+{
+  caml_stat_string result = caml_stat_strdup_noexc(s);
+  if (result == NULL)
+    caml_raise_out_of_memory();
+  return result;
+}
+
+#ifdef _WIN32
+
+CAMLexport wchar_t * caml_stat_wcsdup(const wchar_t *s)
+{
+  int slen = wcslen(s);
+  wchar_t* result = caml_stat_alloc((slen + 1)*sizeof(wchar_t));
+  if (result == NULL)
+    caml_raise_out_of_memory();
+  memcpy(result, s, (slen + 1)*sizeof(wchar_t));
+  return result;
+}
+
+#endif
+
+CAMLexport caml_stat_string caml_stat_strconcat(int n, ...)
+{
+  va_list args;
+  char *result, *p;
+  size_t len = 0;
+  int i;
+
+  va_start(args, n);
+  for (i = 0; i < n; i++) {
+    const char *s = va_arg(args, const char*);
+    len += strlen(s);
+  }
+  va_end(args);
+
+  result = caml_stat_alloc(len + 1);
+
+  va_start(args, n);
+  p = result;
+  for (i = 0; i < n; i++) {
+    const char *s = va_arg(args, const char*);
+    size_t l = strlen(s);
+    memcpy(p, s, l);
+    p += l;
+  }
+  va_end(args);
+
+  *p = 0;
+  return result;
+}
+
+#ifdef _WIN32
+
+CAMLexport wchar_t* caml_stat_wcsconcat(int n, ...)
+{
+  va_list args;
+  wchar_t *result, *p;
+  size_t len = 0;
+  int i;
+
+  va_start(args, n);
+  for (i = 0; i < n; i++) {
+    const wchar_t *s = va_arg(args, const wchar_t*);
+    len += wcslen(s);
+  }
+  va_end(args);
+
+  result = caml_stat_alloc((len + 1)*sizeof(wchar_t));
+
+  va_start(args, n);
+  p = result;
+  for (i = 0; i < n; i++) {
+    const wchar_t *s = va_arg(args, const wchar_t*);
+    size_t l = wcslen(s);
+    memcpy(p, s, l*sizeof(wchar_t));
+    p += l;
+  }
+  va_end(args);
+
+  *p = 0;
+  return result;
+}
+
+#endif

diff --git a/byterun/meta.c b/byterun/meta.c
index 9ec0358bbb55d0a13ada7066b49535043a2816b4..03e0479d04228f74a4d522855030b6710dd1dcfc 100644 (file)
--- a/byterun/meta.c
+++ b/byterun/meta.c
@@ -90,7 +90,7 @@ CAMLprim value caml_static_release_bytecode(value prog, value len)
 
   if (!cf) {
       /* [cf] Not matched with a caml_reify_bytecode call; impossible. */
-      Assert (0);
+      CAMLassert (0);
   } else {
       caml_ext_table_remove(&caml_code_fragments_table, cf);
   }
@@ -123,7 +123,8 @@ CAMLprim value caml_realloc_global(value size)
   actual_size = Wosize_val(caml_global_data);
   if (requested_size >= actual_size) {
     requested_size = (requested_size + 0x100) & 0xFFFFFF00;
-    caml_gc_message (0x08, "Growing global data to %lu entries\n",
+    caml_gc_message (0x08, "Growing global data to %"
+                     ARCH_INTNAT_PRINTF_FORMAT "u entries\n",
                      requested_size);
     new_global_data = caml_alloc_shr(requested_size, 0);
     for (i = 0; i < actual_size; i++)

diff --git a/byterun/minor_gc.c b/byterun/minor_gc.c
index 5c971d01a67442197e77df2270be03483dc7995b..b59b055db8ab67f694c8770e2d433174237bf641 100644 (file)
--- a/byterun/minor_gc.c
+++ b/byterun/minor_gc.c
@@ -85,7 +85,8 @@ static void alloc_generic_table (struct generic_table *tbl, asize_t sz,
 
   tbl->size = sz;
   tbl->reserve = rsv;
-  new_table = (void *) malloc((tbl->size + tbl->reserve) * element_size);
+  new_table = (void *) caml_stat_alloc_noexc((tbl->size + tbl->reserve) *
+                                             element_size);
   if (new_table == NULL) caml_fatal_error ("Fatal error: not enough memory\n");
   if (tbl->base != NULL) caml_stat_free (tbl->base);
   tbl->base = new_table;
@@ -133,9 +134,9 @@ void caml_set_minor_heap_size (asize_t bsz)
   char *new_heap;
   void *new_heap_base;
 
-  Assert (bsz >= Bsize_wsize(Minor_heap_min));
-  Assert (bsz <= Bsize_wsize(Minor_heap_max));
-  Assert (bsz % sizeof (value) == 0);
+  CAMLassert (bsz >= Bsize_wsize(Minor_heap_min));
+  CAMLassert (bsz <= Bsize_wsize(Minor_heap_max));
+  CAMLassert (bsz % sizeof (value) == 0);
   if (caml_young_ptr != caml_young_alloc_end){
     CAML_INSTR_INT ("force_minor/set_minor_heap_size@", 1);
     caml_requested_minor_gc = 0;
@@ -144,14 +145,14 @@ void caml_set_minor_heap_size (asize_t bsz)
     caml_empty_minor_heap ();
   }
   CAMLassert (caml_young_ptr == caml_young_alloc_end);
-  new_heap = caml_aligned_malloc(bsz, 0, &new_heap_base);
+  new_heap = caml_stat_alloc_aligned_noexc(bsz, 0, &new_heap_base);
   if (new_heap == NULL) caml_raise_out_of_memory();
   if (caml_page_table_add(In_young, new_heap, new_heap + bsz) != 0)
     caml_raise_out_of_memory();
 
   if (caml_young_start != NULL){
     caml_page_table_remove(In_young, caml_young_start, caml_young_end);
-    free (caml_young_base);
+    caml_stat_free (caml_young_base);
   }
   caml_young_base = new_heap_base;
   caml_young_start = (value *) new_heap;
@@ -183,7 +184,7 @@ void caml_oldify_one (value v, value *p)
 
  tail_call:
   if (Is_block (v) && Is_young (v)){
-    Assert ((value *) Hp_val (v) >= caml_young_ptr);
+    CAMLassert ((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. */
@@ -203,7 +204,7 @@ void caml_oldify_one (value v, value *p)
           Field (result, 1) = oldify_todo_list;    /* Add this block */
           oldify_todo_list = v;                    /*  to the "to do" list. */
         }else{
-          Assert (sz == 1);
+          CAMLassert (sz == 1);
           p = &Field (result, 0);
           v = field0;
           goto tail_call;
@@ -224,7 +225,7 @@ void caml_oldify_one (value v, value *p)
         tag_t ft = 0;
         int vv = 1;
 
-        Assert (tag == Forward_tag);
+        CAMLassert (tag == Forward_tag);
         if (Is_block (f)){
           if (Is_young (f)){
             vv = 1;
@@ -236,9 +237,13 @@ void caml_oldify_one (value v, value *p)
             }
           }
         }
-        if (!vv || ft == Forward_tag || ft == Lazy_tag || ft == Double_tag){
+        if (!vv || ft == Forward_tag || ft == Lazy_tag
+#ifdef FLAT_FLOAT_ARRAY
+            || ft == Double_tag
+#endif
+            ){
           /* Do not short-circuit the pointer.  Copy as a normal block. */
-          Assert (Wosize_hd (hd) == 1);
+          CAMLassert (Wosize_hd (hd) == 1);
           result = caml_alloc_shr_preserving_profinfo (1, Forward_tag, hd);
           *p = result;
           Hd_val (v) = 0;             /* Set (GC) forward flag */
@@ -285,7 +290,7 @@ void caml_oldify_mopup (void)
 
   while (oldify_todo_list != 0){
     v = oldify_todo_list;                /* Get the head. */
-    Assert (Hd_val (v) == 0);            /* It must be forwarded. */
+    CAMLassert (Hd_val (v) == 0);            /* It must be forwarded. */
     new_v = Field (v, 0);                /* Follow forward pointer. */
     oldify_todo_list = Field (new_v, 1); /* Remove from list. */
 
@@ -341,7 +346,7 @@ void caml_empty_minor_heap (void)
     CAML_INSTR_SETUP (tmr, "minor");
     prev_alloc_words = caml_allocated_words;
     caml_in_minor_collection = 1;
-    caml_gc_message (0x02, "<", 0);
+    caml_gc_message (0x02, "<");
     caml_oldify_local_roots();
     CAML_INSTR_TIME (tmr, "minor/local_roots");
     for (r = caml_ref_table.base; r < caml_ref_table.ptr; r++){
@@ -360,7 +365,7 @@ void caml_empty_minor_heap (void)
           if (Hd_val (*key) == 0){ /* Value copied to major heap */
             *key = Field (*key, 0);
           }else{ /* Value not copied so it's dead */
-            Assert(!ephe_check_alive_data(re));
+            CAMLassert(!ephe_check_alive_data(re));
             *key = caml_ephe_none;
             Field(re->ephe,1) = caml_ephe_none;
           }
@@ -389,7 +394,7 @@ void caml_empty_minor_heap (void)
     clear_table ((struct generic_table *) &caml_ref_table);
     clear_table ((struct generic_table *) &caml_ephe_ref_table);
     clear_table ((struct generic_table *) &caml_custom_table);
-    caml_gc_message (0x02, ">", 0);
+    caml_gc_message (0x02, ">");
     caml_in_minor_collection = 0;
     caml_final_empty_young ();
     CAML_INSTR_TIME (tmr, "minor/finalized");
@@ -488,9 +493,9 @@ static void realloc_generic_table
 (struct generic_table *tbl, asize_t element_size,
  char * msg_intr_int, char *msg_threshold, char *msg_growing, char *msg_error)
 {
-                                            Assert (tbl->ptr == tbl->limit);
-                                            Assert (tbl->limit <= tbl->end);
-                                      Assert (tbl->limit >= tbl->threshold);
+  CAMLassert (tbl->ptr == tbl->limit);
+  CAMLassert (tbl->limit <= tbl->end);
+  CAMLassert (tbl->limit >= tbl->threshold);
 
   if (tbl->base == NULL){
     alloc_generic_table (tbl, caml_minor_heap_wsz / 8, 256,
@@ -508,7 +513,7 @@ static void realloc_generic_table
     tbl->size *= 2;
     sz = (tbl->size + tbl->reserve) * element_size;
     caml_gc_message (0x08, msg_growing, (intnat) sz/1024);
-    tbl->base = (void *) realloc ((char *) tbl->base, sz);
+    tbl->base = caml_stat_resize_noexc (tbl->base, sz);
     if (tbl->base == NULL){
       caml_fatal_error (msg_error);
     }

diff --git a/byterun/misc.c b/byterun/misc.c
index 9d33ac118e17ba024293983e1fc14a0f94049b5d..46e40992b4a83810578a07f543b3a1512c125135 100644 (file)
--- a/byterun/misc.c
+++ b/byterun/misc.c
@@ -53,10 +53,13 @@ void caml_set_fields (value v, unsigned long start, unsigned long filler)
 
 uintnat caml_verb_gc = 0;
 
-void caml_gc_message (int level, char *msg, uintnat arg)
+void caml_gc_message (int level, char *msg, ...)
 {
   if ((caml_verb_gc & level) != 0){
-    fprintf (stderr, msg, arg);
+    va_list ap;
+    va_start(ap, msg);
+    vfprintf (stderr, msg, ap);
+    va_end(ap);
     fflush (stderr);
   }
 }
@@ -81,33 +84,6 @@ 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;
-  uintnat aligned_mem;
-                                                  Assert (modulo < Page_size);
-  raw_mem = (char *) malloc (size + Page_size);
-  if (raw_mem == NULL) return NULL;
-  *block = raw_mem;
-  raw_mem += modulo;                /* Address to be aligned */
-  aligned_mem = (((uintnat) raw_mem / Page_size + 1) * Page_size);
-#ifdef DEBUG
-  {
-    uintnat *p;
-    uintnat *p0 = (void *) *block,
-            *p1 = (void *) (aligned_mem - modulo),
-            *p2 = (void *) (aligned_mem - modulo + size),
-            *p3 = (void *) ((char *) *block + size + Page_size);
-
-    for (p = p0; p < p1; p++) *p = Debug_filler_align;
-    for (p = p1; p < p2; p++) *p = Debug_uninit_align;
-    for (p = p2; p < p3; p++) *p = Debug_filler_align;
-  }
-#endif
-  return (char *) (aligned_mem - modulo);
-}
-
 /* If you change the caml_ext_table* functions, also update
    asmrun/spacetime.c:find_trie_node_from_libunwind. */
 
@@ -118,7 +94,7 @@ void caml_ext_table_init(struct ext_table * tbl, int init_capa)
   tbl->contents = caml_stat_alloc(sizeof(void *) * init_capa);
 }
 
-int caml_ext_table_add(struct ext_table * tbl, void * data)
+int caml_ext_table_add(struct ext_table * tbl, caml_stat_block data)
 {
   int res;
   if (tbl->size >= tbl->capacity) {
@@ -132,7 +108,7 @@ int caml_ext_table_add(struct ext_table * tbl, void * data)
   return res;
 }
 
-void caml_ext_table_remove(struct ext_table * tbl, void * data)
+void caml_ext_table_remove(struct ext_table * tbl, caml_stat_block data)
 {
   int i;
   for (i = 0; i < tbl->size; i++) {
@@ -160,41 +136,50 @@ void caml_ext_table_free(struct ext_table * tbl, int free_entries)
   caml_stat_free(tbl->contents);
 }
 
-CAMLexport char * caml_strdup(const char * s)
-{
-  size_t slen = strlen(s);
-  char * res = caml_stat_alloc(slen + 1);
-  memcpy(res, s, slen + 1);
-  return res;
-}
+/* Integer arithmetic with overflow detection */
 
-CAMLexport char * caml_strconcat(int n, ...)
+#if ! (__GNUC__ >= 5 || Caml_has_builtin(__builtin_mul_overflow))
+CAMLexport int caml_umul_overflow(uintnat a, uintnat b, uintnat * res)
 {
-  va_list args;
-  char * res, * p;
-  size_t len;
-  int i;
-
-  len = 0;
-  va_start(args, n);
-  for (i = 0; i < n; i++) {
-    const char * s = va_arg(args, const char *);
-    len += strlen(s);
-  }
-  va_end(args);
-  res = caml_stat_alloc(len + 1);
-  va_start(args, n);
-  p = res;
-  for (i = 0; i < n; i++) {
-    const char * s = va_arg(args, const char *);
-    size_t l = strlen(s);
-    memcpy(p, s, l);
-    p += l;
-  }
-  va_end(args);
-  *p = 0;
-  return res;
+#define HALF_SIZE (sizeof(uintnat) * 4)
+#define HALF_MASK (((uintnat)1 << HALF_SIZE) - 1)
+#define LOW_HALF(x) ((x) & HALF_MASK)
+#define HIGH_HALF(x) ((x) >> HALF_SIZE)
+  /* Cut in half words */
+  uintnat al = LOW_HALF(a);
+  uintnat ah = HIGH_HALF(a);
+  uintnat bl = LOW_HALF(b);
+  uintnat bh = HIGH_HALF(b);
+  /* Exact product is:
+              al * bl
+           +  ah * bl  << HALF_SIZE
+           +  al * bh  << HALF_SIZE
+           +  ah * bh  << 2*HALF_SIZE
+     Overflow occurs if:
+        ah * bh is not 0, i.e. ah != 0 and bh != 0
+     OR ah * bl has high half != 0
+     OR al * bh has high half != 0
+     OR the sum al * bl + LOW_HALF(ah * bl) << HALF_SIZE
+                        + LOW_HALF(al * bh) << HALF_SIZE overflows.
+     This sum is equal to p = (a * b) modulo word size. */
+  uintnat p = a * b;
+  uintnat p1 = al * bh;
+  uintnat p2 = ah * bl;
+  *res = p;
+  if (ah == 0 && bh == 0) return 0;
+  if (ah != 0 && bh != 0) return 1;
+  if (HIGH_HALF(p1) != 0 || HIGH_HALF(p2) != 0) return 1;
+  p1 <<= HALF_SIZE;
+  p2 <<= HALF_SIZE;
+  p1 += p2;
+  if (p < p1 || p1 < p2) return 1; /* overflow in sums */
+  return 0;
+#undef HALF_SIZE
+#undef HALF_MASK
+#undef LOW_HALF
+#undef HIGH_HALF
 }
+#endif
 
 /* Runtime warnings */
 
@@ -278,11 +263,11 @@ void CAML_INSTR_ATEXIT (void)
     for (p = CAML_INSTR_LOG; p != NULL; p = p->next){
       for (i = 0; i < p->index; i++){
         fprintf (f, "@@ %19ld %19ld %s\n",
-                 Get_time (p, i), Get_time(p, i+1), p->tag[i+1]);
+                 (long) Get_time (p, i), (long) Get_time(p, i+1), p->tag[i+1]);
       }
       if (p->tag[0][0] != '\000'){
         fprintf (f, "@@ %19ld %19ld %s\n",
-                 Get_time (p, 0), Get_time(p, p->index), p->tag[0]);
+                 (long) Get_time (p, 0), (long) Get_time(p, p->index), p->tag[0]);
       }
     }
     fclose (f);

diff --git a/byterun/obj.c b/byterun/obj.c
index b0f764fd14e4b1982618bbaffa9f2032248d2737..4567b8aefca33755621e7fb4834849f742aae05c 100644 (file)
--- a/byterun/obj.c
+++ b/byterun/obj.c
@@ -128,7 +128,8 @@ CAMLprim value caml_obj_dup(value arg)
    before the block is reallocated (since there must be a minor
    collection within each major cycle).
 
-   [newsize] is a value encoding a number of words.
+   [newsize] is a value encoding a number of fields (words, except
+   for float arrays on 32-bit architectures).
 */
 CAMLprim value caml_obj_truncate (value v, value newsize)
 {

diff --git a/byterun/parsing.c b/byterun/parsing.c
index ad1cc8cce653f6c88674341cba1dd891821fb69f..990eb1f6fc1bc2e9179f946edaeebae1fc9aac06 100644 (file)
--- a/byterun/parsing.c
+++ b/byterun/parsing.c
@@ -288,7 +288,7 @@ CAMLprim value caml_parse_engine(struct parser_tables *tables,
     goto loop;
 
   default:                      /* Should not happen */
-    Assert(0);
+    CAMLassert(0);
     return RAISE_PARSE_ERROR;   /* Keeps gcc -Wall happy */
   }
 

diff --git a/byterun/printexc.c b/byterun/printexc.c
index cb32e61b7f59406e9cf349d33b46c393628b848b..735c2994a15a02b8a569ae14d713fa36ca235d17 100644 (file)
--- a/byterun/printexc.c
+++ b/byterun/printexc.c
@@ -27,6 +27,7 @@
 #include "caml/misc.h"
 #include "caml/mlvalues.h"
 #include "caml/printexc.h"
+#include "caml/memory.h"
 
 struct stringbuf {
   char * ptr;
@@ -39,7 +40,7 @@ static void add_char(struct stringbuf *buf, char c)
   if (buf->ptr < buf->end) *(buf->ptr++) = c;
 }
 
-static void add_string(struct stringbuf *buf, char *s)
+static void add_string(struct stringbuf *buf, const char *s)
 {
   int len = strlen(s);
   if (buf->ptr + len > buf->end) len = buf->end - buf->ptr;
@@ -92,7 +93,7 @@ CAMLexport char * caml_format_exception(value exn)
 
   *buf.ptr = 0;              /* Terminate string */
   i = buf.ptr - buf.data + 1;
-  res = malloc(i);
+  res = caml_stat_alloc_noexc(i);
   if (res == NULL) return NULL;
   memmove(res, buf.data, i);
   return res;
@@ -125,7 +126,7 @@ static void default_fatal_uncaught_exception(value exn)
   caml_backtrace_pos = saved_backtrace_pos;
   /* Display the uncaught exception */
   fprintf(stderr, "Fatal error: exception %s\n", msg);
-  free(msg);
+  caml_stat_free(msg);
   /* Display the backtrace if available */
   if (caml_backtrace_active && !DEBUGGER_IN_USE)
     caml_print_exception_backtrace();

diff --git a/byterun/signals.c b/byterun/signals.c
index 6f1811f26c5fca385027bae20bab8cf453674af5..e092e8d0559dda6b9833cc876ee9b71336f1f4fe 100644 (file)
--- a/byterun/signals.c
+++ b/byterun/signals.c
@@ -85,13 +85,13 @@ static intnat volatile caml_async_signal_mode = 0;
 
 static void caml_enter_blocking_section_default(void)
 {
-  Assert (caml_async_signal_mode == 0);
+  CAMLassert (caml_async_signal_mode == 0);
   caml_async_signal_mode = 1;
 }
 
 static void caml_leave_blocking_section_default(void)
 {
-  Assert (caml_async_signal_mode == 1);
+  CAMLassert (caml_async_signal_mode == 1);
   caml_async_signal_mode = 0;
 }
 

diff --git a/byterun/spacetime.c b/byterun/spacetime.c
index fd8b4fd247ec2f9ddb8a7d6b6ba0e08534f1cd3a..2b0bf1dc21f3231724850e236a21fe8d54a35509 100644 (file)
--- a/byterun/spacetime.c
+++ b/byterun/spacetime.c
@@ -12,16 +12,14 @@
 /*                                                                        */
 /**************************************************************************/
 
-#include <assert.h>
 #include "caml/fail.h"
 #include "caml/mlvalues.h"
 
-int ensure_spacetime_dot_o_is_included = 42;
+int caml_ensure_spacetime_dot_o_is_included = 42;
 
 CAMLprim value caml_spacetime_only_works_for_native_code(value foo, ...)
 {
   caml_failwith("Spacetime profiling only works for native code");
-  assert(0);  /* unreachable */
 }
 
 uintnat caml_spacetime_my_profinfo (void)

diff --git a/byterun/stacks.c b/byterun/stacks.c
index 5e7c9a5f78764d601d1dc83541d70f92d3bbc7ff..d6e7f53ce4c2c860a4acc915028bb69f6504159f 100644 (file)
--- a/byterun/stacks.c
+++ b/byterun/stacks.c
@@ -43,7 +43,8 @@ void caml_init_stack (uintnat initial_max_size)
   caml_trapsp = caml_stack_high;
   caml_trap_barrier = caml_stack_high + 1;
   caml_max_stack_size = initial_max_size;
-  caml_gc_message (0x08, "Initial stack limit: %luk bytes\n",
+  caml_gc_message (0x08, "Initial stack limit: %"
+                   ARCH_INTNAT_PRINTF_FORMAT "uk bytes\n",
                    caml_max_stack_size / 1024 * sizeof (value));
 }
 
@@ -53,7 +54,7 @@ void caml_realloc_stack(asize_t required_space)
   value * new_low, * new_high, * new_sp;
   value * p;
 
-  Assert(caml_extern_sp >= caml_stack_low);
+  CAMLassert(caml_extern_sp >= caml_stack_low);
   size = caml_stack_high - caml_stack_low;
   do {
     if (size >= caml_max_stack_size) caml_raise_stack_overflow();
@@ -99,7 +100,8 @@ void caml_change_max_stack_size (uintnat new_max_size)
 
   if (new_max_size < size) new_max_size = size;
   if (new_max_size != caml_max_stack_size){
-    caml_gc_message (0x08, "Changing stack limit to %luk bytes\n",
+    caml_gc_message (0x08, "Changing stack limit to %"
+                     ARCH_INTNAT_PRINTF_FORMAT "uk bytes\n",
                      new_max_size * sizeof (value) / 1024);
   }
   caml_max_stack_size = new_max_size;

diff --git a/byterun/startup.c b/byterun/startup.c
index 4e5583bdec13afb476f89fc6d26088e1eb77ebf1..037f30d07f2a25f046b0438a380cca564ccbbbc3 100644 (file)
--- a/byterun/startup.c
+++ b/byterun/startup.c
@@ -88,21 +88,22 @@ static int read_trailer(int fd, struct exec_trailer *trail)
     return BAD_BYTECODE;
 }
 
-int caml_attempt_open(char **name, struct exec_trailer *trail,
+int caml_attempt_open(char_os **name, struct exec_trailer *trail,
                       int do_open_script)
 {
-  char * truename;
+  char_os * truename;
   int fd;
   int err;
-  char buf [2];
+  char buf [2], * u8;
 
   truename = caml_search_exe_in_path(*name);
-  caml_gc_message(0x100, "Opening bytecode executable %s\n",
-                  (uintnat) truename);
-  fd = open(truename, O_RDONLY | O_BINARY);
+  u8 = caml_stat_strdup_of_os(truename);
+  caml_gc_message(0x100, "Opening bytecode executable %s\n", u8);
+  caml_stat_free(u8);
+  fd = open_os(truename, O_RDONLY | O_BINARY);
   if (fd == -1) {
     caml_stat_free(truename);
-    caml_gc_message(0x100, "Cannot open file\n", 0);
+    caml_gc_message(0x100, "Cannot open file\n");
     return FILE_NOT_FOUND;
   }
   if (!do_open_script) {
@@ -110,7 +111,7 @@ int caml_attempt_open(char **name, struct exec_trailer *trail,
     if (err < 2 || (buf [0] == '#' && buf [1] == '!')) {
       close(fd);
       caml_stat_free(truename);
-      caml_gc_message(0x100, "Rejected #! script\n", 0);
+      caml_gc_message(0x100, "Rejected #! script\n");
       return BAD_BYTECODE;
     }
   }
@@ -118,7 +119,7 @@ int caml_attempt_open(char **name, struct exec_trailer *trail,
   if (err != 0) {
     close(fd);
     caml_stat_free(truename);
-    caml_gc_message(0x100, "Not a bytecode executable\n", 0);
+    caml_gc_message(0x100, "Not a bytecode executable\n");
     return err;
   }
   *name = truename;
@@ -190,6 +191,34 @@ static char * read_section(int fd, struct exec_trailer *trail, char *name)
   return data;
 }
 
+#ifdef _WIN32
+
+static char_os * read_section_to_os(int fd, struct exec_trailer *trail, char *name)
+{
+  int32_t len, wlen;
+  char * data;
+  wchar_t * wdata;
+
+  len = caml_seek_optional_section(fd, trail, name);
+  if (len == -1) return NULL;
+  data = caml_stat_alloc(len + 1);
+  if (read(fd, data, len) != len)
+    caml_fatal_error_arg("Fatal error: error reading section %s\n", name);
+  data[len] = 0;
+  wlen = win_multi_byte_to_wide_char(data, len, NULL, 0);
+  wdata = caml_stat_alloc((wlen + 1)*sizeof(wchar_t));
+  win_multi_byte_to_wide_char(data, len, wdata, wlen);
+  wdata[wlen] = 0;
+  caml_stat_free(data);
+  return wdata;
+}
+
+#else
+
+#define read_section_to_os read_section
+
+#endif
+
 /* Invocation of ocamlrun: 4 cases.
 
    1.  runtime + bytecode
@@ -217,42 +246,42 @@ Algorithm:
 
 /* Parse options on the command line */
 
-static int parse_command_line(char **argv)
+static int parse_command_line(char_os **argv)
 {
   int i, j;
 
-  for(i = 1; argv[i] != NULL && argv[i][0] == '-'; i++) {
+  for(i = 1; argv[i] != NULL && argv[i][0] == _T('-'); i++) {
     switch(argv[i][1]) {
-    case 't':
+    case _T('t'):
       ++ caml_trace_level; /* ignored unless DEBUG mode */
       break;
-    case 'v':
-      if (!strcmp (argv[i], "-version")){
+    case _T('v'):
+      if (!strcmp_os (argv[i], _T("-version"))){
         printf ("The OCaml runtime, version " OCAML_VERSION_STRING "\n");
         exit (0);
-      }else if (!strcmp (argv[i], "-vnum")){
+      }else if (!strcmp_os (argv[i], _T("-vnum"))){
         printf (OCAML_VERSION_STRING "\n");
         exit (0);
       }else{
         caml_verb_gc = 0x001+0x004+0x008+0x010+0x020;
       }
       break;
-    case 'p':
+    case _T('p'):
       for (j = 0; caml_names_of_builtin_cprim[j] != NULL; j++)
         printf("%s\n", caml_names_of_builtin_cprim[j]);
       exit(0);
       break;
-    case 'b':
+    case _T('b'):
       caml_record_backtrace(Val_true);
       break;
-    case 'I':
+    case _T('I'):
       if (argv[i + 1] != NULL) {
         caml_ext_table_add(&caml_shared_libs_path, argv[i + 1]);
         i++;
       }
       break;
     default:
-      caml_fatal_error_arg("Unknown option %s.\n", argv[i]);
+      caml_fatal_error_arg("Unknown option %s.\n", caml_stat_strdup_of_os(argv[i]));
     }
   }
   return i;
@@ -271,20 +300,32 @@ extern void caml_install_invalid_parameter_handler();
 
 #endif
 
-extern int ensure_spacetime_dot_o_is_included;
+extern int caml_ensure_spacetime_dot_o_is_included;
 
 /* Main entry point when loading code from a file */
 
-CAMLexport void caml_main(char **argv)
+CAMLexport void caml_main(char_os **argv)
 {
   int fd, pos;
   struct exec_trailer trail;
   struct channel * chan;
   value res;
-  char * shared_lib_path, * shared_libs, * req_prims;
-  char * exe_name, * proc_self_exe;
+  char * req_prims;
+  char_os * shared_lib_path, * shared_libs;
+  char_os * exe_name, * proc_self_exe;
+
+  caml_ensure_spacetime_dot_o_is_included++;
 
-  ensure_spacetime_dot_o_is_included++;
+  /* Determine options */
+#ifdef DEBUG
+  caml_verb_gc = 0x3F;
+#endif
+  caml_parse_ocamlrunparam();
+#ifdef DEBUG
+  caml_gc_message (-1, "### OCaml runtime: debug mode ###\n");
+#endif
+  if (!caml_startup_aux(/* pooling */ caml_cleanup_on_exit))
+    return;
 
   /* Machine-dependent initialization of the floating-point hardware
      so that it behaves as much as possible as specified in IEEE */
@@ -295,15 +336,8 @@ CAMLexport void caml_main(char **argv)
   caml_init_custom_operations();
   caml_ext_table_init(&caml_shared_libs_path, 8);
   caml_external_raise = NULL;
-  /* Determine options and position of bytecode file */
-#ifdef DEBUG
-  caml_verb_gc = 0x3F;
-#endif
-  caml_parse_ocamlrunparam();
-#ifdef DEBUG
-  caml_gc_message (-1, "### OCaml runtime: debug mode ###\n", 0);
-#endif
 
+  /* Determine position of bytecode file */
   pos = 0;
 
   /* First, try argv[0] (when ocamlrun is called by a bytecode program) */
@@ -329,12 +363,12 @@ CAMLexport void caml_main(char **argv)
     fd = caml_attempt_open(&exe_name, &trail, 1);
     switch(fd) {
     case FILE_NOT_FOUND:
-      caml_fatal_error_arg("Fatal error: cannot find file '%s'\n", argv[pos]);
+      caml_fatal_error_arg("Fatal error: cannot find file '%s'\n", caml_stat_strdup_of_os(argv[pos]));
       break;
     case BAD_BYTECODE:
       caml_fatal_error_arg(
         "Fatal error: the file '%s' is not a bytecode executable file\n",
-        exe_name);
+        caml_stat_strdup_of_os(exe_name));
       break;
     }
   }
@@ -356,8 +390,8 @@ CAMLexport void caml_main(char **argv)
   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");
+  shared_lib_path = read_section_to_os(fd, &trail, "DLPT");
+  shared_libs = read_section_to_os(fd, &trail, "DLLS");
   req_prims = read_section(fd, &trail, "PRIM");
   if (req_prims == NULL) caml_fatal_error("Fatal error: no PRIM section\n");
   caml_build_primitive_table(shared_lib_path, shared_libs, req_prims);
@@ -377,7 +411,7 @@ CAMLexport void caml_main(char **argv)
   caml_sys_init(exe_name, argv + pos);
 #ifdef _WIN32
   /* Start a thread to handle signals */
-  if (caml_secure_getenv("CAMLSIGPIPE"))
+  if (caml_secure_getenv(_T("CAMLSIGPIPE")))
     _beginthread(caml_signal_thread, 4096, NULL);
 #endif
   /* Execute the program */
@@ -400,24 +434,34 @@ CAMLexport value caml_startup_code_exn(
            code_t code, asize_t code_size,
            char *data, asize_t data_size,
            char *section_table, asize_t section_table_size,
-           char **argv)
+           int pooling,
+           char_os **argv)
 {
-  char * cds_file;
-  char * exe_name;
+  char_os * cds_file;
+  char_os * exe_name;
+
+  /* Determine options */
+#ifdef DEBUG
+  caml_verb_gc = 0x3F;
+#endif
+  caml_parse_ocamlrunparam();
+#ifdef DEBUG
+  caml_gc_message (-1, "### OCaml runtime: debug mode ###\n");
+#endif
+  if (caml_cleanup_on_exit)
+    pooling = 1;
+  if (!caml_startup_aux(pooling))
+    return Val_unit;
 
   caml_init_ieee_floats();
 #if defined(_MSC_VER) && __STDC_SECURE_LIB__ >= 200411L
   caml_install_invalid_parameter_handler();
 #endif
   caml_init_custom_operations();
-#ifdef DEBUG
-  caml_verb_gc = 63;
-#endif
-  cds_file = caml_secure_getenv("CAML_DEBUG_FILE");
+  cds_file = caml_secure_getenv(_T("CAML_DEBUG_FILE"));
   if (cds_file != NULL) {
-    caml_cds_file = caml_strdup(cds_file);
+    caml_cds_file = caml_stat_strdup_os(cds_file);
   }
-  caml_parse_ocamlrunparam();
   exe_name = caml_executable_name();
   if (exe_name == NULL) exe_name = caml_search_exe_in_path(argv[0]);
   caml_external_raise = NULL;
@@ -467,13 +511,14 @@ CAMLexport void caml_startup_code(
            code_t code, asize_t code_size,
            char *data, asize_t data_size,
            char *section_table, asize_t section_table_size,
-           char **argv)
+           int pooling,
+           char_os **argv)
 {
   value res;
 
   res = caml_startup_code_exn(code, code_size, data, data_size,
                               section_table, section_table_size,
-                              argv);
+                              pooling, argv);
   if (Is_exception_result(res)) {
     caml_exn_bucket = Extract_exception(res);
     if (caml_debugger_in_use) {

diff --git a/byterun/startup_aux.c b/byterun/startup_aux.c
index 721da61592326ce0e4b1124118d16d4e026d1a27..b913bfaec328d5c956ff96e6092c32e760806de0 100644 (file)
--- a/byterun/startup_aux.c
+++ b/byterun/startup_aux.c
@@ -21,6 +21,11 @@
 #include <stdio.h>
 #include "caml/backtrace.h"
 #include "caml/memory.h"
+#include "caml/callback.h"
+#include "caml/major_gc.h"
+#ifndef NATIVE_CODE
+#include "caml/dynlink.h"
+#endif
 #include "caml/osdeps.h"
 #include "caml/startup_aux.h"
 
@@ -56,51 +61,108 @@ uintnat caml_init_max_stack_wsz = Max_stack_def;
 uintnat caml_init_major_window = Major_window_def;
 extern int caml_parser_trace;
 uintnat caml_trace_level = 0;
+uintnat caml_cleanup_on_exit = 0;
 
 
-static void scanmult (char *opt, uintnat *var)
+static void scanmult (char_os *opt, uintnat *var)
 {
-  char mult = ' ';
+  char_os mult = _T(' ');
   unsigned int val = 1;
-  sscanf (opt, "=%u%c", &val, &mult);
-  sscanf (opt, "=0x%x%c", &val, &mult);
+  sscanf_os (opt, _T("=%u%c"), &val, &mult);
+  sscanf_os (opt, _T("=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;
+  case _T('k'):   *var = (uintnat) val * 1024; break;
+  case _T('M'):   *var = (uintnat) val * (1024 * 1024); break;
+  case _T('G'):   *var = (uintnat) val * (1024 * 1024 * 1024); break;
   default:    *var = (uintnat) val; break;
   }
 }
 
 void caml_parse_ocamlrunparam(void)
 {
-  char *opt = caml_secure_getenv ("OCAMLRUNPARAM");
+  char_os *opt = caml_secure_getenv (_T("OCAMLRUNPARAM"));
   uintnat p;
 
-  if (opt == NULL) opt = caml_secure_getenv ("CAMLRUNPARAM");
+  if (opt == NULL) opt = caml_secure_getenv (_T("CAMLRUNPARAM"));
 
   if (opt != NULL){
-    while (*opt != '\0'){
+    while (*opt != _T('\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 'H': scanmult (opt, &caml_use_huge_pages); 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, &caml_init_major_window); break;
-      case 'W': scanmult (opt, &caml_runtime_warnings); break;
+      case _T('a'): scanmult (opt, &p); caml_set_allocation_policy (p); break;
+      case _T('b'): scanmult (opt, &p); caml_record_backtrace(Val_bool (p)); break;
+      case _T('c'): scanmult (opt, &p); caml_cleanup_on_exit = p; break;
+      case _T('h'): scanmult (opt, &caml_init_heap_wsz); break;
+      case _T('H'): scanmult (opt, &caml_use_huge_pages); break;
+      case _T('i'): scanmult (opt, &caml_init_heap_chunk_sz); break;
+      case _T('l'): scanmult (opt, &caml_init_max_stack_wsz); break;
+      case _T('o'): scanmult (opt, &caml_init_percent_free); break;
+      case _T('O'): scanmult (opt, &caml_init_max_percent_free); break;
+      case _T('p'): scanmult (opt, &p); caml_parser_trace = p; break;
+      case _T('R'): break; /*  see stdlib/hashtbl.mli */
+      case _T('s'): scanmult (opt, &caml_init_minor_heap_wsz); break;
+      case _T('t'): scanmult (opt, &caml_trace_level); break;
+      case _T('v'): scanmult (opt, &caml_verb_gc); break;
+      case _T('w'): scanmult (opt, &caml_init_major_window); break;
+      case _T('W'): scanmult (opt, &caml_runtime_warnings); break;
       }
-      while (*opt != '\0'){
+      while (*opt != _T('\0')){
         if (*opt++ == ',') break;
       }
     }
   }
 }
+
+
+/* The number of outstanding calls to caml_startup */
+static int startup_count = 0;
+
+/* Has the runtime been shut down already? */
+static int shutdown_happened = 0;
+
+
+int caml_startup_aux(int pooling)
+{
+  if (shutdown_happened == 1)
+    caml_fatal_error("Fatal error: caml_startup was called after the runtime "
+                     "was shut down with caml_shutdown");
+
+  /* Second and subsequent calls are ignored,
+     since the runtime has already started */
+  startup_count++;
+  if (startup_count > 1)
+    return 0;
+
+  if (pooling)
+    caml_stat_create_pool();
+
+  return 1;
+}
+
+static void call_registered_value(char* name)
+{
+  value *f = caml_named_value(name);
+  if (f != NULL)
+    caml_callback_exn(*f, Val_unit);
+}
+
+CAMLexport void caml_shutdown(void)
+{
+  if (startup_count <= 0)
+    caml_fatal_error("Fatal error: a call to caml_shutdown has no "
+                     "corresponding call to caml_startup");
+
+  /* Do nothing unless it's the last call remaining */
+  startup_count--;
+  if (startup_count > 0)
+    return;
+
+  call_registered_value("Pervasives.do_at_exit");
+  call_registered_value("Thread.at_shutdown");
+  caml_finalise_heap();
+#ifndef NATIVE_CODE
+  caml_free_shared_libs();
+#endif
+  caml_stat_destroy_pool();
+
+  shutdown_happened = 1;
+}

diff --git a/byterun/str.c b/byterun/str.c
index 38a472e7fa35c0611d254df3a347414d7ed670dc..2eeceb5553da01301feafb1395daa8cb196a6428 100644 (file)
--- a/byterun/str.c
+++ b/byterun/str.c
@@ -23,6 +23,7 @@
 #include <stdarg.h>
 #include "caml/alloc.h"
 #include "caml/fail.h"
+#include "caml/memory.h"
 #include "caml/mlvalues.h"
 #include "caml/misc.h"
 
@@ -31,7 +32,7 @@ CAMLexport mlsize_t caml_string_length(value s)
 {
   mlsize_t temp;
   temp = Bosize_val(s) - 1;
-  Assert (Byte (s, temp - Byte (s, temp)) == 0);
+  CAMLassert (Byte (s, temp - Byte (s, temp)) == 0);
   return temp - Byte (s, temp);
 }
 
@@ -40,7 +41,7 @@ CAMLprim value caml_ml_string_length(value s)
 {
   mlsize_t temp;
   temp = Bosize_val(s) - 1;
-  Assert (Byte (s, temp - Byte (s, temp)) == 0);
+  CAMLassert (Byte (s, temp - Byte (s, temp)) == 0);
   return Val_long(temp - Byte (s, temp));
 }
 
@@ -380,7 +381,7 @@ CAMLprim value caml_bitvect_test(value bv, value n)
 CAMLexport value caml_alloc_sprintf(const char * format, ...)
 {
   va_list args;
-  char buf[64];
+  char buf[128];
   int n;
   value res;
 
@@ -393,19 +394,25 @@ CAMLexport value caml_alloc_sprintf(const char * format, ...)
      excluding the terminating '\0'. */
   n = vsnprintf(buf, sizeof(buf), format, args);
   va_end(args);
-  /* Allocate a Caml string with length "n" as computed by vsnprintf. */
-  res = caml_alloc_string(n);
   if (n < sizeof(buf)) {
     /* All output characters were written to buf, including the
-       terminating '\0'.  Just copy them to the result. */
-    memcpy(String_val(res), buf, n);
+       terminating '\0'.  Allocate a Caml string with length "n"
+       as computed by vsnprintf, and copy the output of vsnprintf into it. */
+    res = caml_alloc_initialized_string(n, buf);
   } else {
+    /* PR#7568: if the format is in the Caml heap, the following
+       caml_alloc_string could move or free the format.  To prevent
+       this, take a copy of the format outside the Caml heap. */
+    char * saved_format = caml_stat_strdup(format);
+    /* Allocate a Caml string with length "n" as computed by vsnprintf. */
+    res = caml_alloc_string(n);
     /* Re-do the formatting, outputting directly in the Caml string.
        Note that caml_alloc_string left room for a '\0' at position n,
        so the size passed to vsnprintf is n+1. */
     va_start(args, format);
-    vsnprintf(String_val(res), n + 1, format, args);
+    vsnprintf((char *)String_val(res), n + 1, saved_format, args);
     va_end(args);
+    caml_stat_free(saved_format);
   }
   return res;
 #else
@@ -422,10 +429,14 @@ CAMLexport value caml_alloc_sprintf(const char * format, ...)
   if (n >= 0 && n <= sizeof(buf)) {
     /* All output characters were written to buf.
        "n" is the actual length of the output.
-       Copy the characters to a Caml string of length n. */
+       Allocate a Caml string of length "n" and copy the characters into it. */
     res = caml_alloc_string(n);
     memcpy(String_val(res), buf, n);
   } else {
+    /* PR#7568: if the format is in the Caml heap, the following
+       caml_alloc_string could move or free the format.  To prevent
+       this, take a copy of the format outside the Caml heap. */
+    char * saved_format = caml_stat_strdup(format);
     /* Determine actual length of output, excluding final '\0' */
     va_start(args, format);
     n = _vscprintf(format, args);
@@ -435,8 +446,9 @@ CAMLexport value caml_alloc_sprintf(const char * format, ...)
        Note that caml_alloc_string left room for a '\0' at position n,
        so the size passed to _vsnprintf is n+1. */
     va_start(args, format);
-    _vsnprintf(String_val(res), n + 1, format, args);
+    _vsnprintf(String_val(res), n + 1, saved_format, args);
     va_end(args);
+    caml_stat_free(saved_format);
   }
   return res;
 #endif

diff --git a/byterun/sys.c b/byterun/sys.c
index 3706e9002d5187cee73973935448d19caf550a54..a46b6be446479b2d625eb58d944d80414807b16c 100644 (file)
--- a/byterun/sys.c
+++ b/byterun/sys.c
@@ -28,6 +28,7 @@
 #include <sys/stat.h>
 #ifdef _WIN32
 #include <io.h> /* for isatty */
+#include <direct.h> /* for _wchdir and _wgetcwd */
 #else
 #include <sys/wait.h>
 #endif
@@ -49,7 +50,6 @@
 #include "caml/debugger.h"
 #include "caml/fail.h"
 #include "caml/gc_ctrl.h"
-#include "caml/instruct.h"
 #include "caml/io.h"
 #include "caml/misc.h"
 #include "caml/mlvalues.h"
@@ -58,6 +58,8 @@
 #include "caml/stacks.h"
 #include "caml/sys.h"
 #include "caml/version.h"
+#include "caml/callback.h"
+#include "caml/startup_aux.h"
 
 static char * error_message(void)
 {
@@ -128,22 +130,33 @@ CAMLprim value caml_sys_exit(value retcode_v)
     intnat heap_chunks = caml_stat_heap_chunks;
     intnat top_heap_words = caml_stat_top_heap_wsz;
     intnat cpct = caml_stat_compactions;
-    caml_gc_message(0x400, "allocated_words: %ld\n", (long)allocated_words);
-    caml_gc_message(0x400, "minor_words: %ld\n", (long) minwords);
-    caml_gc_message(0x400, "promoted_words: %ld\n", (long) prowords);
-    caml_gc_message(0x400, "major_words: %ld\n", (long) majwords);
-    caml_gc_message(0x400, "minor_collections: %d\n", mincoll);
-    caml_gc_message(0x400, "major_collections: %d\n", majcoll);
-    caml_gc_message(0x400, "heap_words: %d\n", heap_words);
-    caml_gc_message(0x400, "heap_chunks: %d\n", heap_chunks);
-    caml_gc_message(0x400, "top_heap_words: %d\n", top_heap_words);
-    caml_gc_message(0x400, "compactions: %d\n", cpct);
+    caml_gc_message(0x400, "allocated_words: %.0f\n", allocated_words);
+    caml_gc_message(0x400, "minor_words: %.0f\n", minwords);
+    caml_gc_message(0x400, "promoted_words: %.0f\n", prowords);
+    caml_gc_message(0x400, "major_words: %.0f\n", majwords);
+    caml_gc_message(0x400, "minor_collections: %"ARCH_INTNAT_PRINTF_FORMAT"d\n",
+                    mincoll);
+    caml_gc_message(0x400, "major_collections: %"ARCH_INTNAT_PRINTF_FORMAT"d\n",
+                    majcoll);
+    caml_gc_message(0x400, "heap_words: %"ARCH_INTNAT_PRINTF_FORMAT"d\n",
+                    heap_words);
+    caml_gc_message(0x400, "heap_chunks: %"ARCH_INTNAT_PRINTF_FORMAT"d\n",
+                    heap_chunks);
+    caml_gc_message(0x400, "top_heap_words: %"ARCH_INTNAT_PRINTF_FORMAT"d\n",
+                    top_heap_words);
+    caml_gc_message(0x400, "compactions: %"ARCH_INTNAT_PRINTF_FORMAT"d\n",
+                    cpct);
   }
 
 #ifndef NATIVE_CODE
   caml_debugger(PROGRAM_EXIT);
 #endif
   CAML_INSTR_ATEXIT ();
+  if (caml_cleanup_on_exit)
+    caml_shutdown();
+#ifdef _WIN32
+  caml_restore_win32_terminal();
+#endif
   CAML_SYS_EXIT(retcode);
   return Val_unit;
 }
@@ -171,17 +184,26 @@ CAMLprim value caml_sys_open(value path, value vflags, value vperm)
 {
   CAMLparam3(path, vflags, vperm);
   int fd, flags, perm;
-  char * p;
+  char_os * p;
+
+#if defined(O_CLOEXEC)
+  flags = O_CLOEXEC;
+#elif defined(_WIN32)
+  flags = _O_NOINHERIT;
+#else
+  flags = 0;
+#endif
 
   caml_sys_check_path(path);
-  p = caml_strdup(String_val(path));
-  flags = caml_convert_flag_list(vflags, sys_open_flags);
+  p = caml_stat_strdup_to_os(String_val(path));
+  flags |= caml_convert_flag_list(vflags, sys_open_flags);
   perm = Int_val(vperm);
   /* open on a named FIFO can block (PR#1533) */
   caml_enter_blocking_section();
   fd = CAML_SYS_OPEN(p, flags, perm);
   /* fcntl on a fd can block (PR#5069)*/
-#if defined(F_SETFD) && defined(FD_CLOEXEC)
+#if defined(F_SETFD) && defined(FD_CLOEXEC) && !defined(_WIN32) \
+  && !defined(O_CLOEXEC)
   if (fd != -1)
     fcntl(fd, F_SETFD, FD_CLOEXEC);
 #endif
@@ -207,17 +229,13 @@ CAMLprim value caml_sys_file_exists(value name)
 #else
   struct stat st;
 #endif
-  char * p;
+  char_os * p;
   int ret;
 
   if (! caml_string_is_c_safe(name)) return Val_false;
-  p = caml_strdup(String_val(name));
+  p = caml_stat_strdup_to_os(String_val(name));
   caml_enter_blocking_section();
-#ifdef _WIN32
-  ret = _stati64(p, &st);
-#else
   ret = CAML_SYS_STAT(p, &st);
-#endif
   caml_leave_blocking_section();
   caml_stat_free(p);
 
@@ -232,17 +250,13 @@ CAMLprim value caml_sys_is_directory(value name)
 #else
   struct stat st;
 #endif
-  char * p;
+  char_os * p;
   int ret;
 
   caml_sys_check_path(name);
-  p = caml_strdup(String_val(name));
+  p = caml_stat_strdup_to_os(String_val(name));
   caml_enter_blocking_section();
-#ifdef _WIN32
-  ret = _stati64(p, &st);
-#else
   ret = CAML_SYS_STAT(p, &st);
-#endif
   caml_leave_blocking_section();
   caml_stat_free(p);
 
@@ -257,10 +271,10 @@ CAMLprim value caml_sys_is_directory(value name)
 CAMLprim value caml_sys_remove(value name)
 {
   CAMLparam1(name);
-  char * p;
+  char_os * p;
   int ret;
   caml_sys_check_path(name);
-  p = caml_strdup(String_val(name));
+  p = caml_stat_strdup_to_os(String_val(name));
   caml_enter_blocking_section();
   ret = CAML_SYS_UNLINK(p);
   caml_leave_blocking_section();
@@ -271,13 +285,13 @@ CAMLprim value caml_sys_remove(value name)
 
 CAMLprim value caml_sys_rename(value oldname, value newname)
 {
-  char * p_old;
-  char * p_new;
+  char_os * p_old;
+  char_os * p_new;
   int ret;
   caml_sys_check_path(oldname);
   caml_sys_check_path(newname);
-  p_old = caml_strdup(String_val(oldname));
-  p_new = caml_strdup(String_val(newname));
+  p_old = caml_stat_strdup_to_os(String_val(oldname));
+  p_new = caml_stat_strdup_to_os(String_val(newname));
   caml_enter_blocking_section();
   ret = CAML_SYS_RENAME(p_old, p_new);
   caml_leave_blocking_section();
@@ -291,10 +305,10 @@ CAMLprim value caml_sys_rename(value oldname, value newname)
 CAMLprim value caml_sys_chdir(value dirname)
 {
   CAMLparam1(dirname);
-  char * p;
+  char_os * p;
   int ret;
   caml_sys_check_path(dirname);
-  p = caml_strdup(String_val(dirname));
+  p = caml_stat_strdup_to_os(String_val(dirname));
   caml_enter_blocking_section();
   ret = CAML_SYS_CHDIR(p);
   caml_leave_blocking_section();
@@ -305,52 +319,66 @@ CAMLprim value caml_sys_chdir(value dirname)
 
 CAMLprim value caml_sys_getcwd(value unit)
 {
-  char buff[4096];
+  char_os buff[4096];
+  char_os * ret;
 #ifdef HAS_GETCWD
-  if (getcwd(buff, sizeof(buff)) == 0) caml_sys_error(NO_ARG);
+  ret = getcwd_os(buff, sizeof(buff)/sizeof(*buff));
 #else
-  if (getwd(buff) == 0) caml_sys_error(NO_ARG);
+  caml_invalid_argument("Sys.getcwd not implemented");
 #endif /* HAS_GETCWD */
-  return caml_copy_string(buff);
+  if (ret == 0) caml_sys_error(NO_ARG);
+  return caml_copy_string_of_os(buff);
 }
 
 CAMLprim value caml_sys_unsafe_getenv(value var)
 {
-  char * res;
+  char_os * res, * p;
 
   if (! caml_string_is_c_safe(var)) caml_raise_not_found();
-  res = CAML_SYS_GETENV(String_val(var));
+  p = caml_stat_strdup_to_os(String_val(var));
+  res = CAML_SYS_GETENV(p);
+  caml_stat_free(p);
   if (res == 0) caml_raise_not_found();
-  return caml_copy_string(res);
+  return caml_copy_string_of_os(res);
 }
 
 CAMLprim value caml_sys_getenv(value var)
 {
-  char * res;
+  char_os * res, * p;
 
   if (! caml_string_is_c_safe(var)) caml_raise_not_found();
-  res = caml_secure_getenv(String_val(var));
+  p = caml_stat_strdup_to_os(String_val(var));
+  res = caml_secure_getenv(p);
+  caml_stat_free(p);
   if (res == 0) caml_raise_not_found();
-  return caml_copy_string(res);
+  return caml_copy_string_of_os(res);
 }
 
-char * caml_exe_name;
-char ** caml_main_argv;
+char_os * caml_exe_name;
+char_os ** caml_main_argv;
 
 CAMLprim value caml_sys_get_argv(value unit)
 {
   CAMLparam0 ();   /* unit is unused */
   CAMLlocal3 (exe_name, argv, res);
-  exe_name = caml_copy_string(caml_exe_name);
-  argv = caml_copy_string_array((char const **) caml_main_argv);
+  exe_name = caml_copy_string_of_os(caml_exe_name);
+  argv = caml_alloc_array((void *)caml_copy_string_of_os, (char const **) caml_main_argv);
   res = caml_alloc_small(2, 0);
   Field(res, 0) = exe_name;
   Field(res, 1) = argv;
   CAMLreturn(res);
 }
 
-void caml_sys_init(char * exe_name, char **argv)
+void caml_sys_init(char_os * exe_name, char_os **argv)
 {
+#ifdef _WIN32
+  /* Initialises the caml_win32_* globals on Windows with the version of
+     Windows which is running */
+  caml_probe_win32_version();
+#if WINDOWS_UNICODE
+  caml_setup_win32_terminal();
+#endif
+#endif
 #ifdef CAML_WITH_CPLUGINS
   caml_cplugins_init(exe_name, argv);
 #endif
@@ -373,13 +401,13 @@ CAMLprim value caml_sys_system_command(value command)
 {
   CAMLparam1 (command);
   int status, retcode;
-  char *buf;
+  char_os *buf;
 
   if (! caml_string_is_c_safe (command)) {
     errno = EINVAL;
     caml_sys_error(command);
   }
-  buf = caml_strdup(String_val(command));
+  buf = caml_stat_strdup_to_os(String_val(command));
   caml_enter_blocking_section ();
   status = CAML_SYS_SYSTEM(buf);
   caml_leave_blocking_section ();
@@ -562,12 +590,12 @@ CAMLprim value caml_sys_read_directory(value path)
   CAMLparam1(path);
   CAMLlocal1(result);
   struct ext_table tbl;
-  char * p;
+  char_os * p;
   int ret;
 
   caml_sys_check_path(path);
   caml_ext_table_init(&tbl, 50);
-  p = caml_strdup(String_val(path));
+  p = caml_stat_strdup_to_os(String_val(path));
   caml_enter_blocking_section();
   ret = CAML_SYS_READ_DIRECTORY(p, &tbl);
   caml_leave_blocking_section();
@@ -614,9 +642,10 @@ value (*caml_cplugins_prim)(int,value,value,value) = NULL;
 
 static struct cplugin_context cplugin_context;
 
-void caml_load_plugin(char *plugin)
+void caml_load_plugin(char_os *plugin)
 {
   void* dll_handle = NULL;
+  char* u8;
 
   dll_handle = caml_dlopen(plugin, DLL_EXECUTABLE, DLL_NOT_GLOBAL);
   if( dll_handle != NULL ){
@@ -629,18 +658,20 @@ void caml_load_plugin(char *plugin)
      caml_dlclose(dll_handle);
    }
   } else {
+   u8 = caml_stat_strdup_of_os(plugin);
    fprintf(stderr, "Cannot load C plugin %s\nReason: %s\n",
-          plugin, caml_dlerror());
+           u8, caml_dlerror());
+   caml_stat_free(u8);
   }
 }
 
-void caml_cplugins_load(char *env_variable)
+void caml_cplugins_load(char_os *env_variable)
 {
-  char *plugins = caml_secure_getenv(env_variable);
+  char_os *plugins = caml_secure_getenv(env_variable);
   if(plugins != NULL){
-    char* curs = plugins;
+    char_os* curs = plugins;
     while(*curs != 0){
-        if(*curs == ','){
+      if(*curs == _T(',')){
           if(curs > plugins){
             *curs = 0;
             caml_load_plugin(plugins);
@@ -653,18 +684,18 @@ void caml_cplugins_load(char *env_variable)
   }
 }
 
-void caml_cplugins_init(char * exe_name, char **argv)
+void caml_cplugins_init(char_os * exe_name, char_os **argv)
 {
   cplugin_context.api_version = CAML_CPLUGIN_CONTEXT_API;
   cplugin_context.prims_bitmap = CAML_CPLUGINS_PRIMS_BITMAP;
   cplugin_context.exe_name = exe_name;
   cplugin_context.argv = argv;
   cplugin_context.ocaml_version = OCAML_VERSION_STRING;
-  caml_cplugins_load("CAML_CPLUGINS");
+  caml_cplugins_load(_T("CAML_CPLUGINS"));
 #ifdef NATIVE_CODE
-  caml_cplugins_load("CAML_NATIVE_CPLUGINS");
+  caml_cplugins_load(_T("CAML_NATIVE_CPLUGINS"));
 #else
-  caml_cplugins_load("CAML_BYTE_CPLUGINS");
+  caml_cplugins_load(_T("CAML_BYTE_CPLUGINS"));
 #endif
 }
 

diff --git a/byterun/terminfo.c b/byterun/terminfo.c
index 05ec87d316f4ac1bd3bb35e78787257106155311..3f3401ee8e68f943b1e7f6fa60f6296a896a0147 100644 (file)
--- a/byterun/terminfo.c
+++ b/byterun/terminfo.c
@@ -64,7 +64,7 @@ CAMLprim value caml_terminfo_setup (value vchan)
     standout = tgetstr ("so", &area_p);
     standend = tgetstr ("se", &area_p);
   }
-  Assert (area_p <= area + 1024);
+  CAMLassert (area_p <= area + 1024);
   if (num_lines == -1 || up == NULL || down == NULL
       || standout == NULL || standend == NULL){
     return Bad_term;

diff --git a/byterun/unix.c b/byterun/unix.c
index a5c5ed45763dc116fd670a73d296826ef511cf54..59882e065d1baa13aa61656bf3074965f8bfb7f7 100644 (file)
--- a/byterun/unix.c
+++ b/byterun/unix.c
@@ -54,6 +54,7 @@
 #include "caml/signals.h"
 #include "caml/sys.h"
 #include "caml/io.h"
+#include "caml/alloc.h"
 
 #ifndef S_ISREG
 #define S_ISREG(mode) (((mode) & S_IFMT) == S_IFREG)
@@ -112,13 +113,13 @@ int caml_write_fd(int fd, int flags, void * buf, int n)
   return retcode;
 }
 
-char * caml_decompose_path(struct ext_table * tbl, char * path)
+caml_stat_string caml_decompose_path(struct ext_table * tbl, char * path)
 {
   char * p, * q;
   size_t n;
 
   if (path == NULL) return NULL;
-  p = caml_strdup(path);
+  p = caml_stat_strdup(path);
   q = p;
   while (1) {
     for (n = 0; q[n] != 0 && q[n] != ':'; n++) /*nothing*/;
@@ -131,9 +132,10 @@ char * caml_decompose_path(struct ext_table * tbl, char * path)
   return p;
 }
 
-char * caml_search_in_path(struct ext_table * path, char * name)
+caml_stat_string caml_search_in_path(struct ext_table * path, const char * name)
 {
-  char * p, * dir, * fullname;
+  const char * p;
+  char * dir, * fullname;
   int i;
   struct stat st;
 
@@ -143,13 +145,13 @@ char * caml_search_in_path(struct ext_table * path, char * name)
   for (i = 0; i < path->size; i++) {
     dir = path->contents[i];
     if (dir[0] == 0) dir = ".";  /* empty path component = current dir */
-    fullname = caml_strconcat(3, dir, "/", name);
+    fullname = caml_stat_strconcat(3, dir, "/", name);
     if (stat(fullname, &st) == 0 && S_ISREG(st.st_mode))
       return fullname;
     caml_stat_free(fullname);
   }
  not_found:
-  return caml_strdup(name);
+  return caml_stat_strdup(name);
 }
 
 #ifdef __CYGWIN__
@@ -157,7 +159,7 @@ char * caml_search_in_path(struct ext_table * path, char * name)
 /* Cygwin needs special treatment because of the implicit ".exe" at the
    end of executable file names */
 
-static int cygwin_file_exists(char * name)
+static int cygwin_file_exists(const char * name)
 {
   int fd;
   /* Cannot use stat() here because it adds ".exe" implicitly */
@@ -167,9 +169,10 @@ static int cygwin_file_exists(char * name)
   return 1;
 }
 
-static char * cygwin_search_exe_in_path(struct ext_table * path, char * name)
+static caml_stat_string cygwin_search_exe_in_path(struct ext_table * path, const char * name)
 {
-  char * p, * dir, * fullname;
+  const char * p;
+  char * dir, * fullname;
   int i;
 
   for (p = name; *p != 0; p++) {
@@ -178,28 +181,28 @@ static char * cygwin_search_exe_in_path(struct ext_table * path, char * name)
   for (i = 0; i < path->size; i++) {
     dir = path->contents[i];
     if (dir[0] == 0) dir = ".";  /* empty path component = current dir */
-    fullname = caml_strconcat(3, dir, "/", name);
+    fullname = caml_stat_strconcat(3, dir, "/", name);
     if (cygwin_file_exists(fullname)) return fullname;
     caml_stat_free(fullname);
-    fullname = caml_strconcat(4, dir, "/", name, ".exe");
+    fullname = caml_stat_strconcat(4, dir, "/", name, ".exe");
     if (cygwin_file_exists(fullname)) return fullname;
     caml_stat_free(fullname);
   }
  not_found:
-  if (cygwin_file_exists(name)) return caml_strdup(name);
-  fullname = caml_strconcat(2, name, ".exe");
+  if (cygwin_file_exists(name)) return caml_stat_strdup(name);
+  fullname = caml_stat_strconcat(2, name, ".exe");
   if (cygwin_file_exists(fullname)) return fullname;
   caml_stat_free(fullname);
-  return caml_strdup(name);
+  return caml_stat_strdup(name);
 }
 
 #endif
 
-char * caml_search_exe_in_path(char * name)
+caml_stat_string caml_search_exe_in_path(const char * name)
 {
   struct ext_table path;
   char * tofree;
-  char * res;
+  caml_stat_string res;
 
   caml_ext_table_init(&path, 8);
   tofree = caml_decompose_path(&path, getenv("PATH"));
@@ -213,12 +216,12 @@ char * caml_search_exe_in_path(char * name)
   return res;
 }
 
-char * caml_search_dll_in_path(struct ext_table * path, char * name)
+caml_stat_string caml_search_dll_in_path(struct ext_table * path, const char * name)
 {
-  char * dllname;
-  char * res;
+  caml_stat_string dllname;
+  caml_stat_string res;
 
-  dllname = caml_strconcat(2, name, ".so");
+  dllname = caml_stat_strconcat(2, name, ".so");
   res = caml_search_in_path(path, dllname);
   caml_stat_free(dllname);
   return res;
@@ -240,12 +243,12 @@ void caml_dlclose(void * handle)
   flexdll_dlclose(handle);
 }
 
-void * caml_dlsym(void * handle, char * name)
+void * caml_dlsym(void * handle, const char * name)
 {
   return flexdll_dlsym(handle, name);
 }
 
-void * caml_globalsym(char * name)
+void * caml_globalsym(const char * name)
 {
   return flexdll_dlsym(flexdll_dlopen(NULL,0), name);
 }
@@ -264,14 +267,10 @@ char * caml_dlerror(void)
 #ifndef RTLD_LOCAL
 #define RTLD_LOCAL 0
 #endif
-#ifndef RTLD_NODELETE
-#define RTLD_NODELETE 0
-#endif
 
 void * caml_dlopen(char * libname, int for_execution, int global)
 {
-  return dlopen(libname, RTLD_NOW | (global ? RTLD_GLOBAL : RTLD_LOCAL)
-                         | RTLD_NODELETE);
+  return dlopen(libname, RTLD_NOW | (global ? RTLD_GLOBAL : RTLD_LOCAL));
   /* Could use RTLD_LAZY if for_execution == 0, but needs testing */
 }
 
@@ -280,7 +279,7 @@ void caml_dlclose(void * handle)
   dlclose(handle);
 }
 
-void * caml_dlsym(void * handle, char * name)
+void * caml_dlsym(void * handle, const char * name)
 {
 #ifdef DL_NEEDS_UNDERSCORE
   char _name[1000] = "_";
@@ -290,7 +289,7 @@ void * caml_dlsym(void * handle, char * name)
   return dlsym(handle, name);
 }
 
-void * caml_globalsym(char * name)
+void * caml_globalsym(const char * name)
 {
 #ifdef RTLD_DEFAULT
   return caml_dlsym(RTLD_DEFAULT, name);
@@ -316,12 +315,12 @@ void caml_dlclose(void * handle)
 {
 }
 
-void * caml_dlsym(void * handle, char * name)
+void * caml_dlsym(void * handle, const char * name)
 {
   return NULL;
 }
 
-void * caml_globalsym(char * name)
+void * caml_globalsym(const char * name)
 {
   return NULL;
 }
@@ -352,7 +351,7 @@ CAMLexport int caml_read_directory(char * dirname, struct ext_table * contents)
     e = readdir(d);
     if (e == NULL) break;
     if (strcmp(e->d_name, ".") == 0 || strcmp(e->d_name, "..") == 0) continue;
-    caml_ext_table_add(contents, caml_strdup(e->d_name));
+    caml_ext_table_add(contents, caml_stat_strdup(e->d_name));
   }
   closedir(d);
   return 0;
@@ -371,15 +370,16 @@ char * caml_executable_name(void)
      to determine the size of the buffer.  Instead, we guess and adjust. */
   namelen = 256;
   while (1) {
-    name = caml_stat_alloc(namelen + 1);
+    name = caml_stat_alloc(namelen);
     retcode = readlink("/proc/self/exe", name, namelen);
     if (retcode == -1) { caml_stat_free(name); return NULL; }
-    if (retcode <= namelen) break;
+    if (retcode < namelen) break;
     caml_stat_free(name);
     if (namelen >= 1024*1024) return NULL; /* avoid runaway and overflow */
     namelen *= 2;
   }
-  /* readlink() does not zero-terminate its result */
+  /* readlink() does not zero-terminate its result.
+     There is room for a final zero since retcode < namelen. */
   name[retcode] = 0;
   /* Make sure that the contents of /proc/self/exe is a regular file.
      (Old Linux kernels return an inode number instead.) */
@@ -401,7 +401,7 @@ char * caml_executable_name(void)
   if (_NSGetExecutablePath(name, &namelen) == 0) return name;
   caml_stat_free(name);
   return NULL;
-    
+
 #else
   return NULL;
 

diff --git a/byterun/weak.c b/byterun/weak.c
index 2b81fa012aa4caa206b43cb42d0293eca1bf9446..2f309f44ea7f00835b5b4a9daf09414c753298fb 100644 (file)
--- a/byterun/weak.c
+++ b/byterun/weak.c
@@ -36,23 +36,27 @@ value caml_ephe_none = (value) &ephe_dummy;
     Outside minor and major heap, x must be black.
 */
 static inline int Is_Dead_during_clean(value x){
-  Assert (x != caml_ephe_none); Assert (caml_gc_phase == Phase_clean);
+  CAMLassert (x != caml_ephe_none);
+  CAMLassert (caml_gc_phase == Phase_clean);
   return Is_block (x) && !Is_young (x) && Is_white_val(x);
 }
 /** The minor heap doesn't have to be marked, outside they should
     already be black
 */
 static inline int Must_be_Marked_during_mark(value x){
-  Assert (x != caml_ephe_none); Assert (caml_gc_phase == Phase_mark);
+  CAMLassert (x != caml_ephe_none);
+  CAMLassert (caml_gc_phase == Phase_mark);
   return Is_block (x) && !Is_young (x);
 }
 #else
 static inline int Is_Dead_during_clean(value x){
-  Assert (x != caml_ephe_none); Assert (caml_gc_phase == Phase_clean);
+  CAMLassert (x != caml_ephe_none);
+  CAMLassert (caml_gc_phase == Phase_clean);
   return Is_block (x) && Is_in_heap (x) && Is_white_val(x);
 }
 static inline int Must_be_Marked_during_mark(value x){
-  Assert (x != caml_ephe_none); Assert (caml_gc_phase == Phase_mark);
+  CAMLassert (x != caml_ephe_none); 
+  CAMLassert (caml_gc_phase == Phase_mark);
   return Is_block (x) && Is_in_heap (x);
 }
 #endif
@@ -115,7 +119,7 @@ CAMLprim value caml_weak_create (value len)
    that is going to disappear is dead and so should trigger a cleaning
  */
 static void do_check_key_clean(value ar, mlsize_t offset){
-                                   Assert ( offset >= 2);
+  CAMLassert ( offset >= 2);
   if (caml_gc_phase == Phase_clean){
     value elt = Field (ar, offset);
     if (elt != caml_ephe_none && Is_Dead_during_clean(elt)){
@@ -158,7 +162,7 @@ static void do_set (value ar, mlsize_t offset, value v)
 CAMLprim value caml_ephe_set_key (value ar, value n, value el)
 {
   mlsize_t offset = Long_val (n) + 2;
-                                                   Assert (Is_in_heap (ar));
+  CAMLassert (Is_in_heap (ar));
   if (offset < 2 || offset >= Wosize_val (ar)){
     caml_invalid_argument ("Weak.set");
   }
@@ -170,7 +174,7 @@ CAMLprim value caml_ephe_set_key (value ar, value n, value el)
 CAMLprim value caml_ephe_unset_key (value ar, value n)
 {
   mlsize_t offset = Long_val (n) + 2;
-                                                   Assert (Is_in_heap (ar));
+  CAMLassert (Is_in_heap (ar));
   if (offset < 2 || offset >= Wosize_val (ar)){
     caml_invalid_argument ("Weak.set");
   }
@@ -182,13 +186,13 @@ CAMLprim value caml_ephe_unset_key (value ar, value n)
 value caml_ephe_set_key_option (value ar, value n, value el)
 {
   mlsize_t offset = Long_val (n) + 2;
-                                                   Assert (Is_in_heap (ar));
+  CAMLassert (Is_in_heap (ar));
   if (offset < 2 || offset >= Wosize_val (ar)){
     caml_invalid_argument ("Weak.set");
   }
   do_check_key_clean(ar,offset);
   if (el != None_val && Is_block (el)){
-                                              Assert (Wosize_val (el) == 1);
+    CAMLassert (Wosize_val (el) == 1);
     do_set (ar, offset, Field (el, 0));
   }else{
     Field (ar, offset) = caml_ephe_none;
@@ -202,7 +206,7 @@ CAMLprim value caml_weak_set (value ar, value n, value el){
 
 CAMLprim value caml_ephe_set_data (value ar, value el)
 {
-                                                   Assert (Is_in_heap (ar));
+  CAMLassert (Is_in_heap (ar));
   if (caml_gc_phase == Phase_clean){
     /* During this phase since we don't know which ephemeron have been
        cleaned we always need to check it. */
@@ -214,21 +218,17 @@ CAMLprim value caml_ephe_set_data (value ar, value el)
 
 CAMLprim value caml_ephe_unset_data (value ar)
 {
-                                                   Assert (Is_in_heap (ar));
+  CAMLassert (Is_in_heap (ar));
   Field (ar, CAML_EPHE_DATA_OFFSET) = caml_ephe_none;
   return Val_unit;
 }
 
-
-#define Setup_for_gc
-#define Restore_after_gc
-
 CAMLprim value caml_ephe_get_key (value ar, value n)
 {
   CAMLparam2 (ar, n);
   mlsize_t offset = Long_val (n) + 2;
   CAMLlocal2 (res, elt);
-                                                   Assert (Is_in_heap (ar));
+  CAMLassert (Is_in_heap (ar));
   if (offset < 2 || offset >= Wosize_val (ar)){
     caml_invalid_argument ("Weak.get_key");
   }
@@ -254,7 +254,7 @@ CAMLprim value caml_ephe_get_data (value ar)
   CAMLparam1 (ar);
   mlsize_t offset = 1;
   CAMLlocal2 (res, elt);
-                                                   Assert (Is_in_heap (ar));
+  CAMLassert (Is_in_heap (ar));
   elt = Field (ar, offset);
   if(caml_gc_phase == Phase_clean) caml_ephe_clean(ar);
   if (elt == caml_ephe_none){
@@ -269,16 +269,13 @@ CAMLprim value caml_ephe_get_data (value ar)
   CAMLreturn (res);
 }
 
-#undef Setup_for_gc
-#undef Restore_after_gc
-
 CAMLprim value caml_ephe_get_key_copy (value ar, value n)
 {
   CAMLparam2 (ar, n);
   mlsize_t offset = Long_val (n) + 2;
   CAMLlocal2 (res, elt);
   value v;  /* Caution: this is NOT a local root. */
-                                                   Assert (Is_in_heap (ar));
+  CAMLassert (Is_in_heap (ar));
   if (offset < 1 || offset >= Wosize_val (ar)){
     caml_invalid_argument ("Weak.get_copy");
   }
@@ -325,7 +322,7 @@ CAMLprim value caml_ephe_get_data_copy (value ar)
   mlsize_t offset = 1;
   CAMLlocal2 (res, elt);
   value v;  /* Caution: this is NOT a local root. */
-                                                   Assert (Is_in_heap (ar));
+  CAMLassert (Is_in_heap (ar));
 
   v = Field (ar, offset);
   if (caml_gc_phase == Phase_clean) caml_ephe_clean(ar);
@@ -364,7 +361,7 @@ CAMLprim value caml_ephe_get_data_copy (value ar)
 CAMLprim value caml_ephe_check_key (value ar, value n)
 {
   mlsize_t offset = Long_val (n) + 2;
-                                                   Assert (Is_in_heap (ar));
+  CAMLassert (Is_in_heap (ar));
   if (offset < 2 || offset >= Wosize_val (ar)){
     caml_invalid_argument ("Weak.check");
   }
@@ -389,8 +386,8 @@ CAMLprim value caml_ephe_blit_key (value ars, value ofs,
   mlsize_t offset_d = Long_val (ofd) + 2;
   mlsize_t length = Long_val (len);
   long i;
-                                                   Assert (Is_in_heap (ars));
-                                                   Assert (Is_in_heap (ard));
+  CAMLassert (Is_in_heap (ars));
+  CAMLassert (Is_in_heap (ard));
   if (offset_s < 1 || offset_s + length > Wosize_val (ars)){
     caml_invalid_argument ("Weak.blit");
   }

diff --git a/byterun/win32.c b/byterun/win32.c
index a69dd5fbd7ad368ef278af24374c036a48a2500c..264ee20160759634cb97583800be2c740e654ed4 100644 (file)
--- a/byterun/win32.c
+++ b/byterun/win32.c
@@ -57,22 +57,27 @@ typedef unsigned int uintptr_t;
 #define _UINTPTR_T_DEFINED
 #endif
 
+unsigned short caml_win32_major = 0;
+unsigned short caml_win32_minor = 0;
+unsigned short caml_win32_build = 0;
+unsigned short caml_win32_revision = 0;
+
 CAMLnoreturn_start
 static void caml_win32_sys_error (int errnum)
 CAMLnoreturn_end;
 
 static void caml_win32_sys_error(int errnum)
 {
-  char buffer[512];
+  wchar_t buffer[512];
   value msg;
   if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_IGNORE_INSERTS,
                     NULL,
                     errnum,
                     0,
                     buffer,
-                    sizeof(buffer),
+                    sizeof(buffer)/sizeof(wchar_t),
                     NULL)) {
-    msg = caml_copy_string(buffer);
+    msg = caml_copy_string_of_utf16(buffer);
   } else {
     msg = caml_alloc_sprintf("unknown error #%d", errnum);
   }
@@ -127,16 +132,16 @@ int caml_write_fd(int fd, int flags, void * buf, int n)
   return retcode;
 }
 
-char * caml_decompose_path(struct ext_table * tbl, char * path)
+wchar_t * caml_decompose_path(struct ext_table * tbl, wchar_t * path)
 {
-  char * p, * q;
+  wchar_t * p, * q;
   int n;
 
   if (path == NULL) return NULL;
-  p = caml_strdup(path);
+  p = caml_stat_wcsdup(path);
   q = p;
   while (1) {
-    for (n = 0; q[n] != 0 && q[n] != ';'; n++) /*nothing*/;
+    for (n = 0; q[n] != 0 && q[n] != L';'; n++) /*nothing*/;
     caml_ext_table_add(tbl, q);
     q = q + n;
     if (*q == 0) break;
@@ -146,11 +151,13 @@ char * caml_decompose_path(struct ext_table * tbl, char * path)
   return p;
 }
 
-char * caml_search_in_path(struct ext_table * path, char * name)
+wchar_t * caml_search_in_path(struct ext_table * path, const wchar_t * name)
 {
-  char * p, * dir, * fullname;
+  wchar_t * dir, * fullname;
+  char * u8;
+  const wchar_t * p;
   int i;
-  struct stat st;
+  struct _stati64 st;
 
   for (p = name; *p != 0; p++) {
     if (*p == '/' || *p == '\\') goto not_found;
@@ -159,38 +166,44 @@ char * caml_search_in_path(struct ext_table * path, char * name)
     dir = path->contents[i];
     if (dir[0] == 0) continue;
          /* not sure what empty path components mean under Windows */
-    fullname = caml_strconcat(3, dir, "\\", name);
-    caml_gc_message(0x100, "Searching %s\n", (uintnat) fullname);
-    if (stat(fullname, &st) == 0 && S_ISREG(st.st_mode))
+    fullname = caml_stat_wcsconcat(3, dir, L"\\", name);
+    u8 = caml_stat_strdup_of_utf16(fullname);
+    caml_gc_message(0x100, "Searching %s\n", u8);
+    caml_stat_free(u8);
+    if (_wstati64(fullname, &st) == 0 && S_ISREG(st.st_mode))
       return fullname;
     caml_stat_free(fullname);
   }
  not_found:
-  caml_gc_message(0x100, "%s not found in search path\n", (uintnat) name);
-  return caml_strdup(name);
+  u8 = caml_stat_strdup_of_utf16(name);
+  caml_gc_message(0x100, "%s not found in search path\n", u8);
+  caml_stat_free(u8);
+  return caml_stat_wcsdup(name);
 }
 
-CAMLexport char * caml_search_exe_in_path(char * name)
+CAMLexport wchar_t * caml_search_exe_in_path(const wchar_t * name)
 {
-  char * fullname, * filepart;
+  wchar_t * fullname, * filepart;
+  char * u8;
   size_t fullnamelen;
   DWORD retcode;
 
-  fullnamelen = strlen(name) + 1;
+  fullnamelen = wcslen(name) + 1;
   if (fullnamelen < 256) fullnamelen = 256;
   while (1) {
-    fullname = caml_stat_alloc(fullnamelen);
+    fullname = caml_stat_alloc(fullnamelen*sizeof(wchar_t));
     retcode = SearchPath(NULL,              /* use system search path */
                          name,
-                         ".exe",            /* add .exe extension if needed */
+                         L".exe",            /* add .exe extension if needed */
                          fullnamelen,
                          fullname,
                          &filepart);
     if (retcode == 0) {
-      caml_gc_message(0x100, "%s not found in search path\n",
-                      (uintnat) name);
+      u8 = caml_stat_strdup_of_utf16(name);
+      caml_gc_message(0x100, "%s not found in search path\n", u8);
+      caml_stat_free(u8);
       caml_stat_free(fullname);
-      return caml_strdup(name);
+      return caml_stat_strdup_os(name);
     }
     if (retcode < fullnamelen)
       return fullname;
@@ -199,12 +212,12 @@ CAMLexport char * caml_search_exe_in_path(char * name)
   }
 }
 
-char * caml_search_dll_in_path(struct ext_table * path, char * name)
+wchar_t * caml_search_dll_in_path(struct ext_table * path, const wchar_t * name)
 {
-  char * dllname;
-  char * res;
+  wchar_t * dllname;
+  wchar_t * res;
 
-  dllname = caml_strconcat(2, name, ".dll");
+  dllname = caml_stat_wcsconcat(2, name, L".dll");
   res = caml_search_in_path(path, dllname);
   caml_stat_free(dllname);
   return res;
@@ -212,12 +225,12 @@ char * caml_search_dll_in_path(struct ext_table * path, char * name)
 
 #ifdef SUPPORT_DYNAMIC_LINKING
 
-void * caml_dlopen(char * libname, int for_execution, int global)
+void * caml_dlopen(wchar_t * libname, int for_execution, int global)
 {
   void *handle;
   int flags = (global ? FLEXDLL_RTLD_GLOBAL : 0);
   if (!for_execution) flags |= FLEXDLL_RTLD_NOEXEC;
-  handle = flexdll_dlopen(libname, flags);
+  handle = flexdll_wdlopen(libname, flags);
   if ((handle != NULL) && ((caml_verb_gc & 0x100) != 0)) {
     flexdll_dump_exports(handle);
     fflush(stdout);
@@ -230,12 +243,12 @@ void caml_dlclose(void * handle)
   flexdll_dlclose(handle);
 }
 
-void * caml_dlsym(void * handle, char * name)
+void * caml_dlsym(void * handle, const char * name)
 {
   return flexdll_dlsym(handle, name);
 }
 
-void * caml_globalsym(char * name)
+void * caml_globalsym(const char * name)
 {
   return flexdll_dlsym(flexdll_dlopen(NULL,0), name);
 }
@@ -247,7 +260,7 @@ char * caml_dlerror(void)
 
 #else
 
-void * caml_dlopen(char * libname, int for_execution, int global)
+void * caml_dlopen(wchar_t * libname, int for_execution, int global)
 {
   return NULL;
 }
@@ -256,12 +269,12 @@ void caml_dlclose(void * handle)
 {
 }
 
-void * caml_dlsym(void * handle, char * name)
+void * caml_dlsym(void * handle, const char * name)
 {
   return NULL;
 }
 
-void * caml_globalsym(char * name)
+void * caml_globalsym(const char * name)
 {
   return NULL;
 }
@@ -315,12 +328,12 @@ sighandler caml_win32_signal(int sig, sighandler action)
 /* Expansion of @responsefile and *? file patterns in the command line */
 
 static int argc;
-static char ** argv;
+static wchar_t ** argv;
 static int argvsize;
 
-static void store_argument(char * arg);
-static void expand_argument(char * arg);
-static void expand_pattern(char * arg);
+static void store_argument(wchar_t * arg);
+static void expand_argument(wchar_t * arg);
+static void expand_pattern(wchar_t * arg);
 
 static void out_of_memory(void)
 {
@@ -328,22 +341,22 @@ static void out_of_memory(void)
   exit(2);
 }
 
-static void store_argument(char * arg)
+static void store_argument(wchar_t * arg)
 {
   if (argc + 1 >= argvsize) {
     argvsize *= 2;
-    argv = (char **) realloc(argv, argvsize * sizeof(char *));
+    argv = (wchar_t **) caml_stat_resize_noexc(argv, argvsize * sizeof(wchar_t *));
     if (argv == NULL) out_of_memory();
   }
   argv[argc++] = arg;
 }
 
-static void expand_argument(char * arg)
+static void expand_argument(wchar_t * arg)
 {
-  char * p;
+  wchar_t * p;
 
   for (p = arg; *p != 0; p++) {
-    if (*p == '*' || *p == '?') {
+    if (*p == L'*' || *p == L'?') {
       expand_pattern(arg);
       return;
     }
@@ -351,43 +364,43 @@ static void expand_argument(char * arg)
   store_argument(arg);
 }
 
-static void expand_pattern(char * pat)
+static void expand_pattern(wchar_t * pat)
 {
-  char * prefix, * p, * name;
+  wchar_t * prefix, * p, * name;
   int handle;
-  struct _finddata_t ffblk;
+  struct _wfinddata_t ffblk;
   size_t i;
 
-  handle = _findfirst(pat, &ffblk);
+  handle = _wfindfirst(pat, &ffblk);
   if (handle == -1) {
     store_argument(pat); /* a la Bourne shell */
     return;
   }
-  prefix = caml_strdup(pat);
+  prefix = caml_stat_wcsdup(pat);
   /* We need to stop at the first directory or drive boundary, because the
    * _findata_t structure contains the filename, not the leading directory. */
-  for (i = strlen(prefix); i > 0; i--) {
+  for (i = wcslen(prefix); i > 0; i--) {
     char c = prefix[i - 1];
-    if (c == '\\' || c == '/' || c == ':') { prefix[i] = 0; break; }
+    if (c == L'\\' || c == L'/' || c == L':') { prefix[i] = 0; break; }
   }
   /* No separator was found, it's a filename pattern without a leading directory. */
   if (i == 0)
     prefix[0] = 0;
   do {
-    name = caml_strconcat(2, prefix, ffblk.name);
+    name = caml_stat_wcsconcat(2, prefix, ffblk.name);
     store_argument(name);
-  } while (_findnext(handle, &ffblk) != -1);
+  } while (_wfindnext(handle, &ffblk) != -1);
   _findclose(handle);
   caml_stat_free(prefix);
 }
 
 
-CAMLexport void caml_expand_command_line(int * argcp, char *** argvp)
+CAMLexport void caml_expand_command_line(int * argcp, wchar_t *** argvp)
 {
   int i;
   argc = 0;
   argvsize = 16;
-  argv = (char **) malloc(argvsize * sizeof(char *));
+  argv = (wchar_t **) caml_stat_alloc_noexc(argvsize * sizeof(wchar_t *));
   if (argv == NULL) out_of_memory();
   for (i = 0; i < *argcp; i++) expand_argument((*argvp)[i]);
   argv[argc] = NULL;
@@ -399,35 +412,35 @@ CAMLexport void caml_expand_command_line(int * argcp, char *** argvp)
    the directory named [dirname].  No entries are added for [.] and [..].
    Return 0 on success, -1 on error; set errno in the case of error. */
 
-int caml_read_directory(char * dirname, struct ext_table * contents)
+int caml_read_directory(wchar_t * dirname, struct ext_table * contents)
 {
   size_t dirnamelen;
-  char * template;
+  wchar_t * template;
 #if _MSC_VER <= 1200
   int h;
 #else
   intptr_t h;
 #endif
-  struct _finddata_t fileinfo;
+  struct _wfinddata_t fileinfo;
 
-  dirnamelen = strlen(dirname);
+  dirnamelen = wcslen(dirname);
   if (dirnamelen > 0 &&
-      (dirname[dirnamelen - 1] == '/'
-       || dirname[dirnamelen - 1] == '\\'
-       || dirname[dirnamelen - 1] == ':'))
-    template = caml_strconcat(2, dirname, "*.*");
+      (dirname[dirnamelen - 1] == L'/'
+       || dirname[dirnamelen - 1] == L'\\'
+       || dirname[dirnamelen - 1] == L':'))
+    template = caml_stat_wcsconcat(2, dirname, L"*.*");
   else
-    template = caml_strconcat(2, dirname, "\\*.*");
-  h = _findfirst(template, &fileinfo);
+    template = caml_stat_wcsconcat(2, dirname, L"\\*.*");
+  h = _wfindfirst(template, &fileinfo);
   if (h == -1) {
     caml_stat_free(template);
     return errno == ENOENT ? 0 : -1;
   }
   do {
-    if (strcmp(fileinfo.name, ".") != 0 && strcmp(fileinfo.name, "..") != 0) {
-      caml_ext_table_add(contents, caml_strdup(fileinfo.name));
+    if (wcscmp(fileinfo.name, L".") != 0 && wcscmp(fileinfo.name, L"..") != 0) {
+      caml_ext_table_add(contents, caml_stat_strdup_of_utf16(fileinfo.name));
     }
-  } while (_findnext(h, &fileinfo) == 0);
+  } while (_wfindnext(h, &fileinfo) == 0);
   _findclose(h);
   caml_stat_free(template);
   return 0;
@@ -439,11 +452,11 @@ int caml_read_directory(char * dirname, struct ext_table * contents)
 
 void caml_signal_thread(void * lpParam)
 {
-  char *endptr;
+  wchar_t *endptr;
   HANDLE h;
   /* Get an hexa-code raw handle through the environment */
   h = (HANDLE) (uintptr_t)
-    strtol(caml_secure_getenv("CAMLSIGPIPE"), &endptr, 16);
+    wcstol(caml_secure_getenv(_T("CAMLSIGPIPE")), &endptr, 16);
   while (1) {
     DWORD numread;
     BOOL ret;
@@ -464,7 +477,7 @@ void caml_signal_thread(void * lpParam)
 
 #endif /* NATIVE_CODE */
 
-#if defined(NATIVE_CODE) && !defined(_WIN64)
+#if defined(NATIVE_CODE)
 
 /* Handling of system stack overflow.
  * Based on code provided by Olivier Andrieu.
@@ -487,7 +500,7 @@ void caml_signal_thread(void * lpParam)
  * exception handler because at this point we are using the page that
  * is to be protected.
  *
- * A solution is to used an alternate stack when restoring the
+ * A solution is to use an alternate stack when restoring the
  * protection. However it's not possible to use _resetstkoflw() then
  * since it determines the stack pointer by calling alloca(): it would
  * try to protect the alternate stack.
@@ -496,29 +509,17 @@ void caml_signal_thread(void * lpParam)
  * caml_raise_exception which switches back to the normal stack, or
  * call caml_fatal_uncaught_exception which terminates the program
  * quickly.
- *
- * NB: The PAGE_GUARD protection is only available on WinNT, not
- * Win9x. There is an equivalent mechanism on Win9x with
- * PAGE_NOACCESS.
- *
- * Currently, does not work under Win64.
  */
 
-static uintnat win32_alt_stack[0x80];
+static uintnat win32_alt_stack[0x100];
 
 static void caml_reset_stack (void *faulting_address)
 {
-  OSVERSIONINFO osi;
   SYSTEM_INFO si;
   DWORD page_size;
   MEMORY_BASIC_INFORMATION mbi;
   DWORD oldprot;
 
-  /* get the os version (Win9x or WinNT ?) */
-  osi.dwOSVersionInfoSize = sizeof osi;
-  if (! GetVersionEx (&osi))
-    goto failed;
-
   /* get the system's page size. */
   GetSystemInfo (&si);
   page_size = si.dwPageSize;
@@ -527,26 +528,17 @@ static void caml_reset_stack (void *faulting_address)
   if (! VirtualQuery (faulting_address, &mbi, sizeof mbi))
     goto failed;
 
-  /* restore the PAGE_GUARD protection on this page */
-  switch (osi.dwPlatformId) {
-  case VER_PLATFORM_WIN32_NT:
-    VirtualProtect (mbi.BaseAddress, page_size,
-                    mbi.Protect | PAGE_GUARD, &oldprot);
-    break;
-  case VER_PLATFORM_WIN32_WINDOWS:
-    VirtualProtect (mbi.BaseAddress, page_size,
-                    PAGE_NOACCESS, &oldprot);
-    break;
-  }
+  VirtualProtect (mbi.BaseAddress, page_size,
+                  mbi.Protect | PAGE_GUARD, &oldprot);
 
  failed:
   caml_raise_stack_overflow();
 }
 
-CAMLextern int caml_is_in_code(void *);
 
+#ifndef _WIN64
 static LONG CALLBACK
-    caml_UnhandledExceptionFilter (EXCEPTION_POINTERS* exn_info)
+    caml_stack_overflow_VEH (EXCEPTION_POINTERS* exn_info)
 {
   DWORD code   = exn_info->ExceptionRecord->ExceptionCode;
   CONTEXT *ctx = exn_info->ContextRecord;
@@ -573,12 +565,58 @@ static LONG CALLBACK
   return EXCEPTION_CONTINUE_SEARCH;
 }
 
-void caml_win32_overflow_detection()
+#else
+extern char *caml_exception_pointer;
+extern value *caml_young_ptr;
+
+/* 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)     \
+|| ((char *)(pc) >= &caml_system__code_begin && \
+    (char *)(pc) <= &caml_system__code_end)     \
+|| (Classify_addr(pc) & In_code_area) )
+extern char caml_system__code_begin, caml_system__code_end;
+
+
+static LONG CALLBACK
+    caml_stack_overflow_VEH (EXCEPTION_POINTERS* exn_info)
+{
+  DWORD code   = exn_info->ExceptionRecord->ExceptionCode;
+  CONTEXT *ctx = exn_info->ContextRecord;
+
+  if (code == EXCEPTION_STACK_OVERFLOW && Is_in_code_area (ctx->Rip))
+    {
+      uintnat faulting_address;
+      uintnat * alt_rsp;
+
+      /* grab the address that caused the fault */
+      faulting_address = exn_info->ExceptionRecord->ExceptionInformation[1];
+
+      /* refresh runtime parameters from registers */
+      caml_exception_pointer =  (char *) ctx->R14;
+      caml_young_ptr         = (value *) ctx->R15;
+
+      /* call caml_reset_stack(faulting_address) using the alternate stack */
+      alt_rsp  = win32_alt_stack + sizeof(win32_alt_stack) / sizeof(uintnat);
+      ctx->Rcx = faulting_address;
+      ctx->Rsp = (uintnat) (alt_rsp - 4 - 1);
+      ctx->Rip = (uintnat) &caml_reset_stack;
+
+      return EXCEPTION_CONTINUE_EXECUTION;
+    }
+
+  return EXCEPTION_CONTINUE_SEARCH;
+}
+#endif /* _WIN64 */
+
+void caml_win32_overflow_detection(void)
 {
-  SetUnhandledExceptionFilter (caml_UnhandledExceptionFilter);
+  AddVectoredExceptionHandler(1, caml_stack_overflow_VEH);
 }
 
-#endif
+#endif /* NATIVE_CODE */
 
 /* Seeding of pseudo-random number generators */
 
@@ -623,14 +661,14 @@ void caml_install_invalid_parameter_handler()
 
 /* Recover executable name  */
 
-char * caml_executable_name(void)
+wchar_t * caml_executable_name(void)
 {
-  char * name;
+  wchar_t * name;
   DWORD namelen, ret;
-  
+
   namelen = 256;
   while (1) {
-    name = caml_stat_alloc(namelen);
+    name = caml_stat_alloc(namelen*sizeof(wchar_t));
     ret = GetModuleFileName(NULL, name, namelen);
     if (ret == 0) { caml_stat_free(name); return NULL; }
     if (ret < namelen) break;
@@ -690,8 +728,189 @@ int caml_snprintf(char * buf, size_t size, const char * format, ...)
 }
 #endif
 
-char *caml_secure_getenv (char const *var)
+wchar_t *caml_secure_getenv (wchar_t const *var)
 {
   /* Win32 doesn't have a notion of setuid bit, so getenv is safe. */
   return CAML_SYS_GETENV (var);
 }
+
+/* The rename() implementation in MSVC's CRT is based on MoveFile()
+   and therefore fails if the new name exists.  This is inconsistent
+   with POSIX and a problem in practice.  Here we reimplement
+   rename() using MoveFileEx() to make it more POSIX-like.
+   There are no official guarantee that the rename operation is atomic,
+   but it is widely believed to be atomic on NTFS. */
+
+int caml_win32_rename(const wchar_t * oldpath, const wchar_t * newpath)
+{
+  /* MOVEFILE_REPLACE_EXISTING: to be closer to POSIX
+     MOVEFILE_COPY_ALLOWED: MoveFile performs a copy if old and new
+       paths are on different devices, so we do the same here for
+       compatibility with the old rename()-based implementation.
+     MOVEFILE_WRITE_THROUGH: not sure it's useful; affects only
+       the case where a copy is done. */
+  if (MoveFileEx(oldpath, newpath,
+                 MOVEFILE_REPLACE_EXISTING | MOVEFILE_WRITE_THROUGH |
+                 MOVEFILE_COPY_ALLOWED)) {
+    return 0;
+  }
+  /* Modest attempt at mapping Win32 error codes to POSIX error codes.
+     The __dosmaperr() function from the CRT does a better job but is
+     generally not accessible. */
+  switch (GetLastError()) {
+  case ERROR_FILE_NOT_FOUND: case ERROR_PATH_NOT_FOUND:
+    errno = ENOENT; break;
+  case ERROR_ACCESS_DENIED: case ERROR_WRITE_PROTECT: case ERROR_CANNOT_MAKE:
+    errno = EACCES; break;
+  case ERROR_CURRENT_DIRECTORY: case ERROR_BUSY:
+    errno = EBUSY; break;
+  case ERROR_NOT_SAME_DEVICE:
+    errno = EXDEV; break;
+  case ERROR_ALREADY_EXISTS:
+    errno = EEXIST; break;
+  default:
+    errno = EINVAL;
+  }
+  return -1;
+}
+
+/* Windows Unicode support */
+static uintnat windows_unicode_enabled = WINDOWS_UNICODE;
+
+/* If [windows_unicode_strict] is non-zero, then illegal UTF-8 characters (on
+   the OCaml side) or illegal UTF-16 characters (on the Windows side) cause an
+   error to be signaled.  What happens then depends on the variable
+   [windows_unicode_fallback].
+
+   If [windows_unicode_strict] is zero, then illegal characters are silently
+   dropped. */
+static uintnat windows_unicode_strict = 1;
+
+/* If [windows_unicode_fallback] is non-zero, then if an error is signaled when
+   translating to UTF-16, the translation is re-done under the assumption that
+   the argument string is encoded in the local codepage. */
+static uintnat windows_unicode_fallback = 1;
+
+CAMLexport int win_multi_byte_to_wide_char(const char *s, int slen, wchar_t *out, int outlen)
+{
+  int retcode;
+
+  CAMLassert (s != NULL);
+
+  if (slen == 0)
+    return 0;
+
+  if (windows_unicode_enabled != 0) {
+    retcode = MultiByteToWideChar(CP_UTF8, windows_unicode_strict ? MB_ERR_INVALID_CHARS : 0, s, slen, out, outlen);
+    if (retcode == 0 && windows_unicode_fallback != 0)
+      retcode = MultiByteToWideChar(CP_THREAD_ACP, 0, s, slen, out, outlen);
+  } else {
+    retcode = MultiByteToWideChar(CP_THREAD_ACP, 0, s, slen, out, outlen);
+  }
+
+  if (retcode == 0)
+    caml_win32_sys_error(GetLastError());
+
+  return retcode;
+}
+
+#ifndef WC_ERR_INVALID_CHARS /* For old versions of Windows we simply ignore the flag */
+#define WC_ERR_INVALID_CHARS 0
+#endif
+
+CAMLexport int win_wide_char_to_multi_byte(const wchar_t *s, int slen, char *out, int outlen)
+{
+  int retcode;
+
+  CAMLassert(s != NULL);
+
+  if (slen == 0)
+    return 0;
+
+  if (windows_unicode_enabled != 0)
+    retcode = WideCharToMultiByte(CP_UTF8, windows_unicode_strict ? WC_ERR_INVALID_CHARS : 0, s, slen, out, outlen, NULL, NULL);
+  else
+    retcode = WideCharToMultiByte(CP_THREAD_ACP, 0, s, slen, out, outlen, NULL, NULL);
+
+  if (retcode == 0)
+    caml_win32_sys_error(GetLastError());
+
+  return retcode;
+}
+
+CAMLexport value caml_copy_string_of_utf16(const wchar_t *s)
+{
+  int retcode, slen;
+  value v;
+
+  slen = wcslen(s);
+  retcode = win_wide_char_to_multi_byte(s, slen, NULL, 0); /* Do not include final NULL */
+  v = caml_alloc_string(retcode);
+  win_wide_char_to_multi_byte(s, slen, String_val(v), retcode);
+
+  return v;
+}
+
+CAMLexport inline wchar_t* caml_stat_strdup_to_utf16(const char *s)
+{
+  wchar_t * ws;
+  int retcode;
+
+  retcode = win_multi_byte_to_wide_char(s, -1, NULL, 0);
+  ws = malloc(retcode * sizeof(*ws));
+  win_multi_byte_to_wide_char(s, -1, ws, retcode);
+
+  return ws;
+}
+
+CAMLexport caml_stat_string caml_stat_strdup_of_utf16(const wchar_t *s)
+{
+  caml_stat_string out;
+  int retcode;
+
+  retcode = win_wide_char_to_multi_byte(s, -1, NULL, 0);
+  out = caml_stat_alloc(retcode);
+  win_wide_char_to_multi_byte(s, -1, out, retcode);
+
+  return out;
+}
+
+void caml_probe_win32_version(void)
+{
+  /* Determine the version of Windows we're running, and cache it */
+  WCHAR fileName[MAX_PATH];
+  DWORD size =
+    GetModuleFileName(GetModuleHandle(L"kernel32"), fileName, MAX_PATH);
+  DWORD dwHandle = 0;
+  BYTE* versionInfo;
+  fileName[size] = 0;
+  size = GetFileVersionInfoSize(fileName, &dwHandle);
+  versionInfo = (BYTE*)malloc(size * sizeof(BYTE));
+  if (GetFileVersionInfo(fileName, 0, size, versionInfo)) {
+    UINT len = 0;
+    VS_FIXEDFILEINFO* vsfi = NULL;
+    VerQueryValue(versionInfo, L"\\", (void**)&vsfi, &len);
+    caml_win32_major = HIWORD(vsfi->dwProductVersionMS);
+    caml_win32_minor = LOWORD(vsfi->dwProductVersionMS);
+    caml_win32_build = HIWORD(vsfi->dwProductVersionLS);
+    caml_win32_revision = LOWORD(vsfi->dwProductVersionLS);
+  }
+  free(versionInfo);
+}
+
+static UINT startup_codepage = 0;
+
+void caml_setup_win32_terminal(void)
+{
+  if (caml_win32_major >= 10) {
+    startup_codepage = GetConsoleOutputCP();
+    if (startup_codepage != CP_UTF8)
+      SetConsoleOutputCP(CP_UTF8);
+  }
+}
+
+void caml_restore_win32_terminal(void)
+{
+  if (startup_codepage != 0)
+    SetConsoleOutputCP(startup_codepage);
+}

diff --git a/config/Makefile-templ b/config/Makefile-templ
index 8b530df2eea359bb81640835b1a2e5f413ec1b87..4797a0ddc6bf4680e57cbf0073466356b0b5fd91 100644 (file)
--- a/config/Makefile-templ
+++ b/config/Makefile-templ
@@ -42,8 +42,8 @@ HASHBANGSCRIPTS=true
 ### Which C compiler to use for the bytecode interpreter.
 ### Performance of the bytecode interpreter is *much* improved
 ### if Gnu CC version 2 is used.
-#BYTECC=gcc
-#BYTECC=cc
+#CC=gcc
+#BYTECFLAGS=
 
 ### Additional compile-time options for $(BYTECC).
 # If using gcc on Intel x86:
@@ -57,9 +57,9 @@ HASHBANGSCRIPTS=true
 ### Additional link-time options for $(BYTECC)
 # To support dynamic loading of shared libraries (they need to look at
 # our own symbols):
-#BYTECCLINKOPTS=-Wl,-E
+#LDFLAGS=-Wl,-E
 # Otherwise:
-#BYTECCLINKOPTS=
+#LDFLAGS=
 
 ### Libraries needed
 # On most platforms:
@@ -99,7 +99,7 @@ RANLIBCMD=ranlib
 #MKSHAREDLIB=gcc -shared -o
 # Compile-time option to $(BYTECC) to add a directory to be searched
 # at run-time for shared libraries
-#BYTECCRPATH=-Wl,-rpath
+#RPATH=-Wl,-rpath
 
 ############# Configuration for the native-code compiler
 
@@ -107,13 +107,11 @@ RANLIBCMD=ranlib
 ### Currently supported:
 ###
 ### i386        Intel Pentium PCs under Linux, *BSD*, NextStep
-### sparc       Sun Sparcstation under SunOS 4.1 or Solaris 2
 ### power       Macintosh under Mac OS X and Linux
 ### arm         ARM under Linux
 ###
 ### Set ARCH=none if your machine is not supported
 #ARCH=i386
-#ARCH=sparc
 #ARCH=power
 #ARCH=arm
 #ARCH=none
@@ -137,20 +135,14 @@ RANLIBCMD=ranlib
 #SYSTEM=bsd
 #SYSTEM=unknown
 
-### Which C compiler to use for the native-code compiler.
-#NATIVECC=cc
-#NATIVECC=gcc
+#NATIVECFLAGS=
 
-### Additional compile-time options for $(NATIVECC).
 # For gcc if cautious:
 #NATIVECCCOMPOPTS=-Wall
 
-### Additional link-time options for $(NATIVECC)
-#NATIVECCLINKOPTS=
-
 # Compile-time option to $(NATIVECC) to add a directory to be searched
 # at run-time for shared libraries
-#NATIVECCRPATH=-Wl,-rpath
+#RPATH=-Wl,-rpath
 
 ### Command and flags to use for assembling ocamlopt-generated code
 #ASM=as
@@ -165,7 +157,7 @@ RANLIBCMD=ranlib
 #ASPPPROFFLAGS=-DPROFILING
 
 ### Whether profiling with gprof is supported
-# If yes: (e.g. x86/Linux, Sparc/Solaris):
+# If yes: (e.g. x86/Linux):
 #PROFILING=true
 # If no:
 #PROFILING=false
@@ -189,18 +181,6 @@ RANLIBCMD=ranlib
 
 OTHERLIBRARIES=unix str num threads graph dynlink bigarray
 
-### Name of the target architecture for the "num" library
-# Known targets:
-#      generic (portable C, works everywhere)
-#      ia32    (Intel x86)
-#      amd64   (AMD Opteron, Athlon64)
-#      ppc     (Power PC)
-#      sparc
-# If you don't know, leave BNG_ARCH=generic, which selects a portable
-# C implementation of these routines.
-BNG_ARCH=generic
-BNG_ASM_LEVEL=1
-
 ### Link-time options to ocamlc or ocamlopt for linking with POSIX threads
 # Needed for the "systhreads" package
 # Usually:

diff --git a/config/Makefile.mingw b/config/Makefile.mingw
index 2819d5b99d58d438304caee3cddaea589c46e5fa..3fafb0fc4c763198403aec2280cf3e8e802e7131 100644 (file)
--- a/config/Makefile.mingw
+++ b/config/Makefile.mingw
@@ -59,22 +59,25 @@ A=a
 S=s
 SO=s.o
 EXE=.exe
+EMPTY=
+OUTPUTEXE=-o $(EMPTY)
 EXT_DLL=.dll
 EXT_OBJ=.$(O)
+OUTPUTOBJ=-o $(EMPTY)
 EXT_LIB=.$(A)
 EXT_ASM=.$(S)
-MANEXT=1
+PROGRAMS_MAN_SECTION=1
+LIBRARIES_MAN_SECTION=3
 HASHBANGSCRIPTS=false
 PTHREAD_LINK=
 PTHREAD_CAML_LINK=
 X11_INCLUDES=
 X11_LINK=
-BYTECCRPATH=
+RPATH=
 SUPPORTS_SHARED_LIBRARIES=true
 SHAREDCCCOMPOPTS=
 MKSHAREDLIBRPATH=
 NATIVECCPROFOPTS=
-NATIVECCRPATH=
 ASM=$(TOOLPREF)as
 ASPP=$(TOOLPREF)gcc -c
 ASPPPROFFLAGS=
@@ -94,39 +97,36 @@ UNIXLIB=win32unix
 GRAPHLIB=win32graph
 FLAMBDA=false
 WITH_SPACETIME=false
+ENABLE_CALL_COUNTS=false
 WITH_PROFINFO=false
 LIBUNWIND_AVAILABLE=false
 LIBUNWIND_LINK_FLAGS=
-PROFINFO_WIDTH=26
-SAFE_STRING=false
+PROFINFO_WIDTH=0
+FORCE_SAFE_STRING=false
+DEFAULT_SAFE_STRING=true
+WINDOWS_UNICODE=1
 AFL_INSTRUMENT=false
 
 ########## Configuration for the bytecode compiler
 
 ### Which C compiler to use for the bytecode interpreter.
-BYTECC=$(TOOLPREF)gcc -O -mms-bitfields
-BYTECODE_C_COMPILER=$(BYTECC)
-
-### Additional compile-time options for $(BYTECC).  (For static linking.)
+CC=$(TOOLPREF)gcc
+CFLAGS=-O -mms-bitfields -Wall -Wno-unused -fno-tree-vrp
 # -fno-tree-vrp is here to try to work around the Skylake/Kaby lake bug,
 # and only works on GCC 4.2 and later.
-BYTECCCOMPOPTS=-DCAML_NAME_SPACE -Wall -Wno-unused -fno-tree-vrp
+CPPFLAGS=-DCAML_NAME_SPACE -DUNICODE -D_UNICODE -DWINDOWS_UNICODE=$(WINDOWS_UNICODE)
+OCAMLC_CFLAGS=-O -mms-bitfields
 
-### Additional compile-time options for $(BYTECC).  (For debug version.)
 BYTECCDBGCOMPOPTS=-g
 
-### Flag to use to rename object files.  (for debug version.)
-NAME_OBJ_FLAG=-o
-
-### Additional link-time options for $(BYTECC).  (For static linking.)
-BYTECCLINKOPTS=
+LDFLAGS=-municode
 
 ### Libraries needed
-BYTECCLIBS=-lws2_32
-NATIVECCLIBS=-lws2_32
+BYTECCLIBS=-lws2_32 -lversion
+NATIVECCLIBS=-lws2_32 -lversion
 
 ### How to invoke the C preprocessor
-CPP=$(BYTECC) -E
+CPP=cpp
 
 ### Flexlink
 FLEXLINK_CMD=flexlink
@@ -145,12 +145,15 @@ endif
 #   $(FLEXLINK_CMD) $(FLEXLINK_FLAGS) [-exe|-maindll]
 # or OCAML_FLEXLINK overriding will not work (see utils/config.mlp)
 MKDLL=$(FLEXLINK)
-MKEXE=$(FLEXLINK) -exe
+MKEXE=$(MKEXE_ANSI) $(if $(LDFLAGS),-link "$(LDFLAGS)")
 MKEXEDEBUGFLAG=-g
 MKMAINDLL=$(FLEXLINK) -maindll
 
 ### Native command to build ocamlrun.exe without flexlink
-MKEXE_BOOT=$(BYTECC) -o $(1) $(2)
+MKEXE_BOOT=$(CC) $(CFLAGS) $(LDFLAGS) $(OUTPUTEXE)$(1) $(2)
+
+### Native command to build an ANSI executable
+MKEXE_ANSI=$(FLEXLINK) -exe
 
 ### How to build a static library
 MKLIB=rm -f $(1); $(TOOLPREF)ar rc $(1) $(2); $(RANLIB) $(1)
@@ -180,28 +183,14 @@ MODEL=default
 ### Name of operating system family for the native-code compiler.
 SYSTEM=mingw
 
-### Which C compiler to use for the native-code compiler.
-NATIVECC=$(BYTECC)
-NATIVE_C_COMPILER=$(NATIVECC)
-
-### Additional compile-time options for $(NATIVECC).
-# -fno-tree-vrp is here to try to work around the Skylake/Kaby lake bug,
-# and only works on GCC 4.2 and later.
-NATIVECCCOMPOPTS=-DCAML_NAME_SPACE -Wall -Wno-unused -fno-tree-vrp
-
-### Additional link-time options for $(NATIVECC)
-NATIVECCLINKOPTS=
+OCAMLOPT_CFLAGS=-O -mms-bitfields
 
 ### Build partially-linked object file
-PACKLD=$(TOOLPREF)ld -r $(NATIVECCLINKOPTS) -o # must have a space after '-o'
+PACKLD=$(TOOLPREF)ld -r -o # must have a space after '-o'
 
 ############# Configuration for the contributed libraries
 
-OTHERLIBRARIES=win32unix str num win32graph dynlink bigarray systhreads
-
-### Name of the target architecture for the "num" library
-BNG_ARCH=ia32
-BNG_ASM_LEVEL=1
+OTHERLIBRARIES=win32unix str win32graph dynlink bigarray systhreads
 
 ############# for the testsuite makefiles
 #ml let topdir = "" and wintopdir = "";;
@@ -211,3 +200,4 @@ CYGPATH=cygpath -m
 DIFF=/usr/bin/diff -q --strip-trailing-cr
 SET_LD_PATH=PATH="$(PATH):$(LD_PATH)"
 MAX_TESTSUITE_DIR_RETRIES=1
+FLAT_FLOAT_ARRAY=true

diff --git a/config/Makefile.mingw64 b/config/Makefile.mingw64
index d0b8b5ea93b65bd94167fa278a61ecaf63c02368..0466e63c0b6090a96539e6997b6620aa14e55032 100644 (file)
--- a/config/Makefile.mingw64
+++ b/config/Makefile.mingw64
@@ -59,22 +59,25 @@ A=a
 S=s
 SO=s.o
 EXE=.exe
+EMPTY=
+OUTPUTEXE=-o $(EMPTY)
 EXT_DLL=.dll
 EXT_OBJ=.$(O)
+OUTPUTOBJ=-o $(EMPTY)
 EXT_LIB=.$(A)
 EXT_ASM=.$(S)
-MANEXT=1
+PROGRAMS_MAN_SECTION=1
+LIBRARIES_MAN_SECTION=3
 HASHBANGSCRIPTS=false
 PTHREAD_LINK=
 PTHREAD_CAML_LINK=
 X11_INCLUDES=
 X11_LINK=
-BYTECCRPATH=
+RPATH=
 SUPPORTS_SHARED_LIBRARIES=true
 SHAREDCCCOMPOPTS=
 MKSHAREDLIBRPATH=
 NATIVECCPROFOPTS=
-NATIVECCRPATH=
 ASM=$(TOOLPREF)as
 ASPP=$(TOOLPREF)gcc -c
 ASPPPROFFLAGS=
@@ -95,38 +98,35 @@ GRAPHLIB=win32graph
 FLAMBDA=false
 WITH_PROFINFO=false
 WITH_SPACETIME=false
+ENABLE_CALL_COUNTS=false
 LIBUNWIND_AVAILABLE=false
 LIBUNWIND_LINK_FLAGS=
-PROFINFO_WIDTH=26
-SAFE_STRING=false
+PROFINFO_WIDTH=0
+FORCE_SAFE_STRING=false
+DEFAULT_SAFE_STRING=true
+WINDOWS_UNICODE=1
 AFL_INSTRUMENT=false
 
 ########## Configuration for the bytecode compiler
 
 ### Which C compiler to use for the bytecode interpreter.
-BYTECC=$(TOOLPREF)gcc -O -mms-bitfields
-BYTECODE_C_COMPILER=$(BYTECC)
-
-### Additional compile-time options for $(BYTECC).  (For static linking.)
+CC=$(TOOLPREF)gcc
+CFLAGS=-O -mms-bitfields -Wall -Wno-unused -fno-tree-vrp
 # -fno-tree-vrp is here to try to work around the Skylake/Kaby lake bug,
 # and only works on GCC 4.2 and later.
-BYTECCCOMPOPTS=-DCAML_NAME_SPACE -Wall -Wno-unused -fno-tree-vrp
+CPPFLAGS=-DCAML_NAME_SPACE -DUNICODE -D_UNICODE -DWINDOWS_UNICODE=$(WINDOWS_UNICODE)
+OCAMLC_CFLAGS=-O -mms-bitfields
 
-### Additional compile-time options for $(BYTECC).  (For debug version.)
 BYTECCDBGCOMPOPTS=-g
 
-### Flag to use to rename object files.  (for debug version.)
-NAME_OBJ_FLAG=-o
-
-### Additional link-time options for $(BYTECC).  (For static linking.)
-BYTECCLINKOPTS=
+LDFLAGS=-municode
 
 ### Libraries needed
-BYTECCLIBS=-lws2_32
-NATIVECCLIBS=-lws2_32
+BYTECCLIBS=-lws2_32 -lversion
+NATIVECCLIBS=-lws2_32 -lversion
 
 ### How to invoke the C preprocessor
-CPP=$(BYTECC) -E
+CPP=cpp
 
 ### Flexlink
 FLEXLINK_CMD=flexlink
@@ -145,12 +145,15 @@ endif
 #   $(FLEXLINK_CMD) $(FLEXLINK_FLAGS) [-exe|-maindll]
 # or OCAML_FLEXLINK overriding will not work (see utils/config.mlp)
 MKDLL=$(FLEXLINK)
-MKEXE=$(FLEXLINK) -exe
+MKEXE=$(MKEXE_ANSI) $(if $(LDFLAGS),-link "$(LDFLAGS)")
 MKEXEDEBUGFLAG=-g
 MKMAINDLL=$(FLEXLINK) -maindll
 
 ### Native command to build ocamlrun.exe without flexlink
-MKEXE_BOOT=$(BYTECC) -o $(1) $(2)
+MKEXE_BOOT=$(CC) $(CFLAGS) $(LDFLAGS) $(OUTPUTEXE)$(1) $(2)
+
+### Native command to build an ANSI executable
+MKEXE_ANSI=$(FLEXLINK) -exe
 
 ### How to build a static library
 MKLIB=rm -f $(1); $(TOOLPREF)ar rc $(1) $(2); $(RANLIB) $(1)
@@ -180,28 +183,14 @@ MODEL=default
 ### Name of operating system family for the native-code compiler.
 SYSTEM=mingw64
 
-### Which C compiler to use for the native-code compiler.
-NATIVECC=$(BYTECC)
-NATIVE_C_COMPILER=$(NATIVECC)
-
-### Additional compile-time options for $(NATIVECC).
-# -fno-tree-vrp is here to try to work around the Skylake/Kaby lake bug,
-# and only works on GCC 4.2 and later.
-NATIVECCCOMPOPTS=-DCAML_NAME_SPACE -Wall -Wno-unused -fno-tree-vrp
-
-### Additional link-time options for $(NATIVECC)
-NATIVECCLINKOPTS=
+OCAMLOPT_CFLAGS=-O -mms-bitfields
 
 ### Build partially-linked object file
-PACKLD=$(TOOLPREF)ld -r $(NATIVECCLINKOPTS) -o # must have a space after '-o'
+PACKLD=$(TOOLPREF)ld -r -o # must have a space after '-o'
 
 ############# Configuration for the contributed libraries
 
-OTHERLIBRARIES=win32unix str num win32graph dynlink bigarray systhreads
-
-### Name of the target architecture for the "num" library
-BNG_ARCH=amd64
-BNG_ASM_LEVEL=1
+OTHERLIBRARIES=win32unix str win32graph dynlink bigarray systhreads
 
 ############# for the testsuite makefiles
 #ml let topdir = "" and wintopdir = "";;
@@ -211,3 +200,4 @@ CYGPATH=cygpath -m
 DIFF=/usr/bin/diff -q --strip-trailing-cr
 SET_LD_PATH=PATH="$(PATH):$(LD_PATH)"
 MAX_TESTSUITE_DIR_RETRIES=1
+FLAT_FLOAT_ARRAY=true

diff --git a/config/Makefile.msvc b/config/Makefile.msvc
index d8cd9f8a1f24e63d342492bac97219847736cdcd..9f62368473255f7db1a3057304964eb3b1d10c78 100644 (file)
--- a/config/Makefile.msvc
+++ b/config/Makefile.msvc
@@ -54,21 +54,23 @@ A=lib
 S=asm
 SO=s.obj
 EXE=.exe
+OUTPUTEXE=-Fe
 EXT_DLL=.dll
 EXT_OBJ=.$(O)
+OUTPUTOBJ=-Fo
 EXT_LIB=.$(A)
 EXT_ASM=.$(S)
-MANEXT=1
+PROGRAMS_MAN_SECTION=1
+LIBRARIES_MAN_SECTION=3
 HASHBANGSCRIPTS=false
 PTHREAD_LINK=
 PTHREAD_CAML_LINK=
 X11_INCLUDES=
 X11_LINK=
-BYTECCRPATH=
+RPATH=
 SUPPORTS_SHARED_LIBRARIES=true
 SHAREDCCCOMPOPTS=
 NATIVECCPROFOPTS=
-NATIVECCRPATH=
 ASM=ml -nologo -coff -Cp -c -Fo
 ASPP=
 ASPPPROFFLAGS=
@@ -89,33 +91,30 @@ GRAPHLIB=win32graph
 FLAMBDA=false
 WITH_PROFINFO=false
 WITH_SPACETIME=false
+ENABLE_CALL_COUNTS=false
 LIBUNWIND_AVAILABLE=false
 LIBUNWIND_LINK_FLAGS=
-PROFINFO_WIDTH=26
-SAFE_STRING=false
+PROFINFO_WIDTH=0
+FORCE_SAFE_STRING=false
+DEFAULT_SAFE_STRING=true
+WINDOWS_UNICODE=1
 AFL_INSTRUMENT=false
 
 ########## Configuration for the bytecode compiler
 
 ### Which C compiler to use for the bytecode interpreter.
-BYTECC=cl -nologo -D_CRT_SECURE_NO_DEPRECATE -O2 -Gy- -MD
-BYTECODE_C_COMPILER=$(BYTECC)
-
-### Additional compile-time options for $(BYTECC).  (For static linking.)
-BYTECCCOMPOPTS=-DCAML_NAME_SPACE
-
-### Additional compile-time options for $(BYTECC).  (For debug version.)
+CC=cl
+CFLAGS=-nologo -O2 -Gy- -MD
+CPPFLAGS=-D_CRT_SECURE_NO_DEPRECATE -DCAML_NAME_SPACE -DUNICODE -D_UNICODE -DWINDOWS_UNICODE=$(WINDOWS_UNICODE)
+OCAMLC_CFLAGS=-nologo -O2 -Gy- -MD
+OCAMLC_CPPFLAGS=-D_CRT_SECURE_NO_DEPRECATE
 BYTECCDBGCOMPOPTS=-Zi
 
-### Flag to use to rename object files.  (for debug version.)
-NAME_OBJ_FLAG=-Fo
-
-### Additional link-time options for $(BYTECC).  (For static linking.)
-BYTECCLINKOPTS=
+LDFLAGS=/ENTRY:wmainCRTStartup
 
 ### Libraries needed
-BYTECCLIBS=advapi32.lib ws2_32.lib
-NATIVECCLIBS=advapi32.lib ws2_32.lib
+BYTECCLIBS=advapi32.lib ws2_32.lib version.lib
+NATIVECCLIBS=advapi32.lib ws2_32.lib version.lib
 
 ### How to invoke the C preprocessor
 CPP=cl -nologo -EP
@@ -137,7 +136,7 @@ endif
 #   $(FLEXLINK_CMD) $(FLEXLINK_FLAGS) [-exe|-maindll]
 # or OCAML_FLEXLINK overriding will not work (see utils/config.mlp)
 MKDLL=$(FLEXLINK)
-MKEXE=$(FLEXLINK) -exe
+MKEXE=$(MKEXE_ANSI) $(if $(LDFLAGS),-link "$(LDFLAGS)")
 MKEXEDEBUGFLAG=
 MKMAINDLL=$(FLEXLINK) -maindll
 
@@ -145,9 +144,12 @@ MKMAINDLL=$(FLEXLINK) -maindll
 MERGEMANIFESTEXE=test ! -f $(1).manifest \
                 || mt -nologo -outputresource:$(1) -manifest $(1).manifest \
                    && rm -f $(1).manifest
-MKEXE_BOOT=$(BYTECC) /Fe$(1) $(2) /link /subsystem:console \
+MKEXE_BOOT=$(CC) $(CFLAGS) $(OUTPUTEXE)$(1) $(2) /link /subsystem:console $(LDFLAGS) \
           && ($(MERGEMANIFESTEXE))
 
+### Native command to build an ANSI executable
+MKEXE_ANSI=$(FLEXLINK) -exe
+
 ### How to build a static library
 MKLIB=link -lib -nologo -out:$(1) $(2)
 #ml let mklib out files opts =
@@ -176,14 +178,8 @@ MODEL=default
 ### Name of operating system family for the native-code compiler.
 SYSTEM=win32
 
-### Which C compiler to use for the native-code compiler.
-NATIVECC=cl -nologo -D_CRT_SECURE_NO_DEPRECATE -O2 -Gy- -MD
-NATIVE_C_COMPILER=$(NATIVECC)
-### Additional compile-time options for $(NATIVECC).
-NATIVECCCOMPOPTS=-DCAML_NAME_SPACE
-
-### Additional link-time options for $(NATIVECC)
-NATIVECCLINKOPTS=
+OCAMLOPT_CFLAGS=-nologo -O2 -Gy- -MD
+OCAMLOPT_CPPFLAGS=-D_CRT_SECURE_NO_DEPRECATE
 
 ### Build partially-linked object file
 PACKLD=link -lib -nologo -out:# there must be no space after this '-out:'
@@ -196,11 +192,7 @@ WITH_OCAMLDOC=ocamldoc
 
 ############# Configuration for the contributed libraries
 
-OTHERLIBRARIES=win32unix systhreads str num win32graph dynlink bigarray
-
-### Name of the target architecture for the "num" library
-BNG_ARCH=generic
-BNG_ASM_LEVEL=0
+OTHERLIBRARIES=win32unix systhreads str win32graph dynlink bigarray
 
 ############# for the testsuite makefiles
 #ml let topdir = "" and wintopdir = "";;
@@ -212,3 +204,4 @@ FIND=/usr/bin/find
 SORT=/usr/bin/sort
 SET_LD_PATH=PATH="$(PATH):$(LD_PATH)"
 MAX_TESTSUITE_DIR_RETRIES=1
+FLAT_FLOAT_ARRAY=true

diff --git a/config/Makefile.msvc64 b/config/Makefile.msvc64
index 4e2653aed355c5dbb2deed9d195ba86f8bc817ec..f7b52033fa835e8f00b08403f4e564b3ce09b4c1 100644 (file)
--- a/config/Makefile.msvc64
+++ b/config/Makefile.msvc64
@@ -54,21 +54,23 @@ A=lib
 S=asm
 SO=s.obj
 EXE=.exe
+OUTPUTEXE=-Fe
 EXT_DLL=.dll
 EXT_OBJ=.$(O)
+OUTPUTOBJ=-Fo
 EXT_LIB=.$(A)
 EXT_ASM=.$(S)
-MANEXT=1
+PROGRAMS_MAN_SECTION=1
+LIBRARIES_MAN_SECTION=3
 HASHBANGSCRIPTS=false
 PTHREAD_LINK=
 PTHREAD_CAML_LINK=
 X11_INCLUDES=
 X11_LINK=
-BYTECCRPATH=
+RPATH=
 SUPPORTS_SHARED_LIBRARIES=true
 SHAREDCCCOMPOPTS=
 NATIVECCPROFOPTS=
-NATIVECCRPATH=
 ASM=ml64 -nologo -Cp -c -Fo
 ASPP=
 ASPPPROFFLAGS=
@@ -88,38 +90,36 @@ GRAPHLIB=win32graph
 FLAMBDA=false
 WITH_PROFINFO=false
 WITH_SPACETIME=false
+ENABLE_CALL_COUNTS=false
 LIBUNWIND_AVAILABLE=false
 LIBUNWIND_LINK_FLAGS=
-PROFINFO_WIDTH=26
-SAFE_STRING=false
+PROFINFO_WIDTH=0
+FORCE_SAFE_STRING=false
+DEFAULT_SAFE_STRING=true
+WINDOWS_UNICODE=1
 AFL_INSTRUMENT=false
 
 ########## Configuration for the bytecode compiler
 
 ### Which C compiler to use for the bytecode interpreter.
-BYTECC=cl -nologo -D_CRT_SECURE_NO_DEPRECATE -O2 -Gy- -MD
-BYTECODE_C_COMPILER=$(BYTECC)
+CC=cl
+CFLAGS=-nologo -O2 -Gy- -MD
+CPPFLAGS=-D_CRT_SECURE_NO_DEPRECATE -DCAML_NAME_SPACE -DUNICODE -D_UNICODE -DWINDOWS_UNICODE=$(WINDOWS_UNICODE)
+OCAMLC_CFLAGS=-nologo -O2 -Gy- -MD
+OCAMLC_CPPFLAGS=-D_CRT_SECURE_NO_DEPRECATE
 
-### Additional compile-time options for $(BYTECC).  (For static linking.)
-BYTECCCOMPOPTS=-DCAML_NAME_SPACE
-
-### Additional compile-time options for $(BYTECC).  (For debug version.)
 BYTECCDBGCOMPOPTS=-Zi
 
-### Flag to use to rename object files.  (for debug version.)
-NAME_OBJ_FLAG=-Fo
-
-### Additional link-time options for $(BYTECC).  (For static linking.)
-BYTECCLINKOPTS=
+LDFLAGS=/ENTRY:wmainCRTStartup
 
 ### Libraries needed
 #EXTRALIBS=bufferoverflowu.lib  # for the old PSDK compiler only
 EXTRALIBS=
-BYTECCLIBS=advapi32.lib ws2_32.lib $(EXTRALIBS)
-NATIVECCLIBS=advapi32.lib ws2_32.lib $(EXTRALIBS)
+BYTECCLIBS=advapi32.lib ws2_32.lib version.lib
+NATIVECCLIBS=advapi32.lib ws2_32.lib version.lib
 
 ### How to invoke the C preprocessor
-CPP=cl -nologo -EP
+CPP=$(CC) -nologo -EP
 
 ### Flexlink
 FLEXLINK_CMD=flexlink
@@ -138,7 +138,7 @@ endif
 #   $(FLEXLINK_CMD) $(FLEXLINK_FLAGS) [-exe|-maindll]
 # or OCAML_FLEXLINK overriding will not work (see utils/config.mlp)
 MKDLL=$(FLEXLINK)
-MKEXE=$(FLEXLINK) -exe
+MKEXE=$(MKEXE_ANSI) $(if $(LDFLAGS),-link "$(LDFLAGS)")
 MKEXEDEBUGFLAG=
 MKMAINDLL=$(FLEXLINK) -maindll
 
@@ -146,9 +146,12 @@ MKMAINDLL=$(FLEXLINK) -maindll
 MERGEMANIFESTEXE=test ! -f $(1).manifest \
                 || mt -nologo -outputresource:$(1) -manifest $(1).manifest \
                    && rm -f $(1).manifest
-MKEXE_BOOT=$(BYTECC) /Fe$(1) $(2) /link /subsystem:console \
+MKEXE_BOOT=$(CC) $(CFLAGS) $(OUTPUTEXE)$(1) $(2) /link /subsystem:console $(LDFLAGS) \
            && ($(MERGEMANIFESTEXE))
 
+### Native command to build an ANSI executable
+MKEXE_ANSI=$(FLEXLINK) -exe
+
 ### How to build a static library
 MKLIB=link -lib -nologo -machine:AMD64 /out:$(1) $(2)
 #ml let mklib out files opts =
@@ -178,15 +181,8 @@ MODEL=default
 ### Name of operating system family for the native-code compiler.
 SYSTEM=win64
 
-### Which C compiler to use for the native-code compiler.
-NATIVECC=cl -nologo -O2 -Gy- -MD
-NATIVE_C_COMPILER=$(NATIVECC)
-
-### Additional compile-time options for $(NATIVECC).
-NATIVECCCOMPOPTS=-DCAML_NAME_SPACE
-
-### Additional link-time options for $(NATIVECC)
-NATIVECCLINKOPTS=
+OCAMLOPT_CFLAGS=-nologo -O2 -Gy- -MD
+OCAMLOPT_CPPFLAGS=-D_CRT_SECURE_NO_DEPRECATE
 
 ### Build partially-linked object file
 PACKLD=link -lib -nologo -machine:AMD64 -out:# must have no space after '-out:'
@@ -199,11 +195,7 @@ WITH_OCAMLDOC=ocamldoc
 
 ############# Configuration for the contributed libraries
 
-OTHERLIBRARIES=win32unix systhreads str num win32graph dynlink bigarray
-
-### Name of the target architecture for the "num" library
-BNG_ARCH=generic
-BNG_ASM_LEVEL=0
+OTHERLIBRARIES=win32unix systhreads str win32graph dynlink bigarray
 
 ############# for the testsuite makefiles
 #ml let topdir = "" and wintopdir = "";;
@@ -215,3 +207,4 @@ FIND=/usr/bin/find
 SORT=/usr/bin/sort
 SET_LD_PATH=PATH="$(PATH):$(LD_PATH)"
 MAX_TESTSUITE_DIR_RETRIES=1
+FLAT_FLOAT_ARRAY=true

diff --git a/config/auto-aux/cckind.c b/config/auto-aux/cckind.c
index 7277a7ad66cbfd7f7a5c842338929ee38027a835..203f701f85be3826b1211035d4df52e512b0fc74 100644 (file)
--- a/config/auto-aux/cckind.c
+++ b/config/auto-aux/cckind.c
@@ -25,6 +25,8 @@ icc __INTEL_COMPILER
 clang __clang_major__ __clang_minor__
 #elif defined(__GNUC__) && defined(__GNUC_MINOR__)
 gcc __GNUC__ __GNUC_MINOR__
+#elif defined(__xlc__) && (__xlC__)
+xlc __xlC__ __xlC_ver__
 #else
 unknown
 #endif

diff --git a/config/auto-aux/hasgot b/config/auto-aux/hasgot
index 8b6c690396c4df36a21b004330a656e63aaee982..54281a42da59a708b62e8dac270112f8da5659c7 100755 (executable)
--- a/config/auto-aux/hasgot
+++ b/config/auto-aux/hasgot
@@ -37,9 +37,11 @@ done
  for f in $*; do echo "  $f();"; done
  echo "  return 0; }") >> hasgot.c
 
-if test "$verbose" = yes; then
-  echo "hasgot $args: $cc $opts -o tst hasgot.c $libs" >&2
-  exec $cc $opts -o tst hasgot.c $libs > /dev/null
+cmd="$cc $cflags $opts -o tst hasgot.c $ldflags $libs"
+
+if $verbose; then
+  echo "hasgot $args: $cmd" >&2
+  exec $cmd > /dev/null
 else
-  exec $cc $opts -o tst hasgot.c $libs > /dev/null 2>/dev/null
+  exec $cmd > /dev/null 2>/dev/null
 fi

diff --git a/config/auto-aux/hasgot2 b/config/auto-aux/hasgot2
index 6ec6b904703d09df1729f7cb82227478145ec575..5a3444e0b2d045d16ebf0b0a5c517ec7fe14366b 100644 (file)
--- a/config/auto-aux/hasgot2
+++ b/config/auto-aux/hasgot2
@@ -36,9 +36,11 @@ done
  for f in $*; do echo "  (void) & $f;"; done
  echo "  return 0; }") >> hasgot.c
 
-if test "$verbose" = yes; then
-  echo "hasgot2 $args: $cc $opts -o tst hasgot.c $libs" >&2
-  exec $cc $opts -o tst hasgot.c $libs > /dev/null
+cmd="$cc $cflags $opts -o tst hasgot.c $ldflags $libs"
+
+if $verbose; then
+  echo "hasgot2 $args: $cmd" >&2
+  exec $cmd > /dev/null
 else
-  exec $cc $opts -o tst hasgot.c $libs > /dev/null 2>/dev/null
+  exec $cmd > /dev/null 2>/dev/null
 fi

diff --git a/config/auto-aux/int64align.c b/config/auto-aux/int64align.c
index 5914d1c26704065c14da3ae2e60937a24a06dcec..adf9821e767090b909ef9ef5dbbd420df6e86184 100644 (file)
--- a/config/auto-aux/int64align.c
+++ b/config/auto-aux/int64align.c
@@ -19,18 +19,18 @@
 #include "m.h"
 
 #if defined(ARCH_INT64_TYPE)
-typedef ARCH_INT64_TYPE int64_t;
+typedef ARCH_INT64_TYPE myint64_t;
 #elif SIZEOF_LONG == 8
-typedef long int64_t;
+typedef long myint64_t;
 #elif SIZEOF_LONGLONG == 8
-typedef long long int64_t;
+typedef long long myint64_t;
 #else
 #error "No 64-bit integer type available"
 #endif
 
-volatile int64_t foo;
+volatile myint64_t foo;
 
-void access_int64(volatile int64_t *p)
+void access_int64(volatile myint64_t *p)
 {
   foo = *p;
 }
@@ -51,8 +51,8 @@ int main(void)
   signal(SIGBUS, sig_handler);
 #endif
   if(setjmp(failure) == 0) {
-    access_int64((volatile int64_t *) n);
-    access_int64((volatile int64_t *) (n+1));
+    access_int64((volatile myint64_t *) n);
+    access_int64((volatile myint64_t *) (n+1));
     res = 0;
   } else {
     res = 1;

diff --git a/config/auto-aux/runtest b/config/auto-aux/runtest
index 2950f8014ef55f39e4489dc5089ba924fefe2e4b..c889a0dbd4d07ddb9ab3303b3d994fe23a7a277c 100755 (executable)
--- a/config/auto-aux/runtest
+++ b/config/auto-aux/runtest
@@ -15,10 +15,12 @@
 #*                                                                        *
 #**************************************************************************
 
-if test "$verbose" = yes; then
-echo "runtest: $cc -o tst $* $cclibs" >&2
-$cc -o tst $* $cclibs || exit 100
+cmd="$cc $cflags -o tst $* $ldflags $cclibs"
+
+if $verbose; then
+  echo "runtest: $cmd" >&2
+  $cmd || exit 100
 else
-$cc -o tst $* $cclibs 2> /dev/null || exit 100
+  $cmd 2> /dev/null || exit 100
 fi
 exec ./tst

diff --git a/config/auto-aux/solaris-ld b/config/auto-aux/solaris-ld
index bd0da5ddffbce115ac5c1086e3442fe6c9f0780b..48239ac8d555f8f69a7b7a9cbee640689ee485f2 100644 (file)
--- a/config/auto-aux/solaris-ld
+++ b/config/auto-aux/solaris-ld
@@ -19,5 +19,5 @@
 # Exit code is 0 for Solaris ld, 1 for GNU ld
 
 echo "int main() { return 0; }" > hasgot.c
-$cc -v -o tst hasgot.c 2>&1 | grep -s '^ld:' > /dev/null
+$cc $cflags -v -o tst hasgot.c $ldflags 2>&1 | grep -s '^ld:' > /dev/null
 exit $?

diff --git a/config/auto-aux/tryassemble b/config/auto-aux/tryassemble
index b6d5217c60262423b43f302d75d13f6f3f48bb1e..c07c1361794a8bfa15382b48a1a05f1ca880e1fe 100644 (file)
--- a/config/auto-aux/tryassemble
+++ b/config/auto-aux/tryassemble
@@ -15,19 +15,19 @@
 #*                                                                        *
 #**************************************************************************
 
-if test "$verbose" = yes; then
-echo "tryassemble: $aspp -o tst $*" >&2
-$aspp -o tst $* || exit 100
+if $verbose; then
+  echo "tryassemble: $aspp -o tst $*" >&2
+  $aspp -o tst $* || exit 100
 else
-$aspp -o tst $* 2> /dev/null || exit 100
+  $aspp -o tst $* 2> /dev/null || exit 100
 fi
 
 # test as also (if differs)
 if test "$aspp" != "$as"; then
-if test "$verbose" = yes; then
-echo "tryassemble: $as -o tst $*" >&2
-$as -o tst $* || exit 100
-else
-$as -o tst $* 2> /dev/null || exit 100
-fi
+  if $verbose; then
+    echo "tryassemble: $as -o tst $*" >&2
+    $as -o tst $* || exit 100
+  else
+    $as -o tst $* 2> /dev/null || exit 100
+  fi
 fi

diff --git a/config/auto-aux/trycompile b/config/auto-aux/trycompile
index 845061d7f4c15017b9430d722270455ccbecc7eb..c697413286b53706dc541a1154eacdc1305d8daf 100755 (executable)
--- a/config/auto-aux/trycompile
+++ b/config/auto-aux/trycompile
@@ -15,9 +15,11 @@
 #*                                                                        *
 #**************************************************************************
 
-if test "$verbose" = yes; then
-echo "trycompile: $cc -o tst $* $cclibs" >&2
-$cc -o tst $* $cclibs || exit 100
+cmd="$cc $cflags -o tst $* $ldflags $cclibs"
+
+if $verbose; then
+  echo "trycompile: $cmd" >&2
+  $cmd || exit 100
 else
-$cc -o tst $* $cclibs 2> /dev/null || exit 100
+  $cmd 2> /dev/null || exit 100
 fi

diff --git a/config/m-nt.h b/config/m-nt.h
index 56a50feb794fd658c72b15e466c7d6be23c51ecf..97ae9cf0481976a2e1c3845d7f41dc56b30bd900 100644 (file)
--- a/config/m-nt.h
+++ b/config/m-nt.h
@@ -41,6 +41,11 @@
 #define ARCH_UINT64_TYPE unsigned __int64
 #endif
 #define ARCH_INT64_PRINTF_FORMAT "I64"
+#if _MSC_VER >= 1800
+#define ARCH_SIZET_PRINTF_FORMAT "z"
+#else
+#define ARCH_SIZET_PRINTF_FORMAT "I"
+#endif
 
 #if defined(_MSC_VER) && !defined(__cplusplus)
 #define inline __inline
@@ -56,3 +61,5 @@
 #else
 #define INT64_LITERAL(s) s ## LL
 #endif
+
+#define FLAT_FLOAT_ARRAY

diff --git a/config/s-nt.h b/config/s-nt.h
index 8c28dc5ef32a81bcf903be3eaa5aed68e0905067..c8de2cabec3956124b34caa3ec6f3255770492b3 100644 (file)
--- a/config/s-nt.h
+++ b/config/s-nt.h
@@ -34,6 +34,7 @@
 #define HAS_IPV6
 #define HAS_NICE
 #define SUPPORT_DYNAMIC_LINKING
+#define HAS_EXECVPE
 #if defined(_MSC_VER) && _MSC_VER < 1300
 #define LACKS_SANE_NAN
 #define LACKS_VSCPRINTF

diff --git a/config/s-templ.h b/config/s-templ.h
index 9ab980b21ee357d560dcd856d32a59e64a046b05..6eb971d2e6ac5d900dc2d8b4820b18e8fc69798c 100644 (file)
--- a/config/s-templ.h
+++ b/config/s-templ.h
@@ -92,10 +92,8 @@
 /* Define HAS_MKFIFO if the library provides the mkfifo() function. */
 
 #define HAS_GETCWD
-#define HAS_GETWD
 
 /* Define HAS_GETCWD if the library provides the getcwd() function. */
-/* Define HAS_GETWD if the library provides the getwd() function. */
 
 #define HAS_GETPRIORITY
 

diff --git a/configure b/configure
index e79659954cead82d9c8ce831229d0f4043aee017..2033965545aff9a2df48707ead82dd8702f781d1 100755 (executable)
--- a/configure
+++ b/configure
@@ -24,10 +24,12 @@ bindir=''
 target_bindir=''
 libdir=''
 mandir=''
-manext=1
+programs_man_section=1
+libraries_man_section=3
 host_type=unknown
 target_type=""
 ccoption=''
+cpp='cpp'
 asoption=''
 asppoption=''
 cclibs=''
@@ -43,16 +45,17 @@ disable_libunwind=false
 graph_wanted=yes
 pthread_wanted=yes
 dl_defs=''
-verbose=no
+verbose=false
 with_curses=yes
 debugruntime=false
 with_instrumented_runtime=false
-with_sharedlibs=yes
+with_sharedlibs=true
 partialld="ld -r"
 with_debugger=ocamldebugger
 with_ocamldoc=ocamldoc
 with_frame_pointers=false
 with_spacetime=false
+enable_call_counts=true
 with_profinfo=false
 profinfo_width=0
 no_naked_pointers=false
@@ -60,11 +63,13 @@ native_compiler=true
 TOOLPREF=""
 with_cfi=true
 flambda=false
-safe_string=false
+force_safe_string=false
+default_safe_string=true
 afl_instrument=false
 max_testsuite_dir_retries=0
-with_cplugins=true
+with_cplugins=false
 with_fpic=false
+flat_float_array=true
 
 # Try to turn internationalization off, can cause config.guess to malfunction!
 unset LANG
@@ -119,10 +124,9 @@ while : ; do
         case "$2" in
           */man[1-9ln])
             mandir=`echo $2 | sed -e 's|^\(.*\)/man.$|\1|'`
-            manext=`echo $2 | sed -e 's/^.*\(.\)$/\1/'`;;
+            programs_man_section=`echo $2 | sed -e 's/^.*\(.\)$/\1/'`;;
           *)
-            mandir=$2
-            manext=1;;
+            mandir=$2;;
         esac
         shift;;
     -libunwinddir|--libunwinddir)
@@ -150,7 +154,7 @@ while : ; do
     -no-curses|--no-curses)
         with_curses=no;;
     -no-shared-libs|--no-shared-libs)
-        with_sharedlibs=no;;
+        with_sharedlibs=false;;
     -x11include*|--x11include*)
         x11_include_dir=$2; shift;;
     -x11lib*|--x11lib*)
@@ -167,7 +171,7 @@ while : ; do
     -dllibs*|--dllibs*)
         dllib="$2"; shift;;
     -verbose|--verbose)
-        verbose=yes;;
+        verbose=true;;
     -with-debug-runtime|--with-debug-runtime)
         debugruntime=true;;
     -with-instrumented-runtime|--with-instrumented-runtime)
@@ -184,6 +188,8 @@ while : ; do
         no_naked_pointers=true;;
     -spacetime|--spacetime)
         with_spacetime=true;  with_profinfo=true; profinfo_width=26;;
+    -disable-call-counts|--disable-call-counts)
+        enable_call_counts=false;;
     -reserved-header-bits|--reserved-header-bits)
         with_spacetime=false; with_profinfo=true; profinfo_width=$2;shift
         case $profinfo_width in
@@ -200,12 +206,46 @@ while : ; do
         native_compiler=false;;
     -flambda|--flambda)
         flambda=true;;
+    -with-cplugins|--with-cplugins)
+        with_cplugins=true;;
     -no-cplugins|--no-cplugins)
-        with_cplugins=false;;
+        ;; # Ignored for backward compatibility
     -fPIC|--fPIC)
         with_fpic=true;;
-    -safe-string|--safe-string)
-        safe_string=true;;
+
+    # There are two configure-time string safety options,
+    # -(no-)force-safe-string and -default-(un)safe-string that
+    # interact with a compile-time (un)safe-string option.
+    #
+    # If -force-safe-string is set at configure time, then the compiler
+    # will always enforce that string and bytes are distinct: the
+    # compile-time -unsafe-string option is disabled. This lets us
+    # assume pervasive string immutability, for code optimizations and
+    # in the C layer.
+    #
+    # If -no-force-safe-string is set at configure-time, the compiler
+    # will use the compile-time (un)safe-string option to decide whether
+    # string and bytes are compatible on a per-file basis. The
+    # configure-time options default-(un)safe-string decide which
+    # setting will be chosen by default, if no compile-time option is
+    # explicitly passed.
+    #
+    # The configure-time behavior of OCaml 4.05 and older was equivalent
+    # to -no-force-safe-string -default-unsafe-string. OCaml 4.06
+    # uses -no-force-safe-string -default-safe-string. We
+    # expect -force-safe-string to become the default in the future.
+    -force-safe-string|--force-safe-string)
+        force_safe_string=true;;
+    -no-force-safe-string|--no-force-safe-string)
+        force_safe_string=false;;
+    -default-safe-string|--default-safe-string)
+        default_safe_string=true;;
+    -default-unsafe-string|--default-unsafe-string)
+        default_safe_string=false;;
+    -flat-float-array|--flat-float-array)
+        flat_float_array=true;;
+    -no-flat-float-array|--no-flat-float-array)
+        flat_float_array=false;;
     -afl-instrument)
         afl_instrument=true;;
     *) if echo "$1" | grep -q -e '^--\?[a-zA-Z0-9-]\+='; then
@@ -251,32 +291,54 @@ touch s.h m.h Makefile
 
 # Write options to Makefile
 
+config() {
+# This function hardens the generated Makefile against '#' symbols
+# present in a source path (opam-compiler-conf may pick such directory
+# names if working from a branch named 'PR#4242-answer-all-questions')
+# by escaping them into '\#'.
+
+# When injecting data in Makefiles, it is customary to also escape
+# '$', which get turned into '$$'. However, this transformation is
+# invalid here as some of the variables are meant to be code
+# interpreted by make: for example, passing
+#   --bindir "$(PREFIX)/bin2"
+# is explicitly supported (see "or relative to $(PREFIX)" messages above).
+
+# Finally, it is also impossible for the user to escape the '#' signs
+# before calling this configure script, given that
+# $(PREFIX) is also injected in C code where this escape is invalid
+# -- see the definition of the OCAML_STDLIB_DIR macro below.
+
+  echo "$1=$2" | sed 's/#/\\#/g' >> Makefile
+}
+
 echo "# generated by ./configure $configure_options" >> Makefile
-echo "CONFIGURE_ARGS=$configure_options" >> Makefile
+config CONFIGURE_ARGS "$configure_options"
 
 # Where to install
 
-echo "PREFIX=$prefix" >> Makefile
+config PREFIX "$prefix"
 case "$bindir" in
-  "") echo 'BINDIR=$(PREFIX)/bin' >> Makefile
+  "") config BINDIR '$(PREFIX)/bin'
       bindir="$prefix/bin";;
-   *) echo "BINDIR=$bindir" >> Makefile;;
+   *) config BINDIR "$bindir";;
 esac
 
-echo 'BYTERUN=$(BINDIR)/ocamlrun' >> Makefile
+config BYTERUN '$(BINDIR)/ocamlrun'
 
 case "$libdir" in
-  "") echo 'LIBDIR=$(PREFIX)/lib/ocaml' >> Makefile
+  "") config LIBDIR '$(PREFIX)/lib/ocaml'
       libdir="$prefix/lib/ocaml";;
-   *) echo "LIBDIR=$libdir" >> Makefile;;
+   *) config LIBDIR "$libdir";;
 esac
-echo 'STUBLIBDIR=$(LIBDIR)/stublibs' >> Makefile
+config STUBLIBDIR '$(LIBDIR)/stublibs'
 case "$mandir" in
-  "") echo 'MANDIR=$(PREFIX)/man' >> Makefile
+  "") config MANDIR '$(PREFIX)/man'
       mandir="$prefix/man";;
-   *) echo "MANDIR=$mandir" >> Makefile;;
+   *) config MANDIR "$mandir";;
 esac
-echo "MANEXT=$manext" >> Makefile
+config PROGRAMS_MAN_SECTION "$programs_man_section"
+config LIBRARIES_MAN_SECTION "$libraries_man_section"
 
 # Determine the system type
 
@@ -323,6 +385,10 @@ fi
 
 inf "Using compiler $cc."
 
+# Configure compiler to use in further tests.
+
+export cc verbose
+
 # Determine the C compiler family (GCC, Clang, etc)
 
 ccfamily=`$cc -E cckind.c | grep '^[a-z]' | tr -s ' ' '-'`
@@ -332,12 +398,6 @@ case $? in
          "Make sure the C compiler $cc is properly installed.";;
 esac
 
-# Configure the bytecode compiler
-
-# The BYTECC make variable defines which compiler and options to use
-# to compile C code intended to be used by OCaml bytecode programs.
-# It is used inside OCaml's build system.
-
 # The BYTECODE_C_COMPILER make variable says how the C compiler should be
 # invoked to process a third-party C source file passed to ocamlc
 # when no -cc command-line option has been specified.
@@ -354,12 +414,17 @@ esac
 # in the OCaml distribution and third-party C source files compiled
 # with ocamlc.
 
-bytecc="$cc"
-mkexe="\$(BYTECC)"
+mkexe="\$(CC) \$(CFLAGS) \$(CPPFLAGS) \$(LDFLAGS)"
 mkexedebugflag="-g"
-bytecccompopts=""
-byteccprivatecompopts=""
-bytecclinkopts=""
+common_cflags=""
+common_cppflags=""
+internal_cflags=""
+internal_cppflags=""
+ocamlc_cflags=""
+ocamlc_cppflags=""
+ocamlopt_cflags=""
+ocamlopt_cppflags=""
+ldflags=""
 ostype="Unix"
 exe=""
 iflexdir=""
@@ -384,8 +449,8 @@ esac
 
 case "$ccfamily" in
   clang-*)
-    bytecccompopts="-O2 -fno-strict-aliasing -fwrapv";
-    byteccprivatecompopts="$gcc_warnings";;
+    common_cflags="-O2 -fno-strict-aliasing -fwrapv";
+    internal_cflags="$gcc_warnings";;
   gcc-[012]-*)
     # Some versions known to miscompile OCaml, e,g, 2.7.2.1, some 2.96.
     # Plus: C99 support unknown.
@@ -395,31 +460,26 @@ case "$ccfamily" in
     # Known problems with -fwrapv fixed in 4.2 only.
     wrn "This version of GCC is rather old.  Reducing optimization level."
     wrn "Consider using GCC version 4.2 or above."
-    bytecccompopts="-std=gnu99 -O";
-    byteccprivatecompopts="$gcc_warnings";;
+    common_cflags="-std=gnu99 -O";
+    internal_cflags="$gcc_warnings";;
   gcc-4-*)
-    bytecccompopts="-std=gnu99 -O2 -fno-strict-aliasing -fwrapv \
+    common_cflags="-std=gnu99 -O2 -fno-strict-aliasing -fwrapv \
 -fno-builtin-memcmp";
-    byteccprivatecompopts="$gcc_warnings";;
+    internal_cflags="$gcc_warnings";;
   gcc-*)
-    bytecccompopts="-O2 -fno-strict-aliasing -fwrapv";
-    byteccprivatecompopts="$gcc_warnings";;
+    common_cflags="-O2 -fno-strict-aliasing -fwrapv";
+    internal_cflags="$gcc_warnings";;
   *)
-    bytecccompopts="-O";;
+    common_cflags="-O";;
 esac
 
-byteccprivatecompopts="-DCAML_NAME_SPACE $byteccprivatecompopts"
+internal_cppflags="-DCAML_NAME_SPACE $internal_cppflags"
 
 # Adjust according to target
 
-case "$bytecc,$target" in
-  cc,*-*-nextstep*)
-    # GNU C extensions disabled, but __GNUC__ still defined!
-    bytecccompopts="$bytecccompopts -U__GNUC__ -posix"
-    bytecclinkopts="-posix";;
+case "$cc,$target" in
   *,*-*-rhapsody*)
-    # Almost the same as NeXTStep
-    bytecccompopts="$bytecccompopts -DSHRINKED_GNUC"
+    common_cppflags="-DSHRINKED_GNUC $common_cppflags"
     mathlib="";;
   *,*-*-darwin*)
     mathlib=""
@@ -436,56 +496,56 @@ case "$bytecc,$target" in
     # No -lm library
     mathlib="";;
   *gcc,alpha*-*-osf*)
-    if cc="$bytecc" sh ./hasgot -mieee; then
-      bytecccompopts="-mieee $bytecccompopts";
+    if sh ./hasgot -mieee; then
+      common_cflags="-mieee $common_cflags";
     fi
     # Put code and static data in lower 4GB
-    bytecclinkopts="-Wl,-T,12000000 -Wl,-D,14000000"
+    ldflags="-Wl,-T,12000000 -Wl,-D,14000000"
     # Tell gcc that we can use 32-bit code addresses for threaded code
     echo "#define ARCH_CODE32" >> m.h;;
   cc,alpha*-*-osf*)
-    bytecccompopts="-std1 -ieee";;
+    common_cflags="-std1 -ieee";;
   *gcc*,alpha*-*-linux*)
-    if cc="$bytecc" sh ./hasgot -mieee; then
-      bytecccompopts="-mieee $bytecccompopts";
+    if sh ./hasgot -mieee; then
+      common_cflags="-mieee $common_cflags";
     fi;;
   *,mips-*-irix6*)
     # Turn off warning "unused library"
-    bytecclinkopts="-n32 -Wl,-woff,84";;
+    ldflags="-n32 -Wl,-woff,84";;
   *,alpha*-*-unicos*)
     # For the Cray T3E
-    bytecccompopts="$bytecccompopts -DUMK";;
+    common_cppflags="$common_cppflags -DUMK";;
   *,powerpc-*-aix*)
     # Avoid name-space pollution by requiring Unix98-conformant includes
-    bytecccompopts="$bytecccompopts -D_XOPEN_SOURCE=500 -D_ALL_SOURCE";;
+    common_cppflags="$common_cppflags -D_XOPEN_SOURCE=500 -D_ALL_SOURCE";;
   *,*-*-cygwin*)
     case $target in
       i686-*) flavor=cygwin;;
       x86_64-*) flavor=cygwin64;;
       *) err "unknown cygwin variant";;
     esac
-    bytecccompopts="$bytecccompopts -U_WIN32"
-    if test $with_sharedlibs = yes; then
+    common_cppflags="$common_cppflags -U_WIN32"
+    if $with_sharedlibs; then
       flexlink="flexlink -chain $flavor -merge-manifest -stack 16777216"
       flexdir=`$flexlink -where | tr -d '\015'`
       if test -z "$flexdir"; then
         wrn "flexlink not found: native shared libraries won't be available."
-        with_sharedlibs=no
+        with_sharedlibs=false
       else
         iflexdir="-I\"$flexdir\""
         mkexe="$flexlink -exe"
         mkexedebugflag="-link -g"
       fi
     fi
-    if test $with_sharedlibs = no; then
+    if ! $with_sharedlibs; then
       mkexe="$mkexe -Wl,--stack,16777216"
-      bytecclinkopts="-Wl,--stack,16777216"
+      ldflags="-Wl,--stack,16777216"
     fi
     exe=".exe"
     ostype="Cygwin";;
   *,*-*-mingw*)
     dllccompopt="-DCAML_DLL"
-    if test $with_sharedlibs = yes; then
+    if $with_sharedlibs; then
       case "$target" in
         i686-*-*)   flexlink_chain="mingw";;
         x86_64-*-*) flexlink_chain="mingw64";;
@@ -494,7 +554,7 @@ case "$bytecc,$target" in
       flexdir=`$flexlink -where`
       if test -z "$flexdir"; then
         wrn "flexlink not found: native shared libraries won't be available."
-        with_sharedlibs=no
+        with_sharedlibs=false
       else
         iflexdir="-I\"$flexdir\""
         mkexe="$flexlink -exe"
@@ -514,14 +574,13 @@ case "$bytecc,$target" in
     echo "#endif" >> m.h;;
 esac
 
-# Configure compiler to use in further tests.
+# Configure compiler options to use in further tests.
 
-cc="$bytecc $bytecclinkopts"
-export cc cclibs verbose
+export cclibs ldflags
 
 # Check C compiler.
 
-cc="$bytecc $bytecccompopts $byteccprivatecompopts $bytecclinkopts" sh ./runtest ansi.c
+cflags="$common_cflags $internal_cflags" sh ./runtest ansi.c
 case $? in
   0) inf "The C compiler is ISO C99 compliant." ;;
   1) wrn "The C compiler is ANSI / ISO C90 compliant, but not ISO C99" \
@@ -554,7 +613,7 @@ if $cross_compiler; then
           "($ocaml_system_version) doesn't match the version of these\n" \
           "sources ($ocaml_source_version)."
     else
-      echo "CAMLRUN=`./searchpath -p ocamlrun`" >> Makefile
+      config CAMLRUN "`./searchpath -p ocamlrun`"
     fi
   fi
 
@@ -566,14 +625,14 @@ if $cross_compiler; then
       err "While you have an ocamlyacc binary, it cannot be executed" \
           "successfully."
     else
-      echo "CAMLYACC=`./searchpath -p ocamlyacc`" >> Makefile
+      config CAMLYACC "`./searchpath -p ocamlyacc`"
     fi
   fi
 
   if [ -z "$target_bindir" ]; then
     err "Cross-compilation requires -target-bindir."
   else
-    echo "TARGET_BINDIR=$target_bindir" >> Makefile
+    config TARGET_BINDIR "$target_bindir"
   fi
 fi # cross-compiler
 
@@ -719,7 +778,7 @@ case "$target" in
              "64-bit integers. I'm going to assume this architecture has\n" \
              "alignment constraints. That's a safe bet: OCaml will work\n" \
              "even if this architecture has actually no alignment\n" \
-             "constraints." \
+             "constraints."
          echo "#define ARCH_ALIGN_INT64" >> m.h;;
     esac
 esac
@@ -730,11 +789,11 @@ shared_libraries_supported=false
 dl_needs_underscore=false
 sharedcccompopts=''
 mksharedlib='shared-libs-not-available'
-byteccrpath=''
+rpath=''
 mksharedlibrpath=''
 natdynlinkopts=""
 
-if test $with_sharedlibs = "yes"; then
+if $with_sharedlibs; then
   case "$target" in
     *-*-cygwin*)
       mksharedlib="$flexlink"
@@ -745,73 +804,83 @@ if test $with_sharedlibs = "yes"; then
       mkmaindll="$flexlink -maindll"
       shared_libraries_supported=true;;
     alpha*-*-osf*)
-      case "$bytecc" in
+      case "$cc" in
         *gcc*)
           sharedcccompopts="-fPIC"
-          mksharedlib="$bytecc -shared"
-          byteccrpath="-Wl,-rpath,"
+          mksharedlib="$cc -shared"
+          rpath="-Wl,-rpath,"
           mksharedlibrpath="-Wl,-rpath,"
           shared_libraries_supported=true;;
         cc*)
           sharedcccompopts=""
           mksharedlib="ld -shared -expect_unresolved '*'"
-          byteccrpath="-Wl,-rpath,"
+          rpath="-Wl,-rpath,"
           mksharedlibrpath="-rpath "
           shared_libraries_supported=true;;
       esac;;
     *-*-solaris2*)
-      case "$bytecc" in
+      case "$cc" in
         *gcc*)
           sharedcccompopts="-fPIC"
           if sh ./solaris-ld; then
             mksharedlib="ld -G"
-            byteccrpath="-R"
+            rpath="-R"
             mksharedlibrpath="-R"
           else
-            mksharedlib="$bytecc -shared"
-            bytecclinkopts="$bytecclinkopts -Wl,-E"
+            mksharedlib="$cc -shared"
+            ldflags="$ldflags -Wl,-E"
             natdynlinkopts="-Wl,-E"
-            byteccrpath="-Wl,-rpath,"
+            rpath="-Wl,-rpath,"
             mksharedlibrpath="-Wl,-rpath,"
           fi
           shared_libraries_supported=true;;
         *)
           sharedcccompopts="-KPIC"
-          byteccrpath="-R"
+          rpath="-R"
           mksharedlibrpath="-R"
           mksharedlib="/usr/ccs/bin/ld -G"
           shared_libraries_supported=true;;
       esac;;
     mips*-*-irix[56]*)
-      case "$bytecc" in
+      case "$cc" in
         cc*) sharedcccompopts="";;
         *gcc*) sharedcccompopts="-fPIC";;
       esac
       mksharedlib="ld -shared -rdata_shared"
-      byteccrpath="-Wl,-rpath,"
+      rpath="-Wl,-rpath,"
       mksharedlibrpath="-rpath "
       shared_libraries_supported=true;;
     i[3456]86-*-darwin[89].*)
-      mksharedlib="$bytecc -bundle -flat_namespace -undefined suppress \
+      mksharedlib="$cc -shared -flat_namespace -undefined suppress \
                    -read_only_relocs suppress"
-      bytecccompopts="$dl_defs $bytecccompopts"
+      common_cflags="$dl_defs $common_cflags"
       dl_needs_underscore=false
       shared_libraries_supported=true;;
     *-apple-darwin*)
-      mksharedlib="$bytecc -bundle -flat_namespace -undefined suppress \
+      mksharedlib="$cc -shared -flat_namespace -undefined suppress \
                    -Wl,-no_compact_unwind"
-      bytecccompopts="$dl_defs $bytecccompopts"
+      common_cflags="$dl_defs $common_cflags"
       dl_needs_underscore=false
       shared_libraries_supported=true;;
-    *-*-linux-gnu|*-*-linux|*-*-freebsd[3-9]*|*-*-freebsd[1-9][0-9]*\
+    *-*-linux*|*-*-freebsd[3-9]*|*-*-freebsd[1-9][0-9]*\
     |*-*-openbsd*|*-*-netbsd*|*-*-dragonfly*|*-*-gnu*|*-*-haiku*)
       sharedcccompopts="-fPIC"
-      mksharedlib="$bytecc -shared"
-      bytecclinkopts="$bytecclinkopts -Wl,-E"
-      byteccrpath="-Wl,-rpath,"
+      mksharedlib="$cc -shared"
+      ldflags="$ldflags -Wl,-E"
+      rpath="-Wl,-rpath,"
       mksharedlibrpath="-Wl,-rpath,"
       natdynlinkopts="-Wl,-E"
       shared_libraries_supported=true;;
+    powerpc-*-aix*)
+      case "$ccfamily" in
+        xlc-*)sharedcccompopts="-qpic"
+              mksharedlib="$cc -qmkshrobj -G"
+              mksharedlibrpath="-Wl,-blibpath,"
+              ldflags="$ldflags -brtl -bexpfull"
+              dl_needs_underscore=false
+              rpath="-Wl,-blibpath,"
+              shared_libraries_supported=true;;
+      esac
   esac
 fi
 
@@ -823,7 +892,7 @@ fi
 
 natdynlink=false
 
-if test $with_sharedlibs = "yes"; then
+if $with_sharedlibs; then
   case "$target" in
     *-*-cygwin*)                  natdynlink=true;;
     *-*-mingw*)                   natdynlink=true;;
@@ -838,7 +907,6 @@ if test $with_sharedlibs = "yes"; then
     x86_64-*-darwin*)             natdynlink=true;;
     s390x*-*-linux*)              natdynlink=true;;
     powerpc*-*-linux*)            natdynlink=true;;
-    sparc*-*-linux*)              natdynlink=true;;
     i686-*-kfreebsd*)             natdynlink=true;;
     x86_64-*-kfreebsd*)           natdynlink=true;;
     x86_64-*-dragonfly*)          natdynlink=true;;
@@ -865,10 +933,10 @@ fi
 
 
 # Try to work around the Skylake/Kaby Lake processor bug.
-case "$bytecc,$target" in
+case "$cc,$target" in
     *gcc*,x86_64-*|*gcc*,i686-*)
         if sh ./hasgot -Werror -fno-tree-vrp; then
-            byteccprivatecompopts="$byteccprivatecompopts -fno-tree-vrp"
+            internal_cflags="$internal_cflags -fno-tree-vrp"
             inf "Adding -fno-tree-vrp option to work around PR#7452"
         fi;;
 esac
@@ -876,32 +944,13 @@ esac
 
 # Configure the native-code compiler
 
-# The NATIVECC make variable defines which compiler and options to use
-# to compile C code intended to be used by OCaml native programs.
-# It is used inside OCaml's build system.
-
-# The NATIVE_C_COMPILER make variable says how the C compiler should be
-# invoked to process a third-party C source file passed to ocamlopt
-# when no -cc command-line option has been specified.
-
-# The NATIVECCCOMPOPTS make variable contains options to pass to the C
-# compiler, but only when compiling C files that belong to the OCaml
-# distribution.
-# In other words, when ocamlopt is called to compile a third-party C
-# source file, it will _not_ pass these options to the C compiler.
-
 arch=none
 model=default
 system=unknown
 
 case "$target" in
-  sparc*-*-solaris2.*)          arch=sparc; system=solaris;;
-  sparc*-*-*bsd*)               arch=sparc; system=bsd;;
-  sparc*-*-linux*)              arch=sparc; system=linux;;
-  sparc*-*-gnu*)                arch=sparc; system=gnu;;
   i[3456]86-*-linux*)           arch=i386; system=linux_`sh ./runtest elf.c`;;
   i[3456]86-*-*bsd*)            arch=i386; system=bsd_`sh ./runtest elf.c`;;
-  i[3456]86-*-nextstep*)        arch=i386; system=nextstep;;
   i[3456]86-*-solaris*)         if $arch64; then
                                   arch=amd64; system=solaris
                                 else
@@ -921,7 +970,7 @@ case "$target" in
   powerpc*-*-linux*)            arch=power;
                                 if $arch64; then model=ppc64; else model=ppc; fi
                                 system=elf;;
-  powerpc-*-netbsd*)            arch=power; model=ppc; system=elf;;
+  powerpc-*-netbsd*)            arch=power; model=ppc; system=netbsd;;
   powerpc-*-openbsd*)           arch=power; model=ppc; system=bsd_elf;;
   s390x*-*-linux*)              arch=s390x; model=z10; system=elf;;
   armv6*-*-linux-gnueabihf)     arch=arm; model=armv6; system=linux_eabihf;;
@@ -955,7 +1004,7 @@ esac
 # Sometimes, it's 32-bit mode that is not supported  (PR#6722).
 
 case "$arch64,$arch,$model" in
-  true,sparc,*|true,power,ppc|false,amd64,*)
+  true,power,ppc|false,amd64,*)
       arch=none; model=default; system=unknown;;
 esac
 
@@ -965,22 +1014,9 @@ case "$native_compiler" in
       arch=none; model=default; system=unknown; natdynlink=false;;
 esac
 
-if test -z "$ccoption"; then
-  nativecc="$bytecc"
-else
-  nativecc="$ccoption"
-fi
-
-nativecccompopts="$bytecccompopts"
-nativeccprivatecompopts="$byteccprivatecompopts"
 nativeccprofopts=''
-nativecclinkopts=''
-# FIXME the naming of nativecclinkopts is broken: these are options for
-# ld (for shared libs), not for cc
-nativeccrpath="$byteccrpath"
 
-case "$arch,$nativecc,$system,$model" in
-  *,*,nextstep,*)      nativecclinkopts="-posix";;
+case "$arch,$cc,$system,$model" in
   *,*,rhapsody,*)      if $arch64; then partialld="ld -r -arch ppc64"; fi;;
   amd64,gcc*,macosx,*) partialld="ld -r -arch x86_64";;
   amd64,gcc*,solaris,*) partialld="ld -r -m elf_x86_64";;
@@ -993,8 +1029,8 @@ asppprofflags='-DPROFILING'
 
 case "$arch,$system" in
   amd64,macosx)   if sh ./searchpath clang; then
-                      as='clang -arch x86_64 -c'
-                      aspp='clang -arch x86_64 -c'
+                      as='clang -arch x86_64 -Wno-trigraphs -c'
+                      aspp='clang -arch x86_64 -Wno-trigraphs -c'
                     else
                       as="${TOOLPREF}as -arch x86_64"
                       aspp="${TOOLPREF}gcc -arch x86_64 -c"
@@ -1012,22 +1048,17 @@ case "$arch,$system" in
                   fi;;
   s390x,elf)      as="${TOOLPREF}as -m 64 -march=$model"
                   aspp="${TOOLPREF}gcc -c -Wa,-march=$model";;
-  sparc,solaris)  as="${TOOLPREF}as"
-                  case "$cc" in
-                    *gcc*) aspp="${TOOLPREF}gcc -c";;
-                    *) aspp="${TOOLPREF}as -P";;
-                  esac;;
   arm,freebsd)    as="${TOOLPREF}cc -c"
                   aspp="${TOOLPREF}cc -c";;
   *,dragonfly)    as="${TOOLPREF}as"
                   aspp="${TOOLPREF}cc -c";;
   *,freebsd)      as="${TOOLPREF}as"
                   aspp="${TOOLPREF}cc -c";;
-  amd64,*|arm,*|arm64,*|i386,*|power,bsd*|sparc,*)
+  amd64,*|arm,*|arm64,*|i386,*|power,bsd*|power,netbsd)
                   as="${TOOLPREF}as"
                   case "$ccfamily" in
                       clang-*)
-                          aspp="${TOOLPREF}clang -c"
+                          aspp="${TOOLPREF}clang -c -Wno-trigraphs"
                           ;;
                       *)
                           aspp="${TOOLPREF}gcc -c"
@@ -1045,10 +1076,6 @@ case "$arch,$system" in
   i386,bsd_elf) profiling='true';;
   amd64,macosx) profiling='true';;
   i386,macosx) profiling='true';;
-  sparc,bsd) profiling='true';;
-  sparc,solaris)
-    profiling='true'
-    case "$nativecc" in gcc*) ;; *) cc_profile='-xpg';; esac;;
   amd64,linux) profiling='true';;
   amd64,openbsd) profiling='true';;
   amd64,freebsd) profiling='true';;
@@ -1058,6 +1085,7 @@ case "$arch,$system" in
   arm,linux*) profiling='true';;
   power,elf) profiling='true';;
   power,bsd*) profiling='true';;
+  power,netbsd) profiling='true';;
   *) profiling='false';;
 esac
 
@@ -1065,15 +1093,15 @@ esac
 
 if sh ./searchpath ${TOOLPREF}ranlib; then
   inf "ranlib found"
-  echo "RANLIB=${TOOLPREF}ranlib" >> Makefile
-  echo "RANLIBCMD=${TOOLPREF}ranlib" >> Makefile
+  config RANLIB "${TOOLPREF}ranlib"
+  config RANLIBCMD "${TOOLPREF}ranlib"
 else
   inf "ranlib not used"
-  echo "RANLIB=${TOOLPREF}ar rs" >> Makefile
-  echo "RANLIBCMD=" >> Makefile
+  config RANLIB "${TOOLPREF}ar rs"
+  config RANLIBCMD ""
 fi
 
-echo "ARCMD=${TOOLPREF}ar" >> Makefile
+config ARCMD "${TOOLPREF}ar"
 
 
 # Write the OS type (Unix or Cygwin)
@@ -1092,27 +1120,26 @@ if ( (./hashbang || ./hashbang2 || ./hashbang3 || ./hashbang4) >/dev/null); then
     *-*-sunos*|*-*-unicos*)
       wrn "We won't use it, though, because under SunOS and Unicos it breaks " \
           "on pathnames longer than 30 characters"
-      echo "HASHBANGSCRIPTS=false" >> Makefile;;
+      config HASHBANGSCRIPTS "false";;
     *-*-cygwin*)
       wrn "We won't use it, though, because of conflicts with .exe extension " \
           "under Cygwin"
-      echo "HASHBANGSCRIPTS=false" >> Makefile;;
+      config HASHBANGSCRIPTS "false";;
     *-*-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."
-      echo "HASHBANGSCRIPTS=false" >> Makefile;;
+      config HASHBANGSCRIPTS "false";;
     *)
-      echo "HASHBANGSCRIPTS=true" >> Makefile;;
+      config HASHBANGSCRIPTS "true";;
   esac
 else
   inf "No support for #! in shell scripts"
-  echo "HASHBANGSCRIPTS=false" >> Makefile
+  config HASHBANGSCRIPTS "false"
 fi
 
 # Use 64-bit file offset if possible
 
-bytecccompopts="$bytecccompopts -D_FILE_OFFSET_BITS=64"
-nativecccompopts="$nativecccompopts -D_FILE_OFFSET_BITS=64"
+common_cppflags="$common_cppflags -D_FILE_OFFSET_BITS=64"
 
 # Check the semantics of signal handlers
 
@@ -1202,21 +1229,21 @@ case "$system" in
   *) unix_or_win32="unix"; unixlib="unix"; graphlib="graph";;
 esac
 
-echo "UNIX_OR_WIN32=$unix_or_win32" >> Makefile
-echo "UNIXLIB=$unixlib" >> Makefile
-echo "GRAPHLIB=$graphlib" >> Makefile
+config UNIX_OR_WIN32 "$unix_or_win32"
+config UNIXLIB "$unixlib"
+config GRAPHLIB "$graphlib"
 
-otherlibraries="$unixlib str num dynlink bigarray"
+otherlibraries="$unixlib str dynlink bigarray"
 
 # Spacetime profiling is only available for native code on 64-bit targets.
 
-case "$native_compiler" in
-    true)
+case "$arch" in
+    none) ;;
+    *)
       if $arch64; then
         otherlibraries="$otherlibraries raw_spacetime_lib"
       fi
       ;;
-    *) ;;
 esac
 
 # For the Unix library
@@ -1305,11 +1332,6 @@ if sh ./hasgot getcwd; then
   echo "#define HAS_GETCWD" >> s.h
 fi
 
-if sh ./hasgot getwd; then
-  inf "getwd() found."
-  echo "#define HAS_GETWD" >> s.h
-fi
-
 if sh ./hasgot getpriority setpriority; then
   inf "getpriority() found."
   echo "#define HAS_GETPRIORITY" >> s.h
@@ -1542,6 +1564,21 @@ if sh ./hasgot accept4; then
   echo "#define HAS_ACCEPT4" >> s.h
 fi
 
+if sh ./hasgot getauxval; then
+  inf "getauxval() found."
+  echo "#define HAS_GETAUXVAL" >> s.h
+fi
+
+if sh ./hasgot -i sys/shm.h; then
+  inf "sys/shm.h found."
+  echo "#define HAS_SYS_SHM_H" >> s.h
+fi
+
+if sh ./hasgot execvpe; then
+  inf "execvpe() found."
+  echo "#define HAS_EXECVPE" >> s.h
+fi
+
 # Determine if the debugger is supported
 
 if test -n "$with_debugger"; then
@@ -1565,23 +1602,6 @@ case "$arch,$system" in
     inf "Cannot detect system stack overflow.";;
 esac
 
-# Determine the target architecture for the "num" library
-
-case "$arch" in
-  i386)     bng_arch=ia32
-            if sh ./trycompile ia32sse2.c
-            then bng_asm_level=2
-            else bng_asm_level=1
-            fi;;
-  power)    bng_arch=ppc; bng_asm_level=1;;
-  amd64)    bng_arch=amd64; bng_asm_level=1;;
-  arm64)    bng_arch=arm64; bng_asm_level=1;;
-  *)        bng_arch=generic; bng_asm_level=0;;
-esac
-
-echo "BNG_ARCH=$bng_arch" >> Makefile
-echo "BNG_ASM_LEVEL=$bng_asm_level" >> Makefile
-
 # Determine if the POSIX threads library is supported
 
 systhread_support=false
@@ -1605,16 +1625,13 @@ if test "$pthread_wanted" = "yes"; then
     inf "POSIX threads library supported."
     systhread_support=true
     otherlibraries="$otherlibraries systhreads"
-    bytecccompopts="$bytecccompopts -D_REENTRANT"
-    nativecccompopts="$nativecccompopts -D_REENTRANT"
+    common_cppflags="$common_cppflags -D_REENTRANT"
     case "$target" in
       *-*-freebsd*|*-*-dragonfly*)
-          bytecccompopts="$bytecccompopts -D_THREAD_SAFE"
-          nativecccompopts="$nativecccompopts -D_THREAD_SAFE";;
+          common_cppflags="$common_cppflags -D_THREAD_SAFE";;
       *-*-openbsd*)
-          bytecccompopts="$bytecccompopts -pthread"
-          asppflags="$asppflags -pthread"
-          nativecccompopts="$nativecccompopts -pthread";;
+          common_cflags="$common_cflags -pthread";
+          asppflags="$asppflags -pthread";;
     esac
     inf "Options for linking with POSIX threads: $pthread_link"
     if sh ./hasgot $pthread_link sigwait; then
@@ -1628,8 +1645,8 @@ if test "$pthread_wanted" = "yes"; then
 else
   pthread_link=""
 fi
-echo "PTHREAD_LINK=$pthread_link" >> Makefile
-echo "PTHREAD_CAML_LINK=$pthread_caml_link" >> Makefile
+config PTHREAD_LINK "$pthread_link"
+config PTHREAD_CAML_LINK "$pthread_caml_link"
 
 # Determine if the bytecode thread library is supported
 
@@ -1821,11 +1838,29 @@ echo "X11_LINK=$x11_link" >> Makefile
 
 # Look for BFD library
 
-if sh ./hasgot -DPACKAGE=ocaml -i bfd.h && \
-   sh ./hasgot -DPACKAGE=ocaml -lbfd -ldl -liberty -lz bfd_openr; then
+if $shared_libraries_supported && ./hasgot -DPACKAGE=ocaml -i bfd.h ; then
   inf "BFD library found."
-  echo "#define HAS_LIBBFD" >> s.h
-  echo "LIBBFD_LINK=-lbfd -ldl -liberty -lz" >> Makefile
+  if sh ./hasgot -DPACKAGE=ocaml -lbfd bfd_openr; then
+    LIBBFD_LINK="-lbfd"
+    inf "BFD links with $LIBBFD_LINK"
+    echo "#define HAS_LIBBFD" >> s.h
+  elif sh ./hasgot -DPACKAGE=ocaml -lbfd -ldl bfd_openr; then
+    LIBBFD_LINK="-lbfd -ldl"
+    inf "BFD links with $LIBBFD_LINK"
+    echo "#define HAS_LIBBFD" >> s.h
+  elif sh ./hasgot -DPACKAGE=ocaml -lbfd -ldl -liberty bfd_openr; then
+    LIBBFD_LINK="-lbfd -ldl -liberty"
+    inf "BFD links with $LIBBFD_LINK"
+    echo "#define HAS_LIBBFD" >> s.h
+  elif sh ./hasgot -DPACKAGE=ocaml -lbfd -ldl -liberty -lz bfd_openr; then
+    LIBBFD_LINK="-lbfd -ldl -liberty -lz"
+    inf "BFD links with $LIBBFD_LINK"
+    echo "#define HAS_LIBBFD" >> s.h
+  else
+    wrn "Could not determine link options for the BFD library"
+    LIBBFD_LINK=
+  fi
+  echo "LIBBFD_LINK=$LIBBFD_LINK" >> 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 \
@@ -1862,9 +1897,7 @@ fi
 if test "$with_frame_pointers" = "true"; then
   case "$target,$cc" in
     x86_64-*-linux*,gcc*|x86_64-*-linux*,clang*)
-       nativecccompopts="$nativecccompopts -g  -fno-omit-frame-pointer"
-       bytecccompopts="$bytecccompopts -g  -fno-omit-frame-pointer"
-       nativecclinkopts="$nativecclinkopts -g"
+       common_cflags="$common_cflags -g  -fno-omit-frame-pointer"
        echo "#define WITH_FRAME_POINTERS" >> m.h
        ;;
     *) err "Unsupported architecture with frame pointers";;
@@ -1909,6 +1942,9 @@ if $with_spacetime; then
   if $spacetime_supported; then
     echo "Spacetime profiling will be available."
     echo "#define WITH_SPACETIME" >> m.h
+    if $enable_call_counts; then
+      echo "#define ENABLE_CALL_COUNTS" >> m.h
+    fi
     if $disable_libunwind; then
       has_libunwind=no
       libunwind_available=false
@@ -1976,7 +2012,8 @@ if $with_spacetime; then
       fi
     fi
   else
-    echo "Spacetime profiling is not available on 32-bit platforms."
+    echo "Spacetime profiling unavailable: it needs a 64-bit platform with"
+    echo "  support for the native code OCaml compiler."
     with_spacetime=false
     libunwind_available=false
     has_libunwind=no
@@ -1988,8 +2025,7 @@ if ! $shared_libraries_supported; then
 fi
 
 if $with_fpic; then
-  bytecccompopts="$bytecccompopts $sharedcccompopts"
-  nativecccompopts="$nativecccompopts $sharedcccompopts"
+  common_cflags="$common_cflags $sharedcccompopts"
   aspp="$aspp $sharedcccompopts"
 fi
 
@@ -2002,23 +2038,35 @@ if $with_fpic; then
   echo "#define CAML_WITH_FPIC" >> m.h
 fi
 
+if $force_safe_string; then
+  echo "#define CAML_SAFE_STRING" >> m.h
+fi
+
+if $flat_float_array; then
+  echo "#define FLAT_FLOAT_ARRAY" >> m.h
+fi
+
 # Finish generated files
 
 cclibs="$cclibs $mathlib"
 
-echo "BYTECC=$bytecc $bytecccompopts" >> Makefile
-echo "BYTECODE_C_COMPILER=$bytecc $bytecccompopts $sharedcccompopts" \
-  >> Makefile
-echo "BYTECCCOMPOPTS=$byteccprivatecompopts" >> Makefile
-echo "BYTECCLINKOPTS=$bytecclinkopts" >> Makefile
-echo "BYTECCLIBS=$cclibs $dllib $curseslibs $pthread_link \
-                 $instrumented_runtime_libs" >> Makefile
-echo "BYTECCRPATH=$byteccrpath" >> Makefile
-echo "EXE=$exe" >> Makefile
-echo "SUPPORTS_SHARED_LIBRARIES=$shared_libraries_supported" >> Makefile
-echo "SHAREDCCCOMPOPTS=$sharedcccompopts" >> Makefile
-echo "MKSHAREDLIBRPATH=$mksharedlibrpath" >> Makefile
-echo "NATDYNLINKOPTS=$natdynlinkopts" >> Makefile
+config CC "$cc"
+config CPP "$cpp"
+config CFLAGS "$common_cflags $internal_cflags"
+config CPPFLAGS "$common_cppflags $internal_cppflags"
+config OCAMLC_CFLAGS "$common_cflags $sharedcccompopts"
+config OCAMLC_CPPFLAGS "$common_cppflags"
+config LDFLAGS "$ldflags"
+config BYTECCLIBS "$cclibs $dllib $curseslibs $pthread_link \
+                 $instrumented_runtime_libs"
+config RPATH "$rpath"
+config EXE "$exe"
+config EMPTY ""
+config OUTPUTEXE "-o \$(EMPTY)"
+config SUPPORTS_SHARED_LIBRARIES "$shared_libraries_supported"
+config SHAREDCCCOMPOPTS "$sharedcccompopts"
+config MKSHAREDLIBRPATH "$mksharedlibrpath"
+config NATDYNLINKOPTS "$natdynlinkopts"
 cat >> Makefile <<EOF
 SYSLIB=-l\$(1)
 #ml let syslib x = "-l"^x;;
@@ -2029,70 +2077,73 @@ MKLIB=${TOOLPREF}ar rc \$(1) \$(2); ${TOOLPREF}ranlib \$(1)
 #ml   Printf.sprintf "${TOOLPREF}ar rc %s %s %s; ${TOOLPREF}ranlib %s"
 #ml                  out opts files out;;
 EOF
-echo "ARCH=$arch" >> Makefile
-echo "MODEL=$model" >> Makefile
-echo "SYSTEM=$system" >> Makefile
-echo "NATIVECC=$nativecc $nativecccompopts" >> Makefile
-echo "NATIVE_C_COMPILER=$nativecc $nativecccompopts" >> Makefile
-echo "NATIVECCCOMPOPTS=$nativeccprivatecompopts" >> Makefile
-echo "NATIVECCPROFOPTS=$nativeccprofopts" >> Makefile
-echo "NATIVECCLINKOPTS=$nativecclinkopts" >> Makefile
-echo "NATIVECCRPATH=$nativeccrpath" >> Makefile
-echo "NATIVECCLIBS=$cclibs $dllib" >> Makefile
-echo "ASM=$as" >> Makefile
-echo "ASPP=$aspp" >> Makefile
-echo "ASPPPROFFLAGS=$asppprofflags" >> Makefile
-echo "PROFILING=$profiling" >> Makefile
-echo "DYNLINKOPTS=$dllib" >> Makefile
-echo "OTHERLIBRARIES=$otherlibraries" >> Makefile
-echo "CC_PROFILE=$cc_profile" >> Makefile
-echo "SYSTHREAD_SUPPORT=$systhread_support" >> Makefile
-echo "PACKLD=$partialld $nativecclinkopts -o\\ " >> Makefile
-echo "IFLEXDIR=$iflexdir" >> Makefile
-echo "O=o" >> Makefile
-echo "A=a" >> Makefile
-echo "SO=$SO" >> Makefile
-echo "EXT_OBJ=.o" >> Makefile
-echo "EXT_ASM=.s" >> Makefile
-echo "EXT_LIB=.a" >> Makefile
-echo "EXT_DLL=.$SO" >> Makefile
-echo "EXTRALIBS=" >> Makefile
-echo "CCOMPTYPE=cc" >> Makefile
-echo "TOOLCHAIN=$TOOLCHAIN" >> Makefile
-echo "NATDYNLINK=$natdynlink" >> Makefile
-echo "CMXS=$cmxs" >> Makefile
-echo "MKEXE=$mkexe" >> Makefile
-echo "MKEXEDEBUGFLAG=$mkexedebugflag" >> Makefile
-echo "MKDLL=$mksharedlib" >> Makefile
-echo "MKMAINDLL=$mkmaindll" >> Makefile
-echo "RUNTIMED=${debugruntime}" >>Makefile
-echo "RUNTIMEI=${with_instrumented_runtime}" >>Makefile
-echo "WITH_DEBUGGER=${with_debugger}" >>Makefile
-echo "WITH_OCAMLDOC=${with_ocamldoc}" >>Makefile
-echo "ASM_CFI_SUPPORTED=$asm_cfi_supported" >> Makefile
-echo "WITH_FRAME_POINTERS=$with_frame_pointers" >> Makefile
-echo "WITH_SPACETIME=$with_spacetime" >> Makefile
-echo "WITH_PROFINFO=$with_profinfo" >> Makefile
-echo "LIBUNWIND_AVAILABLE=$libunwind_available" >> Makefile
-echo "LIBUNWIND_INCLUDE_FLAGS=$libunwind_include" >> Makefile
-echo "LIBUNWIND_LINK_FLAGS=$libunwind_lib" >> Makefile
-echo "PROFINFO_WIDTH=$profinfo_width" >> Makefile
-echo "WITH_CPLUGINS=$with_cplugins" >> Makefile
-echo "WITH_FPIC=$with_fpic" >> Makefile
-echo "TARGET=$target" >> Makefile
-echo "HOST=$host" >> Makefile
+config ARCH "$arch"
+config MODEL "$model"
+config SYSTEM "$system"
+config OCAMLOPT_CFLAGS "$common_cflags"
+config OCAMLOPT_CPPFLAGS "$common_cppflags"
+config NATIVECCPROFOPTS "$nativeccprofopts"
+config NATIVECCLIBS "$cclibs $dllib"
+config ASM "$as"
+config ASPP "$aspp"
+config ASPPPROFFLAGS "$asppprofflags"
+config PROFILING "$profiling"
+config DYNLINKOPTS "$dllib"
+config OTHERLIBRARIES "$otherlibraries"
+config CC_PROFILE "$cc_profile"
+config SYSTHREAD_SUPPORT "$systhread_support"
+config PACKLD "$partialld -o\\ \$(EMPTY)"
+config IFLEXDIR "$iflexdir"
+config O "o"
+config A "a"
+config SO "$SO"
+config EXT_OBJ ".o"
+config OUTPUTOBJ "-o \$(EMPTY)"
+config EXT_ASM ".s"
+config EXT_LIB ".a"
+config EXT_DLL ".$SO"
+config EXTRALIBS ""
+config CCOMPTYPE "cc"
+config TOOLCHAIN "$TOOLCHAIN"
+config NATDYNLINK "$natdynlink"
+config CMXS "$cmxs"
+config MKEXE "$mkexe"
+config MKEXEDEBUGFLAG "$mkexedebugflag"
+config MKDLL "$mksharedlib"
+config MKMAINDLL "$mkmaindll"
+config RUNTIMED "${debugruntime}"
+config RUNTIMEI "${with_instrumented_runtime}"
+config WITH_DEBUGGER "${with_debugger}"
+config WITH_OCAMLDOC "${with_ocamldoc}"
+config ASM_CFI_SUPPORTED "$asm_cfi_supported"
+config WITH_FRAME_POINTERS "$with_frame_pointers"
+config WITH_SPACETIME "$with_spacetime"
+config ENABLE_CALL_COUNTS "$enable_call_counts"
+config WITH_PROFINFO "$with_profinfo"
+config LIBUNWIND_AVAILABLE "$libunwind_available"
+config LIBUNWIND_INCLUDE_FLAGS "$libunwind_include"
+config LIBUNWIND_LINK_FLAGS "$libunwind_lib"
+config PROFINFO_WIDTH "$profinfo_width"
+config WITH_CPLUGINS "$with_cplugins"
+config WITH_FPIC "$with_fpic"
+config TARGET "$target"
+config HOST "$host"
 if [ "$ostype" = Cygwin ]; then
-  echo "DIFF=diff -q --strip-trailing-cr" >>Makefile
+  config DIFF "diff -q --strip-trailing-cr"
 fi
-echo "FLAMBDA=$flambda" >> Makefile
-echo "SAFE_STRING=$safe_string" >> Makefile
-echo "AFL_INSTRUMENT=$afl_instrument" >> Makefile
-echo "MAX_TESTSUITE_DIR_RETRIES=$max_testsuite_dir_retries" >> Makefile
+config FLAMBDA "$flambda"
+config FORCE_SAFE_STRING "$force_safe_string"
+config DEFAULT_SAFE_STRING "$default_safe_string"
+config WINDOWS_UNICODE "0"
+config AFL_INSTRUMENT "$afl_instrument"
+config MAX_TESTSUITE_DIR_RETRIES "$max_testsuite_dir_retries"
+config FLAT_FLOAT_ARRAY "$flat_float_array"
 
 
 rm -f tst hasgot.c
-rm -f ../m.h ../s.h ../Makefile
-mv m.h s.h Makefile ..
+rm -f ../../byterun/caml/m.h ../../byterun/caml/s.h ../Makefile
+mv m.h s.h ../../byterun/caml/
+mv Makefile ..
 
 # Print a summary
 
@@ -2102,16 +2153,16 @@ inf
 inf "Directories where OCaml will be installed:"
 inf "        binaries.................. $bindir"
 inf "        standard library.......... $libdir"
-inf "        manual pages.............. $mandir (with extension .$manext)"
+inf "        manual pages.............. $mandir (with extension .$programs_man_section)"
 
 inf "Configuration for the bytecode compiler:"
-inf "        C compiler used........... $bytecc"
-inf "        options for compiling..... $bytecccompopts"
-inf "        options for linking....... $bytecclinkopts $cclibs $dllib" \
+inf "        C compiler used........... $cc"
+inf "        options for compiling..... $common_cflags"
+inf "        options for linking....... $ldflags $cclibs $dllib" \
                                        "$curseslibs $pthread_link"
 if $shared_libraries_supported; then
 inf "        shared libraries are supported"
-inf "        options for compiling..... $sharedcccompopts $bytecccompopts"
+inf "        options for compiling..... $sharedcccompopts $common_cflags"
 inf "        command for building...... $mksharedlib -o lib.so" \
                                        "$mksharedlibrpath/a/path objs"
 else
@@ -2130,9 +2181,9 @@ else
   if test "$system" = "unknown"; then : ; else
   inf "        OS variant................ $system"
   fi
-  inf "        C compiler used........... $nativecc"
-  inf "        options for compiling..... $nativecccompopts"
-  inf "        options for linking....... $nativecclinkopts $cclibs"
+  inf "        C compiler used........... $cc"
+  inf "        options for compiling..... $common_cflags"
+  inf "        options for linking....... $cclibs"
   inf "        assembler ................ $as"
   inf "        preprocessed assembler ... $aspp"
   if test "$asm_cfi_supported" = "true"; then
@@ -2152,6 +2203,11 @@ else
   fi
   if $with_spacetime; then
     inf "        spacetime profiling....... yes"
+    if test "$with_spacetime_call_counts" = "true"; then
+      inf "          ... with call counts.... yes"
+    else
+      inf "          ... with call counts.... no"
+    fi
     inf "          ... with libunwind...... $has_libunwind"
   else
     inf "        spacetime profiling....... no"
@@ -2198,10 +2254,20 @@ else
   else
   inf "        using flambda middle-end . no"
   fi
-  if test "$safe_string" = "true"; then
-  inf "        safe strings ............. yes"
+  if $force_safe_string; then
+  inf "        force safe strings ............. yes"
+  else
+  inf "        force safe strings ............. no"
+    if $default_safe_string; then
+  inf "        (-safe-string is the default per-file option)"
+    else
+  inf "        (-unsafe-string is the default per-file option)"
+    fi
+  fi
+  if $flat_float_array; then
+  inf "        flat float arrays ........ yes"
   else
-  inf "        safe strings ............. no"
+  inf "        flat float arrays ........ no"
   fi
   if test "$afl_instrument" = "true"; then
   inf "        afl-fuzz always enabled .. yes"
@@ -2227,9 +2293,6 @@ fi
 inf "Additional libraries supported:"
 inf "        $otherlibraries"
 
-inf "Configuration for the \"num\" library:"
-inf "        target architecture ...... $bng_arch (asm level $bng_asm_level)"
-
 if $has_graph; then
 inf "Configuration for the \"graph\" library:"
 inf "        options for compiling .... $x11_include"

diff --git a/debugger/breakpoints.ml b/debugger/breakpoints.ml
index edba0428449ca471893eed42ae1d4c8c480be310..5d5b6ceddb4007aa991a693e4bc9f1a1b6fbde9a 100644 (file)
--- a/debugger/breakpoints.ml
+++ b/debugger/breakpoints.ml
@@ -103,7 +103,7 @@ let set_breakpoints pos =
        set_breakpoint pos)
     pos
 
-(* Ensure the current version in installed in current checkpoint. *)
+(* Ensure the current version is installed in current checkpoint. *)
 let update_breakpoints () =
   if !debug_breakpoints then begin
     prerr_string "Updating breakpoints... ";

diff --git a/debugger/breakpoints.mli b/debugger/breakpoints.mli
index d0e76c3675b6700358593ea508c28d9e6f17edcf..be1baf12f9e30e6b26de42f964ac2544053151aa 100644 (file)
--- a/debugger/breakpoints.mli
+++ b/debugger/breakpoints.mli
@@ -36,7 +36,7 @@ val breakpoints_at_pc : int -> int list
 
 (*** Set and remove breakpoints ***)
 
-(* Ensure the current version in installed in current checkpoint. *)
+(* Ensure the current version is installed in current checkpoint. *)
 val update_breakpoints : unit -> unit
 
 (* Execute given function with no breakpoint in current checkpoint. *)

diff --git a/debugger/debugcom.ml b/debugger/debugcom.ml
index b70eedd1e688fa97d57f32c417bf66ec68ded8cc..e828ec4e2b54cc733ece2591092e9a3434fcea3c 100644 (file)
--- a/debugger/debugcom.ml
+++ b/debugger/debugcom.ml
@@ -201,6 +201,8 @@ module Remote_value =
   struct
     type t = Remote of string | Local of Obj.t
 
+    let repr x = Local (Obj.repr x)
+
     let obj = function
     | Local obj -> Obj.obj obj
     | Remote v ->
@@ -255,6 +257,25 @@ module Remote_value =
             Local(Obj.repr floatbuf)
           end
 
+    let double_field v n =
+      match v with
+      | Local obj -> Obj.double_field obj n
+      | Remote v ->
+          output_char !conn.io_out 'F';
+          output_remote_value !conn.io_out v;
+          output_binary_int !conn.io_out n;
+          flush !conn.io_out;
+          if input_byte !conn.io_in = 0 then
+            raise Marshalling_error
+          else begin
+            let buf = really_input_string !conn.io_in 8 in
+            let floatbuf = float n (* force allocation of a new float *) in
+            String.unsafe_blit buf 0 (Obj.magic floatbuf) 0 8;
+            floatbuf
+          end
+
+    let double_array_tag = Obj.double_array_tag
+
     let of_int n =
       Local(Obj.repr n)
 

diff --git a/debugger/debugcom.mli b/debugger/debugcom.mli
index 6f94df5c3b95a3abee51b9f5fadf3be9b57014f1..4091362613317fa1f1a91efaa975f7713da213ca 100644 (file)
--- a/debugger/debugcom.mli
+++ b/debugger/debugcom.mli
@@ -93,11 +93,14 @@ module Remote_value :
   sig
     type t
 
+    val repr : 'a -> t
     val obj : t -> 'a
     val is_block : t -> bool
     val tag : t -> int
     val size : t -> int
     val field : t -> int -> t
+    val double_field : t -> int -> float
+    val double_array_tag : int
     val same : t -> t -> bool
 
     val of_int : int -> t

diff --git a/debugger/debugger_config.ml b/debugger/debugger_config.ml
index 194a13dd05741ee707b5480518a82f2d03b1424f..3996d221e924fd09dbab982fd77b5ce49a6cdcc3 100644 (file)
--- a/debugger/debugger_config.ml
+++ b/debugger/debugger_config.ml
@@ -82,6 +82,6 @@ let make_checkpoints = ref
     "Win32" -> false
   | _ -> true)
 
-(*** Environment variables for debugee. ***)
+(*** Environment variables for debuggee. ***)
 
 let environment = ref []

diff --git a/debugger/debugger_config.mli b/debugger/debugger_config.mli
index 74c6d5f331e4d5a318e853adc521ae5cda025ba4..42fa7744046dd44bb957114210c2a5ab68d5f68e 100644 (file)
--- a/debugger/debugger_config.mli
+++ b/debugger/debugger_config.mli
@@ -28,13 +28,13 @@ val runtime_program : string
 val history_size : int ref
 val load_path_for : (string, string list) Hashtbl.t
 
-(*** Time travel paramaters. ***)
+(*** Time travel parameters. ***)
 
 val checkpoint_big_step : int64 ref
 val checkpoint_small_step : int64 ref
 val checkpoint_max_count : int ref
 val make_checkpoints : bool ref
 
-(*** Environment variables for debugee. ***)
+(*** Environment variables for debuggee. ***)
 
 val environment : (string * string) list ref

diff --git a/debugger/int64ops.ml b/debugger/int64ops.ml
index 7f6df6184242c7035152c8b89ff669c8e03664a5..d6fb583e5d2359fa2b7ba3cad870f9ccbdb74861 100644 (file)
--- a/debugger/int64ops.ml
+++ b/debugger/int64ops.ml
@@ -2,7 +2,7 @@
 (*                                                                        *)
 (*                                 OCaml                                  *)
 (*                                                                        *)
-(*           Damien Doligez, projet Moscova, INRIA Rocqencourt            *)
+(*           Damien Doligez, projet Moscova, INRIA Rocquencourt           *)
 (*                                                                        *)
 (*   Copyright 2002 Institut National de Recherche en Informatique et     *)
 (*     en Automatique.                                                    *)

diff --git a/debugger/int64ops.mli b/debugger/int64ops.mli
index 29d69bd17059fc5944a1962607fadb2c7f844e7a..7c7616c59abce059f7bb1039ecbea0053caf8dec 100644 (file)
--- a/debugger/int64ops.mli
+++ b/debugger/int64ops.mli
@@ -2,7 +2,7 @@
 (*                                                                        *)
 (*                                 OCaml                                  *)
 (*                                                                        *)
-(*           Damien Doligez, projet Moscova, INRIA Rocqencourt            *)
+(*           Damien Doligez, projet Moscova, INRIA Rocquencourt           *)
 (*                                                                        *)
 (*   Copyright 2002 Institut National de Recherche en Informatique et     *)
 (*     en Automatique.                                                    *)

diff --git a/debugger/loadprinter.ml b/debugger/loadprinter.ml
index 510979e2a9587ba8242b0fd04ca11fb63fd917cd..54a2c167071aa3948c510b7be7fea9bdad690244 100644 (file)
--- a/debugger/loadprinter.ml
+++ b/debugger/loadprinter.ml
@@ -105,7 +105,7 @@ let eval_path path =
 (* Install, remove a printer (as in toplevel/topdirs) *)
 
 (* since 4.00, "topdirs.cmi" is not in the same directory as the standard
-  libray, so we load it beforehand as it cannot be found in the search path. *)
+  library, so we load it beforehand as it cannot be found in the search path. *)
 let () =
   let compiler_libs =
     Filename.concat Config.standard_library "compiler-libs" in

diff --git a/debugger/primitives.ml b/debugger/primitives.ml
index ac69513714bbbd57ebe5918b943d9048d25bf6e9..7c1f900fb99fb6902567ed89b16b3a937fa62a45 100644 (file)
--- a/debugger/primitives.ml
+++ b/debugger/primitives.ml
@@ -45,7 +45,7 @@ let rec list_truncate =
   | (_, [])     -> []
   | (n, (a::l)) -> a::(list_truncate (n - 1) l)
 
-(* Separe the `n' first elements of `l' and the others *)
+(* Separate the `n' first elements of `l' and the others *)
 (* ### n list -> (first, last) *)
 let rec list_truncate2 =
   fun

diff --git a/debugger/primitives.mli b/debugger/primitives.mli
index 2be9032f9fa440e5155c3c792d0e15a4a3d8b390..76526cf96f415c801b0f45371c93ac2dc6c7e61e 100644 (file)
--- a/debugger/primitives.mli
+++ b/debugger/primitives.mli
@@ -34,7 +34,7 @@ val index : 'a -> 'a list -> int
 (* ### n l -> l' *)
 val list_truncate : int -> 'a list -> 'a list
 
-(* Separe the `n' first elements of `l' and the others. *)
+(* Separate the `n' first elements of `l' and the others. *)
 (* ### n list -> (first, last) *)
 val list_truncate2 : int -> 'a list -> 'a list * 'a list
 

diff --git a/debugger/program_loading.ml b/debugger/program_loading.ml
index d804b88eb354418af98c34d9633ee09a78979b82..c03dcfdc6ff76d4fffb698fbf97580f7c614eb43 100644 (file)
--- a/debugger/program_loading.ml
+++ b/debugger/program_loading.ml
@@ -140,7 +140,7 @@ let exec_with_runtime =
                      (Filename.quote !program_name)
                      !arguments)
 
-(* Excute the program directly *)
+(* Execute the program directly *)
 let exec_direct =
   generic_exec
     (function () ->

diff --git a/debugger/program_management.mli b/debugger/program_management.mli
index aca1cddcd629a47562e03dd739bba0c46272794e..384067832efba8d7a3484698a6dc653e69c5812b 100644 (file)
--- a/debugger/program_management.mli
+++ b/debugger/program_management.mli
@@ -22,7 +22,7 @@ val ensure_loaded : unit -> unit
 (*** Kill program. ***)
 val kill_program : unit -> unit
 
-(* Ask wether to kill the program or not. *)
+(* Ask whether to kill the program or not. *)
 (* If yes, kill it. *)
 (* Return true iff the program has been killed. *)
 val ask_kill_program : unit -> bool

diff --git a/debugger/show_information.ml b/debugger/show_information.ml
index 9e34b61c5fb8edfb0953dd0d277d35a5785a1248..30d7774e2f8201b40fd0099f52877ac5795f7d82 100644 (file)
--- a/debugger/show_information.ml
+++ b/debugger/show_information.ml
@@ -88,7 +88,7 @@ let show_one_frame framenum ppf event =
            (pos.Lexing.pos_cnum - pos.Lexing.pos_bol + 1)
 
 (* Display information about the current frame. *)
-(* --- `select frame' must have succeded before calling this function. *)
+(* --- `select frame' must have succeeded before calling this function. *)
 let show_current_frame ppf selected =
   match !selected_event with
   | None ->

diff --git a/debugger/show_information.mli b/debugger/show_information.mli
index 88c51379fd1b7900380d1c1ff0bfd33f230f17a3..2d6b6b018392a349815eda69039f44ebe2f50515 100644 (file)
--- a/debugger/show_information.mli
+++ b/debugger/show_information.mli
@@ -20,7 +20,7 @@ open Format;;
 val show_current_event : formatter -> unit;;
 
 (* Display information about the current frame. *)
-(* --- `select frame' must have succeded before calling this function. *)
+(* --- `select frame' must have succeeded before calling this function. *)
 val show_current_frame : formatter -> bool -> unit;;
 
 (* Display short information about one frame. *)

diff --git a/debugger/symbols.ml b/debugger/symbols.ml
index dd20d8f9133f30b14090ddc17451a8bbf07ecfe2..3112497401159f294ab150e3ff6acfac89649e8e 100644 (file)
--- a/debugger/symbols.ml
+++ b/debugger/symbols.ml
@@ -37,6 +37,18 @@ let events_by_module =
 let all_events_by_module =
   (Hashtbl.create 17 : (string, debug_event list) Hashtbl.t)
 
+let partition_modules evl =
+  let rec partition_modules' ev evl =
+    match evl with
+      [] -> [ev],[]
+    | ev'::evl ->
+       let evl,evll = partition_modules' ev' evl in
+       if ev.ev_module = ev'.ev_module then ev::evl,evll else [ev],evl::evll
+  in
+  match evl with
+    [] -> []
+  | ev::evl -> let evl,evll = partition_modules' ev evl in evl::evll
+
 let relocate_event orig ev =
   ev.ev_pos <- orig + ev.ev_pos;
   match ev.ev_repr with
@@ -67,7 +79,8 @@ let read_symbols' bytecode_file =
     let evl = (input_value ic : debug_event list) in
     (* Relocate events in event list *)
     List.iter (relocate_event orig) evl;
-    eventlists := evl :: !eventlists;
+    let evll = partition_modules evl in
+    eventlists := evll @ !eventlists;
     dirs :=
       List.fold_left (fun s e -> StringSet.add e s) !dirs (input_value ic)
   done;

diff --git a/debugger/time_travel.ml b/debugger/time_travel.ml
index ec72413b07ea8778a6a819d03ae985faf132efc5..cf7d47cb1907c7d73e296c414a5375502e6265fe 100644 (file)
--- a/debugger/time_travel.ml
+++ b/debugger/time_travel.ml
@@ -119,7 +119,7 @@ let kill_checkpoint checkpoint =
 
 (*** Cleaning the checkpoint list. ***)
 
-(* Separe checkpoints before (<=) and after (>) `t'. *)
+(* Separate checkpoints before (<=) and after (>) `t'. *)
 (* ### t checkpoints -> (after, before) *)
 let cut t =
   let rec cut_t =
@@ -147,7 +147,7 @@ let cut2 t0 t l =
     let (after, before) = cut (t0 -- _1) l in
       after::(cut2_t0 t before)
 
-(* Separe first elements and last element of a list of checkpoint. *)
+(* Separate first elements and last element of a list of checkpoints. *)
 let chk_merge2 cont =
   let rec chk_merge2_cont =
     function
@@ -160,7 +160,7 @@ let chk_merge2 cont =
           (accepted, a::rejected)
   in chk_merge2_cont
 
-(* Separe the checkpoint list. *)
+(* Separate the checkpoint list. *)
 (* ### list -> accepted * rejected *)
 let rec chk_merge =
   function
@@ -216,7 +216,7 @@ let find_checkpoint_before time =
   in find !checkpoints
 
 (* Make a copy of the current checkpoint and clean the checkpoint list. *)
-(* --- The new checkpoint in not put in the list. *)
+(* --- The new checkpoint is not put in the list. *)
 let duplicate_current_checkpoint () =
   let checkpoint = !current_checkpoint in
     if not checkpoint.c_valid then
@@ -499,14 +499,14 @@ let rec run () =
   if not !interrupted then
     run ()
 
-(* Run backward the program form current time. *)
+(* Run the program backward from current time. *)
 (* Stop at the first breakpoint, or at the beginning of the program. *)
 let back_run () =
   if current_time () > _0 then
     back_to _0 (current_time ())
 
 (* Step in any direction. *)
-(* Stop at the first brakpoint, or after `duration' steps. *)
+(* Stop at the first breakpoint, or after `duration' steps. *)
 let step duration =
   if duration >= _0 then
     step_forward duration

diff --git a/driver/compenv.ml b/driver/compenv.ml
index f037328d5c6d8d7164327cceea6ab4607c2be8bf..194fa617c8daeebebb5e366492d369291f45028b 100644 (file)
--- a/driver/compenv.ml
+++ b/driver/compenv.ml
@@ -404,7 +404,9 @@ let read_one_param ppf position name v =
   | "can-discard" ->
     can_discard := v ::!can_discard
 
-  | "timings" -> set "timings" [ print_timings ] v
+  | "timings" | "profile" ->
+     let if_on = if name = "timings" then [ `Time ] else Profile.all_columns in
+     profile_columns := if check_bool ppf name v then if_on else []
 
   | "plugin" -> !load_plugin v
 

diff --git a/driver/compile.ml b/driver/compile.ml
index 4e136e4c12e1a19e01fda354b53e1e0c65fdd23d..98ac5be470552d0a0d69464a5705c6b4a45f0cb9 100644 (file)
--- a/driver/compile.ml
+++ b/driver/compile.ml
@@ -27,33 +27,35 @@ open Compenv
 let tool_name = "ocamlc"
 
 let interface ppf sourcefile outputprefix =
-  Compmisc.init_path false;
-  let modulename = module_of_filename ppf sourcefile outputprefix in
-  Env.set_unit_name modulename;
-  let initial_env = Compmisc.initial_env () in
-  let ast = Pparse.parse_interface ~tool_name ppf sourcefile in
+  Profile.record_call sourcefile (fun () ->
+    Compmisc.init_path false;
+    let modulename = module_of_filename ppf sourcefile outputprefix in
+    Env.set_unit_name modulename;
+    let initial_env = Compmisc.initial_env () in
+    let ast = Pparse.parse_interface ~tool_name ppf sourcefile in
 
-  if !Clflags.dump_parsetree then fprintf ppf "%a@." Printast.interface ast;
-  if !Clflags.dump_source then fprintf ppf "%a@." Pprintast.signature ast;
-  Timings.(time_call (Typing sourcefile)) (fun () ->
-    let tsg = Typemod.type_interface sourcefile initial_env ast in
-    if !Clflags.dump_typedtree then fprintf ppf "%a@." Printtyped.interface tsg;
-    let sg = tsg.sig_type in
-    if !Clflags.print_types then
-      Printtyp.wrap_printing_env initial_env (fun () ->
-          fprintf std_formatter "%a@."
-            Printtyp.signature (Typemod.simplify_signature sg));
-    ignore (Includemod.signatures initial_env sg sg);
-    Typecore.force_delayed_checks ();
-    Warnings.check_fatal ();
-    if not !Clflags.print_types then begin
-      let deprecated = Builtin_attributes.deprecated_of_sig ast in
-      let sg =
-        Env.save_signature ~deprecated sg modulename (outputprefix ^ ".cmi")
-      in
-      Typemod.save_signature modulename tsg outputprefix sourcefile
-        initial_env sg ;
-    end
+    if !Clflags.dump_parsetree then fprintf ppf "%a@." Printast.interface ast;
+    if !Clflags.dump_source then fprintf ppf "%a@." Pprintast.signature ast;
+    Profile.(record_call typing) (fun () ->
+      let tsg = Typemod.type_interface sourcefile initial_env ast in
+      if !Clflags.dump_typedtree then fprintf ppf "%a@." Printtyped.interface tsg;
+      let sg = tsg.sig_type in
+      if !Clflags.print_types then
+        Printtyp.wrap_printing_env initial_env (fun () ->
+            fprintf std_formatter "%a@."
+              Printtyp.signature (Typemod.simplify_signature sg));
+      ignore (Includemod.signatures initial_env sg sg);
+      Typecore.force_delayed_checks ();
+      Warnings.check_fatal ();
+      if not !Clflags.print_types then begin
+        let deprecated = Builtin_attributes.deprecated_of_sig ast in
+        let sg =
+          Env.save_signature ~deprecated sg modulename (outputprefix ^ ".cmi")
+        in
+        Typemod.save_signature modulename tsg outputprefix sourcefile
+          initial_env sg ;
+      end
+    )
   )
 
 (* Compile a .ml file *)
@@ -65,51 +67,53 @@ let print_if ppf flag printer arg =
 let (++) x f = f x
 
 let implementation ppf sourcefile outputprefix =
-  Compmisc.init_path false;
-  let modulename = module_of_filename ppf sourcefile outputprefix in
-  Env.set_unit_name modulename;
-  let env = Compmisc.initial_env() in
-  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
-      ++ Timings.(time (Typing sourcefile))
-          (Typemod.type_implementation sourcefile outputprefix modulename env)
-      ++ print_if ppf Clflags.dump_typedtree
-        Printtyped.implementation_with_coercion
-   in
-    if !Clflags.print_types then begin
-      Warnings.check_fatal ();
-      Stypes.dump (Some (outputprefix ^ ".annot"))
-    end else begin
-      let bytecode, required_globals =
-        (typedtree, coercion)
-        ++ Timings.(time (Transl sourcefile))
-            (Translmod.transl_implementation modulename)
-        ++ Timings.(accumulate_time (Generate sourcefile))
-            (fun { Lambda.code = lambda; required_globals } ->
-              print_if ppf Clflags.dump_rawlambda Printlambda.lambda lambda
-              ++ Simplif.simplify_lambda sourcefile
-              ++ print_if ppf Clflags.dump_lambda Printlambda.lambda
-              ++ Bytegen.compile_implementation modulename
-              ++ print_if ppf Clflags.dump_instr Printinstr.instrlist
-              ++ fun bytecode -> bytecode, required_globals)
-      in
-      let objfile = outputprefix ^ ".cmo" in
-      let oc = open_out_bin objfile in
-      try
-        bytecode
-        ++ Timings.(accumulate_time (Generate sourcefile))
-            (Emitcode.to_file oc modulename objfile ~required_globals);
+  Profile.record_call sourcefile (fun () ->
+    Compmisc.init_path false;
+    let modulename = module_of_filename ppf sourcefile outputprefix in
+    Env.set_unit_name modulename;
+    let env = Compmisc.initial_env() in
+    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
+        ++ Profile.(record typing)
+            (Typemod.type_implementation sourcefile outputprefix modulename env)
+        ++ print_if ppf Clflags.dump_typedtree
+          Printtyped.implementation_with_coercion
+     in
+      if !Clflags.print_types then begin
         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
+      end else begin
+        let bytecode, required_globals =
+          (typedtree, coercion)
+          ++ Profile.(record transl)
+              (Translmod.transl_implementation modulename)
+          ++ Profile.(record ~accumulate:true generate)
+              (fun { Lambda.code = lambda; required_globals } ->
+                print_if ppf Clflags.dump_rawlambda Printlambda.lambda lambda
+                ++ Simplif.simplify_lambda sourcefile
+                ++ print_if ppf Clflags.dump_lambda Printlambda.lambda
+                ++ Bytegen.compile_implementation modulename
+                ++ print_if ppf Clflags.dump_instr Printinstr.instrlist
+                ++ fun bytecode -> bytecode, required_globals)
+        in
+        let objfile = outputprefix ^ ".cmo" in
+        let oc = open_out_bin objfile in
+        try
+          bytecode
+          ++ Profile.(record ~accumulate:true generate)
+              (Emitcode.to_file oc modulename objfile ~required_globals);
+          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
+  )

diff --git a/driver/compmisc.ml b/driver/compmisc.ml
index bf45f6658a175e1957fa450021e4784cab5b1e42..a0839f34ca55c65f784ef0e340a7aa64f2e1b8c8 100644 (file)
--- a/driver/compmisc.ml
+++ b/driver/compmisc.ml
@@ -52,7 +52,8 @@ let open_implicit_module m env =
 let initial_env () =
   Ident.reinit();
   let initial =
-    if !Clflags.unsafe_string then Env.initial_unsafe_string
+    if Config.safe_string then Env.initial_safe_string
+    else if !Clflags.unsafe_string then Env.initial_unsafe_string
     else Env.initial_safe_string
   in
   let env =

diff --git a/driver/main.ml b/driver/main.ml
index 250c5ef809e0028fc0a519516b21b8aecc8138a4..110ea3cf3ea920fbce5302a90f383f78bf905645 100644 (file)
--- a/driver/main.ml
+++ b/driver/main.ml
@@ -117,7 +117,8 @@ module Options = Main_args.Make_bytecomp_options (struct
   let _drawlambda = set dump_rawlambda
   let _dlambda = set dump_lambda
   let _dinstr = set dump_instr
-  let _dtimings = set print_timings
+  let _dtimings () = profile_columns := [ `Time ]
+  let _dprofile () = profile_columns := Profile.all_columns
 
   let _args = Arg.read_arg
   let _args0 = Arg.read_arg0
@@ -127,6 +128,9 @@ end)
 
 let main () =
   Clflags.add_arguments __LOC__ Options.list;
+  Clflags.add_arguments __LOC__
+    ["-depend", Arg.Unit Makedepend.main_from_option,
+     "<options> Compute dependencies (use 'ocamlc -depend -help' for details)"];
   try
     readenv ppf Before_args;
     Clflags.parse_arguments anonymous usage;
@@ -196,7 +200,7 @@ let main () =
     Location.report_exception ppf x;
     exit 2
 
-let _ =
-  Timings.(time All) main ();
-  if !Clflags.print_timings then Timings.print Format.std_formatter;
+let () =
+  main ();
+  Profile.print Format.std_formatter !Clflags.profile_columns;
   exit 0

diff --git a/driver/main_args.ml b/driver/main_args.ml
index bf1fb8ef1d523fb2ae8d53f7564e763b095be910..757c7ac5b4da1034b239025f9c734cb0a74ad43e 100644 (file)
--- a/driver/main_args.ml
+++ b/driver/main_args.ml
@@ -233,11 +233,11 @@ let mk_no_keep_docs f =
 ;;
 
 let mk_keep_locs f =
-  "-keep-locs", Arg.Unit f, " Keep locations in .cmi files"
+  "-keep-locs", Arg.Unit f, " Keep locations in .cmi files (default)"
 ;;
 
 let mk_no_keep_locs f =
-  "-no-keep-locs", Arg.Unit f, " Do not keep locations in .cmi files (default)"
+  "-no-keep-locs", Arg.Unit f, " Do not keep locations in .cmi files"
 ;;
 
 let mk_labels f =
@@ -248,6 +248,10 @@ let mk_linkall f =
   "-linkall", Arg.Unit f, " Link all modules, even unused ones"
 ;;
 
+let mk_linscan f =
+  "-linscan", Arg.Unit f, " Use the linear scan register allocator"
+;;
+
 let mk_make_runtime f =
   "-make-runtime", Arg.Unit f,
   " Build a runtime system with given C objects and libraries"
@@ -424,7 +428,8 @@ let mk_S f =
 
 let mk_safe_string f =
   "-safe-string", Arg.Unit f,
-  if Config.safe_string then " Make strings immutable (default)"
+  if Config.safe_string then " (was set when configuring the compiler)"
+  else if Config.default_safe_string then " Make strings immutable (default)"
   else " Make strings immutable"
 ;;
 
@@ -456,7 +461,11 @@ let mk_thread f =
 ;;
 
 let mk_dtimings f =
-  "-dtimings", Arg.Unit f, " Print timings"
+  "-dtimings", Arg.Unit f, " Print timings information for each pass";
+;;
+
+let mk_dprofile f =
+  "-dprofile", Arg.Unit f, Profile.options_doc
 ;;
 
 let mk_unbox_closures f =
@@ -490,10 +499,12 @@ let mk_unsafe f =
 let mk_unsafe_string f =
   if Config.safe_string then
     let err () =
-      raise (Arg.Bad "OCaml has been configured with -safe-string: \
+      raise (Arg.Bad "OCaml has been configured with -force-safe-string: \
                       -unsafe-string is not available")
     in
     "-unsafe-string", Arg.Unit err, " (option not available)"
+  else if Config.default_safe_string then
+    "-unsafe-string", Arg.Unit f, " Make strings mutable"
   else
     "-unsafe-string", Arg.Unit f, " Make strings mutable (default)"
 ;;
@@ -665,6 +676,16 @@ let mk_dlive f =
   "-dlive", Arg.Unit f, " (undocumented)"
 ;;
 
+let mk_davail f =
+  "-davail", Arg.Unit f, " Print register availability info when printing \
+    liveness"
+;;
+
+let mk_drunavail f =
+  "-drunavail", Arg.Unit f, " Run register availability pass (for testing \
+    only; needs -g)"
+;;
+
 let mk_dspill f =
   "-dspill", Arg.Unit f, " (undocumented)"
 ;;
@@ -697,6 +718,10 @@ let mk_dlinear f =
   "-dlinear", Arg.Unit f, " (undocumented)"
 ;;
 
+let mk_dinterval f =
+  "-dinterval", Arg.Unit f, " (undocumented)"
+;;
+
 let mk_dstartup f =
   "-dstartup", Arg.Unit f, " (undocumented)"
 ;;
@@ -835,6 +860,7 @@ module type Compiler_options = sig
 
   val _nopervasives : unit -> unit
   val _dtimings : unit -> unit
+  val _dprofile : unit -> unit
 
   val _args: string -> string array
   val _args0: string -> string array
@@ -848,7 +874,6 @@ module type Toplevel_options = sig
   val _no_version : unit -> unit
   val _noprompt : unit -> unit
   val _nopromptcont : unit -> unit
-  val _plugin : string -> unit
   val _stdin : unit -> unit
   val _args : string -> string array
   val _args0 : string -> string array
@@ -916,6 +941,8 @@ module type Optcommon_options = sig
   val _dcombine : unit -> unit
   val _dcse : unit -> unit
   val _dlive : unit -> unit
+  val _davail : unit -> unit
+  val _drunavail : unit -> unit
   val _dspill : unit -> unit
   val _dsplit : unit -> unit
   val _dinterf : unit -> unit
@@ -931,6 +958,7 @@ module type Optcomp_options = sig
   include Common_options
   include Compiler_options
   include Optcommon_options
+  val _linscan : unit -> unit
   val _no_float_const_prop : unit -> unit
   val _nodynlink : unit -> unit
   val _p : unit -> unit
@@ -939,6 +967,7 @@ module type Optcomp_options = sig
   val _shared : unit -> unit
   val _afl_instrument : unit -> unit
   val _afl_inst_ratio : int -> unit
+  val _dinterval : unit -> unit
 end;;
 
 module type Opttop_options = sig
@@ -1060,6 +1089,7 @@ struct
     mk_dlambda F._dlambda;
     mk_dinstr F._dinstr;
     mk_dtimings F._dtimings;
+    mk_dprofile F._dprofile;
 
     mk_args F._args;
     mk_args0 F._args0;
@@ -1085,7 +1115,6 @@ struct
     mk_nostdlib F._nostdlib;
     mk_open F._open;
     mk_ppx F._ppx;
-    mk_plugin F._plugin;
     mk_principal F._principal;
     mk_no_principal F._no_principal;
     mk_rectypes F._rectypes;
@@ -1167,6 +1196,7 @@ struct
     mk_inline_max_depth F._inline_max_depth;
     mk_alias_deps F._alias_deps;
     mk_no_alias_deps F._no_alias_deps;
+    mk_linscan F._linscan;
     mk_app_funct F._app_funct;
     mk_no_app_funct F._no_app_funct;
     mk_no_float_const_prop F._no_float_const_prop;
@@ -1241,6 +1271,8 @@ struct
     mk_dcombine F._dcombine;
     mk_dcse F._dcse;
     mk_dlive F._dlive;
+    mk_davail F._davail;
+    mk_drunavail F._drunavail;
     mk_dspill F._dspill;
     mk_dsplit F._dsplit;
     mk_dinterf F._dinterf;
@@ -1249,8 +1281,10 @@ struct
     mk_dreload F._dreload;
     mk_dscheduling F._dscheduling;
     mk_dlinear F._dlinear;
+    mk_dinterval F._dinterval;
     mk_dstartup F._dstartup;
     mk_dtimings F._dtimings;
+    mk_dprofile F._dprofile;
     mk_dump_pass F._dump_pass;
 
     mk_args F._args;
@@ -1293,7 +1327,6 @@ module Make_opttop_options (F : Opttop_options) = struct
     mk_o2 F._o2;
     mk_o3 F._o3;
     mk_open F._open;
-    mk_plugin F._plugin;
     mk_ppx F._ppx;
     mk_principal F._principal;
     mk_no_principal F._no_principal;
@@ -1337,6 +1370,8 @@ module Make_opttop_options (F : Opttop_options) = struct
     mk_dcombine F._dcombine;
     mk_dcse F._dcse;
     mk_dlive F._dlive;
+    mk_davail F._davail;
+    mk_drunavail F._drunavail;
     mk_dspill F._dspill;
     mk_dsplit F._dsplit;
     mk_dinterf F._dinterf;

diff --git a/driver/main_args.mli b/driver/main_args.mli
index dfe90c000ffaef35a04486eb7ccd8725fbc7b241..3d6db5351ed8875cd7f8efad63a6eabdd83167cf 100644 (file)
--- a/driver/main_args.mli
+++ b/driver/main_args.mli
@@ -100,6 +100,7 @@ module type Compiler_options = sig
 
   val _nopervasives : unit -> unit
   val _dtimings : unit -> unit
+  val _dprofile : unit -> unit
 
   val _args: string -> string array
   val _args0: string -> string array
@@ -113,7 +114,6 @@ module type Toplevel_options = sig
   val _no_version : unit -> unit
   val _noprompt : unit -> unit
   val _nopromptcont : unit -> unit
-  val _plugin : string -> unit
   val _stdin : unit -> unit
   val _args: string -> string array
   val _args0: string -> string array
@@ -181,6 +181,8 @@ module type Optcommon_options = sig
   val _dcombine : unit -> unit
   val _dcse : unit -> unit
   val _dlive : unit -> unit
+  val _davail : unit -> unit
+  val _drunavail : unit -> unit
   val _dspill : unit -> unit
   val _dsplit : unit -> unit
   val _dinterf : unit -> unit
@@ -196,6 +198,7 @@ module type Optcomp_options = sig
   include Common_options
   include Compiler_options
   include Optcommon_options
+  val _linscan : unit -> unit
   val _no_float_const_prop : unit -> unit
   val _nodynlink : unit -> unit
   val _p : unit -> unit
@@ -204,6 +207,7 @@ module type Optcomp_options = sig
   val _shared : unit -> unit
   val _afl_instrument : unit -> unit
   val _afl_inst_ratio : int -> unit
+  val _dinterval : unit -> unit
 end;;
 
 module type Opttop_options = sig

diff --git a/driver/makedepend.ml b/driver/makedepend.ml
new file mode 100644 (file)
index 0000000..6b888a0
--- /dev/null
+++ b/driver/makedepend.ml
@@ -0,0 +1,626 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1999 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Compenv
+open Parsetree
+module StringMap = Depend.StringMap
+
+let ppf = Format.err_formatter
+(* Print the dependencies *)
+
+type file_kind = ML | MLI;;
+
+let load_path = ref ([] : (string * string array) list)
+let ml_synonyms = ref [".ml"]
+let mli_synonyms = ref [".mli"]
+let shared = ref false
+let native_only = ref false
+let bytecode_only = ref false
+let error_occurred = ref false
+let raw_dependencies = ref false
+let sort_files = ref false
+let all_dependencies = ref false
+let one_line = ref false
+let files =
+  ref ([] : (string * file_kind * Depend.StringSet.t * string list) list)
+let allow_approximation = ref false
+let map_files = ref []
+let module_map = ref StringMap.empty
+let debug = ref false
+
+(* Fix path to use '/' as directory separator instead of '\'.
+   Only under Windows. *)
+
+let fix_slash s =
+  if Sys.os_type = "Unix" then s else begin
+    String.map (function '\\' -> '/' | c -> c) s
+  end
+
+(* Since we reinitialize load_path after reading OCAMLCOMP,
+  we must use a cache instead of calling Sys.readdir too often. *)
+let dirs = ref StringMap.empty
+let readdir dir =
+  try
+    StringMap.find dir !dirs
+  with Not_found ->
+    let contents =
+      try
+        Sys.readdir dir
+      with Sys_error msg ->
+        Format.fprintf Format.err_formatter "@[Bad -I option: %s@]@." msg;
+        error_occurred := true;
+        [||]
+    in
+    dirs := StringMap.add dir contents !dirs;
+    contents
+
+let add_to_list li s =
+  li := s :: !li
+
+let add_to_load_path dir =
+  try
+    let dir = Misc.expand_directory Config.standard_library dir in
+    let contents = readdir dir in
+    add_to_list load_path (dir, contents)
+  with Sys_error msg ->
+    Format.fprintf Format.err_formatter "@[Bad -I option: %s@]@." msg;
+    error_occurred := true
+
+let add_to_synonym_list synonyms suffix =
+  if (String.length suffix) > 1 && suffix.[0] = '.' then
+    add_to_list synonyms suffix
+  else begin
+    Format.fprintf Format.err_formatter "@[Bad suffix: '%s'@]@." suffix;
+    error_occurred := true
+  end
+
+(* Find file 'name' (capitalized) in search path *)
+let find_file name =
+  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
+      if s = name || s = uname then Some s else find_in_array a (pos + 1)
+    end in
+  let rec find_in_path = function
+    [] -> raise Not_found
+  | (dir, contents) :: rem ->
+      match find_in_array contents 0 with
+        Some truename ->
+          if dir = "." then truename else Filename.concat dir truename
+      | None -> find_in_path rem in
+  find_in_path !load_path
+
+let rec find_file_in_list = function
+  [] -> raise Not_found
+| x :: rem -> try find_file x with Not_found -> find_file_in_list rem
+
+
+let find_dependency target_kind modname (byt_deps, opt_deps) =
+  try
+    let candidates = List.map ((^) modname) !mli_synonyms in
+    let filename = find_file_in_list candidates in
+    let basename = Filename.chop_extension filename in
+    let cmi_file = basename ^ ".cmi" in
+    let cmx_file = basename ^ ".cmx" in
+    let ml_exists =
+      List.exists (fun ext -> Sys.file_exists (basename ^ ext)) !ml_synonyms in
+    let new_opt_dep =
+      if !all_dependencies then
+        match target_kind with
+        | MLI -> [ cmi_file ]
+        | ML  ->
+          cmi_file :: (if ml_exists then [ cmx_file ] else [])
+      else
+        (* this is a make-specific hack that makes .cmx to be a 'proxy'
+           target that would force the dependency on .cmi via transitivity *)
+        if ml_exists
+        then [ cmx_file ]
+        else [ cmi_file ]
+    in
+    ( cmi_file :: byt_deps, new_opt_dep @ opt_deps)
+  with Not_found ->
+  try
+    (* "just .ml" case *)
+    let candidates = List.map ((^) modname) !ml_synonyms in
+    let filename = find_file_in_list candidates in
+    let basename = Filename.chop_extension filename in
+    let cmi_file = basename ^ ".cmi" in
+    let cmx_file = basename ^ ".cmx" in
+    let bytenames =
+      if !all_dependencies then
+        match target_kind with
+        | MLI -> [ cmi_file ]
+        | ML  -> [ cmi_file ]
+      else
+        (* again, make-specific hack *)
+        [basename ^ (if !native_only then ".cmx" else ".cmo")] in
+    let optnames =
+      if !all_dependencies
+      then match target_kind with
+        | MLI -> [ cmi_file ]
+        | ML  -> [ cmi_file; cmx_file ]
+      else [ cmx_file ]
+    in
+    (bytenames @ byt_deps, optnames @  opt_deps)
+  with Not_found ->
+    (byt_deps, opt_deps)
+
+let (depends_on, escaped_eol) = (":", " \\\n    ")
+
+let print_filename s =
+  let s = if !Clflags.force_slash then fix_slash s else s in
+  if not (String.contains s ' ') then begin
+    print_string s;
+  end else begin
+    let rec count n i =
+      if i >= String.length s then n
+      else if s.[i] = ' ' then count (n+1) (i+1)
+      else count n (i+1)
+    in
+    let spaces = count 0 0 in
+    let result = Bytes.create (String.length s + spaces) in
+    let rec loop i j =
+      if i >= String.length s then ()
+      else if s.[i] = ' ' then begin
+        Bytes.set result j '\\';
+        Bytes.set result (j+1) ' ';
+        loop (i+1) (j+2);
+      end else begin
+        Bytes.set result j s.[i];
+        loop (i+1) (j+1);
+      end
+    in
+    loop 0 0;
+    print_bytes result;
+  end
+;;
+
+let print_dependencies target_files deps =
+  let rec print_items pos = function
+    [] -> print_string "\n"
+  | dep :: rem ->
+    if !one_line || (pos + 1 + String.length dep <= 77) then begin
+        if pos <> 0 then print_string " "; print_filename dep;
+        print_items (pos + String.length dep + 1) rem
+      end else begin
+        print_string escaped_eol; print_filename dep;
+        print_items (String.length dep + 4) rem
+      end in
+  print_items 0 (target_files @ [depends_on] @ deps)
+
+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' | '\128'..'\255' -> true
+              | _ -> false) then
+        begin
+          print_char ' ';
+          print_string dep
+        end)
+    deps;
+  print_char '\n'
+
+
+(* Process one file *)
+
+let report_err exn =
+  error_occurred := true;
+  Location.report_exception Format.err_formatter 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;
+  Depend.free_structure_names := Depend.StringSet.empty;
+  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 def ast_kind
+    source_file =
+  Depend.pp_deps := [];
+  Depend.free_structure_names := Depend.StringSet.empty;
+  try
+    let input_file = Pparse.preprocess source_file in
+    begin try
+      let ast =
+        Pparse.file ~tool_name Format.err_formatter
+                    input_file parse_function ast_kind
+      in
+      let bound_vars =
+        List.fold_left
+          (fun bv modname ->
+            Depend.open_module bv (Longident.parse modname))
+          !module_map ((* PR#7248 *) List.rev !Clflags.open_modules)
+      in
+      let r = extract_function bound_vars ast in
+      Pparse.remove_preprocessed input_file;
+      (!Depend.free_structure_names, r)
+    with x ->
+      Pparse.remove_preprocessed input_file;
+      raise x
+    end
+  with x -> begin
+    report_err x;
+    if not !allow_approximation
+    then (Depend.StringSet.empty, def)
+    else (read_and_approximate source_file, def)
+  end
+
+let print_ml_dependencies source_file extracted_deps pp_deps =
+  let basename = Filename.chop_extension source_file in
+  let byte_targets = [ basename ^ ".cmo" ] in
+  let native_targets =
+    if !all_dependencies
+    then [ basename ^ ".cmx"; basename ^ ".o" ]
+    else [ basename ^ ".cmx" ] in
+  let shared_targets = [ basename ^ ".cmxs" ] in
+  let init_deps = if !all_dependencies then [source_file] else [] in
+  let cmi_name = basename ^ ".cmi" in
+  let init_deps, extra_targets =
+    if List.exists (fun ext -> Sys.file_exists (basename ^ ext))
+        !mli_synonyms
+    then (cmi_name :: init_deps, cmi_name :: init_deps), []
+    else (init_deps, init_deps),
+         (if !all_dependencies then [cmi_name] else [])
+  in
+  let (byt_deps, native_deps) =
+    Depend.StringSet.fold (find_dependency ML)
+      extracted_deps init_deps in
+  if not !native_only then
+    print_dependencies (byte_targets @ extra_targets) (byt_deps @ pp_deps);
+  if not !bytecode_only then
+    begin
+      print_dependencies (native_targets @ extra_targets)
+        (native_deps @ pp_deps);
+      if !shared then
+        print_dependencies (shared_targets @ extra_targets)
+          (native_deps @ pp_deps)
+    end
+
+let print_mli_dependencies source_file extracted_deps pp_deps =
+  let basename = Filename.chop_extension source_file in
+  let (byt_deps, _opt_deps) =
+    Depend.StringSet.fold (find_dependency MLI)
+      extracted_deps ([], []) in
+  print_dependencies [basename ^ ".cmi"] (byt_deps @ pp_deps)
+
+let print_file_dependencies (source_file, kind, extracted_deps, pp_deps) =
+  if !raw_dependencies then begin
+    print_raw_dependencies source_file extracted_deps
+  end else
+    match kind with
+    | ML -> print_ml_dependencies source_file extracted_deps pp_deps
+    | MLI -> print_mli_dependencies source_file extracted_deps pp_deps
+
+
+let ml_file_dependencies source_file =
+  let parse_use_file_as_impl lexbuf =
+    let f x =
+      match x with
+      | Ptop_def s -> s
+      | Ptop_dir _ -> []
+    in
+    List.flatten (List.map f (Parse.use_file lexbuf))
+  in
+  let (extracted_deps, ()) =
+    read_parse_and_extract parse_use_file_as_impl Depend.add_implementation ()
+                           Pparse.Structure source_file
+  in
+  files := (source_file, ML, extracted_deps, !Depend.pp_deps) :: !files
+
+let mli_file_dependencies source_file =
+  let (extracted_deps, ()) =
+    read_parse_and_extract Parse.interface Depend.add_signature ()
+                           Pparse.Signature source_file
+  in
+  files := (source_file, MLI, extracted_deps, !Depend.pp_deps) :: !files
+
+let process_file_as process_fun def source_file =
+  Compenv.readenv ppf (Before_compile source_file);
+  load_path := [];
+  List.iter add_to_load_path (
+      (!Compenv.last_include_dirs @
+       !Clflags.include_dirs @
+       !Compenv.first_include_dirs
+      ));
+  Location.input_name := source_file;
+  try
+    if Sys.file_exists source_file then process_fun source_file else def
+  with x -> report_err x; def
+
+let process_file source_file ~ml_file ~mli_file ~def =
+  if List.exists (Filename.check_suffix source_file) !ml_synonyms then
+    process_file_as ml_file def source_file
+  else if List.exists (Filename.check_suffix source_file) !mli_synonyms then
+    process_file_as mli_file def source_file
+  else def
+
+let file_dependencies source_file =
+  process_file source_file ~def:()
+    ~ml_file:ml_file_dependencies
+    ~mli_file:mli_file_dependencies
+
+let file_dependencies_as kind =
+  match kind with
+  | ML -> process_file_as ml_file_dependencies ()
+  | MLI -> process_file_as mli_file_dependencies ()
+
+let sort_files_by_dependencies files =
+  let h = Hashtbl.create 31 in
+  let worklist = ref [] in
+
+(* Init Hashtbl with all defined modules *)
+  let files = List.map (fun (file, file_kind, deps, pp_deps) ->
+    let modname =
+      String.capitalize_ascii (Filename.chop_extension (Filename.basename file))
+    in
+    let key = (modname, file_kind) in
+    let new_deps = ref [] in
+    Hashtbl.add h key (file, new_deps);
+    worklist := key :: !worklist;
+    (modname, file_kind, deps, new_deps, pp_deps)
+  ) files in
+
+(* Keep only dependencies to defined modules *)
+  List.iter (fun (modname, file_kind, deps, new_deps, _pp_deps) ->
+    let add_dep modname kind =
+      new_deps := (modname, kind) :: !new_deps;
+    in
+    Depend.StringSet.iter (fun modname ->
+      match file_kind with
+          ML -> (* ML depends both on ML and MLI *)
+            if Hashtbl.mem h (modname, MLI) then add_dep modname MLI;
+            if Hashtbl.mem h (modname, ML) then add_dep modname ML
+        | MLI -> (* MLI depends on MLI if exists, or ML otherwise *)
+          if Hashtbl.mem h (modname, MLI) then add_dep modname MLI
+          else if Hashtbl.mem h (modname, ML) then add_dep modname ML
+    ) deps;
+    if file_kind = ML then (* add dep from .ml to .mli *)
+      if Hashtbl.mem h (modname, MLI) then add_dep modname MLI
+  ) files;
+
+(* Print and remove all files with no remaining dependency. Iterate
+   until all files have been removed (worklist is empty) or
+   no file was removed during a turn (cycle). *)
+  let printed = ref true in
+  while !printed && !worklist <> [] do
+    let files = !worklist in
+    worklist := [];
+    printed := false;
+    List.iter (fun key ->
+      let (file, deps) = Hashtbl.find h key in
+      let set = !deps in
+      deps := [];
+      List.iter (fun key ->
+        if Hashtbl.mem h key then deps := key :: !deps
+      ) set;
+      if !deps = [] then begin
+        printed := true;
+        Printf.printf "%s " file;
+        Hashtbl.remove h key;
+      end else
+        worklist := key :: !worklist
+    ) files
+  done;
+
+  if !worklist <> [] then begin
+    Format.fprintf Format.err_formatter
+      "@[Warning: cycle in dependencies. End of list is not sorted.@]@.";
+    let sorted_deps =
+      let li = ref [] in
+      Hashtbl.iter (fun _ file_deps -> li := file_deps :: !li) h;
+      List.sort (fun (file1, _) (file2, _) -> String.compare file1 file2) !li
+    in
+    List.iter (fun (file, deps) ->
+      Format.fprintf Format.err_formatter "\t@[%s: " file;
+      List.iter (fun (modname, kind) ->
+        Format.fprintf Format.err_formatter "%s.%s " modname
+          (if kind=ML then "ml" else "mli");
+      ) !deps;
+      Format.fprintf Format.err_formatter "@]@.";
+      Printf.printf "%s " file) sorted_deps;
+  end;
+  Printf.printf "\n%!";
+  ()
+
+(* Map *)
+
+let rec dump_map s0 ppf m =
+  let open Depend in
+  StringMap.iter
+    (fun key (Node(s1,m')) ->
+      let s = StringSet.diff s1 s0 in
+      if StringSet.is_empty s then
+        Format.fprintf ppf "@ @[<hv2>module %s : sig%a@;<1 -2>end@]"
+          key (dump_map (StringSet.union s1 s0)) m'
+      else
+        Format.fprintf ppf "@ module %s = %s" key (StringSet.choose s))
+    m
+
+let process_ml_map =
+  read_parse_and_extract Parse.implementation Depend.add_implementation_binding
+                         StringMap.empty Pparse.Structure
+
+let process_mli_map =
+  read_parse_and_extract Parse.interface Depend.add_signature_binding
+                         StringMap.empty Pparse.Signature
+
+let parse_map fname =
+  map_files := fname :: !map_files ;
+  let old_transp = !Clflags.transparent_modules in
+  Clflags.transparent_modules := true;
+  let (deps, m) =
+    process_file fname ~def:(Depend.StringSet.empty, StringMap.empty)
+      ~ml_file:process_ml_map
+      ~mli_file:process_mli_map
+  in
+  Clflags.transparent_modules := old_transp;
+  let modname =
+    String.capitalize_ascii
+      (Filename.basename (Filename.chop_extension fname)) in
+  if StringMap.is_empty m then
+    report_err (Failure (fname ^ " : empty map file or parse error"));
+  let mm = Depend.make_node m in
+  if !debug then begin
+    Format.printf "@[<v>%s:%t%a@]@." fname
+      (fun ppf -> Depend.StringSet.iter (Format.fprintf ppf " %s") deps)
+      (dump_map deps) (StringMap.add modname mm StringMap.empty)
+  end;
+  let mm = Depend.(weaken_map (StringSet.singleton modname) mm) in
+  module_map := StringMap.add modname mm !module_map
+;;
+
+
+(* Entry point *)
+
+let print_version () =
+  Format.printf "ocamldep, version %s@." Sys.ocaml_version;
+  exit 0;
+;;
+
+let print_version_num () =
+  Format.printf "%s@." Sys.ocaml_version;
+  exit 0;
+;;
+
+let main () =
+  Clflags.classic := false;
+  add_to_list first_include_dirs Filename.current_dir_name;
+  Compenv.readenv ppf Before_args;
+  Clflags.reset_arguments (); (* reset arguments from ocamlc/ocamlopt *)
+  Clflags.add_arguments __LOC__ [
+     "-absname", Arg.Set Location.absname,
+        " Show absolute filenames in error messages";
+     "-all", Arg.Set all_dependencies,
+        " Generate dependencies on all files";
+     "-allow-approx", Arg.Set allow_approximation,
+        " Fallback to a lexer-based approximation on unparseable files";
+     "-as-map", Arg.Set Clflags.transparent_modules,
+      " Omit delayed dependencies for module aliases (-no-alias-deps -w -49)";
+      (* "compiler uses -no-alias-deps, and no module is coerced"; *)
+     "-debug-map", Arg.Set debug,
+        " Dump the delayed dependency map for each map file";
+     "-I", Arg.String (add_to_list Clflags.include_dirs),
+        "<dir>  Add <dir> to the list of include directories";
+     "-impl", Arg.String (file_dependencies_as ML),
+        "<f>  Process <f> as a .ml file";
+     "-intf", Arg.String (file_dependencies_as MLI),
+        "<f>  Process <f> as a .mli file";
+     "-map", Arg.String parse_map,
+        "<f>  Read <f> and propagate delayed dependencies to following 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),
+        "<e>  Consider <e> as a synonym of the .mli extension";
+     "-modules", Arg.Set raw_dependencies,
+        " Print module dependencies in raw form (not suitable for make)";
+     "-native", Arg.Set native_only,
+        " Generate dependencies for native-code only (no .cmo files)";
+     "-bytecode", Arg.Set bytecode_only,
+        " Generate dependencies for bytecode-code only (no .cmx files)";
+     "-one-line", Arg.Set one_line,
+        " Output one line per file, regardless of the length";
+     "-open", Arg.String (add_to_list Clflags.open_modules),
+        "<module>  Opens the module <module> before typing";
+     "-plugin", Arg.String Compplugin.load,
+         "<plugin>  Load dynamic plugin <plugin>";
+     "-pp", Arg.String(fun s -> Clflags.preprocessor := Some s),
+         "<cmd>  Pipe sources through preprocessor <cmd>";
+     "-ppx", Arg.String (add_to_list first_ppx),
+         "<cmd>  Pipe abstract syntax trees through preprocessor <cmd>";
+     "-shared", Arg.Set shared,
+         " Generate dependencies for native plugin files (.cmxs targets)";
+     "-slash", Arg.Set Clflags.force_slash,
+         " (Windows) Use forward slash / instead of backslash \\ in file paths";
+     "-sort", Arg.Set sort_files,
+        " Sort files according to their dependencies";
+     "-version", Arg.Unit print_version,
+         " Print version and exit";
+     "-vnum", Arg.Unit print_version_num,
+         " Print version number and exit";
+     "-args", Arg.Expand Arg.read_arg,
+         "<file> Read additional newline separated command line arguments \n\
+         \      from <file>";
+     "-args0", Arg.Expand Arg.read_arg0,
+         "<file> Read additional NUL separated command line arguments from \n\
+         \      <file>"
+  ];
+  let usage =
+    Printf.sprintf "Usage: %s [options] <source files>\nOptions are:"
+                   (Filename.basename Sys.argv.(0))
+  in
+  Clflags.parse_arguments file_dependencies usage;
+  Compenv.readenv ppf Before_link;
+  if !sort_files then sort_files_by_dependencies !files
+  else List.iter print_file_dependencies (List.sort compare !files);
+  exit (if !error_occurred then 2 else 0)
+
+let main_from_option () =
+  if Sys.argv.(1) <> "-depend" then begin
+    Printf.eprintf
+      "Fatal error: argument -depend must be used as first argument.\n%!";
+    exit 2;
+  end;
+  incr Arg.current;
+  Sys.argv.(0) <- Sys.argv.(0) ^ " -depend";
+  Sys.argv.(!Arg.current) <- Sys.argv.(0);
+  main ()

diff --git a/driver/makedepend.mli b/driver/makedepend.mli
new file mode 100644 (file)
index 0000000..5a0a8f1
--- /dev/null
+++ b/driver/makedepend.mli
@@ -0,0 +1,19 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1999 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+val main : unit -> unit
+
+(* entry point when called from the -depend option of ocamlc/ocamlopt *)
+val main_from_option : unit -> unit

diff --git a/driver/optcompile.ml b/driver/optcompile.ml
index 876b1cc90339ca3fde1cf3fc15d886ff99ff0fbb..c450b5f67bc528b043de560ad0b41ca67faf612a 100644 (file)
--- a/driver/optcompile.ml
+++ b/driver/optcompile.ml
@@ -28,32 +28,34 @@ open Compenv
 let tool_name = "ocamlopt"
 
 let interface ppf sourcefile outputprefix =
-  Compmisc.init_path false;
-  let modulename = module_of_filename ppf sourcefile outputprefix in
-  Env.set_unit_name modulename;
-  let initial_env = Compmisc.initial_env () in
-  let ast = Pparse.parse_interface ~tool_name ppf sourcefile in
-  if !Clflags.dump_parsetree then fprintf ppf "%a@." Printast.interface ast;
-  if !Clflags.dump_source then fprintf ppf "%a@." Pprintast.signature ast;
-  Timings.(time_call (Typing sourcefile)) (fun () ->
-    let tsg = Typemod.type_interface sourcefile initial_env ast in
-    if !Clflags.dump_typedtree then fprintf ppf "%a@." Printtyped.interface tsg;
-    let sg = tsg.sig_type in
-    if !Clflags.print_types then
-      Printtyp.wrap_printing_env initial_env (fun () ->
-          fprintf std_formatter "%a@."
-            Printtyp.signature (Typemod.simplify_signature sg));
-    ignore (Includemod.signatures initial_env sg sg);
-    Typecore.force_delayed_checks ();
-    Warnings.check_fatal ();
-    if not !Clflags.print_types then begin
-      let deprecated = Builtin_attributes.deprecated_of_sig ast in
-      let sg =
-        Env.save_signature ~deprecated sg modulename (outputprefix ^ ".cmi")
-      in
-      Typemod.save_signature modulename tsg outputprefix sourcefile
-        initial_env sg ;
-    end
+  Profile.record_call sourcefile (fun () ->
+    Compmisc.init_path false;
+    let modulename = module_of_filename ppf sourcefile outputprefix in
+    Env.set_unit_name modulename;
+    let initial_env = Compmisc.initial_env () in
+    let ast = Pparse.parse_interface ~tool_name ppf sourcefile in
+    if !Clflags.dump_parsetree then fprintf ppf "%a@." Printast.interface ast;
+    if !Clflags.dump_source then fprintf ppf "%a@." Pprintast.signature ast;
+    Profile.(record_call typing) (fun () ->
+      let tsg = Typemod.type_interface sourcefile initial_env ast in
+      if !Clflags.dump_typedtree then fprintf ppf "%a@." Printtyped.interface tsg;
+      let sg = tsg.sig_type in
+      if !Clflags.print_types then
+        Printtyp.wrap_printing_env initial_env (fun () ->
+            fprintf std_formatter "%a@."
+              Printtyp.signature (Typemod.simplify_signature sg));
+      ignore (Includemod.signatures initial_env sg sg);
+      Typecore.force_delayed_checks ();
+      Warnings.check_fatal ();
+      if not !Clflags.print_types then begin
+        let deprecated = Builtin_attributes.deprecated_of_sig ast in
+        let sg =
+          Env.save_signature ~deprecated sg modulename (outputprefix ^ ".cmi")
+        in
+        Typemod.save_signature modulename tsg outputprefix sourcefile
+          initial_env sg ;
+      end
+    )
   )
 
 (* Compile a .ml file *)
@@ -66,77 +68,78 @@ let (++) x f = f x
 let (+++) (x, y) f = (x, f y)
 
 let implementation ~backend ppf sourcefile outputprefix =
-  let source_provenance = Timings.File sourcefile in
-  Compmisc.init_path true;
-  let modulename = module_of_filename ppf sourcefile outputprefix in
-  Env.set_unit_name modulename;
-  let env = Compmisc.initial_env() in
-  Compilenv.reset ~source_provenance ?packname:!Clflags.for_package modulename;
-  let cmxfile = outputprefix ^ ".cmx" in
-  let objfile = outputprefix ^ ext_obj in
-  let comp ast =
-    let (typedtree, coercion) =
-      ast
-      ++ print_if ppf Clflags.dump_parsetree Printast.implementation
-      ++ print_if ppf Clflags.dump_source Pprintast.structure
-      ++ Timings.(time (Typing sourcefile))
-          (Typemod.type_implementation sourcefile outputprefix modulename env)
-      ++ print_if ppf Clflags.dump_typedtree
-          Printtyped.implementation_with_coercion
-    in
-    if not !Clflags.print_types then begin
-      if Config.flambda then begin
-        if !Clflags.classic_inlining then begin
-          Clflags.default_simplify_rounds := 1;
+  Profile.record_call sourcefile (fun () ->
+    Compmisc.init_path true;
+    let modulename = module_of_filename ppf sourcefile outputprefix in
+    Env.set_unit_name modulename;
+    let env = Compmisc.initial_env() in
+    Compilenv.reset ?packname:!Clflags.for_package modulename;
+    let cmxfile = outputprefix ^ ".cmx" in
+    let objfile = outputprefix ^ ext_obj in
+    let comp ast =
+      let (typedtree, coercion) =
+        ast
+        ++ print_if ppf Clflags.dump_parsetree Printast.implementation
+        ++ print_if ppf Clflags.dump_source Pprintast.structure
+        ++ Profile.(record typing)
+            (Typemod.type_implementation sourcefile outputprefix modulename env)
+        ++ print_if ppf Clflags.dump_typedtree
+            Printtyped.implementation_with_coercion
+      in
+      if not !Clflags.print_types then begin
+        if Config.flambda then begin
+          if !Clflags.classic_inlining then begin
+            Clflags.default_simplify_rounds := 1;
+            Clflags.use_inlining_arguments_set Clflags.classic_arguments;
+            Clflags.unbox_free_vars_of_closures := false;
+            Clflags.unbox_specialised_args := false
+          end;
+          (typedtree, coercion)
+          ++ Profile.(record transl)
+              (Translmod.transl_implementation_flambda modulename)
+          ++ Profile.(record generate)
+            (fun { Lambda.module_ident; main_module_block_size;
+                   required_globals; code } ->
+            ((module_ident, main_module_block_size), code)
+            +++ print_if ppf Clflags.dump_rawlambda Printlambda.lambda
+            +++ Simplif.simplify_lambda sourcefile
+            +++ print_if ppf Clflags.dump_lambda Printlambda.lambda
+            ++ (fun ((module_ident, size), lam) ->
+                Middle_end.middle_end ppf
+                  ~prefixname:outputprefix
+                  ~size
+                  ~filename:sourcefile
+                  ~module_ident
+                  ~backend
+                  ~module_initializer:lam)
+            ++ Asmgen.compile_implementation_flambda
+              outputprefix ~required_globals ~backend ppf;
+            Compilenv.save_unit_info cmxfile)
+        end
+        else begin
           Clflags.use_inlining_arguments_set Clflags.classic_arguments;
-          Clflags.unbox_free_vars_of_closures := false;
-          Clflags.unbox_specialised_args := false
-        end;
-        (typedtree, coercion)
-        ++ Timings.(time (Timings.Transl sourcefile)
-            (Translmod.transl_implementation_flambda modulename))
-        ++ Timings.time (Timings.Generate sourcefile)
-          (fun { Lambda.module_ident; main_module_block_size;
-                 required_globals; code } ->
-          ((module_ident, main_module_block_size), code)
-          +++ print_if ppf Clflags.dump_rawlambda Printlambda.lambda
-          +++ Simplif.simplify_lambda sourcefile
-          +++ print_if ppf Clflags.dump_lambda Printlambda.lambda
-          ++ (fun ((module_ident, size), lam) ->
-              Middle_end.middle_end ppf ~source_provenance
-                ~prefixname:outputprefix
-                ~size
-                ~filename:sourcefile
-                ~module_ident
-                ~backend
-                ~module_initializer:lam)
-          ++ Asmgen.compile_implementation_flambda ~source_provenance
-            outputprefix ~required_globals ~backend ppf;
-          Compilenv.save_unit_info cmxfile)
-      end
-      else begin
-        Clflags.use_inlining_arguments_set Clflags.classic_arguments;
-        (typedtree, coercion)
-        ++ Timings.(time (Transl sourcefile))
-            (Translmod.transl_store_implementation modulename)
-        ++ print_if ppf Clflags.dump_rawlambda Printlambda.program
-        ++ Timings.(time (Generate sourcefile))
-            (fun program ->
-              { program with
-                Lambda.code = Simplif.simplify_lambda sourcefile
-                  program.Lambda.code }
-              ++ print_if ppf Clflags.dump_lambda Printlambda.program
-              ++ Asmgen.compile_implementation_clambda ~source_provenance
-                outputprefix ppf;
-              Compilenv.save_unit_info cmxfile)
-      end
-    end;
-    Warnings.check_fatal ();
-    Stypes.dump (Some (outputprefix ^ ".annot"))
-  in
-  try comp (Pparse.parse_implementation ~tool_name ppf sourcefile)
-  with x ->
-    Stypes.dump (Some (outputprefix ^ ".annot"));
-    remove_file objfile;
-    remove_file cmxfile;
-    raise x
+          (typedtree, coercion)
+          ++ Profile.(record transl)
+              (Translmod.transl_store_implementation modulename)
+          ++ print_if ppf Clflags.dump_rawlambda Printlambda.program
+          ++ Profile.(record generate)
+              (fun program ->
+                { program with
+                  Lambda.code = Simplif.simplify_lambda sourcefile
+                    program.Lambda.code }
+                ++ print_if ppf Clflags.dump_lambda Printlambda.program
+                ++ Asmgen.compile_implementation_clambda
+                  outputprefix ppf;
+                Compilenv.save_unit_info cmxfile)
+        end
+      end;
+      Warnings.check_fatal ();
+      Stypes.dump (Some (outputprefix ^ ".annot"))
+    in
+    try comp (Pparse.parse_implementation ~tool_name ppf sourcefile)
+    with x ->
+      Stypes.dump (Some (outputprefix ^ ".annot"));
+      remove_file objfile;
+      remove_file cmxfile;
+      raise x
+  )

diff --git a/driver/optmain.ml b/driver/optmain.ml
index 53904c1ce5e5c804fe42675b2baeb1723bbb64a2..33fc848d14201643c3d9835468be19608d51ca03 100644 (file)
--- a/driver/optmain.ml
+++ b/driver/optmain.ml
@@ -120,6 +120,7 @@ module Options = Main_args.Make_optcomp_options (struct
        inline_max_depth
   let _alias_deps = clear transparent_modules
   let _no_alias_deps = set transparent_modules
+  let _linscan = set use_linscan
   let _app_funct = set applicative_functors
   let _no_app_funct = clear applicative_functors
   let _no_float_const_prop = clear float_const_prop
@@ -213,6 +214,8 @@ module Options = Main_args.Make_optcomp_options (struct
   let _dcombine = set dump_combine
   let _dcse = set dump_cse
   let _dlive () = dump_live := true; Printmach.print_live := true
+  let _davail () = dump_avail := true
+  let _drunavail () = debug_runavail := true
   let _dspill = set dump_spill
   let _dsplit = set dump_split
   let _dinterf = set dump_interf
@@ -221,8 +224,10 @@ module Options = Main_args.Make_optcomp_options (struct
   let _dreload = set dump_reload
   let _dscheduling = set dump_scheduling
   let _dlinear = set dump_linear
+  let _dinterval = set dump_interval
   let _dstartup = set keep_startup_file
-  let _dtimings = set print_timings
+  let _dtimings () = profile_columns := [ `Time ]
+  let _dprofile () = profile_columns := Profile.all_columns
   let _opaque = set opaque
 
   let _args = Arg.read_arg
@@ -237,6 +242,9 @@ let main () =
   try
     readenv ppf Before_args;
     Clflags.add_arguments __LOC__ (Arch.command_line_options @ Options.list);
+    Clflags.add_arguments __LOC__
+      ["-depend", Arg.Unit Makedepend.main_from_option,
+       "<options> Compute dependencies (use 'ocamlopt -depend -help' for details)"];
     Clflags.parse_arguments anonymous usage;
     Compmisc.read_color_env ppf;
     if !gprofile && not Config.profiling then
@@ -305,7 +313,7 @@ let main () =
       Location.report_exception ppf x;
       exit 2
 
-let _ =
-  Timings.(time All) main ();
-  if !Clflags.print_timings then Timings.print Format.std_formatter;
+let () =
+  main ();
+  Profile.print Format.std_formatter !Clflags.profile_columns;
   exit 0

diff --git a/driver/pparse.ml b/driver/pparse.ml
index b00ded4077671f4f6f881347d88958ea53dbc120..cb78d848b4beaba9d001bedd85b09f496be82ebb 100644 (file)
--- a/driver/pparse.ml
+++ b/driver/pparse.ml
@@ -38,7 +38,7 @@ let preprocess sourcefile =
   match !Clflags.preprocessor with
     None -> sourcefile
   | Some pp ->
-      Timings.(time (Dash_pp sourcefile))
+      Profile.record "-pp"
         (call_external_preprocessor sourcefile) pp
 
 
@@ -166,7 +166,6 @@ let parse (type a) (kind : a ast_kind) lexbuf : a =
 let file_aux ppf ~tool_name inputfile (type a) parse_fun invariant_fun
              (kind : a ast_kind) =
   let ast_magic = magic_of_kind kind in
-  let source_file = !Location.input_name in
   let (ic, is_ast_file) = open_and_check_magic inputfile ast_magic in
   let ast =
     try
@@ -179,17 +178,15 @@ let file_aux ppf ~tool_name inputfile (type a) parse_fun invariant_fun
         (input_value ic : a)
       end else begin
         seek_in ic 0;
-        Location.input_name := inputfile;
         let lexbuf = Lexing.from_channel ic in
         Location.init lexbuf inputfile;
-        Timings.(time_call (Parser source_file)) (fun () ->
-          parse_fun lexbuf)
+        Profile.record_call "parser" (fun () -> parse_fun lexbuf)
       end
     with x -> close_in ic; raise x
   in
   close_in ic;
   let ast =
-    Timings.(time_call (Dash_ppx source_file)) (fun () ->
+    Profile.record_call "-ppx" (fun () ->
       apply_rewriters ~restore:false ~tool_name kind ast) in
   if is_ast_file || !Clflags.all_ppx <> [] then invariant_fun ast;
   ast
@@ -233,10 +230,10 @@ module InterfaceHooks = Misc.MakeHooks(struct
   end)
 
 let parse_implementation ppf ~tool_name sourcefile =
-  Timings.(time_call (Parsing sourcefile)) (fun () ->
+  Profile.record_call "parsing" (fun () ->
     parse_file ~tool_name Ast_invariants.structure
       ImplementationHooks.apply_hooks Structure ppf sourcefile)
 let parse_interface ppf ~tool_name sourcefile =
-  Timings.(time_call (Parsing sourcefile)) (fun () ->
+  Profile.record_call "parsing" (fun () ->
     parse_file ~tool_name Ast_invariants.signature
       InterfaceHooks.apply_hooks Signature ppf sourcefile)

diff --git a/driver/pparse.mli b/driver/pparse.mli
index 86d805b8a8df8ed4248764a166bb33c894d9fc39..4c5fc0f6abd7e30b3b055b247d92b7a168e0c7e2 100644 (file)
--- a/driver/pparse.mli
+++ b/driver/pparse.mli
@@ -13,6 +13,8 @@
 (*                                                                        *)
 (**************************************************************************)
 
+(** Driver for the parser, external preprocessors and ast plugin hooks *)
+
 open Format
 
 type error =

diff --git a/emacs/caml.el b/emacs/caml.el
index e91417d2a38d0e33d1ceb0518cfe14f4f99bfba9..def64b913ae92d5926249e07add66c76e5c32f6c 100644 (file)
--- a/emacs/caml.el
+++ b/emacs/caml.el
@@ -1,26 +1,46 @@
-;**************************************************************************
-;*                                                                        *
-;*                                 OCaml                                  *
-;*                                                                        *
-;*                 Jacques Garrigue and Ian T Zimmerman                   *
-;*                                                                        *
-;*   Copyright 1997 Institut National de Recherche en Informatique et     *
-;*     en Automatique.                                                    *
-;*                                                                        *
-;*   All rights reserved.  This file is distributed under the terms of    *
-;*   the GNU General Public License.                                      *
-;*                                                                        *
-;**************************************************************************
-
 ;;; caml.el --- OCaml code editing commands for Emacs
 
-;; Xavier Leroy, july 1993.
+;; Copyright (C) 1997-2017 Institut National de Recherche en Informatique et en Automatique.
+
+;; Author: Jacques Garrigue <garrigue@kurims.kyoto-u.ac.jp>
+;;         Ian T Zimmerman <itz@rahul.net>
+;; Maintainer: Damien Doligez <damien.doligez@inria.fr>
+;; Created: July 1993
+;; Keywords: OCaml
+;; Homepage: https://github.com/ocaml/ocaml/
+
+;; This file is not part of GNU Emacs.
+
+;; This file is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; This file is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; A major mode for editing OCaml code (see <http://ocaml.org/>) in Emacs.
 
-;;indentation code is Copyright (C) 1996 by Ian T Zimmerman <itz@rahul.net>
-;;copying: covered by the current FSF General Public License.
+;; Some of its major features include:
 
-;; indentation code adapted for OCaml by Jacques Garrigue,
-;; july 1997. <garrigue@kurims.kyoto-u.ac.jp>
+;; - syntax highlighting (font lock);
+;; - automatic indentation;
+;; - querying the type of expressions (using compiler generated annot files);
+;; - running an OCaml REPL within Emacs;
+;; - scans declarations and places them in a menu.
+
+
+;; The original indentation code was the work of Ian T Zimmerman and
+;; was adapted for OCaml by Jacques Garrigue in July 1997.
+
+;;; Code:
 
 ;;user customizable variables
 (defvar caml-quote-char "'"
@@ -273,9 +293,6 @@ have caml-electric-indent on, which see.")
 (defvar caml-shell-active nil
   "Non nil when a subshell is running.")
 
-(defvar running-xemacs  (string-match "XEmacs" emacs-version)
-  "Non-nil if we are running in the XEmacs environment.")
-
 (defvar caml-mode-map nil
   "Keymap used in Caml mode.")
 (if caml-mode-map
@@ -291,7 +308,7 @@ have caml-electric-indent on, which see.")
 ;that way we get out effect even when we do \C-x` in compilation buffer
 ;  (define-key caml-mode-map "\C-x`" 'caml-next-error)
 
-  (if running-xemacs
+  (if (featurep 'xemacs)
       (define-key caml-mode-map 'backspace 'backward-delete-char-untabify)
     (define-key caml-mode-map "\177" 'backward-delete-char-untabify))
 
@@ -303,8 +320,8 @@ have caml-electric-indent on, which see.")
   (define-key caml-mode-map [?\C-c down-mouse-1] 'caml-types-explore)
   ;; caml-help
   (define-key caml-mode-map [?\C-c?i] 'ocaml-add-path)
-  (define-key caml-mode-map [?\C-c?]] 'ocaml-close-module)
-  (define-key caml-mode-map [?\C-c?[] 'ocaml-open-module)
+  (define-key caml-mode-map [?\C-c?\]] 'ocaml-close-module)
+  (define-key caml-mode-map [?\C-c?\[] 'ocaml-open-module)
   (define-key caml-mode-map [?\C-c?\C-h] 'caml-help)
   (define-key caml-mode-map [?\C-c?\t] 'caml-complete)
   ;; others
@@ -319,8 +336,8 @@ have caml-electric-indent on, which see.")
   (define-key caml-mode-map "\C-c\C-a" 'caml-find-alternate-file)
   (define-key caml-mode-map "\C-c\C-c" 'compile)
   (define-key caml-mode-map "\C-c\C-e" 'caml-eval-phrase)
-  (define-key caml-mode-map "\C-c\C-\[" 'caml-backward-to-less-indent)
-  (define-key caml-mode-map "\C-c\C-\]" 'caml-forward-to-less-indent)
+  (define-key caml-mode-map "\C-c\C-[" 'caml-backward-to-less-indent)
+  (define-key caml-mode-map "\C-c\C-]" 'caml-forward-to-less-indent)
   (define-key caml-mode-map "\C-c\C-q" 'caml-indent-phrase)
   (define-key caml-mode-map "\C-c\C-r" 'caml-eval-region)
   (define-key caml-mode-map "\C-c\C-s" 'caml-show-subshell)
@@ -328,7 +345,7 @@ have caml-electric-indent on, which see.")
   (define-key caml-mode-map "\M-\C-q" 'caml-indent-phrase)
   (define-key caml-mode-map "\M-\C-x" 'caml-eval-phrase)
 
-  (if running-xemacs nil ; if not running xemacs
+  (if (featurep 'xemacs) nil
     (let ((map (make-sparse-keymap "Caml"))
           (forms (make-sparse-keymap "Forms")))
       (define-key caml-mode-map "\C-c\C-d" 'caml-show-imenu)
@@ -374,7 +391,7 @@ have caml-electric-indent on, which see.")
       (define-key forms [begin] '("begin .. end" . caml-insert-begin-form)))))
 
 (defvar caml-mode-xemacs-menu
-  (if running-xemacs
+  (if (featurep 'xemacs)
       '("Caml"
         [ "Indent phrase" caml-indent-phrase :keys "C-M-q" ]
         [ "Eval phrase" caml-eval-phrase
@@ -407,7 +424,7 @@ have caml-electric-indent on, which see.")
   "Syntax table in use in Caml mode buffers.")
 (if caml-mode-syntax-table
     ()
-  (let ((n (if (string-match "XEmacs" (emacs-version)) "" "n")))
+  (let ((n (if (featurep 'xemacs) "" "n")))
     (setq caml-mode-syntax-table (make-syntax-table))
     ; backslash is an escape sequence
     (modify-syntax-entry ?\\ "\\" caml-mode-syntax-table)
@@ -432,15 +449,10 @@ have caml-electric-indent on, which see.")
 (defvar caml-mode-abbrev-table nil
   "Abbrev table used for Caml mode buffers.")
 (if caml-mode-abbrev-table nil
-  (setq caml-mode-abbrev-table (make-abbrev-table))
-  (define-abbrev caml-mode-abbrev-table "and" "and" 'caml-abbrev-hook)
-  (define-abbrev caml-mode-abbrev-table "do" "do" 'caml-abbrev-hook)
-  (define-abbrev caml-mode-abbrev-table "done" "done" 'caml-abbrev-hook)
-  (define-abbrev caml-mode-abbrev-table "else" "else" 'caml-abbrev-hook)
-  (define-abbrev caml-mode-abbrev-table "end" "end" 'caml-abbrev-hook)
-  (define-abbrev caml-mode-abbrev-table "in" "in" 'caml-abbrev-hook)
-  (define-abbrev caml-mode-abbrev-table "then" "then" 'caml-abbrev-hook)
-  (define-abbrev caml-mode-abbrev-table "with" "with" 'caml-abbrev-hook))
+  (define-abbrev-table 'caml-mode-abbrev-table
+    (mapcar (lambda (keyword)
+              `(,keyword ,keyword caml-abbrev-hook nil t))
+            '("and" "do" "done" "else" "end" "in" "then" "with"))))
 
 ;; Other internal variables
 
@@ -477,7 +489,7 @@ have caml-electric-indent on, which see.")
 
 ;;; The major mode
 (eval-when-compile
-  (if (and (boundp 'running-xemacs) running-xemacs) nil
+  (if (featurep 'xemacs) nil
     (require 'imenu)))
 
 ;;
@@ -527,7 +539,7 @@ have caml-electric-indent on, which see.")
   ;garrigue 27-11-96
   (setq case-fold-search nil)
   ;garrigue july 97
-  (if running-xemacs ; from Xemacs lisp mode
+  (if (featurep 'xemacs)
       (if (and (featurep 'menubar)
                current-menubar)
           (progn
@@ -866,24 +878,24 @@ possible."
  (if (eq major-mode 'caml-mode)
      (let (skip bol beg end)
        (save-excursion
-         (set-buffer
-          (if (boundp 'compilation-last-buffer)
-              compilation-last-buffer   ;Emacs 19
-            "*compilation*"))           ;Emacs 18
-         (save-excursion
-           (goto-char (window-point (get-buffer-window (current-buffer))))
-           (if (looking-at caml-error-chars-regexp)
-               (setq beg
-                     (caml-string-to-int
-                      (buffer-substring (match-beginning 1) (match-end 1)))
-                     end
-                     (caml-string-to-int
-                      (buffer-substring (match-beginning 2) (match-end 2)))))
-           (next-line)
-           (beginning-of-line)
-           (if (and (looking-at "Warning")
-                    caml-next-error-skip-warnings-flag)
-               (setq skip 't))))
+         (with-current-buffer
+             (if (boundp 'compilation-last-buffer)
+                 compilation-last-buffer   ;Emacs 19
+               "*compilation*")           ;Emacs 18
+           (save-excursion
+             (goto-char (window-point (get-buffer-window (current-buffer))))
+             (if (looking-at caml-error-chars-regexp)
+                 (setq beg
+                       (caml-string-to-int
+                        (buffer-substring (match-beginning 1) (match-end 1)))
+                       end
+                       (caml-string-to-int
+                        (buffer-substring (match-beginning 2) (match-end 2)))))
+             (forward-line 1)
+             (beginning-of-line)
+             (if (and (looking-at "Warning")
+                      caml-next-error-skip-warnings-flag)
+                 (setq skip 't)))))
        (cond
         (skip (next-error))
         (beg
@@ -1248,7 +1260,7 @@ Used to distinguish it from toplevel let construct.")
 (defun caml-at-sexp-close-p ()
   (or (char-equal ?\) (following-char))
       (char-equal ?\] (following-char))
-      (char-equal ?} (following-char))))
+      (char-equal ?\} (following-char))))
 
 (defun caml-find-kwop (kwop-regexp &optional min-pos)
   "Look back for a caml keyword or operator matching KWOP-REGEXP.
@@ -1764,7 +1776,7 @@ by |, insert one."
 (defun caml-abbrev-hook ()
   "If inserting a leading keyword at beginning of line, reindent the line."
   ;itz unfortunately we need a special case
-  (if (and (not (caml-in-comment-p)) (not (= last-command-char ?_)))
+  (if (and (not (caml-in-comment-p)) (not (= last-command-event ?_)))
       (let* ((bol (save-excursion (beginning-of-line) (point)))
              (kw (save-excursion
                    (and (re-search-backward "^[ \t]*\\(\\sw+\\)\\=" bol t)
@@ -1774,7 +1786,7 @@ by |, insert one."
                             (goto-char (match-beginning 1))
                             (caml-indent-command)
                             (current-column)))
-                  (abbrev-correct (if (= last-command-char ?\ ) 1 0)))
+                  (abbrev-correct (if (= last-command-event ?\ ) 1 0)))
               (indent-to (- indent
                             (or
                              (symbol-value
@@ -1969,6 +1981,6 @@ with prefix arg, indent that many phrases starting with the current phrase."
 (autoload 'ocaml-add-path "caml-help"
   "Add search path for documentation." t)
 
-;;; caml.el ends here
-
 (provide 'caml)
+
+;;; caml.el ends here

diff --git a/lex/lexgen.ml b/lex/lexgen.ml
index 4054f27cc7303273423bd020ba9de8d1a2670472..ac3751cdfef896a7cd1ca210c2183eede164c51d 100644 (file)
--- a/lex/lexgen.ml
+++ b/lex/lexgen.ml
@@ -208,7 +208,7 @@ let find_double e = do_find_double e
 
 (*
    Type of variables:
-    A variable is bound to a char when all its occurences
+    A variable is bound to a char when all its occurrences
     bind a pattern of length 1.
      The typical case is:
        (_ as x) -> char
@@ -577,7 +577,7 @@ let rec firstpos = function
   | Star r     -> firstpos r
 
 
-(* Berry-sethi followpos *)
+(* Berry-Sethi followpos *)
 let followpos size entry_list =
   let v = Array.make size TransSet.empty in
   let rec fill s = function
@@ -684,13 +684,10 @@ let env_to_class m =
   let env1 =
     MemMap.fold
       (fun _ (tag,s) r ->
-        try
-          let ss = TagMap.find tag r in
-          let r = TagMap.remove tag r in
-          TagMap.add tag (StateSetSet.add s ss) r
-        with
-        | Not_found ->
-            TagMap.add tag (StateSetSet.add s StateSetSet.empty) r)
+         TagMap.update tag (function
+             | None -> Some (StateSetSet.singleton s)
+             | Some ss -> Some (StateSetSet.add s ss)
+           ) r)
       m TagMap.empty in
   TagMap.fold
     (fun tag ss r -> MemKey.add {tag=tag ; equiv=ss} r)
@@ -701,14 +698,12 @@ let env_to_class m =
 let inverse_mem_map trans m r =
   TagMap.fold
     (fun tag addr r ->
-      try
-        let otag,s = MemMap.find addr r in
-        assert (tag = otag) ;
-        let r = MemMap.remove addr r in
-        MemMap.add addr (tag,StateSet.add trans s) r
-      with
-      | Not_found ->
-          MemMap.add addr (tag,StateSet.add trans StateSet.empty) r)
+       MemMap.update addr (function
+           | None -> Some (tag, StateSet.singleton trans)
+           | Some (otag, s) ->
+               assert (tag = otag);
+               Some (tag, StateSet.add trans s)
+         ) r)
     m r
 
 let inverse_mem_map_other n (_,m) r = inverse_mem_map (OnChars n) m r
@@ -754,8 +749,8 @@ let reset_state () =
 
 (* Reset state before processing a given automata.
    We clear both the memory mapping and
-   the state mapping, as state sharing beetween different
-   automata may lead to incorret estimation of the cell memory size
+   the state mapping, as state sharing between different
+   automata may lead to incorrect estimation of the cell memory size
    BUG ID 0004517 *)
 
 
@@ -1045,7 +1040,7 @@ let comp_shift gen chars follow st =
 
 let reachs chars follow st =
   let gen = create_new_addr_gen () in
-(* build a association list (char set -> new state) *)
+(* build an association list (char set -> new state) *)
   let env = comp_shift gen chars follow st in
 (* change it into (char set -> new state_num) *)
   let env =

diff --git a/man/Makefile b/man/Makefile
index 7008b951389fc4dfd611db3c6b7bc58bb02d5832..2b678d837ab0c8c4e32c04c660e78a34ed5e939e 100644 (file)
--- a/man/Makefile
+++ b/man/Makefile
@@ -15,13 +15,14 @@
 
 include ../config/Makefile
 
-INSTALL_DIR=$(DESTDIR)$(MANDIR)/man$(MANEXT)
+INSTALL_DIR=$(DESTDIR)$(MANDIR)/man$(PROGRAMS_MAN_SECTION)
 
 install:
-       for i in *.m; do cp $$i $(INSTALL_DIR)/`basename $$i .m`.$(MANEXT); done
-       echo '.so man$(MANEXT)/ocamlc.$(MANEXT)' \
-            > $(INSTALL_DIR)/ocamlc.opt.$(MANEXT)
-       echo '.so man$(MANEXT)/ocamlopt.$(MANEXT)' \
-            > $(INSTALL_DIR)/ocamlopt.opt.$(MANEXT)
-       echo '.so man$(MANEXT)/ocamlcp.$(MANEXT)' \
-            > $(INSTALL_DIR)/ocamloptp.$(MANEXT)
+       for i in *.m; do cp \
+         $$i $(INSTALL_DIR)/`basename $$i .m`.$(PROGRAMS_MAN_SECTION); done
+       echo '.so man$(PROGRAMS_MAN_SECTION)/ocamlc.$(PROGRAMS_MAN_SECTION)' \
+            > $(INSTALL_DIR)/ocamlc.opt.$(PROGRAMS_MAN_SECTION)
+       echo '.so man$(PROGRAMS_MAN_SECTION)/ocamlopt.$(PROGRAMS_MAN_SECTION)' \
+            > $(INSTALL_DIR)/ocamlopt.opt.$(PROGRAMS_MAN_SECTION)
+       echo '.so man$(PROGRAMS_MAN_SECTION)/ocamlcp.$(PROGRAMS_MAN_SECTION)' \
+            > $(INSTALL_DIR)/ocamloptp.$(PROGRAMS_MAN_SECTION)

diff --git a/man/ocaml.m b/man/ocaml.m
index 1d320022968ce81f1c51f1894f157596f6c666ad..3b20ada0bb571a6bc62fa491f281100bf268e2a6 100644 (file)
--- a/man/ocaml.m
+++ b/man/ocaml.m
@@ -142,11 +142,6 @@ Opens the given module before starting the toplevel. If several
 options are given, they are processed in order, just as if
 the statements open! module1;; ... open! moduleN;; were input.
 .TP
-.BI \-plugin \ plugin
-Dynamically load the code of the given
-.I plugin
-(a .cmo or .cma file) in the toplevel.
-.TP
 .BI \-ppx \ command
 After parsing, pipe the abstract syntax tree through the preprocessor
 .IR command .
@@ -279,10 +274,11 @@ directive to read phrases from a file.
 
 .SH ENVIRONMENT VARIABLES
 .TP
-.B LC_CTYPE
-If set to iso_8859_1, accented characters (from the
-ISO Latin-1 character set) in string and character literals are
-printed as is; otherwise, they are printed as decimal escape sequences.
+.B OCAMLTOP_UTF_8
+When printing string values, non-ascii bytes (>0x7E) are printed as
+decimal escape sequence if
+.B OCAMLTOP_UTF_8
+is set to false. Otherwise they are printed unescaped.
 .TP
 .B TERM
 When printing error messages, the toplevel system

diff --git a/man/ocamlc.m b/man/ocamlc.m
index 4d76da9db94bcba0c9c8e27f81bd5f9b4958ffc3..532397e51b089adb0c94636c039bb62844048567 100644 (file)
--- a/man/ocamlc.m
+++ b/man/ocamlc.m
@@ -321,6 +321,9 @@ executables produced by
 .BR ocamlc\ \-custom ,
 this would make them vulnerable to attacks.
 .TP
+.BI \-depend\ ocamldep-args
+Compute dependencies, as ocamldep would do.
+.TP
 .BI \-dllib\ \-l libname
 Arrange for the C shared library
 .BI dll libname .so
@@ -837,7 +840,7 @@ clause.
 \ \ Bad module name: the source file name is not a valid OCaml module name.
 
 25
-\ \ Pattern-matching with all clauses guarded.
+\ \ Deprecated: now part of warning 8.
 
 26
 \ \ Suspicious unused variable: unused variable that is bound with
@@ -983,7 +986,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\-48\-50\-60 .
+.BR \-w\ +a\-4\-6\-7\-9\-27\-29\-32..42\-44\-45\-48\-50\-60 .
 Note that warnings
 .BR 5 \ and \ 10
 are not always triggered, depending on the internals of the type checker.

diff --git a/man/ocamldep.m b/man/ocamldep.m
index a47cb39753a436aa2fceb0b7d9d8a2bf4fd059c8..b9b58b9a964e1f274382b067dac08a2e122e6aea 100644 (file)
--- a/man/ocamldep.m
+++ b/man/ocamldep.m
@@ -183,6 +183,10 @@ as a preprocessor for each source file.
 Pipe abstract syntax tree through preprocessor
 .IR command .
 .TP
+.B \-shared
+Generate dependencies for native plugin files (.cmxs) in addition to
+native compiled files (.cmx).
+.TP
 .B \-slash
 Under Unix, this option does nothing.
 .TP

diff --git a/man/ocamldoc.m b/man/ocamldoc.m
index 2b2ba3c66ddf6f19eec981345f38f8eccafc6e3d..01c05bb8b188b96a5d476ab8c78595f4d4f8e0fd 100644 (file)
--- a/man/ocamldoc.m
+++ b/man/ocamldoc.m
@@ -244,6 +244,9 @@ Pipe sources through preprocessor
 Pipe abstract syntax tree through preprocessor
 .IR command .
 .TP
+.BR \-show\-missed\-crossref
+Show missed cross-reference opportunities.
+.TP
 .B \-sort
 Sort the list of top-level modules before generating the documentation.
 .TP
@@ -255,6 +258,9 @@ Use
 .I title
 as the title for the generated documentation.
 .TP
+.BI \-text \ file
+Consider \fIfile\fR as a .txt file.
+.TP
 .BI \-intro \ file
 Use content of
 .I file
@@ -313,6 +319,10 @@ option:
 .B \-all\-params
 Display the complete list of parameters for functions and methods.
 .TP
+.BI \-charset \ s
+Add information about character encoding being \fIs\fR
+(default is \fBiso-8859-1\fR).
+.TP
 .BI \-css\-style \ filename
 Use
 .I filename

diff --git a/man/ocamlopt.m b/man/ocamlopt.m
index c5278d46f66c63b864dee9902998b190e8499928..f2a2b208a003dcb72a680733f56ad2f9f8d3e3ac 100644 (file)
--- a/man/ocamlopt.m
+++ b/man/ocamlopt.m
@@ -252,6 +252,9 @@ Print the version number of
 .BR ocamlopt (1)
 and a detailed summary of its configuration, then exit.
 .TP
+.BI \-depend\ ocamldep-args
+Compute dependencies, as ocamldep would do.
+.TP
 .BI \-for\-pack \ module\-path
 Generate an object file (.cmx and .o files) that can later be included
 as a sub-module (with the given access path) of a compilation unit
@@ -330,7 +333,7 @@ Recognize file names ending with
 .I string
 as interface files (instead of the default .mli).
 .TP
-.B \-keep-locs
+.B \-keep-docs
 Keep documentation strings in generated .cmi files.
 .TP
 .B \-keep-locs
@@ -717,18 +720,6 @@ Generate position-independent machine code.  This is the default.
 .B \-fno\-PIC
 Generate position-dependent machine code.
 
-.SH OPTIONS FOR THE SPARC ARCHITECTURE
-The Sparc code generator supports the following additional options:
-.TP
-.B \-march=v8
-Generate SPARC version 8 code.
-.TP
-.B \-march=v9
-Generate SPARC version 9 code.
-.P
-The default is to generate code for SPARC version 7, which runs on all
-SPARC processors.
-
 .SH OPTIONS FOR THE ARM ARCHITECTURE
 The ARM code generator supports the following additional options:
 .TP

diff --git a/middle_end/augment_specialised_args.ml b/middle_end/augment_specialised_args.ml
index 037918c9e68b22f8781478c82627884b07040cf8..a38be378d26ffcee59267593c9aed7af79c95fdb 100755 (executable)
--- a/middle_end/augment_specialised_args.ml
+++ b/middle_end/augment_specialised_args.ml
@@ -246,7 +246,7 @@ module Processed_what_to_specialise = struct
         with
         | exception Not_found -> assert false
         | (function_decl : Flambda.function_declaration) ->
-          let params = Variable.Set.of_list function_decl.params in
+          let params = Parameter.Set.vars function_decl.params in
           let existing_specialised_args =
             Variable.Map.filter (fun inner_var _spec_to ->
                 Variable.Set.mem inner_var params)
@@ -291,7 +291,7 @@ module Processed_what_to_specialise = struct
           if function_decl.stub then
             Definition.Set.empty
           else
-            let params = Variable.Set.of_list function_decl.params in
+            let params = Parameter.Set.vars function_decl.params in
             Variable.Map.fold (fun inner_var
                       (spec_to : Flambda.specialised_to) definitions ->
                 if not (Variable.Set.mem inner_var params) then
@@ -373,7 +373,7 @@ let check_invariants ~pass_name ~(set_of_closures : Flambda.set_of_closures)
   if !Clflags.flambda_invariant_checks then begin
     Variable.Map.iter (fun fun_var
               (function_decl : Flambda.function_declaration) ->
-        let params = Variable.Set.of_list function_decl.params in
+        let params = Parameter.Set.vars function_decl.params in
         Variable.Map.iter (fun inner_var
                     (outer_var : Flambda.specialised_to) ->
               if Variable.Set.mem inner_var params then begin
@@ -408,16 +408,18 @@ module Make (T : S) = struct
   let rename_function_and_parameters ~fun_var
         ~(function_decl : Flambda.function_declaration) =
     let new_fun_var = Variable.rename fun_var ~append:T.variable_suffix in
+    let params_renaming_list =
+      List.map (fun param ->
+          let new_param = Parameter.rename param ~append:T.variable_suffix in
+          param, new_param)
+        function_decl.params
+    in
+    let renamed_params = List.map snd params_renaming_list in
     let params_renaming =
       Variable.Map.of_list
-        (List.map (fun param ->
-            let new_param = Variable.rename param ~append:T.variable_suffix in
-            param, new_param)
-          function_decl.params)
-    in
-    let renamed_params =
-      List.map (fun param -> Variable.Map.find param params_renaming)
-        function_decl.params
+        (List.map (fun (param, new_param) ->
+             Parameter.var param, Parameter.var new_param)
+           params_renaming_list)
     in
     new_fun_var, params_renaming, renamed_params
 
@@ -431,7 +433,7 @@ module Make (T : S) = struct
        definitions are called the "specialised args bound in the wrapper".
        Note that the domain of [params_renaming] is a (non-strict) superset
        of the "inner vars" of the original specialised args. *)
-    let params = Variable.Set.of_list function_decl.params in
+    let params = Parameter.Set.vars function_decl.params in
     let new_fun_var, params_renaming, wrapper_params =
       rename_function_and_parameters ~fun_var ~function_decl
     in
@@ -467,7 +469,9 @@ module Make (T : S) = struct
       let apply : Flambda.expr =
         Apply {
           func = new_fun_var;
-          args = wrapper_params @ spec_args_bound_in_the_wrapper;
+          args =
+            (Parameter.List.vars wrapper_params) @
+            spec_args_bound_in_the_wrapper;
           kind = Direct (Closure_id.wrap new_fun_var);
           dbg = Debuginfo.none;
           inline = Default_inline;
@@ -581,7 +585,7 @@ module Make (T : S) = struct
                 assert (Variable.Map.mem projecting_from
                   set_of_closures.specialised_args);
                 assert (Variable.Set.mem projecting_from
-                  (Variable.Set.of_list function_decl.params));
+                  (Parameter.Set.vars function_decl.params));
                 { var = new_outer_var;
                   projection = Some projection;
                 })
@@ -608,6 +612,9 @@ module Make (T : S) = struct
           Variable.Set.elements (Variable.Map.keys
             for_one_function.new_inner_to_new_outer_vars)
         in
+        let new_params =
+          List.map Parameter.wrap new_params
+        in
         function_decl.params @ new_params
       in
       let rewritten_function_decl =

diff --git a/middle_end/closure_conversion.ml b/middle_end/closure_conversion.ml
index 2a6a2bccf773f1273f70b5699b064ede6b14112b..807889fc4a72fa258f379cf35b4cd762aab77b9f 100755 (executable)
--- a/middle_end/closure_conversion.ml
+++ b/middle_end/closure_conversion.ml
@@ -72,7 +72,7 @@ let add_default_argument_wrappers lam =
     manner from the tuple. *)
 let tupled_function_call_stub original_params unboxed_version
       : Flambda.function_declaration =
-  let tuple_param =
+  let tuple_param_var =
     Variable.rename ~append:"tupled_stub_param" unboxed_version
   in
   let params = List.map (fun p -> Variable.rename p) original_params in
@@ -91,11 +91,12 @@ let tupled_function_call_stub original_params unboxed_version
   let _, body =
     List.fold_left (fun (pos, body) param ->
         let lam : Flambda.named =
-          Prim (Pfield pos, [tuple_param], Debuginfo.none)
+          Prim (Pfield pos, [tuple_param_var], Debuginfo.none)
         in
         pos + 1, Flambda.create_let param lam body)
       (0, call) params
   in
+  let tuple_param = Parameter.wrap tuple_param_var in
   Flambda.create_function_declaration ~params:[tuple_param]
     ~body ~stub:true ~dbg:Debuginfo.none ~inline:Default_inline
     ~specialise:Default_specialise ~is_a_functor:false
@@ -394,7 +395,7 @@ let rec close t env (lam : Lambda.lambda) : Flambda.t =
     let arg2 = close t env arg2 in
     let const_true = Variable.create "const_true" in
     let cond = Variable.create "cond_sequor" in
-    Flambda.create_let const_true (Const (Int 1))
+    Flambda.create_let const_true (Const (Const_pointer 1))
       (Flambda.create_let cond (Expr arg1)
         (If_then_else (cond, Var const_true, arg2)))
   | Lprim (Psequand, [arg1; arg2], _) ->
@@ -402,7 +403,7 @@ let rec close t env (lam : Lambda.lambda) : Flambda.t =
     let arg2 = close t env arg2 in
     let const_false = Variable.create "const_false" in
     let cond = Variable.create "cond_sequand" in
-    Flambda.create_let const_false (Const (Int 0))
+    Flambda.create_let const_false (Const (Const_pointer 0))
       (Flambda.create_let cond (Expr arg1)
         (If_then_else (cond, arg2, Var const_false)))
   | Lprim ((Psequand | Psequor), _, _) ->
@@ -461,7 +462,7 @@ let rec close t env (lam : Lambda.lambda) : Flambda.t =
       ~create_body:(fun args ->
         name_expr (Prim (p, args, dbg))
           ~name)
-  | Lswitch (arg, sw) ->
+  | Lswitch (arg, sw, _loc) ->
     let scrutinee = Variable.create "switch" in
     let aux (i, lam) = i, close t env lam in
     let zero_to_n = Numbers.Int.zero_to_n in
@@ -563,7 +564,8 @@ and close_functions t external_env function_declarations : Flambda.named =
        CR-someday pchambart: eta-expansion wrapper for a primitive are
        not marked as stub but certainly should *)
     let stub = Function_decl.stub decl in
-    let params = List.map (Env.find_var closure_env) params in
+    let param_vars = List.map (Env.find_var closure_env) params in
+    let params = List.map Parameter.wrap param_vars in
     let closure_bound_var = Function_decl.closure_bound_var decl in
     let body = close t closure_env body in
     let fun_decl =
@@ -577,7 +579,7 @@ and close_functions t external_env function_declarations : Flambda.named =
     | Tupled ->
       let unboxed_version = Variable.rename closure_bound_var in
       let generic_function_stub =
-        tupled_function_call_stub params unboxed_version
+        tupled_function_call_stub param_vars unboxed_version
       in
       Variable.Map.add unboxed_version fun_decl
         (Variable.Map.add closure_bound_var generic_function_stub map)

diff --git a/middle_end/flambda.ml b/middle_end/flambda.ml
index 68bd83b7d5fa37b7f12e20f678b5382f1b7bad11..a00091a2bcfd98329f7cbc9689856bcf96bef127 100644 (file)
--- a/middle_end/flambda.ml
+++ b/middle_end/flambda.ml
@@ -116,7 +116,7 @@ and function_declarations = {
 }
 
 and function_declaration = {
-  params : Variable.t list;
+  params : Parameter.t list;
   body : t;
   free_variables : Variable.Set.t;
   free_symbols : Symbol.Set.t;
@@ -353,8 +353,11 @@ and print_named ppf (named : named) =
     (* lam ppf expr *)
 
 and print_function_declaration ppf var (f : function_declaration) =
-  let idents ppf =
-    List.iter (fprintf ppf "@ %a" Variable.print) in
+  let param ppf p =
+    Variable.print ppf (Parameter.var p)
+  in
+  let params ppf =
+    List.iter (fprintf ppf "@ %a" param) in
   let stub =
     if f.stub then
       " *stub*"
@@ -382,7 +385,7 @@ and print_function_declaration ppf var (f : function_declaration) =
   in
   fprintf ppf "@[<2>(%a%s%s%s%s@ =@ fun@[<2>%a@] ->@ @[<2>%a@])@]@ "
     Variable.print var stub is_a_functor inline specialise
-    idents f.params lam f.body
+    params f.params lam f.body
 
 and print_set_of_closures ppf (set_of_closures : set_of_closures) =
   match set_of_closures with
@@ -457,44 +460,38 @@ let print_constant_defining_value ppf (const : constant_defining_value) =
       Closure_id.print closure_id
 
 let rec print_program_body ppf (program : program_body) =
+  let symbol_binding ppf (symbol, constant_defining_value) =
+    fprintf ppf "@[<2>(%a@ %a)@]"
+      Symbol.print symbol
+      print_constant_defining_value constant_defining_value
+  in
   match program with
   | Let_symbol (symbol, constant_defining_value, body) ->
-    let rec letbody (ul : program_body) =
+    let rec extract acc (ul : program_body) =
       match ul with
       | Let_symbol (symbol, constant_defining_value, body) ->
-        fprintf ppf "@ @[<2>(%a@ %a)@]" Symbol.print symbol
-          print_constant_defining_value constant_defining_value;
-        letbody body
-      | _ -> ul
+        extract ((symbol, constant_defining_value) :: acc) body
+      | _ ->
+        List.rev acc,  ul
     in
-    fprintf ppf "@[<2>let_symbol@ @[<hv 1>(@[<2>%a@ %a@])@]@ "
-      Symbol.print symbol
-      print_constant_defining_value constant_defining_value;
-    let program = letbody body in
-    fprintf ppf "@]@.";
+    let defs, program = extract [symbol, constant_defining_value] body in
+    fprintf ppf
+      "@[<2>let_symbol@ @[%a@]@]@."
+      (Format.pp_print_list symbol_binding) defs;
     print_program_body ppf program
   | Let_rec_symbol (defs, program) ->
-    let bindings ppf id_arg_list =
-      let spc = ref false in
-      List.iter
-        (fun (symbol, constant_defining_value) ->
-           if !spc then fprintf ppf "@ " else spc := true;
-           fprintf ppf "@[<2>%a@ %a@]"
-             Symbol.print symbol
-             print_constant_defining_value constant_defining_value)
-        id_arg_list in
     fprintf ppf
-      "@[<2>let_rec_symbol@ (@[<hv 1>%a@])@]@."
-      bindings defs;
+      "@[<2>let_rec_symbol@ @[%a@]@]@."
+      (Format.pp_print_list symbol_binding) defs;
     print_program_body ppf program
   | Initialize_symbol (symbol, tag, fields, program) ->
-    fprintf ppf "@[<2>initialize_symbol@ @[<hv 1>(@[<2>%a@ %a@ %a@])@]@]@."
+    fprintf ppf "@[<2>initialize_symbol@ (@[<2>%a@ %a@ %a@])@]@."
       Symbol.print symbol
       Tag.print tag
       (Format.pp_print_list lam) fields;
     print_program_body ppf program
   | Effect (expr, program) ->
-    fprintf ppf "@[effect @[<hv 1>%a@]@]@."
+    fprintf ppf "@[<2>effect@ %a@]@."
       lam expr;
     print_program_body ppf program;
   | End root -> fprintf ppf "End %a" Symbol.print root
@@ -1053,7 +1050,7 @@ let create_set_of_closures ~function_decls ~free_vars ~specialised_args
       Variable.Map.fold (fun _fun_var function_decl expected_free_vars ->
           let free_vars =
             Variable.Set.diff function_decl.free_variables
-              (Variable.Set.union (Variable.Set.of_list function_decl.params)
+              (Variable.Set.union (Parameter.Set.vars function_decl.params)
                 all_fun_vars)
           in
           Variable.Set.union free_vars expected_free_vars)
@@ -1086,7 +1083,7 @@ let create_set_of_closures ~function_decls ~free_vars ~specialised_args
     end;
     let all_params =
       Variable.Map.fold (fun _fun_var function_decl all_params ->
-          Variable.Set.union (Variable.Set.of_list function_decl.params)
+          Variable.Set.union (Parameter.Set.vars function_decl.params)
             all_params)
         function_decls.funs
         Variable.Set.empty
@@ -1111,7 +1108,7 @@ let create_set_of_closures ~function_decls ~free_vars ~specialised_args
 let used_params function_decl =
   Variable.Set.filter
     (fun param -> Variable.Set.mem param function_decl.free_variables)
-    (Variable.Set.of_list function_decl.params)
+    (Parameter.Set.vars function_decl.params)
 
 let compare_const (c1:const) (c2:const) =
   match c1, c2 with

diff --git a/middle_end/flambda.mli b/middle_end/flambda.mli
index 4ad1a765685b4c3f084b95ab4b0764e7d8e23ea7..695616f334fbb7d2f351349f59997dab05c8c60c 100755 (executable)
--- a/middle_end/flambda.mli
+++ b/middle_end/flambda.mli
@@ -300,7 +300,7 @@ and function_declarations = private {
 }
 
 and function_declaration = private {
-  params : Variable.t list;
+  params : Parameter.t list;
   body : t;
   (* CR-soon mshinwell: inconsistent naming free_variables/free_vars here and
      above *)
@@ -546,7 +546,7 @@ end
 (** Create a function declaration.  This calculates the free variables and
     symbols occurring in the specified [body]. *)
 val create_function_declaration
-   : params:Variable.t list
+   : params:Parameter.t list
   -> body:t
   -> stub:bool
   -> dbg:Debuginfo.t

diff --git a/middle_end/flambda_invariants.ml b/middle_end/flambda_invariants.ml
index 42fa15c2cdd017b23b9953f31cadf99e07fcfdf5..7236c17f378b4aae18b9969f40bd133a115878e3 100755 (executable)
--- a/middle_end/flambda_invariants.ml
+++ b/middle_end/flambda_invariants.ml
@@ -303,7 +303,7 @@ let variable_and_symbol_invariants (program : Flambda.program) =
             let acceptable_free_variables =
               Variable.Set.union
                 (Variable.Set.union variables_in_closure functions_in_closure)
-                (Variable.Set.of_list params)
+                (Parameter.Set.vars params)
             in
             let bad =
               Variable.Set.diff free_variables acceptable_free_variables
@@ -315,7 +315,7 @@ let variable_and_symbol_invariants (program : Flambda.program) =
             (* Check that parameters are unique across all functions in the
                declaration. *)
             let old_all_params_size = Variable.Set.cardinal all_params in
-            let params = Variable.Set.of_list params in
+            let params = Parameter.Set.vars params in
             let params_size = Variable.Set.cardinal params in
             let all_params = Variable.Set.union all_params params in
             let all_params_size = Variable.Set.cardinal all_params in

diff --git a/middle_end/flambda_utils.ml b/middle_end/flambda_utils.ml
index 14a9eafe9e62839a0ae5c57cc8e4e2fb9ef88118..f5f44b36904f62df0466d211412478271d9e9883 100644 (file)
--- a/middle_end/flambda_utils.ml
+++ b/middle_end/flambda_utils.ml
@@ -44,7 +44,7 @@ let function_arity (f : Flambda.function_declaration) = List.length f.params
 let variables_bound_by_the_closure cf
       (decls : Flambda.function_declarations) =
   let func = find_declaration cf decls in
-  let params = Variable.Set.of_list func.params in
+  let params = Parameter.Set.vars func.params in
   let functions = Variable.Map.keys decls.funs in
   Variable.Set.diff
     (Variable.Set.diff func.free_variables params)
@@ -191,7 +191,7 @@ and same_named (named1 : Flambda.named) (named2 : Flambda.named) =
 
 and sameclosure (c1 : Flambda.function_declaration)
       (c2 : Flambda.function_declaration) =
-  Misc.Stdlib.List.equal Variable.equal c1.params c2.params
+  Misc.Stdlib.List.equal Parameter.equal c1.params c2.params
     && same c1.body c2.body
 
 and same_set_of_closures (c1 : Flambda.set_of_closures)
@@ -320,7 +320,7 @@ let toplevel_substitution_named sb named =
 
 let make_closure_declaration ~id ~body ~params ~stub : Flambda.t =
   let free_variables = Flambda.free_variables body in
-  let param_set = Variable.Set.of_list params in
+  let param_set = Parameter.Set.vars params in
   if not (Variable.Set.subset param_set free_variables) then begin
     Misc.fatal_error "Flambda_utils.make_closure_declaration"
   end;
@@ -334,8 +334,9 @@ let make_closure_declaration ~id ~body ~params ~stub : Flambda.t =
      to do something similar to what happens in [Inlining_transforms] now. *)
   let body = toplevel_substitution sb body in
   let subst id = Variable.Map.find id sb in
+  let subst_param param = Parameter.map_var subst param in
   let function_declaration =
-    Flambda.create_function_declaration ~params:(List.map subst params)
+    Flambda.create_function_declaration ~params:(List.map subst_param params)
       ~body ~stub ~dbg:Debuginfo.none ~inline:Default_inline
       ~specialise:Default_specialise ~is_a_functor:false
   in
@@ -733,18 +734,93 @@ let substitute_read_symbol_field_for_variables
   in
   Flambda_iterators.map_toplevel f (fun v -> v) expr
 
-(* CR-soon mshinwell: implement this so that sharing can occur in
-   matches.  Should probably leave this for the first release. *)
-type sharing_key = unit
-let make_key _ = None
+module Switch_storer = Switch.Store (struct
+  type t = Flambda.t
 
-module Switch_storer =
-  Switch.Store
-    (struct
-      type t = Flambda.t
-      type key = sharing_key
-      let make_key = make_key
-    end)
+  (* An easily-comparable subset of [Flambda.t]: currently this only
+     supports that required to share switch branches. *)
+  type key =
+    | Var of Variable.t
+    | Let of Variable.t * key_named * key
+    | Static_raise of Static_exception.t * Variable.t list
+  and key_named =
+    | Symbol of Symbol.t
+    | Const of Flambda.const
+    | Prim of Lambda.primitive * Variable.t list
+    | Expr of key
+
+  exception Not_comparable
+
+  let rec make_expr_key (expr : Flambda.t) : key =
+    match expr with
+    | Var v -> Var v
+    | Let { var; defining_expr; body; } ->
+      Let (var, make_named_key defining_expr, make_expr_key body)
+    | Static_raise (e, args) -> Static_raise (e, args)
+    | _ -> raise Not_comparable
+  and make_named_key (named:Flambda.named) : key_named =
+    match named with
+    | Symbol s -> Symbol s
+    | Const c -> Const c
+    | Expr e -> Expr (make_expr_key e)
+    | Prim (prim, args, _dbg) -> Prim (prim, args)
+    | _ -> raise Not_comparable
+
+  let make_key expr =
+    match make_expr_key expr with
+    | exception Not_comparable -> None
+    | key -> Some key
+
+  let compare_key e1 e2 =
+    (* The environment [env] maps variables bound in [e2] to the corresponding
+       bound variables in [e1]. Every variable to compare in [e2] must have an
+       equivalent in [e1], otherwise the comparison wouldn't have gone
+       past the [Let] binding.  Hence [Variable.Map.find] is safe here. *)
+    let compare_var env v1 v2 =
+      match Variable.Map.find v2 env with
+      | exception Not_found ->
+        (* The variable is free in the expression [e2], hence we can
+           compare it with [v1] directly. *)
+        Variable.compare v1 v2
+      | bound ->
+        Variable.compare v1 bound
+    in
+    let rec compare_expr env (e1 : key) (e2 : key) : int =
+      match e1, e2 with
+      | Var v1, Var v2 ->
+        compare_var env v1 v2
+      | Var _, (Let _| Static_raise _) -> -1
+      | (Let _| Static_raise _), Var _ ->  1
+      | Let (v1, n1, b1), Let (v2, n2, b2) ->
+        let comp_named = compare_named env n1 n2 in
+        if comp_named <> 0 then comp_named
+        else
+          let env = Variable.Map.add v2 v1 env in
+          compare_expr env b1 b2
+      | Let _, Static_raise _ -> -1
+      | Static_raise _, Let _ ->  1
+      | Static_raise (sexn1, args1), Static_raise (sexn2, args2) ->
+        let comp_sexn = Static_exception.compare sexn1 sexn2 in
+        if comp_sexn <> 0 then comp_sexn
+        else Misc.Stdlib.List.compare (compare_var env) args1 args2
+    and compare_named env (n1:key_named) (n2:key_named) : int =
+      match n1, n2 with
+      | Symbol s1, Symbol s2 -> Symbol.compare s1 s2
+      | Symbol _, (Const _ | Expr _ | Prim _) -> -1
+      | (Const _ | Expr _ | Prim _), Symbol _ ->  1
+      | Const c1, Const c2 -> compare c1 c2
+      | Const _, (Expr _ | Prim _) -> -1
+      | (Expr _ | Prim _), Const _ ->  1
+      | Expr e1, Expr e2 -> compare_expr env e1 e2
+      | Expr _, Prim _ -> -1
+      | Prim _, Expr _ ->  1
+      | Prim (prim1, args1), Prim (prim2, args2) ->
+        let comp_prim = Pervasives.compare prim1 prim2 in
+        if comp_prim <> 0 then comp_prim
+        else Misc.Stdlib.List.compare (compare_var env) args1 args2
+    in
+    compare_expr Variable.Map.empty e1 e2
+end)
 
 let fun_vars_referenced_in_decls
       (function_decls : Flambda.function_declarations) ~backend =
@@ -803,7 +879,7 @@ let closures_required_by_entry_point ~(entry_point : Closure_id.t) ~backend
 
 let all_functions_parameters (function_decls : Flambda.function_declarations) =
   Variable.Map.fold (fun _ ({ params } : Flambda.function_declaration) set ->
-      Variable.Set.union set (Variable.Set.of_list params))
+      Variable.Set.union set (Parameter.Set.vars params))
     function_decls.funs Variable.Set.empty
 
 let all_free_symbols (function_decls : Flambda.function_declarations) =
@@ -856,7 +932,7 @@ let parameters_specialised_to_the_same_variable
   in
   Variable.Map.map (fun ({ params; _ } : Flambda.function_declaration) ->
       List.map (fun param ->
-          match Variable.Map.find param specialised_args with
+          match Variable.Map.find (Parameter.var param) specialised_args with
           | exception Not_found -> Not_specialised
           | { var; _ } ->
             Specialised_and_aliased_to

diff --git a/middle_end/flambda_utils.mli b/middle_end/flambda_utils.mli
index d9030d83b603df2602f5af98a09bf91c2d776803..37196c06c9421fc89aa7f0aaf8e6e8554828d8dd 100644 (file)
--- a/middle_end/flambda_utils.mli
+++ b/middle_end/flambda_utils.mli
@@ -54,10 +54,6 @@ val can_be_merged : Flambda.t -> Flambda.t -> bool
 
 val description_of_toplevel_node : Flambda.t -> string
 
-(** Sharing key, used for coalescing switch cases. *)
-type sharing_key
-val make_key : Flambda.t -> sharing_key option
-
 (* Given an expression, freshen all variables within it, and form a function
    whose body is the resulting expression.  The variables specified by
    [params] will become the parameters of the function; the closure will be
@@ -69,7 +65,7 @@ val make_key : Flambda.t -> sharing_key option
 val make_closure_declaration
    : id:Variable.t
   -> body:Flambda.t
-  -> params:Variable.t list
+  -> params:Parameter.t list
   -> stub:bool
   -> Flambda.t
 

diff --git a/middle_end/freshening.ml b/middle_end/freshening.ml
index 796531c2ee09ea297853ed33339a397d1ccbf937..3d891cbd5f82b6f6c8643b13e16223072d52b226 100644 (file)
--- a/middle_end/freshening.ml
+++ b/middle_end/freshening.ml
@@ -130,6 +130,11 @@ let active_add_variable t id =
   let t = add_sb_var t id id' in
   id', t
 
+let active_add_parameter t param =
+  let param' = Parameter.rename param in
+  let t = add_sb_var t (Parameter.var param) (Parameter.var param') in
+  param', t
+
 let add_variable t id =
   match t with
   | Inactive -> id, t
@@ -137,10 +142,11 @@ let add_variable t id =
      let id', t = active_add_variable t id in
      id', Active t
 
-let active_add_variables' t ids =
-  List.fold_right (fun id (ids, t) ->
-      let id', t = active_add_variable t id in
-      id' :: ids, t) ids ([], t)
+let active_add_parameters' t (params:Parameter.t list) =
+  List.fold_right (fun param (params, t) ->
+      let param', t = active_add_parameter t param in
+      param' :: params, t)
+    params ([], t)
 
 let add_variables t defs =
   List.fold_right (fun (id, data) (defs, t) ->
@@ -300,8 +306,8 @@ module Project_var = struct
     | Inactive -> func_decls, subst, t
     | Active subst ->
       let subst_func_decl _fun_id (func_decl : Flambda.function_declaration)
-            subst =
-        let params, subst = active_add_variables' subst func_decl.params in
+          subst =
+        let params, subst = active_add_parameters' subst func_decl.params in
         (* Since all parameters are distinct, even between functions, we can
            just use a single substitution. *)
         let body =

diff --git a/middle_end/inconstant_idents.ml b/middle_end/inconstant_idents.ml
index dc0b3e2c60300d1c823badec58e556821a879218..dde1cba18990de01f9b0e3843510f4a14ddaca29 100755 (executable)
--- a/middle_end/inconstant_idents.ml
+++ b/middle_end/inconstant_idents.ml
@@ -439,7 +439,7 @@ module Inconstants (P:Param) (Backend:Backend_intf.S) = struct
             | outer_var ->
               register_implication ~in_nc:(Var outer_var.var)
                 ~implies_in_nc:[Var param])
-          ffunc.params;
+          (Parameter.List.vars ffunc.params);
         mark_loop ~toplevel:false [] ffunc.body)
       function_decls.funs
 

diff --git a/middle_end/inline_and_simplify.ml b/middle_end/inline_and_simplify.ml
index 20264e00a1d3754ce0768e56c5a33112fe4afb33..3c3ea48fb4064330512d2030bd4ff217f144699d 100755 (executable)
--- a/middle_end/inline_and_simplify.ml
+++ b/middle_end/inline_and_simplify.ml
@@ -807,7 +807,7 @@ and simplify_partial_application env r ~lhs_of_application
   | Default_specialise -> ()
   end;
   let freshened_params =
-    List.map (fun id -> Variable.rename id) function_decl.Flambda.params
+    List.map (fun p -> Parameter.rename p) function_decl.Flambda.params
   in
   let applied_args, remaining_args =
     Misc.Stdlib.List.map2_prefix (fun arg id' -> id', arg)
@@ -817,7 +817,7 @@ and simplify_partial_application env r ~lhs_of_application
     let body : Flambda.t =
       Apply {
         func = lhs_of_application;
-        args = freshened_params;
+        args = Parameter.List.vars freshened_params;
         kind = Direct closure_id_being_applied;
         dbg;
         inline = Default_inline;
@@ -836,8 +836,8 @@ and simplify_partial_application env r ~lhs_of_application
   in
   let with_known_args =
     Flambda_utils.bind
-      ~bindings:(List.map (fun (var, arg) ->
-          var, Flambda.Expr (Var arg)) applied_args)
+      ~bindings:(List.map (fun (param, arg) ->
+          Parameter.var param, Flambda.Expr (Var arg)) applied_args)
       ~body:wrapper_accepting_remaining_args
   in
   simplify env r with_known_args
@@ -1023,22 +1023,24 @@ and simplify_named env r (tree : Flambda.named) : Flambda.named * R.t =
       | (Parraysetu kind | Parraysets kind),
         [_block; _field; _value],
         [block_approx; _field_approx; value_approx] ->
-        if A.is_definitely_immutable block_approx then begin
+        if A.warn_on_mutation block_approx then begin
           Location.prerr_warning (Debuginfo.to_location dbg)
             Warnings.Assignment_to_non_mutable_value
         end;
-        let kind = match A.descr block_approx, A.descr value_approx with
-          | (Value_float_array _, _)
-          | (_, Value_float _) ->
-            begin match kind with
+        let kind =
+          let check () =
+            match kind with
             | Pfloatarray | Pgenarray -> ()
             | Paddrarray | Pintarray ->
               (* CR pchambart: Do a proper warning here *)
               Misc.fatal_errorf "Assignment of a float to a specialised \
                                  non-float array: %a"
                 Flambda.print_named tree
-            end;
-            Lambda.Pfloatarray
+          in
+          match A.descr block_approx, A.descr value_approx with
+          | (Value_float_array _, _) -> check (); Lambda.Pfloatarray
+          | (_, Value_float _) when Config.flat_float_array ->
+            check (); Lambda.Pfloatarray
             (* CR pchambart: This should be accounted by the benefit *)
           | _ ->
             kind
@@ -1050,7 +1052,7 @@ and simplify_named env r (tree : Flambda.named) : Flambda.named * R.t =
         in
         Prim (prim, args, dbg), ret r (A.value_unknown Other)
       | Psetfield _, _block::_, block_approx::_ ->
-        if A.is_definitely_immutable block_approx then begin
+        if A.warn_on_mutation block_approx then begin
           Location.prerr_warning (Debuginfo.to_location dbg)
             Warnings.Assignment_to_non_mutable_value
         end;
@@ -1501,11 +1503,12 @@ let define_let_rec_symbol_approx env defs =
       env
     else
       let env =
-        List.fold_left (fun env (symbol, constant_defining_value) ->
+        List.fold_left (fun newenv (symbol, constant_defining_value) ->
             let approx =
               constant_defining_value_approx env constant_defining_value
             in
-            E.redefine_symbol env symbol approx)
+            let approx = A.augment_with_symbol approx symbol in
+            E.redefine_symbol newenv symbol approx)
           env defs
       in
       loop (times-1) env
@@ -1572,13 +1575,13 @@ let rec simplify_program_body env r (program : Flambda.program_body)
   | Let_rec_symbol (defs, program) ->
     let env = define_let_rec_symbol_approx env defs in
     let env, r, defs =
-      List.fold_left (fun (env, r, defs) (symbol, def) ->
+      List.fold_left (fun (newenv, r, defs) (symbol, def) ->
           let r, def, approx =
             simplify_constant_defining_value env r symbol def
           in
           let approx = A.augment_with_symbol approx symbol in
-          let env = E.redefine_symbol env symbol approx in
-          (env, r, (symbol, def) :: defs))
+          let newenv = E.redefine_symbol newenv symbol approx in
+          (newenv, r, (symbol, def) :: defs))
         (env, r, []) defs
     in
     let program, r = simplify_program_body env r program in

diff --git a/middle_end/inline_and_simplify_aux.ml b/middle_end/inline_and_simplify_aux.ml
index f853d451be3cc3cf8d68494ad6b12d86604bce7c..56d556fc7eeaafc33f84144e5ddf57f5a6d7c9aa 100644 (file)
--- a/middle_end/inline_and_simplify_aux.ml
+++ b/middle_end/inline_and_simplify_aux.ml
@@ -293,7 +293,7 @@ module Env = struct
       try
         Set_of_closures_origin.Map.find origin t.actively_unrolling
       with Not_found ->
-        Misc.fatal_error "Unexpected actively unrolled function";
+        Misc.fatal_error "Unexpected actively unrolled function"
     in
     let actively_unrolling =
       Set_of_closures_origin.Map.add origin (unrolling - 1) t.actively_unrolling
@@ -543,7 +543,7 @@ let prepare_to_simplify_set_of_closures ~env
           match only_for_function_decl with
           | None -> true
           | Some function_decl ->
-            Variable.Set.mem param (Variable.Set.of_list function_decl.params)
+            Variable.Set.mem param (Parameter.Set.vars function_decl.params)
         in
         if not keep then None
         else
@@ -660,7 +660,7 @@ let populate_closure_approximations
           with Not_found -> (A.value_unknown Other)
         in
         E.add env id approx)
-      env function_decl.params
+      env (Parameter.List.vars function_decl.params)
   in
   env
 

diff --git a/middle_end/inline_and_simplify_aux.mli b/middle_end/inline_and_simplify_aux.mli
index a1b71c145babe5d30fd129a659c2dff23734b6ae..b9ea66f3cf7a3e326502ad08d7a68abd70f029ee 100755 (executable)
--- a/middle_end/inline_and_simplify_aux.mli
+++ b/middle_end/inline_and_simplify_aux.mli
@@ -286,7 +286,7 @@ module Result : sig
   val set_approx : t -> Simple_value_approx.t -> t
 
   (** Set the approximation of the subexpression to the meet of the
-      current return aprroximation and the provided one. Typically
+      current return approximation and the provided one. Typically
       used just before returning from a branch case of the
       simplification algorithm. *)
   val meet_approx : t -> Env.t -> Simple_value_approx.t -> t

diff --git a/middle_end/inlining_cost.ml b/middle_end/inlining_cost.ml
index 696a76461b11780e8f2c624378e95d8812faf537..7b8f04f377493fce985855dc13930736bbf06e16 100644 (file)
--- a/middle_end/inlining_cost.ml
+++ b/middle_end/inlining_cost.ml
@@ -482,7 +482,7 @@ module Whether_sufficient_benefit = struct
     let estimate = if t.estimate then "<" else "=" in
       Printf.sprintf "{benefit%s{call=%d,alloc=%d,prim=%i,branch=%i,\
           indirect=%i,req=%i,\
-          lifting=%b}, orig_size=%d,new_size=%d,eval_size=%d,\
+          lifting=%B}, orig_size=%d,new_size=%d,eval_size=%d,\
           eval_benefit%s%d,\
           branch_depth=%d}=%s"
         estimate

diff --git a/middle_end/inlining_decision.ml b/middle_end/inlining_decision.ml
index d0dadee4c3db5162113dab7009fb2949da77a19c..ee7abf2d6ae8d0f580068cfe1c12124bffaeb30b 100755 (executable)
--- a/middle_end/inlining_decision.ml
+++ b/middle_end/inlining_decision.ml
@@ -335,7 +335,7 @@ let specialise env r ~lhs_of_application
          (fun id approx ->
             not ((A.useful approx)
                  && Variable.Map.mem id (Lazy.force invariant_params)))
-         function_decl.params args_approxs)
+         (Parameter.List.vars function_decl.params) args_approxs)
   in
   let always_specialise, never_specialise =
     (* Merge call site annotation and function annotation.

diff --git a/middle_end/inlining_transforms.ml b/middle_end/inlining_transforms.ml
index d2bcd624177aef3633fa89d486a9113c247e4cec..68c8d3bceb452fddbd6aea568eefc0a87d05e2db 100755 (executable)
--- a/middle_end/inlining_transforms.ml
+++ b/middle_end/inlining_transforms.ml
@@ -82,6 +82,7 @@ let set_inline_attribute_on_all_apply body inline specialise =
 let copy_of_function's_body_with_freshened_params env
       ~(function_decl : Flambda.function_declaration) =
   let params = function_decl.params in
+  let param_vars = Parameter.List.vars params in
   (* We cannot avoid the substitution in the case where we are inlining
      inside the function itself.  This can happen in two ways: either
      (a) we are inlining the function itself directly inside its declaration;
@@ -90,13 +91,16 @@ let copy_of_function's_body_with_freshened_params env
      original [params] may still be referenced; for (b) we cannot do it
      either since the freshening may already be renaming the parameters for
      the first inlining of the function. *)
-  if E.does_not_bind env params
-    && E.does_not_freshen env params
+  if E.does_not_bind env param_vars
+    && E.does_not_freshen env param_vars
   then
     params, function_decl.body
   else
-    let freshened_params = List.map (fun var -> Variable.rename var) params in
-    let subst = Variable.Map.of_list (List.combine params freshened_params) in
+    let freshened_params = List.map (fun p -> Parameter.rename p) params in
+    let subst =
+      Variable.Map.of_list
+        (List.combine param_vars (Parameter.List.vars freshened_params))
+    in
     let body = Flambda_utils.toplevel_substitution subst function_decl.body in
     freshened_params, body
 
@@ -142,7 +146,8 @@ let inline_by_copying_function_body ~env ~r
   let bindings_for_params_to_args =
     (* Bind the function's parameters to the arguments from the call site. *)
     let args = List.map (fun arg -> Flambda.Expr (Var arg)) args in
-    Flambda_utils.bind ~body ~bindings:(List.combine freshened_params args)
+    Flambda_utils.bind ~body
+      ~bindings:(List.combine (Parameter.List.vars freshened_params) args)
   in
   (* Add bindings for the variables bound by the closure. *)
   let bindings_for_vars_bound_by_closure_and_params_to_args =
@@ -204,7 +209,7 @@ let inline_by_copying_function_declaration ~env ~r
   let specialised_args_set = Variable.Map.keys specialised_args in
   let worth_specialising_args, specialisable_args, args, args_decl =
     which_function_parameters_can_we_specialise
-      ~params:function_decl.params ~args ~args_approxs
+      ~params:(Parameter.List.vars function_decl.params) ~args ~args_approxs
       ~invariant_params
       ~specialised_args:specialised_args_set
   in

diff --git a/middle_end/invariant_params.ml b/middle_end/invariant_params.ml
index 5011417622719b762af7334133c7651435e0bd3a..065ab22c79c117c4e5866b8c70db31611a0d04ad 100755 (executable)
--- a/middle_end/invariant_params.ml
+++ b/middle_end/invariant_params.ml
@@ -161,7 +161,7 @@ let analyse_functions ~backend ~param_to_param
   let function_variable_alias = function_variable_alias ~backend decls in
   let param_indexes_by_fun_vars =
     Variable.Map.map (fun (decl : Flambda.function_declaration) ->
-        Array.of_list decl.params)
+      Array.of_list (Parameter.List.vars decl.params))
       decls.funs
   in
   let find_callee_arg ~callee ~callee_pos =
@@ -200,7 +200,10 @@ let analyse_functions ~backend ~param_to_param
         let new_relation =
           (* We only track dataflow for parameters of functions, not
              arbitrary variables. *)
-          if List.mem caller_arg params then
+          if List.exists
+              (fun param -> Variable.equal (Parameter.var param) caller_arg)
+              params
+          then
             param_to_param ~caller ~caller_arg ~callee ~callee_arg !relation
           else begin
             used_variable caller_arg;
@@ -252,13 +255,15 @@ let analyse_functions ~backend ~param_to_param
   Variable.Map.iter
     (fun func_var ({ params } : Flambda.function_declaration) ->
        List.iter
-         (fun param ->
-            if Variable.Tbl.mem used_variables param then
+         (fun (param : Parameter.t) ->
+            if Variable.Tbl.mem used_variables (Parameter.var param) then
               relation :=
-                param_to_anywhere ~caller:func_var ~caller_arg:param !relation;
+                param_to_anywhere ~caller:func_var
+                  ~caller_arg:(Parameter.var param) !relation;
             if Variable.Tbl.mem escaping_functions func_var then
               relation :=
-                anything_to_param ~callee:func_var ~callee_arg:param !relation)
+                anything_to_param ~callee:func_var
+                  ~callee_arg:(Parameter.var param) !relation)
          params)
     decls.funs;
   transitive_closure !relation
@@ -329,7 +334,7 @@ let invariant_params_in_recursion (decls : Flambda.function_declarations)
   in
   let params = Variable.Map.fold (fun _
         ({ params } : Flambda.function_declaration) set ->
-      Variable.Set.union (Variable.Set.of_list params) set)
+      Variable.Set.union (Parameter.Set.vars params) set)
     decls.funs Variable.Set.empty
   in
   let unchanging = Variable.Set.diff params not_unchanging in
@@ -405,7 +410,7 @@ let unused_arguments (decls : Flambda.function_declarations) ~backend =
               | exception Not_found -> Variable.Set.add param acc
               | Implication _ -> Variable.Set.add param acc
               | Top -> acc)
-           acc decl.Flambda.params)
+           acc (Parameter.List.vars decl.Flambda.params))
       decls.funs Variable.Set.empty
   in
   if dump then begin

diff --git a/middle_end/lift_constants.mli b/middle_end/lift_constants.mli
index 464391aac0a05fced4c82113c1f06bf8f6ba8b60..969c365e3334f52d8959e2e188795ba26aaf27d3 100644 (file)
--- a/middle_end/lift_constants.mli
+++ b/middle_end/lift_constants.mli
@@ -28,7 +28,7 @@
     [Inconstant_idents] is a "backwards" analysis that propagates implications
     about inconstantness of variables and set of closures IDs.
 
-    [Alias_analysis] is a "forwards" analysis that is analagous to the
+    [Alias_analysis] is a "forwards" analysis that is analogous to the
     propagation of [Simple_value_approx.t] values during [Inline_and_simplify].
     It gives us information about relationships between values but not actually
     about their constantness.

diff --git a/middle_end/lift_let_to_initialize_symbol.mli b/middle_end/lift_let_to_initialize_symbol.mli
index 287cdcab0e79292f6d48657a7f9c09b41428d0f7..afb1c60f9cbf807e28ac259a4223a676a5da7996 100644 (file)
--- a/middle_end/lift_let_to_initialize_symbol.mli
+++ b/middle_end/lift_let_to_initialize_symbol.mli
@@ -22,7 +22,7 @@
     [Let]-expressions typically come from the compilation of modules (using
     the bytecode strategy) in [Translmod].
 
-    This means of compilation supercedes the old "transl_store_" methodology
+    This means of compilation supersedes the old "transl_store_" methodology
     for native code.
 
     An [Initialize_symbol] construction generated by this pass may be

diff --git a/middle_end/middle_end.ml b/middle_end/middle_end.ml
index 901c96a66b78f76ea16498d2aeae4eea33918727..02720645d8893f64f4659a11839dc8f0421913b5 100644 (file)
--- a/middle_end/middle_end.ml
+++ b/middle_end/middle_end.ml
@@ -30,154 +30,170 @@ let _dump_function_sizes flam ~backend =
           | None -> assert false)
         set_of_closures.function_decls.funs)
 
-let middle_end ppf ~source_provenance ~prefixname ~backend
+let middle_end ppf ~prefixname ~backend
     ~size
     ~filename
     ~module_ident
     ~module_initializer =
-  let pass_number = ref 0 in
-  let round_number = ref 0 in
-  let check flam =
-    if !Clflags.flambda_invariant_checks then begin
-      try Flambda_invariants.check_exn flam
-      with exn ->
-        Misc.fatal_errorf "After Flambda pass %d, round %d:@.%s:@.%a"
-          !pass_number !round_number (Printexc.to_string exn)
-          Flambda.print_program flam
-    end
-  in
-  let (+-+) flam (name, pass) =
-    incr pass_number;
-    if !Clflags.dump_flambda_verbose then begin
-      Format.fprintf ppf "@.PASS: %s@." name;
-      Format.fprintf ppf "Before pass %d, round %d:@ %a@." !pass_number
-        !round_number Flambda.print_program flam;
-      Format.eprintf "\n@?"
-    end;
-    let timing_pass = (Timings.Flambda_pass (name, source_provenance)) in
-    let flam = Timings.accumulate_time timing_pass pass flam in
-    if !Clflags.flambda_invariant_checks then begin
-      Timings.accumulate_time (Flambda_pass ("check", source_provenance))
-        check flam
-    end;
-    flam
-  in
-  Timings.accumulate_time
-    (Flambda_pass ("middle_end", source_provenance)) (fun () ->
-    let flam =
-      let timing_pass =
-        Timings.Flambda_pass ("closure_conversion", source_provenance)
-      in
-      Timings.accumulate_time timing_pass (fun () ->
-          module_initializer
-          |> Closure_conversion.lambda_to_flambda ~backend ~module_ident
-                ~size ~filename)
-        ()
+  Profile.record_call "flambda" (fun () ->
+    let previous_warning_printer = !Location.warning_printer in
+    let module WarningSet =
+      Set.Make (struct
+        type t = Location.t * Warnings.t
+        let compare = Pervasives.compare
+      end)
     in
-    if !Clflags.dump_rawflambda
-    then
-      Format.fprintf ppf "After closure conversion:@ %a@."
-        Flambda.print_program flam;
-    check flam;
-    let fast_mode flam =
-      pass_number := 0;
-      let round = 0 in
-      flam
-      +-+ ("lift_lets 1", Lift_code.lift_lets)
-      +-+ ("Lift_constants", Lift_constants.lift_constants ~backend)
-      +-+ ("Share_constants", Share_constants.share_constants)
-      +-+ ("Lift_let_to_initialize_symbol",
-           Lift_let_to_initialize_symbol.lift ~backend)
-      +-+ ("Inline_and_simplify",
-           Inline_and_simplify.run ~never_inline:false ~backend
-             ~prefixname ~round)
-      +-+ ("Remove_unused_closure_vars 2",
-           Remove_unused_closure_vars.remove_unused_closure_variables
-             ~remove_direct_call_surrogates:false)
-      +-+ ("Ref_to_variables",
-           Ref_to_variables.eliminate_ref)
-      +-+ ("Initialize_symbol_to_let_symbol",
-           Initialize_symbol_to_let_symbol.run)
+    let warning_set = ref WarningSet.empty in
+    let flambda_warning_printer loc _fmt w =
+      let elt = loc, w in
+      if not (WarningSet.mem elt !warning_set) then begin
+        warning_set := WarningSet.add elt !warning_set;
+        previous_warning_printer loc !Location.formatter_for_warnings w
+      end;
     in
-    let rec loop flam =
-      pass_number := 0;
-      let round = !round_number in
-      incr round_number;
-      if !round_number > (Clflags.rounds ()) then flam
-      else
-        flam
-        (* Beware: [Lift_constants] must be run before any pass that might
-           duplicate strings. *)
-        +-+ ("lift_lets 1", Lift_code.lift_lets)
-        +-+ ("Lift_constants", Lift_constants.lift_constants ~backend)
-        +-+ ("Share_constants", Share_constants.share_constants)
-        +-+ ("Remove_unused_program_constructs",
-             Remove_unused_program_constructs.remove_unused_program_constructs)
-        +-+ ("Lift_let_to_initialize_symbol",
-             Lift_let_to_initialize_symbol.lift ~backend)
-        +-+ ("lift_lets 2", Lift_code.lift_lets)
-        +-+ ("Remove_unused_closure_vars 1",
-             Remove_unused_closure_vars.remove_unused_closure_variables
-              ~remove_direct_call_surrogates:false)
-        +-+ ("Inline_and_simplify",
-             Inline_and_simplify.run ~never_inline:false ~backend
-               ~prefixname ~round)
-        +-+ ("Remove_unused_closure_vars 2",
-             Remove_unused_closure_vars.remove_unused_closure_variables
-              ~remove_direct_call_surrogates:false)
-        +-+ ("lift_lets 3", Lift_code.lift_lets)
-        +-+ ("Inline_and_simplify noinline",
-             Inline_and_simplify.run ~never_inline:true ~backend
-              ~prefixname ~round)
-        +-+ ("Remove_unused_closure_vars 3",
-             Remove_unused_closure_vars.remove_unused_closure_variables
-              ~remove_direct_call_surrogates:false)
-        +-+ ("Ref_to_variables",
-             Ref_to_variables.eliminate_ref)
-        +-+ ("Initialize_symbol_to_let_symbol",
-             Initialize_symbol_to_let_symbol.run)
-        |> loop
-    in
-    let back_end flam =
-      flam
-      +-+ ("Remove_unused_closure_vars",
-           Remove_unused_closure_vars.remove_unused_closure_variables
-             ~remove_direct_call_surrogates:true)
-      +-+ ("Lift_constants", Lift_constants.lift_constants ~backend)
-      +-+ ("Share_constants", Share_constants.share_constants)
-      +-+ ("Remove_unused_program_constructs",
-        Remove_unused_program_constructs.remove_unused_program_constructs)
-    in
-    let flam =
-      if !Clflags.classic_inlining then
-        fast_mode flam
-      else
-        loop flam
-    in
-    let flam = back_end flam in
-    (* Check that there aren't any unused "always inline" attributes. *)
-    Flambda_iterators.iter_apply_on_program flam ~f:(fun apply ->
-        match apply.inline with
-        | Default_inline | Never_inline -> ()
-        | Always_inline ->
-          (* CR-someday mshinwell: consider a different error message if
-             this triggers as a result of the propagation of a user's
-             attribute into the second part of an over application
-             (inline_and_simplify.ml line 710). *)
-          Location.prerr_warning (Debuginfo.to_location apply.dbg)
-            (Warnings.Inlining_impossible "[@inlined] attribute was not \
-              used on this function application (the optimizer did not \
-              know what function was being applied)")
-        | Unroll _ ->
-          Location.prerr_warning (Debuginfo.to_location apply.dbg)
-            (Warnings.Inlining_impossible "[@unroll] attribute was not \
-              used on this function application (the optimizer did not \
-              know what function was being applied)"));
-    if !Clflags.dump_flambda
-    then
-      Format.fprintf ppf "End of middle end:@ %a@."
-        Flambda.print_program flam;
-    check flam;
-    (* CR-someday mshinwell: add -d... option for this *)
-    (* dump_function_sizes flam ~backend; *)
-    flam) ();
+    Misc.protect_refs
+      [Misc.R (Location.warning_printer, flambda_warning_printer)]
+      (fun () ->
+         let pass_number = ref 0 in
+         let round_number = ref 0 in
+         let check flam =
+           if !Clflags.flambda_invariant_checks then begin
+             try Flambda_invariants.check_exn flam
+             with exn ->
+               Misc.fatal_errorf "After Flambda pass %d, round %d:@.%s:@.%a"
+                 !pass_number !round_number (Printexc.to_string exn)
+                 Flambda.print_program flam
+           end
+         in
+         let (+-+) flam (name, pass) =
+           incr pass_number;
+           if !Clflags.dump_flambda_verbose then begin
+             Format.fprintf ppf "@.PASS: %s@." name;
+             Format.fprintf ppf "Before pass %d, round %d:@ %a@." !pass_number
+               !round_number Flambda.print_program flam;
+             Format.eprintf "\n@?"
+           end;
+           let flam = Profile.record ~accumulate:true name pass flam in
+           if !Clflags.flambda_invariant_checks then begin
+             Profile.record ~accumulate:true "check" check flam
+           end;
+           flam
+         in
+         Profile.record_call ~accumulate:true "middle_end" (fun () ->
+           let flam =
+             Profile.record_call ~accumulate:true "closure_conversion"
+               (fun () ->
+                  module_initializer
+                  |> Closure_conversion.lambda_to_flambda ~backend
+                       ~module_ident ~size ~filename)
+           in
+           if !Clflags.dump_rawflambda
+           then
+             Format.fprintf ppf "After closure conversion:@ %a@."
+               Flambda.print_program flam;
+           check flam;
+           let fast_mode flam =
+             pass_number := 0;
+             let round = 0 in
+             flam
+             +-+ ("lift_lets 1", Lift_code.lift_lets)
+             +-+ ("Lift_constants", Lift_constants.lift_constants ~backend)
+             +-+ ("Share_constants", Share_constants.share_constants)
+             +-+ ("Lift_let_to_initialize_symbol",
+                  Lift_let_to_initialize_symbol.lift ~backend)
+             +-+ ("Inline_and_simplify",
+                  Inline_and_simplify.run ~never_inline:false ~backend
+                    ~prefixname ~round)
+             +-+ ("Remove_unused_closure_vars 2",
+                  Remove_unused_closure_vars.remove_unused_closure_variables
+                    ~remove_direct_call_surrogates:false)
+             +-+ ("Ref_to_variables",
+                  Ref_to_variables.eliminate_ref)
+             +-+ ("Initialize_symbol_to_let_symbol",
+                  Initialize_symbol_to_let_symbol.run)
+           in
+           let rec loop flam =
+             pass_number := 0;
+             let round = !round_number in
+             incr round_number;
+             if !round_number > (Clflags.rounds ()) then flam
+             else
+               flam
+               (* Beware: [Lift_constants] must be run before any pass that
+                  might duplicate strings. *)
+               +-+ ("lift_lets 1", Lift_code.lift_lets)
+               +-+ ("Lift_constants", Lift_constants.lift_constants ~backend)
+               +-+ ("Share_constants", Share_constants.share_constants)
+               +-+ ("Remove_unused_program_constructs",
+                    Remove_unused_program_constructs.remove_unused_program_constructs)
+               +-+ ("Lift_let_to_initialize_symbol",
+                    Lift_let_to_initialize_symbol.lift ~backend)
+               +-+ ("lift_lets 2", Lift_code.lift_lets)
+               +-+ ("Remove_unused_closure_vars 1",
+                    Remove_unused_closure_vars.remove_unused_closure_variables
+                      ~remove_direct_call_surrogates:false)
+               +-+ ("Inline_and_simplify",
+                    Inline_and_simplify.run ~never_inline:false ~backend
+                      ~prefixname ~round)
+               +-+ ("Remove_unused_closure_vars 2",
+                    Remove_unused_closure_vars.remove_unused_closure_variables
+                      ~remove_direct_call_surrogates:false)
+               +-+ ("lift_lets 3", Lift_code.lift_lets)
+               +-+ ("Inline_and_simplify noinline",
+                    Inline_and_simplify.run ~never_inline:true ~backend
+                      ~prefixname ~round)
+               +-+ ("Remove_unused_closure_vars 3",
+                    Remove_unused_closure_vars.remove_unused_closure_variables
+                      ~remove_direct_call_surrogates:false)
+               +-+ ("Ref_to_variables",
+                    Ref_to_variables.eliminate_ref)
+               +-+ ("Initialize_symbol_to_let_symbol",
+                    Initialize_symbol_to_let_symbol.run)
+               |> loop
+           in
+           let back_end flam =
+             flam
+             +-+ ("Remove_unused_closure_vars",
+                  Remove_unused_closure_vars.remove_unused_closure_variables
+                    ~remove_direct_call_surrogates:true)
+             +-+ ("Lift_constants", Lift_constants.lift_constants ~backend)
+             +-+ ("Share_constants", Share_constants.share_constants)
+             +-+ ("Remove_unused_program_constructs",
+                  Remove_unused_program_constructs.remove_unused_program_constructs)
+           in
+           let flam =
+             if !Clflags.classic_inlining then
+               fast_mode flam
+             else
+               loop flam
+           in
+           let flam = back_end flam in
+           (* Check that there aren't any unused "always inline" attributes. *)
+           Flambda_iterators.iter_apply_on_program flam ~f:(fun apply ->
+             match apply.inline with
+             | Default_inline | Never_inline -> ()
+             | Always_inline ->
+               (* CR-someday mshinwell: consider a different error message if
+                  this triggers as a result of the propagation of a user's
+                  attribute into the second part of an over application
+                  (inline_and_simplify.ml line 710). *)
+               Location.prerr_warning (Debuginfo.to_location apply.dbg)
+                 (Warnings.Inlining_impossible
+                    "[@inlined] attribute was not used on this function \
+                     application (the optimizer did not know what function \
+                     was being applied)")
+             | Unroll _ ->
+               Location.prerr_warning (Debuginfo.to_location apply.dbg)
+                 (Warnings.Inlining_impossible
+                    "[@unroll] attribute was not used on this function \
+                     application (the optimizer did not know what function \
+                     was being applied)"));
+           if !Clflags.dump_flambda
+           then
+             Format.fprintf ppf "End of middle end:@ %a@."
+               Flambda.print_program flam;
+           check flam;
+           (* CR-someday mshinwell: add -d... option for this *)
+           (* dump_function_sizes flam ~backend; *)
+           flam))
+      )

diff --git a/middle_end/middle_end.mli b/middle_end/middle_end.mli
index ff8728a3e8f3c152bd56d114afa952584ebeb9de..0f715b9d0b0cb0ca01ef3e636e7ac79895c3523b 100644 (file)
--- a/middle_end/middle_end.mli
+++ b/middle_end/middle_end.mli
@@ -20,7 +20,6 @@
 
 val middle_end
    : Format.formatter
-  -> source_provenance:Timings.source_provenance
   -> prefixname:string
   -> backend:(module Backend_intf.S)
   -> size:int

diff --git a/middle_end/parameter.ml b/middle_end/parameter.ml
new file mode 100644 (file)
index 0000000..213611b
--- /dev/null
+++ b/middle_end/parameter.ml
@@ -0,0 +1,68 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+[@@@ocaml.warning "+a-4-9-30-40-41-42"]
+
+[@@@ocaml.warning "+9"]
+(* Warning 9 is enabled to ensure correct update of each function when
+   a field is added to type parameter *)
+
+type parameter = {
+  var : Variable.t;
+}
+
+let wrap var = { var }
+
+let var p = p.var
+
+module M =
+  Identifiable.Make (struct
+    type t = parameter
+
+    let compare { var = var1 } { var = var2 } =
+      Variable.compare var1 var2
+
+    let equal { var = var1 } { var = var2 } =
+      Variable.equal var1 var2
+
+    let hash { var } =
+      Variable.hash var
+
+    let print ppf { var } =
+      Variable.print ppf var
+
+    let output o { var } =
+      Variable.output o var
+  end)
+
+module T = M.T
+include T
+
+module Map = M.Map
+module Tbl = M.Tbl
+module Set = struct
+  include M.Set
+  let vars l = Variable.Set.of_list (List.map var l)
+end
+
+let rename ?current_compilation_unit ?append p =
+  { var = Variable.rename ?current_compilation_unit ?append p.var }
+
+let map_var f { var } = { var = f var }
+
+module List = struct
+  let vars params = List.map (fun { var } -> var) params
+end

diff --git a/middle_end/parameter.mli b/middle_end/parameter.mli
new file mode 100644 (file)
index 0000000..4565720
--- /dev/null
+++ b/middle_end/parameter.mli
@@ -0,0 +1,53 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+[@@@ocaml.warning "+a-4-9-30-40-41-42"]
+
+(** [Parameter.t] carries a unique [Variable.t] used as function parameter.
+    It can also carry annotations about the usage of the variable. *)
+
+type t
+type parameter = t
+
+(** Make a parameter from a variable with default attributes *)
+val wrap : Variable.t -> t
+
+val var : t -> Variable.t
+
+(** Rename the inner variable of the parameter *)
+val rename
+   : ?current_compilation_unit:Compilation_unit.t
+  -> ?append:string
+  -> t
+  -> t
+
+val map_var : (Variable.t -> Variable.t) -> t -> t
+
+module T : Identifiable.Thing with type t = t
+
+module Set : sig
+  include Identifiable.Set with module T := T
+  val vars : parameter list -> Variable.Set.t
+end
+
+include Identifiable.S with type t := t
+                        and module T := T
+                        and module Set := Set
+
+module List : sig
+  (** extract variables from a list of parameters, preserving the order *)
+  val vars : t list -> Variable.t list
+end

diff --git a/middle_end/remove_free_vars_equal_to_args.ml b/middle_end/remove_free_vars_equal_to_args.ml
index 6b3b59d6d81347927f3b3d0682eb6fd157b19188..c149b4fff1ac17946392e518acb2b2be8c9c03cc 100755 (executable)
--- a/middle_end/remove_free_vars_equal_to_args.ml
+++ b/middle_end/remove_free_vars_equal_to_args.ml
@@ -38,7 +38,7 @@ let rewrite_one_function_decl ~(function_decl : Flambda.function_declaration)
             Variable.Set.fold (fun free_var subst ->
                 Variable.Map.add free_var param subst)
               set subst)
-      Variable.Map.empty function_decl.params
+      Variable.Map.empty (Parameter.List.vars function_decl.params)
   in
   if Variable.Map.is_empty params_for_equal_free_vars then
     function_decl

diff --git a/middle_end/remove_unused_arguments.ml b/middle_end/remove_unused_arguments.ml
index 42f1c0ffe6022ff0edad23c45c6aa31aecb6944f..a810ce98beba5c314e09aa8fb94576b971a3d317 100644 (file)
--- a/middle_end/remove_unused_arguments.ml
+++ b/middle_end/remove_unused_arguments.ml
@@ -25,14 +25,15 @@ let rename_var var =
 
 let remove_params unused (fun_decl: Flambda.function_declaration) =
   let unused_params, used_params =
-    List.partition (fun v -> Variable.Set.mem v unused) fun_decl.params
+    List.partition (fun v -> Variable.Set.mem (Parameter.var v) unused)
+      fun_decl.params
   in
   let unused_params = List.filter (fun v ->
-      Variable.Set.mem v fun_decl.free_variables) unused_params
+      Variable.Set.mem (Parameter.var v) fun_decl.free_variables) unused_params
   in
   let body =
-    List.fold_left (fun body var ->
-        Flambda.create_let var (Const (Const_pointer 0)) body)
+    List.fold_left (fun body param ->
+        Flambda.create_let (Parameter.var param) (Const (Const_pointer 0)) body)
       fun_decl.body
       unused_params
   in
@@ -44,12 +45,16 @@ let make_stub unused var (fun_decl : Flambda.function_declaration)
     ~specialised_args ~additional_specialised_args =
   let renamed = rename_var var in
   let args' =
-    List.map (fun var -> var, rename_var var) fun_decl.params
+    List.map (fun param -> param, Parameter.rename param) fun_decl.params
   in
   let used_args' =
-    List.filter (fun (var, _) -> not (Variable.Set.mem var unused)) args'
+    List.filter (fun (param, _) ->
+      not (Variable.Set.mem (Parameter.var param) unused)) args'
   in
-  let args_renaming = Variable.Map.of_list args' in
+  let args'_var =
+    List.map (fun (p1, p2) -> Parameter.var p1, Parameter.var p2) args'
+  in
+  let args_renaming = Variable.Map.of_list args'_var in
   let additional_specialised_args =
     List.fold_left (fun additional_specialised_args (original_arg,arg) ->
         match Variable.Map.find original_arg specialised_args with
@@ -74,14 +79,14 @@ let make_stub unused var (fun_decl : Flambda.function_declaration)
               }
           in
           Variable.Map.add arg outer_var additional_specialised_args)
-      additional_specialised_args args'
+      additional_specialised_args args'_var
   in
   let args = List.map (fun (_, var) -> var) used_args' in
   let kind = Flambda.Direct (Closure_id.wrap renamed) in
   let body : Flambda.t =
     Apply {
       func = renamed;
-      args;
+      args = Parameter.List.vars args;
       kind;
       dbg = fun_decl.dbg;
       inline = Default_inline;
@@ -104,7 +109,7 @@ let separate_unused_arguments ~only_specialised
         if decl.stub then
           acc
         else
-          Variable.Set.union acc (Variable.Set.of_list decl.Flambda.params))
+          Variable.Set.union acc (Parameter.Set.vars decl.Flambda.params))
       function_decls.funs Variable.Set.empty
   in
   let unused = Variable.Set.inter non_stub_arguments unused in
@@ -119,7 +124,8 @@ let separate_unused_arguments ~only_specialised
     let funs, additional_specialised_args =
       Variable.Map.fold (fun fun_id (fun_decl : Flambda.function_declaration)
                           (funs, additional_specialised_args) ->
-          if List.exists (fun v -> Variable.Set.mem v unused) fun_decl.params
+          if List.exists (fun v -> Variable.Set.mem (Parameter.var v) unused)
+              fun_decl.params
           then begin
             let stub, renamed_fun_id, additional_specialised_args =
               make_stub unused fun_id fun_decl

diff --git a/middle_end/remove_unused_closure_vars.ml b/middle_end/remove_unused_closure_vars.ml
index 2f58d045c65f3d2e73611c9e0b9ef778e6a2b3e2..90036d820714464f959ebe5ba7e2da4d6abe3ff0 100644 (file)
--- a/middle_end/remove_unused_closure_vars.ml
+++ b/middle_end/remove_unused_closure_vars.ml
@@ -93,7 +93,7 @@ let remove_unused_closure_variables ~remove_direct_call_surrogates program =
         (* Remove specialised args that are used by removed functions *)
         let all_remaining_arguments =
           Variable.Map.fold (fun _ { Flambda.params } set ->
-              Variable.Set.union set (Variable.Set.of_list params))
+              Variable.Set.union set (Parameter.Set.vars params))
             funs Variable.Set.empty
         in
         Variable.Map.filter (fun arg _ ->

diff --git a/middle_end/simple_value_approx.ml b/middle_end/simple_value_approx.ml
index 43c7f92ea721d4bbc130e1c371a5bb414504a961..506c755cad3f4b00566c3be6bbbaaaa016eea70d 100644 (file)
--- a/middle_end/simple_value_approx.ml
+++ b/middle_end/simple_value_approx.ml
@@ -243,7 +243,7 @@ let create_value_set_of_closures
     lazy (
       let functions = Variable.Map.keys function_decls.funs in
       Variable.Map.map (fun (function_decl : Flambda.function_declaration) ->
-          let params = Variable.Set.of_list function_decl.params in
+          let params = Parameter.Set.vars function_decl.params in
           let free_vars =
             Variable.Set.diff
               (Variable.Set.diff function_decl.free_variables params)
@@ -488,10 +488,11 @@ let useful t =
 
 let all_not_useful ts = List.for_all (fun t -> not (useful t)) ts
 
-let is_definitely_immutable t =
+let warn_on_mutation t =
   match t.descr with
+  | Value_block(_, fields) -> Array.length fields > 0
   | Value_string { contents = Some _ }
-  | Value_block _ | Value_int _ | Value_char _ | Value_constptr _
+  | Value_int _ | Value_char _ | Value_constptr _
   | Value_set_of_closures _ | Value_float _ | Value_boxed_int _
   | Value_closure _ -> true
   | Value_string { contents = None } | Value_float_array _

diff --git a/middle_end/simple_value_approx.mli b/middle_end/simple_value_approx.mli
index ec33239cfccb51fe8ca3e381970c34a7402cb11a..6e082e32eb290da18a10e2c760d0a14b8349d009 100644 (file)
--- a/middle_end/simple_value_approx.mli
+++ b/middle_end/simple_value_approx.mli
@@ -282,10 +282,10 @@ val useful : t -> bool
 (** Whether all approximations in the given list do *not* satisfy [useful]. *)
 val all_not_useful : t list -> bool
 
-(** A value is certainly immutable if its approximation is known and not bottom.
+(** Whether to warn on attempts to mutate a value.
     It must have been resolved (it cannot be [Value_extern] or
     [Value_symbol]).  (See comment above for further explanation.) *)
-val is_definitely_immutable : t -> bool
+val warn_on_mutation : t -> bool
 
 type simplification_summary =
   | Nothing_done

diff --git a/middle_end/simplify_primitives.ml b/middle_end/simplify_primitives.ml
index 14c43efe379c5b0e6ad7c482a8ef31990a4b24a7..759728d959f9de63718658deb578af1633862428 100644 (file)
--- a/middle_end/simplify_primitives.ml
+++ b/middle_end/simplify_primitives.ml
@@ -37,6 +37,47 @@ let phys_equal (approxs:A.t list) =
     | Some (s1, Some f1), Some (s2, Some f2) -> Symbol.equal s1 s2 && f1 = f2
     | _ -> false
 
+let is_known_to_be_some_kind_of_int (arg:A.descr) =
+  match arg with
+  | Value_int _ | Value_char _ | Value_constptr _ -> true
+  | Value_block (_, _) | Value_float _ | Value_set_of_closures _
+  | Value_closure _ | Value_string _ | Value_float_array _
+  | A.Value_boxed_int _ | Value_unknown _ | Value_extern _
+  | Value_symbol _ | Value_unresolved _ | Value_bottom -> false
+
+let is_known_to_be_some_kind_of_block (arg:A.descr) =
+  match arg with
+  | Value_block _ | Value_float _ | Value_float_array _ | A.Value_boxed_int _
+  | Value_closure _ | Value_string _ -> true
+  | Value_set_of_closures _ | Value_int _ | Value_char _ | Value_constptr _
+  | Value_unknown _ | Value_extern _ | Value_symbol _
+  | Value_unresolved _ | Value_bottom -> false
+
+let rec structurally_different (arg1:A.t) (arg2:A.t) =
+  match arg1.descr, arg2.descr with
+  | (Value_int n1 | Value_constptr n1), (Value_int n2 | Value_constptr n2)
+    when n1 <> n2 ->
+    true
+  | Value_block (tag1, fields1), Value_block (tag2, fields2) ->
+    not (Tag.equal tag1 tag2)
+    || (Array.length fields1 <> Array.length fields2)
+    || Misc.Stdlib.Array.exists2 structurally_different fields1 fields2
+  | descr1, descr2 ->
+    (* This is not very precise as this won't allow to distinguish
+       blocks from strings for instance. This can be improved if it
+       is deemed valuable. *)
+    (is_known_to_be_some_kind_of_int descr1
+     && is_known_to_be_some_kind_of_block descr2)
+    || (is_known_to_be_some_kind_of_block descr1
+        && is_known_to_be_some_kind_of_int descr2)
+
+let phys_different (approxs:A.t list) =
+  match approxs with
+  | [] | [_] | _ :: _ :: _ :: _ ->
+    Misc.fatal_error "wrong number of arguments for equality"
+  | [a1; a2] ->
+    structurally_different a1 a2
+
 let primitive (p : Lambda.primitive) (args, approxs) expr dbg ~size_int
       ~big_endian : Flambda.named * A.t * Inlining_cost.Benefit.t =
   let fpc = !Clflags.float_const_prop in
@@ -59,6 +100,9 @@ let primitive (p : Lambda.primitive) (args, approxs) expr dbg ~size_int
         S.const_ptr_expr (Flambda.Expr (Var arg)) 0
       | _ -> S.const_ptr_expr expr 0
     end
+  | Pmakearray(_, _) when approxs = [] ->
+    Prim (Pmakeblock(0, Asttypes.Immutable, Some []), [], dbg),
+    A.value_block (Tag.create_exn 0) [||], C.Benefit.zero
   | Pmakearray (Pfloatarray, Mutable) ->
       let approx =
         A.value_mutable_float_array ~size:(List.length args)
@@ -94,6 +138,12 @@ let primitive (p : Lambda.primitive) (args, approxs) expr dbg ~size_int
        inlined later, [a] and [b] could be shared and thus [c] and [d] could
        be too.  As such, any intermediate non-aliasing judgement would be
        invalid. *)
+  | Pintcomp Ceq when phys_different approxs ->
+    S.const_bool_expr expr false
+  | Pintcomp Cneq when phys_different approxs ->
+    S.const_bool_expr expr true
+    (* If two values are structurally different we are certain they can never
+       be shared*)
   | _ ->
     match A.descrs approxs with
     | [Value_int x] ->

diff --git a/ocamldoc/.depend b/ocamldoc/.depend
index c9e0a32988573b3a0c749c7a0df772b72113cfbf..a811143b97c6ed8c0a2d9c45ad7f74f10728297c 100644 (file)
--- a/ocamldoc/.depend
+++ b/ocamldoc/.depend
@@ -1,11 +1,3 @@
-generators/odoc_literate.cmo : odoc_info.cmi odoc_html.cmo odoc_gen.cmi \
-    odoc_args.cmi
-generators/odoc_literate.cmx : odoc_info.cmx odoc_html.cmx odoc_gen.cmx \
-    odoc_args.cmx
-generators/odoc_todo.cmo : odoc_module.cmo odoc_info.cmi odoc_html.cmo \
-    odoc_gen.cmi odoc_args.cmi
-generators/odoc_todo.cmx : odoc_module.cmx odoc_info.cmx odoc_html.cmx \
-    odoc_gen.cmx odoc_args.cmx
 odoc.cmo : odoc_messages.cmo odoc_info.cmi odoc_global.cmi odoc_gen.cmi \
     odoc_config.cmi odoc_args.cmi odoc_analyse.cmi
 odoc.cmx : odoc_messages.cmx odoc_info.cmx odoc_global.cmx odoc_gen.cmx \
@@ -15,19 +7,19 @@ odoc_analyse.cmo : ../utils/warnings.cmi ../typing/types.cmi \
     ../driver/pparse.cmi ../parsing/parse.cmi odoc_types.cmi odoc_text.cmi \
     odoc_sig.cmi odoc_module.cmo odoc_misc.cmi odoc_messages.cmo \
     odoc_merge.cmi odoc_global.cmi odoc_dep.cmo odoc_cross.cmi \
-    odoc_comments.cmi odoc_class.cmo odoc_ast.cmi ../utils/misc.cmi \
-    ../parsing/longident.cmi ../parsing/location.cmi ../parsing/lexer.cmi \
-    ../typing/env.cmi ../utils/config.cmi ../utils/clflags.cmi \
-    ../parsing/asttypes.cmi odoc_analyse.cmi
+    odoc_comments.cmi odoc_class.cmo odoc_ast.cmi ../parsing/longident.cmi \
+    ../parsing/location.cmi ../parsing/lexer.cmi ../typing/env.cmi \
+    ../utils/config.cmi ../utils/clflags.cmi ../parsing/asttypes.cmi \
+    odoc_analyse.cmi
 odoc_analyse.cmx : ../utils/warnings.cmx ../typing/types.cmx \
     ../typing/typemod.cmx ../typing/typedtree.cmx ../parsing/syntaxerr.cmx \
     ../driver/pparse.cmx ../parsing/parse.cmx odoc_types.cmx odoc_text.cmx \
     odoc_sig.cmx odoc_module.cmx odoc_misc.cmx odoc_messages.cmx \
     odoc_merge.cmx odoc_global.cmx odoc_dep.cmx odoc_cross.cmx \
-    odoc_comments.cmx odoc_class.cmx odoc_ast.cmx ../utils/misc.cmx \
-    ../parsing/longident.cmx ../parsing/location.cmx ../parsing/lexer.cmx \
-    ../typing/env.cmx ../utils/config.cmx ../utils/clflags.cmx \
-    ../parsing/asttypes.cmi odoc_analyse.cmi
+    odoc_comments.cmx odoc_class.cmx odoc_ast.cmx ../parsing/longident.cmx \
+    ../parsing/location.cmx ../parsing/lexer.cmx ../typing/env.cmx \
+    ../utils/config.cmx ../utils/clflags.cmx ../parsing/asttypes.cmi \
+    odoc_analyse.cmi
 odoc_analyse.cmi : odoc_module.cmo odoc_global.cmi
 odoc_args.cmo : ../utils/warnings.cmi odoc_types.cmi odoc_texi.cmo \
     odoc_messages.cmo odoc_man.cmo odoc_latex.cmo odoc_html.cmo \
@@ -218,19 +210,19 @@ odoc_sig.cmo : ../typing/types.cmi ../typing/typedtree.cmi \
     ../parsing/parsetree.cmi odoc_value.cmo odoc_types.cmi odoc_type.cmo \
     odoc_parameter.cmo odoc_module.cmo odoc_misc.cmi odoc_messages.cmo \
     odoc_merge.cmi odoc_global.cmi odoc_extension.cmo odoc_exception.cmo \
-    odoc_env.cmi odoc_class.cmo ../utils/misc.cmi ../parsing/location.cmi \
-    ../typing/ident.cmi ../typing/ctype.cmi ../typing/btype.cmi \
-    ../parsing/asttypes.cmi odoc_sig.cmi
+    odoc_env.cmi odoc_class.cmo ../utils/misc.cmi ../parsing/longident.cmi \
+    ../parsing/location.cmi ../typing/ident.cmi ../typing/ctype.cmi \
+    ../typing/btype.cmi ../parsing/asttypes.cmi odoc_sig.cmi
 odoc_sig.cmx : ../typing/types.cmx ../typing/typedtree.cmx \
     ../parsing/parsetree.cmi odoc_value.cmx odoc_types.cmx odoc_type.cmx \
     odoc_parameter.cmx odoc_module.cmx odoc_misc.cmx odoc_messages.cmx \
     odoc_merge.cmx odoc_global.cmx odoc_extension.cmx odoc_exception.cmx \
-    odoc_env.cmx odoc_class.cmx ../utils/misc.cmx ../parsing/location.cmx \
-    ../typing/ident.cmx ../typing/ctype.cmx ../typing/btype.cmx \
-    ../parsing/asttypes.cmi odoc_sig.cmi
+    odoc_env.cmx odoc_class.cmx ../utils/misc.cmx ../parsing/longident.cmx \
+    ../parsing/location.cmx ../typing/ident.cmx ../typing/ctype.cmx \
+    ../typing/btype.cmx ../parsing/asttypes.cmi odoc_sig.cmi
 odoc_sig.cmi : ../typing/types.cmi ../typing/typedtree.cmi \
     ../parsing/parsetree.cmi odoc_types.cmi odoc_type.cmo odoc_name.cmi \
-    odoc_module.cmo odoc_env.cmi odoc_class.cmo
+    odoc_module.cmo odoc_env.cmi odoc_class.cmo ../parsing/location.cmi
 odoc_str.cmo : ../typing/types.cmi ../typing/printtyp.cmi odoc_value.cmo \
     odoc_type.cmo odoc_print.cmi odoc_name.cmi odoc_misc.cmi \
     odoc_messages.cmo odoc_extension.cmo odoc_exception.cmo odoc_class.cmo \
@@ -272,3 +264,15 @@ odoc_value.cmo : ../typing/types.cmi ../typing/printtyp.cmi odoc_types.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_misc.cmx ../parsing/asttypes.cmi
+generators/odoc_literate.cmo : odoc_info.cmi odoc_html.cmo odoc_gen.cmi \
+    odoc_args.cmi
+generators/odoc_literate.cmx : odoc_info.cmx odoc_html.cmx odoc_gen.cmx \
+    odoc_args.cmx
+generators/odoc_literate.cmxs : odoc_info.cmx odoc_html.cmx odoc_gen.cmx \
+    odoc_args.cmx
+generators/odoc_todo.cmo : odoc_module.cmo odoc_info.cmi odoc_html.cmo \
+    odoc_gen.cmi odoc_args.cmi
+generators/odoc_todo.cmx : odoc_module.cmx odoc_info.cmx odoc_html.cmx \
+    odoc_gen.cmx odoc_args.cmx
+generators/odoc_todo.cmxs : odoc_module.cmx odoc_info.cmx odoc_html.cmx \
+    odoc_gen.cmx odoc_args.cmx

diff --git a/ocamldoc/Makefile b/ocamldoc/Makefile
index f69b87455027a604bc88776690a5f8eb9c0e455e..dd45b59f46482bdc16520673cb41c69c34c59595 100644 (file)
--- a/ocamldoc/Makefile
+++ b/ocamldoc/Makefile
@@ -110,7 +110,6 @@ INCLUDES_NODEP=\
   -I $(ROOTDIR)/otherlibs/str \
   -I $(ROOTDIR)/otherlibs/dynlink \
   -I $(ROOTDIR)/otherlibs/$(UNIXLIB) \
-  -I $(ROOTDIR)/otherlibs/num \
   -I $(ROOTDIR)/otherlibs/$(GRAPHLIB)
 
 INCLUDES=$(INCLUDES_DEP) $(INCLUDES_NODEP)
@@ -185,8 +184,7 @@ STDLIB_MLIS=\
   ../parsing/*.mli \
   ../otherlibs/$(UNIXLIB)/unix.mli \
   ../otherlibs/str/str.mli \
-  ../otherlibs/bigarray/bigarray.mli \
-  ../otherlibs/num/num.mli
+  ../otherlibs/bigarray/bigarray.mli
 
 .PHONY: all
 all: lib exe generators manpages
@@ -424,6 +422,7 @@ depend:
        $(OCAMLLEX) odoc_lexer.mll
        $(OCAMLLEX) odoc_ocamlhtml.mll
        $(OCAMLLEX) odoc_see_lexer.mll
-       $(OCAMLDEP) $(INCLUDES_DEP) *.mll *.mly *.ml *.mli generators/*.ml > .depend
+       $(OCAMLDEP) $(INCLUDES_DEP) *.mll *.mly *.ml *.mli > .depend
+       $(OCAMLDEP) $(INCLUDES_DEP) -shared generators/*.ml >> .depend
 
 include .depend

diff --git a/ocamldoc/generators/odoc_todo.ml b/ocamldoc/generators/odoc_todo.ml
index d404e9b0f59e25ae72e48dd37f5718e152169c12..ae90cbff4a07cf7eab80d35bdd95a198eeffbc4b 100644 (file)
--- a/ocamldoc/generators/odoc_todo.ml
+++ b/ocamldoc/generators/odoc_todo.ml
@@ -101,7 +101,7 @@ struct
               List.iter
                 (fun (n, e) ->
                    Printf.bprintf b "<span style=\"color: %s\">" (col n);
-                   html#html_of_text b e;
+                   html#html_of_text ?with_p:(Some false) b e;
                    p b "</span><br/>\n";
                 )
                 l;
@@ -143,7 +143,7 @@ struct
         (Odoc_html.Naming.complete_method_target m)
         m.met_value.val_info
 
-   (** This method scan the elements of the given module. *)
+   (** This method scans the elements of the given module. *)
     method! scan_module_elements m =
       List.iter
         (fun ele ->

diff --git a/ocamldoc/odoc_analyse.ml b/ocamldoc/odoc_analyse.ml
index 86c1ea36d00791388bb2768512c9bd5ef82adfb2..1393d571c1d668f34d2ffb76111934e54b945f42 100644 (file)
--- a/ocamldoc/odoc_analyse.ml
+++ b/ocamldoc/odoc_analyse.ml
@@ -34,19 +34,10 @@ let init_path () =
 (** Return the initial environment in which compilation proceeds. *)
 let initial_env () =
   let initial =
-    if !Clflags.unsafe_string then Env.initial_unsafe_string
+    if Config.safe_string then Env.initial_safe_string
+    else if !Clflags.unsafe_string then Env.initial_unsafe_string
     else Env.initial_safe_string
   in
-  let initial =
-    (* Open the Pervasives module by reading directly the corresponding cmi
-       file to avoid troubles when building the documentation for the
-       Pervasives modules.
-       Another option might be to add a -nopervasives option to ocamldoc and update
-       stdlib documentation's build process. *)
-    try
-      Env.open_pers_signature "Pervasives" initial
-    with Not_found ->
-      Misc.fatal_error @@ Printf.sprintf "cannot open pervasives.cmi" in
   let open_mod env m =
     let open Asttypes in
     let lid = {loc = Location.in_file "ocamldoc command line";
@@ -54,7 +45,13 @@ let initial_env () =
     snd (Typemod.type_open_ Override env lid.loc lid) in
   (* Open the list of modules given as arguments of the "-open" flag
      The list is reversed to open the modules in the left-to-right order *)
-  List.fold_left open_mod initial (List.rev !Clflags.open_modules)
+  let to_open = List.rev !Clflags.open_modules in
+  let to_open =
+    if Env.get_unit_name () = "Pervasives"
+    then to_open
+    else "Pervasives" :: to_open
+  in
+  List.fold_left open_mod initial to_open
 
 (** Optionally preprocess a source file *)
 let preprocess sourcefile =
@@ -66,7 +63,7 @@ let preprocess sourcefile =
     exit 2
 
 (** Analysis of an implementation file. Returns (Some typedtree) if
-   no error occured, else None and an error message is printed.*)
+   no error occurred, else None and an error message is printed.*)
 
 let tool_name = "ocamldoc"
 
@@ -109,7 +106,7 @@ let process_implementation_file sourcefile =
           raise e
 
 (** Analysis of an interface file. Returns (Some signature) if
-   no error occured, else None and an error message is printed.*)
+   no error occurred, else None and an error message is printed.*)
 let process_interface_file sourcefile =
   init_path ();
   let prefixname = Filename.chop_extension sourcefile in
@@ -133,13 +130,11 @@ module Sig_analyser = Odoc_sig.Analyser (Odoc_comments.Basic_info_retriever)
 (** Handle an error. *)
 
 let process_error exn =
-  match Location.error_of_exn exn with
-  | Some err ->
-      fprintf Format.err_formatter "@[%a@]@." Location.report_error err
-  | None ->
-      fprintf Format.err_formatter
-        "Compilation error(%s). Use the OCaml compiler to get more details.@."
-        (Printexc.to_string exn)
+  try Location.report_exception Format.err_formatter exn
+  with exn ->
+    fprintf Format.err_formatter
+      "Compilation error(%s). Use the OCaml compiler to get more details.@."
+      (Printexc.to_string exn)
 
 (** Process the given file, according to its extension. Return the Module.t created, if any.*)
 let process_file sourcefile =
@@ -164,7 +159,7 @@ let process_file sourcefile =
              None
          | Some (parsetree, typedtree) ->
              let file_module = Ast_analyser.analyse_typed_tree file
-                 !Location.input_name parsetree typedtree
+                 input_file parsetree typedtree
              in
              file_module.Odoc_module.m_top_deps <- Odoc_dep.impl_dependencies parsetree ;
 
@@ -192,7 +187,7 @@ let process_file sourcefile =
        try
          let (ast, signat, input_file) = process_interface_file file in
          let file_module = Sig_analyser.analyse_signature file
-             !Location.input_name ast signat.sig_type
+             input_file ast signat.sig_type
          in
 
          file_module.Odoc_module.m_top_deps <- Odoc_dep.intf_dependencies ast ;
@@ -288,7 +283,7 @@ let rec remove_class_elements_between_stop_in_class_kind k =
       Odoc_class.Class_constraint (remove_class_elements_between_stop_in_class_kind k1,
                         remove_class_elements_between_stop_in_class_type_kind ctk)
 
-(** Remove the class elements beetween the stop special comments in a class type kind. *)
+(** Remove the class elements between the stop special comments in a class type kind. *)
 and remove_class_elements_between_stop_in_class_type_kind tk =
   match tk with
     Odoc_class.Class_signature (inher, l) ->

diff --git a/ocamldoc/odoc_args.ml b/ocamldoc/odoc_args.ml
index 4d825b6e07736656a89826f2aee3c6407c4376d8..ed14b4f9c58c32a9e4f355be5b783e66af0d8a89 100644 (file)
--- a/ocamldoc/odoc_args.ml
+++ b/ocamldoc/odoc_args.ml
@@ -144,16 +144,22 @@ let analyse_merge_options s =
 
 
 let f_latex_title s =
-  try
-    let pos = String.index s ',' in
-    let n = int_of_string (String.sub s 0 pos) in
-    let len = String.length s in
-    let command = String.sub s (pos + 1) (len - pos - 1) in
-    Odoc_latex.latex_titles := List.remove_assoc n !Odoc_latex.latex_titles ;
-    Odoc_latex.latex_titles := (n, command) :: !Odoc_latex.latex_titles
-  with
-    Not_found
-  | Invalid_argument _ ->
+  match String.split_on_char ',' s with
+  | [n;command] ->
+      let n = int_of_string n in
+      Odoc_latex.latex_titles := List.remove_assoc n !Odoc_latex.latex_titles ;
+      Odoc_latex.latex_titles := (n, command) :: !Odoc_latex.latex_titles
+  | _ ->
+      incr Odoc_global.errors ;
+      prerr_endline (M.wrong_format s)
+
+let f_texinfo_title s =
+  match String.split_on_char ',' s with
+  | [n;title;heading] ->
+      let n = int_of_string n in
+      Odoc_texi.titles_and_headings :=
+        (n, (title,heading) ) :: List.remove_assoc n !Odoc_texi.titles_and_headings;
+  | _ ->
       incr Odoc_global.errors ;
       prerr_endline (M.wrong_format s)
 
@@ -352,6 +358,9 @@ let default_options = Options.list @
 (* texi only options *)
   "-noindex", Arg.Clear Odoc_global.with_index, M.no_index ;
   "-esc8", Arg.Set Odoc_texi.esc_8bits, M.esc_8bits ;
+  "-texinfotitle", Arg.String f_texinfo_title,
+  M.texinfo_title Odoc_texi.titles_and_headings ;
+
   "-info-section", Arg.String ((:=) Odoc_texi.info_section), M.info_section ;
   "-info-entry", Arg.String (fun s -> Odoc_texi.info_entry := !Odoc_texi.info_entry @ [ s ]),
   M.info_entry ^

diff --git a/ocamldoc/odoc_ast.ml b/ocamldoc/odoc_ast.ml
index 511d9d11239b1357def806b3110451e4478996b6..a6a5e55c4c2d439bbbf1ce8412138b4ad0209122 100644 (file)
--- a/ocamldoc/odoc_ast.ml
+++ b/ocamldoc/odoc_ast.ml
@@ -219,12 +219,12 @@ module Analyser =
     (** The name of the analysed file. *)
     let file_name = Sig.file_name
 
-    (** This function takes two indexes (start and end) and return the string
+    (** This function takes two indexes (start and end) and returns the string
        corresponding to the indexes in the file global variable. The function
        prepare_file must have been called to fill the file global variable.*)
     let get_string_of_file = Sig.get_string_of_file
 
-    (** This function loads the given file in the file global variable.
+    (** This function loads the given file in the file global variable
        and sets file_name.*)
     let prepare_file = Sig.prepare_file
 
@@ -677,7 +677,7 @@ module Analyser =
       in
       iter [] [] last_pos (p_cls.Parsetree.pcstr_fields)
 
-    (** Analysis of a [Parsetree.class_expr] and a [Typedtree.class_expr] to get a a couple (class parameters, class kind). *)
+    (** Analysis of a [Parsetree.class_expr] and a [Typedtree.class_expr] to get a pair (class parameters, class kind). *)
     let rec analyse_class_kind env current_class_name comment_opt last_pos p_class_expr tt_class_exp table =
       match (p_class_expr.Parsetree.pcl_desc, tt_class_exp.Typedtree.cl_desc) with
         (Parsetree.Pcl_constr (lid, _), tt_class_exp_desc ) ->
@@ -1424,7 +1424,7 @@ module Analyser =
              let new_env = Odoc_env.add_module env new_module.m_name in
              let new_env2 =
                match new_module.m_type with
-                 (* FIXME : can this be Tmty_ident? In this case, we would'nt have the signature *)
+                 (* FIXME : can this be Tmty_ident? In this case, we wouldn't have the signature *)
                  Types.Mty_signature s ->
                    Odoc_env.add_signature new_env new_module.m_name
                      ~rel: (Name.simple new_module.m_name) s
@@ -1528,7 +1528,7 @@ module Analyser =
           let new_env = Odoc_env.add_module_type env mt.mt_name in
           let new_env2 =
             match sig_mtype with
-              (* FIXME : can this be Tmty_ident? In this case, we would'nt have the signature *)
+              (* FIXME : can this be Tmty_ident? In this case, we wouldn't have the signature *)
               Some (Types.Mty_signature s) ->
                 Odoc_env.add_signature new_env mt.mt_name ~rel: (Name.simple mt.mt_name) s
             | _ ->
@@ -1870,8 +1870,8 @@ module Analyser =
        prepare_file source_file input_file;
        (* We create the t_module for this file. *)
        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
-
+       let len, info_opt = Sig.preamble !file_name !file
+           (fun x -> x.Parsetree.pstr_loc) parsetree in
        (* we must complete the included modules *)
        let elements = analyse_structure Odoc_env.empty mod_name len (String.length !file) parsetree tree_structure in
        let included_modules_from_tt = tt_get_included_module_list tree_structure in

diff --git a/ocamldoc/odoc_ast.mli b/ocamldoc/odoc_ast.mli
index d77842d7dcc26619d4178531fbb5ebc2eb6120f3..fc1c0eb7c27ee8eb682ff4d4e85aa19e02ded945 100644 (file)
--- a/ocamldoc/odoc_ast.mli
+++ b/ocamldoc/odoc_ast.mli
@@ -92,7 +92,7 @@ module Typedtree_search :
 module Analyser :
   functor (My_ir : Odoc_sig.Info_retriever) ->
     sig
-      (** This function takes a file name, a file containg the code and
+      (** This function takes a file name, a file containing the code and
          the typed tree obtained from the compiler.
          It goes through the tree, creating values for encountered
          functions, modules, ..., and looking in the source file for comments.*)

diff --git a/ocamldoc/odoc_class.ml b/ocamldoc/odoc_class.ml
index 168071a909cf0edf1ee1a844542f96ff5f632014..b25d89c513983851c6a55cc69af7b4cfd2de0654 100644 (file)
--- a/ocamldoc/odoc_class.ml
+++ b/ocamldoc/odoc_class.ml
@@ -43,7 +43,7 @@ and class_apply = {
 
 and class_constr = {
     cco_name : Name.t ; (** The complete name of the applied class *)
-    mutable cco_class : cct option;  (** The associated class ot class type if we found it *)
+    mutable cco_class : cct option;  (** The associated class of the class type if we found it *)
     cco_type_parameters : Types.type_expr list; (** The type parameters of the class, if needed *)
   }
 
@@ -55,7 +55,7 @@ and class_kind =
   | Class_constr of class_constr (** a class used to give the type of the defined class,
                                     instead of a structure, used in interface only.
                                     For example, it will be used with the name "M1.M2....tutu"
-                                    when the class to is defined like this :
+                                    when the class toto is defined like this :
                                     class toto : int -> tutu *)
   | Class_constraint of class_kind * class_type_kind
         (** A class definition with a constraint. *)
@@ -94,7 +94,7 @@ and t_class_type = {
   }
 
 
-(** {2 Functions} *)
+(** {1 Functions} *)
 
 (** Returns the text associated to the given parameter label
    in the given class, or None. *)

diff --git a/ocamldoc/odoc_comments.mli b/ocamldoc/odoc_comments.mli
index 1b42fb1564230009a086ffd3a7fcc75dddc0cdc2..1220e589221d835d4d06947c7286c73a212346cb 100644 (file)
--- a/ocamldoc/odoc_comments.mli
+++ b/ocamldoc/odoc_comments.mli
@@ -69,7 +69,7 @@ val info_of_string : string -> Odoc_types.info
    and return an {!Odoc_types.info} structure. The content of the
    file must have the same syntax as the content of a special comment.
    The given module list is used for cross reference.
-   @raise Failure is the file could not be opened or there is a
+   @raise Failure if the file could not be opened or there is a
    syntax error.
 *)
 val info_of_comment_file :

diff --git a/ocamldoc/odoc_config.mli b/ocamldoc/odoc_config.mli
index 9ea9eede70c2b2bb7469938273279162ea3284a7..1ca1af9d855de813facaea83496c1e4d106c5cea 100644 (file)
--- a/ocamldoc/odoc_config.mli
+++ b/ocamldoc/odoc_config.mli
@@ -13,7 +13,7 @@
 (*                                                                        *)
 (**************************************************************************)
 
-(** Ocamldoc configuration contants. *)
+(** Ocamldoc configuration constants. *)
 
 (** Default path to search for custom generators and to install them. *)
 val custom_generators_path : string

diff --git a/ocamldoc/odoc_cross.ml b/ocamldoc/odoc_cross.ml
index a9909ac1cf8046171d7d86370b1c23582fa5dd58..57f461fc2d572983861177b39df79105d849c6ff 100644 (file)
--- a/ocamldoc/odoc_cross.ml
+++ b/ocamldoc/odoc_cross.ml
@@ -795,7 +795,7 @@ let rec assoc_comments_text_elements parent_name module_list t_ele =
                  - if name = parent_name: we are using the name of an element
                  or module in its definition, no need of cross_reference
                  - if the path of name is a suffix of the parent path, we
-                 are in the same module, maybe the same function. To decreace
+                 are in the same module, maybe the same function. To decrease
                  the false positive rate, we stop here *)
               if name = parent_name || is_path_suffix () then
                 t_ele

diff --git a/ocamldoc/odoc_dag2html.ml b/ocamldoc/odoc_dag2html.ml
index c18c0568ed62d572aba25fb0e082e6f8f11419dd..62b7d1ecebc898448869fe85427fff40d79d2563 100644 (file)
--- a/ocamldoc/odoc_dag2html.ml
+++ b/ocamldoc/odoc_dag2html.ml
@@ -313,7 +313,7 @@ let ancestors d =
 
 let get_children d parents =
   (* XXXX merge_children used to be declared as a recursive function,
-     but it was not.  I've not idea if it a bug or not.  One should
+     but it was not.  I've no idea if it is a bug or not.  One should
      either fix it (if this is a bug), or simplify the code otherwise. *)
 
   let merge_children children el =

diff --git a/ocamldoc/odoc_dep.ml b/ocamldoc/odoc_dep.ml
index ad750a047d65ac1b4d9d1cc4327612c0b16f765f..5f8bd0652bd3c70ecf7964a7ce4acb3bc27f153a 100644 (file)
--- a/ocamldoc/odoc_dep.ml
+++ b/ocamldoc/odoc_dep.ml
@@ -180,7 +180,7 @@ let type_deps t =
 
   !l
 
-(** Modify the modules depencies of the given list of modules,
+(** Modify the module dependencies of the given list of modules,
    to get the minimum transitivity kernel. *)
 let kernel_deps_of_modules modules =
   let graph = List.map

diff --git a/ocamldoc/odoc_global.mli b/ocamldoc/odoc_global.mli
index 46bfc756804616890a4284346726669f5870bc33..0a6ef0c7bff405e4a72a42dbb18e4b5bc9ab4fce 100644 (file)
--- a/ocamldoc/odoc_global.mli
+++ b/ocamldoc/odoc_global.mli
@@ -45,7 +45,7 @@ val no_stop : bool ref
 (** We must raise an exception when we find an unknown @-tag. *)
 val no_custom_tags : bool ref
 
-(** We must remove the the first characters of each comment line, until the first asterisk '*'. *)
+(** We must remove the first characters of each comment line, until the first asterisk '*'. *)
 val remove_stars : bool ref
 
 (** To keep the code while merging, when we have both .ml and .mli files for a module. *)

diff --git a/ocamldoc/odoc_html.ml b/ocamldoc/odoc_html.ml
index 29e646caed22616eb045999023f39392f37d71ae..123cc7b53784f653712a9223885fb870e9f4ade6 100644 (file)
--- a/ocamldoc/odoc_html.ml
+++ b/ocamldoc/odoc_html.ml
@@ -36,6 +36,12 @@ let charset = ref "iso-8859-1"
 (** The functions used for naming files and html marks.*)
 module Naming =
   struct
+    (** The prefix for modules marks. *)
+    let mark_module = "MODULE"
+
+    (** The prefix for module type marks. *)
+    let mark_module_type = "MODULETYPE"
+
     (** The prefix for types marks. *)
     let mark_type = "TYPE"
 
@@ -60,10 +66,10 @@ module Naming =
     (** The prefix for methods marks. *)
     let mark_method = "METHOD"
 
-    (** The prefix for code files.. *)
+    (** The prefix for code files. *)
     let code_prefix = "code_"
 
-    (** The prefix for type files.. *)
+    (** The prefix for type files. *)
     let type_prefix = "type_"
 
     (** Return the two html files names for the given module or class name.*)
@@ -94,6 +100,12 @@ module Naming =
       let (html_file, _) = html_files module_name in
       html_file^"#"^(target pref simple_name)
 
+    (**return the link target for the given module. *)
+    let module_target m = target mark_module (Name.simple m.m_name)
+
+    (**return the link target for the given module type. *)
+    let module_type_target mt = target mark_module_type (Name.simple mt.mt_name)
+
     (** Return the link target for the given type. *)
     let type_target t = target mark_type (Name.simple t.ty_name)
 
@@ -270,8 +282,44 @@ class virtual text =
       | None -> Printf.sprintf "%d_%s" n (self#label_of_text t)
 
     (** Print the html code corresponding to the [text] parameter. *)
-    method html_of_text b t =
-      List.iter (self#html_of_text_element b) t
+    method html_of_text ?(with_p=false) b t =
+      if not with_p then
+        List.iter (self#html_of_text_element b) t
+      else
+        self#html_of_text_with_p b t
+
+    method html_of_text_with_p b t =
+      (* In order to enclose the generated text in <p> </p>, we first
+         output the content inside a inner buffer b', and then generate
+         the whole paragraph, if the content is not empty,
+         either at the end of the text, at a Newline element or when
+         encountering an element that cannot be part of a paragraph element
+      *)
+      let b' = Buffer.create 17 (* paragraph buffer *) in
+      let flush b' =
+        (* trim the inner string to avoid outputting empty <p></p> *)
+        let s = String.trim @@ Buffer.contents b' in
+        if s <> "" then
+          begin
+            bp b "<p>";
+            bs b s;
+            bp b "</p>\n"
+          end;
+        Buffer.clear b' in
+      let rec iter txt =
+        match txt with
+        | [] ->
+            flush b' (* flush b' at the end of the text *)
+        | (List _ | Enum _ | Title _ | CodePre _ | Verbatim _ | Center _
+          | Left _ | Right _ | Newline | Index_list ) as a :: q
+          (* these elements cannot be part of <p> element *)
+          ->
+            flush b'; (* stop the current paragraph *)
+            self#html_of_text_element b a; (*output [a] directly on [b] *)
+            iter q
+        | a :: q  -> self#html_of_text_element b' a; iter q
+      in
+      iter t
 
     (** Print the html code for the [text_element] in parameter. *)
     method html_of_text_element b txt =
@@ -413,7 +461,7 @@ class virtual text =
         tl;
       bs b "</OL>\n"
 
-    method html_of_Newline b = bs b "\n<p>\n"
+    method html_of_Newline b = bs b "\n"
 
     method html_of_Block b t =
       bs b "<blockquote>\n";
@@ -424,9 +472,9 @@ class virtual text =
       let label1 = self#create_title_label (n, label_opt, t) in
       let (tag_o, tag_c) =
         if n > 6 then
-          (Printf.sprintf "div class=\"h%d\"" n, "div")
+          (Printf.sprintf "div class=\"h%d\"" (n+1), "div")
         else
-          let t = Printf.sprintf "h%d" n in (t, t)
+          let t = Printf.sprintf "h%d" (n+1) in (t, t)
       in
       bs b "<";
       bp b "%s id=\"%s\"" tag_o (Naming.label_target label1);
@@ -498,7 +546,7 @@ class virtual text =
     method virtual html_of_info_first_sentence : _
 
     method html_of_Module_list b l =
-      bs b "<br>\n<table class=\"indextable\">\n";
+      bs b "\n<table class=\"indextable module-list\">\n";
       List.iter
         (fun name ->
           bs b "<tr><td class=\"module\">";
@@ -572,43 +620,44 @@ class virtual info =
     val mutable tag_functions = ([] : (string * (Odoc_info.text -> string)) list)
 
     (** The method used to get html code from a [text]. *)
-    method virtual html_of_text : Buffer.t -> Odoc_info.text -> unit
+    method virtual html_of_text :
+      ?with_p:bool -> Buffer.t -> Odoc_info.text -> unit
 
     (** Print html for an author list. *)
     method html_of_author_list b l =
       match l with
         [] -> ()
       | _ ->
-          bp b "<b>%s:</b> " Odoc_messages.authors;
+          bp b "<li><b>%s:</b> " Odoc_messages.authors;
           self#html_of_text b [Raw (String.concat ", " l)];
-          bs b "<br>\n"
+          bs b "</li>\n"
 
     (** Print html code for the given optional version information.*)
     method html_of_version_opt b v_opt =
       match v_opt with
         None -> ()
       | Some v ->
-           bp b "<b>%s:</b> " Odoc_messages.version;
+           bp b "<li><b>%s:</b> " Odoc_messages.version;
            self#html_of_text b [Raw v];
-           bs b "<br>\n"
+           bs b "</li>\n"
 
     (** Print html code for the given optional since information.*)
     method html_of_since_opt b s_opt =
       match s_opt with
         None -> ()
       | Some s ->
-          bp b "<b>%s</b> " Odoc_messages.since;
+          bp b "<li><b>%s</b> " Odoc_messages.since;
           self#html_of_text b [Raw s];
-          bs b "<br>\n"
+          bs b "</li>\n"
 
     (** Print html code for the given "before" information.*)
     method html_of_before b l =
       let f (v, text) =
-        bp b "<b>%s " Odoc_messages.before;
+        bp b "<li><b>%s " Odoc_messages.before;
         self#html_of_text b [Raw v];
         bs b " </b> ";
         self#html_of_text b text;
-        bs b "<br>\n"
+        bs b "</li>\n"
       in
       List.iter f l
 
@@ -617,13 +666,13 @@ class virtual info =
       match l with
         [] -> ()
       | (s, t) :: [] ->
-          bp b "<b>%s</b> <code>%s</code> "
+          bp b "<li><b>%s</b> <code>%s</code> "
             Odoc_messages.raises
             s;
           self#html_of_text b t;
-          bs b "<br>\n"
+          bs b "</li>\n"
       | _ ->
-          bp b "<b>%s</b><ul>" Odoc_messages.raises;
+          bp b "<li><b>%s</b><ul>" Odoc_messages.raises;
           List.iter
             (fun (ex, desc) ->
               bp b "<li><code>%s</code> " ex ;
@@ -631,7 +680,7 @@ class virtual info =
               bs b "</li>\n"
             )
             l;
-          bs b "</ul>\n"
+          bs b "</ul></li>\n"
 
     (** Print html code for the given "see also" reference. *)
     method html_of_see b (see_ref, t)  =
@@ -648,11 +697,11 @@ class virtual info =
       match l with
         [] -> ()
       | see :: [] ->
-          bp b "<b>%s</b> " Odoc_messages.see_also;
+          bp b "<li><b>%s</b> " Odoc_messages.see_also;
           self#html_of_see b see;
-          bs b "<br>\n"
+          bs b "</li>\n"
       | _ ->
-          bp b "<b>%s</b><ul>" Odoc_messages.see_also;
+          bp b "<li><b>%s</b><ul>" Odoc_messages.see_also;
           List.iter
             (fun see ->
               bs b "<li>" ;
@@ -660,16 +709,16 @@ class virtual info =
               bs b "</li>\n"
             )
             l;
-          bs b "</ul>\n"
+          bs b "</ul></li>\n"
 
     (** Print html code for the given optional return information.*)
     method html_of_return_opt b return_opt =
       match return_opt with
         None -> ()
       | Some s ->
-          bp b "<b>%s</b> " Odoc_messages.returns;
+          bp b "<li><b>%s</b> " Odoc_messages.returns;
           self#html_of_text b s;
-          bs b "<br>\n"
+          bs b "</li>\n"
 
     (** Print html code for the given list of custom tagged texts. *)
     method html_of_custom b l =
@@ -698,27 +747,39 @@ class virtual info =
           (
            match info.M.i_deprecated with
             None -> ()
-           | Some d ->
+          | Some d ->
+               bs b "<div class=\"info-deprecated\">\n";
                bs b "<span class=\"warning\">";
                bs b Odoc_messages.deprecated ;
                bs b "</span>" ;
                self#html_of_text b d;
-               bs b "<br>\n"
+               bs b "</div>\n"
           );
           (
            match info.M.i_desc with
              None -> ()
            | Some d when d = [Odoc_info.Raw ""] -> ()
-           | Some d -> self#html_of_text b d; bs b "<br>\n"
+           | Some d ->
+               bs b "<div class=\"info-desc\">\n";
+               self#html_of_text ~with_p:true b d;
+               bs b "</div>\n"
           );
-          self#html_of_author_list b info.M.i_authors;
-          self#html_of_version_opt b info.M.i_version;
-          self#html_of_before b info.M.i_before;
-          self#html_of_since_opt b info.M.i_since;
-          self#html_of_raised_exceptions b info.M.i_raised_exceptions;
-          self#html_of_return_opt b info.M.i_return_value;
-          self#html_of_sees b info.M.i_sees;
-          self#html_of_custom b info.M.i_custom;
+
+          let b' = Buffer.create 17 in
+          self#html_of_author_list b' info.M.i_authors;
+          self#html_of_version_opt b' info.M.i_version;
+          self#html_of_before b' info.M.i_before;
+          self#html_of_since_opt b' info.M.i_since;
+          self#html_of_raised_exceptions b' info.M.i_raised_exceptions;
+          self#html_of_return_opt b' info.M.i_return_value;
+          self#html_of_sees b' info.M.i_sees;
+          self#html_of_custom b' info.M.i_custom;
+          if Buffer.length b' > 0 then
+            begin
+              bs b "<ul class=\"info-attributes\">\n";
+              Buffer.add_buffer b b';
+              bs b "</ul>\n"
+            end;
           if indent then bs b "</div>\n"
 
     (** Print html code for the first sentence of a description.
@@ -736,7 +797,7 @@ class virtual info =
              None -> ()
            | Some d when d = [Odoc_info.Raw ""] -> ()
            | Some d ->
-               self#html_of_text b
+               self#html_of_text ~with_p:true b
                  (Odoc_info.text_no_title_no_list
                     (Odoc_info.first_sentence_of_text d));
                bs b "\n"
@@ -813,42 +874,44 @@ class html =
 
         "h1 { font-size : 20pt ; text-align: center; }" ;
 
-        "h2 { font-size : 20pt ; border: 1px solid #000000; "^
+        "h2 { font-size : 20pt ; text-align: center; }" ;
+
+        "h3 { font-size : 20pt ; border: 1px solid #000000; "^
         "margin-top: 5px; margin-bottom: 2px;"^
         "text-align: center; background-color: #90BDFF ;"^
         "padding: 2px; }" ;
 
-        "h3 { font-size : 20pt ; border: 1px solid #000000; "^
+        "h4 { font-size : 20pt ; border: 1px solid #000000; "^
         "margin-top: 5px; margin-bottom: 2px;"^
         "text-align: center; background-color: #90DDFF ;"^
         "padding: 2px; }" ;
 
-        "h4 { font-size : 20pt ; border: 1px solid #000000; "^
+        "h5 { font-size : 20pt ; border: 1px solid #000000; "^
         "margin-top: 5px; margin-bottom: 2px;"^
         "text-align: center; background-color: #90EDFF ;"^
         "padding: 2px; }" ;
 
-        "h5 { font-size : 20pt ; border: 1px solid #000000; "^
+        "h6 { font-size : 20pt ; border: 1px solid #000000; "^
         "margin-top: 5px; margin-bottom: 2px;"^
         "text-align: center; background-color: #90FDFF ;"^
         "padding: 2px; }" ;
 
-        "h6 { font-size : 20pt ; border: 1px solid #000000; "^
+        "div.h7 { font-size : 20pt ; border: 1px solid #000000; "^
         "margin-top: 5px; margin-bottom: 2px;"^
         "text-align: center; background-color: #90BDFF ; "^
         "padding: 2px; }" ;
 
-        "div.h7 { font-size : 20pt ; border: 1px solid #000000; "^
+        "div.h8 { font-size : 20pt ; border: 1px solid #000000; "^
         "margin-top: 5px; margin-bottom: 2px;"^
         "text-align: center; background-color: #E0FFFF ; "^
         "padding: 2px; }" ;
 
-        "div.h8 { font-size : 20pt ; border: 1px solid #000000; "^
+        "div.h9 { font-size : 20pt ; border: 1px solid #000000; "^
         "margin-top: 5px; margin-bottom: 2px;"^
         "text-align: center; background-color: #F0FFFF ; "^
         "padding: 2px; }" ;
 
-        "div.h9 { font-size : 20pt ; border: 1px solid #000000; "^
+        "div.h10 { font-size : 20pt ; border: 1px solid #000000; "^
         "margin-top: 5px; margin-bottom: 2px;"^
         "text-align: center; background-color: #FFFFFF ; "^
         "padding: 2px; }" ;
@@ -869,6 +932,9 @@ class html =
 
         "ul.indexlist { margin-left: 0; padding-left: 0;}";
         "ul.indexlist li { list-style-type: none ; margin-left: 0; padding-left: 0; }";
+        "ul.info-attributes {list-style: none; margin: 0; padding: 0; }";
+        "div.info > p:first-child { margin-top:0; }";
+        "div.info-desc > p:first-child { margin-top:0; margin-bottom:0; }"
       ]
 
     (** The style file for all pages. *)
@@ -1860,12 +1926,14 @@ class html =
             match Parameter.desc_by_name p n with
               None -> ()
             | Some t ->
+                bs b "<div class=\"parameter-desc\">\n";
                 bs b "<code>";
                 bs b n;
                 bs b "</code> : ";
-                self#html_of_text b t
+                self#html_of_text b t;
+                bs b "</div>\n"
           in
-          print_concat b "<br>\n" print_one l2
+          List.iter print_one l2
 
     (** Print html code for a list of parameters. *)
     method html_of_parameter_list b m_name l =
@@ -1889,8 +1957,9 @@ class html =
               );
             bs b "</td>\n<td align=\"center\" valign=\"top\">:</td>\n";
             bs b "<td>";
+            bs b "<div class=\"paramer-type\">\n";
             self#html_of_type_expr b m_name (Parameter.typ p);
-            bs b "<br>\n";
+            bs b "<div>\n";
             self#html_of_parameter_description b p;
             bs b "\n</tr>\n";
           in
@@ -1942,8 +2011,9 @@ class html =
                match desc_opt with
                  None -> ()
                | Some t ->
-                   bs b "<br>";
+                   bs b "<div class=\"parameter-desc\" >";
                    self#html_of_text b t;
+                   bs b "\n</div>\n";
                    bs b "\n</tr>\n" ;
               )
             )
@@ -1955,6 +2025,7 @@ class html =
       let (html_file, _) = Naming.html_files m.m_name in
       let father = Name.father m.m_name in
       bs b "\n<pre>";
+      bp b "<span id=\"%s\">" (Naming.module_target m);
       bs b ((self#keyword "module")^" ");
       (
        if with_link then
@@ -1962,6 +2033,7 @@ class html =
        else
          bs b (Name.simple m.m_name)
       );
+      bs b "</span>" ;
       (
        match m.m_kind with
          Module_functor _ when !html_short_functors  ->
@@ -1985,13 +2057,15 @@ class html =
       let (html_file, _) = Naming.html_files mt.mt_name in
       let father = Name.father mt.mt_name in
       bs b "\n<pre>";
-      bs b ((self#keyword "module type")^" ");
+      bp b "<span id=\"%s\">" (Naming.module_type_target mt);
+      bs b (self#keyword "module type" ^ " ");
       (
        if with_link then
          bp b "<a href=\"%s\">%s</a>" html_file (Name.simple mt.mt_name)
          else
          bs b (Name.simple mt.mt_name)
       );
+      bs b "</span>";
       (match mt.mt_kind with
         None -> ()
       | Some k ->
@@ -2125,11 +2199,12 @@ class html =
       bs b "\n<pre>";
       (* we add a html id, the same as for a type so we can
          go directly here when the class name is used as a type name *)
-      bp b "<span name=\"%s\">"
+      bp b "<span id=\"%s\">"
         (Naming.type_target
            { ty_name = c.cl_name ;
              ty_info = None ; ty_parameters = [] ;
-             ty_kind = Type_abstract ; ty_private = Asttypes.Public; ty_manifest = None ;
+             ty_kind = Type_abstract ; ty_private = Asttypes.Public;
+             ty_manifest = None ;
              ty_loc = Odoc_info.dummy_loc ;
              ty_code = None ;
            }
@@ -2231,9 +2306,7 @@ class html =
 
     (** Print html code for a module comment.*)
     method html_of_module_comment b text =
-      bs b "<br>\n";
-      self#html_of_text b text;
-      bs b "<br>\n"
+      self#html_of_text ~with_p:true b text
 
     (** Print html code for a class comment.*)
     method html_of_class_comment b text =
@@ -2241,10 +2314,10 @@ class html =
       let text2 =
         match text with
         | (Odoc_info.Raw s) :: q ->
-            (Odoc_info.Title (2, None, [Odoc_info.Raw s])) :: q
+            (Odoc_info.Title (1, None, [Odoc_info.Raw s])) :: q
         | _ -> text
       in
-      self#html_of_text b text2
+      self#html_of_text ~with_p:true b text2
 
     (** Generate html code for the given list of inherited classes.*)
     method generate_inheritance_info b inher_l =
@@ -2344,9 +2417,9 @@ class html =
                   'A'..'Z' as c -> String.make 1 c
                 | _ -> ""
               in
-              bs b "<tr><td align=\"left\"><br>";
+              bs b "<tr><td align=\"left\"><div>";
               bs b s ;
-              bs b "</td></tr>\n" ;
+              bs b "</div></td></tr>\n" ;
               List.iter f_ele l
         in
         bs b "<table>\n";
@@ -2626,15 +2699,20 @@ class html =
       try
         let chanout = open_out (Filename.concat !Global.target_dir self#index) in
         let b = new_buf () in
-        let title = match !Global.title with None -> "" | Some t -> self#escape t in
         bs b doctype ;
         bs b "<html>\n";
         self#print_header b self#title;
         bs b "<body>\n";
 
-        bs b "<h1>";
-        bs b title;
-        bs b "</h1>\n" ;
+        (
+        match !Global.title with
+        | None -> ()
+        | Some t ->
+            bs b "<h1>";
+            bs b (self#escape t);
+            bs b "</h1>\n"
+        );
+
         let info = Odoc_info.apply_opt
             (Odoc_info.info_of_comment_file module_list)
             !Odoc_info.Global.intro_file
@@ -2642,8 +2720,9 @@ class html =
         (
          match info with
            None ->
+             bs b "<div class = \"index-list\">\n";
              self#html_of_Index_list b;
-             bs b "<br/>";
+             bs b "</div>\n";
              self#html_of_Module_list b
                (List.map (fun m -> m.m_name) module_list);
          | Some _ -> self#html_of_info ~indent: false b info

diff --git a/ocamldoc/odoc_info.mli b/ocamldoc/odoc_info.mli
index d7c3677736cbd5e00ff54f0f55abbf9f9bb4ebca..d0d183b40a8678a0add33e037ec91bd618d4d021 100644 (file)
--- a/ocamldoc/odoc_info.mli
+++ b/ocamldoc/odoc_info.mli
@@ -15,7 +15,7 @@
 
 (** Interface to the information collected in source files. *)
 
-(** The differents kinds of element references. *)
+(** The different kinds of element references. *)
 type ref_kind = Odoc_types.ref_kind =
     RK_module
   | RK_module_type
@@ -94,7 +94,7 @@ type info = Odoc_types.info = {
     i_sees : see list; (** The list of \@see tags. *)
     i_since : string option; (** The string in the \@since tag. *)
     i_before : (string * text) list ; (** the version number and text in \@before tag *)
-    i_deprecated : text option; (** The of the \@deprecated tag. *)
+    i_deprecated : text option; (** The description text of the \@deprecated tag. *)
     i_params : param list; (** The list of parameter descriptions. *)
     i_raised_exceptions : raised_exception list; (** The list of raised exceptions. *)
     i_return_value : text option; (** The description text of the return value. *)
@@ -121,7 +121,7 @@ module Name :
       (** [concat t1 t2] returns the concatenation of [t1] and [t2].*)
       val concat : t -> t -> t
 
-      (** Return the depth of the name, i.e. the numer of levels to the root.
+      (** Return the depth of the name, i.e. the number of levels to the root.
          Example : [depth "Toto.Tutu.name"] = [3]. *)
       val depth : t -> int
 
@@ -135,7 +135,7 @@ module Name :
 (** Representation and manipulation of method / function / class / module parameters.*)
 module Parameter :
   sig
-    (** {3 Types} *)
+    (** {1 Types} *)
 
     (** Representation of a simple parameter name *)
     type simple_name = Odoc_parameter.simple_name =
@@ -154,9 +154,9 @@ module Parameter :
     (** A parameter is just a param_info.*)
     type parameter = param_info
 
-    (** {3 Functions} *)
+    (** {1 Functions} *)
 
-    (** Acces to the name as a string. For tuples, parenthesis and commas are added. *)
+    (** Access to the name as a string. For tuples, parentheses and commas are added. *)
     val complete_name : parameter -> string
 
     (** Access to the complete type. *)
@@ -232,7 +232,7 @@ module Exception :
           ex_name : Name.t ;
           mutable ex_info : info option ; (** Information found in the optional associated comment. *)
           ex_args : Odoc_type.constructor_args;
-          ex_ret : Types.type_expr option ; (** The the optional return type of the exception. *)
+          ex_ret : Types.type_expr option ; (** The optional return type of the exception. *)
           ex_alias : exception_alias option ; (** [None] when the exception is not a rebind. *)
           mutable ex_loc : location ;
           mutable ex_code : string option ;
@@ -283,7 +283,7 @@ module Type :
     }
 
     type type_manifest = Odoc_type.type_manifest =
-      | Other of Types.type_expr (** Type manifest directly taken from Typedtre. *)
+      | Other of Types.type_expr (** Type manifest directly taken from Typedtree. *)
       | Object_type of object_field list
 
     (** Representation of a type. *)
@@ -343,7 +343,7 @@ module Value :
 (** Representation and manipulation of classes and class types.*)
 module Class :
   sig
-    (** {3 Types} *)
+    (** {1 Types} *)
 
     (** To keep the order of elements in a class. *)
     type class_element = Odoc_class.class_element =
@@ -368,7 +368,7 @@ module Class :
           capp_name : Name.t ; (** The complete name of the applied class. *)
           mutable capp_class : t_class option;  (** The associated t_class if we found it. *)
           capp_params : Types.type_expr list; (** The type of expressions the class is applied to. *)
-          capp_params_code : string list ; (** The code of these exprssions. *)
+          capp_params_code : string list ; (** The code of these expressions. *)
         }
 
     and class_constr = Odoc_class.class_constr =
@@ -429,7 +429,7 @@ module Class :
           mutable clt_loc : location ;
         }
 
-    (** {3 Functions} *)
+    (** {1 Functions} *)
 
     (** Access to the elements of a class. *)
     val class_elements : ?trans:bool -> t_class -> class_element list
@@ -465,7 +465,7 @@ module Class :
 (** Representation and manipulation of modules and module types. *)
 module Module :
   sig
-    (** {3 Types} *)
+    (** {1 Types} *)
 
     (** To keep the order of elements in a module. *)
     type module_element = Odoc_module.module_element =
@@ -489,7 +489,7 @@ module Module :
         {
           im_name : Name.t ; (** Complete name of the included module. *)
           mutable im_module : mmt option ; (** The included module or module type, if we found it. *)
-          mutable im_info : Odoc_types.info option ; (** comment associated to the includ directive *)
+          mutable im_info : Odoc_types.info option ; (** comment associated with the include directive *)
         }
 
     and module_alias = Odoc_module.module_alias =
@@ -570,7 +570,7 @@ module Module :
           mutable mt_loc : location ;
         }
 
-    (** {3 Functions for modules} *)
+    (** {1 Functions for modules} *)
 
     (** Access to the elements of a module. *)
     val module_elements : ?trans:bool -> t_module -> module_element list
@@ -620,7 +620,7 @@ module Module :
     (** The list of module comments. *)
     val module_comments : ?trans:bool-> t_module -> text list
 
-    (** {3 Functions for module types} *)
+    (** {1 Functions for module types} *)
 
     (** Access to the elements of a module type. *)
     val module_type_elements : ?trans:bool-> t_module_type -> module_element list
@@ -669,7 +669,7 @@ module Module :
   end
 
 
-(** {3 Getting strings from values} *)
+(** {2 Getting strings from values} *)
 
 (** This function is used to reset the names of type variables.
    It must be called when printing the whole type of a function,
@@ -678,10 +678,10 @@ module Module :
 val reset_type_names : unit -> unit
 
 (** [string_of_variance t (covariant, invariant)] returns ["+"] if
-   the given information means "covariant", ["-"] if the it means
+   the given information means "covariant", ["-"] if it means
    "contravariant", orelse [""], and always [""] if the given
    type is not an abstract type with no manifest (i.e. no need
-   for the variance to be printed.*)
+   for the variance to be printed).*)
 val string_of_variance : Type.t_type -> (bool * bool) -> string
 
 (** This function returns a string representing a Types.type_expr. *)
@@ -710,7 +710,7 @@ val string_of_class_type_param_list : Types.type_expr list -> string
 
 (** This function returns a string representing a [Types.module_type].
    @param complete indicates if we must print complete signatures
-   or just [sig end]. Default if [false].
+   or just [sig end]. Default is [false].
    @param code if [complete = false] and the type contains something else
    than identificators and functors, then the given code is used.
 *)
@@ -718,7 +718,7 @@ val string_of_module_type : ?code: string -> ?complete: bool -> Types.module_typ
 
 (** This function returns a string representing a [Types.class_type].
    @param complete indicates if we must print complete signatures
-   or just [object end]. Default if [false].
+   or just [object end]. Default is [false].
 *)
 val string_of_class_type : ?complete: bool -> Types.class_type -> string
 
@@ -749,7 +749,7 @@ val string_of_attribute : Value.t_attribute -> string
 (** @return a string to describe the given method. *)
 val string_of_method : Value.t_method -> string
 
-(** {3 Miscelaneous functions} *)
+(** {2 Miscellaneous functions} *)
 
 (** Return the first sentence (until the first dot followed by a blank
    or the first blank line) of a text.
@@ -782,7 +782,7 @@ val get_titles_in_text : text -> (int * string option * text) list
 val create_index_lists : 'a list -> ('a -> string) -> 'a list list
 
 (** Take a type and remove the option top constructor. This is
-   useful when printing labels, we we then remove the top option contructor
+   useful when printing labels, we then remove the top option constructor
    for optional labels.*)
 val remove_option : Types.type_expr -> Types.type_expr
 
@@ -849,7 +849,7 @@ val info_string_of_info : info -> string
    and return an {!Odoc_info.info} structure. The content of the
    file must have the same syntax as the content of a special comment.
    The given module list is used for cross reference.
-   @raise Failure is the file could not be opened or there is a
+   @raise Failure if the file could not be opened or there is a
    syntax error.
 *)
 val info_of_comment_file : Module.t_module list -> string -> info
@@ -933,7 +933,7 @@ module Scan :
 
       (** Scan of a type extension *)
 
-        (** Overide this method to perform controls on the extension's type,
+        (** Override this method to perform controls on the extension's type,
             private and info. This method is called before scanning the
             extension's constructors.
             @return true if the extension's constructors must be scanned.*)
@@ -956,7 +956,7 @@ module Scan :
           @return true if the class elements must be scanned.*)
         method scan_class_pre : Class.t_class -> bool
 
-       (** This method scan the elements of the given class. *)
+       (** This method scans the elements of the given class. *)
         method scan_class_elements : Class.t_class -> unit
 
        (** Scan of a class. Should not be overridden. It calls [scan_class_pre]
@@ -973,7 +973,7 @@ module Scan :
            @return true if the class type elements must be scanned.*)
         method scan_class_type_pre : Class.t_class_type -> bool
 
-        (** This method scan the elements of the given class type. *)
+        (** This method scans the elements of the given class type. *)
         method scan_class_type_elements : Class.t_class_type -> unit
 
         (** Scan of a class type. Should not be overridden. It calls [scan_class_type_pre]
@@ -990,7 +990,7 @@ module Scan :
            @return true if the module elements must be scanned.*)
         method scan_module_pre : Module.t_module -> bool
 
-        (** This method scan the elements of the given module. *)
+        (** This method scans the elements of the given module. *)
         method scan_module_elements : Module.t_module -> unit
 
        (** Scan of a module. Should not be overridden. It calls [scan_module_pre]
@@ -1007,7 +1007,7 @@ module Scan :
            @return true if the module type elements must be scanned. *)
         method scan_module_type_pre : Module.t_module_type -> bool
 
-        (** This method scan the elements of the given module type. *)
+        (** This method scans the elements of the given module type. *)
         method scan_module_type_elements : Module.t_module_type -> unit
 
         (** Scan of a module type. Should not be overridden. It calls [scan_module_type_pre]
@@ -1024,7 +1024,7 @@ module Scan :
 (** Computation of dependencies. *)
 module Dep :
   sig
-    (** Modify the modules depencies of the given list of modules,
+    (** Modify the module dependencies of the given list of modules,
        to get the minimum transitivity kernel. *)
     val kernel_deps_of_modules : Module.t_module list -> unit
 
@@ -1036,7 +1036,7 @@ module Dep :
     val deps_of_types : ?kernel: bool -> Type.t_type list -> (Type.t_type * (Name.t list)) list
   end
 
-(** {2 Some global variables} *)
+(** {1 Some global variables} *)
 
 module Global :
   sig

diff --git a/ocamldoc/odoc_latex.ml b/ocamldoc/odoc_latex.ml
index c9292b8470593c04681128b841a0cb3636911ecd..1c6075e8a4d3c6da347c0569c38fe31c1f43ff95 100644 (file)
--- a/ocamldoc/odoc_latex.ml
+++ b/ocamldoc/odoc_latex.ml
@@ -30,6 +30,7 @@ open Module
 let separate_files = ref false
 
 let latex_titles = ref [
+  0, "section" ;
   1, "section" ;
   2, "subsection" ;
   3, "subsubsection" ;
@@ -90,7 +91,7 @@ let print_concat fmt sep f =
 (** Generation of LaTeX code from text structures. *)
 class text =
   object (self)
-    (** Return latex code to make a sectionning according to the given level,
+    (** Return latex code to make a section according to the given level,
        and with the given latex code. *)
     method section_style level s =
       try
@@ -108,19 +109,6 @@ class text =
         "}", "\\\\}";
         "\\$", "\\\\$";
         "\\^", "{\\\\textasciicircum}";
-        "\xE0", "\\\\`a";
-        "\xE2", "\\\\^a";
-        "\xE9", "\\\\'e";
-        "\xE8", "\\\\`e";
-        "\xEA", "\\\\^e";
-        "\xEB", "\\\\\"e";
-        "\xE7", "\\\\c{c}";
-        "\xF4", "\\\\^o";
-        "\xF6", "\\\\\"o";
-        "\xEE", "\\\\^i";
-        "\xEF", "\\\\\"i";
-        "\xF9", "\\\\`u";
-        "\xFB", "\\\\^u";
         "%", "\\\\%";
         "_", "\\\\_";
         "~", "\\\\~{}";
@@ -460,7 +448,7 @@ class virtual info =
     (** The method used to get LaTeX code from a [text]. *)
     method virtual latex_of_text : Format.formatter -> Odoc_info.text -> unit
 
-    (** The method used to get a [text] from an optionel info structure. *)
+    (** The method used to get a [text] from an optional info structure. *)
     method virtual text_of_info : ?block: bool -> Odoc_info.info option -> Odoc_info.text
 
     (** Print LaTeX code for a description, except for the [i_params] field. *)
@@ -757,6 +745,7 @@ class latex =
                 );
               [CodePre (flush2 ())]
         in
+        Latex ( self#make_label (self#exception_label e.ex_name) ) ::
        merge_codepre (l @ s ) @
       [Latex ("\\index{"^(self#label s_name)^"@\\verb`"^(self#label ~no_:false s_name)^"`}\n")]
        @ (self#text_of_info e.ex_info) in
@@ -817,7 +806,7 @@ class latex =
           self#latex_of_module_kind fmt father k2;
           self#latex_of_text fmt [Code ")"]
       | Module_with (k, s) ->
-          (* TODO: modify when Module_with will be more detailled *)
+          (* TODO: modify when Module_with will be more detailed *)
           self#latex_of_module_type_kind fmt father k;
           self#latex_of_text fmt
             [ Code " ";
@@ -1076,7 +1065,7 @@ class latex =
       in
       self#latex_of_text fmt t;
       self#latex_of_class_parameter_list fmt father c;
-      (* avoid a big gap if the kind is a consrt *)
+      (* avoid a big gap if the kind is a constr *)
       (
        match c.cl_kind with
          Class.Class_constr _ ->
@@ -1218,7 +1207,7 @@ class latex =
         let subtitle = match first_t with
           | [] -> []
           | t -> (Raw " : ") :: t in
-        [ Title (1, None, title @ subtitle ) ]
+        [ Title (0, None, title @ subtitle ) ]
       in
       self#latex_of_text fmt text;
       self#latex_for_module_label fmt m;
@@ -1268,7 +1257,7 @@ class latex =
       )
 
 
-    (** Generate the LaTeX style file, if it does not exists. *)
+    (** Generate the LaTeX style file, if it does not exist. *)
     method generate_style_file =
       try
         let dir = Filename.dirname !Global.out_file in
@@ -1325,7 +1314,7 @@ class latex =
               self#generate_for_top_module fmt m
           )
           module_list ;
-        if !Global.with_trailer then ps fmt "\\end{document}";
+        if !Global.with_trailer then ps fmt "\\end{document}\n";
         Format.pp_print_flush fmt ();
         close_out chanout
       with

diff --git a/ocamldoc/odoc_man.ml b/ocamldoc/odoc_man.ml
index a640d767a50ec11025908d933936e098c46016be..9a4d3f1ca1d8246c09e294e98090aaf032ccace5 100644 (file)
--- a/ocamldoc/odoc_man.ml
+++ b/ocamldoc/odoc_man.ml
@@ -874,7 +874,7 @@ class man =
         let b = new_buf () in
         bs b (".TH \""^cl.cl_name^"\" ");
         bs b !man_section ;
-        bs b (" source: "^Odoc_misc.current_date^" ");
+        bs b (" "^Odoc_misc.current_date^" ");
         bs b "OCamldoc ";
         bs b ("\""^(match !Global.title with Some t -> t | None -> "")^"\"\n");
 
@@ -932,7 +932,7 @@ class man =
         let b = new_buf () in
         bs b (".TH \""^ct.clt_name^"\" ");
         bs b !man_section ;
-        bs b (" source: "^Odoc_misc.current_date^" ");
+        bs b (" "^Odoc_misc.current_date^" ");
         bs b "OCamldoc ";
         bs b ("\""^(match !Global.title with Some t -> t | None -> "")^"\"\n");
 
@@ -1024,7 +1024,7 @@ class man =
         let b = new_buf () in
         bs b (".TH \""^mt.mt_name^"\" ");
         bs b !man_section ;
-        bs b (" source: "^Odoc_misc.current_date^" ");
+        bs b (" "^Odoc_misc.current_date^" ");
         bs b "OCamldoc ";
         bs b ("\""^(match !Global.title with Some t -> t | None -> "")^"\"\n");
 
@@ -1106,7 +1106,7 @@ class man =
         let b = new_buf () in
         bs b (".TH \""^m.m_name^"\" ");
         bs b !man_section ;
-        bs b (" source: "^Odoc_misc.current_date^" ");
+        bs b (" "^Odoc_misc.current_date^" ");
         bs b "OCamldoc ";
         bs b ("\""^(match !Global.title with Some t -> t | None -> "")^"\"\n");
 
@@ -1212,7 +1212,7 @@ class man =
         let b = new_buf () in
         bs b (".TH \""^name^"\" ");
         bs b !man_section ;
-        bs b (" source: "^Odoc_misc.current_date^" ");
+        bs b (" "^Odoc_misc.current_date^" ");
         bs b "OCamldoc ";
         bs b ("\""^(match !Global.title with Some t -> t | None -> "")^"\"\n");
         bs b ".SH NAME\n";
@@ -1283,7 +1283,7 @@ class man =
               self#man_of_module_type_body b mt
 
           | Res_section _ ->
-              (* normaly, we cannot have modules here. *)
+              (* normally, we cannot have modules here. *)
               ()
         in
         List.iter f l;

diff --git a/ocamldoc/odoc_merge.ml b/ocamldoc/odoc_merge.ml
index 4f1bbff7b6dae6792a144b2c9d41335cc38e6366..7f9434db226c4fe396399e95926518640fd2289b 100644 (file)
--- a/ocamldoc/odoc_merge.ml
+++ b/ocamldoc/odoc_merge.ml
@@ -46,7 +46,7 @@ let merge_before_tags l =
 
 let version_separators = Str.regexp "[\\.\\+]";;
 
-(** Merge two Odoctypes.info struture, completing the information of
+(** Merge two Odoctypes.info structures, completing the information of
    the first one with the information in the second one.
    The merge treatment depends on a given merge_option list.
    @return the new info structure.*)
@@ -355,7 +355,7 @@ let rec merge_param_info pi_mli pi_ml =
         Tuple (new_l, t_mli)
 
 (** Merge of the parameters of two functions/methods/classes, one for a .mli, another for a .ml.
-   The prameters in the .mli are completed by the name in the .ml.*)
+   The parameters in the .mli are completed by the name in the .ml.*)
 let rec merge_parameters param_mli param_ml =
   match (param_mli, param_ml) with
     ([], []) -> []
@@ -370,8 +370,8 @@ let merge_classes merge_options mli ml =
   mli.cl_loc <- { mli.cl_loc with loc_impl = ml.cl_loc.loc_impl } ;
   mli.cl_parameters <- merge_parameters mli.cl_parameters ml.cl_parameters;
 
-  (* we must reassociate comments in @param to the the corresponding
-     parameters because the associated comment of a parameter may have been changed y the merge.*)
+  (* we must reassociate comments in @param to the corresponding
+     parameters because the associated comment of a parameter may have been changed by the merge.*)
   Odoc_class.class_update_parameters_text mli;
 
   (* merge values *)
@@ -499,8 +499,8 @@ let merge_class_types merge_options mli ml =
                      m.met_value.val_parameters <- (merge_parameters
                                                       m.met_value.val_parameters
                                                       m2.met_value.val_parameters) ;
-                     (* we must reassociate comments in @param to the the corresponding
-                        parameters because the associated comment of a parameter may have been changed y the merge.*)
+                     (* we must reassociate comments in @param to the corresponding
+                        parameters because the associated comment of a parameter may have been changed by the merge.*)
                      Odoc_value.update_value_parameters_text m.met_value;
 
                      if !Odoc_global.keep_code then
@@ -690,8 +690,8 @@ let rec merge_module_types merge_options mli ml =
                      v.val_parameters <- (merge_parameters
                                             v.val_parameters
                                             v2.val_parameters) ;
-                     (* we must reassociate comments in @param to the the corresponding
-                        parameters because the associated comment of a parameter may have been changed y the merge.*)
+                     (* we must reassociate comments in @param to the corresponding
+                        parameters because the associated comment of a parameter may have been changed by the merge.*)
                      Odoc_value.update_value_parameters_text v;
 
                      if !Odoc_global.keep_code then
@@ -963,8 +963,8 @@ and merge_modules merge_options mli ml =
                  v.val_parameters <- (merge_parameters
                                         v.val_parameters
                                         v2.val_parameters) ;
-                 (* we must reassociate comments in @param to the the corresponding
-                    parameters because the associated comment of a parameter may have been changed y the merge.*)
+                 (* we must reassociate comments in @param to the corresponding
+                    parameters because the associated comment of a parameter may have been changed by the merge.*)
                  Odoc_value.update_value_parameters_text v;
 
                  if !Odoc_global.keep_code then

diff --git a/ocamldoc/odoc_messages.ml b/ocamldoc/odoc_messages.ml
index c46198861da47bf7d97ba0dfc89cfde44c6f2639..6e14f11634222a722b2711d6986b5deaddee320a 100644 (file)
--- a/ocamldoc/odoc_messages.ml
+++ b/ocamldoc/odoc_messages.ml
@@ -203,6 +203,14 @@ let merge_all = ('A', "merge all")
 
 let no_index = " Do not build index for Info files "^texi_only
 let esc_8bits = " Escape accentuated characters in Info files "^texi_only
+let texinfo_title r=
+  "n,style Associate {n } to the given sectionning style\n"^
+  "\t\t(e.g. 'section') in the texInfo output "^texi_only^"\n"^
+  "\t\tDefault sectionning is:\n\t\t"^
+  (String.concat "\n\t\t"
+     (List.map (fun (n,(t,h)) ->
+          Printf.sprintf " %d -> %s, %s " n t h) !r))
+
 let info_section = " Specify section of Info directory "^texi_only
 let info_entry = " Specify Info directory entry "^texi_only
 

diff --git a/ocamldoc/odoc_misc.mli b/ocamldoc/odoc_misc.mli
index 03918f8aa501d0bef2b60ad87d6c863c08524873..8b848158fabcc47bcf1150a1aa3d3f77c9ea8336 100644 (file)
--- a/ocamldoc/odoc_misc.mli
+++ b/ocamldoc/odoc_misc.mli
@@ -64,7 +64,7 @@ val string_of_info : Odoc_types.info -> string
 val apply_opt : ('a -> 'b) -> 'a option -> 'b option
 
 (** Return a string representing a date given as a number of seconds
-   since 1970. The hour is optionnaly displayed. *)
+   since 1970. The hour is optionally displayed. *)
 val string_of_date : ?absolute:bool -> ?hour:bool -> float -> string
 
 (* Value returned by string_of_date for current time.
@@ -110,7 +110,7 @@ val remove_ending_newline : string -> string
 val search_string_backward : pat: string -> s: string -> int
 
 (** Take a type and remove the option top constructor. This is
-   useful when printing labels, we we then remove the top option contructor
+   useful when printing labels, we then remove the top option constructor
    for optional labels.*)
 val remove_option : Types.type_expr -> Types.type_expr
 

diff --git a/ocamldoc/odoc_module.ml b/ocamldoc/odoc_module.ml
index afd31020ebf12262264296ce57494106793480a0..790a812d546c7a3e306629c247fac0e88492890c 100644 (file)
--- a/ocamldoc/odoc_module.ml
+++ b/ocamldoc/odoc_module.ml
@@ -40,7 +40,7 @@ and mmt =
 and included_module = {
     im_name : Name.t ; (** the name of the included module *)
     mutable im_module : mmt option ; (** the included module or module type *)
-    mutable im_info : Odoc_types.info option ; (** comment associated to the includ directive *)
+    mutable im_info : Odoc_types.info option ; (** comment associated to the include directive *)
   }
 
 and module_alias = {
@@ -107,7 +107,7 @@ and t_module_type = {
   }
 
 
-(** {2 Functions} *)
+(** {1 Functions} *)
 
 (** Returns the list of values from a list of module_element. *)
 let values l =
@@ -442,7 +442,7 @@ and module_parameters ?(trans=true) m =
   in
   iter m.m_kind
 
-(** access to all submodules and sudmobules of submodules ... of the given module.
+(** access to all submodules and submodules of submodules ... of the given module.
   @param trans indicates if, for aliased modules, we must perform a transitive search.*)
 let rec module_all_submodules ?(trans=true) m =
   let l = module_modules ~trans m in
@@ -451,7 +451,7 @@ let rec module_all_submodules ?(trans=true) m =
     l
     l
 
-(** The module type is a functor if is defined as a functor or if it is an alias for a functor. *)
+(** The module type is a functor if it is defined as a functor or if it is an alias for a functor. *)
 let rec module_type_is_functor mt =
   let rec iter k =
     match k with
@@ -470,7 +470,7 @@ let rec module_type_is_functor mt =
   in
   iter mt.mt_kind
 
-(** The module is a functor if is defined as a functor or if it is an alias for a functor. *)
+(** The module is a functor if it is defined as a functor or if it is an alias for a functor. *)
 let module_is_functor m =
   let rec iter visited = function
       Module_functor _ -> true
@@ -543,7 +543,7 @@ let module_type_simple_values ?(trans=true) mt =
     (fun v -> not (Odoc_value.is_function v))
     (values (module_type_elements ~trans mt))
 
-(** {2 Functions for modules and module types} *)
+(** {1 Functions for modules and module types} *)
 
 (** The list of classes defined in this module and all its modules, functors, ....
   @param trans indicates if, for aliased modules, we must perform a transitive search.*)

diff --git a/ocamldoc/odoc_name.ml b/ocamldoc/odoc_name.ml
index df8a78605000c6319457f9c78d3cd246b7a31c34..6ed5363d3a7200a5e3c7a13c9097d8e21a3cfe36 100644 (file)
--- a/ocamldoc/odoc_name.ml
+++ b/ocamldoc/odoc_name.ml
@@ -219,8 +219,4 @@ let to_path n =
 
 let from_longident = Odoc_misc.string_of_longident
 
-module Set = Set.Make (struct
-  type z = t
-  type t = z
-  let compare = String.compare
-end)
+module Map = Map.Make(String)

diff --git a/ocamldoc/odoc_name.mli b/ocamldoc/odoc_name.mli
index 2ca47a804c7ea8df9951cead41d683cd19fabab2..ac2bc0d3ed9e78439779c13284ea00f9cb14bc5f 100644 (file)
--- a/ocamldoc/odoc_name.mli
+++ b/ocamldoc/odoc_name.mli
@@ -36,12 +36,12 @@ val normalize_name : t -> t
 (** Returns the head of a name. *)
 val head : t -> t
 
-(** Returns the depth of the name, i.e. the numer of levels to the root.
+(** Returns the depth of the name, i.e. the number of levels to the root.
    Example : [Toto.Tutu.name] has depth 3. *)
 val depth : t -> int
 
 (** Returns true if the first name is a prefix of the second name.
-   If the two names are equals, then if is false (strict prefix).*)
+   If the two names are equal, then it is false (strict prefix).*)
 val prefix : t -> t -> bool
 
 (** Take two names n1 and n2 = n3.n4 and return n4 if n3=n1 or else n2. *)
@@ -70,5 +70,4 @@ val to_path : t -> Path.t
 (** Get a name from a [Longident.t].*)
 val from_longident : Longident.t -> t
 
-(** Set of Name.t *)
-module Set : Set.S with type elt = t
+module Map : Map.S with type key = t

diff --git a/ocamldoc/odoc_parameter.ml b/ocamldoc/odoc_parameter.ml
index 6775b88494138071fea47c3b00be26683c5d6774..32aa0decea604e27797bc856211e3d133b9a9386 100644 (file)
--- a/ocamldoc/odoc_parameter.ml
+++ b/ocamldoc/odoc_parameter.ml
@@ -37,7 +37,7 @@ type parameter = param_info
 
 (** Functions *)
 
-(** acces to the name as a string. For tuples, parenthesis and commas are added. *)
+(** access to the name as a string. For tuples, parentheses and commas are added. *)
 let complete_name p =
   let rec iter pi =
     match pi with
@@ -82,7 +82,7 @@ let desc_by_name pi name =
   List.assoc name l
 
 
-(** acces to the list of names ; only one for a simple parameter, or
+(** access to the list of names ; only one for a simple parameter, or
    a list for tuples. *)
 let names pi =
   let rec iter acc pi =

diff --git a/ocamldoc/odoc_parser.mly b/ocamldoc/odoc_parser.mly
index 9c762b1d24e8a56037c8669399cc6e8a3da51ac6..f27a9982fed61a9774039b1b4ee8adf02d1d43d1 100644 (file)
--- a/ocamldoc/odoc_parser.mly
+++ b/ocamldoc/odoc_parser.mly
@@ -147,7 +147,7 @@ deprecated:
 raise_exc:
     T_RAISES Desc
     {
-      (* isolate the exception construtor name *)
+      (* isolate the exception constructor name *)
       let s = $2 in
       match Str.split (Str.regexp (blank^"+")) s with
         []

diff --git a/ocamldoc/odoc_print.ml b/ocamldoc/odoc_print.ml
index c07e7841f6b1eea6010ca787ab207102b8f30561..e729fe3593c014927cb727e98ad231a00710a159 100644 (file)
--- a/ocamldoc/odoc_print.ml
+++ b/ocamldoc/odoc_print.ml
@@ -46,8 +46,8 @@ exception Use_code of string
 
 (** Return the given module type where methods and vals have been removed
    from the signatures. Used when we don't want to print a too long module type.
-   @param code when the code is given, we raise the [Use_code] exception is we
-   encouter a signature, to that the calling function can use the code rather
+   @param code when the code is given, we raise the [Use_code] exception if we
+   encounter a signature, so that the calling function can use the code rather
    than the "emptied" type.
 *)
 let simpl_module_type ?code t =

diff --git a/ocamldoc/odoc_print.mli b/ocamldoc/odoc_print.mli
index f56d541e8285c256c48a305a8d91202d00f13da0..e288fffb434208a472aceff943ccc847fae8f869 100644 (file)
--- a/ocamldoc/odoc_print.mli
+++ b/ocamldoc/odoc_print.mli
@@ -21,7 +21,7 @@ val string_of_type_expr : Types.type_expr -> string
 
 (** This function returns a string representing a [Types.module_type].
    @param complete indicates if we must print complete signatures
-   or just [sig end]. Default if [false].
+   or just [sig end]. Default is [false].
    @param code if [complete = false] and the type contains something else
    than identificators and functors, then the given code is used.
 *)
@@ -29,6 +29,6 @@ val string_of_module_type : ?code: string -> ?complete: bool -> Types.module_typ
 
 (** This function returns a string representing a [Types.class_type].
    @param complete indicates if we must print complete signatures
-   or just [object end]. Default if [false].
+   or just [object end]. Default is [false].
 *)
 val string_of_class_type : ?complete: bool -> Types.class_type -> string

diff --git a/ocamldoc/odoc_scan.ml b/ocamldoc/odoc_scan.ml
index 7b5ba5dd494e7ce21d86b6820fe6401bc5614ac5..50850d117a2fe977c9fe78cc173929bec49e17d4 100644 (file)
--- a/ocamldoc/odoc_scan.ml
+++ b/ocamldoc/odoc_scan.ml
@@ -50,7 +50,7 @@ class scanner =
 
   (** Scan of a type extension *)
 
-    (** Overide this method to perform controls on the extension's type,
+    (** Override this method to perform controls on the extension's type,
         private and info. This method is called before scanning the
         extensions's constructors.
         @return true if the extension's constructors must be scanned.*)
@@ -76,7 +76,7 @@ class scanner =
        @return true if the class elements must be scanned.*)
     method scan_class_pre (_ : Odoc_class.t_class) = true
 
-    (** This method scan the elements of the given class.
+    (** This method scans the elements of the given class.
        A VOIR : scan des classes heritees.*)
     method scan_class_elements c =
       List.iter
@@ -102,7 +102,7 @@ class scanner =
        @return true if the class type elements must be scanned.*)
     method scan_class_type_pre (_ : Odoc_class.t_class_type) = true
 
-    (** This method scan the elements of the given class type.
+    (** This method scans the elements of the given class type.
        A VOIR : scan des classes heritees.*)
     method scan_class_type_elements ct =
       List.iter
@@ -128,7 +128,7 @@ class scanner =
        @return true if the module elements must be scanned.*)
     method scan_module_pre (_ : Odoc_module.t_module) = true
 
-    (** This method scan the elements of the given module. *)
+    (** This method scans the elements of the given module. *)
     method scan_module_elements m =
       List.iter
         (fun ele ->
@@ -160,7 +160,7 @@ class scanner =
        @return true if the module type elements must be scanned. *)
     method scan_module_type_pre (_ : Odoc_module.t_module_type) = true
 
-    (** This method scan the elements of the given module type. *)
+    (** This method scans the elements of the given module type. *)
     method scan_module_type_elements mt =
       List.iter
         (fun ele ->

diff --git a/ocamldoc/odoc_sig.ml b/ocamldoc/odoc_sig.ml
index 5bc67b8016d88614f076d57f5977cf1caa50e0ba..f7d8e4285a5932412a9c8c8c2c42254fd449ad30 100644 (file)
--- a/ocamldoc/odoc_sig.ml
+++ b/ocamldoc/odoc_sig.ml
@@ -131,7 +131,7 @@ module Analyser =
     (** The name of the analysed file. *)
     let file_name = ref ""
 
-    (** This function takes two indexes (start and end) and return the string
+    (** This function takes two indexes (start and end) and returns the string
        corresponding to the indexes in the file global variable. The function
        prepare_file must have been called to fill the file global variable.*)
     let get_string_of_file the_start the_end =
@@ -185,6 +185,14 @@ module Analyser =
         !file_name
         (get_string_of_file pos_start pos_end)
 
+    let preamble filename file proj ast =
+      let info = My_ir.first_special filename file in
+      (* Only use as module preamble documentation comments that occur before
+           any module elements *)
+      match ast with
+      | a :: _ when  Loc.start (proj a) < fst info -> (0,None)
+      | _ -> info
+
     let merge_infos = Odoc_merge.merge_info_opt Odoc_types.all_merge_options
 
     (** Module for extracting documentation comments for record from different
@@ -245,7 +253,7 @@ module Analyser =
         end_ =  (fun ld -> Loc.start ld.ld_loc);
         (* Beware, Loc.start is correct in the code above:
            type_expr's do not hold location information, and ld.ld_loc
-           ends after the documentation comment, sow e use Loc.start as
+           ends after the documentation comment, so we use Loc.start as
            the least problematic approximation for end_. *)
         inline_record = begin
           fun c -> match c.cd_args with
@@ -282,23 +290,24 @@ module Analyser =
           | Ptyp_object (fields, _) ->
             let rec f = function
               | [] -> []
-              | ({txt=""},_,_) :: _ ->
+              | Otag ({txt=""},_,_) :: _ ->
                 (* Fields with no name have been eliminated previously. *)
                 assert false
-
-              | ({txt=name}, _atts, ct) :: [] ->
+              | Otag ({txt=name}, _atts, ct) :: [] ->
                 let pos = Loc.ptyp_end ct in
                 let (_,comment_opt) = just_after_special pos pos_end in
                 [name, comment_opt]
-              | ({txt=name}, _atts, ct) :: ((_name2, _atts2, ct2) as ele2) :: q ->
+              | Otag ({txt=name}, _, ct) ::
+                  ((Oinherit ct2 | Otag (_, _, ct2)) as ele2) :: q ->
                 let pos = Loc.ptyp_end ct in
                 let pos2 = Loc.ptyp_start ct2 in
                 let (_,comment_opt) = just_after_special pos pos2 in
                 (name, comment_opt) :: (f (ele2 :: q))
+              | _ :: q -> f q
             in
             let is_named_field field =
               match field with
-              | ({txt=""},_,_) -> false
+              | Otag ({txt=""},_,_) -> false
               | _ -> true
             in
             (0, f @@ List.filter is_named_field fields)
@@ -413,17 +422,57 @@ module Analyser =
           let comments = Record.(doc typedtree) pos_end l in
           Odoc_type.Cstr_record (List.map (record comments) l)
 
+    (* Given a constraint "with type M.N.t := foo", this function adds "M" ->
+       "with type N.t := foo" to acc, ie it build the constraint to put on the
+       first element of the path being modified.
+       When filter_out_erased_items_from_signature finds "M", it applies the
+       constraint on its module type. *)
+    let constraint_for_subitem =
+      let split_longident p =
+        match Longident.flatten p with
+        | [] -> assert false
+        | hd :: tl -> hd, Longident.unflatten tl
+      in
+      fun acc s rebuild_constraint ->
+        match split_longident s.txt with
+        | hd, None -> Name.Map.add hd `Removed acc
+        | hd, Some p ->
+           let constraint_ = rebuild_constraint { s with txt = p } in
+           match Name.Map.find hd acc with
+           | exception Not_found ->
+              Name.Map.add hd (`Constrained [constraint_]) acc
+           | `Constrained old ->
+              Name.Map.add hd (`Constrained (constraint_ :: old)) acc
+           | `Removed -> acc
+
     let erased_names_of_constraints constraints acc =
       List.fold_right (fun constraint_ acc ->
         match constraint_ with
         | Parsetree.Pwith_type _ | Parsetree.Pwith_module _ -> acc
-        | Parsetree.Pwith_typesubst {Parsetree.ptype_name=s}
-        | Parsetree.Pwith_modsubst (s, _) ->
-          Name.Set.add s.txt acc)
+        | Parsetree.Pwith_typesubst (s, typedecl) ->
+           constraint_for_subitem acc s (fun s -> Parsetree.Pwith_typesubst (s, typedecl))
+        | Parsetree.Pwith_modsubst (s, modpath) ->
+           constraint_for_subitem acc s (fun s -> Parsetree.Pwith_modsubst (s, modpath)))
         constraints acc
 
+    let is_erased ident map =
+      match Name.Map.find ident map with
+      | exception Not_found -> false
+      | `Removed -> true
+      | `Constrained _ -> false
+
+    let apply_constraint module_type constraints  =
+      match module_type.Parsetree.pmty_desc with
+      | Parsetree.Pmty_alias _ -> module_type
+      | _ ->
+         { Parsetree.
+           pmty_desc = Parsetree.Pmty_with (module_type, List.rev constraints);
+           pmty_loc = module_type.Parsetree.pmty_loc;
+           pmty_attributes = []
+         }
+
     let filter_out_erased_items_from_signature erased signature =
-      if Name.Set.is_empty erased then signature
+      if Name.Map.is_empty erased then signature
       else List.fold_right (fun sig_item acc ->
         let take_item psig_desc = { sig_item with Parsetree.psig_desc } :: acc in
         match sig_item.Parsetree.psig_desc with
@@ -437,14 +486,24 @@ module Analyser =
         | Parsetree.Psig_class _
         | Parsetree.Psig_class_type _ as tp -> take_item tp
         | Parsetree.Psig_type (rf, types) ->
-          (match List.filter (fun td -> not (Name.Set.mem td.Parsetree.ptype_name.txt erased)) types with
+          (match List.filter (fun td -> not (is_erased td.Parsetree.ptype_name.txt erased)) types with
           | [] -> acc
           | types -> take_item (Parsetree.Psig_type (rf, types)))
-        | Parsetree.Psig_module {Parsetree.pmd_name=name}
+        | Parsetree.Psig_module ({Parsetree.pmd_name=name;
+                                  pmd_type=module_type} as r) as m ->
+           begin match Name.Map.find name.txt erased with
+           | exception Not_found -> take_item m
+           | `Removed -> acc
+           | `Constrained constraints ->
+              take_item
+                (Parsetree.Psig_module
+                   { r with Parsetree.pmd_type =
+                       apply_constraint module_type constraints })
+           end
         | Parsetree.Psig_modtype {Parsetree.pmtd_name=name} as m ->
-          if Name.Set.mem name.txt erased then acc else take_item m
+          if is_erased name.txt erased then acc else take_item m
         | Parsetree.Psig_recmodule mods ->
-          (match List.filter (fun pmd -> not (Name.Set.mem pmd.Parsetree.pmd_name.txt erased)) mods with
+          (match List.filter (fun pmd -> not (is_erased pmd.Parsetree.pmd_name.txt erased)) mods with
           | [] -> acc
           | mods -> take_item (Parsetree.Psig_recmodule mods)))
         signature []
@@ -606,6 +665,7 @@ module Analyser =
                     ic_text = text_opt ;
                   }
 
+              | Parsetree.Pcty_open _ (* one could also traverse the open *)
               | Parsetree.Pcty_signature _
               | Parsetree.Pcty_arrow _ ->
                     (* we don't have a name for the class signature, so we call it "object ... end"  *)
@@ -968,7 +1028,7 @@ module Analyser =
 
         | Parsetree.Psig_module {Parsetree.pmd_name=name; pmd_type=module_type} ->
             let complete_name = Name.concat current_module_name name.txt in
-            (* get the the module type in the signature by the module name *)
+            (* get the module type in the signature by the module name *)
             let sig_module_type =
               try Signature_search.search_module table name.txt
               with Not_found ->
@@ -1007,7 +1067,7 @@ module Analyser =
             new_module.m_info <- merge_infos new_module.m_info info_after_opt ;
             let new_env = Odoc_env.add_module env new_module.m_name in
             let new_env2 =
-              match new_module.m_type with (* FIXME : can this be a Tmty_ident? in this case, we would'nt have the signature *)
+              match new_module.m_type with (* FIXME : can this be a Tmty_ident? in this case, we wouldn't have the signature *)
                 Types.Mty_signature s -> Odoc_env.add_signature new_env new_module.m_name ~rel: (Name.simple new_module.m_name) s
               | _ -> new_env
             in
@@ -1027,7 +1087,7 @@ module Analyser =
                       raise (Failure (Odoc_messages.module_not_found current_module_name name))
                   in
                   match sig_module_type with
-                    (* FIXME : can this be a Tmty_ident? in this case, we would'nt have the signature *)
+                    (* FIXME : can this be a Tmty_ident? in this case, we wouldn't have the signature *)
                     Types.Mty_signature s ->
                       Odoc_env.add_signature e complete_name ~rel: name s
                   | _ ->
@@ -1142,7 +1202,7 @@ module Analyser =
             mt.mt_info <- merge_infos mt.mt_info info_after_opt ;
             let new_env = Odoc_env.add_module_type env mt.mt_name in
             let new_env2 =
-              match sig_mtype with (* FIXME : can this be a Tmty_ident? in this case, we would'nt have the signature *)
+              match sig_mtype with (* FIXME : can this be a Tmty_ident? in this case, we wouldn't have the signature *)
                 Some (Types.Mty_signature s) -> Odoc_env.add_signature new_env mt.mt_name ~rel: (Name.simple mt.mt_name) s
               | _ -> new_env
             in
@@ -1326,7 +1386,7 @@ module Analyser =
 
     (** Return a module_type_kind from a Parsetree.module_type and a Types.module_type *)
     and analyse_module_type_kind
-      ?(erased = Name.Set.empty) env current_module_name module_type sig_module_type =
+      ?(erased = Name.Map.empty) env current_module_name module_type sig_module_type =
       match module_type.Parsetree.pmty_desc with
         Parsetree.Pmty_ident longident ->
           let name =
@@ -1422,7 +1482,7 @@ module Analyser =
 
     (** analyse of a Parsetree.module_type and a Types.module_type.*)
     and analyse_module_kind
-        ?(erased = Name.Set.empty) env current_module_name module_type sig_module_type =
+        ?(erased = Name.Map.empty) env current_module_name module_type sig_module_type =
       match module_type.Parsetree.pmty_desc with
       | Parsetree.Pmty_ident _longident ->
           let k = analyse_module_type_kind env current_module_name module_type sig_module_type in
@@ -1492,7 +1552,7 @@ module Analyser =
                raise (Failure "Parsetree.Pmty_functor _ but not Types.Mty_functor _")
           )
       | Parsetree.Pmty_with (module_type2, constraints) ->
-          (*of module_type * (Longident.t * with_constraint) list*)
+          (* of module_type * (Longident.t * with_constraint) list*)
           (
            let loc_start = Loc.end_ module_type2.Parsetree.pmty_loc in
            let loc_end = Loc.end_ module_type.Parsetree.pmty_loc in
@@ -1592,7 +1652,7 @@ module Analyser =
 (*
       | (Parsetree.Pcty_constr (longident, _) (*of Longident.t * core_type list *),
          Types.Cty_signature class_signature) ->
-           (* FIXME : this for the case of class contraints :
+           (* FIXME : this for the case of class constraints :
               class type cons = object
                 method m : int
               end
@@ -1624,7 +1684,8 @@ module Analyser =
       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
+      let len, info_opt = preamble !file_name !file
+          (fun x -> x.Parsetree.psig_loc) ast in
       let elements =
         analyse_parsetree Odoc_env.empty signat mod_name len (String.length !file) ast
       in

diff --git a/ocamldoc/odoc_sig.mli b/ocamldoc/odoc_sig.mli
index b53189873d69bc31d3917634dfe5b35cd668c2fe..ac26bc8b49f486c948fc35f56560c9664cfa25a8 100644 (file)
--- a/ocamldoc/odoc_sig.mli
+++ b/ocamldoc/odoc_sig.mli
@@ -118,7 +118,7 @@ module Analyser :
       (** The name of the analysed file. *)
       val file_name : string ref
 
-      (** This function takes two indexes (start and end) and return the string
+      (** This function takes two indexes (start and end) and returns the string
          corresponding to the indexes in the file global variable. The function
          prepare_file must have been called to fill the file global variable.*)
       val get_string_of_file : int -> int -> string
@@ -127,6 +127,15 @@ module Analyser :
          [input_f] into [file].*)
       val prepare_file : string -> string -> unit
 
+      (** [preamble f input_f loc ast ] retrieves the position and contents of
+          the preamble for the file [f]: i.e, the first documentation comment
+          before any elements in [ast].
+          If there is no such preamble, [0,None] is returned.
+          The function [loc] is used to obtain the location of this
+          first element of [ast].*)
+      val preamble: string -> string -> ('a -> Location.t) -> 'a list
+        -> int * Odoc_types.info option
+
       (** The function used to get the comments in a class. *)
       val get_comments_in_class : int -> int ->
         (Odoc_types.info option * Odoc_class.class_element list)
@@ -141,12 +150,12 @@ module Analyser :
          or an empty list for an abstract type.
          [pos_end] is last char of the complete type definition.
          [pos_limit] is the position of the last char we could use to look for a comment,
-         i.e. usually the beginning on the next element.*)
+         i.e. usually the beginning of the next element.*)
       val name_comment_from_type_decl :
           int -> int -> Parsetree.type_declaration -> int * (string * Odoc_types.info option) list
 
       (** This function converts a [Types.type_expr] into a [Odoc_type.type_kind],
-         by associating the comment found in the parstree of each object field, if any. *)
+         by associating the comment found in the parsetree of each object field, if any. *)
       val manifest_structure :
           Odoc_env.env -> (string * Odoc_types.info option) list ->
             Types.type_expr -> Odoc_type.type_manifest
@@ -164,14 +173,16 @@ module Analyser :
         Odoc_env.env -> int -> Typedtree.constructor_arguments ->
         Odoc_type.constructor_args
 
-      (** This function merge two optional info structures. *)
+      (** This function merges two optional info structures. *)
       val merge_infos :
           Odoc_types.info option -> Odoc_types.info option ->
             Odoc_types.info option
 
       (** Return a module_type_kind from a Parsetree.module_type and a Types.module_type *)
       val analyse_module_type_kind :
-          ?erased:Odoc_name.Set.t -> Odoc_env.env -> Odoc_name.t ->
+          ?erased:[ `Constrained of Parsetree.with_constraint list
+                  | `Removed ] Odoc_name.Map.t
+          -> Odoc_env.env -> Odoc_name.t ->
             Parsetree.module_type -> Types.module_type ->
               Odoc_module.module_type_kind
 
@@ -181,7 +192,7 @@ module Analyser :
         Odoc_name.t -> int -> Parsetree.class_type -> Types.class_type ->
           Odoc_class.class_type_kind
 
-      (** This function takes an interface file name, a file containg the code, a parse tree
+      (** This function takes an interface file name, a file containing the code, a parse tree
          and the signature obtained from the compiler.
          It goes through the parse tree, creating values for encountered
          functions, modules, ..., looking in the source file for comments,

diff --git a/ocamldoc/odoc_str.ml b/ocamldoc/odoc_str.ml
index 44d03db11094d12219991e4fd7d1d06cc9e83251..1189ead5ee51ce977783fa8e25a3a8c0d72de2f8 100644 (file)
--- a/ocamldoc/odoc_str.ml
+++ b/ocamldoc/odoc_str.ml
@@ -254,7 +254,7 @@ let string_of_type t =
       )
 
   | M.Type_open ->
-      "= .." (* FIXME MG: when introducing new constuctors next time,
+      "= .." (* FIXME MG: when introducing new constructors next time,
                 thanks to setup a minimal correct output *)
   | M.Type_record l ->
      P.sprintf "= %s{\n%s\n}\n" (if priv then "private " else "")

diff --git a/ocamldoc/odoc_texi.ml b/ocamldoc/odoc_texi.ml
index b52e03583ed470823914d6e4fedfd8e973c83648..22f2000b806f746656bce353efb60851b6091434 100644 (file)
--- a/ocamldoc/odoc_texi.ml
+++ b/ocamldoc/odoc_texi.ml
@@ -29,7 +29,7 @@ let info_section = ref "OCaml"
 
 let info_entry = ref []
 
-(** {2 Some small helper functions} *)
+(** {1 Some small helper functions} *)
 
 let puts_nl chan s =
   output_string chan s ;
@@ -141,7 +141,7 @@ let indices_names = [
 (** Module for generating various Texinfo things (menus, xrefs, ...) *)
 module Texi =
 struct
-  (** Associations of strings to subsitute in Texinfo code. *)
+  (** Associations of strings to substitute in Texinfo code. *)
   let subst_strings = [
     (Str.regexp "@", "@@") ;
     (Str.regexp "{", "@{") ;
@@ -240,32 +240,29 @@ end
 
 
 
-(** {2 Generation of Texinfo code} *)
+(** {1 Generation of Texinfo code} *)
 
-(** This class generates Texinfo code from text structures *)
-class text =
-  object(self)
+(** {2 Associations between a title number and texinfo code.} *)
+let titles_and_headings = ref [
+    0, ("@chapter ", "@majorheading ")  ;
+    1, ("@chapter ", "@majorheading ")  ;
+    2, ("@section ", "@heading ")  ;
+    3, ("@subsection ", "@subheading ") ;
+    4, ("@subsubsection ", "@subsubheading ")  ;
+  ]
 
-  (** Associations between a title number and texinfo code. *)
-    val titles = [
-      1, "@chapter " ;
-      2, "@section " ;
-      3, "@subsection " ;
-      4, "@subsubsection " ;
-    ]
+let title = fst
+let heading = snd
 
-    val fallback_title =
-      "@unnumberedsubsubsec "
+let fallback_title =
+  "@unnumberedsubsubsec "
 
-    val headings = [
-      1, "@majorheading " ;
-      2, "@heading " ;
-      3, "@subheading " ;
-      4, "@subsubheading " ;
-    ]
+let fallback_heading =
+  "@subsubheading "
 
-    val fallback_heading =
-      "@subsubheading "
+(** This class generates Texinfo code from text structures *)
+class text =
+  object(self)
 
     method escape =
       Texi.escape
@@ -281,7 +278,7 @@ class text =
         (List.map self#texi_of_text_element t)
 
 
-    (** {3 Conversion methods}
+    (** {2 Conversion methods}
        [texi_of_????] converts a [text_element] to a Texinfo string. *)
 
     (** Return the Texinfo code for the [text_element] in parameter. *)
@@ -350,7 +347,7 @@ class text =
         [ "@format" ; self#texi_of_text t ; "@end format" ; "" ]
     method texi_of_Title n t =
       let t_begin =
-        try List.assoc n titles
+        try title @@ List.assoc n !titles_and_headings
         with Not_found -> fallback_title in
       t_begin ^ (self#texi_of_text t) ^ "\n"
     method texi_of_Link s t =
@@ -377,7 +374,7 @@ class text =
 
     method heading n t =
       let f =
-        try List.assoc n headings
+        try heading @@ List.assoc n !titles_and_headings
         with Not_found -> fallback_heading
       in
       f ^ (self#texi_of_text t) ^ "\n"
@@ -399,7 +396,7 @@ class texi =
     inherit text
     inherit Odoc_to_text.to_text as to_text
 
-    (** {3 Small helper stuff.} *)
+    (** {2 Small helper stuff.} *)
 
     val maxdepth = 4
 
@@ -453,7 +450,7 @@ class texi =
             | Raw s -> Raw (Str.global_replace re rep s)
             | txt -> txt) t
 
-    (** {3 [text] values generation}
+    (** {2 [text] values generation}
        Generates [text] values out of description parts.
        Redefines some of methods of {! Odoc_to_text.to_text}. *)
 
@@ -565,7 +562,7 @@ class texi =
     method texi_of_info i =
       self#texi_of_text (self#text_of_info i)
 
-    (** {3 Conversion of [module_elements] into Texinfo strings}
+    (** {2 Conversion of [module_elements] into Texinfo strings}
        The following functions convert [module_elements] and their
        description to [text] values then to Texinfo strings using the
        functions above. *)
@@ -907,7 +904,7 @@ class texi =
           self#texi_of_text (Newline :: t @ [Newline])
       )
 
-    (** {3 Generating methods }
+    (** {2 Generating methods }
        These methods write Texinfo code to an [out_channel] *)
 
     (** Generate the Texinfo code for the given list of inherited classes.*)

diff --git a/ocamldoc/odoc_text_lexer.mll b/ocamldoc/odoc_text_lexer.mll
index 62f996cbac175a574a5f3de33f01ad1c8ee541a4..f503b52719d4354bb0ac45918c18bfd4b6b61526 100644 (file)
--- a/ocamldoc/odoc_text_lexer.mll
+++ b/ocamldoc/odoc_text_lexer.mll
@@ -210,7 +210,7 @@ rule main = parse
       else
         let s = Lexing.lexeme lexbuf in
         try
-          (* chech if the "{..." or html_title mark was used. *)
+          (* check if the "{..." or html_title mark was used. *)
           if s.[0] = '<' then
             let (n, l) = (2, (String.length s - 3)) in
             let s2 = String.sub s n l in

diff --git a/ocamldoc/odoc_to_text.ml b/ocamldoc/odoc_to_text.ml
index fd65051009b93591694923c339920e4e3107ca6b..b42b419e90b360283165ea3923e79c8632292c05 100644 (file)
--- a/ocamldoc/odoc_to_text.ml
+++ b/ocamldoc/odoc_to_text.ml
@@ -33,7 +33,7 @@ class virtual info =
        Add a pair here to handle a tag.*)
     val mutable tag_functions = ([] : (string * (Odoc_info.text -> Odoc_info.text)) list)
 
-    (** @return [etxt] value for an authors list. *)
+    (** @return [text] value for an authors list. *)
     method text_of_author_list l =
       match l with
         [] ->
@@ -265,7 +265,7 @@ class virtual to_text =
     method text_of_class_type_param_expr_list module_name l =
       [ Code (self#normal_class_type_param_list module_name l) ]
 
-    (** @return [text] value to represent parameters of a class (with arraows).*)
+    (** @return [text] value to represent parameters of a class (with arrows).*)
     method text_of_class_params module_name c =
       Odoc_info.text_concat
         [Newline]

diff --git a/ocamldoc/odoc_type.ml b/ocamldoc/odoc_type.ml
index 7320f550fd88afa7754668f75b5931a3606c33c1..5f4df740f963471bbbcbc83dab56853079b38061 100644 (file)
--- a/ocamldoc/odoc_type.ml
+++ b/ocamldoc/odoc_type.ml
@@ -56,7 +56,7 @@ type object_field = {
 }
 
 type type_manifest =
-  | Other of Types.type_expr (** Type manifest directly taken from Typedtre. *)
+  | Other of Types.type_expr (** Type manifest directly taken from Typedtree. *)
   | Object_type of object_field list
 
 (** Representation of a type. *)

diff --git a/ocamldoc/odoc_types.mli b/ocamldoc/odoc_types.mli
index fddd6d2f4907565003198117d8340314cfda353f..e73b26ca6b9c159ca287657bbe80c3e2b11289b5 100644 (file)
--- a/ocamldoc/odoc_types.mli
+++ b/ocamldoc/odoc_types.mli
@@ -15,7 +15,7 @@
 
 (** Types for the information collected in comments. *)
 
-(** The differents kinds of element references. *)
+(** The different kinds of element references. *)
 type ref_kind =
     RK_module
   | RK_module_type
@@ -56,7 +56,7 @@ and text_element =
   | Superscript of text (** Superscripts. *)
   | Subscript of text (** Subscripts. *)
   | Module_list of string list
-       (** The table of the given modules with their abstract; *)
+       (** The table of the given modules with their abstracts. *)
   | Index_list (** The links to the various indexes (values, types, ...) *)
   | Custom of string * text (** to extend \{foo syntax *)
   | Target of string * string (** (target, code) : to specify code for a specific target format *)
@@ -87,7 +87,7 @@ type info = {
     i_sees : see list; (** The list of \@see tags. *)
     i_since : string option; (** The string in the \@since tag. *)
     i_before : (string * text) list; (** the version number and text in \@before tag *)
-    i_deprecated : text option; (** The of the \@deprecated tag. *)
+    i_deprecated : text option; (** The textual description of the \@deprecated tag. *)
     i_params : param list; (** The list of parameter descriptions. *)
     i_raised_exceptions : raised_exception list; (** The list of raised exceptions. *)
     i_return_value : text option ; (** The description text of the return value. *)

diff --git a/ocamltest/.depend b/ocamltest/.depend
new file mode 100644 (file)
index 0000000..77a652a
--- /dev/null
+++ b/ocamltest/.depend
@@ -0,0 +1,86 @@
+run_unix.$(O): run_unix.c run.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/s.h \
+  run_common.h
+run_stubs.$(O): run_stubs.c run.h ../byterun/caml/misc.h \
+  ../byterun/caml/config.h ../byterun/caml/m.h ../byterun/caml/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/io.h \
+  ../byterun/caml/osdeps.h
+actions.cmo : environments.cmi actions.cmi
+actions.cmx : environments.cmx actions.cmi
+actions.cmi : environments.cmi
+backends.cmo : backends.cmi
+backends.cmx : backends.cmi
+backends.cmi :
+builtin_actions.cmo : variables.cmi testlib.cmi run_command.cmi \
+    ocamltest_config.cmi filetype.cmi filecompare.cmi environments.cmi \
+    builtin_variables.cmi builtin_modifiers.cmi backends.cmi actions.cmi \
+    builtin_actions.cmi
+builtin_actions.cmx : variables.cmx testlib.cmx run_command.cmx \
+    ocamltest_config.cmx filetype.cmx filecompare.cmx environments.cmx \
+    builtin_variables.cmx builtin_modifiers.cmx backends.cmx actions.cmx \
+    builtin_actions.cmi
+builtin_actions.cmi : actions.cmi
+builtin_modifiers.cmo : ocamltest_config.cmi environments.cmi \
+    builtin_variables.cmi builtin_modifiers.cmi
+builtin_modifiers.cmx : ocamltest_config.cmx environments.cmx \
+    builtin_variables.cmx builtin_modifiers.cmi
+builtin_modifiers.cmi : environments.cmi
+builtin_tests.cmo : tests.cmi ocamltest_config.cmi builtin_actions.cmi \
+    builtin_tests.cmi
+builtin_tests.cmx : tests.cmx ocamltest_config.cmx builtin_actions.cmx \
+    builtin_tests.cmi
+builtin_tests.cmi : tests.cmi
+builtin_variables.cmo : variables.cmi builtin_variables.cmi
+builtin_variables.cmx : variables.cmx builtin_variables.cmi
+builtin_variables.cmi : variables.cmi
+environments.cmo : variables.cmi environments.cmi
+environments.cmx : variables.cmx environments.cmi
+environments.cmi : variables.cmi
+filecompare.cmo : testlib.cmi run_command.cmi filecompare.cmi
+filecompare.cmx : testlib.cmx run_command.cmx filecompare.cmi
+filecompare.cmi :
+filetype.cmo : filetype.cmi
+filetype.cmx : filetype.cmi
+filetype.cmi :
+main.cmo : tsl_semantics.cmi tsl_parser.cmi tsl_lexer.cmi tests.cmi \
+    testlib.cmi options.cmi ocamltest_config.cmi environments.cmi \
+    builtin_variables.cmi actions.cmi main.cmi
+main.cmx : tsl_semantics.cmx tsl_parser.cmx tsl_lexer.cmx tests.cmx \
+    testlib.cmx options.cmx ocamltest_config.cmx environments.cmx \
+    builtin_variables.cmx actions.cmx main.cmi
+main.cmi :
+ocamltest_config.cmo : ocamltest_config.cmi
+ocamltest_config.cmx : ocamltest_config.cmi
+ocamltest_config.cmi :
+options.cmo : tests.cmi actions.cmi options.cmi
+options.cmx : tests.cmx actions.cmx options.cmi
+options.cmi :
+run_command.cmo : testlib.cmi run_command.cmi
+run_command.cmx : testlib.cmx run_command.cmi
+run_command.cmi :
+testlib.cmo : testlib.cmi
+testlib.cmx : testlib.cmi
+testlib.cmi :
+tests.cmo : actions.cmi tests.cmi
+tests.cmx : actions.cmx tests.cmi
+tests.cmi : environments.cmi actions.cmi
+tsl_ast.cmo : tsl_ast.cmi
+tsl_ast.cmx : tsl_ast.cmi
+tsl_ast.cmi :
+tsl_lexer.cmo : tsl_parser.cmi tsl_lexer.cmi
+tsl_lexer.cmx : tsl_parser.cmx tsl_lexer.cmi
+tsl_lexer.cmi : tsl_parser.cmi
+tsl_parser.cmo : tsl_ast.cmi tsl_parser.cmi
+tsl_parser.cmx : tsl_ast.cmx tsl_parser.cmi
+tsl_parser.cmi : tsl_ast.cmi
+tsl_semantics.cmo : variables.cmi tsl_ast.cmi tests.cmi testlib.cmi \
+    environments.cmi actions.cmi tsl_semantics.cmi
+tsl_semantics.cmx : variables.cmx tsl_ast.cmx tests.cmx testlib.cmx \
+    environments.cmx actions.cmx tsl_semantics.cmi
+tsl_semantics.cmi : tsl_ast.cmi tests.cmi environments.cmi actions.cmi
+variables.cmo : variables.cmi
+variables.cmx : variables.cmi
+variables.cmi :

diff --git a/ocamltest/Makefile b/ocamltest/Makefile
new file mode 100644 (file)
index 0000000..64c2411
--- /dev/null
+++ b/ocamltest/Makefile
@@ -0,0 +1,181 @@
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*            Sebastien Hinderer, projet Gallium, INRIA Paris             *
+#*                                                                        *
+#*   Copyright 2016 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+# The Makefile for ocamltest
+
+include ../config/Makefile
+
+ifeq "$(UNIX_OR_WIN32)" "win32"
+  ocamlsrcdir := $(shell echo "$(abspath $(shell pwd)/..)"|cygpath -m -f -)
+else
+  ocamlsrcdir := $(abspath $(shell pwd)/..)
+endif
+
+CPPFLAGS += -I../byterun -DCAML_INTERNALS
+
+run := run_$(UNIX_OR_WIN32)
+
+# List of source files from which ocamltest is compiled
+# (all the different sorts of files are derived from this)
+
+sources := \
+  $(run).c \
+  run_stubs.c \
+  ocamltest_config.mli ocamltest_config.ml.in \
+  testlib.mli testlib.ml \
+  run_command.mli run_command.ml \
+  filetype.mli filetype.ml \
+  filecompare.mli filecompare.ml \
+  backends.mli backends.ml \
+  variables.mli variables.ml \
+  environments.mli environments.ml \
+  builtin_variables.mli builtin_variables.ml \
+  builtin_modifiers.mli builtin_modifiers.ml \
+  actions.mli actions.ml \
+  builtin_actions.mli builtin_actions.ml \
+  tests.mli tests.ml \
+  builtin_tests.mli builtin_tests.ml \
+  tsl_ast.mli tsl_ast.ml \
+  tsl_parser.mly \
+  tsl_lexer.mli tsl_lexer.mll \
+  tsl_semantics.mli tsl_semantics.ml \
+  options.mli options.ml \
+  main.mli main.ml
+
+# List of .ml files used for ocamldep and to get the list of modules
+
+ml_files := \
+  $(filter %.ml, \
+    $(subst .ml.in,.ml,$(subst .mll,.ml,$(subst .mly,.ml,$(sources)))) \
+  )
+
+cmo_files := $(ml_files:.ml=.cmo)
+
+cmx_files := $(ml_files:.ml=.cmx)
+
+ocaml_objects := $(ml_files:.ml=.$(O))
+
+# List of .mli files for ocamldep
+mli_files := \
+  $(filter %.mli,$(subst .mly,.mli,$(sources)))
+
+cmi_files := $(mli_files:.mli=.cmi)
+
+c_files := $(filter %.c, $(sources))
+
+o_files := $(c_files:.c=.$(O))
+
+lexers := $(filter %.mll,$(sources))
+
+parsers := $(filter %.mly,$(sources))
+
+config_files := $(filter %.ml.in,$(sources))
+
+dependencies_generated_prereqs := \
+  $(config_files:.ml.in=.ml) \
+  $(lexers:.mll=.ml) \
+  $(parsers:.mly=.mli) $(parsers:.mly=.ml)
+
+generated := $(dependencies_generated_prereqs) $(parsers:.mly=.output)
+
+bytecode_modules := $(o_files) $(cmo_files)
+
+native_modules := $(o_files) $(cmx_files)
+
+directories = ../utils ../parsing ../stdlib ../compilerlibs
+
+include_directories = $(addprefix -I , $(directories))
+
+flags = -g -nostdlib $(include_directories) \
+  -strict-sequence -safe-string -strict-formats \
+  -w +a-4-9-41-42-44-45-48 -warn-error A
+
+ifeq "$(UNIX_OR_WIN32)" "unix"
+FLEXLINK_ENV=
+else # Windows
+  ifeq "$(wildcard ../flexdll/Makefile)" ""
+    FLEXLINK_ENV=
+  else
+    FLEXLINK_ENV=OCAML_FLEXLINK="../boot/ocamlrun ../flexdll/flexlink.exe"
+  endif
+endif
+
+ocamlc := $(FLEXLINK_ENV) ../byterun/ocamlrun ../ocamlc $(flags)
+
+ocamlopt := $(FLEXLINK_ENV) ../byterun/ocamlrun ../ocamlopt $(flags)
+
+ocamldep := ../byterun/ocamlrun ../tools/ocamldep -slash
+
+ocamllex := ../byterun/ocamlrun ../lex/ocamllex
+
+ocamlyacc := ../yacc/ocamlyacc
+
+ocamlcdefaultflags :=
+
+ocamloptdefaultflags := $(shell ./getocamloptdefaultflags $(TARGET))
+
+ocamltest$(EXE): $(bytecode_modules)
+       $(ocamlc) -custom ocamlcommon.cma -o $@ $^
+
+%.cmo: %.ml
+       $(ocamlc) -c $<
+
+ocamltest.opt$(EXE): $(native_modules)
+       $(ocamlopt) ocamlcommon.cmxa -o $@ $^
+
+%.cmx: %.ml
+       $(ocamlopt) -c $<
+
+%.cmi: %.mli
+       $(ocamlc) -c $<
+
+%.ml %.mli: %.mly
+       $(ocamlyacc) $<
+
+%.ml: %.mll
+       $(ocamllex) -q $<
+
+%.$(O): %.c
+       $(CC) $(CFLAGS) $(CPPFLAGS) $(BYTECCCOMPOPTS) -c $<
+
+ocamltest_config.ml: ocamltest_config.ml.in
+       sed \
+         -e 's|@@ARCH@@|$(ARCH)|' \
+         -e 's|@@CPP@@|$(CPP)|' \
+         -e 's|@@OCAMLCDEFAULTFLAGS@@|$(ocamlcdefaultflags)|' \
+         -e 's|@@OCAMLOPTDEFAULTFLAGS@@|$(ocamloptdefaultflags)|' \
+         -e 's|@@OCAMLSRCDIR@@|$(ocamlsrcdir)|' \
+         -e 's|@@FLAMBDA@@|$(FLAMBDA)|' \
+         -e 's|@@FORCE_SAFE_STRING@@|$(FORCE_SAFE_STRING)|' \
+         $< > $@
+
+.PHONY: clean
+clean:
+       rm -rf ocamltest$(EXE) ocamltest.opt$(EXE)
+       rm -rf $(o_files) $(ocaml_objects)
+       rm -rf $(cmi_files)
+       rm -rf $(cmo_files)
+       rm -rf $(cmx_files)
+       rm -rf $(generated)
+
+ifneq "$(TOOLCHAIN)" "msvc"
+.PHONY: depend
+depend: $(dependencies_generated_prereqs)
+       $(CC) -MM $(CPPFLAGS) $(c_files) \
+         | sed -e 's/\.o/.$$(O)/' > .depend
+       $(ocamldep) $(mli_files) $(ml_files) >> .depend
+endif
+
+-include .depend

diff --git a/ocamltest/README b/ocamltest/README
new file mode 100644 (file)
index 0000000..012f98b
--- /dev/null
+++ b/ocamltest/README
@@ -0,0 +1,199 @@
+# Introduction
+
+## Context
+
+The testsuite of the OCaml compiler consists of a series of programs
+that are compiled and executed. The output of their compilation and
+execution is compared to expected outputs.
+
+Before the introduction of ocamltest, the tests were driven by a set of
+makefiles which were responsible for compiling and running the test
+programs, and verifying that the compilation and execution outputs were
+matching the expected ones.
+
+In this set-up, the precise information about how exactly one test
+should be compiled was separated from the test itself. It was stored
+somewhere in the makefiles, interleaved with the recipes to actually
+compile and run the test. Thus, given one test, it was not easy to
+determine exactly how this test was supposed to be compiled and run.
+
+## Purpose
+
+The ocamltest tool has been introduced to replace most of the makefiles
+logic. It takes a test program as its input and derives from annotations
+stored as a special comment at the beginning of the program the exact
+way to compile and run it. Thus the test-specific metadata are stored in
+the test file itself and clearly separated from the machinery required
+to perform the actual tasks, which is centralized in the ocamltest tool.
+
+## Constraints
+
+It may look odd at first glance to write the tool used to test the
+compiler in its target language. There are, however, parts of the
+compiler and the standard library that are already tested in a way,
+namely those used to compile the compiler itself. Therefore, these
+components can be considered more trustworthy than those that have
+not yet been used and that's
+why ocamltest relies only on the part of the standard library that has been
+used to develop the compiler itself.
+
+This excludes for instance the use of the Unix and Str libraries.
+
+# Initial set-up
+
+ocamltest needs to know two things:
+
+1. Where the sources of the OCaml compiler to test are located.
+This is determined while OCaml is built. The default location can be
+overriden by defining the OCAMLSRCDIR environment variable.
+
+2. Which directory to use to build tests. The default value for this is
+"ocamltest" under Filename.get_temp_dir_name(). This value can be
+overriden by defining the OCAMLTESTDIR environemnt variable.
+
+# Running tests
+
+(all the commands below are assumed to be run from OCAMLSRCDIR/testsuite)
+
+From here, one can:
+
+## Run all tests: make all
+
+This runs the complete testsuite. This includes the "legacy" tests
+that still use the makefile-based infrastructure and the "new" tests
+that have been migrated to use ocamltest.
+
+## Run legacy tests: make legacy
+
+## Run new tests: make new
+
+## Run tests manually
+
+It is convenient to have the following ocamltest script in a directory
+appearing in PATH, like ~/bin:
+
+#!/bin/sh
+TERM=dumb OCAMLRUNPARAM= /path/to/ocaml/sources/ocamltest/ocamltest $*
+
+Once this file has been made executable, one can for instance run:
+
+ocamltest tests/basic-io/wc.ml
+
+As can be seen, ocamltest's output looks similar to the legacy format.
+
+This is to make the transition between the makefile-based
+infrastructure and ocamltest as smooth as possible. Once all the
+tests will have been migrated to ocamltest, it will become possible to
+change this output format.
+
+The details of what exactly has been tested can be found in
+${OCAMLTESTDIR}/tests/basic-io/wc/wc.log
+
+One can then examine tests/basic-io/wc.ml to see how the file
+had to be annotated to produce such a result.
+
+Many other tests have already been migrated and it may be useful to see
+how the test files have been annotated. the command
+
+find tests -name '*ocamltests*' | xargs cat
+
+gives a list of tests that have been modified and can therefore be used
+as starting points to understand what ocamltest can do.
+
+# Migrating tests from makefiles to ocamltest
+
+It may be a good idea to run make new from the testsuite directory before
+starting to migrate tests. This will show how many "new" tests there
+already are.
+
+Then, when running make new after migrating n tests,
+the number of new tests reported by make new should have increased by n.
+
+OCaml's testsuite is divided into directories, each of them
+containing one or several tests, which can each consist of one or
+several files.
+
+Thus, the directory is the smallest unit that can be migrated.
+
+To see which directories still need to be migrated, do:
+
+find tests -name 'Makefile'
+
+In other words, the directories that still need to be migrated are
+the subdirectories of testsuite/tests that still contain a Makefile.
+
+Once you knwo which directory you want to migrate, say foo, here is
+what you should do:
+
+Read foo/Makefile to see how many tests the directory contains and how
+they are compiled. If the makefile only includes other makefiles and
+does not define any variable, then it means that nothing special
+has to be done to compile or run the tests.
+
+You can also run the tests of this directory with the legacy framework,
+to see exactly how they are compiled and executed. To do so, use the
+following command  from the testsuite directory:
+
+make --trace DIR=tests/foo
+
+(You may want to log the output of this command for future reference.)
+
+For each test, annotate its main file with a test block, i.e. a
+comment that looks like this:
+
+(* TEST
+  Optional variable assignments and tests
+*)
+
+In particular, if the test's main file is foo.ml and the test uses
+modules m1.ml and m2.ml, the test block will look like ths:
+
+(* TEST
+  modules = "m1.ml m2.ml"
+*)
+
+And if the test consists of a single file foo.ml that needs to be
+run under the top-level, then its test block will look like this:
+
+(* TEST
+  * toplevel
+*)
+
+Or, if there are two reference files for that test and the name
+of one of them contains "principal", then it means the file should
+be tested with the top-level, without and with the -principal option.
+This is expressed as follows:
+
+(* TEST
+  * toplevel
+  * toplevel
+    include principal
+*)
+
+Lines starting with stars indicate which tests to run. If no test is
+specified, then the tests that are enabled by default are used,
+namely to compile and run the test program in both bytecode and native
+code (roughly speaking).
+
+Once your test has been annotated, run ocamltest on it and see
+whether it passes or fails. If it fails, see the log file to understand why
+and make the necessary adjustments until all the tests pass.
+
+The adjustments will mostly consist in renaming reference files and
+updating their content.
+
+Note that there are different types of reference files, those for
+compiler output and those for program output.
+
+To make sure the migration has been done correctly, you can compare the
+commands used to compile the programs in ocamltest's log file to those
+obtained with make --trace. Beware that the commands used to compare an
+obtained result to an expected one will not show up in ocamltest's log
+file.
+
+Once this has been done for all tests, create a file called "ocamltests"
+(mark the final s!) with the names of all the files that
+have been annotated for ocamltest, one per line.
+
+Finally, git rm the Makefile and run make new from the testsuite directory
+to make sure the number of new tests has increased as expected.

diff --git a/ocamltest/actions.ml b/ocamltest/actions.ml
new file mode 100644 (file)
index 0000000..6df72c5
--- /dev/null
+++ b/ocamltest/actions.ml
@@ -0,0 +1,67 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Sebastien Hinderer, projet Gallium, INRIA Paris            *)
+(*                                                                        *)
+(*   Copyright 2016 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Definition of actions, basic blocks for tests *)
+
+type result =
+  | Pass of Environments.t
+  | Fail of string
+  | Skip of string
+
+let string_of_reason prefix reason =
+  if reason="" then prefix
+  else prefix ^ " (" ^ reason ^ ")"
+
+let string_of_result = function
+  | Pass _ -> "Pass"
+  | Fail reason -> string_of_reason "Fail" reason
+  | Skip reason -> string_of_reason "Skip" reason
+
+type body = out_channel -> Environments.t -> result
+
+type t = {
+  action_name : string;
+  action_environment : Environments.t -> Environments.t;
+  action_body : body
+}
+
+let compare a1 a2 = String.compare a1.action_name a2.action_name
+
+let (actions : (string, t) Hashtbl.t) = Hashtbl.create 10
+
+let register action =
+  Hashtbl.add actions action.action_name action
+
+let get_registered_actions () =
+  let f _action_name action acc = action::acc in
+  let unsorted_actions = Hashtbl.fold f actions [] in
+  List.sort compare unsorted_actions
+
+let lookup name =
+  try Some (Hashtbl.find actions name)
+  with Not_found -> None
+
+let run log env action =
+  action.action_body log env
+
+module ActionSet = Set.Make
+(struct
+  type nonrec t = t
+  let compare = compare
+end)
+
+let update_environment initial_env actions =
+  let f act env = act.action_environment env in
+  ActionSet.fold f actions initial_env

diff --git a/ocamltest/actions.mli b/ocamltest/actions.mli
new file mode 100644 (file)
index 0000000..e9bde85
--- /dev/null
+++ b/ocamltest/actions.mli
@@ -0,0 +1,45 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Sebastien Hinderer, projet Gallium, INRIA Paris            *)
+(*                                                                        *)
+(*   Copyright 2016 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Definition of actions, basic blocks for tests *)
+
+type result =
+  | Pass of Environments.t
+  | Fail of string
+  | Skip of string
+
+val string_of_result : result -> string
+
+type body = out_channel -> Environments.t -> result
+
+type t = {
+  action_name : string;
+  action_environment : Environments.t -> Environments.t;
+  action_body : body
+}
+
+val compare : t -> t -> int
+
+val register : t -> unit
+
+val get_registered_actions : unit -> t list
+
+val lookup : string -> t option
+
+val run : out_channel -> Environments.t -> t -> result
+
+module ActionSet : Set.S with type elt = t
+
+val update_environment : Environments.t -> ActionSet.t -> Environments.t

diff --git a/ocamltest/backends.ml b/ocamltest/backends.ml
new file mode 100644 (file)
index 0000000..c92e969
--- /dev/null
+++ b/ocamltest/backends.ml
@@ -0,0 +1,39 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Sebastien Hinderer, projet Gallium, INRIA Paris            *)
+(*                                                                        *)
+(*   Copyright 2016 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Backends of the OCaml compiler and their properties *)
+
+type t = Sys.backend_type
+
+let string_of_backend = function
+  | Sys.Bytecode -> "bytecode"
+  | Sys.Native -> "native"
+  | Sys.Other backend_name -> backend_name
+
+(* Creates a function that returns its first argument for Bytecode,          *)
+(* its second argument for Native code and fails for other backends          *)
+let make_backend_function bytecode_value native_value = function
+  | Sys.Bytecode -> bytecode_value
+  | Sys.Native -> native_value
+  | Sys.Other backend_name ->
+    let error_message =
+      ("Other backend " ^ backend_name ^ " not supported") in
+    raise (Invalid_argument error_message)
+
+let module_extension = make_backend_function "cmo" "cmx"
+
+let library_extension = make_backend_function "cma" "cmxa"
+
+let executable_extension = make_backend_function "byte" "opt"

diff --git a/ocamltest/backends.mli b/ocamltest/backends.mli
new file mode 100644 (file)
index 0000000..6d651ae
--- /dev/null
+++ b/ocamltest/backends.mli
@@ -0,0 +1,28 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Sebastien Hinderer, projet Gallium, INRIA Paris            *)
+(*                                                                        *)
+(*   Copyright 2016 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Backends of the OCaml compiler and their properties *)
+
+type t = Sys.backend_type
+
+val string_of_backend : t -> string
+
+val make_backend_function : 'a -> 'a -> t -> 'a
+
+val module_extension : t -> string
+
+val library_extension : t -> string
+
+val executable_extension : t -> string

diff --git a/ocamltest/builtin_actions.ml b/ocamltest/builtin_actions.ml
new file mode 100644 (file)
index 0000000..0c090ec
--- /dev/null
+++ b/ocamltest/builtin_actions.ml
@@ -0,0 +1,863 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Sebastien Hinderer, projet Gallium, INRIA Paris            *)
+(*                                                                        *)
+(*   Copyright 2016 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Definition of a few built-in actions *)
+
+open Actions
+
+(* Miscellaneous functions *)
+
+let env_id env = env
+
+let run_command
+    ?(stdin_variable=Builtin_variables.stdin)
+    ?(stdout_variable=Builtin_variables.stdout)
+    ?(stderr_variable=Builtin_variables.stderr)
+    ?(append=false)
+    ?(timeout=0)
+    log env cmd
+  =
+  let log_redirection std filename =
+    if filename<>"" then
+    begin
+      Printf.fprintf log "  Redirecting %s to %s \n%!" std filename
+    end in
+  let lst = List.concat (List.map Testlib.words cmd) in
+  let quoted_lst =
+    if Sys.os_type="Win32"
+    then List.map Testlib.maybe_quote lst
+    else lst in
+  let cmd' = String.concat " " quoted_lst in
+  Printf.fprintf log "Commandline: %s\n" cmd';
+  let progname = List.hd quoted_lst in
+  let arguments = Array.of_list quoted_lst in
+  (*
+  let environment =
+    try [|Sys.getenv "PATH" |]
+    with Not_found -> [| |] in
+  *)
+  let stdin_filename = Environments.safe_lookup stdin_variable env in
+  let stdout_filename = Environments.safe_lookup stdout_variable env in
+  let stderr_filename = Environments.safe_lookup stderr_variable env in
+  log_redirection "stdin" stdin_filename;
+  log_redirection "stdout" stdout_filename;
+  log_redirection "stderr" stderr_filename;
+  Run_command.run {
+    Run_command.progname = progname;
+    Run_command.argv = arguments;
+    (* Run_command.envp = environment; *)
+    Run_command.stdin_filename = stdin_filename;
+    Run_command.stdout_filename = stdout_filename;
+    Run_command.stderr_filename = stderr_filename;
+    Run_command.append = append;
+    Run_command.timeout = timeout;
+    Run_command.log = log
+  }
+
+let mkreason what commandline exitcode =
+  Printf.sprintf "%s: command\n%s\nfailed with exit code %d"
+    what commandline exitcode
+
+let make_file_name name ext = String.concat "." [name; ext]
+
+let make_path components = List.fold_left Filename.concat "" components
+
+(*
+let rec map_reduce_result f g init = function
+  | [] -> Ok init
+  | x::xs ->
+    (match f x with
+      | Ok fx ->
+        (match map_reduce_result f g init xs with
+          | Ok fxs -> Ok (g fx fxs)
+          | Error _ as e -> e
+        )
+      | Error _ as e -> e
+    )
+*)
+
+let setup_symlinks test_source_directory build_directory files =
+  let symlink filename =
+    let src = Filename.concat test_source_directory filename in
+    let cmd = "ln -sf " ^ src ^" " ^ build_directory in
+    Testlib.run_system_command cmd in
+  let copy filename =
+    let src = Filename.concat test_source_directory filename in
+    let dst = Filename.concat build_directory filename in
+    Testlib.copy_file src dst in
+  let f = if Sys.os_type="Win32" then copy else symlink in
+  List.iter f files
+
+let mkexe =
+  if Sys.os_type="Win32"
+  then fun name -> make_file_name name "exe"
+  else fun name -> name
+
+(* Compilers and flags *)
+
+let ocamlsrcdir () =
+  try Sys.getenv "OCAMLSRCDIR"
+  with Not_found -> Ocamltest_config.ocamlsrcdir
+
+let ocamlrun ocamlsrcdir =
+  let ocamlrunfile = mkexe "ocamlrun" in
+  make_path [ocamlsrcdir; "byterun"; ocamlrunfile]
+
+let ocamlc ocamlsrcdir =
+  make_path [ocamlsrcdir; "ocamlc"]
+
+let ocaml ocamlsrcdir =
+  make_path [ocamlsrcdir; "ocaml"]
+
+let ocamlc_dot_byte ocamlsrcdir =
+  let ocamlrun = ocamlrun ocamlsrcdir in
+  let ocamlc = ocamlc ocamlsrcdir in
+  ocamlrun ^ " " ^ ocamlc
+
+let ocamlc_dot_opt ocamlsrcdir =
+  make_path [ocamlsrcdir; "ocamlc.opt"]
+
+let ocamlopt ocamlsrcdir =
+  make_path [ocamlsrcdir; "ocamlopt"]
+
+let ocamlopt_dot_byte ocamlsrcdir =
+  let ocamlrun = ocamlrun ocamlsrcdir in
+  let ocamlopt = ocamlopt ocamlsrcdir in
+  ocamlrun ^ " " ^ ocamlopt
+
+let ocamlopt_dot_opt ocamlsrcdir =
+  make_path [ocamlsrcdir; "ocamlopt.opt"]
+
+let ocaml_dot_byte ocamlsrcdir =
+  let ocamlrun = ocamlrun ocamlsrcdir in
+  let ocaml = ocaml ocamlsrcdir in
+  ocamlrun ^ " " ^ ocaml
+
+let ocaml_dot_opt ocamlsrcdir =
+  make_path [ocamlsrcdir; mkexe "ocamlnat"]
+
+let cmpbyt ocamlsrcdir =
+  make_path [ocamlsrcdir; "tools"; "cmpbyt"]
+
+let stdlib ocamlsrcdir =
+  make_path [ocamlsrcdir; "stdlib"]
+
+let stdlib_flags ocamlsrcdir =
+  let stdlib_path = stdlib ocamlsrcdir in
+  "-nostdlib -I " ^ stdlib_path
+
+let c_includes ocamlsrcdir =
+  make_path [ocamlsrcdir; "byterun"]
+
+let c_includes_flags ocamlsrcdir =
+  let dir = c_includes ocamlsrcdir in
+  "-ccopt -I" ^ dir
+
+let use_runtime backend ocamlsrcdir = match backend with
+  | Sys.Bytecode ->
+    let ocamlrun = ocamlrun ocamlsrcdir in
+    "-use-runtime " ^ ocamlrun
+  | _ -> ""
+
+(* Compiler descriptions *)
+
+type compiler_info = {
+  compiler_name : string -> string;
+  compiler_flags : string;
+  compiler_directory : string;
+  compiler_backend : Sys.backend_type;
+  compiler_exit_status_variabe : Variables.t;
+  compiler_reference_variable : Variables.t;
+  compiler_output_variable : Variables.t
+}
+
+(* Compilers compiling byte-code programs *)
+
+let bytecode_bytecode_compiler =
+{
+  compiler_name = ocamlc_dot_byte;
+  compiler_flags = "";
+  compiler_directory = "ocamlc.byte";
+  compiler_backend = Sys.Bytecode;
+  compiler_exit_status_variabe = Builtin_variables.ocamlc_byte_exit_status;
+  compiler_reference_variable = Builtin_variables.compiler_reference;
+  compiler_output_variable = Builtin_variables.compiler_output;
+}
+
+let bytecode_native_compiler =
+{
+  compiler_name = ocamlc_dot_opt;
+  compiler_flags = "";
+  compiler_directory = "ocamlc.opt";
+  compiler_backend = Sys.Bytecode;
+  compiler_exit_status_variabe = Builtin_variables.ocamlc_opt_exit_status;
+  compiler_reference_variable = Builtin_variables.compiler_reference2;
+  compiler_output_variable = Builtin_variables.compiler_output2;
+}
+
+(* Compilers compiling native-code programs *)
+
+let native_bytecode_compiler =
+{
+  compiler_name = ocamlopt_dot_byte;
+  compiler_flags = "";
+  compiler_directory = "ocamlopt.byte";
+  compiler_backend = Sys.Native;
+  compiler_exit_status_variabe = Builtin_variables.ocamlopt_byte_exit_status;
+  compiler_reference_variable = Builtin_variables.compiler_reference;
+  compiler_output_variable = Builtin_variables.compiler_output;
+}
+
+let native_native_compiler =
+{
+  compiler_name = ocamlopt_dot_opt;
+  compiler_flags = "";
+  compiler_directory = "ocamlopt.opt";
+  compiler_backend = Sys.Native;
+  compiler_exit_status_variabe = Builtin_variables.ocamlopt_opt_exit_status;
+  compiler_reference_variable = Builtin_variables.compiler_reference2;
+  compiler_output_variable = Builtin_variables.compiler_output2;
+}
+
+(* Top-levels *)
+
+let ocaml = {
+  compiler_name = ocaml_dot_byte;
+  compiler_flags = "";
+  compiler_directory = "ocaml";
+  compiler_backend = Sys.Bytecode;
+  compiler_exit_status_variabe = Builtin_variables.ocaml_byte_exit_status;
+  compiler_reference_variable = Builtin_variables.compiler_reference;
+  compiler_output_variable = Builtin_variables.compiler_output;
+}
+
+let ocamlnat = {
+  compiler_name = ocaml_dot_opt;
+  compiler_flags = "-S"; (* Keep intermediate assembly files *)
+  compiler_directory = "ocamlnat";
+  compiler_backend = Sys.Native;
+  compiler_exit_status_variabe = Builtin_variables.ocaml_opt_exit_status;
+  compiler_reference_variable = Builtin_variables.compiler_reference2;
+  compiler_output_variable = Builtin_variables.compiler_output2;
+}
+
+let expected_compiler_exit_status env compiler =
+  try int_of_string
+    (Environments.safe_lookup compiler.compiler_exit_status_variabe env)
+  with _ -> 0
+
+let compiler_reference_filename env prefix compiler =
+  let compiler_reference_suffix =
+    Environments.safe_lookup Builtin_variables.compiler_reference_suffix env in
+  let suffix =
+    if compiler_reference_suffix<>""
+    then compiler_reference_suffix ^ ".reference"
+    else ".reference" in
+  let mk s = (make_file_name prefix s) ^suffix in
+  let filename = mk compiler.compiler_directory in
+  if Sys.file_exists filename then filename else
+  let filename = mk (Backends.string_of_backend compiler.compiler_backend) in
+  if Sys.file_exists filename then filename else
+  mk "compilers"
+
+(* Extracting information from environment *)
+
+let get_backend_value_from_env env bytecode_var native_var =
+  Backends.make_backend_function
+    (Environments.safe_lookup bytecode_var env)
+    (Environments.safe_lookup native_var env)
+
+let testfile env =
+  match Environments.lookup Builtin_variables.test_file env with
+  | None -> assert false
+  | Some t -> t
+
+let words_of_variable variable env =
+  Testlib.words (Environments.safe_lookup variable env)
+
+let modules env = words_of_variable Builtin_variables.modules env
+
+let files env = words_of_variable Builtin_variables.files env
+
+let flags env = Environments.safe_lookup Builtin_variables.flags env
+
+let libraries backend env =
+  let value = Environments.safe_lookup Builtin_variables.libraries env in
+  let libs = Testlib.words value in
+  let extension = Backends.library_extension backend in
+  let add_extension lib = make_file_name lib extension in
+  String.concat " " (List.map add_extension libs)
+
+let backend_default_flags env =
+  get_backend_value_from_env env
+    Builtin_variables.ocamlc_default_flags
+    Builtin_variables.ocamlopt_default_flags
+
+let backend_flags env =
+  get_backend_value_from_env env
+    Builtin_variables.ocamlc_flags
+    Builtin_variables.ocamlopt_flags
+
+let test_source_directory env =
+  Environments.safe_lookup Builtin_variables.test_source_directory env
+
+let test_build_directory env =
+  Environments.safe_lookup Builtin_variables.test_build_directory env
+
+(*
+let action_of_filetype = function
+  | Filetype.Implementation -> "Compiling implementation"
+  | Filetype.Interface -> "Compiling interface"
+  | Filetype.C -> "Compiling C source file"
+  | Filetype.C_minus_minus -> "Processing C minus minus file"
+  | Filetype.Lexer -> "Generating lexer"
+  | Filetype.Grammar -> "Generating parser"
+*)
+
+let link_modules
+    ocamlsrcdir compiler compilername compileroutput program_variable
+    custom c_headers_flags log env modules
+  =
+  let backend = compiler.compiler_backend in
+  let expected_exit_status = expected_compiler_exit_status env compiler in
+  let executable_name = match Environments.lookup program_variable env with
+    | None -> assert false
+    | Some program -> program in
+  let module_names =
+    String.concat " " (List.map Filetype.make_filename modules) in
+  let what = Printf.sprintf "Linking modules %s into %s"
+    module_names executable_name in
+  Printf.fprintf log "%s\n%!" what;
+  let output = "-o " ^ executable_name in
+  let customstr = if custom then "-custom" else "" in
+  let commandline =
+  [
+    compilername;
+    customstr;
+    c_headers_flags;
+    use_runtime backend ocamlsrcdir;
+    stdlib_flags ocamlsrcdir;
+    "-linkall";
+    flags env;
+    libraries backend env;
+    backend_default_flags env backend;
+    backend_flags env backend;
+    output;
+    module_names
+  ] in
+  let exit_status =
+    run_command
+      ~stdout_variable:compileroutput
+      ~stderr_variable:compileroutput
+      ~append:true
+      log env commandline in
+  if exit_status=expected_exit_status
+  then Pass env
+  else Fail (mkreason what (String.concat " " commandline) exit_status)
+
+let compile_program
+    ocamlsrcdir compiler compilername compileroutput program_variable
+    log env modules
+  =
+  let is_c_file (_filename, filetype) = filetype=Filetype.C in
+  let has_c_file = List.exists is_c_file modules in
+  let backend = compiler.compiler_backend in
+  let custom = (backend = Sys.Bytecode) && has_c_file in
+  let c_headers_flags =
+    if has_c_file then c_includes_flags ocamlsrcdir else "" in
+  link_modules
+    ocamlsrcdir compiler compilername compileroutput
+    program_variable custom c_headers_flags log env modules
+
+let module_has_interface directory module_name =
+  let interface_name =
+    Filetype.make_filename (module_name, Filetype.Interface) in
+  let interface_fullpath = make_path [directory;interface_name] in
+  Sys.file_exists interface_fullpath
+
+let add_module_interface directory module_description =
+  match module_description with
+    | (filename, Filetype.Implementation) when
+      module_has_interface directory filename ->
+        [(filename, Filetype.Interface); module_description]
+  | _ -> [module_description]
+
+let print_module_names log description modules =
+  Printf.fprintf log "%s modules: %s\n%!"
+    description
+    (String.concat " " (List.map Filetype.make_filename modules))
+
+let setup_build_environment
+    testfile source_directory build_directory log env
+  =
+  let specified_modules =
+    List.map Filetype.filetype ((modules env) @ [testfile]) in
+  print_module_names log "Specified" specified_modules;
+  let source_modules =
+    Testlib.concatmap
+      (add_module_interface source_directory)
+      specified_modules in
+  print_module_names log "Source" source_modules;
+  Testlib.make_directory build_directory;
+  setup_symlinks
+    source_directory
+    build_directory
+    (List.map Filetype.make_filename source_modules);
+  setup_symlinks source_directory build_directory (files env);
+  Sys.chdir build_directory;
+  source_modules
+
+let prepare_module (module_name, module_type) =
+  match module_type with
+    | Filetype.Implementation | Filetype.Interface | Filetype.C ->
+      [(module_name, module_type)]
+    | Filetype.C_minus_minus -> assert false
+    | Filetype.Lexer -> assert false
+    | Filetype.Grammar -> assert false
+
+let compile_test_program program_variable compiler log env =
+  let backend = compiler.compiler_backend in
+  let testfile = testfile env in
+  let testfile_basename = Filename.chop_extension testfile in
+  let source_directory = test_source_directory env in
+  let compiler_directory_suffix =
+    Environments.safe_lookup Builtin_variables.compiler_directory_suffix env in
+  let compiler_directory_name =
+    compiler.compiler_directory ^ compiler_directory_suffix in
+  let build_directory =
+    make_path [test_build_directory env; compiler_directory_name] in
+  let compilerreference_prefix =
+    make_path [source_directory; testfile_basename] in
+  let compilerreference_filename =
+    compiler_reference_filename env compilerreference_prefix compiler in
+  let compiler_reference_variable = compiler.compiler_reference_variable in
+  let executable_filename =
+    mkexe
+      (make_file_name
+        testfile_basename (Backends.executable_extension backend)) in
+  let executable_path = make_path [build_directory; executable_filename] in
+  let compiler_output_filename =
+    make_file_name compiler.compiler_directory "output" in
+  let compiler_output =
+    make_path [build_directory; compiler_output_filename] in
+  let compiler_output_variable = compiler.compiler_output_variable in
+  let newenv = Environments.add_bindings
+    [
+      (program_variable, executable_path);
+      (compiler_reference_variable, compilerreference_filename);
+      (compiler_output_variable, compiler_output);
+    ] env in
+  if Sys.file_exists compiler_output_filename then
+    Sys.remove compiler_output_filename;
+  let ocamlsrcdir = ocamlsrcdir () in
+  let compilername = compiler.compiler_name ocamlsrcdir in
+  let source_modules =
+    setup_build_environment
+      testfile source_directory build_directory log env in
+  let prepared_modules =
+    Testlib.concatmap prepare_module source_modules in
+  compile_program
+    ocamlsrcdir
+    compiler
+    compilername
+    compiler_output_variable
+    program_variable log newenv prepared_modules
+
+(* Compile actions *)
+
+let compile_bytecode_with_bytecode_compiler = {
+  action_name = "compile-bytecode-with-bytecode-compiler";
+  action_environment = env_id;
+  action_body =
+    compile_test_program
+      Builtin_variables.program bytecode_bytecode_compiler
+}
+
+let compile_bytecode_with_native_compiler = {
+  action_name = "compile-bytecode-with-native-compiler";
+  action_environment = env_id;
+  action_body =
+    compile_test_program
+      Builtin_variables.program2 bytecode_native_compiler
+}
+
+let compile_native_with_bytecode_compiler = {
+  action_name = "compile-native-with-bytecode-compiler";
+  action_environment = env_id;
+  action_body =
+    compile_test_program
+      Builtin_variables.program native_bytecode_compiler
+}
+
+let compile_native_with_native_compiler = {
+  action_name = "compile-native-with-native-compiler";
+  action_environment = env_id;
+  action_body =
+    compile_test_program
+      Builtin_variables.program2 native_native_compiler
+}
+
+let exec log_message redirect_output prog_variable args_variable log env =
+  match Environments.lookup prog_variable env with
+  | None ->
+    let msg = Printf.sprintf "%s: variable %s is undefined"
+      log_message (Variables.name_of_variable prog_variable) in
+    Fail msg
+  | Some program ->
+    let arguments = Environments.safe_lookup args_variable env in
+    let commandline = [program; arguments] in
+    let what = log_message ^ " " ^ program ^ " " ^
+    begin if arguments="" then "without any argument"
+    else "with arguments " ^ arguments
+    end in
+    let output = program ^ ".output" in
+    let bindings =
+    [
+      Builtin_variables.stdout, output;
+      Builtin_variables.stderr, output
+    ] in
+    let execution_env =
+      if redirect_output then Environments.add_bindings bindings env
+      else env in
+    match run_command log execution_env commandline with
+      | 0 ->
+        let newenv =
+          if redirect_output
+          then Environments.add Builtin_variables.output output env
+          else env in
+        Pass newenv
+      | _ as exitcode ->
+        if exitcode = 125
+        then Skip (mkreason what (String.concat " " commandline) exitcode)
+        else Fail (mkreason what (String.concat " " commandline) exitcode)
+
+let execute_program =
+  exec
+    "Executing program"
+    true
+    Builtin_variables.program
+    Builtin_variables.arguments
+
+let execute = {
+  action_name = "execute-program";
+  action_environment = env_id;
+  action_body = execute_program
+}
+
+let run_script log env =
+  let testfile = testfile env in
+  (* let testfile_basename = Filename.chop_extension testfile in *)
+  let source_directory = test_source_directory env in
+  let build_directory = test_build_directory env in
+  let _modules =
+    setup_build_environment
+      testfile source_directory build_directory log env in
+  exec
+    "Running script"
+    false
+    Builtin_variables.script
+    Builtin_variables.test_file
+    log env
+
+let script = {
+  action_name = "run-script";
+  action_environment = env_id;
+  action_body = run_script
+}
+
+let run_expect log env =
+  let newenv = Environments.apply_modifiers env Builtin_modifiers.expect in
+  run_script log newenv
+
+let expect = {
+  action_name = "run-expect";
+  action_environment = env_id;
+  action_body = run_expect
+}
+
+let check_output kind_of_output output_variable reference_variable log env =
+  let reference_filename = Environments.safe_lookup reference_variable env in
+  let output_filename = Environments.safe_lookup output_variable env in
+  Printf.fprintf log "Comparing %s output %s to reference %s\n%!"
+    kind_of_output output_filename reference_filename;
+  let files =
+  {
+    Filecompare.filetype = Filecompare.Text;
+    Filecompare.reference_filename = reference_filename;
+    Filecompare.output_filename = output_filename
+  } in
+  match Filecompare.check_file files with
+    | Filecompare.Same -> Pass env
+    | Filecompare.Different ->
+      let diff = Filecompare.diff files in
+      let diffstr = match diff with
+        | Ok difference -> difference
+        | Error diff_file -> ("See " ^ diff_file) in
+      let reason =
+        Printf.sprintf "%s output %s differs from reference %s: \n%s\n"
+        kind_of_output output_filename reference_filename diffstr in
+      (Actions.Fail reason)
+    | Filecompare.Unexpected_output ->
+      let banner = String.make 40 '=' in
+      let unexpected_output = Testlib.string_of_file output_filename in
+      let unexpected_output_with_banners = Printf.sprintf
+        "%s\n%s%s\n" banner unexpected_output banner in
+      let reason = Printf.sprintf
+        "The file %s was expected to be empty because there is no \
+          reference file %s but it is not:\n%s\n"
+        output_filename reference_filename unexpected_output_with_banners in
+      (Actions.Fail reason)
+    | Filecompare.Error (commandline, exitcode) ->
+      let reason = Printf.sprintf "The command %s failed with status %d"
+        commandline exitcode in
+      (Actions.Fail reason)
+
+let make_check_compiler_output name compiler = {
+  action_name = name;
+  action_environment = env_id;
+  action_body =
+    check_output
+      "compiler"
+      compiler.compiler_output_variable
+      compiler.compiler_reference_variable
+}
+
+let check_ocamlc_dot_byte_output = make_check_compiler_output
+  "check-ocamlc-byte-output" bytecode_bytecode_compiler
+
+let check_ocamlc_dot_opt_output = make_check_compiler_output
+  "check-ocamlc-opt-output" bytecode_native_compiler
+
+let check_ocamlopt_dot_byte_output = make_check_compiler_output
+  "check-ocamlopt-byte-output" native_bytecode_compiler
+
+let check_ocamlopt_dot_opt_output = make_check_compiler_output
+  "check-ocamlopt-opt-output" native_native_compiler
+
+let check_program_output = {
+  action_name = "check-program-output";
+  action_environment = env_id;
+  action_body = check_output "program"
+    Builtin_variables.output
+    Builtin_variables.reference
+}
+
+(*
+let comparison_start_address portable_executable_filename =
+  let portable_executalbe_signature = "PE\000\000" in
+  let signature_length = String.length portable_executalbe_signature in
+  let address_length = 4 in
+  let start_address = 0x3c in
+  let ic = open_in portable_executable_filename in
+  seek_in ic start_address;
+  let portable_executable_signature_address_str =
+    really_input_string ic address_length in
+  let b0 = int_of_char portable_executable_signature_address_str.[0] in
+  let b1 = int_of_char portable_executable_signature_address_str.[1] in
+  let b2 = int_of_char portable_executable_signature_address_str.[2] in
+  let b3 = int_of_char portable_executable_signature_address_str.[3] in
+  let signature_address =
+    b0 +
+    b1 * 256 +
+    b2 * 256 * 256 +
+    b3 * 256 * 256 * 256 in
+  seek_in ic signature_address;
+  let signature =
+    really_input_string ic signature_length in
+  if signature<>portable_executalbe_signature
+  then failwith
+    (portable_executable_filename ^ " does not contain the PE signature");
+  let result = signature_address + 12 in
+  (* 12 is 4-bytes signature, 2-bytes machine type, *)
+  (* 2-bytes number of sections, 4-bytes timestamp *)
+  close_in ic;
+  result
+*)
+
+let compare_programs backend comparison_tool log env =
+  let program = Environments.safe_lookup Builtin_variables.program env in
+  let program2 = Environments.safe_lookup Builtin_variables.program2 env in
+  let what = Printf.sprintf "Comparing %s programs %s and %s"
+    (Backends.string_of_backend backend) program program2 in
+  Printf.fprintf log "%s\n%!" what;
+  let files = {
+    Filecompare.filetype = Filecompare.Binary;
+    Filecompare.reference_filename = program;
+    Filecompare.output_filename = program2
+  } in
+  if Ocamltest_config.flambda && backend = Sys.Native
+  then begin
+    Printf.fprintf log
+      "flambda temporarily disables comparison of native programs";
+    Pass env
+  end else if backend = Sys.Native && (Sys.os_type="Win32" || Sys.os_type="Cygwin")
+  then begin
+    Printf.fprintf log
+      "comparison of native programs temporarily disabled under Windows";
+    Pass env
+  end else begin
+    let comparison_tool =
+      if backend=Sys.Native && (Sys.os_type="Win32" || Sys.os_type="Cygwin")
+        then
+          let bytes_to_ignore = 512 (* comparison_start_address program *) in
+          Filecompare.make_cmp_tool bytes_to_ignore
+        else comparison_tool in
+    match Filecompare.compare_files ~tool:comparison_tool files with
+      | Filecompare.Same -> Pass env
+      | Filecompare.Different ->
+        let reason = Printf.sprintf "Files %s and %s are different"
+          program program2 in
+        Fail reason
+      | Filecompare.Unexpected_output -> assert false
+      | Filecompare.Error (commandline, exitcode) ->
+        let reason = mkreason what commandline exitcode in
+        Fail reason
+  end
+
+let make_bytecode_programs_comparison_tool ocamlsrcdir =
+  let ocamlrun = ocamlrun ocamlsrcdir in
+  let cmpbyt = cmpbyt ocamlsrcdir in
+  let tool_name = ocamlrun ^ " " ^ cmpbyt in
+  Filecompare.make_comparison_tool tool_name ""
+
+let native_programs_comparison_tool = Filecompare.default_comparison_tool
+
+let compare_bytecode_programs_body log env =
+  let ocamlsrcdir = ocamlsrcdir () in
+  let bytecode_programs_comparison_tool =
+    make_bytecode_programs_comparison_tool ocamlsrcdir in
+  compare_programs Sys.Bytecode bytecode_programs_comparison_tool log env
+
+let compare_bytecode_programs = {
+  action_name = "compare-bytecode-programs";
+  action_environment = env_id;
+  action_body = compare_bytecode_programs_body
+}
+
+let compare_native_programs = {
+  action_name = "compare-native-programs";
+  action_environment = env_id;
+  action_body = compare_programs Sys.Native native_programs_comparison_tool
+}
+
+let run_test_program_in_toplevel toplevel log env =
+  let testfile = testfile env in
+  let testfile_basename = Filename.chop_extension testfile in
+  let expected_exit_status = expected_compiler_exit_status env toplevel in
+  let what =
+    Printf.sprintf "Running %s in %s toplevel (expected exit status: %d)"
+      testfile
+      (Backends.string_of_backend toplevel.compiler_backend)
+      expected_exit_status in
+  Printf.fprintf log "%s\n%!" what;
+  let source_directory = test_source_directory env in
+  let compiler_directory_suffix =
+    Environments.safe_lookup Builtin_variables.compiler_directory_suffix env in
+  let compiler_directory_name =
+    toplevel.compiler_directory ^ compiler_directory_suffix in
+  let build_directory =
+    make_path [test_build_directory env; compiler_directory_name] in
+  let _modules =
+    setup_build_environment
+      testfile source_directory build_directory log env in
+  let compilerreference_prefix =
+    make_path [source_directory; testfile_basename] in
+  let compilerreference_filename =
+    compiler_reference_filename env compilerreference_prefix toplevel in
+  let compiler_reference_variable = toplevel.compiler_reference_variable in
+  let compiler_output_filename =
+    make_file_name toplevel.compiler_directory "output" in
+  let compiler_output =
+    make_path [build_directory; compiler_output_filename] in
+  let compiler_output_variable = toplevel.compiler_output_variable in
+  let newenv = Environments.add_bindings
+    [
+      (compiler_reference_variable, compilerreference_filename);
+      (compiler_output_variable, compiler_output);
+    ] env in
+  if Sys.file_exists compiler_output_filename then
+    Sys.remove compiler_output_filename;
+  let ocamlsrcdir = ocamlsrcdir () in
+  let toplevel_name = toplevel.compiler_name ocamlsrcdir in
+  let toplevel_default_flags = "-noinit -no-version -noprompt" in
+  let commandline =
+  [
+    toplevel_name;
+    toplevel_default_flags;
+    toplevel.compiler_flags;
+    stdlib_flags ocamlsrcdir;
+    flags env;
+  ] in
+  let exit_status =
+    run_command
+      ~stdin_variable:Builtin_variables.test_file
+      ~stdout_variable:compiler_output_variable
+      ~stderr_variable:compiler_output_variable
+      log newenv commandline in
+  if exit_status=expected_exit_status
+  then Pass newenv
+  else Fail (mkreason what (String.concat " " commandline) exit_status)
+
+let run_in_ocaml =
+{
+  action_name = "run-in-bytecode-toplevel";
+  action_environment = env_id;
+  action_body = run_test_program_in_toplevel ocaml;
+}
+
+let run_in_ocamlnat =
+{
+  action_name = "run-in-native-toplevel";
+  action_environment = env_id;
+  action_body = run_test_program_in_toplevel ocamlnat;
+}
+
+let check_ocaml_output = make_check_compiler_output
+  "check-bytecode-toplevel-output" ocaml
+
+let check_ocamlnat_output = make_check_compiler_output
+  "check-native-toplevel-output" ocamlnat
+
+let if_not_safe_string = {
+  action_name = "if_not_safe_string";
+  action_environment = env_id;
+  action_body = fun _log env ->
+    if Ocamltest_config.safe_string
+    then Skip "safe strings enabled"
+    else Pass env
+}
+
+let _ =
+  List.iter register
+  [
+    compile_bytecode_with_bytecode_compiler;
+    compile_bytecode_with_native_compiler;
+    compile_native_with_bytecode_compiler;
+    compile_native_with_native_compiler;
+    execute;
+    script;
+    check_program_output;
+    compare_bytecode_programs;
+    compare_native_programs;
+    check_ocamlc_dot_byte_output;
+    check_ocamlc_dot_opt_output;
+    check_ocamlopt_dot_byte_output;
+    check_ocamlopt_dot_opt_output;
+    run_in_ocaml;
+    run_in_ocamlnat;
+    check_ocaml_output;
+    check_ocamlnat_output;
+    if_not_safe_string;
+  ]

diff --git a/ocamltest/builtin_actions.mli b/ocamltest/builtin_actions.mli
new file mode 100644 (file)
index 0000000..a61a5f0
--- /dev/null
+++ b/ocamltest/builtin_actions.mli
@@ -0,0 +1,43 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Sebastien Hinderer, projet Gallium, INRIA Paris            *)
+(*                                                                        *)
+(*   Copyright 2016 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Definition of a few built-in actions *)
+
+val compile_bytecode_with_bytecode_compiler : Actions.t
+val compile_bytecode_with_native_compiler : Actions.t
+val compile_native_with_bytecode_compiler : Actions.t
+val compile_native_with_native_compiler : Actions.t
+
+val execute : Actions.t
+val expect : Actions.t
+val script : Actions.t
+val check_program_output : Actions.t
+
+val compare_bytecode_programs : Actions.t
+val compare_native_programs : Actions.t
+
+val check_ocamlc_dot_byte_output : Actions.t
+val check_ocamlc_dot_opt_output : Actions.t
+val check_ocamlopt_dot_byte_output : Actions.t
+val check_ocamlopt_dot_opt_output : Actions.t
+
+val run_in_ocaml : Actions.t
+
+val run_in_ocamlnat : Actions.t
+
+val check_ocaml_output : Actions.t
+
+val check_ocamlnat_output : Actions.t
+val if_not_safe_string : Actions.t

diff --git a/ocamltest/builtin_modifiers.ml b/ocamltest/builtin_modifiers.ml
new file mode 100644 (file)
index 0000000..9fc930d
--- /dev/null
+++ b/ocamltest/builtin_modifiers.ml
@@ -0,0 +1,44 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Sebastien Hinderer, projet Gallium, INRIA Paris            *)
+(*                                                                        *)
+(*   Copyright 2016 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Definition of a few built-in environment modifiers *)
+
+open Environments
+open Builtin_variables
+
+let expect =
+[
+  Replace (script, "bash ${OCAMLSRCDIR}/testsuite/tools/expect");
+]
+
+let principal =
+[
+  Append (flags, " -principal ");
+  Add (compiler_directory_suffix, ".principal");
+  Add (compiler_reference_suffix, ".principal");
+]
+
+let testinglib_directory = Ocamltest_config.ocamlsrcdir ^ "/testsuite/lib"
+
+let testing =
+[
+  Append (flags, (" -I " ^ testinglib_directory ^ " "));
+  Append (libraries, " testing ");
+]
+
+let _ =
+  register expect "expect";
+  register principal "principal";
+  register testing "testing"

diff --git a/ocamltest/builtin_modifiers.mli b/ocamltest/builtin_modifiers.mli
new file mode 100644 (file)
index 0000000..f35b897
--- /dev/null
+++ b/ocamltest/builtin_modifiers.mli
@@ -0,0 +1,22 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Sebastien Hinderer, projet Gallium, INRIA Paris            *)
+(*                                                                        *)
+(*   Copyright 2016 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Definition of a few built-in environment modifiers *)
+
+val expect : Environments.modifiers
+
+val principal : Environments.modifiers
+
+val testing : Environments.modifiers

diff --git a/ocamltest/builtin_tests.ml b/ocamltest/builtin_tests.ml
new file mode 100644 (file)
index 0000000..59af5c5
--- /dev/null
+++ b/ocamltest/builtin_tests.ml
@@ -0,0 +1,89 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Sebastien Hinderer, projet Gallium, INRIA Paris            *)
+(*                                                                        *)
+(*   Copyright 2016 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Definitions of built-in tests *)
+
+open Tests
+open Builtin_actions
+
+let bytecode =
+  let opt_actions =
+  [
+    compile_bytecode_with_native_compiler;
+    check_ocamlc_dot_opt_output;
+    compare_bytecode_programs
+  ] in
+{
+  test_name = "bytecode";
+  test_run_by_default = true;
+  test_actions =
+  [
+    compile_bytecode_with_bytecode_compiler;
+    check_ocamlc_dot_byte_output;
+    execute;
+    check_program_output
+  ] @ (if Ocamltest_config.arch<>"none" then opt_actions else [])
+}
+
+let expect = {
+  test_name = "expect";
+  test_run_by_default = false;
+  test_actions = [expect];
+}
+
+let native = {
+  test_name = "native";
+  test_run_by_default = true;
+  test_actions =
+  [
+    compile_native_with_bytecode_compiler;
+    check_ocamlopt_dot_byte_output;
+    execute;
+    check_program_output;
+    compile_native_with_native_compiler;
+    check_ocamlopt_dot_opt_output;
+    compare_native_programs;
+  ]
+}
+
+let script = {
+  test_name = "script";
+  test_run_by_default = false;
+  test_actions = [script];
+}
+
+let toplevel = {
+  test_name = "toplevel";
+  test_run_by_default = false;
+  test_actions =
+  [
+    run_in_ocaml;
+    check_ocaml_output;
+(*
+    run_in_ocamlnat;
+    check_ocamlnat_output;
+*)
+  ]
+}
+
+let _ =
+  List.iter register
+  [
+    bytecode;
+    expect;
+    script;
+    toplevel;
+  ];
+  if (Ocamltest_config.arch <> "none") then register native

diff --git a/ocamltest/builtin_tests.mli b/ocamltest/builtin_tests.mli
new file mode 100644 (file)
index 0000000..2a223d0
--- /dev/null
+++ b/ocamltest/builtin_tests.mli
@@ -0,0 +1,26 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Sebastien Hinderer, projet Gallium, INRIA Paris            *)
+(*                                                                        *)
+(*   Copyright 2016 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Definitions of built-in tests *)
+
+val bytecode : Tests.t
+
+val expect : Tests.t
+
+val native : Tests.t
+
+val script : Tests.t
+
+val toplevel : Tests.t

diff --git a/ocamltest/builtin_variables.ml b/ocamltest/builtin_variables.ml
new file mode 100644 (file)
index 0000000..987da19
--- /dev/null
+++ b/ocamltest/builtin_variables.ml
@@ -0,0 +1,125 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Sebastien Hinderer, projet Gallium, INRIA Paris            *)
+(*                                                                        *)
+(*   Copyright 2016 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Definition of variables used by built-in actions *)
+
+(* The variables are listed in alphabetical order *)
+
+(*
+  The name of the identifier representing a variable and its string name
+  should be similar. Is there a way to enforce this?
+*)
+
+open Variables (* Should not be necessary with a ppx *)
+
+let arguments = make ("arguments",
+  "Arguments passed to executed programs and scripts")
+
+let c_preprocessor = make ("c_preprocessor",
+  "Command to use to invoke the C preprocessor")
+
+let compiler_directory_suffix = make ("compiler_directory_suffix",
+  "Suffix to add to the directory where the test will be compiled")
+
+let compiler_reference = make ("compiler_reference",
+  "Reference file for compiler output for ocamlc.byte and ocamlopt.byte")
+
+let compiler_reference2 = make ("compiler_reference2",
+  "Reference file for compiler output for ocamlc.opt and ocamlopt.opt")
+
+let compiler_reference_suffix = make ("compiler_reference_suffix",
+  "Suffix to add to the file name containing the reference for compiler output")
+
+let compiler_output = make ("compiler_output",
+  "Where to log output of bytecode compilers")
+
+let compiler_output2 = make ("compiler_output2",
+  "Where to log output of native compilers")
+
+let ocamlc_flags = make ("ocamlc_flags",
+  "Flags passed to ocamlc.byte and ocamlc.opt")
+
+let ocamlc_default_flags = make ("ocamlc_default_flags",
+  "Flags passed by default to ocamlc.byte and ocamlc.opt")
+
+let files = make ("files",
+  "Files used by the tests")
+
+let flags = make ("flags",
+  "Flags passed to all the compilers")
+
+let libraries = make ("libraries",
+  "Libraries the program should be linked with")
+
+let modules = make ("modules",
+  "Other modules of the test")
+
+let ocamlopt_flags = make ("ocamlopt_flags",
+  "Flags passed to ocamlopt.byte and ocamlopt.opt")
+
+let ocamlopt_default_flags = make ("ocamlopt_default_flags",
+  "Flags passed by default to ocamlopt.byte and ocamlopt.opt")
+
+let ocaml_byte_exit_status = make ("ocaml_byte_exit_status",
+  "Expected exit status of ocaml.byte")
+
+let ocamlc_byte_exit_status = make ("ocamlc_byte_exit_status",
+  "Expected exit status of ocac.byte")
+
+let ocamlopt_byte_exit_status = make ("ocamlopt_byte_exit_status",
+  "Expected exit status of ocamlopt.byte")
+
+let ocaml_opt_exit_status = make ("ocaml_opt_exit_status",
+  "Expected exit status of ocaml.opt")
+
+let ocamlc_opt_exit_status = make ("ocamlc_opt_exit_status",
+  "Expected exit status of ocac.opt")
+
+let ocamlopt_opt_exit_status = make ("ocamlopt_opt_exit_status",
+  "Expected exit status of ocamlopt.opt")
+
+let output = make ("output",
+  "Where the output of executing the program is saved")
+
+let program = make ("program",
+  "Name of program produced by ocamlc.byte and ocamlopt.byte")
+let program2 = make ("program2",
+  "Name of program produced by ocamlc.opt and ocamlopt.opt")
+
+let reference = make ("reference",
+  "Path of file to which program output should be compared")
+
+let script = make ("script",
+  "External script to run")
+
+let stdin = make ("stdin", "Default standard input")
+let stdout = make ("stdout", "Default standard output")
+let stderr = make ("stderr", "Default standard error")
+
+let test_build_directory = make ("test_build_directory",
+  "Directory for files produced during a test")
+
+let test_file = make ("test_file",
+  "Name of file containing the specification of which tests to run")
+
+let test_source_directory = make ("test_source_directory",
+  "Directory containing the test source files")
+
+let _ = List.iter register_variable
+  [
+    c_preprocessor;
+    ocamlc_default_flags;
+    ocamlopt_default_flags
+  ]

diff --git a/ocamltest/builtin_variables.mli b/ocamltest/builtin_variables.mli
new file mode 100644 (file)
index 0000000..0b0c8ae
--- /dev/null
+++ b/ocamltest/builtin_variables.mli
@@ -0,0 +1,79 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Sebastien Hinderer, projet Gallium, INRIA Paris            *)
+(*                                                                        *)
+(*   Copyright 2016 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Definition of variables used by built-in actions *)
+
+(* The variables are listed in alphabetical order *)
+
+val arguments : Variables.t
+
+val c_preprocessor : Variables.t
+
+val compiler_directory_suffix : Variables.t
+
+val compiler_reference : Variables.t
+
+val compiler_reference2 : Variables.t
+
+val compiler_reference_suffix : Variables.t
+
+val compiler_output : Variables.t
+
+val compiler_output2 : Variables.t
+
+val files : Variables.t
+
+val flags : Variables.t
+
+val libraries : Variables.t
+
+val modules : Variables.t
+
+val ocamlc_flags : Variables.t
+val ocamlc_default_flags : Variables.t
+
+val ocamlopt_flags : Variables.t
+val ocamlopt_default_flags : Variables.t
+
+val ocaml_byte_exit_status : Variables.t
+
+val ocamlc_byte_exit_status : Variables.t
+
+val ocamlopt_byte_exit_status : Variables.t
+
+val ocaml_opt_exit_status : Variables.t
+
+val ocamlc_opt_exit_status : Variables.t
+
+val ocamlopt_opt_exit_status : Variables.t
+
+val output : Variables.t
+
+val program : Variables.t
+val program2 : Variables.t
+
+val reference : Variables.t
+
+val script : Variables.t
+
+val stdin : Variables.t
+val stdout : Variables.t
+val stderr : Variables.t
+
+val test_build_directory : Variables.t
+
+val test_file : Variables.t
+
+val test_source_directory : Variables.t

diff --git a/ocamltest/environments.ml b/ocamltest/environments.ml
new file mode 100644 (file)
index 0000000..fa239da
--- /dev/null
+++ b/ocamltest/environments.ml
@@ -0,0 +1,107 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Sebastien Hinderer, projet Gallium, INRIA Paris            *)
+(*                                                                        *)
+(*   Copyright 2016 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Definition of environments, used to pass parameters to tests and actions *)
+
+exception Variable_already_defined of Variables.t
+
+module VariableMap = Map.Make (Variables)
+
+type t = string VariableMap.t
+
+let empty = VariableMap.empty
+
+let to_bindings env =
+  let f variable value lst = (variable, value) :: lst in
+  VariableMap.fold f env []
+
+let expand env value =
+
+  let bindings = to_bindings env in
+  let f (variable, value) = ((Variables.name_of_variable variable), value) in
+  let simple_bindings = List.map f bindings in
+  let subst s = try (List.assoc s simple_bindings) with Not_found -> "" in
+  let b = Buffer.create 100 in
+  try Buffer.add_substitute b subst value; Buffer.contents b with _ -> value
+
+let lookup variable env =
+  try Some (expand env (VariableMap.find variable env)) with Not_found -> None
+
+let safe_lookup variable env = match lookup variable env with
+  | None -> ""
+  | Some value -> value
+
+let is_variable_defined variable env =
+  VariableMap.mem variable env
+
+let add variable value env =
+  if VariableMap.mem variable env
+  then raise (Variable_already_defined variable)
+  else VariableMap.add variable value env
+
+let replace variable value environment =
+  VariableMap.add variable value environment
+
+let append variable appened_value environment =
+  let previous_value = safe_lookup variable environment in
+  let new_value = previous_value ^ appened_value in
+  VariableMap.add variable new_value environment
+
+let add_bindings bindings env =
+  let f env (variable, value) = add variable value env in
+  List.fold_left f env bindings
+
+let from_bindings bindings = add_bindings bindings empty
+
+let dump_assignment log (variable, value) =
+  Printf.fprintf log "%s = %s\n%!" (Variables.name_of_variable variable) value
+
+let dump log environment =
+  List.iter (dump_assignment log) (VariableMap.bindings environment);
+
+(* Environment modifiers *)
+
+type modifier =
+  | Include of string
+  | Add of Variables.t * string
+  | Replace of Variables.t * string
+  | Append of Variables.t * string
+
+type modifiers = modifier list
+
+exception Empty_modifiers_name
+exception Modifiers_name_already_registered of string
+exception Modifiers_name_not_found of string
+
+let (registered_modifiers : (string, modifiers) Hashtbl.t) = Hashtbl.create 20
+
+let register modifiers name =
+  if name="" then raise Empty_modifiers_name
+  else if Hashtbl.mem registered_modifiers name
+  then raise (Modifiers_name_already_registered name)
+  else Hashtbl.add registered_modifiers name modifiers
+
+let find_modifiers name =
+  try Hashtbl.find registered_modifiers name
+  with Not_found -> raise (Modifiers_name_not_found name)
+
+let rec apply_modifier environment = function
+  | Include modifiers_name ->
+    apply_modifiers environment (find_modifiers modifiers_name)
+  | Add (variable, value) -> add variable value environment
+  | Replace (variable, value) -> replace variable value environment
+  | Append (variable, value) -> append variable value environment
+and apply_modifiers environment modifiers =
+  List.fold_left apply_modifier environment modifiers

diff --git a/ocamltest/environments.mli b/ocamltest/environments.mli
new file mode 100644 (file)
index 0000000..be19f8e
--- /dev/null
+++ b/ocamltest/environments.mli
@@ -0,0 +1,53 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Sebastien Hinderer, projet Gallium, INRIA Paris            *)
+(*                                                                        *)
+(*   Copyright 2016 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Definition of environments, used to pass parameters to tests and actions *)
+
+exception Variable_already_defined of Variables.t
+
+type t
+
+val empty : t
+
+val from_bindings : (Variables.t * string) list -> t
+val to_bindings : t -> (Variables.t * string) list
+
+val lookup : Variables.t -> t -> string option
+val safe_lookup : Variables.t -> t -> string
+val is_variable_defined : Variables.t -> t -> bool
+
+val add : Variables.t -> string -> t -> t
+val add_bindings : (Variables.t * string) list -> t -> t
+
+val dump : out_channel -> t -> unit
+
+(* Environment modifiers *)
+
+type modifier =
+  | Include of string
+  | Add of Variables.t * string
+  | Replace of Variables.t * string
+  | Append of Variables.t * string
+
+type modifiers = modifier list
+
+val apply_modifier : t -> modifier -> t
+val apply_modifiers : t -> modifiers -> t
+
+exception Empty_modifiers_name
+exception Modifiers_name_already_registered of string
+exception Modifiers_name_not_found of string
+
+val register : modifiers -> string -> unit

diff --git a/ocamltest/filecompare.ml b/ocamltest/filecompare.ml
new file mode 100644 (file)
index 0000000..2fe59c2
--- /dev/null
+++ b/ocamltest/filecompare.ml
@@ -0,0 +1,167 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Sebastien Hinderer, projet Gallium, INRIA Paris            *)
+(*                                                                        *)
+(*   Copyright 2016 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* File comparison tools *)
+
+type result =
+  | Same
+  | Different
+  | Unexpected_output
+  | Error of string * int
+
+type tool =
+  |  External of {
+                   tool_name : string;
+                   tool_flags : string;
+                   result_of_exitcode : string -> int -> result
+                }
+  | Internal of int
+
+let cmp_result_of_exitcode commandline = function
+  | 0 -> Same
+  | 1 -> Different
+  | exit_code -> (Error (commandline, exit_code))
+
+let make_cmp_tool bytes_to_ignore =
+  Internal bytes_to_ignore
+
+let make_comparison_tool ?(result_of_exitcode = cmp_result_of_exitcode)
+                         name flags =
+  External
+    {
+      tool_name = name;
+      tool_flags = flags;
+      result_of_exitcode
+    }
+
+let default_comparison_tool = make_cmp_tool 0
+
+type filetype = Binary | Text
+
+type files = {
+  filetype : filetype;
+  reference_filename : string;
+  output_filename : string;
+}
+
+let read_text_file fn =
+  let ic = open_in_bin fn in
+  let drop_cr s =
+    let l = String.length s in
+    if l > 0 && s.[l - 1] = '\r' then String.sub s 0 (l - 1)
+    else raise Exit
+  in
+  let rec loop acc =
+    match input_line ic with
+    | s -> loop (s :: acc)
+    | exception End_of_file ->
+      close_in ic;
+      try List.rev_map drop_cr acc
+      with Exit -> List.rev acc
+  in
+  loop []
+
+let compare_text_files file1 file2 =
+  if read_text_file file1 = read_text_file file2 then
+    Same
+  else
+    Different
+
+(* Version of Pervasives.really_input which stops at EOF, rather than raising
+   an exception. *)
+let really_input_up_to ic =
+  let block_size = 8192 in
+  let buf = Bytes.create block_size in
+  let rec read pos =
+    let bytes_read = input ic buf pos (block_size - pos) in
+    let new_pos = pos + bytes_read in
+    if bytes_read = 0 || new_pos = block_size then
+      new_pos
+    else
+      read new_pos
+  in
+  let bytes_read = read 0 in
+  if bytes_read = block_size then
+    buf
+  else
+    Bytes.sub buf 0 bytes_read
+
+let compare_binary_files bytes_to_ignore file1 file2 =
+  let ic1 = open_in_bin file1 in
+  let ic2 = open_in_bin file2 in
+  seek_in ic1 bytes_to_ignore;
+  seek_in ic2 bytes_to_ignore;
+  let rec compare () =
+    let block1 = really_input_up_to ic1 in
+    let block2 = really_input_up_to ic2 in
+    if block1 = block2 then
+      if Bytes.length block1 > 0 then
+        compare ()
+      else
+        Same
+    else
+      Different
+  in
+  let result = compare () in
+  close_in ic1;
+  close_in ic2;
+  result
+
+let compare_files ?(tool = default_comparison_tool) files =
+  match tool with
+  | External {tool_name; tool_flags; result_of_exitcode} ->
+      let commandline = String.concat " "
+      [
+        tool_name;
+        tool_flags;
+        files.reference_filename;
+        files.output_filename
+      ] in
+      let dev_null = match Sys.os_type with
+        | "Win32" -> "NUL"
+        | _ -> "/dev/null" in
+      let settings = Run_command.settings_of_commandline
+        ~stdout_fname:dev_null ~stderr_fname:dev_null commandline in
+      let status = Run_command.run settings in
+      result_of_exitcode commandline status
+  | Internal bytes_to_ignore ->
+      match files.filetype with
+        | Text ->
+            (* bytes_to_ignore is silently ignored for text files *)
+            compare_text_files files.reference_filename files.output_filename
+        | Binary ->
+            compare_binary_files bytes_to_ignore
+                                 files.reference_filename files.output_filename
+
+let check_file ?(tool = default_comparison_tool) files =
+  if Sys.file_exists files.reference_filename
+  then compare_files ~tool:tool files
+  else begin
+    if Testlib.file_is_empty files.output_filename
+    then Same
+    else Unexpected_output
+  end
+
+let diff files =
+  let temporary_file = Filename.temp_file "ocamltest" "diff" in
+  let diff_commandline = String.concat " "
+  [
+    "diff -u";
+    files.reference_filename;
+    files.output_filename;
+    "> " ^ temporary_file
+  ] in
+  if (Sys.command diff_commandline) = 2 then Pervasives.Error "diff"
+  else Ok (Testlib.string_of_file temporary_file)

diff --git a/ocamltest/filecompare.mli b/ocamltest/filecompare.mli
new file mode 100644 (file)
index 0000000..c7d8ff6
--- /dev/null
+++ b/ocamltest/filecompare.mli
@@ -0,0 +1,47 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Sebastien Hinderer, projet Gallium, INRIA Paris            *)
+(*                                                                        *)
+(*   Copyright 2016 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* File comparison tools *)
+
+type result =
+  | Same
+  | Different
+  | Unexpected_output
+  | Error of string * int
+
+type tool
+
+val make_cmp_tool : int -> tool
+
+val make_comparison_tool :
+  ?result_of_exitcode:(string -> int -> result) -> string -> string -> tool
+
+val default_comparison_tool : tool
+
+type filetype = Binary | Text
+
+type files = {
+  filetype : filetype;
+  reference_filename : string;
+  output_filename : string;
+}
+
+val compare_files : ?tool:tool -> files -> result
+
+val check_file : ?tool:tool -> files -> result
+
+val cmp_result_of_exitcode : string -> int -> result
+
+val diff : files -> (string, string) Pervasives.result

diff --git a/ocamltest/filetype.ml b/ocamltest/filetype.ml
new file mode 100644 (file)
index 0000000..ba62596
--- /dev/null
+++ b/ocamltest/filetype.ml
@@ -0,0 +1,69 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Sebastien Hinderer, projet Gallium, INRIA Paris            *)
+(*                                                                        *)
+(*   Copyright 2016 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Types of input files involved in an OCaml project and related functions *)
+
+type t =
+  | Implementation
+  | Interface
+  | C
+  | C_minus_minus
+  | Lexer
+  | Grammar
+
+let string_of_filetype = function
+  | Implementation -> "implementation"
+  | Interface -> "interface"
+  | C -> "C source file"
+  | C_minus_minus -> "C minus minus source file"
+  | Lexer -> "lexer"
+  | Grammar -> "grammar"
+
+let extension_of_filetype = function
+  | Implementation -> "ml"
+  | Interface -> "mli"
+  | C -> "c"
+  | C_minus_minus -> "cmm"
+  | Lexer -> "mll"
+  | Grammar -> "mly"
+
+let filetype_of_extension = function
+  | "ml" -> Implementation
+  | "mli" -> Interface
+  | "c" -> C
+  | "cmm" -> C_minus_minus
+  | "mll" -> Lexer
+  | "mly" -> Grammar
+  | _ -> raise Not_found
+
+let split_filename name =
+  let l = String.length name in
+  let is_dir_sep name i = name.[i] = Filename.dir_sep.[0] in
+  let rec search_dot i =
+    if i < 0 || is_dir_sep name i then (name, "")
+    else if name.[i] = '.' then
+      let basename = String.sub name 0 i in
+      let extension = String.sub name (i+1) (l-i-1) in
+      (basename, extension)
+    else search_dot (i - 1) in
+  search_dot (l - 1)
+
+let filetype filename =
+  let (basename, extension) = split_filename filename in
+  (basename, filetype_of_extension extension)
+
+let make_filename (basename, filetype) =
+  let extension = extension_of_filetype filetype in
+  basename ^ "." ^ extension

diff --git a/ocamltest/filetype.mli b/ocamltest/filetype.mli
new file mode 100644 (file)
index 0000000..69db0e2
--- /dev/null
+++ b/ocamltest/filetype.mli
@@ -0,0 +1,36 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Sebastien Hinderer, projet Gallium, INRIA Paris            *)
+(*                                                                        *)
+(*   Copyright 2016 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Types of input files involved in an OCaml project and related functions *)
+
+type t =
+  | Implementation
+  | Interface
+  | C
+  | C_minus_minus
+  | Lexer
+  | Grammar
+
+val string_of_filetype : t -> string
+
+val extension_of_filetype : t -> string
+
+val filetype_of_extension : string -> t
+
+val split_filename : string -> string * string
+
+val filetype : string -> string * t
+
+val make_filename : string * t -> string

diff --git a/ocamltest/getocamloptdefaultflags b/ocamltest/getocamloptdefaultflags
new file mode 100755 (executable)
index 0000000..8d835ee
--- /dev/null
+++ b/ocamltest/getocamloptdefaultflags
@@ -0,0 +1,26 @@
+#!/bin/sh
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*            Sebastien Hinderer, projet Gallium, INRIA Paris             *
+#*                                                                        *
+#*   Copyright 2016 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+# This script provides command-line options to use by default
+# when invoking ocamlopt
+
+# It is used to add that disable annoying linker warnings on some versions
+# of OpenBSD
+
+case "$1" in
+  i386-*-openbsd5.[5-9]*|i386-*-openbsd[6-9].*)
+    echo "-ccopt -nopie";;
+esac

diff --git a/ocamltest/main.ml b/ocamltest/main.ml
new file mode 100644 (file)
index 0000000..21ca874
--- /dev/null
+++ b/ocamltest/main.ml
@@ -0,0 +1,146 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Sebastien Hinderer, projet Gallium, INRIA Paris            *)
+(*                                                                        *)
+(*   Copyright 2016 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Main program of the ocamltest test driver *)
+
+open Tsl_semantics
+
+(*
+let first_token filename =
+  let input_channel = open_in filename in
+  let lexbuf = Lexing.from_channel input_channel in
+  Location.init lexbuf filename;
+  let token =
+    try Tsl_lexer.token lexbuf with e -> close_in input_channel; raise e
+  in close_in input_channel; token
+
+let is_test filename =
+  match first_token filename with
+    | exception _ -> false
+    | Tsl_parser.TSL_BEGIN -> true
+    | _ -> false
+*)
+
+let tsl_block_of_file test_filename =
+  let input_channel = open_in test_filename in
+  let lexbuf = Lexing.from_channel input_channel in
+  Location.init lexbuf test_filename;
+  match Tsl_parser.tsl_block Tsl_lexer.token lexbuf with
+    | exception e -> close_in input_channel; raise e
+    | _ as tsl_block -> close_in input_channel; tsl_block
+
+let tsl_block_of_file_safe test_filename =
+  try tsl_block_of_file test_filename with
+  | Sys_error message ->
+    Printf.eprintf "%s\n" message;
+    exit 1
+  | Parsing.Parse_error ->
+    Printf.eprintf "Could not read test block in %s\n" test_filename;
+    exit 1
+
+let print_usage () =
+  Printf.printf "%s\n%!" Options.usage
+
+let rec run_test log common_prefix path ancestor_result = function
+  Node (testenvspec, test, env_modifiers, subtrees) ->
+  Printf.printf "%s %s (%s) => %!" common_prefix path test.Tests.test_name;
+  let print_test_result str = Printf.printf "%s\n%!" str in
+  let test_result = match ancestor_result with
+    | Actions.Pass env -> (* Ancestor succeded, really run the test *)
+      let testenv0 = interprete_environment_statements env testenvspec in
+      let testenv = List.fold_left apply_modifiers testenv0 env_modifiers in
+      Tests.run log testenv test
+    | Actions.Skip _ -> (Actions.Skip "ancestor test skipped")
+    | Actions.Fail _ -> (Actions.Skip "ancestor test failed") in
+  let result_to_pass = match test_result with
+    | Actions.Pass _ ->
+      print_test_result "passed";
+      test_result
+    | Actions.Fail _ ->
+      print_test_result "failed";
+      ancestor_result
+    | Actions.Skip _ ->
+      print_test_result "skipped";
+      ancestor_result in
+  List.iteri (run_test_i log common_prefix path result_to_pass) subtrees
+and run_test_i log common_prefix path ancestor_result i test_tree =
+  let path_prefix = if path="" then "" else path ^ "." in
+  let new_path = Printf.sprintf "%s%d" path_prefix (i+1) in
+  run_test log common_prefix new_path ancestor_result test_tree
+
+let get_test_source_directory test_dirname =
+  if not (Filename.is_relative test_dirname) then test_dirname
+  else let pwd = Sys.getcwd() in
+  Filename.concat pwd test_dirname
+
+let get_test_build_directory test_dirname =
+  let ocamltestdir_variable = "OCAMLTESTDIR" in
+  let root = try Sys.getenv ocamltestdir_variable with
+    | Not_found -> (Filename.concat (Sys.getcwd ()) "_ocamltest") in
+  if test_dirname = "." then root
+  else Filename.concat root test_dirname
+
+let main () =
+  if !Options.testfile = "" then begin
+    print_usage();
+    exit 1
+  end;
+  let test_filename = !Options.testfile in
+  (* Printf.printf "# reading test file %s\n%!" test_filename; *)
+  let tsl_block = tsl_block_of_file_safe test_filename in
+  let (rootenv_statements, test_trees) = test_trees_of_tsl_block tsl_block in
+  let test_trees = match test_trees with
+    | [] ->
+      let default_tests = Tests.default_tests() in
+      let make_tree test = Node ([], test, [], []) in
+      List.map make_tree default_tests
+    | _ -> test_trees in
+  let actions = actions_in_tests (tests_in_trees test_trees) in
+  let test_dirname = Filename.dirname test_filename in
+  let test_basename = Filename.basename test_filename in
+  let test_prefix = Filename.chop_extension test_basename in
+  let test_directory =
+    if test_dirname="." then test_prefix
+    else Filename.concat test_dirname test_prefix in
+  let test_source_directory = get_test_source_directory test_dirname in
+  let test_build_directory = get_test_build_directory test_directory in
+  let reference_filename = Filename.concat
+    test_source_directory (test_prefix ^ ".reference") in
+  let initial_environment = Environments.from_bindings
+  [
+    Builtin_variables.c_preprocessor, Ocamltest_config.c_preprocessor;
+    Builtin_variables.ocamlc_default_flags,
+      Ocamltest_config.ocamlc_default_flags;
+    Builtin_variables.ocamlopt_default_flags,
+      Ocamltest_config.ocamlopt_default_flags;
+    Builtin_variables.test_file, test_basename;
+    Builtin_variables.reference, reference_filename;
+    Builtin_variables.test_source_directory, test_source_directory;
+    Builtin_variables.test_build_directory, test_build_directory;
+  ] in
+  let root_environment =
+    interprete_environment_statements initial_environment rootenv_statements in
+  let rootenv = Actions.update_environment root_environment actions in
+  Testlib.make_directory test_build_directory;
+  Sys.chdir test_build_directory;
+  let log_filename = test_prefix ^ ".log" in
+  let log = open_out log_filename in
+  let common_prefix = " ... testing '" ^ test_basename ^ "' with" in
+  List.iteri
+    (run_test_i log common_prefix "" (Actions.Pass rootenv))
+    test_trees;
+  close_out log
+
+let _ = main()

diff --git a/ocamltest/main.mli b/ocamltest/main.mli
new file mode 100644 (file)
index 0000000..6d84084
--- /dev/null
+++ b/ocamltest/main.mli
@@ -0,0 +1,19 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Sebastien Hinderer, projet Gallium, INRIA Paris            *)
+(*                                                                        *)
+(*   Copyright 2016 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Interface for the main program of the test driver *)
+
+(* Nothing is exported. This file exists merely so that every
+ * .ml has a corresponding interface *)

diff --git a/ocamltest/ocamltest_config.ml.in b/ocamltest/ocamltest_config.ml.in
new file mode 100644 (file)
index 0000000..05f4b1e
--- /dev/null
+++ b/ocamltest/ocamltest_config.ml.in
@@ -0,0 +1,29 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Sebastien Hinderer, projet Gallium, INRIA Paris            *)
+(*                                                                        *)
+(*   Copyright 2016 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* The configuration module for ocamltest *)
+
+let arch = "@@ARCH@@"
+
+let c_preprocessor = "@@CPP@@"
+
+let ocamlsrcdir = "@@OCAMLSRCDIR@@"
+
+let flambda = @@FLAMBDA@@
+
+let ocamlc_default_flags = "@@OCAMLCDEFAULTFLAGS@@"
+let ocamlopt_default_flags = "@@OCAMLOPTDEFAULTFLAGS@@"
+
+let safe_string = @@FORCE_SAFE_STRING@@

diff --git a/ocamltest/ocamltest_config.mli b/ocamltest/ocamltest_config.mli
new file mode 100644 (file)
index 0000000..51531c9
--- /dev/null
+++ b/ocamltest/ocamltest_config.mli
@@ -0,0 +1,38 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Sebastien Hinderer, projet Gallium, INRIA Paris            *)
+(*                                                                        *)
+(*   Copyright 2017 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Interface for ocamltest's configuration module *)
+
+val arch : string
+(** Architecture for the native compiler, "none" if it is disabled *)
+
+val c_preprocessor : string
+(** Command to use to invoke the C preprocessor *)
+
+
+val ocamlc_default_flags : string
+(** Flags passed by default to ocamlc.byte and ocamlc.opt *)
+
+val ocamlopt_default_flags : string
+(** Flags passed by default to ocamlopt.byte and ocamlopt.opt *)
+
+val ocamlsrcdir : string
+(** The absolute path of the directory containing the sources of OCaml *)
+
+val flambda : bool
+(** Whether flambda has been enabled at configure time *)
+
+val safe_string : bool
+(** Whether the compiler was configured with -safe-string *)

diff --git a/ocamltest/options.ml b/ocamltest/options.ml
new file mode 100644 (file)
index 0000000..04b2fbb
--- /dev/null
+++ b/ocamltest/options.ml
@@ -0,0 +1,57 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Sebastien Hinderer, projet Gallium, INRIA Paris            *)
+(*                                                                        *)
+(*   Copyright 2016 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Description of ocamltest's command-line options *)
+
+let show_objects title string_of_object objects =
+  let print_object o = print_endline ("  " ^ (string_of_object o)) in
+  print_endline title;
+  List.iter print_object objects;
+  exit 0
+
+let string_of_action action = action.Actions.action_name
+
+let string_of_test test =
+  if test.Tests.test_run_by_default
+  then (test.Tests.test_name ^ " (run by default)")
+  else test.Tests.test_name
+
+let show_actions () =
+  let actions = Actions.get_registered_actions () in
+  show_objects "Available actions are:" string_of_action actions
+
+let show_tests () =
+  let tests = Tests.get_registered_tests () in
+  show_objects "Available tests are:" string_of_test tests
+
+let commandline_options =
+[
+  ("-show-actions", Arg.Unit show_actions, "Show available actions.");
+  ("-show-tests", Arg.Unit show_tests, "Show available tests.");
+]
+
+let testfile = ref ""
+
+let set_testfile name =
+  if !testfile<> "" then
+  begin
+    Printf.eprintf "Can't deal with more than one test file at the moment\n%!";
+    exit 1
+  end else testfile := name
+
+let usage = "Usage: " ^ Sys.argv.(0) ^ " options testfile"
+
+let _ =
+  Arg.parse commandline_options set_testfile usage

diff --git a/ocamltest/options.mli b/ocamltest/options.mli
new file mode 100644 (file)
index 0000000..57fe7a3
--- /dev/null
+++ b/ocamltest/options.mli
@@ -0,0 +1,20 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Sebastien Hinderer, projet Gallium, INRIA Paris            *)
+(*                                                                        *)
+(*   Copyright 2016 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Description of ocamltest's command-line options *)
+
+val testfile : string ref
+
+val usage : string

diff --git a/ocamltest/run.h b/ocamltest/run.h
new file mode 100644 (file)
index 0000000..348d16d
--- /dev/null
+++ b/ocamltest/run.h
@@ -0,0 +1,44 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Sebastien Hinderer, projet Gallium, INRIA Paris            */
+/*                                                                        */
+/*   Copyright 2016 Institut National de Recherche en Informatique et     */
+/*     en Automatique.                                                    */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+/* Header file for the run library */
+
+#ifndef __RUN_H__
+
+#define __RUN_H__
+
+#include <stdarg.h>
+#include <caml/misc.h>
+
+typedef char_os **array;
+
+typedef void Logger(void *, const char *, va_list ap);
+
+typedef struct {
+  char_os *program;
+  array argv;
+  /* array envp; */
+  char_os *stdin_filename;
+  char_os *stdout_filename;
+  char_os *stderr_filename;
+  int append;
+  int timeout;
+  Logger *logger;
+  void *loggerData;
+} command_settings;
+
+extern int run_command(const command_settings *settings);
+
+#endif /* __RUN_H__ */

diff --git a/ocamltest/run_command.ml b/ocamltest/run_command.ml
new file mode 100644 (file)
index 0000000..55b4b13
--- /dev/null
+++ b/ocamltest/run_command.ml
@@ -0,0 +1,49 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Sebastien Hinderer, projet Gallium, INRIA Paris            *)
+(*                                                                        *)
+(*   Copyright 2016 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Run programs and log their stdout/stderr, with a timer... *)
+
+type settings = {
+  progname : string;
+  argv : string array;
+  (* envp : string array; *)
+  stdin_filename : string;
+  stdout_filename : string;
+  stderr_filename : string;
+  append : bool;
+  timeout : int;
+  log : out_channel;
+}
+
+let settings_of_commandline ?(stdout_fname="") ?(stderr_fname="") commandline =
+  let words = Testlib.words commandline in
+  let quoted_words =
+    if Sys.os_type="Win32"
+    then List.map Testlib.maybe_quote words
+    else words in
+  {
+    progname = List.hd quoted_words;
+    argv = Array.of_list quoted_words;
+    stdin_filename = "";
+    stdout_filename = stdout_fname;
+    stderr_filename = stderr_fname;
+    append = false;
+    timeout = 0;
+    log = stderr
+  }
+
+external run : settings -> int = "caml_run_command"
+
+let run_commandline commandline = run (settings_of_commandline commandline)

diff --git a/ocamltest/run_command.mli b/ocamltest/run_command.mli
new file mode 100644 (file)
index 0000000..9fcdadb
--- /dev/null
+++ b/ocamltest/run_command.mli
@@ -0,0 +1,37 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Sebastien Hinderer, projet Gallium, INRIA Paris            *)
+(*                                                                        *)
+(*   Copyright 2016 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Run programs and log their stdout/stderr, with a timer... *)
+
+type settings = {
+  progname : string;
+  argv : string array;
+  (* envp : string array; *)
+  stdin_filename : string;
+  stdout_filename : string;
+  stderr_filename : string;
+  append : bool;
+  timeout : int;
+  log : out_channel;
+}
+
+val settings_of_commandline :
+  ?stdout_fname:string ->
+  ?stderr_fname:string ->
+  string -> settings
+
+val run : settings -> int
+
+val run_commandline : string -> int

diff --git a/ocamltest/run_common.h b/ocamltest/run_common.h
new file mode 100644 (file)
index 0000000..fdedd86
--- /dev/null
+++ b/ocamltest/run_common.h
@@ -0,0 +1,59 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Sebastien Hinderer, projet Gallium, INRIA Paris            */
+/*                                                                        */
+/*   Copyright 2016 Institut National de Recherche en Informatique et     */
+/*     en Automatique.                                                    */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+/* Private definitions shared by both Unix and Windows process runners */
+
+#ifndef __RUN_COMMON_H__
+#define __RUN_COMMON_H__
+
+/* is_defined(str) returns 1 iff str points to a non-empty string */
+/* Otherwise returns 0 */
+static int is_defined(const char_os *str)
+{
+  return (str != NULL) && (*str != 0);
+}
+
+static void defaultLogger(void *where, const char *format, va_list ap)
+{
+  vfprintf(stderr, format, ap);
+}
+
+static void mylog(Logger *logger, void *loggerData, char *fmt, ...)
+{
+  va_list ap;
+  va_start(ap, fmt);
+  logger(loggerData, fmt, ap);
+  va_end(ap);
+}
+
+static void error_with_location(
+  const char *file, int line,
+  const command_settings *settings,
+  const char *msg, ...)
+{
+  va_list ap;
+  Logger *logger = (settings->logger != NULL) ? settings->logger
+                                              : defaultLogger;
+  void *loggerData = settings->loggerData;
+  va_start(ap, msg);
+  mylog(logger, loggerData, "%s:%d: ", file, line);
+  logger(loggerData, msg, ap);
+  mylog(logger, loggerData, "\n");
+  va_end(ap);
+}
+
+
+
+#endif /* __RUN_COMMON_H__ */

diff --git a/ocamltest/run_stubs.c b/ocamltest/run_stubs.c
new file mode 100644 (file)
index 0000000..9505b07
--- /dev/null
+++ b/ocamltest/run_stubs.c
@@ -0,0 +1,103 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Sebastien Hinderer, projet Gallium, INRIA Paris            */
+/*                                                                        */
+/*   Copyright 2016 Institut National de Recherche en Informatique et     */
+/*     en Automatique.                                                    */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+/* Stubs to let OCaml programs use the run library */
+
+#define _GNU_SOURCE
+
+#include <stdio.h>
+#include <stdlib.h>
+#include <stdarg.h>
+#include <sys/types.h>
+#include <string.h>
+
+#include "run.h"
+
+#include "caml/mlvalues.h"
+#include "caml/memory.h"
+#include "caml/io.h"
+#include "caml/osdeps.h"
+
+/* cstringvect: inspired by similar function in otherlibs/unix/cstringv.c */
+static array cstringvect(value arg)
+{
+  array res;
+  mlsize_t size, i;
+
+  size = Wosize_val(arg);
+  res = (array) caml_stat_alloc((size + 1) * sizeof(char_os *));
+  for (i = 0; i < size; i++)
+    res[i] = caml_stat_strdup_to_os(String_val(Field(arg, i)));
+  res[size] = NULL;
+  return res;
+}
+
+static void free_cstringvect(array v)
+{
+  char_os **p;
+  for (p = v; *p != NULL; p++)
+    caml_stat_free(*p);
+  caml_stat_free(v);
+}
+
+static void logToChannel(void *voidchannel, const char *fmt, va_list ap)
+{
+  struct channel *channel = (struct channel *) voidchannel;
+  int length, initialTextLength = 512;
+  char *text = malloc(512);
+  if (text == NULL) return;
+  length = vsnprintf(text, initialTextLength, fmt, ap);
+  if (length <= 0)
+  {
+    free(text);
+    return;
+  }
+  if (length > initialTextLength)
+  {
+    free(text);
+    text = malloc(length);
+    if (text == NULL) return;
+    if (vsnprintf(text, length, fmt, ap) != length) goto end;
+  }
+  caml_putblock(channel, text, length);
+  caml_flush(channel);
+end:
+  free(text);
+}
+
+CAMLprim value caml_run_command(value caml_settings)
+{
+  int res;
+  command_settings settings;
+
+  CAMLparam1(caml_settings);
+  settings.program = caml_stat_strdup_to_os(String_val(Field(caml_settings, 0)));
+  settings.argv = cstringvect(Field(caml_settings, 1));
+  /* settings.envp = cstringvect(Field(caml_settings, 2)); */
+  settings.stdin_filename = caml_stat_strdup_to_os(String_val(Field(caml_settings, 2)));
+  settings.stdout_filename = caml_stat_strdup_to_os(String_val(Field(caml_settings, 4)));
+  settings.stderr_filename = caml_stat_strdup_to_os(String_val(Field(caml_settings, 4)));
+  settings.append = Bool_val(Field(caml_settings, 5));
+  settings.timeout = Int_val(Field(caml_settings, 6));
+  settings.logger = logToChannel;
+  settings.loggerData = Channel(Field(caml_settings, 7));
+  res = run_command(&settings);
+  caml_stat_free(settings.program);
+  free_cstringvect(settings.argv);
+  caml_stat_free(settings.stdin_filename);
+  caml_stat_free(settings.stdout_filename);
+  caml_stat_free(settings.stderr_filename);
+  CAMLreturn(Val_int(res));
+}

diff --git a/ocamltest/run_unix.c b/ocamltest/run_unix.c
new file mode 100644 (file)
index 0000000..5416016
--- /dev/null
+++ b/ocamltest/run_unix.c
@@ -0,0 +1,279 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Sebastien Hinderer, projet Gallium, INRIA Paris            */
+/*                                                                        */
+/*   Copyright 2016 Institut National de Recherche en Informatique et     */
+/*     en Automatique.                                                    */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+/* Run programs with rediretions and timeouts under Unix */
+
+#include <stdio.h>
+#include <limits.h>
+#include <stdlib.h>
+#include <sys/types.h>
+#include <sys/wait.h>
+#include <unistd.h>
+#include <fcntl.h>
+#include <string.h>
+#include <errno.h>
+#include <stdarg.h>
+#include <signal.h>
+
+#include "run.h"
+#include "run_common.h"
+
+#define COREFILENAME "core"
+
+static volatile int timeout_expired = 0;
+
+#define error(msg, ...) \
+error_with_location(__FILE__, __LINE__, settings, msg, ## __VA_ARGS__)
+
+/*
+  Note: the ## __VA_ARGS__ construct is gcc specific.
+  For a more portable (but also more complex) solution, see
+  http://stackoverflow.com/questions/20818800/variadic-macro-and-trailing-comma
+*/
+
+static void myperror_with_location(
+  const char *file, int line,
+  const command_settings *settings,
+  const char *msg, ...)
+{
+  va_list ap;
+  Logger *logger = (settings->logger != NULL) ? settings->logger
+                                              : defaultLogger;
+  void *loggerData = settings->loggerData;
+  va_start(ap, msg);
+  mylog(logger, loggerData, "%s:%d: ", file, line);
+  logger(loggerData, msg, ap);
+  mylog(logger, loggerData, ": %s\n", strerror(errno));
+  va_end(ap);
+}
+
+#define myperror(msg, ...) \
+myperror_with_location(__FILE__, __LINE__, settings, msg, ## __VA_ARGS__)
+
+/* Same remark as for the error macro. */
+
+static void open_error_with_location(
+  const char *file, int line,
+  const command_settings *settings,
+  const char *msg)
+{
+  myperror_with_location(file, line, settings, "Can not open %s", msg);
+}
+
+#define open_error(filename) \
+open_error_with_location(__FILE__, __LINE__, settings, filename)
+
+static void realpath_error_with_location(
+  const char *file, int line,
+  const command_settings *settings,
+  const char *msg)
+{
+  myperror_with_location(file, line, settings, "realpath(\"%s\") failed", msg);
+}
+
+#define realpath_error(filename) \
+realpath_error_with_location(__FILE__, __LINE__, settings, filename)
+
+static void handle_alarm(int sig)
+{
+  timeout_expired = 1;
+}
+
+static int paths_same_file(
+  const command_settings *settings, const char * path1, const char * path2)
+{
+  int same_file = 0;
+#ifdef __GLIBC__
+  char *realpath1, *realpath2;
+  realpath1 = realpath(path1, NULL);
+  if (realpath1 == NULL)
+    realpath_error(path1);
+  realpath2 = realpath(path2, NULL);
+  if ( (realpath2 == NULL)  && (errno != ENOENT) )
+  {
+    free(realpath1);
+    realpath_error(path2);
+  }
+#else
+  char realpath1[PATH_MAX], realpath2[PATH_MAX];
+  if (realpath(path1, realpath1) == NULL)
+    realpath_error(path1);
+    if ((realpath(path2, realpath2) == NULL) && (errno != ENOENT))
+      realpath_error(path2);
+#endif /* __GLIBC__ */
+  if (strcmp(realpath1, realpath2) == 0)
+    same_file = 1;
+#ifdef __GLIBC__
+  free(realpath1);
+  free(realpath2);
+#endif /* __GLIBC__ */
+  return same_file;
+}
+
+static int run_command_child(const command_settings *settings)
+{
+  int res;
+  int stdin_fd = -1, stdout_fd = -1, stderr_fd = -1; /* -1 = no redir */
+  int inputFlags = O_RDONLY;
+  int outputFlags =
+    O_CREAT | O_WRONLY | (settings->append ? O_APPEND : O_TRUNC);
+  int inputMode = 0400, outputMode = 0666;
+
+  if (setpgid(0, 0) == -1) myperror("setpgid");
+
+  if (is_defined(settings->stdin_filename))
+  {
+    stdin_fd = open(settings->stdin_filename, inputFlags, inputMode);
+    if (stdin_fd < 0)
+      open_error(settings->stdin_filename);
+    if ( dup2(stdin_fd, STDIN_FILENO) == -1 )
+      myperror("dup2 for stdin");
+  }
+
+  if (is_defined(settings->stdout_filename))
+  {
+    stdout_fd = open(settings->stdout_filename, outputFlags, outputMode);
+    if (stdout_fd < 0)
+      open_error(settings->stdout_filename);
+    if ( dup2(stdout_fd, STDOUT_FILENO) == -1 )
+      myperror("dup2 for stdout");
+  }
+
+  if (is_defined(settings->stderr_filename))
+  {
+    if (stdout_fd != -1)
+    {
+      if (paths_same_file(
+        settings, settings->stdout_filename,settings->stderr_filename))
+        stderr_fd = stdout_fd;
+    }
+    if (stderr_fd == -1)
+    {
+      stderr_fd = open(settings->stderr_filename, outputFlags, outputMode);
+      if (stderr_fd == -1) open_error(settings->stderr_filename);
+    }
+    if ( dup2(stderr_fd, STDERR_FILENO) == -1 )
+      myperror("dup2 for stderr");
+  }
+
+  res = execvp(settings->program, settings->argv); /* , settings->envp); */
+
+  myperror("Cannot execute %s", settings->program);
+  return res;
+}
+
+/* Handles the termination of a process. Arguments:
+ * The pid of the terminated process
+ * Its termination status as returned by wait(2)
+ * A string giving a prefix for the core file name.
+   (the file will be called prefix.pid.core but may come from a
+   diffferent process)
+ * Returns the code to return if this is the child process
+ */
+static int handle_process_termination(
+  const command_settings *settings,
+  pid_t pid, int status, const char *corefilename_prefix)
+{
+  int signal, core = 0;
+  char *corestr;
+
+  if (WIFEXITED(status)) return WEXITSTATUS(status);
+
+  if ( !WIFSIGNALED(status) )
+    error("Process %d neither terminated normally nor received a" \
+          "signal!?", pid);
+
+  /* From here we know that the process terminated due to a signal */
+  signal = WTERMSIG(status);
+#ifdef WCOREDUMP
+  core = WCOREDUMP(status);
+#endif /* WCOREDUMP */
+  corestr = core ? "" : "no ";
+  fprintf(stderr,
+    "Process %d got signal %d(%s), %score dumped\n",
+    pid, signal, strsignal(signal), corestr
+  );
+
+  if (core)
+  {
+    if ( access(COREFILENAME, F_OK) == -1)
+      fprintf(stderr, "Could not find core file.\n");
+    else {
+      char corefile[strlen(corefilename_prefix) + 128];
+      snprintf(corefile, sizeof(corefile),
+        "%s.%d.core", corefilename_prefix, pid);
+      if ( rename(COREFILENAME, corefile) == -1)
+        fprintf(stderr, "The core file exists but could not be renamed.\n");
+      else
+        fprintf(stderr,"The core file has been renamed to %s\n", corefile);
+    }
+  }
+
+  return -signal;
+}
+
+static int run_command_parent(const command_settings *settings, pid_t child_pid)
+{
+  int waiting = 1, status, code, child_code = 0;
+  pid_t pid;
+
+  if (settings->timeout>0)
+  {
+    struct sigaction action;
+    action.sa_handler = handle_alarm;
+    sigemptyset(&action.sa_mask);
+    action.sa_flags = SA_RESETHAND;
+    if (sigaction(SIGALRM, &action, NULL) == -1) myperror("sigaction");
+    if (alarm(settings->timeout) == -1) myperror("alarm");
+  }
+
+  while (waiting)
+  {
+    pid = wait(&status);
+    if (pid == -1)
+    {
+      switch (errno)
+      {
+        case EINTR:
+          if ((settings->timeout > 0) && (timeout_expired))
+          {
+            timeout_expired = 0;
+            fprintf(stderr, "Timeout expired, killing all child processes");
+            if (kill(-child_pid, SIGKILL) == -1) myperror("kill");
+          };
+          break;
+        case ECHILD:
+          waiting = 0;
+          break;
+        default:
+          myperror("wait");
+      }
+    } else { /* Got a pid */
+      code = handle_process_termination(
+        settings, pid, status, settings->program);
+      if (pid == child_pid) child_code = code;
+    }
+  }
+
+  return child_code;
+}
+
+int run_command(const command_settings *settings)
+{
+  pid_t child_pid = fork();
+  if (child_pid == -1) myperror("fork");
+  if (child_pid == 0) return run_command_child(settings);
+  else return run_command_parent(settings, child_pid);
+}

diff --git a/ocamltest/run_win32.c b/ocamltest/run_win32.c
new file mode 100644 (file)
index 0000000..b60e5da
--- /dev/null
+++ b/ocamltest/run_win32.c
@@ -0,0 +1,303 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Sebastien Hinderer, projet Gallium, INRIA Paris            */
+/*                                                                        */
+/*   Copyright 2016 Institut National de Recherche en Informatique et     */
+/*     en Automatique.                                                    */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+/* Run programs with rediretions and timeouts under Windows */
+
+#include <stdio.h>
+#include <stdlib.h>
+#include <wtypes.h>
+#include <winbase.h>
+#include <windows.h>
+#include <process.h>
+#include <string.h>
+#include <errno.h>
+#include <stdarg.h>
+#include <sys/types.h>
+
+#include "caml/osdeps.h"
+
+#include "run.h"
+#include "run_common.h"
+
+static void report_error(
+  const char *file, int line,
+  const command_settings *settings,
+  const char *message, const WCHAR *argument)
+{
+  WCHAR error_message[1024];
+  DWORD error = GetLastError();
+  char *error_message_c;
+  FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, NULL, error, 0,
+                error_message, sizeof(error_message)/sizeof(WCHAR), NULL);
+  error_message_c = caml_stat_strdup_of_utf16(error_message);
+  if ( is_defined(argument) )
+    error_with_location(file, line,
+      settings, "%s %s: %s", message, argument, error_message_c);
+  else
+    error_with_location(file, line,
+      settings, "%s: %s", message, error_message_c);
+  caml_stat_free(error_message_c);
+}
+
+static WCHAR *find_program(const WCHAR *program_name)
+{
+  int max_path_length = 512;
+  DWORD result;
+  LPCWSTR searchpath = NULL, extension = L".exe";
+  WCHAR **filepart = NULL;
+  WCHAR *fullpath = malloc(max_path_length*sizeof(WCHAR));
+  if (fullpath == NULL) return NULL;
+
+  result = SearchPath
+  (
+    searchpath,
+    program_name,
+    extension,
+    max_path_length,
+    fullpath,
+    filepart
+  );
+  if (result == 0)
+  {
+    /* It may be an absolute path, return a copy of it */
+    int l = wcslen(program_name) + 1;
+    free(fullpath);
+    fullpath = malloc(l*sizeof(WCHAR));
+    if (fullpath != NULL) wcscpy(fullpath, program_name);
+    return fullpath;
+  }
+  if (result <= max_path_length) return fullpath;
+
+  /* fullpath was too small, allocate a bigger one */
+  free(fullpath);
+
+  result++; /* Take '\0' into account */
+
+  fullpath = malloc(result*sizeof(WCHAR));
+  if (fullpath == NULL) return NULL;
+  SearchPath
+  (
+    searchpath,
+    program_name,
+    extension,
+    result,
+    fullpath,
+    filepart
+  );
+  return fullpath;
+}
+
+static WCHAR *commandline_of_arguments(WCHAR **arguments)
+{
+  WCHAR *commandline = NULL, **arguments_p, *commandline_p;
+  int args = 0; /* Number of arguments */
+  int commandline_length = 0;
+
+  if (*arguments == NULL) return NULL;
+  /* From here we know there is at least one argument */
+
+  /* First compute number of arguments and commandline length */
+  for (arguments_p = arguments; *arguments_p != NULL; arguments_p++)
+  {
+    args++;
+    commandline_length += wcslen(*arguments_p);
+  }
+  commandline_length += args; /* args-1 ' ' between arguments + final '\0' */
+
+  /* Allocate memory and accumulate arguments separated by spaces */
+  commandline = malloc(commandline_length*sizeof(WCHAR));
+  if (commandline == NULL) return NULL;
+  commandline_p = commandline;
+  for (arguments_p = arguments; *arguments_p!=NULL; arguments_p++)
+  {
+    int l = wcslen(*arguments_p);
+    memcpy(commandline_p, *arguments_p, l*sizeof(WCHAR));
+    commandline_p += l;
+    *commandline_p = L' ';
+    commandline_p++;
+  }
+  commandline[commandline_length-1] = 0;
+  return commandline;
+}
+
+static SECURITY_ATTRIBUTES security_attributes = {
+  sizeof(SECURITY_ATTRIBUTES), /* nLength */
+  NULL, /* lpSecurityDescriptor */
+  TRUE /* bInheritHandle */
+};
+
+static HANDLE create_input_handle(const WCHAR *filename)
+{
+  return CreateFile
+  (
+    filename,
+    GENERIC_READ, /* DWORD desired_access */
+    FILE_SHARE_READ, /* DWORD share_mode */
+    &security_attributes,
+    OPEN_EXISTING, /* DWORD creation_disposition */
+    FILE_ATTRIBUTE_NORMAL, /* DWORD flags_and_attributes */
+    NULL /* HANDLE template_file */
+  );
+}
+
+static HANDLE create_output_handle(const WCHAR *filename, int append)
+{
+  DWORD desired_access = append ? FILE_APPEND_DATA : GENERIC_WRITE;
+  DWORD share_mode = FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE;
+  DWORD creation_disposition = append ? OPEN_ALWAYS : CREATE_ALWAYS;
+  return CreateFile
+  (
+    filename,
+    desired_access,
+    share_mode,
+    &security_attributes,
+    creation_disposition,
+    FILE_ATTRIBUTE_NORMAL, /* DWORD flags_and_attributes */
+    NULL /* HANDLE template_file */
+  );
+}
+
+#define checkerr(condition, message, argument) \
+if ( (condition) ) \
+{ \
+  report_error(__FILE__, __LINE__, settings, message, argument); \
+  status = -1; \
+  goto cleanup; \
+} else { }
+
+int run_command(const command_settings *settings)
+{
+  BOOL process_created = FALSE;
+  int stdin_redirected = 0, stdout_redirected = 0, stderr_redirected = 0;
+  int combined = 0; /* 1 if stdout and stderr are redirected to the same file */
+  int wait_again = 0;
+  WCHAR *program = NULL;
+  WCHAR *commandline = NULL;
+
+  LPVOID environment = NULL;
+  LPCWSTR current_directory = NULL;
+  STARTUPINFO startup_info;
+  PROCESS_INFORMATION process_info;
+  DWORD wait_result, status;
+  DWORD timeout = (settings->timeout > 0) ? settings->timeout * 1000 : INFINITE;
+
+  ZeroMemory(&startup_info, sizeof(STARTUPINFO));
+  startup_info.cb = sizeof(STARTUPINFO);
+  startup_info.dwFlags = STARTF_USESTDHANDLES;
+
+  program = find_program(settings->program);
+  checkerr(
+    (program == NULL),
+    "Could not find program to execute",
+     settings->program
+  );
+
+  commandline = commandline_of_arguments(settings->argv);
+
+  if (is_defined(settings->stdin_filename))
+  {
+    startup_info.hStdInput = create_input_handle(settings->stdin_filename);
+    checkerr( (startup_info.hStdInput == INVALID_HANDLE_VALUE),
+      "Could not redirect standard input",
+      settings->stdin_filename);
+    stdin_redirected = 1;
+  } else startup_info.hStdInput = GetStdHandle(STD_INPUT_HANDLE);
+
+  if (is_defined(settings->stdout_filename))
+  {
+    startup_info.hStdOutput = create_output_handle(
+      settings->stdout_filename, settings->append
+    );
+    checkerr( (startup_info.hStdOutput == INVALID_HANDLE_VALUE),
+      "Could not redirect standard output",
+      settings->stdout_filename);
+    stdout_redirected = 1;
+  } else startup_info.hStdOutput = GetStdHandle(STD_OUTPUT_HANDLE);
+
+  if (is_defined(settings->stderr_filename))
+  {
+    if (stdout_redirected)
+    {
+      if (wcscmp(settings->stdout_filename, settings->stderr_filename) == 0)
+      {
+        startup_info.hStdError = startup_info.hStdOutput;
+        stderr_redirected = 1;
+        combined = 1;
+      }
+    }
+
+    if (! stderr_redirected)
+    {
+      startup_info.hStdError = create_output_handle
+      (
+        settings->stderr_filename, settings->append
+      );
+      checkerr( (startup_info.hStdError == INVALID_HANDLE_VALUE),
+        "Could not redirect standard error",
+        settings->stderr_filename);
+      stderr_redirected = 1;
+    }
+  } else startup_info.hStdError = GetStdHandle(STD_ERROR_HANDLE);
+
+  process_created = CreateProcess(
+    program,
+    commandline,
+    NULL, /* SECURITY_ATTRIBUTES process_attributes */
+    NULL, /* SECURITY_ATTRIBUTES thread_attributes */
+    TRUE, /* BOOL inherit_handles */
+    CREATE_UNICODE_ENVIRONMENT, /* DWORD creation_flags */
+    NULL, /* LPVOID environment */
+    NULL, /* LPCSTR current_directory */
+    &startup_info,
+    &process_info
+  );
+  checkerr( (! process_created), "CreateProcess failed", NULL);
+
+  CloseHandle(process_info.hThread); /* Not needed so closed ASAP */
+
+  wait_result = WaitForSingleObject(process_info.hProcess, timeout);
+  if (wait_result == WAIT_OBJECT_0)
+  {
+    /* The child has terminated before the timeout has expired */
+    checkerr( (! GetExitCodeProcess(process_info.hProcess, &status)),
+      "GetExitCodeProcess failed", NULL);
+  } else if (wait_result == WAIT_TIMEOUT) {
+    /* The timeout has expired, terminate the process */
+    checkerr( (! TerminateProcess(process_info.hProcess, 0)),
+      "TerminateProcess failed", NULL);
+    status = -1;
+    wait_again = 1;
+  } else {
+    error_with_location(__FILE__, __LINE__, settings,
+      "WaitForSingleObject failed\n");
+    report_error(__FILE__, __LINE__,
+      settings, "Failure while waiting for process termination", NULL);
+    status = -1;
+  }
+
+cleanup:
+  free(program);
+  free(commandline);
+  if (stdin_redirected) CloseHandle(startup_info.hStdInput);
+  if (stdout_redirected) CloseHandle(startup_info.hStdOutput);
+  if (stderr_redirected && !combined) CloseHandle(startup_info.hStdError);
+  if (wait_again)
+  {
+    /* Wait again but this time just 1sec to avoid being blocked */
+    WaitForSingleObject(process_info.hProcess, 1000);
+  }
+  if (process_created) CloseHandle(process_info.hProcess);
+  return status;
+}

diff --git a/ocamltest/testlib.ml b/ocamltest/testlib.ml
new file mode 100644 (file)
index 0000000..e24e6ab
--- /dev/null
+++ b/ocamltest/testlib.ml
@@ -0,0 +1,134 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Sebastien Hinderer, projet Gallium, INRIA Paris            *)
+(*                                                                        *)
+(*   Copyright 2016 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Miscellaneous library functions *)
+
+let rec concatmap f = function
+  | [] -> []
+  | x::xs -> (f x) @ (concatmap f xs)
+
+let is_blank c =
+  c = ' ' || c = '\012' || c = '\n' || c = '\r' || c =  '\t'
+
+let string_of_char = String.make 1
+
+(* This function comes from otherlibs/win32unix/unix.ml *)
+let maybe_quote f =
+  if String.contains f ' ' ||
+     String.contains f '\"' ||
+     String.contains f '\t' ||
+     f = ""
+  then Filename.quote f
+  else f
+
+let words s =
+  let l = String.length s in
+  let rec f quote w ws i =
+    if i>=l then begin
+      if w<>"" then List.rev (w::ws)
+      else List.rev ws
+    end else begin
+      let j = i+1 in
+      match s.[i] with
+        | '\'' -> f (not quote) w ws j
+        | ' ' ->
+          begin
+            if quote
+            then f true (w ^ (string_of_char ' ')) ws j
+            else begin
+              if w=""
+              then f false w ws j
+              else f false "" (w::ws) j
+            end
+          end
+        | _ as c -> f quote (w ^ (string_of_char c)) ws j
+    end in
+  if l=0 then [] else f false "" [] 0
+
+let file_is_empty filename =
+  let ic = open_in filename in
+  let filesize = in_channel_length ic in
+  close_in ic;
+  filesize = 0
+
+let string_of_location loc =
+  let buf = Buffer.create 64 in
+  let fmt = Format.formatter_of_buffer buf in
+  Location.print_loc fmt loc;
+  Format.pp_print_flush fmt ();
+  Buffer.contents buf
+
+let run_system_command command = match Sys.command command with
+  | 0 -> ()
+  | _ as exitcode ->
+    Printf.eprintf "Sysem command %s failed with status %d\n%!"
+      command exitcode;
+    exit 3
+
+let mkdir dir =
+  if not (Sys.file_exists dir) then
+    let quoted_dir = "\"" ^ dir ^ "\"" in
+    run_system_command ("mkdir " ^ quoted_dir)
+
+let rec make_directory dir =
+  if Sys.file_exists dir then ()
+  else (make_directory (Filename.dirname dir); mkdir dir)
+
+let string_of_file filename =
+  let chan = open_in_bin filename in
+  let filesize = in_channel_length chan in
+  if filesize > Sys.max_string_length then
+  begin
+    close_in chan;
+    failwith
+      ("The file " ^ filename ^ " is too large to be loaded into a string")
+  end else begin
+    let result =
+      try really_input_string chan filesize
+      with End_of_file ->
+        close_in chan;
+        failwith ("Got unexpected end of file while reading " ^ filename) in
+    close_in chan;
+    result
+  end
+
+let with_input_file ?(bin=false) x f =
+  let ic = (if bin then open_in_bin else open_in) x in
+  try let res = f ic in close_in ic; res with e -> (close_in ic; raise e)
+
+let with_output_file ?(bin=false) x f =
+  let oc = (if bin then open_out_bin else open_out) x in
+  try let res = f oc in close_out oc; res with e -> (close_out oc; raise e)
+
+
+let copy_chan ic oc =
+  let m = in_channel_length ic in
+  let m = (m lsr 12) lsl 12 in
+  let m = max 16384 (min Sys.max_string_length m) in
+  let buf = Bytes.create m in
+  let rec loop () =
+    let len = input ic buf 0 m in
+    if len > 0 then begin
+      output oc buf 0 len;
+      loop ()
+    end
+  in loop ()
+
+let copy_file src dest =
+  with_input_file ~bin:true src begin fun ic ->
+    with_output_file ~bin:true dest begin fun oc ->
+      copy_chan ic oc
+    end
+  end

diff --git a/ocamltest/testlib.mli b/ocamltest/testlib.mli
new file mode 100644 (file)
index 0000000..70ecc7e
--- /dev/null
+++ b/ocamltest/testlib.mli
@@ -0,0 +1,36 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Sebastien Hinderer, projet Gallium, INRIA Paris            *)
+(*                                                                        *)
+(*   Copyright 2016 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Miscellaneous library functions *)
+
+val concatmap : ('a -> 'b list) -> 'a list -> 'b list
+
+val is_blank : char -> bool
+
+val maybe_quote : string -> string
+
+val words : string -> string list
+
+val file_is_empty : string -> bool
+
+val string_of_location: Location.t -> string
+
+val run_system_command : string -> unit
+
+val make_directory : string -> unit
+
+val string_of_file : string -> string
+
+val copy_file : string -> string -> unit

diff --git a/ocamltest/tests.ml b/ocamltest/tests.ml
new file mode 100644 (file)
index 0000000..0a93ac7
--- /dev/null
+++ b/ocamltest/tests.ml
@@ -0,0 +1,86 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Sebastien Hinderer, projet Gallium, INRIA Paris            *)
+(*                                                                        *)
+(*   Copyright 2016 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Definition of tests, built from actions *)
+
+type t = {
+  test_name : string;
+  test_run_by_default : bool;
+  test_actions : Actions.t list
+}
+
+let compare t1 t2 = String.compare t1.test_name t2.test_name
+
+let (tests: (string, t) Hashtbl.t) = Hashtbl.create 20
+
+let register test = Hashtbl.add tests test.test_name test
+
+let get_registered_tests () =
+  let f _test_name test acc = test::acc in
+  let unsorted_tests = Hashtbl.fold f tests [] in
+  List.sort compare unsorted_tests
+
+let default_tests () =
+  let f _test_name test acc =
+    if test.test_run_by_default then test::acc else acc in
+  Hashtbl.fold f tests []
+
+let lookup name =
+  try Some (Hashtbl.find tests name)
+  with Not_found -> None
+
+let test_of_action action =
+{
+  test_name = action.Actions.action_name;
+  test_run_by_default = false;
+  test_actions = [action]
+}
+
+let run_actions log testenv actions =
+  let total = List.length actions in
+  let rec run_actions_aux action_number env = function
+    | [] -> Actions.Pass env
+    | action::remaining_actions ->
+      begin
+        Printf.fprintf log "Running action %d/%d (%s)\n%!"
+          action_number total action.Actions.action_name;
+        let result = Actions.run log env action in
+        let report = match result with
+          | Actions.Pass _ -> "succeded."
+          | Actions.Fail reason ->
+            ("failed for the following reason:\n" ^ reason)
+          | Actions.Skip reason ->
+            ("has been skipped for the following reason:\n" ^ reason) in
+        Printf.fprintf log "Action %d/%d (%s) %s\n%!"
+          action_number total action.Actions.action_name
+          report;
+        match result with
+          | Actions.Pass env' ->
+            run_actions_aux (action_number+1) env' remaining_actions
+          | _ -> result
+      end in
+  run_actions_aux 1 testenv actions
+
+let run log env test =
+  Printf.fprintf log "Running test %s with %d actions\n%!"
+    test.test_name
+    (List.length test.test_actions);
+  run_actions log env test.test_actions
+
+module TestSet = Set.Make
+(struct
+  type nonrec t = t
+  let compare = compare
+end)

diff --git a/ocamltest/tests.mli b/ocamltest/tests.mli
new file mode 100644 (file)
index 0000000..0093e45
--- /dev/null
+++ b/ocamltest/tests.mli
@@ -0,0 +1,38 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Sebastien Hinderer, projet Gallium, INRIA Paris            *)
+(*                                                                        *)
+(*   Copyright 2016 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Definition of tests, built from actions *)
+
+type t = {
+  test_name : string;
+  test_run_by_default : bool;
+  test_actions : Actions.t list
+}
+
+val compare : t -> t -> int
+
+val register : t -> unit
+
+val get_registered_tests : unit -> t list
+
+val default_tests : unit -> t list
+
+val lookup : string -> t option
+
+val run : out_channel -> Environments.t -> t -> Actions.result
+
+val test_of_action : Actions.t -> t
+
+module TestSet : Set.S with type elt = t

diff --git a/ocamltest/tsl_ast.ml b/ocamltest/tsl_ast.ml
new file mode 100644 (file)
index 0000000..36e7df7
--- /dev/null
+++ b/ocamltest/tsl_ast.ml
@@ -0,0 +1,40 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Sebastien Hinderer, projet Gallium, INRIA Paris            *)
+(*                                                                        *)
+(*   Copyright 2016 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Abstract Syntax Tree for the Tests Specification Language *)
+
+type 'a located = {
+  node : 'a;
+  loc : Location.t
+}
+
+type environment_statement =
+  | Assignment of string located * string located (* variable = value *)
+  | Include of string located (* include named environemnt *)
+
+type tsl_item =
+  | Environment_statement of environment_statement located
+  | Test of
+    int (* test depth *) *
+    string located (* test name *) *
+    string located list (* environment modifiers *)
+
+type tsl_block = tsl_item list
+
+let make ?(loc = Location.none) foo = { node = foo; loc = loc }
+
+let make_identifier = make
+let make_string = make
+let make_environment_statement = make

diff --git a/ocamltest/tsl_ast.mli b/ocamltest/tsl_ast.mli
new file mode 100644 (file)
index 0000000..c053097
--- /dev/null
+++ b/ocamltest/tsl_ast.mli
@@ -0,0 +1,39 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Sebastien Hinderer, projet Gallium, INRIA Paris            *)
+(*                                                                        *)
+(*   Copyright 2016 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Abstract Syntax Tree for the Tests Specification Language *)
+
+type 'a located = {
+  node : 'a;
+  loc : Location.t
+}
+
+type environment_statement =
+  | Assignment of string located * string located (* variable = value *)
+  | Include of string located (* include named environemnt *)
+
+type tsl_item =
+  | Environment_statement of environment_statement located
+  | Test of
+    int (* test depth *) *
+    string located (* test name *) *
+    string located list (* environment modifiers *)
+
+type tsl_block = tsl_item list
+
+val make_identifier : ?loc:Location.t -> string -> string located
+val make_string : ?loc:Location.t -> string -> string located
+val make_environment_statement :
+  ?loc:Location.t -> environment_statement -> environment_statement located

diff --git a/ocamltest/tsl_lexer.mli b/ocamltest/tsl_lexer.mli
new file mode 100644 (file)
index 0000000..a92ad67
--- /dev/null
+++ b/ocamltest/tsl_lexer.mli
@@ -0,0 +1,18 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Sebastien Hinderer, projet Gallium, INRIA Paris            *)
+(*                                                                        *)
+(*   Copyright 2017 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Interface to the Tsl_lexer module *)
+
+val token : Lexing.lexbuf -> Tsl_parser.token

diff --git a/ocamltest/tsl_lexer.mll b/ocamltest/tsl_lexer.mll
new file mode 100644 (file)
index 0000000..b14cee8
--- /dev/null
+++ b/ocamltest/tsl_lexer.mll
@@ -0,0 +1,96 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Sebastien Hinderer, projet Gallium, INRIA Paris            *)
+(*                                                                        *)
+(*   Copyright 2016 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Lexer definitions for the Tests Specification Language *)
+
+{
+open Tsl_parser
+
+let comment_start_pos = ref []
+
+let lexer_error message =
+  Printf.eprintf "%s\n%!" message;
+  exit 2
+
+}
+
+let newline = ('\013'* '\010')
+let blank = [' ' '\009' '\012']
+let identchar = ['A'-'Z' 'a'-'z' '_' '\'' '0'-'9']
+
+rule token = parse
+  | blank * { token lexbuf }
+  | newline { Lexing.new_line lexbuf; token lexbuf }
+  | "/*" blank* "TEST" { TSL_BEGIN_C_STYLE }
+  | "*/" { TSL_END_C_STYLE }
+  | "(*" blank* "TEST" { TSL_BEGIN_OCAML_STYLE }
+  | "*)" { TSL_END_OCAML_STYLE }
+  | "," { COMA }
+  | '*'+ { TEST_DEPTH (String.length (Lexing.lexeme lexbuf)) }
+  | "=" { EQUAL }
+  | identchar *
+    { let s = Lexing.lexeme lexbuf in
+      match s with
+        | "include" -> INCLUDE
+        | "with" -> WITH
+        | _ -> IDENTIFIER s
+    }
+  | "(*"
+    {
+      comment_start_pos := [Lexing.lexeme_start_p lexbuf];
+      comment lexbuf
+    }
+  | "\"" [^'"']* "\""
+    { let s = Lexing.lexeme lexbuf in
+      let string_length = (String.length s) -2 in
+      let s' = String.sub s 1 string_length in
+      STRING s'
+    }
+  | _
+    {
+      let pos = Lexing.lexeme_start_p lexbuf in
+      let file = pos.Lexing.pos_fname in
+      let line = pos.Lexing.pos_lnum in
+      let column = pos.Lexing.pos_cnum - pos.Lexing.pos_bol in
+      let message = Printf.sprintf "%s:%d:%d: unexpected character %s"
+        file line column (Lexing.lexeme lexbuf) in
+      lexer_error message
+    }
+and comment = parse
+  | "(*"
+    {
+      comment_start_pos :=
+        (Lexing.lexeme_start_p lexbuf) :: !comment_start_pos;
+      comment lexbuf
+    }
+  | "*)"
+    {
+      comment_start_pos := List.tl !comment_start_pos;
+      if !comment_start_pos = [] then token lexbuf else comment lexbuf
+    }
+  | eof
+    {
+      let pos = List.hd !comment_start_pos in
+      let file = pos.Lexing.pos_fname in
+      let line = pos.Lexing.pos_lnum in
+      let column = pos.Lexing.pos_cnum - pos.Lexing.pos_bol in
+      let message = Printf.sprintf "%s:%d:%d: unterminated comment"
+        file line column in
+      lexer_error message
+    }
+  | _
+    {
+      comment lexbuf
+    }

diff --git a/ocamltest/tsl_parser.mly b/ocamltest/tsl_parser.mly
new file mode 100644 (file)
index 0000000..7555b13
--- /dev/null
+++ b/ocamltest/tsl_parser.mly
@@ -0,0 +1,82 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Sebastien Hinderer, projet Gallium, INRIA Paris            */
+/*                                                                        */
+/*   Copyright 2016 Institut National de Recherche en Informatique et     */
+/*     en Automatique.                                                    */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+/* Parser for the Tests Specification Language */
+
+%{
+
+open Location
+open Tsl_ast
+
+let mkstring s = make_string ~loc:(symbol_rloc()) s
+
+let mkidentifier id = make_identifier ~loc:(symbol_rloc()) id
+
+let mkenvstmt envstmt =
+  let located_env_statement =
+    make_environment_statement ~loc:(symbol_rloc()) envstmt in
+  Environment_statement located_env_statement
+
+%}
+
+%token TSL_BEGIN_C_STYLE TSL_END_C_STYLE
+%token TSL_BEGIN_OCAML_STYLE TSL_END_OCAML_STYLE
+%token COMA
+%token <int> TEST_DEPTH
+%token EQUAL
+/* %token COLON */
+%token INCLUDE WITH
+%token <string> IDENTIFIER
+%token <string> STRING
+
+%start tsl_block
+%type <Tsl_ast.tsl_block> tsl_block
+
+%%
+
+tsl_block:
+| TSL_BEGIN_C_STYLE tsl_items TSL_END_C_STYLE { $2 }
+| TSL_BEGIN_OCAML_STYLE tsl_items TSL_END_OCAML_STYLE { $2 }
+
+tsl_items:
+| { [] }
+| tsl_item tsl_items { $1 :: $2 }
+
+tsl_item:
+| test_item { $1 }
+| env_item { $1 }
+
+test_item:
+  TEST_DEPTH identifier with_environment_modifiers { (Test ($1, $2, $3)) }
+
+with_environment_modifiers:
+| { [] }
+| WITH identifier opt_environment_modifiers { $2::(List.rev $3) }
+
+opt_environment_modifiers:
+| { [] }
+| opt_environment_modifiers COMA identifier { $3::$1 }
+
+env_item:
+| identifier EQUAL string
+  { mkenvstmt (Assignment ($1, $3)) }
+| INCLUDE identifier
+  { mkenvstmt (Include $2) }
+
+identifier: IDENTIFIER { mkidentifier $1 }
+
+string: STRING { mkstring $1 }
+
+%%

diff --git a/ocamltest/tsl_semantics.ml b/ocamltest/tsl_semantics.ml
new file mode 100644 (file)
index 0000000..ca4b774
--- /dev/null
+++ b/ocamltest/tsl_semantics.ml
@@ -0,0 +1,149 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Sebastien Hinderer, projet Gallium, INRIA Paris            *)
+(*                                                                        *)
+(*   Copyright 2016 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Interpretation of TSL blocks and operations on test trees *)
+
+open Tsl_ast
+
+let variable_already_defined loc variable context =
+  let ctxt = match context with
+    | None -> ""
+    | Some envname -> " while including environment " ^ envname in
+  let locstr = Testlib.string_of_location loc in
+  Printf.eprintf "%s\nVariable %s already defined%s\n%!" locstr variable ctxt;
+  exit 2
+
+let no_such_modifiers loc name =
+  let locstr = Testlib.string_of_location loc in
+  Printf.eprintf "%s\nNo such modifiers %s\n%!" locstr name;
+  exit 2
+
+let apply_modifiers env modifiers_name =
+  let name = modifiers_name.node in
+  let modifier = Environments.Include name in
+  try Environments.apply_modifier env modifier with
+  | Environments.Modifiers_name_not_found name ->
+    no_such_modifiers modifiers_name.loc name
+  | Environments.Variable_already_defined variable ->
+    variable_already_defined modifiers_name.loc
+      (Variables.name_of_variable variable) (Some name)
+
+let interprete_environment_statement env statement = match statement.node with
+  | Assignment (var, value) ->
+    begin
+      let variable_name = var.node in
+      let variable = match Variables.find_variable variable_name with
+        | None -> Variables.make (variable_name, "User variable")
+        | Some variable -> variable in
+      try Environments.add variable value.node env with
+      Environments.Variable_already_defined variable ->
+        variable_already_defined statement.loc
+          (Variables.name_of_variable variable) None
+    end
+  | Include modifiers_name -> apply_modifiers env modifiers_name
+
+let interprete_environment_statements env l =
+  List.fold_left interprete_environment_statement env l
+
+type test_tree =
+  | Node of
+    (Tsl_ast.environment_statement located list) *
+    Tests.t *
+    string located list *
+    (test_tree list)
+
+let too_deep testname max_level real_level =
+  Printf.eprintf "Test %s should have depth atmost %d but has depth %d\n%!"
+    testname max_level real_level;
+  exit 2
+
+let unexpected_environment_statement s =
+  let locstr = Testlib.string_of_location s.loc in
+  Printf.eprintf "%s\nUnexpected environment statement\n%!" locstr;
+  exit 2
+
+let no_such_test_or_action t =
+  let locstr = Testlib.string_of_location t.loc in
+  Printf.eprintf "%s\nNo such test or action: %s\n%!" locstr t.node;
+  exit 2
+
+let test_trees_of_tsl_block tsl_block =
+  let rec env_of_lines = function
+    | [] -> ([], [])
+    | Environment_statement s :: lines ->
+      let (env', remaining_lines) = env_of_lines lines in
+      (s :: env', remaining_lines)
+    | lines -> ([], lines)
+  and tree_of_lines depth = function
+    | [] -> (None, [])
+    | line::remaining_lines as l ->
+      begin match line with
+        | Environment_statement s -> unexpected_environment_statement s
+        | Test (test_depth, located_name, env_modifiers) ->
+          begin
+            let name = located_name.node in
+            if test_depth > depth then too_deep name depth test_depth
+            else if test_depth < depth then (None, l)
+            else
+              let (env, rem) = env_of_lines remaining_lines in
+              let (trees, rem) = trees_of_lines (depth+1) rem in
+              match Tests.lookup name with
+                | None ->
+                  begin match Actions.lookup name with
+                    | None -> no_such_test_or_action located_name
+                    | Some action ->
+                      let test = Tests.test_of_action action in
+                      (Some (Node (env, test, env_modifiers, trees)), rem)
+                  end
+                | Some test ->
+                  (Some (Node (env, test, env_modifiers, trees)), rem)
+          end
+      end
+  and trees_of_lines depth lines =
+    let remaining_lines = ref lines in
+    let trees = ref [] in
+    let continue = ref true in
+    while !continue; do
+      let (tree, rem) = tree_of_lines depth !remaining_lines in
+      remaining_lines := rem;
+      match tree with
+        | None -> continue := false
+        | Some t -> trees := t :: !trees
+    done;
+    (List.rev !trees, !remaining_lines) in
+  let (env, rem) = env_of_lines tsl_block in
+  let (trees, rem) = trees_of_lines 1 rem in
+  match rem with
+    | [] -> (env, trees)
+    | (Environment_statement s)::_ -> unexpected_environment_statement s
+    | _ -> assert false
+
+let rec tests_in_tree_aux set = function Node (_, test, _, subtrees) ->
+  let set' = List.fold_left tests_in_tree_aux set subtrees in
+  Tests.TestSet.add test set'
+
+let tests_in_tree t = tests_in_tree_aux Tests.TestSet.empty t
+
+let tests_in_trees subtrees =
+  List.fold_left tests_in_tree_aux Tests.TestSet.empty subtrees
+
+let actions_in_test test =
+  let add action_set action = Actions.ActionSet.add action action_set in
+  List.fold_left add Actions.ActionSet.empty test.Tests.test_actions
+
+let actions_in_tests tests =
+  let f test action_set =
+    Actions.ActionSet.union (actions_in_test test) action_set in
+  Tests.TestSet.fold f tests Actions.ActionSet.empty

diff --git a/ocamltest/tsl_semantics.mli b/ocamltest/tsl_semantics.mli
new file mode 100644 (file)
index 0000000..dc0f285
--- /dev/null
+++ b/ocamltest/tsl_semantics.mli
@@ -0,0 +1,47 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Sebastien Hinderer, projet Gallium, INRIA Paris            *)
+(*                                                                        *)
+(*   Copyright 2016 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Interpretation of TSL blocks and operations on test trees *)
+
+open Tsl_ast
+
+val apply_modifiers : Environments.t -> string located -> Environments.t
+
+val interprete_environment_statement :
+  Environments.t -> Tsl_ast.environment_statement Tsl_ast.located ->
+  Environments.t
+
+val interprete_environment_statements :
+  Environments.t -> Tsl_ast.environment_statement Tsl_ast.located list ->
+  Environments.t
+
+type test_tree =
+  | Node of
+    (Tsl_ast.environment_statement located list) *
+    Tests.t *
+    string located list *
+    (test_tree list)
+
+val test_trees_of_tsl_block :
+  Tsl_ast.tsl_block ->
+  Tsl_ast.environment_statement located list * test_tree list
+
+val tests_in_tree : test_tree -> Tests.TestSet.t
+
+val tests_in_trees : test_tree list -> Tests.TestSet.t
+
+val actions_in_test : Tests.t -> Actions.ActionSet.t
+
+val actions_in_tests : Tests.TestSet.t -> Actions.ActionSet.t

diff --git a/ocamltest/variables.ml b/ocamltest/variables.ml
new file mode 100644 (file)
index 0000000..2762ef3
--- /dev/null
+++ b/ocamltest/variables.ml
@@ -0,0 +1,48 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Sebastien Hinderer, projet Gallium, INRIA Paris            *)
+(*                                                                        *)
+(*   Copyright 2016 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Definition of environment variabless *)
+
+type t = {
+  variable_name : string;
+  variable_description : string
+}
+
+let compare v1 v2 = String.compare v1.variable_name v2.variable_name
+
+exception Empty_variable_name
+
+exception Variable_already_registered
+
+let make (name, description) =
+  if name="" then raise Empty_variable_name else {
+    variable_name = name;
+    variable_description = description
+  }
+
+let name_of_variable v = v.variable_name
+
+let description_of_variable v = v.variable_description
+
+let (variables : (string, t) Hashtbl.t) = Hashtbl.create 10
+
+let register_variable variable =
+  if Hashtbl.mem variables variable.variable_name
+  then raise Variable_already_registered
+  else Hashtbl.add variables variable.variable_name variable
+
+let find_variable variable_name =
+  try Some (Hashtbl.find variables variable_name)
+  with Not_found -> None

diff --git a/ocamltest/variables.mli b/ocamltest/variables.mli
new file mode 100644 (file)
index 0000000..4c63001
--- /dev/null
+++ b/ocamltest/variables.mli
@@ -0,0 +1,34 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Sebastien Hinderer, projet Gallium, INRIA Paris            *)
+(*                                                                        *)
+(*   Copyright 2016 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Definition of environment variabless *)
+
+type t
+
+val compare : t -> t -> int
+
+exception Empty_variable_name
+
+exception Variable_already_registered
+
+val make : string * string -> t
+
+val name_of_variable : t -> string
+
+val description_of_variable : t -> string
+
+val register_variable : t -> unit
+
+val find_variable : string -> t option

diff --git a/otherlibs/Makefile b/otherlibs/Makefile
index 05a093fd0703d6ab3bcb597cc2efec731540e965..0958d0c06aba234295a651baedf98da13b77648c 100644 (file)
--- a/otherlibs/Makefile
+++ b/otherlibs/Makefile
@@ -29,10 +29,10 @@ endif
 CAMLC=$(CAMLRUN) $(ROOTDIR)/ocamlc -nostdlib -I $(ROOTDIR)/stdlib
 CAMLOPT=$(CAMLRUN) $(ROOTDIR)/ocamlopt -nostdlib \
         -I $(ROOTDIR)/stdlib
-CFLAGS=-I$(ROOTDIR)/byterun $(SHAREDCCCOMPOPTS) $(EXTRACFLAGS)
+CFLAGS += $(SHAREDCCCOMPOPTS) $(EXTRACFLAGS)
+CPPFLAGS += -I$(ROOTDIR)/byterun
 
 # Compilation options
-CC=$(BYTECC)
 COMPFLAGS=-absname -w +a-4-9-41-42-44-45-48 -warn-error A -bin-annot -g \
           -safe-string -strict-sequence -strict-formats $(EXTRACAMLFLAGS)
 ifeq "$(FLAMBDA)" "true"
@@ -113,4 +113,4 @@ clean:: partialclean
        $(CAMLOPT) -c $(COMPFLAGS) $(OPTCOMPFLAGS) $<
 
 .c.$(O):
-       $(BYTECC) $(BYTECCCOMPOPTS) $(CFLAGS) -c $<
+       $(CC) -c $(CFLAGS) $(CPPFLAGS) $(OUTPUTOBJ)$@ $<

diff --git a/otherlibs/bigarray/.depend b/otherlibs/bigarray/.depend
index 7d75fc253012c22d22eac0b695aca4413fff59d9..ea433c07bdea8b1aa1ebac8567be8287d87838f1 100644 (file)
--- a/otherlibs/bigarray/.depend
+++ b/otherlibs/bigarray/.depend
@@ -1,25 +1,13 @@
-bigarray_stubs.o: bigarray_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 \
-  bigarray.h ../../byterun/caml/custom.h ../../byterun/caml/fail.h \
+bigarray_stubs.$(O): bigarray_stubs.c ../../byterun/caml/alloc.h \
+  ../../byterun/caml/misc.h ../../byterun/caml/config.h \
+  ../../byterun/caml/m.h ../../byterun/caml/s.h \
+  ../../byterun/caml/mlvalues.h ../../byterun/caml/bigarray.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/compatibility.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/custom.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/compatibility.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/alloc.h \
-  ../../byterun/caml/custom.h ../../byterun/caml/fail.h \
-  ../../byterun/caml/sys.h ../unix/unixsupport.h
 bigarray.cmo : bigarray.cmi
 bigarray.cmx : bigarray.cmi
 bigarray.cmi :

diff --git a/otherlibs/bigarray/Makefile b/otherlibs/bigarray/Makefile
index 5044c724b77c85d19f5bb7e3ce27d9422ef7d051..2094ad2f4ca6373002ecac071108aed193ce5ca1 100644 (file)
--- a/otherlibs/bigarray/Makefile
+++ b/otherlibs/bigarray/Makefile
@@ -16,22 +16,24 @@
 LIBNAME=bigarray
 EXTRACFLAGS=-I../$(UNIXLIB) -DIN_OCAML_BIGARRAY
 EXTRACAMLFLAGS=-I ../$(UNIXLIB)
-COBJS=bigarray_stubs.$(O) mmap_$(UNIX_OR_WIN32).$(O)
+COBJS=bigarray_stubs.$(O) mmap_ba.$(O) mmap.$(O)
 CAMLOBJS=bigarray.cmo
-HEADERS=bigarray.h
 
 include ../Makefile
 
-depend:
-       $(CC) -MM $(CFLAGS) *.c > .depend
-       $(CAMLRUN) $(ROOTDIR)/tools/ocamldep -slash *.mli *.ml >> .depend
+mmap.$(O): ../$(UNIXLIB)/mmap.c
+       $(CC) -c $(CFLAGS) $(CPPFLAGS) $(OUTPUTOBJ)$@ $<
+mmap_ba.$(O): ../unix/mmap_ba.c
+       $(CC) -c $(CFLAGS) $(CPPFLAGS) $(OUTPUTOBJ)$@ $<
 
-ifeq "$(TOOLCHAIN)" "msvc"
-.depend.nt: .depend
-       sed -e 's/\.o/.$(O)/g' $< > $@
-
-include .depend.nt
+.PHONY: depend
 
+depend:
+ifeq "$(TOOLCHAIN)" "msvc"
+       $(error Dependencies cannot be regenerated using the MSVC ports)
 else
-include .depend
+       $(CC) -MM $(CFLAGS) $(CPPFLAGS) *.c | sed -e 's/\.o/.$$(O)/g' > .depend
+       $(CAMLRUN) $(ROOTDIR)/tools/ocamldep -slash *.mli *.ml >> .depend
 endif
+
+include .depend

diff --git a/otherlibs/bigarray/bigarray.h b/otherlibs/bigarray/bigarray.h
deleted file mode 100644 (file)
index 46a3a6a..0000000
--- a/otherlibs/bigarray/bigarray.h
+++ /dev/null
@@ -1,125 +0,0 @@
-/**************************************************************************/
-/*                                                                        */
-/*                                 OCaml                                  */
-/*                                                                        */
-/*          Manuel Serrano and Xavier Leroy, INRIA Rocquencourt           */
-/*                                                                        */
-/*   Copyright 2000 Institut National de Recherche en Informatique et     */
-/*     en Automatique.                                                    */
-/*                                                                        */
-/*   All rights reserved.  This file is distributed under the terms of    */
-/*   the GNU Lesser General Public License version 2.1, with the          */
-/*   special exception on linking described in the file LICENSE.          */
-/*                                                                        */
-/**************************************************************************/
-
-#ifndef CAML_BIGARRAY_H
-#define CAML_BIGARRAY_H
-
-#ifndef CAML_NAME_SPACE
-#include "caml/compatibility.h"
-#endif
-#include "caml/config.h"
-#include "caml/mlvalues.h"
-
-typedef signed char caml_ba_int8;
-typedef unsigned char caml_ba_uint8;
-#if SIZEOF_SHORT == 2
-typedef short caml_ba_int16;
-typedef unsigned short caml_ba_uint16;
-#else
-#error "No 16-bit integer type available"
-#endif
-
-#define CAML_BA_MAX_NUM_DIMS 16
-
-enum caml_ba_kind {
-  CAML_BA_FLOAT32,             /* Single-precision floats */
-  CAML_BA_FLOAT64,             /* Double-precision floats */
-  CAML_BA_SINT8,               /* Signed 8-bit integers */
-  CAML_BA_UINT8,               /* Unsigned 8-bit integers */
-  CAML_BA_SINT16,              /* Signed 16-bit integers */
-  CAML_BA_UINT16,              /* Unsigned 16-bit integers */
-  CAML_BA_INT32,               /* Signed 32-bit integers */
-  CAML_BA_INT64,               /* Signed 64-bit integers */
-  CAML_BA_CAML_INT,            /* OCaml-style integers (signed 31 or 63 bits) */
-  CAML_BA_NATIVE_INT,       /* Platform-native long integers (32 or 64 bits) */
-  CAML_BA_COMPLEX32,           /* Single-precision complex */
-  CAML_BA_COMPLEX64,           /* Double-precision complex */
-  CAML_BA_CHAR,                /* Characters */
-  CAML_BA_KIND_MASK = 0xFF     /* Mask for kind in flags field */
-};
-
-#define Caml_ba_kind_val(v) Int_val(v)
-
-#define Val_caml_ba_kind(k) Val_int(k)
-
-enum caml_ba_layout {
-  CAML_BA_C_LAYOUT = 0,           /* Row major, indices start at 0 */
-  CAML_BA_FORTRAN_LAYOUT = 0x100, /* Column major, indices start at 1 */
-  CAML_BA_LAYOUT_MASK = 0x100,    /* Mask for layout in flags field */
-  CAML_BA_LAYOUT_SHIFT = 8        /* Bit offset of layout flag */
-};
-
-#define Caml_ba_layout_val(v) (Int_val(v) << CAML_BA_LAYOUT_SHIFT)
-
-#define Val_caml_ba_layout(l) Val_int(l >> CAML_BA_LAYOUT_SHIFT)
-
-enum caml_ba_managed {
-  CAML_BA_EXTERNAL = 0,        /* Data is not allocated by OCaml */
-  CAML_BA_MANAGED = 0x200,     /* Data is allocated by OCaml */
-  CAML_BA_MAPPED_FILE = 0x400, /* Data is a memory mapped file */
-  CAML_BA_MANAGED_MASK = 0x600 /* Mask for "managed" bits in flags field */
-};
-
-struct caml_ba_proxy {
-  intnat refcount;              /* Reference count */
-  void * data;                  /* Pointer to base of actual data */
-  uintnat size;                 /* Size of data in bytes (if mapped file) */
-};
-
-struct caml_ba_array {
-  void * data;                /* Pointer to raw data */
-  intnat num_dims;            /* Number of dimensions */
-  intnat flags;  /* Kind of element array + memory layout + allocation status */
-  struct caml_ba_proxy * proxy; /* The proxy for sub-arrays, or NULL */
-  /* PR#5516: use C99's flexible array types if possible */
-#if (__STDC_VERSION__ >= 199901L)
-  intnat dim[]  /*[num_dims]*/; /* Size in each dimension */
-#else
-  intnat dim[1] /*[num_dims]*/; /* Size in each dimension */
-#endif
-};
-
-/* Size of struct caml_ba_array, in bytes, without dummy first dimension */
-#if (__STDC_VERSION__ >= 199901L)
-#define SIZEOF_BA_ARRAY sizeof(struct caml_ba_array)
-#else
-#define SIZEOF_BA_ARRAY (sizeof(struct caml_ba_array) - sizeof(intnat))
-#endif
-
-#define Caml_ba_array_val(v) ((struct caml_ba_array *) Data_custom_val(v))
-
-#define Caml_ba_data_val(v) (Caml_ba_array_val(v)->data)
-
-#if defined(IN_OCAML_BIGARRAY)
-#define CAMLBAextern CAMLexport
-#else
-#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 8d697150b5c363b0e68a40595231c3f22bae1173..d5e66daf4dfab34b6d73e02fcb1f19712a24063b 100644 (file)
--- a/otherlibs/bigarray/bigarray.ml
+++ b/otherlibs/bigarray/bigarray.ml
@@ -15,37 +15,7 @@
 
 (* Module [Bigarray]: large, multi-dimensional, numerical arrays *)
 
-external init : unit -> unit = "caml_ba_init"
-
-let _ = init()
-
-type float32_elt = Float32_elt
-type float64_elt = Float64_elt
-type int8_signed_elt = Int8_signed_elt
-type int8_unsigned_elt = Int8_unsigned_elt
-type int16_signed_elt = Int16_signed_elt
-type int16_unsigned_elt = Int16_unsigned_elt
-type int32_elt = Int32_elt
-type int64_elt = Int64_elt
-type int_elt = Int_elt
-type nativeint_elt = Nativeint_elt
-type complex32_elt = Complex32_elt
-type complex64_elt = Complex64_elt
-
-type ('a, 'b) kind =
-    Float32 : (float, float32_elt) kind
-  | Float64 : (float, float64_elt) kind
-  | Int8_signed : (int, int8_signed_elt) kind
-  | Int8_unsigned : (int, int8_unsigned_elt) kind
-  | Int16_signed : (int, int16_signed_elt) kind
-  | Int16_unsigned : (int, int16_unsigned_elt) kind
-  | Int32 : (int32, int32_elt) kind
-  | Int64 : (int64, int64_elt) kind
-  | Int : (int, int_elt) kind
-  | Nativeint : (nativeint, nativeint_elt) kind
-  | Complex32 : (Complex.t, complex32_elt) kind
-  | Complex64 : (Complex.t, complex64_elt) kind
-  | Char : (char, int8_unsigned_elt) kind
+include CamlinternalBigarray
 
 (* Keep those constants in sync with the caml_ba_kind enumeration
    in bigarray.h *)
@@ -79,13 +49,6 @@ let kind_size_in_bytes : type a b. (a, b) kind -> int = function
   | Complex64 -> 16
   | Char -> 1
 
-type c_layout = C_layout_typ
-type fortran_layout = Fortran_layout_typ
-
-type 'a layout =
-    C_layout: c_layout layout
-  | Fortran_layout: fortran_layout layout
-
 (* Keep those constants in sync with the caml_ba_layout enumeration
    in bigarray.h *)
 
@@ -93,7 +56,7 @@ let c_layout = C_layout
 let fortran_layout = Fortran_layout
 
 module Genarray = struct
-  type ('a, 'b, 'c) t
+  type ('a, 'b, 'c) t = ('a, 'b, 'c) genarray
   external create: ('a, 'b) kind -> 'c layout -> int array -> ('a, 'b, 'c) t
      = "caml_ba_create"
   external get: ('a, 'b, 'c) t -> int array -> 'a
@@ -146,6 +109,9 @@ module Array0 = struct
   external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind"
   external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout"
 
+  external change_layout: ('a, 'b, 'c) t -> 'd layout -> ('a, 'b, 'd) t
+    = "caml_ba_change_layout"
+
   let size_in_bytes arr = kind_size_in_bytes (kind arr)
 
   external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit = "caml_ba_blit"
@@ -170,6 +136,9 @@ module Array1 = struct
   external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind"
   external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout"
 
+  external change_layout: ('a, 'b, 'c) t -> 'd layout -> ('a, 'b, 'd) t
+    = "caml_ba_change_layout"
+
   let size_in_bytes arr =
     (kind_size_in_bytes (kind arr)) * (dim arr)
 
@@ -208,6 +177,9 @@ module Array2 = struct
   external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind"
   external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout"
 
+  external change_layout: ('a, 'b, 'c) t -> 'd layout -> ('a, 'b, 'd) t
+    = "caml_ba_change_layout"
+
   let size_in_bytes arr =
     (kind_size_in_bytes (kind arr)) * (dim1 arr) * (dim2 arr)
 
@@ -259,6 +231,9 @@ module Array3 = struct
   external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind"
   external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout"
 
+  external change_layout: ('a, 'b, 'c) t -> 'd layout -> ('a, 'b, 'd) t
+    = "caml_ba_change_layout"
+
   let size_in_bytes arr =
     (kind_size_in_bytes (kind arr)) * (dim1 arr) * (dim2 arr) * (dim3 arr)
 

diff --git a/otherlibs/bigarray/bigarray.mli b/otherlibs/bigarray/bigarray.mli
index 683e1682b7b1c393aa59938b168e35960add7f52..cadd04a6108e3b8ba87302a7daed2526acda3321 100644 (file)
--- a/otherlibs/bigarray/bigarray.mli
+++ b/otherlibs/bigarray/bigarray.mli
@@ -32,7 +32,7 @@
      and {!Pervasives.input_value}).
 *)
 
-(** {6 Element kinds} *)
+(** {1 Element kinds} *)
 
 (** Big arrays can contain elements of the following kinds:
 - IEEE single precision (32 bits) floating-point numbers
@@ -59,20 +59,23 @@
    of abstract types for technical injectivity reasons).
 *)
 
-type float32_elt = Float32_elt
-type float64_elt = Float64_elt
-type int8_signed_elt = Int8_signed_elt
-type int8_unsigned_elt = Int8_unsigned_elt
-type int16_signed_elt = Int16_signed_elt
-type int16_unsigned_elt = Int16_unsigned_elt
-type int32_elt = Int32_elt
-type int64_elt = Int64_elt
-type int_elt = Int_elt
-type nativeint_elt = Nativeint_elt
-type complex32_elt = Complex32_elt
-type complex64_elt = Complex64_elt
-
-type ('a, 'b) kind =
+type float32_elt = CamlinternalBigarray.float32_elt = Float32_elt
+type float64_elt = CamlinternalBigarray.float64_elt = Float64_elt
+type int8_signed_elt = CamlinternalBigarray.int8_signed_elt = Int8_signed_elt
+type int8_unsigned_elt = CamlinternalBigarray.int8_unsigned_elt =
+    Int8_unsigned_elt
+type int16_signed_elt = CamlinternalBigarray.int16_signed_elt =
+    Int16_signed_elt
+type int16_unsigned_elt = CamlinternalBigarray.int16_unsigned_elt =
+    Int16_unsigned_elt
+type int32_elt = CamlinternalBigarray.int32_elt = Int32_elt
+type int64_elt = CamlinternalBigarray.int64_elt = Int64_elt
+type int_elt = CamlinternalBigarray.int_elt = Int_elt
+type nativeint_elt = CamlinternalBigarray.nativeint_elt = Nativeint_elt
+type complex32_elt = CamlinternalBigarray.complex32_elt = Complex32_elt
+type complex64_elt = CamlinternalBigarray.complex64_elt = Complex64_elt
+
+type ('a, 'b) kind = ('a, 'b) CamlinternalBigarray.kind =
     Float32 : (float, float32_elt) kind
   | Float64 : (float, float64_elt) kind
   | Int8_signed : (int, int8_signed_elt) kind
@@ -176,12 +179,13 @@ val kind_size_in_bytes : ('a, 'b) kind -> int
 
    @since 4.03.0 *)
 
-(** {6 Array layouts} *)
+(** {1 Array layouts} *)
 
-type c_layout = C_layout_typ (**)
+type c_layout = CamlinternalBigarray.c_layout = C_layout_typ (**)
 (** See {!Bigarray.fortran_layout}.*)
 
-type fortran_layout = Fortran_layout_typ (**)
+type fortran_layout = CamlinternalBigarray.fortran_layout =
+    Fortran_layout_typ (**)
 (** To facilitate interoperability with existing C and Fortran code,
    this library supports two different memory layouts for big arrays,
    one compatible with the C conventions,
@@ -212,7 +216,7 @@ type fortran_layout = Fortran_layout_typ (**)
    re-exported as values below for backward-compatibility reasons.
 *)
 
-type 'a layout =
+type 'a layout = 'a CamlinternalBigarray.layout =
     C_layout: c_layout layout
   | Fortran_layout: fortran_layout layout
 
@@ -220,11 +224,11 @@ val c_layout : c_layout layout
 val fortran_layout : fortran_layout layout
 
 
-(** {6 Generic arrays (of arbitrarily many dimensions)} *)
+(** {1 Generic arrays (of arbitrarily many dimensions)} *)
 
 module Genarray :
   sig
-  type ('a, 'b, 'c) t
+  type ('a, 'b, 'c) t = ('a, 'b, 'c) CamlinternalBigarray.genarray
   (** The type [Genarray.t] is the type of big arrays with variable
      numbers of dimensions.  Any number of dimensions between 0 and 16
      is supported.
@@ -437,56 +441,13 @@ module Genarray :
   val map_file:
     Unix.file_descr -> ?pos:int64 -> ('a, 'b) kind -> 'c layout ->
     bool -> int array -> ('a, 'b, 'c) t
-  (** Memory mapping of a file as a big array.
-     [Genarray.map_file fd kind layout shared dims]
-     returns a big array of kind [kind], layout [layout],
-     and dimensions as specified in [dims].  The data contained in
-     this big array are the contents of the file referred to by
-     the file descriptor [fd] (as opened previously with
-     [Unix.openfile], for example).  The optional [pos] parameter
-     is the byte offset in the file of the data being mapped;
-     it defaults to 0 (map from the beginning of the file).
-
-     If [shared] is [true], all modifications performed on the array
-     are reflected in the file.  This requires that [fd] be opened
-     with write permissions.  If [shared] is [false], modifications
-     performed on the array are done in memory only, using
-     copy-on-write of the modified pages; the underlying file is not
-     affected.
-
-     [Genarray.map_file] is much more efficient than reading
-     the whole file in a big array, modifying that big array,
-     and writing it afterwards.
-
-     To adjust automatically the dimensions of the big array to
-     the actual size of the file, the major dimension (that is,
-     the first dimension for an array with C layout, and the last
-     dimension for an array with Fortran layout) can be given as
-     [-1].  [Genarray.map_file] then determines the major dimension
-     from the size of the file.  The file must contain an integral
-     number of sub-arrays as determined by the non-major dimensions,
-     otherwise [Failure] is raised.
-
-     If all dimensions of the big array are given, the file size is
-     matched against the size of the big array.  If the file is larger
-     than the big array, only the initial portion of the file is
-     mapped to the big array.  If the file is smaller than the big
-     array, the file is automatically grown to the size of the big array.
-     This requires write permissions on [fd].
-
-     Array accesses are bounds-checked, but the bounds are determined by
-     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 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. *)
-
+  [@@ocaml.deprecated "\
+Use Unix.map_file instead.\n\
+Note that Bigarray.Genarray.map_file raises Sys_error while\n\
+Unix.map_file raises Unix_error."]
   end
 
-(** {6 Zero-dimensional arrays} *)
+(** {1 Zero-dimensional arrays} *)
 
 (** Zero-dimensional arrays. The [Array0] structure provides operations
    similar to those of {!Bigarray.Genarray}, but specialized to the case
@@ -510,6 +471,15 @@ module Array0 : sig
   external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout"
   (** Return the layout of the given big array. *)
 
+  val change_layout: ('a, 'b, 'c) t -> 'd layout -> ('a, 'b, 'd) t
+  (** [Array0.change_layout a layout] returns a big array with the
+      specified [layout], sharing the data with [a]. No copying of elements
+      is involved: the new array and the original array share the same
+      storage space.
+
+      @since 4.06.0
+  *)
+
   val size_in_bytes : ('a, 'b, 'c) t -> int
   (** [size_in_bytes a] is [a]'s {!kind_size_in_bytes}. *)
 
@@ -534,7 +504,7 @@ module Array0 : sig
 end
 
 
-(** {6 One-dimensional arrays} *)
+(** {1 One-dimensional arrays} *)
 
 (** One-dimensional arrays. The [Array1] structure provides operations
    similar to those of
@@ -564,6 +534,16 @@ module Array1 : sig
   external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout"
   (** Return the layout of the given big array. *)
 
+  val change_layout: ('a, 'b, 'c) t -> 'd layout -> ('a, 'b, 'd) t
+  (** [Array1.change_layout a layout] returns a bigarray with the
+      specified [layout], sharing the data with [a] (and hence having
+      the same dimension as [a]). No copying of elements is involved: the
+      new array and the original array share the same storage space.
+
+      @since 4.06.0
+  *)
+
+
   val size_in_bytes : ('a, 'b, 'c) t -> int
   (** [size_in_bytes a] is the number of elements in [a]
     multiplied by [a]'s {!kind_size_in_bytes}.
@@ -612,8 +592,10 @@ module Array1 : sig
 
   val map_file: Unix.file_descr -> ?pos:int64 -> ('a, 'b) kind -> 'c layout ->
     bool -> int -> ('a, 'b, 'c) t
-  (** Memory mapping of a file as a one-dimensional big array.
-     See {!Bigarray.Genarray.map_file} for more details. *)
+  [@@ocaml.deprecated "\
+Use [array1_of_genarray (Unix.map_file ...)] instead.\n\
+Note that Bigarray.Array1.map_file raises Sys_error while\n\
+Unix.map_file raises Unix_error."]
 
   external unsafe_get: ('a, 'b, 'c) t -> int -> 'a = "%caml_ba_unsafe_ref_1"
   (** Like {!Bigarray.Array1.get}, but bounds checking is not always performed.
@@ -629,7 +611,7 @@ module Array1 : sig
 end
 
 
-(** {6 Two-dimensional arrays} *)
+(** {1 Two-dimensional arrays} *)
 
 (** Two-dimensional arrays. The [Array2] structure provides operations
    similar to those of {!Bigarray.Genarray}, but specialized to the
@@ -659,6 +641,18 @@ module Array2 :
   external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout"
   (** Return the layout of the given big array. *)
 
+  val change_layout: ('a, 'b, 'c) t -> 'd layout -> ('a, 'b, 'd) t
+  (** [Array2.change_layout a layout] returns a bigarray with the
+      specified [layout], sharing the data with [a] (and hence having
+      the same dimensions as [a]). No copying of elements is involved: the
+      new array and the original array share the same storage space.
+      The dimensions are reversed, such that [get v [| a; b |]] in
+      C layout becomes [get v [| b+1; a+1 |]] in Fortran layout.
+
+      @since 4.06.0
+  *)
+
+
   val size_in_bytes : ('a, 'b, 'c) t -> int
   (** [size_in_bytes a] is the number of elements in [a]
     multiplied by [a]'s {!kind_size_in_bytes}.
@@ -723,8 +717,10 @@ module Array2 :
 
   val map_file: Unix.file_descr -> ?pos:int64 -> ('a, 'b) kind -> 'c layout ->
                 bool -> int -> int -> ('a, 'b, 'c) t
-  (** Memory mapping of a file as a two-dimensional big array.
-     See {!Bigarray.Genarray.map_file} for more details. *)
+  [@@ocaml.deprecated "\
+Use [array2_of_genarray (Unix.map_file ...)] instead.\n\
+Note that Bigarray.Array2.map_file raises Sys_error while\n\
+Unix.map_file raises Unix_error."]
 
   external unsafe_get: ('a, 'b, 'c) t -> int -> int -> 'a
                      = "%caml_ba_unsafe_ref_2"
@@ -738,7 +734,7 @@ module Array2 :
 
 end
 
-(** {6 Three-dimensional arrays} *)
+(** {1 Three-dimensional arrays} *)
 
 (** Three-dimensional arrays. The [Array3] structure provides operations
    similar to those of {!Bigarray.Genarray}, but specialized to the case
@@ -771,6 +767,18 @@ module Array3 :
   external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout"
   (** Return the layout of the given big array. *)
 
+
+  val change_layout: ('a, 'b, 'c) t -> 'd layout -> ('a, 'b, 'd) t
+  (** [Array3.change_layout a layout] returns a bigarray with the
+      specified [layout], sharing the data with [a] (and hence having
+      the same dimensions as [a]). No copying of elements is involved: the
+      new array and the original array share the same storage space.
+      The dimensions are reversed, such that [get v [| a; b; c |]] in
+      C layout becomes [get v [| c+1; b+1; a+1 |]] in Fortran layout.
+
+      @since 4.06.0
+  *)
+
   val size_in_bytes : ('a, 'b, 'c) t -> int
   (** [size_in_bytes a] is the number of elements in [a]
     multiplied by [a]'s {!kind_size_in_bytes}.
@@ -857,8 +865,10 @@ module Array3 :
 
   val map_file: Unix.file_descr -> ?pos:int64 -> ('a, 'b) kind -> 'c layout ->
              bool -> int -> int -> int -> ('a, 'b, 'c) t
-  (** Memory mapping of a file as a three-dimensional big array.
-     See {!Bigarray.Genarray.map_file} for more details. *)
+  [@@ocaml.deprecated "\
+Use [array3_of_genarray (Unix.map_file ...)] instead.\n\
+Note that Bigarray.Array3.map_file raises Sys_error while\n\
+Unix.map_file raises Unix_error."]
 
   external unsafe_get: ('a, 'b, 'c) t -> int -> int -> int -> 'a
                      = "%caml_ba_unsafe_ref_3"
@@ -872,7 +882,7 @@ module Array3 :
 
 end
 
-(** {6 Coercions between generic big arrays and fixed-dimension big arrays} *)
+(** {1 Coercions between generic big arrays and fixed-dimension big arrays} *)
 
 external genarray_of_array0 :
   ('a, 'b, 'c) Array0.t -> ('a, 'b, 'c) Genarray.t = "%identity"
@@ -916,7 +926,7 @@ val array3_of_genarray : ('a, 'b, 'c) Genarray.t -> ('a, 'b, 'c) Array3.t
    does not have exactly three dimensions. *)
 
 
-(** {6 Re-shaping big arrays} *)
+(** {1 Re-shaping big arrays} *)
 
 val reshape : ('a, 'b, 'c) Genarray.t -> int array -> ('a, 'b, 'c) Genarray.t
 (** [reshape b [|d1;...;dN|]] converts the big array [b] to a

diff --git a/otherlibs/bigarray/bigarray_stubs.c b/otherlibs/bigarray/bigarray_stubs.c
index cb38bef7260cdef8c674ff35327936442d3324b1..aa51026860b6093457a09084f676a9098331c269 100644 (file)
--- a/otherlibs/bigarray/bigarray_stubs.c
+++ b/otherlibs/bigarray/bigarray_stubs.c
@@ -19,7 +19,7 @@
 #include <stdarg.h>
 #include <string.h>
 #include "caml/alloc.h"
-#include "bigarray.h"
+#include "caml/bigarray.h"
 #include "caml/custom.h"
 #include "caml/fail.h"
 #include "caml/intext.h"
@@ -33,166 +33,6 @@
 #define int16 caml_ba_int16
 #define uint16 caml_ba_uint16
 
-extern void caml_ba_unmap_file(void * addr, uintnat len);
-                                          /* from mmap_xxx.c */
-
-/* Compute the number of elements of a big array */
-
-static uintnat caml_ba_num_elts(struct caml_ba_array * b)
-{
-  uintnat num_elts;
-  int i;
-  num_elts = 1;
-  for (i = 0; i < b->num_dims; i++) num_elts = num_elts * b->dim[i];
-  return num_elts;
-}
-
-/* Size in bytes of a bigarray element, indexed by bigarray kind */
-
-int caml_ba_element_size[] =
-{ 4 /*FLOAT32*/, 8 /*FLOAT64*/,
-  1 /*SINT8*/, 1 /*UINT8*/,
-  2 /*SINT16*/, 2 /*UINT16*/,
-  4 /*INT32*/, 8 /*INT64*/,
-  sizeof(value) /*CAML_INT*/, sizeof(value) /*NATIVE_INT*/,
-  8 /*COMPLEX32*/, 16 /*COMPLEX64*/,
-  1 /*CHAR*/
-};
-
-/* Compute the number of bytes for the elements of a big array */
-
-CAMLexport uintnat caml_ba_byte_size(struct caml_ba_array * b)
-{
-  return caml_ba_num_elts(b)
-         * caml_ba_element_size[b->flags & CAML_BA_KIND_MASK];
-}
-
-/* Operation table for bigarrays */
-
-static void caml_ba_finalize(value v);
-static int caml_ba_compare(value v1, value v2);
-static intnat caml_ba_hash(value v);
-static void caml_ba_serialize(value, uintnat *, uintnat *);
-uintnat caml_ba_deserialize(void * dst);
-static struct custom_operations caml_ba_ops = {
-  "_bigarray",
-  caml_ba_finalize,
-  caml_ba_compare,
-  caml_ba_hash,
-  caml_ba_serialize,
-  caml_ba_deserialize,
-  custom_compare_ext_default
-};
-
-/* Multiplication of unsigned longs with overflow detection */
-
-static uintnat
-caml_ba_multov(uintnat a, uintnat b, int * overflow)
-{
-#define HALF_SIZE (sizeof(uintnat) * 4)
-#define HALF_MASK (((uintnat)1 << HALF_SIZE) - 1)
-#define LOW_HALF(x) ((x) & HALF_MASK)
-#define HIGH_HALF(x) ((x) >> HALF_SIZE)
-  /* Cut in half words */
-  uintnat al = LOW_HALF(a);
-  uintnat ah = HIGH_HALF(a);
-  uintnat bl = LOW_HALF(b);
-  uintnat bh = HIGH_HALF(b);
-  /* Exact product is:
-              al * bl
-           +  ah * bl  << HALF_SIZE
-           +  al * bh  << HALF_SIZE
-           +  ah * bh  << 2*HALF_SIZE
-     Overflow occurs if:
-        ah * bh is not 0, i.e. ah != 0 and bh != 0
-     OR ah * bl has high half != 0
-     OR ah * bl has high half != 0
-     OR the sum al * bl + LOW_HALF(ah * bl) << HALF_SIZE
-                        + LOW_HALF(al * bh) << HALF_SIZE overflows.
-     This sum is equal to p = (a * b) modulo word size. */
-  uintnat p1 = al * bh;
-  uintnat p2 = ah * bl;
-  uintnat p = a * b;
-  if (ah != 0 && bh != 0) *overflow = 1;
-  if (HIGH_HALF(p1) != 0 || HIGH_HALF(p2) != 0) *overflow = 1;
-  p1 <<= HALF_SIZE;
-  p2 <<= HALF_SIZE;
-  p1 += p2;
-  if (p < p1 || p1 < p2) *overflow = 1; /* overflow in sums */
-  return p;
-#undef HALF_SIZE
-#undef LOW_HALF
-#undef HIGH_HALF
-}
-
-/* Allocation of a big array */
-
-#define CAML_BA_MAX_MEMORY 1024*1024*1024
-/* 1 Gb -- after allocating that much, it's probably worth speeding
-   up the major GC */
-
-/* [caml_ba_alloc] will allocate a new bigarray object in the heap.
-   If [data] is NULL, the memory for the contents is also allocated
-   (with [malloc]) by [caml_ba_alloc].
-   [data] cannot point into the OCaml heap.
-   [dim] may point into an object in the OCaml heap.
-*/
-CAMLexport value
-caml_ba_alloc(int flags, int num_dims, void * data, intnat * dim)
-{
-  uintnat num_elts, asize, size;
-  int overflow, i;
-  value res;
-  struct caml_ba_array * b;
-  intnat dimcopy[CAML_BA_MAX_NUM_DIMS];
-
-  Assert(num_dims >= 0 && num_dims <= CAML_BA_MAX_NUM_DIMS);
-  Assert((flags & CAML_BA_KIND_MASK) <= CAML_BA_CHAR);
-  for (i = 0; i < num_dims; i++) dimcopy[i] = dim[i];
-  size = 0;
-  if (data == NULL) {
-    overflow = 0;
-    num_elts = 1;
-    for (i = 0; i < num_dims; i++) {
-      num_elts = caml_ba_multov(num_elts, dimcopy[i], &overflow);
-    }
-    size = caml_ba_multov(num_elts,
-                          caml_ba_element_size[flags & CAML_BA_KIND_MASK],
-                          &overflow);
-    if (overflow) caml_raise_out_of_memory();
-    data = malloc(size);
-    if (data == NULL && size != 0) caml_raise_out_of_memory();
-    flags |= CAML_BA_MANAGED;
-  }
-  asize = SIZEOF_BA_ARRAY + num_dims * sizeof(intnat);
-  res = caml_alloc_custom(&caml_ba_ops, asize, size, CAML_BA_MAX_MEMORY);
-  b = Caml_ba_array_val(res);
-  b->data = data;
-  b->num_dims = num_dims;
-  b->flags = flags;
-  b->proxy = NULL;
-  for (i = 0; i < num_dims; i++) b->dim[i] = dimcopy[i];
-  return res;
-}
-
-/* Same as caml_ba_alloc, but dimensions are passed as a list of
-   arguments */
-
-CAMLexport value caml_ba_alloc_dims(int flags, int num_dims, void * data, ...)
-{
-  va_list ap;
-  intnat dim[CAML_BA_MAX_NUM_DIMS];
-  int i;
-  value res;
-
-  Assert(num_dims <= CAML_BA_MAX_NUM_DIMS);
-  va_start(ap, data);
-  for (i = 0; i < num_dims; i++) dim[i] = va_arg(ap, intnat);
-  va_end(ap);
-  res = caml_ba_alloc(flags, num_dims, data, dim);
-  return res;
-}
-
 /* Allocate a bigarray from OCaml */
 
 CAMLprim value caml_ba_create(value vkind, value vlayout, value vdim)
@@ -271,7 +111,7 @@ value caml_ba_get_N(value vb, value * vind, int nind)
   /* Perform read */
   switch ((b->flags) & CAML_BA_KIND_MASK) {
   default:
-    Assert(0);
+    CAMLassert(0);
   case CAML_BA_FLOAT32:
     return caml_copy_double(((float *) b->data)[offset]);
   case CAML_BA_FLOAT64:
@@ -440,7 +280,7 @@ static value caml_ba_set_aux(value vb, value * vind, intnat nind, value newval)
   /* Perform write */
   switch (b->flags & CAML_BA_KIND_MASK) {
   default:
-    Assert(0);
+    CAMLassert(0);
   case CAML_BA_FLOAT32:
     ((float *) b->data)[offset] = Double_val(newval); break;
   case CAML_BA_FLOAT64:
@@ -665,352 +505,6 @@ CAMLprim value caml_ba_layout(value vb)
   return Val_caml_ba_layout(layout);
 }
 
-/* Finalization of a big array */
-
-static void caml_ba_finalize(value v)
-{
-  struct caml_ba_array * b = Caml_ba_array_val(v);
-
-  switch (b->flags & CAML_BA_MANAGED_MASK) {
-  case CAML_BA_EXTERNAL:
-    break;
-  case CAML_BA_MANAGED:
-    if (b->proxy == NULL) {
-      free(b->data);
-    } else {
-      if (-- b->proxy->refcount == 0) {
-        free(b->proxy->data);
-        caml_stat_free(b->proxy);
-      }
-    }
-    break;
-  case CAML_BA_MAPPED_FILE:
-    if (b->proxy == NULL) {
-      caml_ba_unmap_file(b->data, caml_ba_byte_size(b));
-    } else {
-      if (-- b->proxy->refcount == 0) {
-        caml_ba_unmap_file(b->proxy->data, b->proxy->size);
-        caml_stat_free(b->proxy);
-      }
-    }
-    break;
-  }
-}
-
-/* Comparison of two big arrays */
-
-static int caml_ba_compare(value v1, value v2)
-{
-  struct caml_ba_array * b1 = Caml_ba_array_val(v1);
-  struct caml_ba_array * b2 = Caml_ba_array_val(v2);
-  uintnat n, num_elts;
-  intnat flags1, flags2;
-  int i;
-
-  /* Compare kind & layout in case the arguments are of different types */
-  flags1 = b1->flags & (CAML_BA_KIND_MASK | CAML_BA_LAYOUT_MASK);
-  flags2 = b2->flags & (CAML_BA_KIND_MASK | CAML_BA_LAYOUT_MASK);
-  if (flags1 != flags2) return flags2 - flags1;
-  /* Compare number of dimensions */
-  if (b1->num_dims != b2->num_dims) return b2->num_dims - b1->num_dims;
-  /* Same number of dimensions: compare dimensions lexicographically */
-  for (i = 0; i < b1->num_dims; i++) {
-    intnat d1 = b1->dim[i];
-    intnat d2 = b2->dim[i];
-    if (d1 != d2) return d1 < d2 ? -1 : 1;
-  }
-  /* Same dimensions: compare contents lexicographically */
-  num_elts = caml_ba_num_elts(b1);
-
-#define DO_INTEGER_COMPARISON(type) \
-  { type * p1 = b1->data; type * p2 = b2->data; \
-    for (n = 0; n < num_elts; n++) { \
-      type e1 = *p1++; type e2 = *p2++; \
-      if (e1 < e2) return -1; \
-      if (e1 > e2) return 1; \
-    } \
-    return 0; \
-  }
-#define DO_FLOAT_COMPARISON(type) \
-  { type * p1 = b1->data; type * p2 = b2->data; \
-    for (n = 0; n < num_elts; n++) { \
-      type e1 = *p1++; type e2 = *p2++; \
-      if (e1 < e2) return -1; \
-      if (e1 > e2) return 1; \
-      if (e1 != e2) { \
-        caml_compare_unordered = 1; \
-        if (e1 == e1) return 1; \
-        if (e2 == e2) return -1; \
-      } \
-    } \
-    return 0; \
-  }
-
-  switch (b1->flags & CAML_BA_KIND_MASK) {
-  case CAML_BA_COMPLEX32:
-    num_elts *= 2; /*fallthrough*/
-  case CAML_BA_FLOAT32:
-    DO_FLOAT_COMPARISON(float);
-  case CAML_BA_COMPLEX64:
-    num_elts *= 2; /*fallthrough*/
-  case CAML_BA_FLOAT64:
-    DO_FLOAT_COMPARISON(double);
-  case CAML_BA_CHAR:
-    DO_INTEGER_COMPARISON(uint8);
-  case CAML_BA_SINT8:
-    DO_INTEGER_COMPARISON(int8);
-  case CAML_BA_UINT8:
-    DO_INTEGER_COMPARISON(uint8);
-  case CAML_BA_SINT16:
-    DO_INTEGER_COMPARISON(int16);
-  case CAML_BA_UINT16:
-    DO_INTEGER_COMPARISON(uint16);
-  case CAML_BA_INT32:
-    DO_INTEGER_COMPARISON(int32_t);
-  case CAML_BA_INT64:
-    DO_INTEGER_COMPARISON(int64_t);
-  case CAML_BA_CAML_INT:
-  case CAML_BA_NATIVE_INT:
-    DO_INTEGER_COMPARISON(intnat);
-  default:
-    Assert(0);
-    return 0;                   /* should not happen */
-  }
-#undef DO_INTEGER_COMPARISON
-#undef DO_FLOAT_COMPARISON
-}
-
-/* Hashing of a bigarray */
-
-static intnat caml_ba_hash(value v)
-{
-  struct caml_ba_array * b = Caml_ba_array_val(v);
-  intnat num_elts, n;
-  uint32_t h, w;
-  int i;
-
-  num_elts = 1;
-  for (i = 0; i < b->num_dims; i++) num_elts = num_elts * b->dim[i];
-  h = 0;
-
-  switch (b->flags & CAML_BA_KIND_MASK) {
-  case CAML_BA_CHAR:
-  case CAML_BA_SINT8:
-  case CAML_BA_UINT8: {
-    uint8 * p = b->data;
-    if (num_elts > 256) num_elts = 256;
-    for (n = 0; n + 4 <= num_elts; n += 4, p += 4) {
-      w = p[0] | (p[1] << 8) | (p[2] << 16) | (p[3] << 24);
-      h = caml_hash_mix_uint32(h, w);
-    }
-    w = 0;
-    switch (num_elts & 3) {
-    case 3: w  = p[2] << 16;    /* fallthrough */
-    case 2: w |= p[1] << 8;     /* fallthrough */
-    case 1: w |= p[0];
-            h = caml_hash_mix_uint32(h, w);
-    }
-    break;
-  }
-  case CAML_BA_SINT16:
-  case CAML_BA_UINT16: {
-    uint16 * p = b->data;
-    if (num_elts > 128) num_elts = 128;
-    for (n = 0; n + 2 <= num_elts; n += 2, p += 2) {
-      w = p[0] | (p[1] << 16);
-      h = caml_hash_mix_uint32(h, w);
-    }
-    if ((num_elts & 1) != 0)
-      h = caml_hash_mix_uint32(h, p[0]);
-    break;
-  }
-  case CAML_BA_INT32:
-  {
-    uint32_t * p = b->data;
-    if (num_elts > 64) num_elts = 64;
-    for (n = 0; n < num_elts; n++, p++) h = caml_hash_mix_uint32(h, *p);
-    break;
-  }
-  case CAML_BA_CAML_INT:
-  case CAML_BA_NATIVE_INT:
-  {
-    intnat * p = b->data;
-    if (num_elts > 64) num_elts = 64;
-    for (n = 0; n < num_elts; n++, p++) h = caml_hash_mix_intnat(h, *p);
-    break;
-  }
-  case CAML_BA_INT64:
-  {
-    int64_t * p = b->data;
-    if (num_elts > 32) num_elts = 32;
-    for (n = 0; n < num_elts; n++, p++) h = caml_hash_mix_int64(h, *p);
-    break;
-  }
-  case CAML_BA_COMPLEX32:
-    num_elts *= 2;              /* fallthrough */
-  case CAML_BA_FLOAT32:
-  {
-    float * p = b->data;
-    if (num_elts > 64) num_elts = 64;
-    for (n = 0; n < num_elts; n++, p++) h = caml_hash_mix_float(h, *p);
-    break;
-  }
-  case CAML_BA_COMPLEX64:
-    num_elts *= 2;              /* fallthrough */
-  case CAML_BA_FLOAT64:
-  {
-    double * p = b->data;
-    if (num_elts > 32) num_elts = 32;
-    for (n = 0; n < num_elts; n++, p++) h = caml_hash_mix_double(h, *p);
-    break;
-  }
-  }
-  return h;
-}
-
-static void caml_ba_serialize_longarray(void * data,
-                                        intnat num_elts,
-                                        intnat min_val, intnat max_val)
-{
-#ifdef ARCH_SIXTYFOUR
-  int overflow_32 = 0;
-  intnat * p, n;
-  for (n = 0, p = data; n < num_elts; n++, p++) {
-    if (*p < min_val || *p > max_val) { overflow_32 = 1; break; }
-  }
-  if (overflow_32) {
-    caml_serialize_int_1(1);
-    caml_serialize_block_8(data, num_elts);
-  } else {
-    caml_serialize_int_1(0);
-    for (n = 0, p = data; n < num_elts; n++, p++)
-      caml_serialize_int_4((int32_t) *p);
-  }
-#else
-  caml_serialize_int_1(0);
-  caml_serialize_block_4(data, num_elts);
-#endif
-}
-
-static void caml_ba_serialize(value v,
-                              uintnat * wsize_32,
-                              uintnat * wsize_64)
-{
-  struct caml_ba_array * b = Caml_ba_array_val(v);
-  intnat num_elts;
-  int i;
-
-  /* Serialize header information */
-  caml_serialize_int_4(b->num_dims);
-  caml_serialize_int_4(b->flags & (CAML_BA_KIND_MASK | CAML_BA_LAYOUT_MASK));
-  /* On a 64-bit machine, if any of the dimensions is >= 2^32,
-     the size of the marshaled data will be >= 2^32 and
-     extern_value() will fail.  So, it is safe to write the dimensions
-     as 32-bit unsigned integers. */
-  for (i = 0; i < b->num_dims; i++) caml_serialize_int_4(b->dim[i]);
-  /* Compute total number of elements */
-  num_elts = 1;
-  for (i = 0; i < b->num_dims; i++) num_elts = num_elts * b->dim[i];
-  /* Serialize elements */
-  switch (b->flags & CAML_BA_KIND_MASK) {
-  case CAML_BA_CHAR:
-  case CAML_BA_SINT8:
-  case CAML_BA_UINT8:
-    caml_serialize_block_1(b->data, num_elts); break;
-  case CAML_BA_SINT16:
-  case CAML_BA_UINT16:
-    caml_serialize_block_2(b->data, num_elts); break;
-  case CAML_BA_FLOAT32:
-  case CAML_BA_INT32:
-    caml_serialize_block_4(b->data, num_elts); break;
-  case CAML_BA_COMPLEX32:
-    caml_serialize_block_4(b->data, num_elts * 2); break;
-  case CAML_BA_FLOAT64:
-  case CAML_BA_INT64:
-    caml_serialize_block_8(b->data, num_elts); break;
-  case CAML_BA_COMPLEX64:
-    caml_serialize_block_8(b->data, num_elts * 2); break;
-  case CAML_BA_CAML_INT:
-    caml_ba_serialize_longarray(b->data, num_elts, -0x40000000, 0x3FFFFFFF);
-    break;
-  case CAML_BA_NATIVE_INT:
-    caml_ba_serialize_longarray(b->data, num_elts, -0x80000000, 0x7FFFFFFF);
-    break;
-  }
-  /* Compute required size in OCaml heap.  Assumes struct caml_ba_array
-     is exactly 4 + num_dims words */
-  Assert(SIZEOF_BA_ARRAY == 4 * sizeof(value));
-  *wsize_32 = (4 + b->num_dims) * 4;
-  *wsize_64 = (4 + b->num_dims) * 8;
-}
-
-static void caml_ba_deserialize_longarray(void * dest, intnat num_elts)
-{
-  int sixty = caml_deserialize_uint_1();
-#ifdef ARCH_SIXTYFOUR
-  if (sixty) {
-    caml_deserialize_block_8(dest, num_elts);
-  } else {
-    intnat * p, n;
-    for (n = 0, p = dest; n < num_elts; n++, p++)
-      *p = caml_deserialize_sint_4();
-  }
-#else
-  if (sixty)
-    caml_deserialize_error("input_value: cannot read bigarray "
-                      "with 64-bit OCaml ints");
-  caml_deserialize_block_4(dest, num_elts);
-#endif
-}
-
-uintnat caml_ba_deserialize(void * dst)
-{
-  struct caml_ba_array * b = dst;
-  int i, elt_size;
-  uintnat num_elts;
-
-  /* Read back header information */
-  b->num_dims = caml_deserialize_uint_4();
-  b->flags = caml_deserialize_uint_4() | CAML_BA_MANAGED;
-  b->proxy = NULL;
-  for (i = 0; i < b->num_dims; i++) b->dim[i] = caml_deserialize_uint_4();
-  /* Compute total number of elements */
-  num_elts = caml_ba_num_elts(b);
-  /* Determine element size in bytes */
-  if ((b->flags & CAML_BA_KIND_MASK) > CAML_BA_CHAR)
-    caml_deserialize_error("input_value: bad bigarray kind");
-  elt_size = caml_ba_element_size[b->flags & CAML_BA_KIND_MASK];
-  /* Allocate room for data */
-  b->data = malloc(elt_size * num_elts);
-  if (b->data == NULL)
-    caml_deserialize_error("input_value: out of memory for bigarray");
-  /* Read data */
-  switch (b->flags & CAML_BA_KIND_MASK) {
-  case CAML_BA_CHAR:
-  case CAML_BA_SINT8:
-  case CAML_BA_UINT8:
-    caml_deserialize_block_1(b->data, num_elts); break;
-  case CAML_BA_SINT16:
-  case CAML_BA_UINT16:
-    caml_deserialize_block_2(b->data, num_elts); break;
-  case CAML_BA_FLOAT32:
-  case CAML_BA_INT32:
-    caml_deserialize_block_4(b->data, num_elts); break;
-  case CAML_BA_COMPLEX32:
-    caml_deserialize_block_4(b->data, num_elts * 2); break;
-  case CAML_BA_FLOAT64:
-  case CAML_BA_INT64:
-    caml_deserialize_block_8(b->data, num_elts); break;
-  case CAML_BA_COMPLEX64:
-    caml_deserialize_block_8(b->data, num_elts * 2); break;
-  case CAML_BA_CAML_INT:
-  case CAML_BA_NATIVE_INT:
-    caml_ba_deserialize_longarray(b->data, num_elts); break;
-  }
-  /* PR#5516: use C99's flexible array types if possible */
-  return SIZEOF_BA_ARRAY + b->num_dims * sizeof(intnat);
-}
-
 /* Create / update proxy to indicate that b2 is a sub-array of b1 */
 
 static void caml_ba_update_proxy(struct caml_ba_array * b1,
@@ -1026,7 +520,8 @@ static void caml_ba_update_proxy(struct caml_ba_array * b1,
     ++ b1->proxy->refcount;
   } else {
     /* Otherwise, create proxy and attach it to both b1 and b2 */
-    proxy = caml_stat_alloc(sizeof(struct caml_ba_proxy));
+    proxy = malloc(sizeof(struct caml_ba_proxy));
+    if (proxy == NULL) caml_raise_out_of_memory();
     proxy->refcount = 2;      /* original array + sub array */
     proxy->data = b1->data;
     proxy->size =
@@ -1217,7 +712,7 @@ CAMLprim value caml_ba_fill(value vb, value vinit)
 
   switch (b->flags & CAML_BA_KIND_MASK) {
   default:
-    Assert(0);
+    CAMLassert(0);
   case CAML_BA_FLOAT32: {
     float init = Double_val(vinit);
     float * p;
@@ -1323,11 +818,3 @@ CAMLprim value caml_ba_reshape(value vb, value vdim)
 
 #undef b
 }
-
-/* Initialization */
-
-CAMLprim value caml_ba_init(value unit)
-{
-  caml_register_custom_operations(&caml_ba_ops);
-  return Val_unit;
-}

diff --git a/otherlibs/bigarray/mmap_unix.c b/otherlibs/bigarray/mmap_unix.c
deleted file mode 100644 (file)
index f276514..0000000
--- a/otherlibs/bigarray/mmap_unix.c
+++ /dev/null
@@ -1,206 +0,0 @@
-/**************************************************************************/
-/*                                                                        */
-/*                                 OCaml                                  */
-/*                                                                        */
-/*          Manuel Serrano and Xavier Leroy, INRIA Rocquencourt           */
-/*                                                                        */
-/*   Copyright 2000 Institut National de Recherche en Informatique et     */
-/*     en Automatique.                                                    */
-/*                                                                        */
-/*   All rights reserved.  This file is distributed under the terms of    */
-/*   the GNU Lesser General Public License version 2.1, with the          */
-/*   special exception on linking described in the file LICENSE.          */
-/*                                                                        */
-/**************************************************************************/
-
-#define CAML_INTERNALS
-
-/* Needed (under Linux at least) to get pwrite's prototype in unistd.h.
-   Must be defined before the first system .h is included. */
-#define _XOPEN_SOURCE 600
-
-#include <stddef.h>
-#include <string.h>
-#include "bigarray.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 */
-
-#include <errno.h>
-#ifdef HAS_UNISTD
-#include <unistd.h>
-#endif
-#ifdef HAS_MMAP
-#include <sys/types.h>
-#include <sys/mman.h>
-#include <sys/stat.h>
-#endif
-
-#if defined(HAS_MMAP)
-
-#ifndef MAP_FAILED
-#define MAP_FAILED ((void *) -1)
-#endif
-
-/* [caml_grow_file] function contributed by Gerd Stolpmann (PR#5543). */
-
-static int caml_grow_file(int fd, file_offset size)
-{
-  char c;
-  int p;
-
-  /* First use pwrite for growing - it is a conservative method, as it
-     can never happen that we shrink by accident
-   */
-#ifdef HAS_PWRITE
-  c = 0;
-  p = pwrite(fd, &c, 1, size - 1);
-#else
-
-  /* Emulate pwrite with lseek. This should only be necessary on ancient
-     systems nowadays
-   */
-  file_offset currpos;
-  currpos = lseek(fd, 0, SEEK_CUR);
-  if (currpos != -1) {
-    p = lseek(fd, size - 1, SEEK_SET);
-    if (p != -1) {
-      c = 0;
-      p = write(fd, &c, 1);
-      if (p != -1)
-        p = lseek(fd, currpos, SEEK_SET);
-    }
-  }
-  else p=-1;
-#endif
-#ifdef HAS_TRUNCATE
-  if (p == -1 && errno == ESPIPE) {
-    /* Plan B. Check if at least ftruncate is possible. There are
-       some non-seekable descriptor types that do not support pwrite
-       but ftruncate, like shared memory. We never get into this case
-       for real files, so there is no danger of truncating persistent
-       data by accident
-     */
-    p = ftruncate(fd, size);
-  }
-#endif
-  return p;
-}
-
-
-CAMLprim value caml_ba_map_file(value vfd, value vkind, value vlayout,
-                                value vshared, value vdim, value vstart)
-{
-  int fd, flags, major_dim, shared;
-  intnat num_dims, i;
-  intnat dim[CAML_BA_MAX_NUM_DIMS];
-  file_offset startpos, file_size, data_size;
-  struct stat st;
-  uintnat array_size, page, delta;
-  void * addr;
-
-  fd = Int_val(vfd);
-  flags = Caml_ba_kind_val(vkind) | Caml_ba_layout_val(vlayout);
-  startpos = File_offset_val(vstart);
-  num_dims = Wosize_val(vdim);
-  major_dim = flags & CAML_BA_FORTRAN_LAYOUT ? num_dims - 1 : 0;
-  /* Extract dimensions from OCaml array */
-  num_dims = Wosize_val(vdim);
-  if (num_dims < 1 || num_dims > CAML_BA_MAX_NUM_DIMS)
-    caml_invalid_argument("Bigarray.mmap: bad number of dimensions");
-  for (i = 0; i < num_dims; i++) {
-    dim[i] = Long_val(Field(vdim, i));
-    if (dim[i] == -1 && i == major_dim) continue;
-    if (dim[i] < 0)
-      caml_invalid_argument("Bigarray.create: negative dimension");
-  }
-  /* Determine file size. We avoid lseek here because it is fragile,
-     and because some mappable file types do not support it
-   */
-  caml_enter_blocking_section();
-  if (fstat(fd, &st) == -1) {
-    caml_leave_blocking_section();
-    caml_sys_error(NO_ARG);
-  }
-  file_size = st.st_size;
-  /* Determine array size in bytes (or size of array without the major
-     dimension if that dimension wasn't specified) */
-  array_size = caml_ba_element_size[flags & CAML_BA_KIND_MASK];
-  for (i = 0; i < num_dims; i++)
-    if (dim[i] != -1) array_size *= dim[i];
-  /* Check if the major dimension is unknown */
-  if (dim[major_dim] == -1) {
-    /* Determine major dimension from file size */
-    if (file_size < startpos) {
-      caml_leave_blocking_section();
-      caml_failwith("Bigarray.mmap: file position exceeds file size");
-    }
-    data_size = file_size - startpos;
-    dim[major_dim] = (uintnat) (data_size / array_size);
-    array_size = dim[major_dim] * array_size;
-    if (array_size != data_size) {
-      caml_leave_blocking_section();
-      caml_failwith("Bigarray.mmap: file size doesn't match array dimensions");
-    }
-  } else {
-    /* Check that file is large enough, and grow it otherwise */
-    if (file_size < startpos + array_size) {
-      if (caml_grow_file(fd, startpos + array_size) == -1) { /* PR#5543 */
-        caml_leave_blocking_section();
-        caml_sys_error(NO_ARG);
-      }
-    }
-  }
-  /* Determine offset so that the mapping starts at the given file pos */
-  page = sysconf(_SC_PAGESIZE);
-  delta = (uintnat) startpos % page;
-  /* Do the mmap */
-  shared = Bool_val(vshared) ? MAP_SHARED : MAP_PRIVATE;
-  if (array_size > 0)
-    addr = mmap(NULL, array_size + delta, PROT_READ | PROT_WRITE,
-                shared, fd, startpos - delta);
-  else
-    addr = NULL;                /* PR#5463 - mmap fails on empty region */
-  caml_leave_blocking_section();
-  if (addr == (void *) MAP_FAILED) caml_sys_error(NO_ARG);
-  addr = (void *) ((uintnat) addr + delta);
-  /* Build and return the OCaml bigarray */
-  return caml_ba_alloc(flags | CAML_BA_MAPPED_FILE, num_dims, addr, dim);
-}
-
-#else
-
-CAMLprim value caml_ba_map_file(value vfd, value vkind, value vlayout,
-                                value vshared, value vdim, value vpos)
-{
-  caml_invalid_argument("Bigarray.map_file: not supported");
-  return Val_unit;
-}
-
-#endif
-
-CAMLprim value caml_ba_map_file_bytecode(value * argv, int argn)
-{
-  return caml_ba_map_file(argv[0], argv[1], argv[2],
-                          argv[3], argv[4], argv[5]);
-}
-
-void caml_ba_unmap_file(void * addr, uintnat len)
-{
-#if defined(HAS_MMAP)
-  uintnat page = sysconf(_SC_PAGESIZE);
-  uintnat delta = (uintnat) addr % page;
-  if (len == 0) return;         /* PR#5463 */
-  addr = (void *)((uintnat)addr - delta);
-  len  = len + delta;
-#if defined(_POSIX_SYNCHRONIZED_IO)
-  msync(addr, len, MS_ASYNC);   /* PR#3571 */
-#endif
-  munmap(addr, len);
-#endif
-}

diff --git a/otherlibs/bigarray/mmap_win32.c b/otherlibs/bigarray/mmap_win32.c
deleted file mode 100644 (file)
index 89ac6a4..0000000
--- a/otherlibs/bigarray/mmap_win32.c
+++ /dev/null
@@ -1,155 +0,0 @@
-/**************************************************************************/
-/*                                                                        */
-/*                                 OCaml                                  */
-/*                                                                        */
-/*          Manuel Serrano and Xavier Leroy, INRIA Rocquencourt           */
-/*                                                                        */
-/*   Copyright 2000 Institut National de Recherche en Informatique et     */
-/*     en Automatique.                                                    */
-/*                                                                        */
-/*   All rights reserved.  This file is distributed under the terms of    */
-/*   the GNU Lesser General Public License version 2.1, with the          */
-/*   special exception on linking described in the file LICENSE.          */
-/*                                                                        */
-/**************************************************************************/
-
-#include <stddef.h>
-#include <stdio.h>
-#include <string.h>
-#include "bigarray.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 */
-
-static void caml_ba_sys_error(void);
-
-#ifndef INVALID_SET_FILE_POINTER
-#define INVALID_SET_FILE_POINTER (-1)
-#endif
-
-static __int64 caml_ba_set_file_pointer(HANDLE h, __int64 dist, DWORD mode)
-{
-  LARGE_INTEGER i;
-  DWORD err;
-
-  i.QuadPart = dist;
-  i.LowPart = SetFilePointer(h, i.LowPart, &i.HighPart, mode);
-  if (i.LowPart == INVALID_SET_FILE_POINTER) return -1;
-  return i.QuadPart;
-}
-
-CAMLprim value caml_ba_map_file(value vfd, value vkind, value vlayout,
-                                value vshared, value vdim, value vstart)
-{
-  HANDLE fd, fmap;
-  int flags, major_dim, mode, perm;
-  intnat num_dims, i;
-  intnat dim[CAML_BA_MAX_NUM_DIMS];
-  __int64 currpos, startpos, file_size, data_size;
-  uintnat array_size, page, delta;
-  char c;
-  void * addr;
-  LARGE_INTEGER li;
-  SYSTEM_INFO sysinfo;
-
-  fd = Handle_val(vfd);
-  flags = Caml_ba_kind_val(vkind) | Caml_ba_layout_val(vlayout);
-  startpos = Int64_val(vstart);
-  num_dims = Wosize_val(vdim);
-  major_dim = flags & CAML_BA_FORTRAN_LAYOUT ? num_dims - 1 : 0;
-  /* Extract dimensions from OCaml array */
-  num_dims = Wosize_val(vdim);
-  if (num_dims < 1 || num_dims > CAML_BA_MAX_NUM_DIMS)
-    caml_invalid_argument("Bigarray.mmap: bad number of dimensions");
-  for (i = 0; i < num_dims; i++) {
-    dim[i] = Long_val(Field(vdim, i));
-    if (dim[i] == -1 && i == major_dim) continue;
-    if (dim[i] < 0)
-      caml_invalid_argument("Bigarray.create: negative dimension");
-  }
-  /* Determine file size */
-  currpos = caml_ba_set_file_pointer(fd, 0, FILE_CURRENT);
-  if (currpos == -1) caml_ba_sys_error();
-  file_size = caml_ba_set_file_pointer(fd, 0, FILE_END);
-  if (file_size == -1) caml_ba_sys_error();
-  /* Determine array size in bytes (or size of array without the major
-     dimension if that dimension wasn't specified) */
-  array_size = caml_ba_element_size[flags & CAML_BA_KIND_MASK];
-  for (i = 0; i < num_dims; i++)
-    if (dim[i] != -1) array_size *= dim[i];
-  /* Check if the first/last dimension is unknown */
-  if (dim[major_dim] == -1) {
-    /* Determine first/last dimension from file size */
-    if (file_size < startpos)
-      caml_failwith("Bigarray.mmap: file position exceeds file size");
-    data_size = file_size - startpos;
-    dim[major_dim] = (uintnat) (data_size / array_size);
-    array_size = dim[major_dim] * array_size;
-    if (array_size != data_size)
-      caml_failwith("Bigarray.mmap: file size doesn't match array dimensions");
-  }
-  /* Restore original file position */
-  caml_ba_set_file_pointer(fd, currpos, FILE_BEGIN);
-  /* Create the file mapping */
-  if (Bool_val(vshared)) {
-    perm = PAGE_READWRITE;
-    mode = FILE_MAP_WRITE;
-  } else {
-    perm = PAGE_READONLY;       /* doesn't work under Win98 */
-    mode = FILE_MAP_COPY;
-  }
-  li.QuadPart = startpos + array_size;
-  fmap = CreateFileMapping(fd, NULL, perm, li.HighPart, li.LowPart, NULL);
-  if (fmap == NULL) caml_ba_sys_error();
-  /* Determine offset so that the mapping starts at the given file pos */
-  GetSystemInfo(&sysinfo);
-  delta = (uintnat) (startpos % sysinfo.dwAllocationGranularity);
-  /* Map the mapping in memory */
-  li.QuadPart = startpos - delta;
-  addr =
-    MapViewOfFile(fmap, mode, li.HighPart, li.LowPart, array_size + delta);
-  if (addr == NULL) caml_ba_sys_error();
-  addr = (void *) ((uintnat) addr + delta);
-  /* Close the file mapping */
-  CloseHandle(fmap);
-  /* Build and return the OCaml bigarray */
-  return caml_ba_alloc(flags | CAML_BA_MAPPED_FILE, num_dims, addr, dim);
-}
-
-CAMLprim value caml_ba_map_file_bytecode(value * argv, int argn)
-{
-  return caml_ba_map_file(argv[0], argv[1], argv[2],
-                          argv[3], argv[4], argv[5]);
-}
-
-void caml_ba_unmap_file(void * addr, uintnat len)
-{
-  SYSTEM_INFO sysinfo;
-  uintnat delta;
-
-  GetSystemInfo(&sysinfo);
-  delta = (uintnat) addr % sysinfo.dwAllocationGranularity;
-  UnmapViewOfFile((void *)((uintnat)addr - delta));
-}
-
-static void caml_ba_sys_error(void)
-{
-  char buffer[512];
-  DWORD errnum;
-
-  errnum = GetLastError();
-  if (!FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM|FORMAT_MESSAGE_IGNORE_INSERTS,
-                     NULL,
-                     errnum,
-                     0,
-                     buffer,
-                     sizeof(buffer),
-                     NULL))
-    sprintf(buffer, "Unknown error %ld\n", errnum);
-  caml_raise_sys_error(caml_copy_string(buffer));
-}

diff --git a/otherlibs/dynlink/dynlink.mli b/otherlibs/dynlink/dynlink.mli
index 39b3ea62d74dcefdda0eb3a203503733d08d2f9d..fabbe6d3109a1ed0804258ce7d78f692e20ccd6e 100644 (file)
--- a/otherlibs/dynlink/dynlink.mli
+++ b/otherlibs/dynlink/dynlink.mli
@@ -19,7 +19,7 @@ val is_native: bool
 (** [true] if the program is native,
     [false] if the program is bytecode. *)
 
-(** {6 Dynamic loading of compiled files} *)
+(** {1 Dynamic loading of compiled files} *)
 
 val loadfile : string -> unit
 (** In bytecode: load the given bytecode object file ([.cmo] file) or
@@ -42,7 +42,7 @@ val adapt_filename : string -> string
 (** In bytecode, the identity function. In native code, replace the last
     extension with [.cmxs]. *)
 
-(** {6 Access control} *)
+(** {1 Access control} *)
 
 val allow_only: string list -> unit
 (** [allow_only units] restricts the compilation units that
@@ -81,7 +81,7 @@ val allow_unsafe_modules : bool -> unit
     not allowed. In native code, this function does nothing; object files
     with external functions are always allowed to be dynamically linked. *)
 
-(** {6 Deprecated, low-level API for access control} *)
+(** {1 Deprecated, low-level API for access control} *)
 
 (** @deprecated  The functions [add_interfaces], [add_available_units]
     and [clear_available_units] should not be used in new programs,
@@ -109,13 +109,13 @@ val clear_available_units : unit -> unit
 (** Empty the list of compilation units accessible to dynamically-linked
     programs. *)
 
-(** {6 Deprecated, initialization} *)
+(** {1 Deprecated, initialization} *)
 
 val init : unit -> unit
 (** @deprecated Initialize the [Dynlink] library. This function is called
     automatically when needed. *)
 
-(** {6 Error reporting} *)
+(** {1 Error reporting} *)
 
 type linking_error =
     Undefined_global of string
@@ -143,6 +143,6 @@ val error_message : error -> string
 
 (**/**)
 
-(** {6 Internal functions} *)
+(** {1 Internal functions} *)
 
 val digest_interface : string -> string list -> Digest.t

diff --git a/otherlibs/dynlink/natdynlink.ml b/otherlibs/dynlink/natdynlink.ml
index de237728b0e74563a38106ec643764fc8947316c..71aec3f164d27a94747a607373c016981bb016f4 100644 (file)
--- a/otherlibs/dynlink/natdynlink.ml
+++ b/otherlibs/dynlink/natdynlink.ml
@@ -51,7 +51,7 @@ type error =
 exception Error of error
 
 (* Copied from config.ml to avoid dependencies *)
-let cmxs_magic_number = "Caml2007D002"
+let cmxs_magic_number = "Caml1999D022"
 
 let dll_filename fname =
   if Filename.is_implicit fname then Filename.concat (Sys.getcwd ()) fname

diff --git a/otherlibs/graph/.depend b/otherlibs/graph/.depend
index ada82fd646bcd767edbf2627232ee1862f3b56b8..fdfa62008cf55f75ae8f17e1b12716b9ea6ba542 100644 (file)
--- a/otherlibs/graph/.depend
+++ b/otherlibs/graph/.depend
@@ -1,97 +1,3 @@
-color.o: color.c libgraph.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 \
- 
-draw.o: draw.c libgraph.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/alloc.h
-dump_img.o: dump_img.c libgraph.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 image.h \
-  ../../byterun/caml/alloc.h ../../byterun/caml/memory.h
-events.o: events.c libgraph.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/alloc.h ../../byterun/caml/signals.h
-fill.o: fill.c libgraph.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/memory.h
-image.o: image.c libgraph.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 image.h \
-  ../../byterun/caml/alloc.h ../../byterun/caml/custom.h
-make_img.o: make_img.c libgraph.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 image.h \
-  ../../byterun/caml/memory.h
-open.o: open.c libgraph.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/alloc.h ../../byterun/caml/callback.h \
-  ../../byterun/caml/fail.h ../../byterun/caml/memory.h
-point_col.o: point_col.c libgraph.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
-sound.o: sound.c libgraph.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
-subwindow.o: subwindow.c libgraph.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
-text.o: text.c libgraph.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/alloc.h
 graphics.cmo : graphics.cmi
 graphics.cmx : graphics.cmi
 graphics.cmi :

diff --git a/otherlibs/graph/Makefile b/otherlibs/graph/Makefile
index 6887554320fec78d698298a33e18976c67619803..ff8f45b006a29c622f531f11110d29c7e363e637 100644 (file)
--- a/otherlibs/graph/Makefile
+++ b/otherlibs/graph/Makefile
@@ -28,7 +28,7 @@ EXTRACFLAGS=$(X11_INCLUDES)
 include ../Makefile
 
 depend:
-       $(CC) -MM $(CFLAGS) *.c | sed -e 's, /[^ ]*\.h,,g' > .depend
+       $(CC) -MM $(CPPFLAGS) *.c | sed -e 's, /[^ ]*\.h,,g' > .depend
        $(CAMLRUN) ../../tools/ocamldep -slash *.mli *.ml >> .depend
 
 include .depend

diff --git a/otherlibs/graph/graphics.mli b/otherlibs/graph/graphics.mli
index e364f6e0996ee94ac4823dcc6a4b90a5ce86d08a..2373241cba06fd30e19bdb234c4498e463aaa5c5 100644 (file)
--- a/otherlibs/graph/graphics.mli
+++ b/otherlibs/graph/graphics.mli
@@ -19,7 +19,7 @@ exception Graphic_failure of string
 (** Raised by the functions below when they encounter an error. *)
 
 
-(** {6 Initializations} *)
+(** {1 Initializations} *)
 
 val open_graph : string -> unit
 (** Show the graphics window or switch the screen to graphic mode.
@@ -53,7 +53,7 @@ external size_y : unit -> int = "caml_gr_size_y"
    16-bit integers, hence wrong clipping may occur with coordinates
    below [-32768] or above [32676]. *)
 
-(** {6 Colors} *)
+(** {1 Colors} *)
 
 type color = int
 (** A color is specified by its R, G, B components. Each component
@@ -93,7 +93,7 @@ val cyan : color
 val magenta : color
 
 
-(** {6 Point and line drawing} *)
+(** {1 Point and line drawing} *)
 
 external plot : int -> int -> unit = "caml_gr_plot"
 (** Plot the given point with the current drawing color. *)
@@ -184,7 +184,7 @@ val set_line_width : int -> unit
    used when [set_line_width 1] is specified.
    Raise [Invalid_argument] if the argument is negative. *)
 
-(** {6 Text drawing} *)
+(** {1 Text drawing} *)
 
 external draw_char : char -> unit = "caml_gr_draw_char"
 (** See {!Graphics.draw_string}.*)
@@ -209,7 +209,7 @@ external text_size : string -> int * int = "caml_gr_text_size"
    the current font and size. *)
 
 
-(** {6 Filling} *)
+(** {1 Filling} *)
 
 val fill_rect : int -> int -> int -> int -> unit
 (** [fill_rect x y w h] fills the rectangle with lower left corner
@@ -233,7 +233,7 @@ val fill_circle : int -> int -> int -> unit
    parameters are the same as for {!Graphics.draw_circle}. *)
 
 
-(** {6 Images} *)
+(** {1 Images} *)
 
 type image
 (** The abstract type for images, in internal representation.
@@ -277,7 +277,7 @@ external blit_image : image -> int -> int -> unit = "caml_gr_blit_image"
    [img] are left unchanged. *)
 
 
-(** {6 Mouse and keyboard events} *)
+(** {1 Mouse and keyboard events} *)
 
 type status =
   { mouse_x : int;              (** X coordinate of the mouse *)
@@ -316,7 +316,7 @@ val loop_at_exit : event list -> (status -> unit) -> unit
     @since 4.01
 *)
 
-(** {6 Mouse and keyboard polling} *)
+(** {1 Mouse and keyboard polling} *)
 
 val mouse_pos : unit -> int * int
 (** Return the position of the mouse cursor, relative to the
@@ -336,13 +336,13 @@ val key_pressed : unit -> bool
    would not block. *)
 
 
-(** {6 Sound} *)
+(** {1 Sound} *)
 
 external sound : int -> int -> unit = "caml_gr_sound"
 (** [sound freq dur] plays a sound at frequency [freq] (in hertz)
    for a duration [dur] (in milliseconds). *)
 
-(** {6 Double buffering} *)
+(** {1 Double buffering} *)
 
 val auto_synchronize : bool -> unit
 (** By default, drawing takes place both on the window displayed

diff --git a/otherlibs/graph/libgraph.h b/otherlibs/graph/libgraph.h
index 5eb397af5803f0681a9ebed8145c183186fb7d49..e2dcb2bf2adc15cb7646ac2e5a259cd9f9dccb1c 100644 (file)
--- a/otherlibs/graph/libgraph.h
+++ b/otherlibs/graph/libgraph.h
@@ -77,7 +77,7 @@ extern int caml_gr_bits_per_pixel;
 #endif
 
 CAMLnoreturn_start
-extern void caml_gr_fail(char *fmt, char *arg)
+extern void caml_gr_fail(const char *fmt, const char *arg)
 CAMLnoreturn_end;
 
 extern void caml_gr_check_open(void);

diff --git a/otherlibs/graph/open.c b/otherlibs/graph/open.c
index 8f6ee07fb0a6f2e53583383c6068311a2119288f..10a0c4ad76b775c66c3f233a3357fc7f9e5cbc37 100644 (file)
--- a/otherlibs/graph/open.c
+++ b/otherlibs/graph/open.c
@@ -51,7 +51,8 @@ value caml_gr_clear_graph(void);
 value caml_gr_open_graph(value arg)
 {
   char display_name[256], geometry_spec[64];
-  char * p, * q;
+  const char * p;
+  char * q;
   XSizeHints hints;
   int ret;
   XEvent event;
@@ -246,7 +247,7 @@ value caml_gr_window_id(void)
 value caml_gr_set_window_title(value n)
 {
   if (window_name != NULL) caml_stat_free(window_name);
-  window_name = caml_strdup(String_val(n));
+  window_name = caml_stat_strdup(String_val(n));
   if (caml_gr_initialized) {
     XStoreName(caml_gr_display, caml_gr_window.win, window_name);
     XSetIconName(caml_gr_display, caml_gr_window.win, window_name);
@@ -366,7 +367,7 @@ value caml_gr_sigio_handler(void)
 
 static value * graphic_failure_exn = NULL;
 
-void caml_gr_fail(char *fmt, char *arg)
+void caml_gr_fail(const char *fmt, const char *arg)
 {
   char buffer[1024];
 

diff --git a/otherlibs/graph/text.c b/otherlibs/graph/text.c
index 7328967d95f3ea3e196842e45484c68e425a847d..d98c884e068b584ce6419927ede431508dc91c20 100644 (file)
--- a/otherlibs/graph/text.c
+++ b/otherlibs/graph/text.c
@@ -18,7 +18,7 @@
 
 XFontStruct * caml_gr_font = NULL;
 
-static void caml_gr_get_font(char *fontname)
+static void caml_gr_get_font(const char *fontname)
 {
   XFontStruct * font = XLoadQueryFont(caml_gr_display, fontname);
   if (font == NULL) caml_gr_fail("cannot find font %s", fontname);
@@ -40,7 +40,7 @@ value caml_gr_set_text_size (value sz)
   return Val_unit;
 }
 
-static void caml_gr_draw_text(char *txt, int len)
+static void caml_gr_draw_text(const char *txt, int len)
 {
   if (caml_gr_font == NULL) caml_gr_get_font(DEFAULT_FONT);
   if (caml_gr_remember_modeflag)

diff --git a/otherlibs/num/.depend b/otherlibs/num/.depend
deleted file mode 100644 (file)
index 906bca5..0000000
--- a/otherlibs/num/.depend
+++ /dev/null
@@ -1,41 +0,0 @@
-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/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/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 bng.h nat.h
-arith_flags.cmo : arith_flags.cmi
-arith_flags.cmx : arith_flags.cmi
-arith_flags.cmi :
-arith_status.cmo : arith_flags.cmi arith_status.cmi
-arith_status.cmx : arith_flags.cmx arith_status.cmi
-arith_status.cmi :
-big_int.cmo : nat.cmi int_misc.cmi big_int.cmi
-big_int.cmx : nat.cmx int_misc.cmx big_int.cmi
-big_int.cmi : nat.cmi
-int_misc.cmo : int_misc.cmi
-int_misc.cmx : int_misc.cmi
-int_misc.cmi :
-nat.cmo : int_misc.cmi nat.cmi
-nat.cmx : int_misc.cmx nat.cmi
-nat.cmi :
-num.cmo : ratio.cmi nat.cmi int_misc.cmi big_int.cmi arith_flags.cmi num.cmi
-num.cmx : ratio.cmx nat.cmx int_misc.cmx big_int.cmx arith_flags.cmx num.cmi
-num.cmi : ratio.cmi nat.cmi big_int.cmi
-ratio.cmo : nat.cmi int_misc.cmi big_int.cmi arith_flags.cmi ratio.cmi
-ratio.cmx : nat.cmx int_misc.cmx big_int.cmx arith_flags.cmx ratio.cmi
-ratio.cmi : nat.cmi big_int.cmi

diff --git a/otherlibs/num/.depend.nt b/otherlibs/num/.depend.nt
deleted file mode 100644 (file)
index a22644b..0000000
--- a/otherlibs/num/.depend.nt
+++ /dev/null
@@ -1,66 +0,0 @@
-bng.dobj: bng.c bng.h ../../byterun/config.h ../../config/m.h \
-  ../../config/s.h ../../byterun/compatibility.h bng_ppc.c bng_digit.c
-bng_alpha.dobj: bng_alpha.c
-bng_amd64.dobj: bng_amd64.c
-bng_digit.dobj: bng_digit.c
-bng_ia32.dobj: bng_ia32.c
-bng_mips.dobj: bng_mips.c
-bng_ppc.dobj: bng_ppc.c
-bng_sparc.dobj: bng_sparc.c
-nat_stubs.dobj: nat_stubs.c ../../byterun/alloc.h \
-  ../../byterun/compatibility.h ../../byterun/misc.h \
-  ../../byterun/config.h ../../config/m.h ../../config/s.h \
-  ../../byterun/mlvalues.h ../../byterun/custom.h ../../byterun/intext.h \
-  ../../byterun/io.h ../../byterun/fix_code.h ../../byterun/fail.h \
-  ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \
-  ../../byterun/freelist.h ../../byterun/minor_gc.h bng.h nat.h
-big_int.cmi: nat.cmi
-num.cmi: ratio.cmi nat.cmi big_int.cmi
-ratio.cmi: nat.cmi big_int.cmi
-arith_flags.cmo: arith_flags.cmi
-arith_flags.cmx: arith_flags.cmi
-arith_status.cmo: arith_flags.cmi arith_status.cmi
-arith_status.cmx: arith_flags.cmx arith_status.cmi
-big_int.cmo: nat.cmi int_misc.cmi big_int.cmi
-big_int.cmx: nat.cmx int_misc.cmx big_int.cmi
-int_misc.cmo: int_misc.cmi
-int_misc.cmx: int_misc.cmi
-nat.cmo: int_misc.cmi nat.cmi
-nat.cmx: int_misc.cmx nat.cmi
-num.cmo: ratio.cmi nat.cmi int_misc.cmi big_int.cmi arith_flags.cmi num.cmi
-num.cmx: ratio.cmx nat.cmx int_misc.cmx big_int.cmx arith_flags.cmx num.cmi
-ratio.cmo: nat.cmi int_misc.cmi big_int.cmi arith_flags.cmi ratio.cmi
-ratio.cmx: nat.cmx int_misc.cmx big_int.cmx arith_flags.cmx ratio.cmi
-bng.sobj: bng.c bng.h ../../byterun/config.h ../../config/m.h \
-  ../../config/s.h ../../byterun/compatibility.h bng_ppc.c bng_digit.c
-bng_alpha.sobj: bng_alpha.c
-bng_amd64.sobj: bng_amd64.c
-bng_digit.sobj: bng_digit.c
-bng_ia32.sobj: bng_ia32.c
-bng_mips.sobj: bng_mips.c
-bng_ppc.sobj: bng_ppc.c
-bng_sparc.sobj: bng_sparc.c
-nat_stubs.sobj: nat_stubs.c ../../byterun/alloc.h \
-  ../../byterun/compatibility.h ../../byterun/misc.h \
-  ../../byterun/config.h ../../config/m.h ../../config/s.h \
-  ../../byterun/mlvalues.h ../../byterun/custom.h ../../byterun/intext.h \
-  ../../byterun/io.h ../../byterun/fix_code.h ../../byterun/fail.h \
-  ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \
-  ../../byterun/freelist.h ../../byterun/minor_gc.h bng.h nat.h
-big_int.cmi: nat.cmi
-num.cmi: ratio.cmi nat.cmi big_int.cmi
-ratio.cmi: nat.cmi big_int.cmi
-arith_flags.cmo: arith_flags.cmi
-arith_flags.cmx: arith_flags.cmi
-arith_status.cmo: arith_flags.cmi arith_status.cmi
-arith_status.cmx: arith_flags.cmx arith_status.cmi
-big_int.cmo: nat.cmi int_misc.cmi big_int.cmi
-big_int.cmx: nat.cmx int_misc.cmx big_int.cmi
-int_misc.cmo: int_misc.cmi
-int_misc.cmx: int_misc.cmi
-nat.cmo: int_misc.cmi nat.cmi
-nat.cmx: int_misc.cmx nat.cmi
-num.cmo: ratio.cmi nat.cmi int_misc.cmi big_int.cmi arith_flags.cmi num.cmi
-num.cmx: ratio.cmx nat.cmx int_misc.cmx big_int.cmx arith_flags.cmx num.cmi
-ratio.cmo: nat.cmi int_misc.cmi big_int.cmi arith_flags.cmi ratio.cmi
-ratio.cmx: nat.cmx int_misc.cmx big_int.cmx arith_flags.cmx ratio.cmi

diff --git a/otherlibs/num/Makefile b/otherlibs/num/Makefile
deleted file mode 100644 (file)
index ccd077d..0000000
--- a/otherlibs/num/Makefile
+++ /dev/null
@@ -1,48 +0,0 @@
-#**************************************************************************
-#*                                                                        *
-#*                                 OCaml                                  *
-#*                                                                        *
-#*            Xavier Leroy, projet Cristal, INRIA Rocquencourt            *
-#*                                                                        *
-#*   Copyright 1999 Institut National de Recherche en Informatique et     *
-#*     en Automatique.                                                    *
-#*                                                                        *
-#*   All rights reserved.  This file is distributed under the terms of    *
-#*   the GNU Lesser General Public License version 2.1, with the          *
-#*   special exception on linking described in the file LICENSE.          *
-#*                                                                        *
-#**************************************************************************
-
-# Makefile for the "num" (exact rational arithmetic) library
-
-LIBNAME=nums
-EXTRACFLAGS=-DBNG_ARCH_$(BNG_ARCH) -DBNG_ASM_LEVEL=$(BNG_ASM_LEVEL)
-CAMLOBJS=int_misc.cmo nat.cmo big_int.cmo arith_flags.cmo \
-  ratio.cmo num.cmo arith_status.cmo
-CMIFILES=big_int.cmi nat.cmi num.cmi ratio.cmi arith_status.cmi
-COBJS=bng.$(O) nat_stubs.$(O)
-
-include ../Makefile
-
-clean::
-       rm -f *~
-
-bng.$(O): bng.h bng_digit.c \
-       bng_amd64.c bng_ia32.c bng_ppc.c bng_sparc.c
-
-# At the moment, the following rule only works with gcc
-# It is not a big deal since the .depend file it produces is stored
-# in the repository
-depend:
-       $(CC) -MM $(CFLAGS) *.c > .depend
-       $(CAMLRUN) $(ROOTDIR)/tools/ocamldep -slash *.mli *.ml >> .depend
-
-ifeq "$(TOOLCHAIN)" "msvc"
-
-.depend.nt: .depend
-       sed -e 's/\.o/.$(O)/g' $< > $@
-
-include .depend.nt
-else
-include .depend
-endif

diff --git a/otherlibs/num/Makefile.nt b/otherlibs/num/Makefile.nt
deleted file mode 100644 (file)
index ed9900b..0000000
--- a/otherlibs/num/Makefile.nt
+++ /dev/null
@@ -1,16 +0,0 @@
-#**************************************************************************
-#*                                                                        *
-#*                                 OCaml                                  *
-#*                                                                        *
-#*            Xavier Leroy, projet Cristal, INRIA Rocquencourt            *
-#*                                                                        *
-#*   Copyright 1999 Institut National de Recherche en Informatique et     *
-#*     en Automatique.                                                    *
-#*                                                                        *
-#*   All rights reserved.  This file is distributed under the terms of    *
-#*   the GNU Lesser General Public License version 2.1, with the          *
-#*   special exception on linking described in the file LICENSE.          *
-#*                                                                        *
-#**************************************************************************
-
-include Makefile

diff --git a/otherlibs/num/README b/otherlibs/num/README
deleted file mode 100644 (file)
index a979356..0000000
--- a/otherlibs/num/README
+++ /dev/null
@@ -1,55 +0,0 @@
-The "libnum" library implements exact-precision arithmetic on
-big integers and on rationals.
-
-This library is derived from Valerie Menissie-Morain's implementation
-of rational arithmetic for Caml V3.1 (INRIA).  Xavier Leroy (INRIA)
-did the Caml Light port.  Victor Manuel Gulias Fernandez did the
-initial Caml Special Light port.  Pierre Weis did most of the
-maintenance and bug fixing.
-
-Initially, the low-level big integer operations were provided by the
-BigNum package developed by Bernard Serpette, Jean Vuillemin and
-Jean-Claude Herve (INRIA and Digital PRL).  License issues forced us to
-replace the BigNum package.  The current implementation of low-level
-big integer operations is due to Xavier Leroy.
-
-This library is documented in "The CAML Numbers Reference Manual" by
-Valerie Menissier-Morain, technical report 141, INRIA, july 1992,
-available at ftp://ftp.inria.fr/INRIA/publication/RT/RT-0141.ps.gz
-
-
-USAGE:
-
-To use the bignum library from your programs, just do
-
-    ocamlc <options> nums.cma <.cmo and .ml files>
-or
-    ocamlopt <options> nums.cmxa <.cmx and .ml files>
-
-for the linking phase.
-
-If you'd like to have the bignum functions available at toplevel, do
-
-    ocamlmktop -o ocamltopnum <options> nums.cma <.cmo and .ml files>
-    ./ocamltopnum
-
-As an example, try:
-
-        open Num;;
-        let rec fact n =
-          if n = 0 then Int 1 else mult_num (num_of_int n) (fact(n-1));;
-        string_of_num(fact 1000);;
-
-
-PROCESSOR-SPECIFIC OPTIMIZATIONS:
-
-When compiled with GCC, the low-level primitives use "inline extended asm"
-to exploit useful features of the target processor (additions and
-subtractions with carry; double-width multiplication, division).
-Here are the processors for which such optimizations are available:
-  IA32 (x86)       (carry, dwmult, dwdiv, 64-bit ops with SSE2 if available)
-  AMD64 (Opteron)  (carry, dwmult, dwdiv)
-  PowerPC          (carry, dwmult)
-  Alpha            (dwmult)
-  SPARC            (carry, dwmult, dwdiv)
-  MIPS             (dwmult)

diff --git a/otherlibs/num/arith_flags.ml b/otherlibs/num/arith_flags.ml
deleted file mode 100644 (file)
index a1ca0b0..0000000
--- a/otherlibs/num/arith_flags.ml
+++ /dev/null
@@ -1,24 +0,0 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                 OCaml                                  *)
-(*                                                                        *)
-(*     Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt       *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
-let error_when_null_denominator_flag = ref true;;
-
-let normalize_ratio_flag = ref false;;
-
-let normalize_ratio_when_printing_flag = ref true;;
-
-let floating_precision = ref 12;;
-
-let approx_printing_flag = ref false;;

diff --git a/otherlibs/num/arith_flags.mli b/otherlibs/num/arith_flags.mli
deleted file mode 100644 (file)
index 7dd6bc7..0000000
--- a/otherlibs/num/arith_flags.mli
+++ /dev/null
@@ -1,20 +0,0 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                 OCaml                                  *)
-(*                                                                        *)
-(*     Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt       *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
-val error_when_null_denominator_flag : bool ref
-val normalize_ratio_flag : bool ref
-val normalize_ratio_when_printing_flag : bool ref
-val floating_precision : int ref
-val approx_printing_flag : bool ref

diff --git a/otherlibs/num/arith_status.ml b/otherlibs/num/arith_status.ml
deleted file mode 100644 (file)
index 2fbdd4a..0000000
--- a/otherlibs/num/arith_status.ml
+++ /dev/null
@@ -1,100 +0,0 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                 OCaml                                  *)
-(*                                                                        *)
-(*     Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt       *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
-open Arith_flags;;
-
-let get_error_when_null_denominator () =
-  !error_when_null_denominator_flag
-and set_error_when_null_denominator choice =
- error_when_null_denominator_flag := choice;;
-
-let get_normalize_ratio () = !normalize_ratio_flag
-and set_normalize_ratio choice = normalize_ratio_flag := choice;;
-
-let get_normalize_ratio_when_printing () =
-  !normalize_ratio_when_printing_flag
-and set_normalize_ratio_when_printing choice =
- normalize_ratio_when_printing_flag := choice;;
-
-let get_floating_precision () = !floating_precision
-and set_floating_precision i = floating_precision := i;;
-
-let get_approx_printing () = !approx_printing_flag
-and set_approx_printing b = approx_printing_flag := b;;
-
-let arith_print_string s = print_string s; print_string " --> ";;
-
-let arith_print_bool = function
-  true -> print_string "ON"
-| _ -> print_string "OFF"
-;;
-
-let arith_status () =
-  print_newline ();
-
-  arith_print_string
-  "Normalization during computation";
-  arith_print_bool (get_normalize_ratio ());
-  print_newline ();
-  print_string "     (returned by get_normalize_ratio ())";
-  print_newline ();
-  print_string "     (modifiable with set_normalize_ratio <your choice>)";
-  print_newline ();
-  print_newline ();
-
-  arith_print_string
-  "Normalization when printing";
-  arith_print_bool (get_normalize_ratio_when_printing ());
-  print_newline ();
-  print_string
-  "     (returned by get_normalize_ratio_when_printing ())";
-  print_newline ();
-  print_string
-  "     (modifiable with set_normalize_ratio_when_printing <your choice>)";
-  print_newline ();
-  print_newline ();
-
-  arith_print_string
-  "Floating point approximation when printing rational numbers";
-  arith_print_bool (get_approx_printing ());
-  print_newline ();
-  print_string
-  "     (returned by get_approx_printing ())";
-  print_newline ();
-  print_string
-  "     (modifiable with set_approx_printing <your choice>)";
-  print_newline ();
-  (if (get_approx_printing ())
-      then (print_string "  Default precision = ";
-            print_int (get_floating_precision ());
-            print_newline ();
-            print_string "     (returned by get_floating_precision ())";
-            print_newline ();
-            print_string
-              "     (modifiable with set_floating_precision <your choice>)";
-            print_newline ();
-            print_newline ())
-      else print_newline());
-
-  arith_print_string
-  "Error when a rational denominator is null";
-  arith_print_bool (get_error_when_null_denominator ());
-  print_newline ();
-  print_string "     (returned by get_error_when_null_denominator ())";
-  print_newline ();
-  print_string
-  "     (modifiable with set_error_when_null_denominator <your choice>)";
-  print_newline ()
-;;

diff --git a/otherlibs/num/arith_status.mli b/otherlibs/num/arith_status.mli
deleted file mode 100644 (file)
index ba60434..0000000
--- a/otherlibs/num/arith_status.mli
+++ /dev/null
@@ -1,64 +0,0 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                 OCaml                                  *)
-(*                                                                        *)
-(*     Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt       *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
-(** Flags that control rational arithmetic. *)
-
-val arith_status: unit -> unit
-        (** Print the current status of the arithmetic flags. *)
-
-val get_error_when_null_denominator : unit -> bool
-(** See {!Arith_status.set_error_when_null_denominator}.*)
-
-val set_error_when_null_denominator : bool -> unit
-        (** Get or set the flag [null_denominator]. When on, attempting to
-           create a rational with a null denominator raises an exception.
-           When off, rationals with null denominators are accepted.
-           Initially: on. *)
-
-val get_normalize_ratio : unit -> bool
-(** See {!Arith_status.set_normalize_ratio}.*)
-
-val set_normalize_ratio : bool -> unit
-        (** Get or set the flag [normalize_ratio]. When on, rational
-           numbers are normalized after each operation. When off,
-           rational numbers are not normalized until printed.
-           Initially: off. *)
-
-val get_normalize_ratio_when_printing : unit -> bool
-(** See {!Arith_status.set_normalize_ratio_when_printing}.*)
-
-val set_normalize_ratio_when_printing : bool -> unit
-        (** Get or set the flag [normalize_ratio_when_printing].
-           When on, rational numbers are normalized before being printed.
-           When off, rational numbers are printed as is, without normalization.
-           Initially: on. *)
-
-val get_approx_printing : unit -> bool
-(** See {!Arith_status.set_approx_printing}.*)
-
-val set_approx_printing : bool -> unit
-        (** Get or set the flag [approx_printing].
-           When on, rational numbers are printed as a decimal approximation.
-           When off, rational numbers are printed as a fraction.
-           Initially: off. *)
-
-val get_floating_precision : unit -> int
-(** See {!Arith_status.set_floating_precision}.*)
-
-val set_floating_precision : int -> unit
-        (** Get or set the parameter [floating_precision].
-           This parameter is the number of digits displayed when
-           [approx_printing] is on.
-           Initially: 12. *)

diff --git a/otherlibs/num/big_int.ml b/otherlibs/num/big_int.ml
deleted file mode 100644 (file)
index 45cea9c..0000000
--- a/otherlibs/num/big_int.ml
+++ /dev/null
@@ -1,898 +0,0 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                 OCaml                                  *)
-(*                                                                        *)
-(*     Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt       *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
-open Int_misc
-open Nat
-
-type big_int =
-   { sign : int;
-     abs_value : nat }
-
-let create_big_int sign nat =
- if sign = 1 || sign = -1 ||
-    (sign = 0 &&
-     is_zero_nat nat 0 (num_digits_nat nat 0 (length_nat nat)))
- then { sign = sign;
-         abs_value = nat }
- else invalid_arg "create_big_int"
-
-(* Sign of a big_int *)
-let sign_big_int bi = bi.sign
-
-let zero_big_int =
- { sign = 0;
-   abs_value = make_nat 1 }
-
-let unit_big_int =
-  { sign = 1;
-    abs_value = nat_of_int 1 }
-
-(* Number of digits in a 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;
-   abs_value = copy_nat (bi.abs_value) 0 (num_digits_big_int bi)}
-
-(* Absolute value of a big_int *)
-let abs_big_int bi =
-    { sign = if bi.sign = 0 then 0 else 1;
-      abs_value = copy_nat (bi.abs_value) 0 (num_digits_big_int bi)}
-
-(* Comparison operators on big_int *)
-
-(*
-   compare_big_int (bi, bi2) = sign of (bi-bi2)
-   i.e. 1 if bi > bi2
-        0 if bi = bi2
-        -1 if bi < bi2
-*)
-let compare_big_int bi1 bi2 =
-  if bi1.sign = 0 && bi2.sign = 0 then 0
-  else if bi1.sign < bi2.sign then -1
-  else if bi1.sign > bi2.sign then 1
-  else if bi1.sign = 1 then
-            compare_nat (bi1.abs_value) 0 (num_digits_big_int bi1)
-                        (bi2.abs_value) 0 (num_digits_big_int bi2)
-  else
-            compare_nat (bi2.abs_value) 0 (num_digits_big_int bi2)
-                        (bi1.abs_value) 0 (num_digits_big_int bi1)
-
-let eq_big_int bi1 bi2 = compare_big_int bi1 bi2 = 0
-and le_big_int bi1 bi2 = compare_big_int bi1 bi2 <= 0
-and ge_big_int bi1 bi2 = compare_big_int bi1 bi2 >= 0
-and lt_big_int bi1 bi2 = compare_big_int bi1 bi2 < 0
-and gt_big_int bi1 bi2 = compare_big_int bi1 bi2 > 0
-
-let max_big_int bi1 bi2 = if lt_big_int bi1 bi2 then bi2 else bi1
-and min_big_int bi1 bi2 = if gt_big_int bi1 bi2 then bi2 else bi1
-
-(* Operations on big_int *)
-
-let pred_big_int bi =
- match bi.sign with
-    0 -> { sign = -1; abs_value = nat_of_int 1}
-  | 1 -> let size_bi = num_digits_big_int bi in
-          let copy_bi = copy_nat (bi.abs_value) 0 size_bi in
-            ignore (decr_nat copy_bi 0 size_bi 0);
-            { sign = if is_zero_nat copy_bi 0 size_bi then 0 else 1;
-              abs_value = copy_bi }
-  | _ -> let size_bi = num_digits_big_int bi in
-         let size_res = succ (size_bi) in
-         let copy_bi = create_nat (size_res) in
-          blit_nat copy_bi 0 (bi.abs_value) 0 size_bi;
-          set_digit_nat copy_bi size_bi 0;
-          ignore (incr_nat copy_bi 0 size_res 1);
-          { sign = -1;
-            abs_value = copy_bi }
-
-let succ_big_int bi =
- match bi.sign with
-    0 -> {sign = 1; abs_value = nat_of_int 1}
-  | -1 -> let size_bi = num_digits_big_int bi in
-           let copy_bi = copy_nat (bi.abs_value) 0 size_bi in
-            ignore (decr_nat copy_bi 0 size_bi 0);
-            { sign = if is_zero_nat copy_bi 0 size_bi then 0 else -1;
-              abs_value = copy_bi }
-  | _ -> let size_bi = num_digits_big_int bi in
-         let size_res = succ (size_bi) in
-         let copy_bi = create_nat (size_res) in
-          blit_nat copy_bi 0 (bi.abs_value) 0 size_bi;
-          set_digit_nat copy_bi size_bi 0;
-          ignore (incr_nat copy_bi 0 size_res 1);
-          { sign = 1;
-            abs_value = copy_bi }
-
-let add_big_int bi1 bi2 =
- let size_bi1 = num_digits_big_int bi1
- and size_bi2 = num_digits_big_int bi2 in
-  if bi1.sign = bi2.sign
-   then    (* Add absolute values if signs are the same *)
-    { sign = bi1.sign;
-      abs_value =
-       match compare_nat (bi1.abs_value) 0 size_bi1
-                         (bi2.abs_value) 0 size_bi2 with
-        -1 -> let res = create_nat (succ size_bi2) in
-                (blit_nat res 0 (bi2.abs_value) 0 size_bi2;
-                 set_digit_nat res size_bi2 0;
-                 ignore
-                   (add_nat res 0 (succ size_bi2)
-                      (bi1.abs_value) 0 size_bi1 0);
-                 res)
-       |_  -> let res = create_nat (succ size_bi1) in
-               (blit_nat res 0 (bi1.abs_value) 0 size_bi1;
-                set_digit_nat res size_bi1 0;
-                ignore (add_nat res 0 (succ size_bi1)
-                         (bi2.abs_value) 0 size_bi2 0);
-                res)}
-
-  else      (* Subtract absolute values if signs are different *)
-    match compare_nat (bi1.abs_value) 0 size_bi1
-                      (bi2.abs_value) 0 size_bi2 with
-       0 -> zero_big_int
-     | 1 -> { sign = bi1.sign;
-               abs_value =
-                let res = copy_nat (bi1.abs_value) 0 size_bi1 in
-                 (ignore (sub_nat res 0 size_bi1
-                            (bi2.abs_value) 0 size_bi2 1);
-                  res) }
-     | _ -> { sign = bi2.sign;
-              abs_value =
-               let res = copy_nat (bi2.abs_value) 0 size_bi2 in
-                 (ignore (sub_nat res 0 size_bi2
-                            (bi1.abs_value) 0 size_bi1 1);
-                  res) }
-
-(* Coercion with int type *)
-let big_int_of_int i =
-  { sign = sign_int i;
-    abs_value =
-      let res = (create_nat 1)
-      in (if i = monster_int
-             then (set_digit_nat res 0 biggest_int;
-                   ignore (incr_nat res 0 1 1))
-             else set_digit_nat res 0 (abs i));
-      res }
-
-let add_int_big_int i bi = add_big_int (big_int_of_int i) bi
-
-let sub_big_int bi1 bi2 = add_big_int bi1 (minus_big_int bi2)
-
-(* Returns i * bi *)
-let mult_int_big_int i bi =
- let size_bi = num_digits_big_int bi in
- let size_res = succ size_bi in
-  if i = monster_int
-     then let res = create_nat size_res in
-            blit_nat res 0 (bi.abs_value) 0 size_bi;
-            set_digit_nat res size_bi 0;
-            ignore (mult_digit_nat res 0 size_res (bi.abs_value) 0 size_bi
-                      (nat_of_int biggest_int) 0);
-            { sign = - (sign_big_int bi);
-              abs_value = res }
-     else let res = make_nat (size_res) in
-          ignore (mult_digit_nat res 0 size_res (bi.abs_value) 0 size_bi
-                    (nat_of_int (abs i)) 0);
-          { sign = (sign_int i) * (sign_big_int bi);
-            abs_value = res }
-
-let mult_big_int bi1 bi2 =
- let size_bi1 = num_digits_big_int bi1
- and size_bi2 = num_digits_big_int bi2 in
- let size_res = size_bi1 + size_bi2 in
- let res = make_nat (size_res) in
-  { sign = bi1.sign * bi2.sign;
-    abs_value =
-         if size_bi2 > size_bi1
-           then (ignore (mult_nat res 0 size_res (bi2.abs_value) 0 size_bi2
-                           (bi1.abs_value) 0 size_bi1);res)
-           else (ignore (mult_nat res 0 size_res (bi1.abs_value) 0 size_bi1
-                           (bi2.abs_value) 0 size_bi2);res) }
-
-(* (quotient, remainder ) of the euclidian division of 2 big_int *)
-let quomod_big_int bi1 bi2 =
- if bi2.sign = 0 then raise Division_by_zero
- else
-  let size_bi1 = num_digits_big_int bi1
-  and size_bi2 = num_digits_big_int bi2 in
-   match compare_nat (bi1.abs_value) 0 size_bi1
-                     (bi2.abs_value) 0 size_bi2 with
-      -1 -> (* 1/2  -> 0, remains 1, -1/2  -> -1, remains 1 *)
-            (* 1/-2 -> 0, remains 1, -1/-2 -> 1, remains 1 *)
-             if bi1.sign >= 0 then
-               (big_int_of_int 0, bi1)
-             else if bi2.sign >= 0 then
-               (big_int_of_int(-1), add_big_int bi2 bi1)
-             else
-               (big_int_of_int 1, sub_big_int bi1 bi2)
-    | 0 -> (big_int_of_int (bi1.sign * bi2.sign), zero_big_int)
-    | _ -> let bi1_negatif = bi1.sign = -1 in
-           let size_q =
-            if bi1_negatif
-             then succ (max (succ (size_bi1 - size_bi2)) 1)
-             else max (succ (size_bi1 - size_bi2)) 1
-           and size_r = succ (max size_bi1 size_bi2)
-            (* r is long enough to contain both quotient and remainder *)
-            (* of the euclidian division *)
-           in
-            (* set up quotient, remainder *)
-            let q = create_nat size_q
-            and r = create_nat size_r in
-            blit_nat r 0 (bi1.abs_value) 0 size_bi1;
-            set_to_zero_nat r size_bi1 (size_r - size_bi1);
-
-            (* do the division of |bi1| by |bi2|
-               - at the beginning, r contains |bi1|
-               - at the end, r contains
-                 * in the size_bi2 least significant digits, the remainder
-                 * in the size_r-size_bi2 most significant digits, the quotient
-              note the conditions for application of div_nat are verified here
-             *)
-            div_nat r 0 size_r (bi2.abs_value) 0 size_bi2;
-
-            (* separate quotient and remainder *)
-            blit_nat q 0 r size_bi2 (size_r - size_bi2);
-            let not_null_mod = not (is_zero_nat r 0 size_bi2) in
-
-            (* correct the signs, adjusting the quotient and remainder *)
-            if bi1_negatif && not_null_mod
-             then
-              (* bi1<0, r>0, noting r for (r, size_bi2) the remainder,      *)
-              (* we have |bi1|=q * |bi2| + r with 0 < r < |bi2|,            *)
-              (* thus -bi1 = q * |bi2| + r                                  *)
-              (* and bi1 = (-q) * |bi2| + (-r) with -|bi2| < (-r) < 0       *)
-              (* thus bi1 = -(q+1) * |bi2| + (|bi2|-r)                      *)
-              (* with 0 < (|bi2|-r) < |bi2|                                 *)
-              (* so the quotient has for sign the opposite of the bi2'one   *)
-              (*                 and for value q+1                          *)
-              (* and the remainder is strictly positive                     *)
-              (*                  has for value |bi2|-r                     *)
-              (let new_r = copy_nat (bi2.abs_value) 0 size_bi2 in
-                      (* new_r contains (r, size_bi2) the remainder *)
-                { sign = - bi2.sign;
-                  abs_value = (set_digit_nat q (pred size_q) 0;
-                               ignore (incr_nat q 0 size_q 1); q) },
-                { sign = 1;
-                 abs_value =
-                      (ignore (sub_nat new_r 0 size_bi2 r 0 size_bi2 1);
-                      new_r) })
-             else
-              (if bi1_negatif then set_digit_nat q (pred size_q) 0;
-                { sign = if is_zero_nat q 0 size_q
-                          then 0
-                          else bi1.sign * bi2.sign;
-                  abs_value = q },
-                { sign = if not_null_mod then 1 else 0;
-                  abs_value = copy_nat r 0 size_bi2 })
-
-let div_big_int bi1 bi2 = fst (quomod_big_int bi1 bi2)
-and mod_big_int bi1 bi2 = snd (quomod_big_int bi1 bi2)
-
-let gcd_big_int bi1 bi2 =
- let size_bi1 = num_digits_big_int bi1
- and size_bi2 = num_digits_big_int bi2 in
-  if is_zero_nat (bi1.abs_value) 0 size_bi1 then abs_big_int bi2
-  else if is_zero_nat (bi2.abs_value) 0 size_bi2 then
-        { sign = 1;
-          abs_value = bi1.abs_value }
-  else
-        { sign = 1;
-          abs_value =
-           match compare_nat (bi1.abs_value) 0 size_bi1
-                             (bi2.abs_value) 0 size_bi2 with
-           0 -> bi1.abs_value
-         | 1 ->
-            let res = copy_nat (bi1.abs_value) 0 size_bi1 in
-            let len =
-              gcd_nat res 0 size_bi1 (bi2.abs_value) 0 size_bi2 in
-            copy_nat res 0 len
-         | _ ->
-            let res = copy_nat (bi2.abs_value) 0 size_bi2 in
-            let len =
-              gcd_nat res 0 size_bi2 (bi1.abs_value) 0 size_bi1 in
-            copy_nat res 0 len
-         }
-
-(* Coercion operators *)
-
-let monster_big_int = big_int_of_int monster_int;;
-
-let monster_nat = monster_big_int.abs_value;;
-
-let is_int_big_int bi =
-  num_digits_big_int bi == 1 &&
-  match compare_nat bi.abs_value 0 1 monster_nat 0 1 with
-  | 0 -> bi.sign == -1
-  | -1 -> true
-  | _ -> false;;
-
-let int_of_big_int bi =
-  try let n = int_of_nat bi.abs_value in
-      if bi.sign = -1 then - n else n
-  with Failure _ ->
-    if eq_big_int bi monster_big_int then monster_int
-    else failwith "int_of_big_int";;
-
-let int_of_big_int_opt bi =
-  try Some (int_of_big_int bi) with Failure _ -> None
-
-let big_int_of_nativeint i =
-  if i = 0n then
-    zero_big_int
-  else if i > 0n then begin
-    let res = create_nat 1 in
-    set_digit_nat_native res 0 i;
-    { sign = 1; abs_value = res }
-  end else begin
-    let res = create_nat 1 in
-    set_digit_nat_native res 0 (Nativeint.neg i);
-    { sign = -1; abs_value = res }
-  end
-
-let nativeint_of_big_int bi =
-  if num_digits_big_int bi > 1 then failwith "nativeint_of_big_int";
-  let i = nth_digit_nat_native bi.abs_value 0 in
-  if bi.sign >= 0 then
-    if i >= 0n then i else failwith "nativeint_of_big_int"
-  else
-    if i >= 0n || i = Nativeint.min_int
-    then Nativeint.neg i
-    else failwith "nativeint_of_big_int"
-
-let nativeint_of_big_int_opt bi =
-  try Some (nativeint_of_big_int bi) with Failure _ -> None
-
-let big_int_of_int32 i = big_int_of_nativeint (Nativeint.of_int32 i)
-
-let int32_of_big_int bi =
-  let i = nativeint_of_big_int bi in
-  if i <= 0x7FFF_FFFFn && i >= -0x8000_0000n
-  then Nativeint.to_int32 i
-  else failwith "int32_of_big_int"
-
-let int32_of_big_int_opt bi =
-  try Some (int32_of_big_int bi) with Failure _ -> None
-
-let big_int_of_int64 i =
-  if Sys.word_size = 64 then
-    big_int_of_nativeint (Int64.to_nativeint i)
-  else begin
-    let (sg, absi) =
-      if i = 0L then (0, 0L)
-      else if i > 0L then (1, i)
-      else (-1, Int64.neg i) in
-    let res = create_nat 2 in
-    set_digit_nat_native res 0 (Int64.to_nativeint absi);
-    set_digit_nat_native res 1 (Int64.to_nativeint (Int64.shift_right absi 32));
-    { sign = sg; abs_value = res }
-  end
-
-let int64_of_big_int bi =
-  if Sys.word_size = 64 then
-    Int64.of_nativeint (nativeint_of_big_int bi)
-  else begin
-    let i =
-      match num_digits_big_int bi with
-      | 1 -> Int64.logand
-               (Int64.of_nativeint (nth_digit_nat_native bi.abs_value 0))
-               0xFFFFFFFFL
-      | 2 -> Int64.logor
-               (Int64.logand
-                 (Int64.of_nativeint (nth_digit_nat_native bi.abs_value 0))
-                 0xFFFFFFFFL)
-               (Int64.shift_left
-                 (Int64.of_nativeint (nth_digit_nat_native bi.abs_value 1))
-                 32)
-      | _ -> failwith "int64_of_big_int" in
-    if bi.sign >= 0 then
-      if i >= 0L then i else failwith "int64_of_big_int"
-    else
-      if i >= 0L || i = Int64.min_int
-      then Int64.neg i
-      else failwith "int64_of_big_int"
-  end
-
-let int64_of_big_int_opt bi =
-  try Some (int64_of_big_int bi) with Failure _ -> None
-
-(* Coercion with nat type *)
-let nat_of_big_int bi =
- if bi.sign = -1
- then failwith "nat_of_big_int"
- else copy_nat (bi.abs_value) 0 (num_digits_big_int bi)
-
-let sys_big_int_of_nat nat off len =
- let length = num_digits_nat nat off len in
-    { sign = if is_zero_nat nat off  length then 0 else 1;
-      abs_value = copy_nat nat off length }
-
-let big_int_of_nat nat =
- sys_big_int_of_nat nat 0 (length_nat nat)
-
-(* Coercion with string type *)
-
-let string_of_big_int bi =
-  if bi.sign = -1
-  then "-" ^ string_of_nat bi.abs_value
-  else string_of_nat bi.abs_value
-
-
-let sys_big_int_of_string_aux s ofs len sgn base =
-  if len < 1 then failwith "sys_big_int_of_string";
-  let n = sys_nat_of_string base s ofs len in
-  if is_zero_nat n 0 (length_nat n) then zero_big_int
-  else {sign = sgn; abs_value = n}
-;;
-
-let sys_big_int_of_string_base s ofs len sgn =
-  if len < 1 then failwith "sys_big_int_of_string";
-  if len < 2 then sys_big_int_of_string_aux s ofs len sgn 10
-  else
-    match (s.[ofs], s.[ofs+1]) with
-    | ('0', 'x') | ('0', 'X') ->
-        sys_big_int_of_string_aux s (ofs+2) (len-2) sgn 16
-    | ('0', 'o') | ('0', 'O') ->
-        sys_big_int_of_string_aux s (ofs+2) (len-2) sgn 8
-    | ('0', 'b') | ('0', 'B') ->
-        sys_big_int_of_string_aux s (ofs+2) (len-2) sgn 2
-    | _ -> sys_big_int_of_string_aux s ofs len sgn 10
-;;
-
-let sys_big_int_of_string s ofs len =
-  if len < 1 then failwith "sys_big_int_of_string";
-  match s.[ofs] with
-  | '-' -> sys_big_int_of_string_base s (ofs+1) (len-1) (-1)
-  | '+' -> sys_big_int_of_string_base s (ofs+1) (len-1) 1
-  | _ -> sys_big_int_of_string_base s ofs len 1
-;;
-
-let big_int_of_string s =
-  sys_big_int_of_string s 0 (String.length s)
-
-let big_int_of_string_opt s =
-  try Some (big_int_of_string s) with Failure _ -> None
-
-let power_base_nat base nat off len =
-  if base = 0 then nat_of_int 0 else
-  if is_zero_nat nat off len || base = 1 then nat_of_int 1 else
-  let power_base = make_nat (succ length_of_digit) in
-  let (pmax, _pint) = make_power_base base power_base in
-  let (n, rem) =
-      let (x, y) = quomod_big_int (sys_big_int_of_nat nat off len)
-                                  (big_int_of_int (succ pmax)) in
-        (int_of_big_int x, int_of_big_int y) in
-  if n = 0 then copy_nat power_base (pred rem) 1 else
-   begin
-    let res = make_nat n
-    and res2 = make_nat (succ n)
-    and l = num_bits_int n - 2 in
-      blit_nat res 0 power_base pmax 1;
-      for i = l downto 0 do
-        let len = num_digits_nat res 0 n in
-        let len2 = min n (2 * len) in
-        let succ_len2 = succ len2 in
-          ignore (square_nat res2 0 len2 res 0 len);
-          begin
-           if n land (1 lsl i) > 0
-              then (set_to_zero_nat res 0 len;
-                    ignore (mult_digit_nat res 0 succ_len2
-                              res2 0 len2 power_base pmax))
-              else blit_nat res 0 res2 0 len2
-          end;
-          set_to_zero_nat res2 0 len2
-      done;
-    if rem > 0
-     then (ignore (mult_digit_nat res2 0 (succ n)
-                     res 0 n power_base (pred rem));
-           res2)
-     else res
-  end
-
-let power_int_positive_int i n =
-  match sign_int n with
-    0 -> unit_big_int
-  | -1 -> invalid_arg "power_int_positive_int"
-  | _ -> let nat = power_base_int (abs i) n in
-           { sign = if i >= 0
-                       then sign_int i
-                       else if n land 1 = 0
-                               then 1
-                               else -1;
-             abs_value = nat}
-
-let power_big_int_positive_int bi n =
-  match sign_int n with
-    0 -> unit_big_int
-  | -1 -> invalid_arg "power_big_int_positive_int"
-  | _ -> let bi_len = num_digits_big_int bi in
-         let res_len = bi_len * n in
-         let res = make_nat res_len
-         and res2 = make_nat res_len
-         and l = num_bits_int n - 2 in
-         blit_nat res 0 bi.abs_value 0 bi_len;
-         for i = l downto 0 do
-           let len = num_digits_nat res 0 res_len in
-           let len2 = min res_len (2 * len) in
-           set_to_zero_nat res2 0 len2;
-           ignore (square_nat res2 0 len2 res 0 len);
-           if n land (1 lsl i) > 0 then begin
-             let lenp = min res_len (len2 + bi_len) in
-             set_to_zero_nat res 0 lenp;
-             ignore(mult_nat res 0 lenp res2 0 len2 (bi.abs_value) 0 bi_len)
-           end else begin
-             blit_nat res 0 res2 0 len2
-           end
-         done;
-         {sign = if bi.sign >=  0 then bi.sign
-                 else if n land 1 = 0 then 1 else -1;
-            abs_value = res}
-
-let power_int_positive_big_int i bi =
-  match sign_big_int bi with
-    0 -> unit_big_int
-  | -1 -> invalid_arg "power_int_positive_big_int"
-  | _ -> let nat = power_base_nat
-                     (abs i) (bi.abs_value) 0 (num_digits_big_int bi) in
-           { sign = if i >= 0
-                       then sign_int i
-                       else if is_digit_odd (bi.abs_value) 0
-                               then -1
-                               else 1;
-             abs_value = nat }
-
-let power_big_int_positive_big_int bi1 bi2 =
-  match sign_big_int bi2 with
-    0 -> unit_big_int
-  | -1 -> invalid_arg "power_big_int_positive_big_int"
-  | _ -> try
-           power_big_int_positive_int bi1 (int_of_big_int bi2)
-         with Failure _ ->
-         try
-           power_int_positive_big_int (int_of_big_int bi1) bi2
-         with Failure _ ->
-           raise Out_of_memory
-           (* If neither bi1 nor bi2 is a small integer, bi1^bi2 is not
-              representable.  Indeed, on a 32-bit platform,
-              |bi1| >= 2 and |bi2| >= 2^30, hence bi1^bi2 has at least
-              2^30 bits = 2^27 bytes, greater than the max size of
-              allocated blocks.  On a 64-bit platform,
-              |bi1| >= 2 and |bi2| >= 2^62, hence bi1^bi2 has at least
-              2^62 bits = 2^59 bytes, greater than the max size of
-              allocated blocks. *)
-
-(* base_power_big_int compute bi*base^n *)
-let base_power_big_int base n bi =
-  match sign_int n with
-    0 -> bi
-  | -1 -> let nat = power_base_int base (-n) in
-           let len_nat = num_digits_nat nat 0 (length_nat nat)
-           and len_bi = num_digits_big_int bi in
-             if len_bi < len_nat then
-               invalid_arg "base_power_big_int"
-             else if len_bi = len_nat &&
-                     compare_digits_nat (bi.abs_value) len_bi nat len_nat = -1
-               then invalid_arg "base_power_big_int"
-             else
-               let copy = create_nat (succ len_bi) in
-                      blit_nat copy 0 (bi.abs_value) 0 len_bi;
-                      set_digit_nat copy len_bi 0;
-                      div_nat copy 0 (succ len_bi)
-                              nat 0 len_nat;
-                      if not (is_zero_nat copy 0 len_nat)
-                         then invalid_arg "base_power_big_int"
-                         else { sign = bi.sign;
-                                abs_value = copy_nat copy len_nat 1 }
-  | _ -> let nat = power_base_int base n in
-         let len_nat = num_digits_nat nat 0 (length_nat nat)
-         and len_bi = num_digits_big_int bi in
-         let new_len = len_bi + len_nat in
-         let res = make_nat new_len in
-         ignore
-           (if len_bi > len_nat
-               then mult_nat res 0 new_len
-                              (bi.abs_value) 0 len_bi
-                              nat 0 len_nat
-               else mult_nat res 0 new_len
-                              nat 0 len_nat
-                              (bi.abs_value) 0 len_bi)
-          ; if is_zero_nat res 0 new_len
-               then zero_big_int
-               else create_big_int (bi.sign) res
-
-(* Other functions needed *)
-
-(* Integer part of the square root of a big_int *)
-let sqrt_big_int bi =
- match bi.sign with
- | 0 -> zero_big_int
- | -1 -> invalid_arg "sqrt_big_int"
- | _ -> {sign = 1;
-         abs_value = sqrt_nat (bi.abs_value) 0 (num_digits_big_int bi)}
-
-let square_big_int bi =
-  if bi.sign == 0 then zero_big_int else
-  let len_bi = num_digits_big_int bi in
-  let len_res = 2 * len_bi in
-  let res = make_nat len_res in
-  ignore (square_nat res 0 len_res (bi.abs_value) 0 len_bi);
-  {sign = 1; abs_value = res}
-
-(* round off of the futur last digit (of the integer represented by the string
-   argument of the function) that is now the previous one.
-   if s contains an integer of the form (10^n)-1
-    then s <- only 0 digits and the result_int is true
-   else s <- the round number and the result_int is false *)
-let round_futur_last_digit s off_set length =
- let l = pred (length + off_set) in
-  if Char.code(Bytes.get s l) >= Char.code '5'
-    then
-     let rec round_rec l =
-       if l < off_set then true else begin
-         let current_char = Bytes.get s l in
-         if current_char = '9' then
-           (Bytes.set s l '0'; round_rec (pred l))
-         else
-           (Bytes.set s l (Char.chr (succ (Char.code current_char)));
-            false)
-       end
-     in round_rec (pred l)
-   else false
-
-
-(* Approximation with floating decimal point a` la approx_ratio_exp *)
-let approx_big_int prec bi =
-  let len_bi = num_digits_big_int bi in
-  let n =
-    max 0
-        (int_of_big_int (
-          add_int_big_int
-            (-prec)
-            (div_big_int (mult_big_int (big_int_of_int (pred len_bi))
-                                      (big_int_of_string "963295986"))
-                        (big_int_of_string "100000000")))) in
-  let s =
-    Bytes.unsafe_of_string
-      (string_of_big_int (div_big_int bi (power_int_positive_int 10 n)))
-  in
-  let (sign, off) =
-    if Bytes.get s 0 = '-'
-       then ("-", 1)
-       else ("", 0) in
-  if (round_futur_last_digit s off (succ prec))
-       then (sign^"1."^(String.make prec '0')^"e"^
-             (string_of_int (n + 1 - off + Bytes.length s)))
-       else (sign^(Bytes.sub_string s off 1)^"."^
-             (Bytes.sub_string s (succ off) (pred prec))
-             ^"e"^(string_of_int (n - succ off + Bytes.length s)))
-
-(* Logical operations *)
-
-(* Shift left by N bits *)
-
-let shift_left_big_int bi n =
-  if n < 0 then invalid_arg "shift_left_big_int"
-  else if n = 0 then bi
-  else if bi.sign = 0 then bi
-  else begin
-    let size_bi = num_digits_big_int bi in
-    let size_res = size_bi + ((n + length_of_digit - 1) / length_of_digit) in
-    let res = create_nat size_res in
-    let ndigits = n / length_of_digit in
-    set_to_zero_nat res 0 ndigits;
-    blit_nat res ndigits bi.abs_value 0 size_bi;
-    let nbits = n mod length_of_digit in
-    if nbits > 0 then
-      shift_left_nat res ndigits size_bi res (ndigits + size_bi) nbits;
-    { sign = bi.sign; abs_value = res }
-  end
-
-(* Shift right by N bits (rounds toward zero) *)
-
-let shift_right_towards_zero_big_int bi n =
-  if n < 0 then invalid_arg "shift_right_towards_zero_big_int"
-  else if n = 0 then bi
-  else if bi.sign = 0 then bi
-  else begin
-    let size_bi = num_digits_big_int bi in
-    let ndigits = n / length_of_digit in
-    let nbits = n mod length_of_digit in
-    if ndigits >= size_bi then zero_big_int else begin
-      let size_res = size_bi - ndigits in
-      let res = create_nat size_res in
-      blit_nat res 0 bi.abs_value ndigits size_res;
-      if nbits > 0 then begin
-        let tmp = create_nat 1 in
-        shift_right_nat res 0 size_res tmp 0 nbits
-      end;
-      if is_zero_nat res 0 size_res
-      then zero_big_int
-      else { sign = bi.sign; abs_value = res }
-    end
-  end
-
-(* Compute 2^n - 1 *)
-
-let two_power_m1_big_int n =
-  if n < 0 then invalid_arg "two_power_m1_big_int"
-  else if n = 0 then zero_big_int
-  else begin
-    let idx = n / length_of_digit in
-    let size_res = idx + 1 in
-    let res = make_nat size_res in
-    set_digit_nat_native res idx
-                         (Nativeint.shift_left 1n (n mod length_of_digit));
-    ignore (decr_nat res 0 size_res 0);
-    { sign = 1; abs_value = res }
-  end
-
-(* Shift right by N bits (rounds toward minus infinity) *)
-
-let shift_right_big_int bi n =
-  if n < 0 then invalid_arg "shift_right_big_int"
-  else if bi.sign >= 0 then shift_right_towards_zero_big_int bi n
-  else
-    shift_right_towards_zero_big_int (sub_big_int bi (two_power_m1_big_int n)) n
-
-(* Extract N bits starting at ofs.
-   Treats bi in two's complement.
-   Result is always positive. *)
-
-let extract_big_int bi ofs n =
-  if ofs < 0 || n < 0 then invalid_arg "extract_big_int"
-  else if bi.sign = 0 then bi
-  else begin
-    let size_bi = num_digits_big_int bi in
-    let size_res = (n + length_of_digit - 1) / length_of_digit in
-    let ndigits = ofs / length_of_digit in
-    let nbits = ofs mod length_of_digit in
-    let res = make_nat size_res in
-    if ndigits < size_bi then
-      blit_nat res 0 bi.abs_value ndigits (min size_res (size_bi - ndigits));
-    if bi.sign < 0 then begin
-      (* Two's complement *)
-      complement_nat res 0 size_res;
-      (* PR#6010: need to increment res iff digits 0...ndigits-1 of bi are 0.
-         In this case, digits 0...ndigits-1 of not(bi) are all 0xFF...FF,
-         and adding 1 to them produces a carry out at ndigits. *)
-      let rec carry_incr i =
-        i >= ndigits || i >= size_bi ||
-          (is_digit_zero bi.abs_value i && carry_incr (i + 1)) in
-      if carry_incr 0 then ignore (incr_nat res 0 size_res 1)
-    end;
-    if nbits > 0 then begin
-      let tmp = create_nat 1 in
-      shift_right_nat res 0 size_res tmp 0 nbits
-    end;
-    let n' = n mod length_of_digit in
-    if n' > 0 then begin
-      let tmp = create_nat 1 in
-      set_digit_nat_native tmp 0
-          (Nativeint.shift_right_logical (-1n) (length_of_digit - n'));
-      land_digit_nat res (size_res - 1) tmp 0
-    end;
-    if is_zero_nat res 0 size_res
-    then zero_big_int
-    else { sign = 1; abs_value = res }
-  end
-
-(* Bitwise logical operations.  Arguments must be >= 0. *)
-
-let and_big_int a b =
-  if a.sign < 0 || b.sign < 0 then invalid_arg "and_big_int"
-  else if a.sign = 0 || b.sign = 0 then zero_big_int
-  else begin
-    let size_a = num_digits_big_int a
-    and size_b = num_digits_big_int b in
-    let size_res = min size_a size_b in
-    let res = create_nat size_res in
-    blit_nat res 0 a.abs_value 0 size_res;
-    for i = 0 to size_res - 1 do
-      land_digit_nat res i b.abs_value i
-    done;
-    if is_zero_nat res 0 size_res
-    then zero_big_int
-    else { sign = 1; abs_value = res }
-  end
-
-let or_big_int a b =
-  if a.sign < 0 || b.sign < 0 then invalid_arg "or_big_int"
-  else if a.sign = 0 then b
-  else if b.sign = 0 then a
-  else begin
-    let size_a = num_digits_big_int a
-    and size_b = num_digits_big_int b in
-    let size_res = max size_a size_b in
-    let res = create_nat size_res in
-    let or_aux a' b' size_b' =
-      blit_nat res 0 a'.abs_value 0 size_res;
-      for i = 0 to size_b' - 1 do
-        lor_digit_nat res i b'.abs_value i
-      done in
-    if size_a >= size_b
-    then or_aux a b size_b
-    else or_aux b a size_a;
-    if is_zero_nat res 0 size_res
-    then zero_big_int
-    else { sign = 1; abs_value = res }
-  end
-
-let xor_big_int a b =
-  if a.sign < 0 || b.sign < 0 then invalid_arg "xor_big_int"
-  else if a.sign = 0 then b
-  else if b.sign = 0 then a
-  else begin
-    let size_a = num_digits_big_int a
-    and size_b = num_digits_big_int b in
-    let size_res = max size_a size_b in
-    let res = create_nat size_res in
-    let xor_aux a' b' size_b' =
-      blit_nat res 0 a'.abs_value 0 size_res;
-      for i = 0 to size_b' - 1 do
-        lxor_digit_nat res i b'.abs_value i
-      done in
-    if size_a >= size_b
-    then xor_aux a b size_b
-    else xor_aux b a size_a;
-    if is_zero_nat res 0 size_res
-    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_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

diff --git a/otherlibs/num/big_int.mli b/otherlibs/num/big_int.mli
deleted file mode 100644 (file)
index 07c4072..0000000
--- a/otherlibs/num/big_int.mli
+++ /dev/null
@@ -1,276 +0,0 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                 OCaml                                  *)
-(*                                                                        *)
-(*     Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt       *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
-(** Operations on arbitrary-precision integers.
-
-   Big integers (type [big_int]) are signed integers of arbitrary size.
-*)
-
-open Nat
-
-type big_int
-        (** The type of big integers. *)
-
-val zero_big_int : big_int
-(** The big integer [0]. *)
-
-val unit_big_int : big_int
-        (** The big integer [1]. *)
-
-(** {6 Arithmetic operations} *)
-
-val minus_big_int : big_int -> big_int
-(** Unary negation. *)
-
-val abs_big_int : big_int -> big_int
-(** Absolute value. *)
-
-val add_big_int : big_int -> big_int -> big_int
-(** Addition. *)
-
-val succ_big_int : big_int -> big_int
-(** Successor (add 1). *)
-
-val add_int_big_int : int -> big_int -> big_int
-(** Addition of a small integer to a big integer. *)
-
-val sub_big_int : big_int -> big_int -> big_int
-(** Subtraction. *)
-
-val pred_big_int : big_int -> big_int
-(** Predecessor (subtract 1). *)
-
-val mult_big_int : big_int -> big_int -> big_int
-(** Multiplication of two big integers. *)
-
-val mult_int_big_int : int -> big_int -> big_int
-(** Multiplication of a big integer by a small integer *)
-
-val square_big_int: big_int -> big_int
-(** Return the square of the given big integer *)
-
-val sqrt_big_int: big_int -> big_int
-        (** [sqrt_big_int a] returns the integer square root of [a],
-           that is, the largest big integer [r] such that [r * r <= a].
-            Raise [Invalid_argument] if [a] is negative. *)
-
-val quomod_big_int : big_int -> big_int -> big_int * big_int
-        (** Euclidean division of two big integers.
-           The first part of the result is the quotient,
-           the second part is the remainder.
-           Writing [(q,r) = quomod_big_int a b], we have
-           [a = q * b + r] and [0 <= r < |b|].
-            Raise [Division_by_zero] if the divisor is zero. *)
-
-val div_big_int : big_int -> big_int -> big_int
-        (** Euclidean quotient of two big integers.
-            This is the first result [q] of [quomod_big_int] (see above). *)
-
-val mod_big_int : big_int -> big_int -> big_int
-        (** Euclidean modulus of two big integers.
-            This is the second result [r] of [quomod_big_int] (see above). *)
-
-val gcd_big_int : big_int -> big_int -> big_int
-(** Greatest common divisor of two big integers. *)
-
-val power_int_positive_int: int -> int -> big_int
-val power_big_int_positive_int: big_int -> int -> big_int
-val power_int_positive_big_int: int -> big_int -> big_int
-val power_big_int_positive_big_int: big_int -> big_int -> big_int
-        (** Exponentiation functions.  Return the big integer
-           representing the first argument [a] raised to the power [b]
-           (the second argument).  Depending
-           on the function, [a] and [b] can be either small integers
-           or big integers.  Raise [Invalid_argument] if [b] is negative. *)
-
-(** {6 Comparisons and tests} *)
-
-val sign_big_int : big_int -> int
-        (** Return [0] if the given big integer is zero,
-            [1] if it is positive, and [-1] if it is negative. *)
-
-val compare_big_int : big_int -> big_int -> int
-        (** [compare_big_int a b] returns [0] if [a] and [b] are equal,
-           [1] if [a] is greater than [b], and [-1] if [a] is smaller
-            than [b]. *)
-
-val eq_big_int : big_int -> big_int -> bool
-val le_big_int : big_int -> big_int -> bool
-val ge_big_int : big_int -> big_int -> bool
-val lt_big_int : big_int -> big_int -> bool
-val gt_big_int : big_int -> big_int -> bool
-(** Usual boolean comparisons between two big integers. *)
-
-val max_big_int : big_int -> big_int -> big_int
-(** Return the greater of its two arguments. *)
-
-val min_big_int : big_int -> big_int -> big_int
-(** Return the smaller of its two arguments. *)
-
-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].
-
-            @since 4.03.0 *)
-
-(** {6 Conversions to and from strings} *)
-
-val string_of_big_int : big_int -> string
-        (** Return the string representation of the given big integer,
-            in decimal (base 10). *)
-
-val big_int_of_string : string -> big_int
-        (** Convert a string to a big integer, in decimal.
-           The string consists of an optional [-] or [+] sign,
-           followed by one or several decimal digits. *)
-(* TODO: document error condition. *)
-
-val big_int_of_string_opt: string -> big_int option
-(** Convert a string to a big integer, in decimal.
-    The string consists of an optional [-] or [+] sign,
-    followed by one or several decimal digits. Other the function
-    returns [None].
-    @since 4.05
-*)
-
-
-(** {6 Conversions to and from other numerical types} *)
-
-val big_int_of_int : int -> big_int
-(** Convert a small integer to a big integer. *)
-
-val is_int_big_int : big_int -> bool
-        (** Test whether the given big integer is small enough to
-           be representable as a small integer (type [int])
-           without loss of precision.  On a 32-bit platform,
-           [is_int_big_int a] returns [true] if and only if
-           [a] is between 2{^30} and 2{^30}-1.  On a 64-bit platform,
-           [is_int_big_int a] returns [true] if and only if
-            [a] is between -2{^62} and 2{^62}-1. *)
-
-val int_of_big_int : big_int -> int
-        (** Convert a big integer to a small integer (type [int]).
-           Raises [Failure "int_of_big_int"] if the big integer
-           is not representable as a small integer. *)
-
-val int_of_big_int_opt: big_int -> int option
-(** Convert a big integer to a small integer (type [int]).  Return
-    [None] if the big integer is not representable as a small
-    integer.
-    @since 4.05
-*)
-
-val big_int_of_int32 : int32 -> big_int
-(** Convert a 32-bit integer to a big integer. *)
-
-val big_int_of_nativeint : nativeint -> big_int
-(** Convert a native integer to a big integer. *)
-
-val big_int_of_int64 : int64 -> big_int
-(** Convert a 64-bit integer to a big integer. *)
-
-val int32_of_big_int : big_int -> int32
-        (** Convert a big integer to a 32-bit integer.
-            Raises [Failure] if the big integer is outside the
-            range \[-2{^31}, 2{^31}-1\]. *)
-
-val int32_of_big_int_opt: big_int -> int32 option
-(** Convert a big integer to a 32-bit integer.  Return [None] if the
-    big integer is outside the range \[-2{^31}, 2{^31}-1\].
-    @since 4.05
-*)
-
-val nativeint_of_big_int : big_int -> nativeint
-        (** Convert a big integer to a native integer.
-            Raises [Failure] if the big integer is outside the
-            range [[Nativeint.min_int, Nativeint.max_int]]. *)
-
-val nativeint_of_big_int_opt: big_int -> nativeint option
-(** Convert a big integer to a native integer. Return [None] if the
-    big integer is outside the range [[Nativeint.min_int,
-    Nativeint.max_int]];
-    @since 4.05
-*)
-
-val int64_of_big_int : big_int -> int64
-        (** Convert a big integer to a 64-bit integer.
-            Raises [Failure] if the big integer is outside the
-            range \[-2{^63}, 2{^63}-1\]. *)
-
-val int64_of_big_int_opt: big_int -> int64 option
-(** Convert a big integer to a 64-bit integer. Return [None] if the
-    big integer is outside the range \[-2{^63}, 2{^63}-1\].
-    @since 4.05
-*)
-
-val float_of_big_int : big_int -> float
-        (** Returns a floating-point number approximating the
-           given big integer. *)
-
-(** {6 Bit-oriented operations} *)
-
-val and_big_int : big_int -> big_int -> big_int
-        (** Bitwise logical 'and'.
-            The arguments must be positive or zero. *)
-
-val or_big_int : big_int -> big_int -> big_int
-        (** Bitwise logical 'or'.
-            The arguments must be positive or zero. *)
-
-val xor_big_int : big_int -> big_int -> big_int
-        (** Bitwise logical 'exclusive or'.
-            The arguments must be positive or zero. *)
-
-val shift_left_big_int : big_int -> int -> big_int
-        (** [shift_left_big_int b n] returns [b] shifted left by [n] bits.
-            Equivalent to multiplication by 2^n. *)
-
-val shift_right_big_int : big_int -> int -> big_int
-        (** [shift_right_big_int b n] returns [b] shifted right by [n] bits.
-            Equivalent to division by 2^n with the result being
-            rounded towards minus infinity. *)
-
-val shift_right_towards_zero_big_int : big_int -> int -> big_int
-        (** [shift_right_towards_zero_big_int b n] returns [b] shifted
-            right by [n] bits.  The shift is performed on the absolute
-            value of [b], and the result has the same sign as [b].
-            Equivalent to division by 2^n with the result being
-            rounded towards zero. *)
-
-val extract_big_int : big_int -> int -> int -> big_int
-        (** [extract_big_int bi ofs n] returns a nonnegative number
-            corresponding to bits [ofs] to [ofs + n - 1] of the
-            binary representation of [bi].  If [bi] is negative,
-            a two's complement representation is used. *)
-
-(**/**)
-
-(** {6 For internal use} *)
-
-val nat_of_big_int : big_int -> nat
-val big_int_of_nat : nat -> big_int
-val base_power_big_int: int -> int -> big_int -> big_int
-val sys_big_int_of_string: string -> int -> int -> big_int
-val round_futur_last_digit : bytes -> int -> int -> bool
-val approx_big_int: int -> big_int -> string
-
-val round_big_int_to_float: big_int -> bool -> float
-(** @since 4.03.0 *)

diff --git a/otherlibs/num/bng.c b/otherlibs/num/bng.c
deleted file mode 100644 (file)
index c4d0ea1..0000000
--- a/otherlibs/num/bng.c
+++ /dev/null
@@ -1,433 +0,0 @@
-/**************************************************************************/
-/*                                                                        */
-/*                                 OCaml                                  */
-/*                                                                        */
-/*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           */
-/*                                                                        */
-/*   Copyright 2003 Institut National de Recherche en Informatique et     */
-/*     en Automatique.                                                    */
-/*                                                                        */
-/*   All rights reserved.  This file is distributed under the terms of    */
-/*   the GNU Lesser General Public License version 2.1, with the          */
-/*   special exception on linking described in the file LICENSE.          */
-/*                                                                        */
-/**************************************************************************/
-
-#include "bng.h"
-#include "caml/config.h"
-
-#if defined(__GNUC__) && BNG_ASM_LEVEL > 0
-#if defined(BNG_ARCH_ia32)
-#include "bng_ia32.c"
-#elif defined(BNG_ARCH_amd64)
-#include "bng_amd64.c"
-#elif defined(BNG_ARCH_ppc)
-#include "bng_ppc.c"
-#elif defined (BNG_ARCH_sparc)
-#include "bng_sparc.c"
-#elif defined (BNG_ARCH_arm64)
-#include "bng_arm64.c"
-#endif
-#endif
-
-#include "bng_digit.c"
-
-/**** Operations that cannot be overridden ****/
-
-/* Return number of leading zero bits in d */
-int bng_leading_zero_bits(bngdigit d)
-{
-  int n = BNG_BITS_PER_DIGIT;
-#ifdef ARCH_SIXTYFOUR
-  if ((d & 0xFFFFFFFF00000000L) != 0) { n -= 32; d = d >> 32; }
-#endif
-  if ((d & 0xFFFF0000) != 0) { n -= 16; d = d >> 16; }
-  if ((d & 0xFF00) != 0) { n -= 8; d = d >> 8; }
-  if ((d & 0xF0) != 0) { n -= 4; d = d >> 4; }
-  if ((d & 0xC) != 0) { n -= 2; d = d >> 2; }
-  if ((d & 2) != 0) { n -= 1; d = d >> 1; }
-  return n - d;
-}
-
-/* Complement the digits of {a,len} */
-void bng_complement(bng a/*[alen]*/, bngsize alen)
-{
-  for (/**/; alen > 0; alen--, a++) *a = ~*a;
-}
-
-/* Return number of significant digits in {a,alen}. */
-bngsize bng_num_digits(bng a/*[alen]*/, bngsize alen)
-{
-  while (1) {
-    if (alen == 0) return 1;
-    if (a[alen - 1] != 0) return alen;
-    alen--;
-  }
-}
-
-/* Return 0 if {a,alen} = {b,blen}
-         -1 if {a,alen} < {b,blen}
-          1 if {a,alen} > {b,blen}. */
-int bng_compare(bng a/*[alen]*/, bngsize alen,
-                bng b/*[blen]*/, bngsize blen)
-{
-  bngdigit da, db;
-
-  while (alen > 0 && a[alen-1] == 0) alen--;
-  while (blen > 0 && b[blen-1] == 0) blen--;
-  if (alen > blen) return 1;
-  if (alen < blen) return -1;
-  while (alen > 0) {
-    alen--;
-    da = a[alen];
-    db = b[alen];
-    if (da > db) return 1;
-    if (da < db) return -1;
-  }
-  return 0;
-}
-
-/**** Generic definitions of the overridable operations ****/
-
-/* {a,alen} := {a, alen} + carry.  Return carry out. */
-static bngcarry bng_generic_add_carry
-       (bng a/*[alen]*/,  bngsize alen, bngcarry carry)
-{
-  if (carry == 0 || alen == 0) return carry;
-  do {
-    if (++(*a) != 0) return 0;
-    a++;
-  } while (--alen);
-  return 1;
-}
-
-/* {a,alen} := {a,alen} + {b,blen} + carry.  Return carry out.
-   Require alen >= blen. */
-static bngcarry bng_generic_add
-       (bng a/*[alen]*/, bngsize alen,
-        bng b/*[blen]*/, bngsize blen,
-        bngcarry carry)
-{
-  alen -= blen;
-  for (/**/; blen > 0; blen--, a++, b++) {
-    BngAdd2Carry(*a, carry, *a, *b, carry);
-  }
-  if (carry == 0 || alen == 0) return carry;
-  do {
-    if (++(*a) != 0) return 0;
-    a++;
-  } while (--alen);
-  return 1;
-}
-
-/* {a,alen} := {a, alen} - carry.  Return carry out. */
-static bngcarry bng_generic_sub_carry
-       (bng a/*[alen]*/,  bngsize alen, bngcarry carry)
-{
-  if (carry == 0 || alen == 0) return carry;
-  do {
-    if ((*a)-- != 0) return 0;
-    a++;
-  } while (--alen);
-  return 1;
-}
-
-/* {a,alen} := {a,alen} - {b,blen} - carry.  Return carry out.
-   Require alen >= blen. */
-static bngcarry bng_generic_sub
-       (bng a/*[alen]*/, bngsize alen,
-        bng b/*[blen]*/, bngsize blen,
-        bngcarry carry)
-{
-  alen -= blen;
-  for (/**/; blen > 0; blen--, a++, b++) {
-    BngSub2Carry(*a, carry, *a, *b, carry);
-  }
-  if (carry == 0 || alen == 0) return carry;
-  do {
-    if ((*a)-- != 0) return 0;
-    a++;
-  } while (--alen);
-  return 1;
-}
-
-/* {a,alen} := {a,alen} << shift.
-   Return the bits shifted out of the most significant digit of a.
-   Require 0 <= shift < BITS_PER_BNGDIGIT. */
-static bngdigit bng_generic_shift_left
-     (bng a/*[alen]*/, bngsize alen,
-      int shift)
-{
-  int shift2 = BNG_BITS_PER_DIGIT - shift;
-  bngdigit carry = 0;
-  if (shift > 0) {
-    for (/**/; alen > 0; alen--, a++) {
-      bngdigit d = *a;
-      *a = (d << shift) | carry;
-      carry = d >> shift2;
-    }
-  }
-  return carry;
-}
-
-/* {a,alen} := {a,alen} >> shift.
-   Return the bits shifted out of the least significant digit of a.
-   Require 0 <= shift < BITS_PER_BNGDIGIT. */
-static bngdigit bng_generic_shift_right
-     (bng a/*[alen]*/, bngsize alen,
-      int shift)
-{
-  int shift2 = BNG_BITS_PER_DIGIT - shift;
-  bngdigit carry = 0;
-  if (shift > 0) {
-    for (a = a + alen - 1; alen > 0; alen--, a--) {
-      bngdigit d = *a;
-      *a = (d >> shift) | carry;
-      carry = d << shift2;
-    }
-  }
-  return carry;
-}
-
-/* {a,alen} := {a,alen} + d * {b,blen}.  Return carry out.
-   Require alen >= blen. */
-static bngdigit bng_generic_mult_add_digit
-     (bng a/*[alen]*/, bngsize alen,
-      bng b/*[blen]*/, bngsize blen,
-      bngdigit d)
-{
-  bngdigit out, ph, pl;
-  bngcarry carry;
-
-  alen -= blen;
-  for (out = 0; blen > 0; blen--, a++, b++) {
-    bngdigit bd = *b;
-    /* ph:pl = double-digit product of b's current digit and d */
-    BngMult(ph, pl, bd, d);
-    /* current digit of a += pl + out.  Accumulate carries in ph. */
-    BngAdd3(*a, ph, *a, pl, out);
-    /* prepare out for next iteration */
-    out = ph;
-  }
-  if (alen == 0) return out;
-  /* current digit of a += out */
-  BngAdd2(*a, carry, *a, out);
-  a++;
-  alen--;
-  /* Propagate carry */
-  if (carry == 0 || alen == 0) return carry;
-  do {
-    if (++(*a) != 0) return 0;
-    a++;
-  } while (--alen);
-  return 1;
-}
-
-/* {a,alen} := {a,alen} - d * {b,blen}.  Return carry out.
-   Require alen >= blen. */
-static bngdigit bng_generic_mult_sub_digit
-     (bng a/*[alen]*/, bngsize alen,
-      bng b/*[blen]*/, bngsize blen,
-      bngdigit d)
-{
-  bngdigit out, ph, pl;
-  bngcarry carry;
-
-  alen -= blen;
-  for (out = 0; blen > 0; blen--, a++, b++) {
-    bngdigit bd = *b;
-    /* ph:pl = double-digit product of b's current digit and d */
-    BngMult(ph, pl, bd, d);
-    /* current digit of a -= pl + out.  Accumulate carrys in ph. */
-    BngSub3(*a, ph, *a, pl, out);
-    /* prepare out for next iteration */
-    out = ph;
-  }
-  if (alen == 0) return out;
-  /* current digit of a -= out */
-  BngSub2(*a, carry, *a, out);
-  a++;
-  alen--;
-  /* Propagate carry */
-  if (carry == 0 || alen == 0) return carry;
-  do {
-    if ((*a)-- != 0) return 0;
-    a++;
-  } while (--alen);
-  return 1;
-}
-
-/* {a,alen} := {a,alen} + {b,blen} * {c,clen}.  Return carry out.
-   Require alen >= blen + clen. */
-static bngcarry bng_generic_mult_add
-     (bng a/*[alen]*/, bngsize alen,
-      bng b/*[blen]*/, bngsize blen,
-      bng c/*[clen]*/, bngsize clen)
-{
-  bngcarry carry;
-  for (carry = 0; clen > 0; clen--, c++, alen--, a++)
-    carry += bng_mult_add_digit(a, alen, b, blen, *c);
-  return carry;
-}
-
-/* {a,alen} := 2 * {a,alen} + {b,blen}^2.  Return carry out.
-   Require alen >= 2 * blen. */
-static bngcarry bng_generic_square_add
-     (bng a/*[alen]*/, bngsize alen,
-      bng b/*[blen]*/, bngsize blen)
-{
-  bngcarry carry1, carry2;
-  bngsize i, aofs;
-  bngdigit ph, pl, d;
-
-  /* Double products */
-  for (carry1 = 0, i = 1; i < blen; i++) {
-    aofs = 2 * i - 1;
-    carry1 += bng_mult_add_digit(a + aofs, alen - aofs,
-                                 b + i, blen - i, b[i - 1]);
-  }
-  /* Multiply by two */
-  carry1 = (carry1 << 1) | bng_shift_left(a, alen, 1);
-  /* Add square of digits */
-  carry2 = 0;
-  for (i = 0; i < blen; i++) {
-    d = b[i];
-    BngMult(ph, pl, d, d);
-    BngAdd2Carry(*a, carry2, *a, pl, carry2);
-    a++;
-    BngAdd2Carry(*a, carry2, *a, ph, carry2);
-    a++;
-  }
-  alen -= 2 * blen;
-  if (alen > 0 && carry2 != 0) {
-    do {
-      if (++(*a) != 0) { carry2 = 0; break; }
-      a++;
-    } while (--alen);
-  }
-  return carry1 + carry2;
-}
-
-/* {a,len-1} := {b,len} / d.  Return {b,len} modulo d.
-   Require MSD of b < d.
-   If BngDivNeedsNormalization is defined, require d normalized. */
-static bngdigit bng_generic_div_rem_norm_digit
-     (bng a/*[len-1]*/, bng b/*[len]*/, bngsize len, bngdigit d)
-{
-  bngdigit topdigit, quo, rem;
-  intnat i;
-
-  topdigit = b[len - 1];
-  for (i = len - 2; i >= 0; i--) {
-    /* Divide topdigit:current digit of numerator by d */
-    BngDiv(quo, rem, topdigit, b[i], d);
-    /* Quotient is current digit of result */
-    a[i] = quo;
-    /* Iterate with topdigit = remainder */
-    topdigit = rem;
-  }
-  return topdigit;
-}
-
-#ifdef BngDivNeedsNormalization
-/* {a,len-1} := {b,len} / d.  Return {b,len} modulo d.
-   Require MSD of b < d. */
-static bngdigit bng_generic_div_rem_digit
-     (bng a/*[len-1]*/, bng b/*[len]*/, bngsize len, bngdigit d)
-{
-  bngdigit rem;
-  int shift;
-
-  /* Normalize d and b */
-  shift = bng_leading_zero_bits(d);
-  d <<= shift;
-  bng_shift_left(b, len, shift);
-  /* Do the division */
-  rem = bng_div_rem_norm_digit(a, b, len, d);
-  /* Undo normalization on b and remainder */
-  bng_shift_right(b, len, shift);
-  return rem >> shift;
-}
-#endif
-
-/* {n+dlen, nlen-dlen} := {n,nlen} / {d, dlen}.
-   {n, dlen} := {n,nlen} modulo {d, dlen}.
-   Require nlen > dlen and MSD of n < MSD of d.
-   (This implies MSD of d > 0). */
-static void bng_generic_div_rem
-       (bng n/*[nlen]*/, bngsize nlen,
-        bng d/*[dlen]*/, bngsize dlen)
-{
-  bngdigit topden, quo, rem;
-  int shift;
-  bngsize i, j;
-
-  /* Normalize d */
-  shift = bng_leading_zero_bits(d[dlen - 1]);
-  /* Note that no bits of n are lost by the following shift,
-     since n[nlen-1] < d[dlen-1] */
-  bng_shift_left(n, nlen, shift);
-  bng_shift_left(d, dlen, shift);
-  /* Special case if d is just one digit */
-  if (dlen == 1) {
-    *n = bng_div_rem_norm_digit(n + 1, n, nlen, *d);
-  } else {
-    topden = d[dlen - 1];
-    /* Long division */
-    for (j = nlen - 1; j >= dlen; j--) {
-      i = j - dlen;
-      /* At this point:
-         - the current numerator is      n[j] : ...................... : n[0]
-         - to be subtracted quo times:   d[dlen-1] : ... : d[0] : 0... : 0
-         (there are i zeroes at the end) */
-      /* Under-estimate the next digit of the quotient (quo) */
-      if (topden + 1 == 0)
-        quo = n[j];
-      else
-        BngDiv(quo, rem, n[j], n[j - 1], topden + 1);
-      /* Subtract d * quo (shifted i places) from numerator */
-      n[j] -= bng_mult_sub_digit(n + i, dlen, d, dlen, quo);
-      /* Adjust if necessary */
-      while (n[j] != 0 || bng_compare(n + i, dlen, d, dlen) >= 0) {
-        /* Numerator is still bigger than shifted divisor.
-           Increment quotient and subtract shifted divisor. */
-        quo++;
-        n[j] -= bng_sub(n + i, dlen, d, dlen, 0);
-      }
-      /* Store quotient digit */
-      n[j] = quo;
-    }
-  }
-  /* Undo normalization on remainder and divisor */
-  bng_shift_right(n, dlen, shift);
-  bng_shift_right(d, dlen, shift);
-}
-
-/**** Construction of the table of operations ****/
-
-struct bng_operations bng_ops = {
-  bng_generic_add_carry,
-  bng_generic_add,
-  bng_generic_sub_carry,
-  bng_generic_sub,
-  bng_generic_shift_left,
-  bng_generic_shift_right,
-  bng_generic_mult_add_digit,
-  bng_generic_mult_sub_digit,
-  bng_generic_mult_add,
-  bng_generic_square_add,
-  bng_generic_div_rem_norm_digit,
-#ifdef BngDivNeedsNormalization
-  bng_generic_div_rem_digit,
-#else
-  bng_generic_div_rem_norm_digit,
-#endif
-  bng_generic_div_rem
-};
-
-void bng_init(void)
-{
-#ifdef BNG_SETUP_OPS
-  BNG_SETUP_OPS;
-#endif
-}

diff --git a/otherlibs/num/bng.h b/otherlibs/num/bng.h
deleted file mode 100644 (file)
index 406117d..0000000
--- a/otherlibs/num/bng.h
+++ /dev/null
@@ -1,156 +0,0 @@
-/**************************************************************************/
-/*                                                                        */
-/*                                 OCaml                                  */
-/*                                                                        */
-/*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           */
-/*                                                                        */
-/*   Copyright 2003 Institut National de Recherche en Informatique et     */
-/*     en Automatique.                                                    */
-/*                                                                        */
-/*   All rights reserved.  This file is distributed under the terms of    */
-/*   the GNU Lesser General Public License version 2.1, with the          */
-/*   special exception on linking described in the file LICENSE.          */
-/*                                                                        */
-/**************************************************************************/
-
-#include <string.h>
-#include "caml/config.h"
-
-typedef uintnat bngdigit;
-typedef bngdigit * bng;
-typedef unsigned int bngcarry;
-typedef uintnat bngsize;
-
-#define BNG_BITS_PER_DIGIT (sizeof(bngdigit) * 8)
-#define BNG_BITS_PER_HALF_DIGIT (sizeof(bngdigit) * 4)
-
-struct bng_operations {
-
-  /* {a,alen} := {a, alen} + carry.  Return carry out. */
-  bngcarry (*add_carry)
-       (bng a/*[alen]*/,  bngsize alen, bngcarry carry);
-#define bng_add_carry bng_ops.add_carry
-
-  /* {a,alen} := {a,alen} + {b,blen} + carry.  Return carry out.
-     Require alen >= blen. */
-  bngcarry (*add)
-       (bng a/*[alen]*/, bngsize alen,
-        bng b/*[blen]*/, bngsize blen,
-        bngcarry carry);
-#define bng_add bng_ops.add
-
-  /* {a,alen} := {a, alen} - carry.  Return carry out. */
-  bngcarry (*sub_carry)
-       (bng a/*[alen]*/,  bngsize alen, bngcarry carry);
-#define bng_sub_carry bng_ops.sub_carry
-
-  /* {a,alen} := {a,alen} - {b,blen} - carry.  Return carry out.
-     Require alen >= blen. */
-  bngcarry (*sub)
-       (bng a/*[alen]*/, bngsize alen,
-        bng b/*[blen]*/, bngsize blen,
-        bngcarry carry);
-#define bng_sub bng_ops.sub
-
-  /* {a,alen} := {a,alen} << shift.
-     Return the bits shifted out of the most significant digit of a.
-     Require 0 <= shift < BITS_PER_BNGDIGIT. */
-  bngdigit (*shift_left)
-       (bng a/*[alen]*/, bngsize alen,
-        int shift);
-#define bng_shift_left bng_ops.shift_left
-
-  /* {a,alen} := {a,alen} >> shift.
-     Return the bits shifted out of the least significant digit of a.
-     Require 0 <= shift < BITS_PER_BNGDIGIT. */
-  bngdigit (*shift_right)
-       (bng a/*[alen]*/, bngsize alen,
-        int shift);
-#define bng_shift_right bng_ops.shift_right
-
-  /* {a,alen} := {a,alen} + d * {b,blen}.  Return carry out.
-     Require alen >= blen.
-     If alen > blen, the carry out returned is 0 or 1.
-     If alen == blen, the carry out returned is a full digit. */
-  bngdigit (*mult_add_digit)
-       (bng a/*[alen]*/, bngsize alen,
-        bng b/*[blen]*/, bngsize blen,
-        bngdigit d);
-#define bng_mult_add_digit bng_ops.mult_add_digit
-
-  /* {a,alen} := {a,alen} - d * {b,blen}.  Return carry out.
-     Require alen >= blen.
-     If alen > blen, the carry out returned is 0 or 1.
-     If alen == blen, the carry out returned is a full digit. */
-  bngdigit (*mult_sub_digit)
-       (bng a/*[alen]*/, bngsize alen,
-        bng b/*[blen]*/, bngsize blen,
-        bngdigit d);
-#define bng_mult_sub_digit bng_ops.mult_sub_digit
-
-  /* {a,alen} := {a,alen} + {b,blen} * {c,clen}.  Return carry out.
-     Require alen >= blen + clen. */
-  bngcarry (*mult_add)
-       (bng a/*[alen]*/, bngsize alen,
-        bng b/*[blen]*/, bngsize blen,
-        bng c/*[clen]*/, bngsize clen);
-#define bng_mult_add bng_ops.mult_add
-
-  /* {a,alen} := 2 * {a,alen} + {b,blen}^2.  Return carry out.
-     Require alen >= 2 * blen. */
-  bngcarry (*square_add)
-       (bng a/*[alen]*/, bngsize alen,
-        bng b/*[blen]*/, bngsize blen);
-#define bng_square_add bng_ops.square_add
-
-  /* {a,len-1} := {b,len} / d.  Return {b,len} modulo d.
-     Require d is normalized and MSD of b < d.
-     See div_rem_digit for a function that does not require d
-     to be normalized */
-  bngdigit (*div_rem_norm_digit)
-       (bng a/*[len-1]*/, bng b/*[len]*/, bngsize len, bngdigit d);
-#define bng_div_rem_norm_digit bng_ops.div_rem_norm_digit
-
-  /* {a,len-1} := {b,len} / d.  Return {b,len} modulo d.
-     Require MSD of b < d. */
-     bngdigit (*div_rem_digit)
-       (bng a/*[len-1]*/, bng b/*[len]*/, bngsize len, bngdigit d);
-#define bng_div_rem_digit bng_ops.div_rem_digit
-
-  /* {n+dlen, nlen-dlen} := {n,nlen} / {d, dlen}.
-     {n, dlen} := {n,nlen} modulo {d, dlen}.
-     Require nlen > dlen and MSD of n < MSD of d (which implies d != 0). */
-  void (*div_rem)
-       (bng n/*[nlen]*/, bngsize nlen,
-        bng d/*[nlen]*/, bngsize dlen);
-#define bng_div_rem bng_ops.div_rem
-};
-
-extern struct bng_operations bng_ops;
-
-/* Initialize the BNG library */
-extern void bng_init(void);
-
-/* {a,alen} := 0 */
-#define bng_zero(a,alen) memset((a), 0, (alen) * sizeof(bngdigit))
-
-/* {a,len} := {b,len} */
-#define bng_assign(a,b,len) memmove((a), (b), (len) * sizeof(bngdigit))
-
-/* Complement the digits of {a,len} */
-extern void bng_complement(bng a/*[alen]*/, bngsize alen);
-
-/* Return number of significant digits in {a,alen}. */
-extern bngsize bng_num_digits(bng a/*[alen]*/, bngsize alen);
-
-/* Return 1 if {a,alen} is 0, 0 otherwise. */
-#define bng_is_zero(a,alen) (bng_num_digits(a,alen) == 0)
-
-/* Return 0 if {a,alen} = {b,blen}
-         <0 if {a,alen} < {b,blen}
-         >0 if {a,alen} > {b,blen}. */
-extern int bng_compare(bng a/*[alen]*/, bngsize alen,
-                       bng b/*[blen]*/, bngsize blen);
-
-/* Return the number of leading zero bits in digit d. */
-extern int bng_leading_zero_bits(bngdigit d);

diff --git a/otherlibs/num/bng_amd64.c b/otherlibs/num/bng_amd64.c
deleted file mode 100644 (file)
index 585900e..0000000
--- a/otherlibs/num/bng_amd64.c
+++ /dev/null
@@ -1,195 +0,0 @@
-/**************************************************************************/
-/*                                                                        */
-/*                                 OCaml                                  */
-/*                                                                        */
-/*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           */
-/*                                                                        */
-/*   Copyright 2003 Institut National de Recherche en Informatique et     */
-/*     en Automatique.                                                    */
-/*                                                                        */
-/*   All rights reserved.  This file is distributed under the terms of    */
-/*   the GNU Lesser General Public License version 2.1, with the          */
-/*   special exception on linking described in the file LICENSE.          */
-/*                                                                        */
-/**************************************************************************/
-
-/* Code specific to the AMD x86_64 architecture. */
-
-#define BngAdd2(res,carryout,arg1,arg2)                                     \
-  asm("xorl %1, %1 \n\t"                                                    \
-      "addq %3, %0 \n\t"                                                    \
-      "setc %b1"                                                            \
-      : "=r" (res), "=&q" (carryout)                                        \
-      : "0" (arg1), "rm" (arg2))
-
-#define BngSub2(res,carryout,arg1,arg2)                                     \
-  asm("xorl %1, %1 \n\t"                                                    \
-      "subq %3, %0 \n\t"                                                    \
-      "setc %b1"                                                            \
-      : "=r" (res), "=&q" (carryout)                                        \
-      : "0" (arg1), "rm" (arg2))
-
-#define BngMult(resh,resl,arg1,arg2)                                        \
-  asm("mulq %3"                                                             \
-      : "=a" (resl), "=d" (resh)                                            \
-      : "a" (arg1), "r" (arg2))
-
-#define BngDiv(quo,rem,nh,nl,d)                                             \
-  asm("divq %4"                                                             \
-      : "=a" (quo), "=d" (rem)                                              \
-      : "a" (nl), "d" (nh), "r" (d))
-
-/* Reimplementation in asm of some of the bng operations. */
-
-static bngcarry bng_amd64_add
-       (bng a/*[alen]*/, bngsize alen,
-        bng b/*[blen]*/, bngsize blen,
-        bngcarry carry)
-{
-  bngdigit tmp;
-  alen -= blen;
-  if (blen > 0) {
-    asm("negb %b3 \n\t"
-        "1: \n\t"
-        "movq (%0), %4 \n\t"
-        "adcq (%1), %4 \n\t"
-        "movq %4, (%0) \n\t"
-        "leaq 8(%0), %0 \n\t"
-        "leaq 8(%1), %1 \n\t"
-        "decq %2 \n\t"
-        "jnz 1b \n\t"
-        "setc %b3"
-        : "=r" (a), "=r" (b), "=r" (blen), "=q" (carry), "=r" (tmp)
-        : "0" (a), "1" (b), "2" (blen), "3" (carry));
-  }
-  if (carry == 0 || alen == 0) return carry;
-  do {
-    if (++(*a) != 0) return 0;
-    a++;
-  } while (--alen);
-  return 1;
-}
-
-static bngcarry bng_amd64_sub
-       (bng a/*[alen]*/, bngsize alen,
-        bng b/*[blen]*/, bngsize blen,
-        bngcarry carry)
-{
-  bngdigit tmp;
-  alen -= blen;
-  if (blen > 0) {
-    asm("negb %b3 \n\t"
-        "1: \n\t"
-        "movq (%0), %4 \n\t"
-        "sbbq (%1), %4 \n\t"
-        "movq %4, (%0) \n\t"
-        "leaq 8(%0), %0 \n\t"
-        "leaq 8(%1), %1 \n\t"
-        "decq %2 \n\t"
-        "jnz 1b \n\t"
-        "setc %b3"
-        : "=r" (a), "=r" (b), "=r" (blen), "=q" (carry), "=r" (tmp)
-        : "0" (a), "1" (b), "2" (blen), "3" (carry));
-  }
-  if (carry == 0 || alen == 0) return carry;
-  do {
-    if ((*a)-- != 0) return 0;
-    a++;
-  } while (--alen);
-  return 1;
-}
-
-static bngdigit bng_amd64_mult_add_digit
-     (bng a/*[alen]*/, bngsize alen,
-      bng b/*[blen]*/, bngsize blen,
-      bngdigit d)
-{
-  bngdigit out;
-  bngcarry carry;
-
-  alen -= blen;
-  out = 0;
-  if (blen > 0) {
-    asm("1: \n\t"
-        "movq (%1), %%rax \n\t"
-        "mulq %7\n\t"           /* rdx:rax = d * next digit of b */
-        "addq (%0), %%rax \n\t" /* add next digit of a to rax */
-        "adcq $0, %%rdx \n\t"   /* accumulate carry in rdx */
-        "addq %3, %%rax \n\t"   /* add out to rax */
-        "adcq $0, %%rdx \n\t"   /* accumulate carry in rdx */
-        "movq %%rax, (%0) \n\t" /* rax is next digit of result */
-        "movq %%rdx, %3 \n\t"   /* rdx is next out */
-        "leaq 8(%0), %0 \n\t"
-        "leaq 8(%1), %1 \n\t"
-        "decq %2 \n\t"
-        "jnz 1b"
-        : "=&r" (a), "=&r" (b), "=&r" (blen), "=&r" (out)
-        : "0" (a), "1" (b), "2" (blen), "rm" (d), "3" (out)
-        : "rax", "rdx");
-  }
-  if (alen == 0) return out;
-  /* current digit of a += out */
-  BngAdd2(*a, carry, *a, out);
-  a++;
-  alen--;
-  /* Propagate carry */
-  if (carry == 0 || alen == 0) return carry;
-  do {
-    if (++(*a) != 0) return 0;
-    a++;
-  } while (--alen);
-  return 1;
-}
-
-static bngdigit bng_amd64_mult_sub_digit
-     (bng a/*[alen]*/, bngsize alen,
-      bng b/*[blen]*/, bngsize blen,
-      bngdigit d)
-{
-  bngdigit out, tmp;
-  bngcarry carry;
-
-  alen -= blen;
-  out = 0;
-  if (blen > 0) {
-    asm("1: \n\t"
-        "movq (%1), %%rax \n\t"
-        "movq (%0), %4 \n\t"
-        "mulq %8\n\t"           /* rdx:rax = d * next digit of b */
-        "subq %%rax, %4 \n\t"   /* subtract rax from next digit of a */
-        "adcq $0, %%rdx \n\t"   /* accumulate carry in rdx */
-        "subq %3, %4 \n\t"      /* subtract out */
-        "adcq $0, %%rdx \n\t"   /* accumulate carry in rdx */
-        "movq %4, (%0) \n\t"    /* store next digit of result */
-        "movq %%rdx, %3 \n\t"   /* rdx is next out */
-        "leaq 8(%0), %0 \n\t"
-        "leaq 8(%1), %1 \n\t"
-        "decq %2 \n\t"
-        "jnz 1b"
-        : "=&r" (a), "=&r" (b), "=&rm" (blen), "=&r" (out), "=&r" (tmp)
-        : "0" (a), "1" (b), "2" (blen), "rm" (d), "3" (out)
-        : "rax", "rdx");
-  }
-  if (alen == 0) return out;
-  /* current digit of a -= out */
-  BngSub2(*a, carry, *a, out);
-  a++;
-  alen--;
-  /* Propagate carry */
-  if (carry == 0 || alen == 0) return carry;
-  do {
-    if ((*a)-- != 0) return 0;
-    a++;
-  } while (--alen);
-  return 1;
-}
-
-static void bng_amd64_setup_ops(void)
-{
-  bng_ops.add = bng_amd64_add;
-  bng_ops.sub = bng_amd64_sub;
-  bng_ops.mult_add_digit = bng_amd64_mult_add_digit;
-  bng_ops.mult_sub_digit = bng_amd64_mult_sub_digit;
-}
-
-#define BNG_SETUP_OPS bng_amd64_setup_ops()

diff --git a/otherlibs/num/bng_arm64.c b/otherlibs/num/bng_arm64.c
deleted file mode 100644 (file)
index b900b80..0000000
--- a/otherlibs/num/bng_arm64.c
+++ /dev/null
@@ -1,22 +0,0 @@
-/**************************************************************************/
-/*                                                                        */
-/*                                 OCaml                                  */
-/*                                                                        */
-/*             Xavier Leroy, projet Gallium, INRIA Rocquencourt           */
-/*                                                                        */
-/*   Copyright 2013 Institut National de Recherche en Informatique et     */
-/*     en Automatique.                                                    */
-/*                                                                        */
-/*   All rights reserved.  This file is distributed under the terms of    */
-/*   the GNU Lesser General Public License version 2.1, with the          */
-/*   special exception on linking described in the file LICENSE.          */
-/*                                                                        */
-/**************************************************************************/
-
-/* Code specific for the ARM 64 (AArch64) architecture */
-
-#define BngMult(resh,resl,arg1,arg2)                                        \
-  asm("mul %0, %2, %3 \n\t"                                                 \
-      "umulh %1, %2, %3"                                                    \
-      : "=&r" (resl), "=&r" (resh)                                          \
-      : "r" (arg1), "r" (arg2))

diff --git a/otherlibs/num/bng_digit.c b/otherlibs/num/bng_digit.c
deleted file mode 100644 (file)
index 6983af6..0000000
--- a/otherlibs/num/bng_digit.c
+++ /dev/null
@@ -1,178 +0,0 @@
-/**************************************************************************/
-/*                                                                        */
-/*                                 OCaml                                  */
-/*                                                                        */
-/*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           */
-/*                                                                        */
-/*   Copyright 2003 Institut National de Recherche en Informatique et     */
-/*     en Automatique.                                                    */
-/*                                                                        */
-/*   All rights reserved.  This file is distributed under the terms of    */
-/*   the GNU Lesser General Public License version 2.1, with the          */
-/*   special exception on linking described in the file LICENSE.          */
-/*                                                                        */
-/**************************************************************************/
-
-/**** Generic operations on digits ****/
-
-/* These macros can be defined in the machine-specific include file.
-   Below are the default definitions (in plain C).
-   Except for BngMult, all macros are guaranteed to evaluate their
-   arguments exactly once. */
-
-#ifndef BngAdd2
-/* res = arg1 + arg2.  carryout = carry out. */
-#define BngAdd2(res,carryout,arg1,arg2) {                                   \
-  bngdigit tmp1, tmp2;                                                      \
-  tmp1 = arg1;                                                              \
-  tmp2 = tmp1 + (arg2);                                                     \
-  carryout = (tmp2 < tmp1);                                                 \
-  res = tmp2;                                                               \
-}
-#endif
-
-#ifndef BngAdd2Carry
-/* res = arg1 + arg2 + carryin.  carryout = carry out. */
-#define BngAdd2Carry(res,carryout,arg1,arg2,carryin) {                      \
-  bngdigit tmp1, tmp2, tmp3;                                                \
-  tmp1 = arg1;                                                              \
-  tmp2 = tmp1 + (arg2);                                                     \
-  tmp3 = tmp2 + (carryin);                                                  \
-  carryout = (tmp2 < tmp1) + (tmp3 < tmp2);                                 \
-  res = tmp3;                                                               \
-}
-#endif
-
-#ifndef BngAdd3
-/* res = arg1 + arg2 + arg3.  Each carry increments carryaccu. */
-#define BngAdd3(res,carryaccu,arg1,arg2,arg3) {                             \
-  bngdigit tmp1, tmp2, tmp3;                                                \
-  tmp1 = arg1;                                                              \
-  tmp2 = tmp1 + (arg2);                                                     \
-  carryaccu += (tmp2 < tmp1);                                               \
-  tmp3 = tmp2 + (arg3);                                                     \
-  carryaccu += (tmp3 < tmp2);                                               \
-  res = tmp3;                                                               \
-}
-#endif
-
-#ifndef BngSub2
-/* res = arg1 - arg2.  carryout = carry out. */
-#define BngSub2(res,carryout,arg1,arg2) {                                   \
-  bngdigit tmp1, tmp2;                                                      \
-  tmp1 = arg1;                                                              \
-  tmp2 = arg2;                                                              \
-  res = tmp1 - tmp2;                                                        \
-  carryout = (tmp1 < tmp2);                                                 \
-}
-#endif
-
-#ifndef BngSub2Carry
-/* res = arg1 - arg2 - carryin.  carryout = carry out. */
-#define BngSub2Carry(res,carryout,arg1,arg2,carryin) {                      \
-  bngdigit tmp1, tmp2, tmp3;                                                \
-  tmp1 = arg1;                                                              \
-  tmp2 = arg2;                                                              \
-  tmp3 = tmp1 - tmp2;                                                       \
-  res = tmp3 - (carryin);                                                   \
-  carryout = (tmp1 < tmp2) + (tmp3 < carryin);                              \
-}
-#endif
-
-#ifndef BngSub3
-/* res = arg1 - arg2 - arg3.  Each carry increments carryaccu. */
-#define BngSub3(res,carryaccu,arg1,arg2,arg3) {                             \
-  bngdigit tmp1, tmp2, tmp3, tmp4;                                          \
-  tmp1 = arg1;                                                              \
-  tmp2 = arg2;                                                              \
-  tmp3 = arg3;                                                              \
-  tmp4 = tmp1 - tmp2;                                                       \
-  res = tmp4 - tmp3;                                                        \
-  carryaccu += (tmp1 < tmp2) + (tmp4 < tmp3);                               \
-}
-#endif
-
-#define BngLowHalf(d) ((d) & (((bngdigit)1 << BNG_BITS_PER_HALF_DIGIT) - 1))
-#define BngHighHalf(d) ((d) >> BNG_BITS_PER_HALF_DIGIT)
-
-#ifndef BngMult
-/* resl = low  digit of product arg1 * arg2
-   resh = high digit of product arg1 * arg2. */
-#if SIZEOF_PTR == 4 && defined(ARCH_UINT64_TYPE)
-#define BngMult(resh,resl,arg1,arg2) {                                      \
-  ARCH_UINT64_TYPE p = (ARCH_UINT64_TYPE)(arg1) * (ARCH_UINT64_TYPE)(arg2); \
-  resh = p >> 32;                                                           \
-  resl = p;                                                                 \
-}
-#else
-#define BngMult(resh,resl,arg1,arg2) {                                      \
-  bngdigit p11 = BngLowHalf(arg1) * BngLowHalf(arg2);                       \
-  bngdigit p12 = BngLowHalf(arg1) * BngHighHalf(arg2);                      \
-  bngdigit p21 = BngHighHalf(arg1) * BngLowHalf(arg2);                      \
-  bngdigit p22 = BngHighHalf(arg1) * BngHighHalf(arg2);                     \
-  resh = p22 + (p12 >> BNG_BITS_PER_HALF_DIGIT)                             \
-             + (p21 >> BNG_BITS_PER_HALF_DIGIT);                            \
-  BngAdd3(resl, resh,                                                       \
-     p11, p12 << BNG_BITS_PER_HALF_DIGIT, p21 << BNG_BITS_PER_HALF_DIGIT);  \
-}
-#endif
-#endif
-
-#ifndef BngDiv
-/* Divide the double-width number nh:nl by d.
-   Require d != 0 and nh < d.
-   Store quotient in quo, remainder in rem.
-   Can be slow if d is not normalized. */
-#define BngDiv(quo,rem,nh,nl,d) bng_div_aux(&(quo),&(rem),nh,nl,d)
-#define BngDivNeedsNormalization
-
-static void bng_div_aux(bngdigit * quo, bngdigit * rem,
-                        bngdigit nh, bngdigit nl, bngdigit d)
-{
-  bngdigit dl, dh, ql, qh, pl, ph, nsaved;
-
-  dl = BngLowHalf(d);
-  dh = BngHighHalf(d);
-  /* Under-estimate the top half of the quotient (qh) */
-  qh = nh / (dh + 1);
-  /* Shift nh:nl right by BNG_BITS_PER_HALF_DIGIT bits,
-     so that we focus on the top 1.5 digits of the numerator.
-     Then, subtract (qh * d) from nh:nl. */
-  nsaved = BngLowHalf(nl);
-  ph = qh * dh;
-  pl = qh * dl;
-  nh -= ph; /* Subtract before shifting so that carry propagates for free */
-  nl = (nl >> BNG_BITS_PER_HALF_DIGIT) | (nh << BNG_BITS_PER_HALF_DIGIT);
-  nh = (nh >> BNG_BITS_PER_HALF_DIGIT);
-  nh -= (nl < pl);  /* Borrow */
-  nl -= pl;
-  /* Adjust estimate qh until nh:nl < 0:d */
-  while (nh != 0 || nl >= d) {
-    nh -= (nl < d); /* Borrow */
-    nl -= d;
-    qh++;
-  }
-  /* Under-estimate the bottom half of the quotient (ql) */
-  ql = nl / (dh + 1);
-  /* Shift nh:nl left by BNG_BITS_PER_HALF_DIGIT bits, restoring the
-     low bits we saved earlier, so that we focus on the bottom 1.5 digit
-     of the numerator.  Then, subtract (ql * d) from nh:nl. */
-  ph = ql * dh;
-  pl = ql * dl;
-  nl -= ph; /* Subtract before shifting so that carry propagates for free */
-  nh = (nl >> BNG_BITS_PER_HALF_DIGIT);
-  nl = (nl << BNG_BITS_PER_HALF_DIGIT) | nsaved;
-  nh -= (nl < pl);  /* Borrow */
-  nl -= pl;
-  /* Adjust estimate ql until nh:nl < 0:d */
-  while (nh != 0 || nl >= d) {
-    nh -= (nl < d); /* Borrow */
-    nl -= d;
-    ql++;
-  }
-  /* We're done */
-  *quo = (qh << BNG_BITS_PER_HALF_DIGIT) | ql;
-  *rem = nl;
-}
-
-#endif

diff --git a/otherlibs/num/bng_ia32.c b/otherlibs/num/bng_ia32.c
deleted file mode 100644 (file)
index 6b6cabd..0000000
--- a/otherlibs/num/bng_ia32.c
+++ /dev/null
@@ -1,411 +0,0 @@
-/**************************************************************************/
-/*                                                                        */
-/*                                 OCaml                                  */
-/*                                                                        */
-/*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           */
-/*                                                                        */
-/*   Copyright 2003 Institut National de Recherche en Informatique et     */
-/*     en Automatique.                                                    */
-/*                                                                        */
-/*   All rights reserved.  This file is distributed under the terms of    */
-/*   the GNU Lesser General Public License version 2.1, with the          */
-/*   special exception on linking described in the file LICENSE.          */
-/*                                                                        */
-/**************************************************************************/
-
-/* Code specific to the Intel IA32 (x86) architecture. */
-
-#define BngAdd2(res,carryout,arg1,arg2)                                     \
-  asm("xorl %1, %1 \n\t"                                                    \
-      "addl %3, %0 \n\t"                                                    \
-      "setc %b1"                                                            \
-      : "=r" (res), "=&q" (carryout)                                        \
-      : "0" (arg1), "rm" (arg2))
-
-#define BngSub2(res,carryout,arg1,arg2)                                     \
-  asm("xorl %1, %1 \n\t"                                                    \
-      "subl %3, %0 \n\t"                                                    \
-      "setc %b1"                                                            \
-      : "=r" (res), "=&q" (carryout)                                        \
-      : "0" (arg1), "rm" (arg2))
-
-#define BngMult(resh,resl,arg1,arg2)                                        \
-  asm("mull %3"                                                             \
-      : "=a" (resl), "=d" (resh)                                            \
-      : "a" (arg1), "r" (arg2))
-
-#define BngDiv(quo,rem,nh,nl,d)                                             \
-  asm("divl %4"                                                             \
-      : "=a" (quo), "=d" (rem)                                              \
-      : "a" (nl), "d" (nh), "r" (d))
-
-/* Reimplementation in asm of some of the bng operations. */
-
-static bngcarry bng_ia32_add
-       (bng a/*[alen]*/, bngsize alen,
-        bng b/*[blen]*/, bngsize blen,
-        bngcarry carry)
-{
-  bngdigit tmp;
-  alen -= blen;
-  if (blen > 0) {
-    asm("negb %b3 \n\t"
-        "1: \n\t"
-        "movl (%0), %4 \n\t"
-        "adcl (%1), %4 \n\t"
-        "movl %4, (%0) \n\t"
-        "leal 4(%0), %0 \n\t"
-        "leal 4(%1), %1 \n\t"
-        "decl %2 \n\t"
-        "jnz 1b \n\t"
-        "setc %b3"
-        : "+&r" (a), "+&r" (b), "+&r" (blen), "+&q" (carry), "=&r" (tmp));
-  }
-  if (carry == 0 || alen == 0) return carry;
-  do {
-    if (++(*a) != 0) return 0;
-    a++;
-  } while (--alen);
-  return 1;
-}
-
-static bngcarry bng_ia32_sub
-       (bng a/*[alen]*/, bngsize alen,
-        bng b/*[blen]*/, bngsize blen,
-        bngcarry carry)
-{
-  bngdigit tmp;
-  alen -= blen;
-  if (blen > 0) {
-    asm("negb %b3 \n\t"
-        "1: \n\t"
-        "movl (%0), %4 \n\t"
-        "sbbl (%1), %4 \n\t"
-        "movl %4, (%0) \n\t"
-        "leal 4(%0), %0 \n\t"
-        "leal 4(%1), %1 \n\t"
-        "decl %2 \n\t"
-        "jnz 1b \n\t"
-        "setc %b3"
-        : "+&r" (a), "+&r" (b), "+&r" (blen), "+&q" (carry), "=&r" (tmp));
-  }
-  if (carry == 0 || alen == 0) return carry;
-  do {
-    if ((*a)-- != 0) return 0;
-    a++;
-  } while (--alen);
-  return 1;
-}
-
-static bngdigit bng_ia32_mult_add_digit
-     (bng a/*[alen]*/, bngsize alen,
-      bng b/*[blen]*/, bngsize blen,
-      bngdigit d)
-{
-  bngdigit out;
-  bngcarry carry;
-
-  alen -= blen;
-  out = 0;
-  if (blen > 0) {
-    asm("1: \n\t"
-        "movl (%1), %%eax \n\t"
-        "mull %4\n\t"           /* edx:eax = d * next digit of b */
-        "addl (%0), %%eax \n\t" /* add next digit of a to eax */
-        "adcl $0, %%edx \n\t"   /* accumulate carry in edx */
-        "addl %3, %%eax \n\t"   /* add out to eax */
-        "adcl $0, %%edx \n\t"   /* accumulate carry in edx */
-        "movl %%eax, (%0) \n\t" /* eax is next digit of result */
-        "movl %%edx, %3 \n\t"   /* edx is next out */
-        "leal 4(%0), %0 \n\t"
-        "leal 4(%1), %1 \n\t"
-        "decl %2 \n\t"
-        "jnz 1b"
-        : "+&r" (a), "+&r" (b), "+&r" (blen), "=m" (out)
-        : "m" (d)
-        : "eax", "edx");
-  }
-  if (alen == 0) return out;
-  /* current digit of a += out */
-  BngAdd2(*a, carry, *a, out);
-  a++;
-  alen--;
-  /* Propagate carry */
-  if (carry == 0 || alen == 0) return carry;
-  do {
-    if (++(*a) != 0) return 0;
-    a++;
-  } while (--alen);
-  return 1;
-}
-
-static bngdigit bng_ia32_mult_sub_digit
-     (bng a/*[alen]*/, bngsize alen,
-      bng b/*[blen]*/, bngsize blen,
-      bngdigit d)
-{
-  bngdigit out, tmp;
-  bngcarry carry;
-
-  alen -= blen;
-  out = 0;
-  if (blen > 0) {
-    asm("1: \n\t"
-        "movl (%1), %%eax \n\t"
-        "movl (%0), %4 \n\t"
-        "mull %5\n\t"           /* edx:eax = d * next digit of b */
-        "subl %%eax, %4 \n\t"   /* subtract eax from next digit of a */
-        "adcl $0, %%edx \n\t"   /* accumulate carry in edx */
-        "subl %3, %4 \n\t"      /* subtract out */
-        "adcl $0, %%edx \n\t"   /* accumulate carry in edx */
-        "movl %4, (%0) \n\t"    /* store next digit of result */
-        "movl %%edx, %3 \n\t"   /* edx is next out */
-        "leal 4(%0), %0 \n\t"
-        "leal 4(%1), %1 \n\t"
-        "decl %2 \n\t"
-        "jnz 1b"
-        : "+&r" (a), "+&r" (b), "=m" (blen), "=m" (out), "=&r" (tmp)
-        : "m" (d)
-        : "eax", "edx");
-  }
-  if (alen == 0) return out;
-  /* current digit of a -= out */
-  BngSub2(*a, carry, *a, out);
-  a++;
-  alen--;
-  /* Propagate carry */
-  if (carry == 0 || alen == 0) return carry;
-  do {
-    if ((*a)-- != 0) return 0;
-    a++;
-  } while (--alen);
-  return 1;
-}
-
-/* This is another asm implementation of some of the bng operations,
-   using SSE2 operations to provide 64-bit arithmetic.
-   This is faster than the plain IA32 code above on the Pentium 4.
-   (Arithmetic operations with carry are slow on the Pentium 4). */
-
-#if BNG_ASM_LEVEL >= 2
-
-static bngcarry bng_ia32sse2_add
-       (bng a/*[alen]*/, bngsize alen,
-        bng b/*[blen]*/, bngsize blen,
-        bngcarry carry)
-{
-  alen -= blen;
-  if (blen > 0) {
-    asm("movd %3, %%mm0 \n\t"       /* MM0 is carry */
-        "1: \n\t"
-        "movd (%0), %%mm1 \n\t"     /* MM1 is next digit of a */
-        "movd (%1), %%mm2 \n\t"     /* MM2 is next digit of b */
-        "paddq %%mm1, %%mm0 \n\t"   /* Add carry (64 bits) */
-        "paddq %%mm2, %%mm0 \n\t"   /* Add digits (64 bits) */
-        "movd %%mm0, (%0) \n\t"     /* Store low 32 bits of result */
-        "psrlq $32, %%mm0 \n\t"     /* Next carry is top 32 bits of results */
-        "addl $4, %0\n\t"
-        "addl $4, %1\n\t"
-        "subl $1, %2\n\t"
-        "jne 1b \n\t"
-        "movd %%mm0, %3 \n\t"
-        "emms"
-        : "+&r" (a), "+&r" (b), "+&r" (blen), "+&rm" (carry));
-  }
-  if (carry == 0 || alen == 0) return carry;
-  do {
-    if (++(*a) != 0) return 0;
-    a++;
-  } while (--alen);
-  return 1;
-}
-
-static bngcarry bng_ia32sse2_sub
-       (bng a/*[alen]*/, bngsize alen,
-        bng b/*[blen]*/, bngsize blen,
-        bngcarry carry)
-{
-  alen -= blen;
-  if (blen > 0) {
-    asm("movd %3, %%mm0 \n\t"       /* MM0 is carry */
-        "1: \n\t"
-        "movd (%0), %%mm1 \n\t"     /* MM1 is next digit of a */
-        "movd (%1), %%mm2 \n\t"     /* MM2 is next digit of b */
-        "psubq %%mm0, %%mm1 \n\t"   /* Subtract carry (64 bits) */
-        "psubq %%mm2, %%mm1 \n\t"   /* Subtract digits (64 bits) */
-        "movd %%mm1, (%0) \n\t"     /* Store low 32 bits of result */
-        "psrlq $63, %%mm1 \n\t"     /* Next carry is sign bit of result */
-        "movq %%mm1, %%mm0 \n\t"
-        "addl $4, %0\n\t"
-        "addl $4, %1\n\t"
-        "subl $1, %2\n\t"
-        "jne 1b \n\t"
-        "movd %%mm0, %3 \n\t"
-        "emms"
-        : "+&r" (a), "+&r" (b), "+&r" (blen), "+&rm" (carry));
-  }
-  if (carry == 0 || alen == 0) return carry;
-  do {
-    if ((*a)-- != 0) return 0;
-    a++;
-  } while (--alen);
-  return 1;
-}
-
-static bngdigit bng_ia32sse2_mult_add_digit
-     (bng a/*[alen]*/, bngsize alen,
-      bng b/*[blen]*/, bngsize blen,
-      bngdigit d)
-{
-  bngdigit out;
-  bngcarry carry;
-
-  alen -= blen;
-  out = 0;
-  if (blen > 0) {
-    asm("pxor %%mm0, %%mm0 \n\t"      /* MM0 is carry */
-        "movd %4, %%mm7 \n\t"         /* MM7 is digit d */
-        "1: \n\t"
-        "movd (%0), %%mm1 \n\t"       /* MM1 is next digit of a */
-        "movd (%1), %%mm2 \n\t"       /* MM2 is next digit of b */
-        "pmuludq %%mm7, %%mm2 \n\t"   /* MM2 = d * digit of b */
-        "paddq %%mm1, %%mm0 \n\t"     /* Add product and carry ... */
-        "paddq %%mm2, %%mm0 \n\t"     /* ... and digit of a */
-        "movd %%mm0, (%0) \n\t"       /* Store low 32 bits of result */
-        "psrlq $32, %%mm0 \n\t"       /* Next carry is high 32 bits result */
-        "addl $4, %0\n\t"
-        "addl $4, %1\n\t"
-        "subl $1, %2\n\t"
-        "jne 1b \n\t"
-        "movd %%mm0, %3 \n\t"
-        "emms"
-        : "+&r" (a), "+&r" (b), "+&r" (blen), "=&rm" (out)
-        : "m" (d));
-  }
-  if (alen == 0) return out;
-  /* current digit of a += out */
-  BngAdd2(*a, carry, *a, out);
-  a++;
-  alen--;
-  /* Propagate carry */
-  if (carry == 0 || alen == 0) return carry;
-  do {
-    if (++(*a) != 0) return 0;
-    a++;
-  } while (--alen);
-  return 1;
-}
-
-static bngdigit bng_ia32sse2_mult_sub_digit
-     (bng a/*[alen]*/, bngsize alen,
-      bng b/*[blen]*/, bngsize blen,
-      bngdigit d)
-{
-  static unsigned long long bias1 = 0xFFFFFFFF00000000ULL - 0xFFFFFFFFULL;
-  static unsigned long bias2 = 0xFFFFFFFFUL;
-  bngdigit out;
-  bngcarry carry;
-
-  alen -= blen;
-  out = 0;
-  if (blen > 0) {
-    /* Carry C is represented by ENC(C) = 0xFFFFFFFF - C (one's complement) */
-    asm("movd %6, %%mm0 \n\t"         /* MM0 is carry (initially 0xFFFFFFFF) */
-        "movq %5, %%mm6 \n\t"         /* MM6 is magic constant bias1 */
-        "movd %4, %%mm7 \n\t"         /* MM7 is digit d */
-        "1: \n\t"
-        "movd (%0), %%mm1 \n\t"       /* MM1 is next digit of a */
-        "movd (%1), %%mm2 \n\t"       /* MM2 is next digit of b */
-        "paddq %%mm6, %%mm1 \n\t"     /* bias digit of a */
-        "pmuludq %%mm7, %%mm2 \n\t"   /* MM2 = d * digit of b */
-        /* Compute
-           digit of a + ENC(carry) + 0xFFFFFFFF00000000 - 0xFFFFFFFF - product
-           = digit of a - carry + 0xFFFFFFFF00000000 - product
-           = digit of a - carry - productlow + (ENC(nextcarry) << 32) */
-        "psubq %%mm2, %%mm1 \n\t"
-        "paddq %%mm1, %%mm0 \n\t"
-        "movd %%mm0, (%0) \n\t"       /* Store low 32 bits of result */
-        "psrlq $32, %%mm0 \n\t"       /* Next carry is 32 high bits of result */
-        "addl $4, %0\n\t"
-        "addl $4, %1\n\t"
-        "subl $1, %2\n\t"
-        "jne 1b \n\t"
-        "movd %%mm0, %3 \n\t"
-        "emms"
-        : "+&r" (a), "+&r" (b), "+&r" (blen), "=&rm" (out)
-        : "m" (d), "m" (bias1), "m" (bias2));
-    out = ~out; /* Undo encoding on out digit */
-  }
-  if (alen == 0) return out;
-  /* current digit of a -= out */
-  BngSub2(*a, carry, *a, out);
-  a++;
-  alen--;
-  /* Propagate carry */
-  if (carry == 0 || alen == 0) return carry;
-  do {
-    if ((*a)-- != 0) return 0;
-    a++;
-  } while (--alen);
-  return 1;
-}
-
-/* Detect whether SSE2 instructions are supported */
-
-static int bng_ia32_sse2_supported(void)
-{
-  unsigned int flags, newflags, max_id, capabilities;
-
-#define EFLAG_CPUID 0x00200000
-#define CPUID_IDENTIFY 0
-#define CPUID_CAPABILITIES 1
-#define SSE2_CAPABILITY 26
-
-  /* Check if processor has CPUID instruction */
-  asm("pushfl \n\t"
-      "popl %0"
-      : "=r" (flags) : );
-  newflags = flags ^ EFLAG_CPUID;   /* CPUID detection flag */
-  asm("pushfl \n\t"
-      "pushl %1 \n\t"
-      "popfl \n\t"
-      "pushfl \n\t"
-      "popl %0 \n\t"
-      "popfl"
-      : "=r" (flags) : "r" (newflags));
-  /* If CPUID detection flag cannot be changed, CPUID instruction is not
-     available */
-  if ((flags & EFLAG_CPUID) != (newflags & EFLAG_CPUID)) return 0;
-  /* See if SSE2 extensions are supported */
-  asm("pushl %%ebx \n\t"        /* need to preserve %ebx for PIC */
-      "cpuid \n\t"
-      "popl %%ebx"
-      : "=a" (max_id) : "a" (CPUID_IDENTIFY): "ecx", "edx");
-  if (max_id < 1) return 0;
-  asm("pushl %%ebx \n\t"
-      "cpuid \n\t"
-      "popl %%ebx"
-      : "=d" (capabilities) : "a" (CPUID_CAPABILITIES) : "ecx");
-  return capabilities & (1 << SSE2_CAPABILITY);
-}
-
-#endif
-
-static void bng_ia32_setup_ops(void)
-{
-#if BNG_ASM_LEVEL >= 2
-  if (bng_ia32_sse2_supported()) {
-    bng_ops.add = bng_ia32sse2_add;
-    bng_ops.sub = bng_ia32sse2_sub;
-    bng_ops.mult_add_digit = bng_ia32sse2_mult_add_digit;
-    bng_ops.mult_sub_digit = bng_ia32sse2_mult_sub_digit;
-    return;
-  }
-#endif
-  bng_ops.add = bng_ia32_add;
-  bng_ops.sub = bng_ia32_sub;
-  bng_ops.mult_add_digit = bng_ia32_mult_add_digit;
-  bng_ops.mult_sub_digit = bng_ia32_mult_sub_digit;
-}
-
-#define BNG_SETUP_OPS bng_ia32_setup_ops()

diff --git a/otherlibs/num/bng_ppc.c b/otherlibs/num/bng_ppc.c
deleted file mode 100644 (file)
index f4c098c..0000000
--- a/otherlibs/num/bng_ppc.c
+++ /dev/null
@@ -1,94 +0,0 @@
-/**************************************************************************/
-/*                                                                        */
-/*                                 OCaml                                  */
-/*                                                                        */
-/*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           */
-/*                                                                        */
-/*   Copyright 2003 Institut National de Recherche en Informatique et     */
-/*     en Automatique.                                                    */
-/*                                                                        */
-/*   All rights reserved.  This file is distributed under the terms of    */
-/*   the GNU Lesser General Public License version 2.1, with the          */
-/*   special exception on linking described in the file LICENSE.          */
-/*                                                                        */
-/**************************************************************************/
-
-/* Code specific to the PowerPC architecture. */
-
-#define BngAdd2(res,carryout,arg1,arg2)                                     \
-  asm("addc %0, %2, %3 \n\t"                                                \
-      "li %1, 0 \n\t"                                                       \
-      "addze %1, %1"                                                        \
-      : "=r" (res), "=r" (carryout)                                         \
-      : "r" (arg1), "r" (arg2))
-
-#define BngAdd2Carry(res,carryout,arg1,arg2,carryin)                        \
-  asm("addic %1, %4, -1 \n\t"                                               \
-      "adde %0, %2, %3 \n\t"                                                \
-      "li %1, 0 \n\t"                                                       \
-      "addze %1, %1"                                                        \
-      : "=r" (res), "=&r" (carryout)                                        \
-      : "r" (arg1), "r" (arg2), "1" (carryin))
-
-#define BngAdd3(res,carryaccu,arg1,arg2,arg3)                               \
-  asm("addc %0, %2, %3 \n\t"                                                \
-      "addze %1, %1 \n\t"                                                   \
-      "addc %0, %0, %4 \n\t"                                                \
-      "addze %1, %1"                                                        \
-      : "=&r" (res), "=&r" (carryaccu)                                      \
-      : "r" (arg1), "r" (arg2), "r" (arg3), "1" (carryaccu))
-
-/* The "subtract" instructions interpret carry differently than what we
-   need: the processor carry bit CA is 1 if no carry occured,
-   0 if a carry occured.  In other terms, CA = !carry.
-   Thus, subfe rd,ra,rb computes rd = ra - rb - !CA
-         subfe rd,rd,rd sets rd = - !CA
-         subfe rd,rd,rd; neg rd, rd sets rd = !CA and recovers "our" carry. */
-
-#define BngSub2(res,carryout,arg1,arg2)                                     \
-  asm("subfc %0, %3, %2 \n\t"                                               \
-      "subfe %1, %1, %1\n\t"                                                \
-      "neg %1, %1"                                                          \
-      : "=r" (res), "=r" (carryout)                                         \
-      : "r" (arg1), "r" (arg2))
-
-#define BngSub2Carry(res,carryout,arg1,arg2,carryin)                        \
-  asm("subfic %1, %4, 0 \n\t"                                               \
-      "subfe %0, %3, %2 \n\t"                                               \
-      "subfe %1, %1, %1 \n\t"                                               \
-      "neg %1, %1"                                                          \
-      : "=r" (res), "=&r" (carryout)                                        \
-      : "r" (arg1), "r" (arg2), "1" (carryin))
-
-/* Here is what happens with carryaccu:
-       neg %1, %1       carryaccu = -carryaccu
-       addze %1, %1     carryaccu += !carry1
-       addze %1, %1     carryaccu += !carry2
-       subifc %1, %1, 2 carryaccu = 2 - carryaccu
-   Thus, carryaccu_final = carryaccu_initial + 2 - (1 - carry1) - (1 - carry2)
-                         = carryaccu_initial + carry1 + carry2
-*/
-
-#define BngSub3(res,carryaccu,arg1,arg2,arg3)                               \
-  asm("neg %1, %1 \n\t"                                                     \
-      "subfc %0, %3, %2 \n\t"                                               \
-      "addze %1, %1 \n\t"                                                   \
-      "subfc %0, %4, %0 \n\t"                                               \
-      "addze %1, %1 \n\t"                                                   \
-      "subfic %1, %1, 2 \n\t"                                               \
-      : "=&r" (res), "=&r" (carryaccu)                                      \
-      : "r" (arg1), "r" (arg2), "r" (arg3), "1" (carryaccu))
-
-#if defined(__ppc64__) || defined(__PPC64__)
-#define BngMult(resh,resl,arg1,arg2)                                        \
-  asm("mulld %0, %2, %3 \n\t"                                               \
-      "mulhdu %1, %2, %3"                                                   \
-      : "=&r" (resl), "=r" (resh)                                           \
-      : "r" (arg1), "r" (arg2))
-#else
-#define BngMult(resh,resl,arg1,arg2)                                        \
-  asm("mullw %0, %2, %3 \n\t"                                               \
-      "mulhwu %1, %2, %3"                                                   \
-      : "=&r" (resl), "=r" (resh)                                           \
-      : "r" (arg1), "r" (arg2))
-#endif

diff --git a/otherlibs/num/bng_sparc.c b/otherlibs/num/bng_sparc.c
deleted file mode 100644 (file)
index c007cb7..0000000
--- a/otherlibs/num/bng_sparc.c
+++ /dev/null
@@ -1,77 +0,0 @@
-/**************************************************************************/
-/*                                                                        */
-/*                                 OCaml                                  */
-/*                                                                        */
-/*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           */
-/*                                                                        */
-/*   Copyright 2003 Institut National de Recherche en Informatique et     */
-/*     en Automatique.                                                    */
-/*                                                                        */
-/*   All rights reserved.  This file is distributed under the terms of    */
-/*   the GNU Lesser General Public License version 2.1, with the          */
-/*   special exception on linking described in the file LICENSE.          */
-/*                                                                        */
-/**************************************************************************/
-
-/* Code specific to the SPARC (V8 and above) architecture. */
-
-#define BngAdd2(res,carryout,arg1,arg2)                                     \
-  asm("addcc %2, %3, %0 \n\t"                                               \
-      "addx  %%g0, 0, %1"                                                   \
-      : "=r" (res), "=r" (carryout)                                         \
-      : "r" (arg1), "r" (arg2)                                              \
-      : "cc")
-
-#define BngAdd2Carry(res,carryout,arg1,arg2,carryin)                        \
-  asm("subcc %%g0, %4, %%g0 \n\t"                                           \
-      "addxcc %2, %3, %0 \n\t"                                              \
-      "addx  %%g0, 0, %1"                                                   \
-      : "=r" (res), "=r" (carryout)                                         \
-      : "r" (arg1), "r" (arg2), "r" (carryin)                               \
-      : "cc")
-
-#define BngAdd3(res,carryaccu,arg1,arg2,arg3)                               \
-  asm("addcc %2, %3, %0 \n\t"                                               \
-      "addx %1, 0, %1 \n\t"                                                 \
-      "addcc %0, %4, %0 \n\t"                                               \
-      "addx %1, 0, %1"                                                      \
-      : "=r" (res), "=r" (carryaccu)                                        \
-      : "r" (arg1), "r" (arg2), "r" (arg3), "1" (carryaccu)                 \
-      : "cc")
-
-#define BngSub2(res,carryout,arg1,arg2)                                     \
-  asm("subcc %2, %3, %0 \n\t"                                               \
-      "addx  %%g0, 0, %1"                                                   \
-      : "=r" (res), "=r" (carryout)                                         \
-      : "r" (arg1), "r" (arg2)                                              \
-      : "cc")
-
-#define BngSub2Carry(res,carryout,arg1,arg2,carryin)                        \
-  asm("subcc %%g0, %4, %%g0 \n\t"                                           \
-      "subxcc %2, %3, %0 \n\t"                                              \
-      "addx  %%g0, 0, %1"                                                   \
-      : "=r" (res), "=r" (carryout)                                         \
-      : "r" (arg1), "r" (arg2), "r" (carryin)                               \
-      : "cc")
-
-#define BngSub3(res,carryaccu,arg1,arg2,arg3)                               \
-  asm("subcc %2, %3, %0 \n\t"                                               \
-      "addx %1, 0, %1 \n\t"                                                 \
-      "subcc %0, %4, %0 \n\t"                                               \
-      "addx %1, 0, %1"                                                      \
-      : "=r" (res), "=r" (carryaccu)                                        \
-      : "r" (arg1), "r" (arg2), "r" (arg3), "1" (carryaccu)                 \
-      : "cc")
-
-#define BngMult(resh,resl,arg1,arg2)                                        \
-  asm("umul %2, %3, %0 \n\t"                                                \
-      "rd %%y, %1"                                                          \
-      : "=r" (resl), "=r" (resh)                                            \
-      : "r" (arg1), "r" (arg2))
-
-#define BngDiv(quo,rem,nh,nl,d)                                             \
-  asm("wr %1, %%y \n\t"                                                     \
-      "udiv %2, %3, %0"                                                     \
-      : "=r" (quo)                                                          \
-      : "r" (nh), "r" (nl), "r" (d));                                       \
-  rem = nl - d * quo

diff --git a/otherlibs/num/int_misc.ml b/otherlibs/num/int_misc.ml
deleted file mode 100644 (file)
index d7d7190..0000000
--- a/otherlibs/num/int_misc.ml
+++ /dev/null
@@ -1,36 +0,0 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                 OCaml                                  *)
-(*                                                                        *)
-(*     Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt       *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
-(* Some extra operations on integers *)
-
-let rec gcd_int i1 i2 =
-  if i2 = 0 then abs i1 else gcd_int i2 (i1 mod i2)
-;;
-
-let rec num_bits_int_aux n =
-  if n = 0 then 0 else succ(num_bits_int_aux (n lsr 1));;
-
-let num_bits_int n = num_bits_int_aux (abs n);;
-
-let sign_int i = if i = 0 then 0 else if i > 0 then 1 else -1;;
-
-let length_of_int = Sys.word_size - 2;;
-
-let monster_int = 1 lsl length_of_int;;
-let biggest_int = monster_int - 1;;
-let least_int = - biggest_int;;
-
-let compare_int n1 n2 =
-  if n1 == n2 then 0 else if n1 > n2 then 1 else -1;;

diff --git a/otherlibs/num/int_misc.mli b/otherlibs/num/int_misc.mli
deleted file mode 100644 (file)
index 1ee11ba..0000000
--- a/otherlibs/num/int_misc.mli
+++ /dev/null
@@ -1,25 +0,0 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                 OCaml                                  *)
-(*                                                                        *)
-(*     Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt       *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
-(* Some extra operations on integers *)
-
-val gcd_int: int -> int -> int
-val num_bits_int: int -> int
-val compare_int: int -> int -> int
-val sign_int: int -> int
-val length_of_int: int
-val biggest_int: int
-val least_int: int
-val monster_int: int

diff --git a/otherlibs/num/nat.h b/otherlibs/num/nat.h
deleted file mode 100644 (file)
index 45e7b95..0000000
--- a/otherlibs/num/nat.h
+++ /dev/null
@@ -1,18 +0,0 @@
-/**************************************************************************/
-/*                                                                        */
-/*                                 OCaml                                  */
-/*                                                                        */
-/*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           */
-/*                                                                        */
-/*   Copyright 1999 Institut National de Recherche en Informatique et     */
-/*     en Automatique.                                                    */
-/*                                                                        */
-/*   All rights reserved.  This file is distributed under the terms of    */
-/*   the GNU Lesser General Public License version 2.1, with the          */
-/*   special exception on linking described in the file LICENSE.          */
-/*                                                                        */
-/**************************************************************************/
-
-/* Nats are represented as unstructured blocks with tag Custom_tag. */
-
-#define Digit_val(nat,pos) (((bng) Data_custom_val(nat))[pos])

diff --git a/otherlibs/num/nat.ml b/otherlibs/num/nat.ml
deleted file mode 100644 (file)
index c7a2669..0000000
--- a/otherlibs/num/nat.ml
+++ /dev/null
@@ -1,594 +0,0 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                 OCaml                                  *)
-(*                                                                        *)
-(*     Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt       *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
-open Int_misc
-
-type nat;;
-
-external create_nat: int -> nat = "create_nat"
-external set_to_zero_nat: nat -> int -> int -> unit = "set_to_zero_nat"
-external blit_nat: nat -> int -> nat -> int -> int -> unit = "blit_nat"
-external set_digit_nat: nat -> int -> int -> unit = "set_digit_nat"
-external nth_digit_nat: nat -> int -> int = "nth_digit_nat"
-external set_digit_nat_native: nat -> int -> nativeint -> unit
-                             = "set_digit_nat_native"
-external nth_digit_nat_native: nat -> int -> nativeint = "nth_digit_nat_native"
-external num_digits_nat: nat -> int -> int -> int = "num_digits_nat"
-external num_leading_zero_bits_in_digit: nat -> int -> int
-                                       = "num_leading_zero_bits_in_digit"
-external is_digit_int: nat -> int -> bool = "is_digit_int"
-external is_digit_zero: nat -> int -> bool = "is_digit_zero"
-external is_digit_normalized: nat -> int -> bool = "is_digit_normalized"
-external is_digit_odd: nat -> int -> bool = "is_digit_odd"
-external incr_nat: nat -> int -> int -> int -> int = "incr_nat"
-external add_nat: nat -> int -> int -> nat -> int -> int -> int -> int
-                = "add_nat" "add_nat_native"
-external complement_nat: nat -> int -> int -> unit = "complement_nat"
-external decr_nat: nat -> int -> int -> int -> int = "decr_nat"
-external sub_nat: nat -> int -> int -> nat -> int -> int -> int -> int
-                = "sub_nat" "sub_nat_native"
-external mult_digit_nat:
-     nat -> int -> int -> nat -> int -> int -> nat -> int -> int
-   = "mult_digit_nat" "mult_digit_nat_native"
-external mult_nat:
-    nat -> int -> int -> nat -> int -> int -> nat -> int -> int -> int
-  = "mult_nat" "mult_nat_native"
-external square_nat: nat -> int -> int -> nat -> int -> int -> int
-                   = "square_nat" "square_nat_native"
-external shift_left_nat: nat -> int -> int -> nat -> int -> int -> unit
-                       = "shift_left_nat" "shift_left_nat_native"
-external div_digit_nat:
-    nat -> int -> nat -> int -> nat -> int -> int -> nat -> int -> unit
-  = "div_digit_nat" "div_digit_nat_native"
-external div_nat: nat -> int -> int -> nat -> int -> int -> unit
-                = "div_nat" "div_nat_native"
-external shift_right_nat: nat -> int -> int -> nat -> int -> int -> unit
-                        = "shift_right_nat" "shift_right_nat_native"
-external compare_digits_nat: nat -> int -> nat -> int -> int
-                           = "compare_digits_nat"
-external compare_nat: nat -> int -> int -> nat -> int -> int -> int
-                    = "compare_nat" "compare_nat_native"
-external land_digit_nat: nat -> int -> nat -> int -> unit = "land_digit_nat"
-external lor_digit_nat: nat -> int -> nat -> int -> unit = "lor_digit_nat"
-external lxor_digit_nat: nat -> int -> nat -> int -> unit = "lxor_digit_nat"
-
-external initialize_nat: unit -> unit = "initialize_nat"
-let _ = initialize_nat()
-
-let length_nat (n : nat) = Obj.size (Obj.repr n) - 1
-
-let length_of_digit = Sys.word_size;;
-
-let make_nat len =
-  if len < 0 then invalid_arg "make_nat" else
-    let res = create_nat len in set_to_zero_nat res 0 len; res
-
-(* Nat temporaries *)
-let a_2 = make_nat 2
-and a_1 = make_nat 1
-and b_2 = make_nat 2
-
-let copy_nat nat off_set length =
- let res = create_nat (length) in
-  blit_nat res 0 nat off_set length;
-  res
-
-let is_zero_nat n off len =
-  compare_nat (make_nat 1) 0 1 n off (num_digits_nat n off len) = 0
-
-let is_nat_int nat off len =
-  num_digits_nat nat off len = 1 && is_digit_int nat off
-
-let sys_int_of_nat nat off len =
-  if is_nat_int nat off len
-  then nth_digit_nat nat off
-  else failwith "int_of_nat"
-
-let int_of_nat nat =
-  sys_int_of_nat nat 0 (length_nat nat)
-
-let nat_of_int i =
-  if i < 0 then invalid_arg "nat_of_int" else
-    let res = make_nat 1 in
-    if i = 0 then res else begin set_digit_nat res 0 i; res end
-
-let eq_nat nat1 off1 len1 nat2 off2 len2 =
-  compare_nat nat1 off1 (num_digits_nat nat1 off1 len1)
-              nat2 off2 (num_digits_nat nat2 off2 len2) = 0
-and le_nat nat1 off1 len1 nat2 off2 len2 =
-  compare_nat nat1 off1 (num_digits_nat nat1 off1 len1)
-              nat2 off2 (num_digits_nat nat2 off2 len2) <= 0
-and lt_nat nat1 off1 len1 nat2 off2 len2 =
-  compare_nat nat1 off1 (num_digits_nat nat1 off1 len1)
-              nat2 off2 (num_digits_nat nat2 off2 len2) < 0
-and ge_nat nat1 off1 len1 nat2 off2 len2 =
-  compare_nat nat1 off1 (num_digits_nat nat1 off1 len1)
-              nat2 off2 (num_digits_nat nat2 off2 len2) >= 0
-and gt_nat nat1 off1 len1 nat2 off2 len2 =
-  compare_nat nat1 off1 (num_digits_nat nat1 off1 len1)
-              nat2 off2 (num_digits_nat nat2 off2 len2) > 0
-
-(* XL: now implemented in C for better performance.
-   The code below doesn't handle carries correctly.
-   Fortunately, the carry is never used. *)
-(***
-let square_nat nat1 off1 len1 nat2 off2 len2 =
-  let c = ref 0
-  and trash = make_nat 1 in
-    (* Double product *)
-    for i = 0 to len2 - 2 do
-        c := !c + mult_digit_nat
-                         nat1
-                         (succ (off1 + 2 * i))
-                         (2 * (pred (len2 - i)))
-                         nat2
-                         (succ (off2 + i))
-                         (pred (len2 - i))
-                         nat2
-                         (off2 + i)
-    done;
-    shift_left_nat nat1 0 len1 trash 0 1;
-    (* Square of digit *)
-    for i = 0 to len2 - 1 do
-        c := !c + mult_digit_nat
-                         nat1
-                         (off1 + 2 * i)
-                         (len1 - 2 * i)
-                         nat2
-                         (off2 + i)
-                         1
-                         nat2
-                         (off2 + i)
-    done;
-  !c
-***)
-
-(*
-let gcd_int_nat i nat off len =
-  if i = 0 then 1 else
-  if is_nat_int nat off len then begin
-    set_digit_nat nat off (gcd_int (nth_digit_nat nat off) i); 0
-  end else begin
-    let len_copy = succ len in
-    let copy = create_nat len_copy
-    and quotient = create_nat 1
-    and remainder = create_nat 1 in
-    blit_nat copy 0 nat off len;
-    set_digit_nat copy len 0;
-    div_digit_nat quotient 0 remainder 0 copy 0 len_copy (nat_of_int i) 0;
-    set_digit_nat nat off (gcd_int (nth_digit_nat remainder 0) i);
-    0
-  end
-*)
-
-let exchange r1 r2 =
-  let old1 = !r1 in r1 := !r2; r2 := old1
-
-let gcd_nat nat1 off1 len1 nat2 off2 len2 =
-  if is_zero_nat nat1 off1 len1 then begin
-    blit_nat nat1 off1 nat2 off2 len2; len2
-  end else begin
-    let copy1 = ref (create_nat (succ len1))
-    and copy2 = ref (create_nat (succ len2)) in
-      blit_nat !copy1 0 nat1 off1 len1;
-      blit_nat !copy2 0 nat2 off2 len2;
-      set_digit_nat !copy1 len1 0;
-      set_digit_nat !copy2 len2 0;
-      if lt_nat !copy1 0 len1 !copy2 0 len2
-         then exchange copy1 copy2;
-      let real_len1 =
-            ref (num_digits_nat !copy1 0 (length_nat !copy1))
-      and real_len2 =
-            ref (num_digits_nat !copy2 0 (length_nat !copy2)) in
-      while not (is_zero_nat !copy2 0 !real_len2) do
-        set_digit_nat !copy1 !real_len1 0;
-        div_nat !copy1 0 (succ !real_len1) !copy2 0 !real_len2;
-        exchange copy1 copy2;
-        real_len1 := !real_len2;
-        real_len2 := num_digits_nat !copy2 0 !real_len2
-      done;
-      blit_nat nat1 off1 !copy1 0 !real_len1;
-      !real_len1
-  end
-
-(* Integer square root using newton method (nearest integer by default) *)
-
-(* Theorem: the sequence x_{n+1} = ( x_n + a/x_n )/2 converges toward
-   the integer square root (by default) of a for any starting value x_0
-   strictly greater than the square root of a except if a + 1 is a
-   perfect square. In this situation, the sequence alternates between
-   the excess and default integer square root. In any case, the last
-   strictly decreasing term is the expected result *)
-
-let sqrt_nat rad off len =
- let len = num_digits_nat rad off len in
- (* Working copy of radicand *)
- let len_parity = len mod 2 in
- let rad_len = len + 1 + len_parity in
- let rad =
-   let res = create_nat rad_len in
-   blit_nat res 0 rad off len;
-   set_digit_nat res len 0;
-   set_digit_nat res (rad_len - 1) 0;
-   res in
- let cand_len = (len + 1) / 2 in  (* ceiling len / 2 *)
- let cand_rest = rad_len - cand_len in
- (* Candidate square root cand = "|FFFF .... |" *)
- let cand = make_nat cand_len in
- (* Improve starting square root:
-    We compute nbb, the number of significant bits of the first digit of the
-    candidate
-    (half of the number of significant bits in the first two digits
-     of the radicand extended to an even length).
-    shift_cand is word_size - nbb *)
- let shift_cand =
-   ((num_leading_zero_bits_in_digit rad (len-1)) +
-     Sys.word_size * len_parity) / 2 in
- (* All radicand bits are zeroed, we give back 0. *)
- if shift_cand = Sys.word_size then cand else
- begin
-  complement_nat cand 0 cand_len;
-  shift_right_nat cand 0 1 a_1 0 shift_cand;
-  let next_cand = create_nat rad_len in
-  (* Repeat until *)
-  let rec loop () =
-           (* next_cand := rad *)
-   blit_nat next_cand 0 rad 0 rad_len;
-           (* next_cand <- next_cand / cand *)
-   div_nat next_cand 0 rad_len cand 0 cand_len;
-           (* next_cand (strong weight) <- next_cand (strong weight) + cand,
-              i.e. next_cand <- cand + rad / cand *)
-   ignore (add_nat next_cand cand_len cand_rest cand 0 cand_len 0);
-        (* next_cand <- next_cand / 2 *)
-   shift_right_nat next_cand cand_len cand_rest a_1 0 1;
-   if lt_nat next_cand cand_len cand_rest cand 0 cand_len then
-    begin  (* cand <- next_cand *)
-     blit_nat cand 0 next_cand cand_len cand_len; loop ()
-    end
-   else cand in
-  loop ()
- end;;
-
-let power_base_max = make_nat 2;;
-
-match length_of_digit with
-  | 64 ->
-      set_digit_nat power_base_max 0 (Int64.to_int 1000000000000000000L);
-      ignore
-        (mult_digit_nat power_base_max 0 2
-           power_base_max 0 1 (nat_of_int 9) 0)
-  | 32 -> set_digit_nat power_base_max 0 1000000000
-  | _ -> assert false
-;;
-
-let pmax =
-  match length_of_digit with
-  | 64 -> 19
-  | 32 -> 9
-  | _ -> assert false
-;;
-
-let max_superscript_10_power_in_int =
-  match length_of_digit with
-  | 64 -> 18
-  | 32 -> 9
-  | _ -> assert false
-;;
-let max_power_10_power_in_int =
-  match length_of_digit with
-  | 64 -> nat_of_int (Int64.to_int 1000000000000000000L)
-  | 32 -> nat_of_int 1000000000
-  | _ -> assert false
-;;
-
-let raw_string_of_digit nat off =
-  if is_nat_int nat off 1
-     then begin string_of_int (nth_digit_nat nat off) end
-  else begin
-       blit_nat b_2 0 nat off 1;
-       div_digit_nat a_2 0 a_1 0 b_2 0 2 max_power_10_power_in_int 0;
-       let leading_digits = nth_digit_nat a_2 0
-       and s1 = string_of_int (nth_digit_nat a_1 0) in
-       let len = String.length s1 in
-       if leading_digits < 10 then begin
-            let result = Bytes.make (max_superscript_10_power_in_int+1) '0' in
-            Bytes.set result 0 (Char.chr (48 + leading_digits));
-            String.blit s1 0 result (Bytes.length result - len) len;
-            Bytes.to_string result
-       end else begin
-            let result = Bytes.make (max_superscript_10_power_in_int+2) '0' in
-            String.blit (string_of_int leading_digits) 0 result 0 2;
-            String.blit s1 0 result (Bytes.length result - len) len;
-            Bytes.to_string result
-       end
-  end
-
-(* XL: suppression de string_of_digit et de sys_string_of_digit.
-   La copie est de toute facon faite dans string_of_nat, qui est le
-   seul point d entree public dans ce code.
-
-   |   Deletion of string_of_digit and sys_string_of_digit.
-   The copy is already done in string_of_nat which is the only
-   public entry point in this code
-
-*)
-
-(******
-let sys_string_of_digit nat off =
-    let s = raw_string_of_digit nat off in
-    let result = String.create (String.length s) in
-    String.blit s 0 result 0 (String.length s);
-    s
-
-let string_of_digit nat =
-    sys_string_of_digit nat 0
-
-*******)
-
-(*
-   make_power_base affecte power_base des puissances successives de base a
-   partir de la puissance 1-ieme.
-   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
-  and j = ref 0 in
-   set_digit_nat power_base 0 base;
-   while incr i; is_digit_zero power_base !i do
-     ignore
-       (mult_digit_nat power_base !i 2
-          power_base (pred !i) 1
-          power_base 0)
-   done;
-   while !j < !i - 1 && is_digit_int power_base !j do incr j done;
-  (!i - 2, !j)
-
-(*
-(*
-   int_to_string places the representation of the integer int in base 'base'
-   in the string s by starting from the end position pos and going towards
-   the start, for 'times' places and updates the value of pos.
-*)
-let digits = "0123456789ABCDEF"
-
-let int_to_string int s pos_ref base times =
-  let i = ref int
-  and j = ref times in
-     while ((!i != 0) || (!j != 0)) && (!pos_ref != -1) do
-        Bytes.set s !pos_ref (String.get digits (!i mod base));
-        decr pos_ref;
-        decr j;
-        i := !i / base
-     done
-*)
-
-let power_base_int base i =
-  if i = 0 || base = 1 then
-    nat_of_int 1
-  else if base = 0 then
-    nat_of_int 0
-  else if i < 0 then
-    invalid_arg "power_base_int"
-  else begin
-         let power_base = make_nat (succ length_of_digit) in
-         let (pmax, _pint) = make_power_base base power_base in
-         let n = i / (succ pmax)
-         and rem = i mod (succ pmax) in
-           if n > 0 then begin
-               let newn =
-                 if i = biggest_int then n else (succ n) in
-               let res = make_nat newn
-               and res2 = make_nat newn
-               and l = num_bits_int n - 2 in
-                 blit_nat res 0 power_base pmax 1;
-                 for i = l downto 0 do
-                   let len = num_digits_nat res 0 newn in
-                   let len2 = min n (2 * len) in
-                   let succ_len2 = succ len2 in
-                     ignore (square_nat res2 0 len2 res 0 len);
-                     if n land (1 lsl i) > 0 then begin
-                       set_to_zero_nat res 0 len;
-                       ignore
-                         (mult_digit_nat res 0 succ_len2
-                            res2 0 len2  power_base pmax)
-                     end else
-                       blit_nat res 0 res2 0 len2;
-                     set_to_zero_nat res2 0 len2
-                 done;
-               if rem > 0 then begin
-                 ignore
-                   (mult_digit_nat res2 0 newn
-                      res 0 n power_base (pred rem));
-                 res2
-               end else res
-            end else
-              copy_nat power_base (pred rem) 1
-  end
-
-(* the ith element (i >= 2) of num_digits_max_vector is :
-    |                                 |
-    | biggest_string_length * log (i) |
-    | ------------------------------- | + 1
-    |      length_of_digit * log (2)  |
-    --                               --
-*)
-
-(* XL: ai specialise le code d origine a length_of_digit = 32.
-  |    the original code have been specialized to a length_of_digit = 32. *)
-(* Now deleted (useless?) *)
-
-(******
-let num_digits_max_vector =
-  [|0; 0; 1024; 1623; 2048; 2378; 2647; 2875; 3072; 3246; 3402;
-              3543; 3671; 3789; 3899; 4001; 4096|]
-
-let num_digits_max_vector =
-   match length_of_digit with
-     16 -> [|0; 0; 2048; 3246; 4096; 4755; 5294; 5749; 6144; 6492; 6803;
-              7085; 7342; 7578; 7797; 8001; 8192|]
-(* If really exotic machines !!!!
-   | 17 -> [|0; 0; 1928; 3055; 3855; 4476; 4983; 5411; 5783; 6110; 6403;
-              6668; 6910; 7133; 7339; 7530; 7710|]
-   | 18 -> [|0; 0; 1821; 2886; 3641; 4227; 4706; 5111; 5461; 5771; 6047;
-              6298; 6526; 6736; 6931; 7112; 7282|]
-   | 19 -> [|0; 0; 1725; 2734; 3449; 4005; 4458; 4842; 5174; 5467; 5729;
-              5966; 6183; 6382; 6566; 6738; 6898|]
-   | 20 -> [|0; 0; 1639; 2597; 3277; 3804; 4235; 4600; 4915; 5194; 5443;
-              5668; 5874; 6063; 6238; 6401; 6553|]
-   | 21 -> [|0; 0; 1561; 2473; 3121; 3623; 4034; 4381; 4681; 4946; 5183;
-              5398; 5594; 5774; 5941; 6096; 6241|]
-   | 22 -> [|0; 0; 1490; 2361; 2979; 3459; 3850; 4182; 4468; 4722; 4948;
-              5153; 5340; 5512; 5671; 5819; 5958|]
-   | 23 -> [|0; 0; 1425; 2258; 2850; 3308; 3683; 4000; 4274; 4516; 4733;
-              4929; 5108; 5272; 5424; 5566; 5699|]
-   | 24 -> [|0; 0; 1366; 2164; 2731; 3170; 3530; 3833; 4096; 4328; 4536;
-              4723; 4895; 5052; 5198; 5334; 5461|]
-   | 25 -> [|0; 0; 1311; 2078; 2622; 3044; 3388; 3680; 3932; 4155; 4354;
-              4534; 4699; 4850; 4990; 5121; 5243|]
-   | 26 -> [|0; 0; 1261; 1998; 2521; 2927; 3258; 3538; 3781; 3995; 4187;
-              4360; 4518; 4664; 4798; 4924; 5041|]
-   | 27 -> [|0; 0; 1214; 1924; 2428; 2818; 3137; 3407; 3641; 3847; 4032;
-              4199; 4351; 4491; 4621; 4742; 4855|]
-   | 28 -> [|0; 0; 1171; 1855; 2341; 2718; 3025; 3286; 3511; 3710; 3888;
-              4049; 4196; 4331; 4456; 4572; 4681|]
-   | 29 -> [|0; 0; 1130; 1791; 2260; 2624; 2921; 3172; 3390; 3582; 3754;
-              3909; 4051; 4181; 4302; 4415; 4520|]
-   | 30 -> [|0; 0; 1093; 1732; 2185; 2536; 2824; 3067; 3277; 3463; 3629;
-              3779; 3916; 4042; 4159; 4267; 4369|]
-   | 31 -> [|0; 0; 1057; 1676; 2114; 2455; 2733; 2968; 3171; 3351; 3512;
-              3657; 3790; 3912; 4025; 4130; 4228|]
-*)
-   | 32 -> [|0; 0; 1024; 1623; 2048; 2378; 2647; 2875; 3072; 3246; 3402;
-              3543; 3671; 3789; 3899; 4001; 4096|]
-   | n -> failwith "num_digits_max_vector"
-******)
-
-let unadjusted_string_of_nat nat off len_nat =
-  let len = num_digits_nat nat off len_nat in
-  if len = 1 then
-       raw_string_of_digit nat off
-  else
-       let len_copy = ref (succ len) in
-       let copy1 = create_nat !len_copy
-       and copy2 = make_nat !len_copy
-       and rest_digit = make_nat 2 in
-         if len > biggest_int / (succ pmax)
-            then failwith "number too long"
-            else let len_s = (succ pmax) * len in
-                 let s = Bytes.make len_s '0'
-                 and pos_ref = ref len_s in
-                   len_copy := pred !len_copy;
-                   blit_nat copy1 0 nat off len;
-                   set_digit_nat copy1 len 0;
-                   while not (is_zero_nat copy1 0 !len_copy) do
-                      div_digit_nat copy2 0
-                                     rest_digit 0
-                                     copy1 0 (succ !len_copy)
-                                     power_base_max 0;
-                      let str = raw_string_of_digit rest_digit 0 in
-                      String.blit str 0
-                                  s (!pos_ref - String.length str)
-                                  (String.length str);
-                      pos_ref := !pos_ref - pmax;
-                      len_copy := num_digits_nat copy2 0 !len_copy;
-                      blit_nat copy1 0 copy2 0 !len_copy;
-                      set_digit_nat copy1 !len_copy 0
-                   done;
-                   Bytes.unsafe_to_string s
-
-let string_of_nat nat =
-  let s = unadjusted_string_of_nat nat 0 (length_nat nat)
-  and index = ref 0 in
-    begin try
-      for i = 0 to String.length s - 2 do
-       if String.get s i <> '0' then (index:= i; raise Exit)
-      done
-    with Exit -> ()
-    end;
-    String.sub s !index (String.length s - !index)
-
-let base_digit_of_char c base =
-  let n = Char.code c in
-    if n >= 48 && n <= 47 + min base 10 then n - 48
-    else if n >= 65 && n <= 65 + base - 11 then n - 55
-    else if n >= 97 && n <= 97 + base - 11 then n - 87
-    else failwith "invalid digit"
-
-(*
-   The substring (s, off, len) represents a nat in base 'base' which is
-determined here
-*)
-let sys_nat_of_string base s off len =
-  let power_base = make_nat (succ length_of_digit) in
-  let (pmax, pint) = make_power_base base power_base in
-  let new_len = ref (1 + len / (pmax + 1))
-  and current_len = ref 1 in
-  let possible_len = ref (min 2 !new_len) in
-
-  let nat1 = make_nat !new_len
-  and nat2 = make_nat !new_len
-
-  and digits_read = ref 0
-  and bound = off + len - 1
-  and int = ref 0 in
-
-  for i = off to bound do
-    (*
-       we read (at most) pint digits, we transform them in a int
-       and integrate it to the number
-     *)
-      let c = String.get s i  in
-        begin match c with
-          ' ' | '\t' | '\n' | '\r' | '\\' -> ()
-        | '_' when i > off -> ()
-        | _ -> int := !int * base + base_digit_of_char c base;
-               incr digits_read
-        end;
-        if (!digits_read = pint || i = bound) && not (!digits_read = 0) then
-          begin
-           set_digit_nat nat1 0 !int;
-           let erase_len = if !new_len = !current_len then !current_len - 1
-                           else !current_len in
-           for j = 1 to erase_len do
-             set_digit_nat nat1 j 0
-           done;
-           ignore
-             (mult_digit_nat nat1 0 !possible_len
-                nat2 0 !current_len power_base (pred !digits_read));
-           blit_nat nat2 0 nat1 0 !possible_len;
-           current_len := num_digits_nat nat1 0 !possible_len;
-           possible_len := min !new_len (succ !current_len);
-           int := 0;
-           digits_read := 0
-           end
-  done;
-  (*
-     We reframe nat
-  *)
-  let nat = create_nat !current_len in
-    blit_nat nat 0 nat1 0 !current_len;
-    nat
-
-let nat_of_string s = sys_nat_of_string 10 s 0 (String.length s)
-
-let float_of_nat nat = float_of_string(string_of_nat nat)

diff --git a/otherlibs/num/nat.mli b/otherlibs/num/nat.mli
deleted file mode 100644 (file)
index 803a653..0000000
--- a/otherlibs/num/nat.mli
+++ /dev/null
@@ -1,89 +0,0 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                 OCaml                                  *)
-(*                                                                        *)
-(*     Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt       *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
-(* Module [Nat]: operations on natural numbers *)
-
-type nat
-
-(* Natural numbers (type [nat]) are positive integers of arbitrary size.
-   All operations on [nat] are performed in-place. *)
-
-external create_nat: int -> nat = "create_nat"
-val make_nat: int -> nat
-external set_to_zero_nat: nat -> int -> int -> unit = "set_to_zero_nat"
-external blit_nat: nat -> int -> nat -> int -> int -> unit = "blit_nat"
-val copy_nat: nat -> int -> int -> nat
-external set_digit_nat: nat -> int -> int -> unit = "set_digit_nat"
-external nth_digit_nat: nat -> int -> int = "nth_digit_nat"
-external set_digit_nat_native: nat -> int -> nativeint -> unit
-                             = "set_digit_nat_native"
-external nth_digit_nat_native: nat -> int -> nativeint = "nth_digit_nat_native"
-val length_nat : nat -> int
-external num_digits_nat: nat -> int -> int -> int = "num_digits_nat"
-external num_leading_zero_bits_in_digit: nat -> int -> int
-                                       = "num_leading_zero_bits_in_digit"
-external is_digit_int: nat -> int -> bool = "is_digit_int"
-external is_digit_zero: nat -> int -> bool = "is_digit_zero"
-external is_digit_normalized: nat -> int -> bool = "is_digit_normalized"
-external is_digit_odd: nat -> int -> bool = "is_digit_odd"
-val is_zero_nat: nat -> int -> int -> bool
-val is_nat_int: nat -> int -> int -> bool
-val int_of_nat: nat -> int
-val nat_of_int: int -> nat
-external incr_nat: nat -> int -> int -> int -> int = "incr_nat"
-external add_nat: nat -> int -> int -> nat -> int -> int -> int -> int
-                = "add_nat" "add_nat_native"
-external complement_nat: nat -> int -> int -> unit = "complement_nat"
-external decr_nat: nat -> int -> int -> int -> int = "decr_nat"
-external sub_nat: nat -> int -> int -> nat -> int -> int -> int -> int
-                = "sub_nat" "sub_nat_native"
-external mult_digit_nat:
-    nat -> int -> int -> nat -> int -> int -> nat -> int -> int
-  = "mult_digit_nat" "mult_digit_nat_native"
-external mult_nat:
-    nat -> int -> int -> nat -> int -> int -> nat -> int -> int -> int
-  = "mult_nat" "mult_nat_native"
-external square_nat: nat -> int -> int -> nat -> int -> int -> int
-                   = "square_nat" "square_nat_native"
-external shift_left_nat: nat -> int -> int -> nat -> int -> int -> unit
-                       = "shift_left_nat" "shift_left_nat_native"
-external div_digit_nat:
-    nat -> int -> nat -> int -> nat -> int -> int -> nat -> int -> unit
-  = "div_digit_nat" "div_digit_nat_native"
-external div_nat: nat -> int -> int -> nat -> int -> int -> unit
-                = "div_nat" "div_nat_native"
-external shift_right_nat: nat -> int -> int -> nat -> int -> int -> unit
-                        = "shift_right_nat" "shift_right_nat_native"
-external compare_digits_nat: nat -> int -> nat -> int -> int
-                           = "compare_digits_nat"
-external compare_nat: nat -> int -> int -> nat -> int -> int -> int
-                    = "compare_nat" "compare_nat_native"
-val eq_nat : nat -> int -> int -> nat -> int -> int -> bool
-val le_nat : nat -> int -> int -> nat -> int -> int -> bool
-val lt_nat : nat -> int -> int -> nat -> int -> int -> bool
-val ge_nat : nat -> int -> int -> nat -> int -> int -> bool
-val gt_nat : nat -> int -> int -> nat -> int -> int -> bool
-external land_digit_nat: nat -> int -> nat -> int -> unit = "land_digit_nat"
-external lor_digit_nat: nat -> int -> nat -> int -> unit = "lor_digit_nat"
-external lxor_digit_nat: nat -> int -> nat -> int -> unit = "lxor_digit_nat"
-val gcd_nat : nat -> int -> int -> nat -> int -> int -> int
-val sqrt_nat : nat -> int -> int -> nat
-val string_of_nat : nat -> string
-val nat_of_string : string -> nat
-val sys_nat_of_string : int -> string -> int -> int -> nat
-val float_of_nat : nat -> float
-val make_power_base :  int -> nat -> int * int
-val power_base_int : int -> int -> nat
-val length_of_digit: int

diff --git a/otherlibs/num/nat_stubs.c b/otherlibs/num/nat_stubs.c
deleted file mode 100644 (file)
index 5a07a80..0000000
--- a/otherlibs/num/nat_stubs.c
+++ /dev/null
@@ -1,421 +0,0 @@
-/**************************************************************************/
-/*                                                                        */
-/*                                 OCaml                                  */
-/*                                                                        */
-/*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           */
-/*                                                                        */
-/*   Copyright 1996 Institut National de Recherche en Informatique et     */
-/*     en Automatique.                                                    */
-/*                                                                        */
-/*   All rights reserved.  This file is distributed under the terms of    */
-/*   the GNU Lesser General Public License version 2.1, with the          */
-/*   special exception on linking described in the file LICENSE.          */
-/*                                                                        */
-/**************************************************************************/
-
-#define CAML_INTERNALS
-
-#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"
-
-/* Stub code for the Nat module. */
-
-static intnat hash_nat(value);
-static void serialize_nat(value, uintnat *, uintnat *);
-static uintnat deserialize_nat(void * dst);
-
-static struct custom_operations nat_operations = {
-  "_nat",
-  custom_finalize_default,
-  custom_compare_default,
-  hash_nat,
-  serialize_nat,
-  deserialize_nat,
-  custom_compare_ext_default
-};
-
-CAMLprim value initialize_nat(value unit)
-{
-  bng_init();
-  caml_register_custom_operations(&nat_operations);
-  return Val_unit;
-}
-
-CAMLprim value create_nat(value size)
-{
-  mlsize_t sz = Long_val(size);
-
-  return caml_alloc_custom(&nat_operations, sz * sizeof(value), 0, 1);
-}
-
-CAMLprim value length_nat(value nat)
-{
-  return Val_long(Wosize_val(nat) - 1);
-}
-
-CAMLprim value set_to_zero_nat(value nat, value ofs, value len)
-{
-  bng_zero(&Digit_val(nat, Long_val(ofs)), Long_val(len));
-  return Val_unit;
-}
-
-CAMLprim value blit_nat(value nat1, value ofs1,
-                        value nat2, value ofs2,
-                        value len)
-{
-  bng_assign(&Digit_val(nat1, Long_val(ofs1)),
-             &Digit_val(nat2, Long_val(ofs2)),
-             Long_val(len));
-  return Val_unit;
-}
-
-CAMLprim value set_digit_nat(value nat, value ofs, value digit)
-{
-  Digit_val(nat, Long_val(ofs)) = Long_val(digit);
-  return Val_unit;
-}
-
-CAMLprim value nth_digit_nat(value nat, value ofs)
-{
-  return Val_long(Digit_val(nat, Long_val(ofs)));
-}
-
-CAMLprim value set_digit_nat_native(value nat, value ofs, value digit)
-{
-  Digit_val(nat, Long_val(ofs)) = Nativeint_val(digit);
-  return Val_unit;
-}
-
-CAMLprim value nth_digit_nat_native(value nat, value ofs)
-{
-  return caml_copy_nativeint(Digit_val(nat, Long_val(ofs)));
-}
-
-CAMLprim value num_digits_nat(value nat, value ofs, value len)
-{
-  return Val_long(bng_num_digits(&Digit_val(nat, Long_val(ofs)),
-                                 Long_val(len)));
-}
-
-CAMLprim value num_leading_zero_bits_in_digit(value nat, value ofs)
-{
-  return
-    Val_long(bng_leading_zero_bits(Digit_val(nat, Long_val(ofs))));
-}
-
-CAMLprim value is_digit_int(value nat, value ofs)
-{
-  return Val_bool(Digit_val(nat, Long_val(ofs)) <= Max_long);
-}
-
-CAMLprim value is_digit_zero(value nat, value ofs)
-{
-  return Val_bool(Digit_val(nat, Long_val(ofs)) == 0);
-}
-
-CAMLprim value is_digit_normalized(value nat, value ofs)
-{
-  return
-    Val_bool(Digit_val(nat, Long_val(ofs))
-             & ((bngdigit)1 << (BNG_BITS_PER_DIGIT-1)));
-}
-
-CAMLprim value is_digit_odd(value nat, value ofs)
-{
-  return Val_bool(Digit_val(nat, Long_val(ofs)) & 1);
-}
-
-CAMLprim value incr_nat(value nat, value ofs, value len, value carry_in)
-{
-  return Val_long(bng_add_carry(&Digit_val(nat, Long_val(ofs)),
-                                Long_val(len), Long_val(carry_in)));
-}
-
-value add_nat_native(value nat1, value ofs1, value len1,
-                     value nat2, value ofs2, value len2, value carry_in)
-{
-  return Val_long(bng_add(&Digit_val(nat1, Long_val(ofs1)), Long_val(len1),
-                          &Digit_val(nat2, Long_val(ofs2)), Long_val(len2),
-                          Long_val(carry_in)));
-}
-
-CAMLprim value add_nat(value *argv, int argn)
-{
-  return add_nat_native(argv[0], argv[1], argv[2], argv[3],
-                        argv[4], argv[5], argv[6]);
-}
-
-CAMLprim value complement_nat(value nat, value ofs, value len)
-{
-  bng_complement(&Digit_val(nat, Long_val(ofs)), Long_val(len));
-  return Val_unit;
-}
-
-CAMLprim value decr_nat(value nat, value ofs, value len, value carry_in)
-{
-  return Val_long(1 ^ bng_sub_carry(&Digit_val(nat, Long_val(ofs)),
-                                    Long_val(len), 1 ^ Long_val(carry_in)));
-}
-
-value sub_nat_native(value nat1, value ofs1, value len1,
-                     value nat2, value ofs2, value len2, value carry_in)
-{
-  return Val_long(1 ^ bng_sub(&Digit_val(nat1, Long_val(ofs1)), Long_val(len1),
-                              &Digit_val(nat2, Long_val(ofs2)), Long_val(len2),
-                              1 ^ Long_val(carry_in)));
-}
-
-CAMLprim value sub_nat(value *argv, int argn)
-{
-  return sub_nat_native(argv[0], argv[1], argv[2], argv[3],
-                        argv[4], argv[5], argv[6]);
-}
-
-value mult_digit_nat_native(value nat1, value ofs1, value len1,
-                            value nat2, value ofs2, value len2,
-                            value nat3, value ofs3)
-{
-  return
-    Val_long(bng_mult_add_digit(
-                   &Digit_val(nat1, Long_val(ofs1)), Long_val(len1),
-                   &Digit_val(nat2, Long_val(ofs2)), Long_val(len2),
-                   Digit_val(nat3, Long_val(ofs3))));
-}
-
-CAMLprim value mult_digit_nat(value *argv, int argn)
-{
-  return mult_digit_nat_native(argv[0], argv[1], argv[2], argv[3],
-                               argv[4], argv[5], argv[6], argv[7]);
-}
-
-value mult_nat_native(value nat1, value ofs1, value len1,
-                      value nat2, value ofs2, value len2,
-                      value nat3, value ofs3, value len3)
-{
-  return
-    Val_long(bng_mult_add(&Digit_val(nat1, Long_val(ofs1)), Long_val(len1),
-                          &Digit_val(nat2, Long_val(ofs2)), Long_val(len2),
-                          &Digit_val(nat3, Long_val(ofs3)), Long_val(len3)));
-}
-
-CAMLprim value mult_nat(value *argv, int argn)
-{
-  return mult_nat_native(argv[0], argv[1], argv[2], argv[3],
-                         argv[4], argv[5], argv[6], argv[7], argv[8]);
-}
-
-value square_nat_native(value nat1, value ofs1, value len1,
-                        value nat2, value ofs2, value len2)
-{
-  return
-    Val_long(bng_square_add(&Digit_val(nat1, Long_val(ofs1)), Long_val(len1),
-                            &Digit_val(nat2, Long_val(ofs2)), Long_val(len2)));
-}
-
-CAMLprim value square_nat(value *argv, int argn)
-{
-  return square_nat_native(argv[0], argv[1], argv[2],
-                           argv[3], argv[4], argv[5]);
-}
-
-value shift_left_nat_native(value nat1, value ofs1, value len1,
-                            value nat2, value ofs2, value nbits)
-{
-  Digit_val(nat2, Long_val(ofs2)) =
-    bng_shift_left(&Digit_val(nat1, Long_val(ofs1)), Long_val(len1),
-                   Long_val(nbits));
-  return Val_unit;
-}
-
-CAMLprim value shift_left_nat(value *argv, int argn)
-{
-  return shift_left_nat_native(argv[0], argv[1], argv[2],
-                               argv[3], argv[4], argv[5]);
-}
-
-value div_digit_nat_native(value natq, value ofsq,
-                           value natr, value ofsr,
-                           value nat1, value ofs1, value len1,
-                           value nat2, value ofs2)
-{
-  Digit_val(natr, Long_val(ofsr)) =
-    bng_div_rem_digit(&Digit_val(natq, Long_val(ofsq)),
-                      &Digit_val(nat1, Long_val(ofs1)), Long_val(len1),
-                      Digit_val(nat2, Long_val(ofs2)));
-  return Val_unit;
-}
-
-CAMLprim value div_digit_nat(value *argv, int argn)
-{
-  return div_digit_nat_native(argv[0], argv[1], argv[2], argv[3],
-                              argv[4], argv[5], argv[6], argv[7], argv[8]);
-}
-
-value div_nat_native(value nat1, value ofs1, value len1,
-                     value nat2, value ofs2, value len2)
-{
-  bng_div_rem(&Digit_val(nat1, Long_val(ofs1)), Long_val(len1),
-              &Digit_val(nat2, Long_val(ofs2)), Long_val(len2));
-  return Val_unit;
-}
-
-CAMLprim value div_nat(value *argv, int argn)
-{
-  return div_nat_native(argv[0], argv[1], argv[2],
-                        argv[3], argv[4], argv[5]);
-}
-
-value shift_right_nat_native(value nat1, value ofs1, value len1,
-                             value nat2, value ofs2, value nbits)
-{
-  Digit_val(nat2, Long_val(ofs2)) =
-    bng_shift_right(&Digit_val(nat1, Long_val(ofs1)), Long_val(len1),
-                    Long_val(nbits));
-  return Val_unit;
-}
-
-CAMLprim value shift_right_nat(value *argv, int argn)
-{
-  return shift_right_nat_native(argv[0], argv[1], argv[2],
-                                argv[3], argv[4], argv[5]);
-}
-
-CAMLprim value compare_digits_nat(value nat1, value ofs1,
-                                  value nat2, value ofs2)
-{
-  bngdigit d1 = Digit_val(nat1, Long_val(ofs1));
-  bngdigit d2 = Digit_val(nat2, Long_val(ofs2));
-  if (d1 > d2) return Val_int(1);
-  if (d1 < d2) return Val_int(-1);
-  return Val_int(0);
-}
-
-value compare_nat_native(value nat1, value ofs1, value len1,
-                         value nat2, value ofs2, value len2)
-{
-  return
-    Val_int(bng_compare(&Digit_val(nat1, Long_val(ofs1)), Long_val(len1),
-                        &Digit_val(nat2, Long_val(ofs2)), Long_val(len2)));
-}
-
-CAMLprim value compare_nat(value *argv, int argn)
-{
-  return compare_nat_native(argv[0], argv[1], argv[2],
-                            argv[3], argv[4], argv[5]);
-}
-
-CAMLprim value land_digit_nat(value nat1, value ofs1, value nat2, value ofs2)
-{
-  Digit_val(nat1, Long_val(ofs1)) &= Digit_val(nat2, Long_val(ofs2));
-  return Val_unit;
-}
-
-CAMLprim value lor_digit_nat(value nat1, value ofs1, value nat2, value ofs2)
-{
-  Digit_val(nat1, Long_val(ofs1)) |= Digit_val(nat2, Long_val(ofs2));
-  return Val_unit;
-}
-
-CAMLprim value lxor_digit_nat(value nat1, value ofs1, value nat2, value ofs2)
-{
-  Digit_val(nat1, Long_val(ofs1)) ^= Digit_val(nat2, Long_val(ofs2));
-  return Val_unit;
-}
-
-/* The wire format for a nat is:
-   - 32-bit word: number of 32-bit words in nat
-   - N 32-bit words (big-endian format)
-   For little-endian platforms, the memory layout between 32-bit and 64-bit
-   machines is identical, so we can write the nat using caml_serialize_block_4.
-   For big-endian 64-bit platforms, we need to swap the two 32-bit halves
-   of 64-bit words to obtain the correct behavior. */
-
-static void serialize_nat(value nat,
-                          uintnat * wsize_32,
-                          uintnat * wsize_64)
-{
-  mlsize_t len = Wosize_val(nat) - 1;
-
-#ifdef ARCH_SIXTYFOUR
-  len = len * 2; /* two 32-bit words per 64-bit digit  */
-  if (len >= ((mlsize_t)1 << 32))
-    caml_failwith("output_value: nat too big");
-#endif
-  caml_serialize_int_4((int32_t) len);
-#if defined(ARCH_SIXTYFOUR) && defined(ARCH_BIG_ENDIAN)
-  { int32_t * p;
-    mlsize_t i;
-    for (i = len, p = Data_custom_val(nat); i > 0; i -= 2, p += 2) {
-      caml_serialize_int_4(p[1]);    /* low 32 bits of 64-bit digit */
-      caml_serialize_int_4(p[0]);    /* high 32 bits of 64-bit digit */
-    }
-  }
-#else
-  caml_serialize_block_4(Data_custom_val(nat), len);
-#endif
-  *wsize_32 = len * 4;
-  *wsize_64 = len * 4;
-}
-
-static uintnat deserialize_nat(void * dst)
-{
-  mlsize_t len;
-
-  len = caml_deserialize_uint_4();
-#if defined(ARCH_SIXTYFOUR) && defined(ARCH_BIG_ENDIAN)
-  { uint32_t * p;
-    mlsize_t i;
-    for (i = len, p = dst; i > 1; i -= 2, p += 2) {
-      p[1] = caml_deserialize_uint_4();   /* low 32 bits of 64-bit digit */
-      p[0] = caml_deserialize_uint_4();   /* high 32 bits of 64-bit digit */
-    }
-    if (i > 0){
-      p[1] = caml_deserialize_uint_4();   /* low 32 bits of 64-bit digit */
-      p[0] = 0;                      /* high 32 bits of 64-bit digit */
-      ++ len;
-    }
-  }
-#else
-  caml_deserialize_block_4(dst, len);
-#if defined(ARCH_SIXTYFOUR)
-  if (len & 1){
-    ((uint32_t *) dst)[len] = 0;
-    ++ len;
-  }
-#endif
-#endif
-  return len * 4;
-}
-
-static intnat hash_nat(value v)
-{
-  bngsize len, i;
-  uint32_t h;
-
-  len = bng_num_digits(&Digit_val(v,0), Wosize_val(v) - 1);
-  h = 0;
-  for (i = 0; i < len; i++) {
-    bngdigit d = Digit_val(v, i);
-#ifdef ARCH_SIXTYFOUR
-    /* Mix the two 32-bit halves as if we were on a 32-bit platform,
-       namely low 32 bits first, then high 32 bits.
-       Also, ignore final 32 bits if they are zero. */
-    h = caml_hash_mix_uint32(h, (uint32_t) d);
-    d = d >> 32;
-    if (d == 0 && i + 1 == len) break;
-    h = caml_hash_mix_uint32(h, (uint32_t) d);
-#else
-    h = caml_hash_mix_uint32(h, d);
-#endif
-  }
-  return h;
-}

diff --git a/otherlibs/num/num.ml b/otherlibs/num/num.ml
deleted file mode 100644 (file)
index 46b70a1..0000000
--- a/otherlibs/num/num.ml
+++ /dev/null
@@ -1,450 +0,0 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                 OCaml                                  *)
-(*                                                                        *)
-(*     Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt       *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
-open Int_misc
-open Nat
-open Big_int
-open Arith_flags
-open Ratio
-
-type num = Int of int | Big_int of big_int | Ratio of ratio
-        (* The type of numbers. *)
-
-let biggest_INT = big_int_of_int biggest_int
-and least_INT = big_int_of_int least_int
-
-(* Coercion big_int -> num *)
-let num_of_big_int bi =
- if le_big_int bi biggest_INT && ge_big_int bi least_INT
- then Int (int_of_big_int bi)
- else Big_int bi
-
-let normalize_num = function
-  Int i -> Int i
-| Big_int bi -> num_of_big_int bi
-| Ratio r -> if is_integer_ratio r
-              then num_of_big_int (numerator_ratio r)
-              else Ratio r
-
-let cautious_normalize_num_when_printing n =
- if (!normalize_ratio_when_printing_flag) then (normalize_num n) else n
-
-let num_of_ratio r =
- ignore (normalize_ratio r);
- if not (is_integer_ratio r) then Ratio r
- else if is_int_big_int (numerator_ratio r) then
-        Int (int_of_big_int (numerator_ratio r))
- else Big_int (numerator_ratio r)
-
-(* Operations on num *)
-
-let add_num a b = match (a,b) with
-    ((Int int1), (Int int2)) ->
-      let r =  int1 + int2 in
-      if (int1 lxor int2) lor (int1 lxor (r lxor (-1))) < 0
-      then Int r                        (* No overflow *)
-      else Big_int(add_big_int (big_int_of_int int1) (big_int_of_int int2))
-  | ((Int i), (Big_int bi)) ->
-      num_of_big_int (add_int_big_int i bi)
-  | ((Big_int bi), (Int i)) ->
-      num_of_big_int (add_int_big_int i bi)
-
-  | ((Int i), (Ratio r)) ->
-      Ratio (add_int_ratio i r)
-  | ((Ratio r), (Int i)) ->
-      Ratio (add_int_ratio i r)
-
-  | ((Big_int bi1), (Big_int bi2)) -> num_of_big_int (add_big_int bi1 bi2)
-
-  | ((Big_int bi), (Ratio r)) ->
-      Ratio (add_big_int_ratio bi r)
-  | ((Ratio r), (Big_int bi)) ->
-      Ratio (add_big_int_ratio bi r)
-
-  | ((Ratio r1), (Ratio r2)) -> num_of_ratio (add_ratio r1 r2)
-
-let ( +/ ) = add_num
-
-let minus_num = function
-  Int i -> if i = monster_int
-              then Big_int (minus_big_int (big_int_of_int i))
-              else Int (-i)
-| Big_int bi -> Big_int (minus_big_int bi)
-| Ratio r -> Ratio (minus_ratio r)
-
-let sub_num n1 n2 = add_num n1 (minus_num n2)
-
-let ( -/ ) = sub_num
-
-let mult_num a b = match (a,b) with
-   ((Int int1), (Int int2)) ->
-    if num_bits_int int1 + num_bits_int int2 < length_of_int
-       then Int (int1 * int2)
-       else num_of_big_int (mult_big_int (big_int_of_int int1)
-                                         (big_int_of_int int2))
-
- | ((Int i), (Big_int bi)) ->
-     num_of_big_int (mult_int_big_int i bi)
- | ((Big_int bi), (Int i)) ->
-     num_of_big_int (mult_int_big_int i bi)
-
- | ((Int i), (Ratio r)) ->
-     num_of_ratio (mult_int_ratio i r)
- | ((Ratio r), (Int i)) ->
-     num_of_ratio (mult_int_ratio i r)
-
- | ((Big_int bi1), (Big_int bi2)) ->
-     num_of_big_int (mult_big_int bi1 bi2)
-
- | ((Big_int bi), (Ratio r)) ->
-     num_of_ratio (mult_big_int_ratio bi r)
- | ((Ratio r), (Big_int bi)) ->
-     num_of_ratio (mult_big_int_ratio bi r)
-
- | ((Ratio r1), (Ratio r2)) ->
-     num_of_ratio (mult_ratio r1 r2)
-
-let ( */ ) = mult_num
-
-let square_num = function
-   Int i -> if 2 * num_bits_int i < length_of_int
-               then Int (i * i)
-               else num_of_big_int (square_big_int (big_int_of_int i))
- | Big_int bi -> Big_int (square_big_int bi)
- | Ratio r -> Ratio (square_ratio r)
-
-let div_num n1 n2 =
- match n1 with
- | Int i1 ->
-    begin match n2 with
-    | Int i2 ->
-       num_of_ratio (create_ratio (big_int_of_int i1) (big_int_of_int i2))
-    | Big_int bi2 -> num_of_ratio (create_ratio (big_int_of_int i1) bi2)
-    | Ratio r2 -> num_of_ratio (div_int_ratio i1 r2) end
-
- | Big_int bi1 ->
-     begin match n2 with
-     | Int i2 -> num_of_ratio (create_ratio bi1 (big_int_of_int i2))
-     | Big_int bi2 -> num_of_ratio (create_ratio bi1 bi2)
-     | Ratio r2 -> num_of_ratio (div_big_int_ratio bi1 r2) end
-
- | Ratio r1 ->
-     begin match n2 with
-     | Int i2 -> num_of_ratio (div_ratio_int r1 i2)
-     | Big_int bi2 -> num_of_ratio (div_ratio_big_int r1 bi2)
-     | Ratio r2 -> num_of_ratio (div_ratio r1 r2) end
-;;
-
-let ( // ) = div_num
-
-let floor_num = function
-  Int _ as n -> n
-| Big_int _ as n -> n
-| Ratio r -> num_of_big_int (floor_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
-;;
-
-(* Euclidean division and remainder.  The specification is:
-
-      a = b * quo_num a b + mod_num a b
-      quo_num a b is an integer (Z)
-      0 <= mod_num a b < |b|
-
-A correct but slow implementation is:
-
-      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)))
-
-      mod_num a b =
-        sub_num a (mult_num b (quo_num a b))
-
-  However, this definition is vastly inefficient (cf PR #3473):
-  we define here a better way of computing the same thing.
-
-  PR#6753: the previous implementation was based on
-    quo_num a b = floor_num (div_num a b)
-  which is incorrect for negative b.
-*)
-
-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) ->
-       (match sign_int n with
-           0 -> Int 1
-         | 1 -> num_of_big_int (power_int_positive_int i n)
-         | _ -> Ratio (create_normalized_ratio
-                        unit_big_int (power_int_positive_int i (-n))))
-| ((Big_int bi), n) ->
-       (match sign_int n with
-           0 -> Int 1
-         | 1 -> num_of_big_int (power_big_int_positive_int bi n)
-         | _ -> Ratio (create_normalized_ratio
-                 unit_big_int (power_big_int_positive_int bi (-n))))
-| ((Ratio r), n) ->
-       (match sign_int n with
-           0 -> Int 1
-         | 1 -> Ratio (power_ratio_positive_int r n)
-         | _ -> Ratio (power_ratio_positive_int
-                         (inverse_ratio r) (-n)))
-
-let power_num_big_int a b =  match (a,b) with
-   ((Int i), n) ->
-    (match sign_big_int n with
-           0 -> Int 1
-         | 1 -> num_of_big_int (power_int_positive_big_int i n)
-         | _ -> Ratio (create_normalized_ratio
-                         unit_big_int
-                         (power_int_positive_big_int i (minus_big_int n))))
-| ((Big_int bi), n) ->
-       (match sign_big_int n with
-           0 -> Int 1
-         | 1 -> num_of_big_int (power_big_int_positive_big_int bi n)
-         | _ -> Ratio (create_normalized_ratio
-                         unit_big_int
-                         (power_big_int_positive_big_int bi (minus_big_int n))))
-| ((Ratio r), n) ->
-       (match sign_big_int n with
-           0 -> Int 1
-         | 1 -> Ratio (power_ratio_positive_big_int r n)
-         | _ -> Ratio (power_ratio_positive_big_int
-                         (inverse_ratio r) (minus_big_int n)))
-
-let power_num a b = match (a,b) with
-  (n, (Int i)) -> power_num_int n i
-| (n, (Big_int bi)) -> power_num_big_int n bi
-| _ -> invalid_arg "power_num"
-
-let ( **/ ) = power_num
-
-let is_integer_num = function
-  Int _     -> true
-| Big_int _ -> true
-| Ratio r   -> is_integer_ratio r
-
-(* integer_num, floor_num, round_num, ceiling_num rendent des nums *)
-let integer_num = function
-  Int _ as n -> n
-| Big_int _ as n -> n
-| Ratio r -> num_of_big_int (integer_ratio r)
-
-and round_num = function
-  Int _ as n -> n
-| Big_int _ as n -> n
-| Ratio r -> num_of_big_int (round_ratio r)
-
-and ceiling_num = function
-  Int _ as n -> n
-| Big_int _ as n -> n
-| Ratio r -> num_of_big_int (ceiling_ratio r)
-
-(* Comparisons on nums *)
-
-let sign_num = function
-  Int i -> sign_int i
-| Big_int bi -> sign_big_int bi
-| Ratio r -> sign_ratio r
-
-let eq_num a b = match (a,b) with
-  ((Int int1), (Int int2)) -> int1 = int2
-
-| ((Int i), (Big_int bi)) -> eq_big_int (big_int_of_int i) bi
-| ((Big_int bi), (Int i)) -> eq_big_int (big_int_of_int i) bi
-
-| ((Int i), (Ratio r)) -> eq_big_int_ratio (big_int_of_int i) r
-| ((Ratio r), (Int i)) -> eq_big_int_ratio (big_int_of_int i) r
-
-| ((Big_int bi1), (Big_int bi2)) -> eq_big_int bi1 bi2
-
-| ((Big_int bi), (Ratio r)) -> eq_big_int_ratio bi r
-| ((Ratio r), (Big_int bi)) -> eq_big_int_ratio bi r
-
-| ((Ratio r1), (Ratio r2)) -> eq_ratio r1 r2
-
-let ( =/ ) = eq_num
-
-let ( <>/ ) a b = not(eq_num a b)
-
-let compare_num a b = match (a,b) with
-  ((Int int1), (Int int2)) -> compare_int int1 int2
-
-| ((Int i), (Big_int bi)) -> compare_big_int (big_int_of_int i) bi
-| ((Big_int bi), (Int i)) -> compare_big_int bi (big_int_of_int i)
-
-| ((Int i), (Ratio r)) -> compare_big_int_ratio (big_int_of_int i) r
-| ((Ratio r), (Int i)) -> -(compare_big_int_ratio (big_int_of_int i) r)
-
-| ((Big_int bi1), (Big_int bi2)) -> compare_big_int bi1 bi2
-
-| ((Big_int bi), (Ratio r)) -> compare_big_int_ratio bi r
-| ((Ratio r), (Big_int bi)) -> -(compare_big_int_ratio bi r)
-
-| ((Ratio r1), (Ratio r2)) -> compare_ratio r1 r2
-
-let lt_num num1 num2 = compare_num num1 num2 < 0
-and le_num num1 num2 = compare_num num1 num2 <= 0
-and gt_num num1 num2 = compare_num num1 num2 > 0
-and ge_num num1 num2 = compare_num num1 num2 >= 0
-
-let ( </ ) = lt_num
-and ( <=/ ) = le_num
-and ( >/ ) = gt_num
-and ( >=/ ) = ge_num
-
-let max_num num1 num2 = if lt_num num1 num2 then num2 else num1
-and min_num num1 num2 = if gt_num num1 num2 then num2 else num1
-
-(* Coercions with basic types *)
-
-(* Coercion with int type *)
-let int_of_num = function
-  Int i -> i
-| Big_int bi -> int_of_big_int bi
-| Ratio r -> int_of_ratio r
-
-let int_of_num_opt = function
-  Int i -> Some i
-| Big_int bi -> int_of_big_int_opt bi
-| Ratio r -> (try Some (int_of_ratio r) with Failure _ -> None)
-
-and num_of_int i =
-  if i = monster_int
-  then Big_int (big_int_of_int i)
-  else Int i
-
-(* Coercion with nat type *)
-let nat_of_num = function
-  Int i -> nat_of_int i
-| Big_int bi -> nat_of_big_int bi
-| Ratio r -> nat_of_ratio r
-
-and num_of_nat nat =
-  if (is_nat_int nat 0 (length_nat nat))
-  then Int (nth_digit_nat nat 0)
-  else Big_int (big_int_of_nat nat)
-
-let nat_of_num_opt x =
-  try Some (nat_of_num x) with Failure _ -> None
-
-(* Coercion with big_int type *)
-let big_int_of_num = function
-  Int i -> big_int_of_int i
-| Big_int bi -> bi
-| Ratio r -> big_int_of_ratio r
-
-let big_int_of_num_opt x =
-  try Some (big_int_of_num x) with Failure _ -> None
-
-let string_of_big_int_for_num bi =
-  if !approx_printing_flag
-     then approx_big_int !floating_precision bi
-     else string_of_big_int bi
-
-(* Coercion with string type *)
-
-let string_of_normalized_num = function
-  Int i -> string_of_int i
-| Big_int bi -> string_of_big_int_for_num bi
-| Ratio r -> string_of_ratio r
-let string_of_num n =
-    string_of_normalized_num (cautious_normalize_num_when_printing n)
-
-let num_of_string s =
-  try
-    let flag = !normalize_ratio_flag in
-    normalize_ratio_flag := true;
-    let r = ratio_of_string s in
-    normalize_ratio_flag := flag;
-    if eq_big_int (denominator_ratio r) unit_big_int
-    then num_of_big_int (numerator_ratio r)
-    else Ratio r
-  with Failure _ ->
-    failwith "num_of_string"
-
-let num_of_string_opt s =
-  try Some (num_of_string s) with Failure _ -> None
-
-(* Coercion with float type *)
-let float_of_num = function
-  Int i -> float i
-| Big_int bi -> float_of_big_int bi
-| Ratio r -> float_of_ratio r
-
-let succ_num = function
-  Int i -> if i = biggest_int
-              then Big_int (succ_big_int (big_int_of_int i))
-              else Int (succ i)
-| Big_int bi -> num_of_big_int (succ_big_int bi)
-| Ratio r -> Ratio (add_int_ratio 1 r)
-
-and pred_num = function
-  Int i -> if i = monster_int
-              then Big_int (pred_big_int (big_int_of_int i))
-              else Int (pred i)
-| Big_int bi -> num_of_big_int (pred_big_int bi)
-| Ratio r -> Ratio (add_int_ratio (-1) r)
-
-let abs_num = function
-   Int i -> if i = monster_int
-              then Big_int (minus_big_int (big_int_of_int i))
-              else Int (abs i)
- | Big_int bi -> Big_int (abs_big_int bi)
- | Ratio r -> Ratio (abs_ratio r)
-
-let approx_num_fix n num = approx_ratio_fix n (ratio_of_num num)
-and approx_num_exp n num = approx_ratio_exp n (ratio_of_num num)
-
-let incr_num r = r := succ_num !r
-and decr_num r = r := pred_num !r

diff --git a/otherlibs/num/num.mli b/otherlibs/num/num.mli
deleted file mode 100644 (file)
index 4d3793b..0000000
--- a/otherlibs/num/num.mli
+++ /dev/null
@@ -1,191 +0,0 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                 OCaml                                  *)
-(*                                                                        *)
-(*     Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt       *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
-(** Operation on arbitrary-precision numbers.
-
-   Numbers (type [num]) are arbitrary-precision rational numbers,
-   plus the special elements [1/0] (infinity) and [0/0] (undefined).
-*)
-
-open Nat
-open Big_int
-open Ratio
-
-(** The type of numbers. *)
-type num =
-    Int of int
-  | Big_int of big_int
-  | Ratio of ratio
-
-
-(** {6 Arithmetic operations} *)
-
-
-val ( +/ ) : num -> num -> num
-(** Same as {!Num.add_num}.*)
-
-val add_num : num -> num -> num
-(** Addition *)
-
-val minus_num : num -> num
-(** Unary negation. *)
-
-val ( -/ ) : num -> num -> num
-(** Same as {!Num.sub_num}.*)
-
-val sub_num : num -> num -> num
-(** Subtraction *)
-
-val ( */ ) : num -> num -> num
-(** Same as {!Num.mult_num}.*)
-
-val mult_num : num -> num -> num
-(** Multiplication *)
-
-val square_num : num -> num
-(** Squaring *)
-
-val ( // ) : num -> num -> num
-(** Same as {!Num.div_num}.*)
-
-val div_num : num -> num -> num
-(** Division *)
-
-val quo_num : num -> num -> num
-(** Euclidean division: quotient. *)
-
-val mod_num : num -> num -> num
-(** Euclidean division: remainder. *)
-
-val ( **/ ) : num -> num -> num
-(** Same as {!Num.power_num}. *)
-
-val power_num : num -> num -> num
-(** Exponentiation *)
-
-val abs_num : num -> num
-(** Absolute value. *)
-
-val succ_num : num -> num
-(** [succ n] is [n+1] *)
-
-val pred_num : num -> num
-(** [pred n] is [n-1] *)
-
-val incr_num : num ref -> unit
-(** [incr r] is [r:=!r+1], where [r] is a reference to a number. *)
-
-val decr_num : num ref -> unit
-(** [decr r] is [r:=!r-1], where [r] is a reference to a number. *)
-
-val is_integer_num : num -> bool
-(** Test if a number is an integer *)
-
-(** The four following functions approximate a number by an integer : *)
-
-val integer_num : num -> num
-(** [integer_num n] returns the integer closest to [n]. In case of ties,
-   rounds towards zero. *)
-
-val floor_num : num -> num
-(** [floor_num n] returns the largest integer smaller or equal to [n]. *)
-
-val round_num : num -> num
-(** [round_num n] returns the integer closest to [n]. In case of ties,
-   rounds off zero. *)
-
-val ceiling_num : num -> num
-(** [ceiling_num n] returns the smallest integer bigger or equal to [n]. *)
-
-
-val sign_num : num -> int
-(** Return [-1], [0] or [1] according to the sign of the argument. *)
-
-(** {7 Comparisons between numbers} *)
-
-val ( =/ ) : num -> num -> bool
-val ( </ ) : num -> num -> bool
-val ( >/ ) : num -> num -> bool
-val ( <=/ ) : num -> num -> bool
-val ( >=/ ) : num -> num -> bool
-val ( <>/ ) : num -> num -> bool
-val eq_num : num -> num -> bool
-val lt_num : num -> num -> bool
-val le_num : num -> num -> bool
-val gt_num : num -> num -> bool
-val ge_num : num -> num -> bool
-
-val compare_num : num -> num -> int
-(** Return [-1], [0] or [1] if the first argument is less than,
-   equal to, or greater than the second argument. *)
-
-val max_num : num -> num -> num
-(** Return the greater of the two arguments. *)
-
-val min_num : num -> num -> num
-(** Return the smaller of the two arguments. *)
-
-
-(** {6 Coercions with strings} *)
-
-val string_of_num : num -> string
-(** Convert a number to a string, using fractional notation. *)
-
-val approx_num_fix : int -> num -> string
-(** See {!Num.approx_num_exp}.*)
-
-val approx_num_exp : int -> num -> string
-(** Approximate a number by a decimal. The first argument is the
-   required precision. The second argument is the number to
-   approximate. {!Num.approx_num_fix} uses decimal notation; the first
-   argument is the number of digits after the decimal point.
-   [approx_num_exp] uses scientific (exponential) notation; the
-   first argument is the number of digits in the mantissa. *)
-
-val num_of_string : string -> num
-(** Convert a string to a number.
-   Raise [Failure "num_of_string"] if the given string is not
-   a valid representation of an integer *)
-
-val num_of_string_opt: string -> num option
-(** Convert a string to a number.
-    Return [None] if the given string is not
-    a valid representation of an integer.
-
-    @since 4.05
-*)
-
-(** {6 Coercions between numerical types} *)
-
-(* TODO: document the functions below (truncating behavior and error conditions). *)
-
-val int_of_num : num -> int
-val int_of_num_opt: num -> int option
-(** @since 4.05.0 *)
-
-val num_of_int : int -> num
-val nat_of_num : num -> nat
-val nat_of_num_opt: num -> nat option
-(** @since 4.05.0 *)
-
-val num_of_nat : nat -> num
-val num_of_big_int : big_int -> num
-val big_int_of_num : num -> big_int
-val big_int_of_num_opt: num -> big_int option
-(** @since 4.05.0 *)
-
-val ratio_of_num : num -> ratio
-val num_of_ratio : ratio -> num
-val float_of_num : num -> float

diff --git a/otherlibs/num/ratio.ml b/otherlibs/num/ratio.ml
deleted file mode 100644 (file)
index 04f9c5e..0000000
--- a/otherlibs/num/ratio.ml
+++ /dev/null
@@ -1,619 +0,0 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                 OCaml                                  *)
-(*                                                                        *)
-(*     Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt       *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
-open Int_misc
-open Nat
-open Big_int
-open Arith_flags
-
-(* Definition of the type ratio :
-   Conventions :
-   - the denominator is always a positive number
-   - the sign of n/0 is the sign of n
-These convention is automatically respected when a ratio is created with
-the create_ratio primitive
-*)
-
-type ratio = { mutable numerator : big_int;
-               mutable denominator : big_int;
-               mutable normalized : bool}
-
-let failwith_zero name =
-    let s = "infinite or undefined rational number" in
-    failwith (if String.length name = 0 then s else name ^ " " ^ s)
-
-let numerator_ratio r = r.numerator
-and denominator_ratio r = r.denominator
-
-let null_denominator r = sign_big_int r.denominator = 0
-
-let verify_null_denominator r =
-  if sign_big_int r.denominator = 0
-     then (if !error_when_null_denominator_flag
-           then (failwith_zero "")
-           else true)
-     else false
-
-let sign_ratio r = sign_big_int r.numerator
-
-(* Physical normalization of rational numbers *)
-(* 1/0, 0/0 and -1/0 are the normalized forms for n/0 numbers *)
-let normalize_ratio r =
-  if r.normalized then r
-  else if verify_null_denominator r then begin
-    r.numerator <- big_int_of_int (sign_big_int r.numerator);
-    r.normalized <- true;
-    r
-  end else begin
-    let p = gcd_big_int r.numerator r.denominator in
-    if eq_big_int p unit_big_int
-    then begin
-      r.normalized <- true; r
-    end else begin
-      r.numerator <- div_big_int (r.numerator) p;
-      r.denominator <- div_big_int (r.denominator) p;
-      r.normalized <- true; r
-    end
-  end
-
-let cautious_normalize_ratio r =
- if (!normalize_ratio_flag) then (normalize_ratio r) else r
-
-let cautious_normalize_ratio_when_printing r =
- if (!normalize_ratio_when_printing_flag) then (normalize_ratio r) else r
-
-let create_ratio bi1 bi2 =
- match sign_big_int bi2 with
-       -1 -> cautious_normalize_ratio
-               { numerator = minus_big_int bi1;
-                 denominator = minus_big_int bi2;
-                 normalized = false }
-     | 0 -> if !error_when_null_denominator_flag
-                then (failwith_zero "create_ratio")
-                else cautious_normalize_ratio
-                    { numerator = bi1; denominator = bi2; normalized = false }
-     | _ ->  cautious_normalize_ratio
-              { numerator = bi1; denominator = bi2; normalized = false }
-
-let create_normalized_ratio bi1 bi2 =
- match sign_big_int bi2 with
-  -1 -> { numerator = minus_big_int bi1;
-          denominator = minus_big_int bi2;
-          normalized = true }
-|  0 -> if !error_when_null_denominator_flag
-            then failwith_zero "create_normalized_ratio"
-            else { numerator = bi1; denominator = bi2; normalized = true }
-|  _  -> { numerator = bi1; denominator = bi2; normalized = true }
-
-let is_normalized_ratio r = r.normalized
-
-let report_sign_ratio r bi =
-  if sign_ratio r = -1
-  then minus_big_int bi
-  else bi
-
-let abs_ratio r =
- { numerator = abs_big_int r.numerator;
-   denominator = r.denominator;
-   normalized = r.normalized }
-
-let is_integer_ratio r =
- eq_big_int ((normalize_ratio r).denominator) unit_big_int
-
-(* Operations on rational numbers *)
-
-let add_ratio r1 r2 =
- if !normalize_ratio_flag then begin
-    let p = gcd_big_int ((normalize_ratio r1).denominator)
-                        ((normalize_ratio r2).denominator) in
-    if eq_big_int p unit_big_int then
-       {numerator = add_big_int (mult_big_int (r1.numerator) r2.denominator)
-                                (mult_big_int (r2.numerator) r1.denominator);
-        denominator = mult_big_int (r1.denominator) r2.denominator;
-        normalized = true}
-    else begin
-      let d1 = div_big_int (r1.denominator) p
-      and d2 = div_big_int (r2.denominator) p in
-      let n = add_big_int (mult_big_int (r1.numerator) d2)
-                          (mult_big_int d1 r2.numerator) in
-      let p' = gcd_big_int n p in
-        { numerator = div_big_int n p';
-          denominator = mult_big_int d1 (div_big_int (r2.denominator) p');
-          normalized = true }
-      end
- end else
-  { numerator = add_big_int (mult_big_int (r1.numerator) r2.denominator)
-                            (mult_big_int (r1.denominator) r2.numerator);
-    denominator = mult_big_int (r1.denominator) r2.denominator;
-    normalized = false }
-
-let minus_ratio r =
- { numerator = minus_big_int (r.numerator);
-   denominator = r.denominator;
-   normalized = r.normalized }
-
-let add_int_ratio i r =
-  ignore (cautious_normalize_ratio r);
-  { numerator = add_big_int (mult_int_big_int i r.denominator) r.numerator;
-    denominator = r.denominator;
-    normalized = r.normalized }
-
-let add_big_int_ratio bi r =
-  ignore (cautious_normalize_ratio r);
-  { numerator = add_big_int (mult_big_int bi r.denominator) r.numerator ;
-    denominator = r.denominator;
-    normalized = r.normalized }
-
-let sub_ratio r1 r2 = add_ratio r1 (minus_ratio r2)
-
-let mult_ratio r1 r2 =
- if !normalize_ratio_flag then begin
-   let p1 = gcd_big_int ((normalize_ratio r1).numerator)
-                        ((normalize_ratio r2).denominator)
-   and p2 = gcd_big_int (r2.numerator) r1.denominator in
-   let (n1, d2) =
-     if eq_big_int p1 unit_big_int
-         then (r1.numerator, r2.denominator)
-         else (div_big_int (r1.numerator) p1, div_big_int (r2.denominator) p1)
-   and (n2, d1) =
-      if eq_big_int p2 unit_big_int
-         then (r2.numerator, r1.denominator)
-         else (div_big_int r2.numerator p2, div_big_int r1.denominator p2) in
-    { numerator = mult_big_int n1 n2;
-      denominator = mult_big_int d1 d2;
-      normalized = true }
- end else
-  { numerator = mult_big_int (r1.numerator) r2.numerator;
-    denominator = mult_big_int (r1.denominator) r2.denominator;
-    normalized = false }
-
-let mult_int_ratio i r =
- if !normalize_ratio_flag then
-  begin
-   let p = gcd_big_int ((normalize_ratio r).denominator) (big_int_of_int i) in
-   if eq_big_int p unit_big_int
-      then { numerator = mult_big_int (big_int_of_int i) r.numerator;
-             denominator = r.denominator;
-             normalized = true }
-      else { numerator = mult_big_int (div_big_int (big_int_of_int i) p)
-                                      r.numerator;
-             denominator = div_big_int (r.denominator) p;
-             normalized = true }
-  end
- else
-  { numerator = mult_int_big_int i r.numerator;
-    denominator = r.denominator;
-    normalized = false }
-
-let mult_big_int_ratio bi r =
- if !normalize_ratio_flag then
-  begin
-   let p = gcd_big_int ((normalize_ratio r).denominator) bi in
-     if eq_big_int p unit_big_int
-        then { numerator = mult_big_int bi r.numerator;
-               denominator = r.denominator;
-               normalized = true }
-        else { numerator = mult_big_int (div_big_int bi p) r.numerator;
-               denominator = div_big_int (r.denominator) p;
-               normalized = true }
-  end
- else
-  { numerator = mult_big_int bi r.numerator;
-      denominator = r.denominator;
-      normalized = false }
-
-let square_ratio r =
-  ignore (cautious_normalize_ratio r);
-  { numerator = square_big_int r.numerator;
-    denominator = square_big_int r.denominator;
-    normalized = r.normalized }
-
-let inverse_ratio r =
-  if !error_when_null_denominator_flag && (sign_big_int r.numerator) = 0
-  then failwith_zero "inverse_ratio"
-  else {numerator = report_sign_ratio r r.denominator;
-        denominator = abs_big_int r.numerator;
-        normalized = r.normalized}
-
-let div_ratio r1 r2 =
-  mult_ratio r1 (inverse_ratio r2)
-
-(* Integer part of a rational number *)
-(* Odd function *)
-let integer_ratio r =
- if null_denominator r then failwith_zero "integer_ratio"
- else if sign_ratio r = 0 then zero_big_int
- else report_sign_ratio r (div_big_int (abs_big_int r.numerator)
-                                       (abs_big_int r.denominator))
-
-(* Floor of a rational number *)
-(* Always less or equal to r *)
-let floor_ratio r =
- ignore (verify_null_denominator r);
- div_big_int (r.numerator) r.denominator
-
-(* Round of a rational number *)
-(* Odd function, 1/2 -> 1 *)
-let round_ratio r =
- ignore (verify_null_denominator r);
-  let abs_num = abs_big_int r.numerator in
-   let bi = div_big_int abs_num r.denominator in
-    report_sign_ratio r
-     (if sign_big_int
-          (sub_big_int
-           (mult_int_big_int
-             2
-             (sub_big_int abs_num (mult_big_int (r.denominator) bi)))
-           r.denominator) = -1
-      then bi
-      else succ_big_int bi)
-
-let ceiling_ratio r =
- if (is_integer_ratio r)
- then r.numerator
- else succ_big_int (floor_ratio r)
-
-
-(* Comparison operators on rational numbers *)
-let eq_ratio r1 r2 =
- ignore (normalize_ratio r1);
- ignore (normalize_ratio r2);
- eq_big_int (r1.numerator) r2.numerator &&
- eq_big_int (r1.denominator) r2.denominator
-
-let compare_ratio r1 r2 =
-  if verify_null_denominator r1 then
-        let sign_num_r1 = sign_big_int r1.numerator in
-         if (verify_null_denominator r2)
-          then
-           let sign_num_r2 = sign_big_int r2.numerator in
-             if sign_num_r1 = 1 && sign_num_r2 = -1 then  1
-             else if sign_num_r1 = -1 && sign_num_r2 = 1 then -1
-             else 0
-         else sign_num_r1
-  else if verify_null_denominator r2 then
-          -(sign_big_int r2.numerator)
-  else match compare_int (sign_big_int r1.numerator)
-                         (sign_big_int r2.numerator) with
-               1 -> 1
-             | -1 -> -1
-             | _ -> if eq_big_int (r1.denominator) r2.denominator
-                    then compare_big_int (r1.numerator) r2.numerator
-                    else compare_big_int
-                            (mult_big_int (r1.numerator) r2.denominator)
-                            (mult_big_int (r1.denominator) r2.numerator)
-
-
-let lt_ratio r1 r2 = compare_ratio r1 r2 < 0
-and le_ratio r1 r2 = compare_ratio r1 r2 <= 0
-and gt_ratio r1 r2 = compare_ratio r1 r2 > 0
-and ge_ratio r1 r2 = compare_ratio r1 r2 >= 0
-
-let max_ratio r1 r2 = if lt_ratio r1 r2 then r2 else r1
-and min_ratio r1 r2 = if gt_ratio r1 r2 then r2 else r1
-
-let eq_big_int_ratio bi r =
- (is_integer_ratio r) && eq_big_int bi r.numerator
-
-let compare_big_int_ratio bi r =
- ignore (normalize_ratio r);
- if (verify_null_denominator r)
- then -(sign_big_int r.numerator)
- else compare_big_int (mult_big_int bi r.denominator) r.numerator
-
-let lt_big_int_ratio bi r = compare_big_int_ratio bi r < 0
-and le_big_int_ratio bi r = compare_big_int_ratio bi r <= 0
-and gt_big_int_ratio bi r = compare_big_int_ratio bi r > 0
-and ge_big_int_ratio bi r = compare_big_int_ratio bi r >= 0
-
-(* Coercions *)
-
-(* Coercions with type int *)
-let int_of_ratio r =
- if ((is_integer_ratio r) && (is_int_big_int r.numerator))
- then (int_of_big_int r.numerator)
- else failwith "integer argument required"
-
-and ratio_of_int i =
- { numerator = big_int_of_int i;
-   denominator = unit_big_int;
-   normalized = true }
-
-(* Coercions with type nat *)
-let ratio_of_nat nat =
- { numerator = big_int_of_nat nat;
-   denominator = unit_big_int;
-   normalized = true }
-
-and nat_of_ratio r =
- ignore (normalize_ratio r);
- if not (is_integer_ratio r) then
-          failwith "nat_of_ratio"
- else if sign_big_int r.numerator > -1 then
-         nat_of_big_int (r.numerator)
- else failwith "nat_of_ratio"
-
-(* Coercions with type big_int *)
-let ratio_of_big_int bi =
- { numerator = bi; denominator = unit_big_int; normalized = true }
-
-and big_int_of_ratio r =
- ignore (normalize_ratio r);
- if is_integer_ratio r
-  then r.numerator
- else failwith "big_int_of_ratio"
-
-let div_int_ratio i r =
-  ignore (verify_null_denominator r);
-  mult_int_ratio i (inverse_ratio r)
-
-let div_ratio_int r i =
-  div_ratio r (ratio_of_int i)
-
-let div_big_int_ratio bi r =
-  ignore (verify_null_denominator r);
-  mult_big_int_ratio bi (inverse_ratio r)
-
-let div_ratio_big_int r bi =
-  div_ratio r (ratio_of_big_int bi)
-
-(* Functions on type string                                 *)
-(* giving floating point approximations of rational numbers *)
-
-(* Compares strings that contains only digits, have the same length,
-   from index i to index i + l *)
-let rec compare_num_string s1 s2 i len =
- if i >= len then 0 else
- let c1 = int_of_char s1.[i]
- and c2 = int_of_char s2.[i] in
- match compare_int c1 c2 with
- | 0 -> compare_num_string s1 s2 (succ i) len
- | c -> c;;
-
-(* Position of the leading digit of the decimal expansion          *)
-(* of a strictly positive rational number                          *)
-(* if the decimal expansion of a non null rational r is equal to   *)
-(* sigma for k=-P to N of r_k*10^k then msd_ratio r = N            *)
-(* Nota : for a big_int we have msd_ratio = nums_digits_big_int -1 *)
-
-(* Tests if s has only zeros characters from index i to index lim *)
-let rec only_zeros s i lim =
- i >= lim || s.[i] == '0' && only_zeros s (succ i) lim;;
-
-(* Nota : for a big_int we have msd_ratio = nums_digits_big_int -1 *)
-let msd_ratio r =
- ignore (cautious_normalize_ratio r);
- if null_denominator r then failwith_zero "msd_ratio"
- else if sign_big_int r.numerator == 0 then 0
- else begin
-         let str_num = string_of_big_int r.numerator
-         and str_den = string_of_big_int r.denominator in
-         let size_num = String.length str_num
-         and size_den = String.length str_den in
-         let size_min = min size_num size_den in
-         let m = size_num - size_den in
-         let cmp = compare_num_string str_num str_den 0 size_min in
-         match cmp with
-         | 1 -> m
-         | -1 -> pred m
-         | _ ->
-           if m >= 0 then m else
-           if only_zeros str_den size_min size_den then m
-           else pred m
-      end
-;;
-
-(* Decimal approximations of rational numbers *)
-
-(* Approximation with fix decimal point *)
-(* This is an odd function and the last digit is round off *)
-(* Format integer_part . decimal_part_with_n_digits *)
-let approx_ratio_fix n r =
- (* Don't need to normalize *)
- if (null_denominator r) then failwith_zero "approx_ratio_fix"
- else
-  let sign_r = sign_ratio r in
-   if sign_r = 0
-   then "+0" (* r = 0 *)
-   else
-    (* r.numerator and r.denominator are not null numbers
-       s1 contains one more digit than desired for the round off operation *)
-     if n >= 0 then begin
-       let s1 =
-         string_of_nat
-           (nat_of_big_int
-                (div_big_int
-                   (base_power_big_int
-                       10 (succ n) (abs_big_int r.numerator))
-                   r.denominator)) in
-       (* Round up and add 1 in front if needed *)
-       let s2 =
-         if round_futur_last_digit (Bytes.unsafe_of_string s1) 0
-                                   (String.length s1)
-         then "1" ^ s1
-         else s1 in
-       let l2 = String.length s2 - 1 in
-       (*   if s2 without last digit is xxxxyyy with n 'yyy' digits:
-               <sign> xxxx . yyy
-            if s2 without last digit is      yy with <= n digits:
-               <sign> 0 . 0yy *)
-       if l2 > n then begin
-         let s = Bytes.make (l2 + 2) '0' in
-         Bytes.set s 0  (if sign_r = -1 then '-' else '+');
-         String.blit s2 0 s 1 (l2 - n);
-         Bytes.set s (l2 - n + 1) '.';
-         String.blit s2 (l2 - n) s (l2 - n + 2) n;
-         Bytes.unsafe_to_string s
-       end else begin
-         let s = Bytes.make (n + 3) '0' in
-         Bytes.set s 0  (if sign_r = -1 then '-' else '+');
-         Bytes.set s 2 '.';
-         String.blit s2 0 s (n + 3 - l2) l2;
-         Bytes.unsafe_to_string s
-       end
-     end else begin
-       (* Dubious; what is this code supposed to do? *)
-       let s = string_of_big_int
-                 (div_big_int
-                    (abs_big_int r.numerator)
-                    (base_power_big_int
-                      10 (-n) r.denominator)) in
-       let len = succ (String.length s) in
-       let s' = Bytes.make len '0' in
-        Bytes.set s' 0 (if sign_r = -1 then '-' else '+');
-        String.blit s 0 s' 1 (pred len);
-        Bytes.unsafe_to_string s'
-     end
-
-(* Number of digits of the decimal representation of an int *)
-let num_decimal_digits_int n =
-  String.length (string_of_int n)
-
-(* Approximation with floating decimal point *)
-(* This is an odd function and the last digit is round off *)
-(* Format (+/-)(0. n_first_digits e msd)/(1. n_zeros e (msd+1) *)
-let approx_ratio_exp n r =
- (* Don't need to normalize *)
- if (null_denominator r) then failwith_zero "approx_ratio_exp"
- else if n <= 0 then invalid_arg "approx_ratio_exp"
- else
-  let sign_r = sign_ratio r
-  and i = ref (n + 3) in
-   if sign_r = 0 then
-     String.concat "" ["+0."; String.make n '0'; "e0"]
-   else
-     let msd = msd_ratio (abs_ratio r) in
-     let k = n - msd in
-     let s =
-      (let nat = nat_of_big_int
-                (if k < 0
-                  then
-                   div_big_int (abs_big_int r.numerator)
-                               (base_power_big_int 10 (- k)
-                                                   r.denominator)
-                 else
-                  div_big_int (base_power_big_int
-                                10 k (abs_big_int r.numerator))
-                               r.denominator) in
-       string_of_nat nat) in
-     if round_futur_last_digit (Bytes.unsafe_of_string s) 0
-                               (String.length s)
-      then
-       let m = num_decimal_digits_int (succ msd) in
-       let str = Bytes.make (n + m + 4) '0' in
-         (String.blit (if sign_r = -1 then "-1." else "+1.") 0 str 0 3);
-         Bytes.set str !i ('e');
-         incr i;
-         (if m = 0
-          then Bytes.set str !i '0'
-          else String.blit (string_of_int (succ msd)) 0 str !i m);
-         Bytes.unsafe_to_string str
-     else
-      let m = num_decimal_digits_int (succ msd)
-      and p = n + 3 in
-      let str = Bytes.make (succ (m + p)) '0' in
-        (String.blit (if sign_r = -1 then "-0." else "+0.") 0 str 0 3);
-        (String.blit s 0 str 3 n);
-        Bytes.set str p 'e';
-        (if m = 0
-          then Bytes.set str (succ p) '0'
-          else (String.blit (string_of_int (succ msd)) 0 str (succ p) m));
-        Bytes.unsafe_to_string str
-
-(* String approximation of a rational with a fixed number of significant *)
-(* digits printed                                                        *)
-let float_of_rational_string r =
-  let s = approx_ratio_exp !floating_precision r in
-    if String.get s 0 = '+'
-       then (String.sub s 1 (pred (String.length s)))
-       else s
-
-(* Coercions with type string *)
-let string_of_ratio r =
- ignore (cautious_normalize_ratio_when_printing r);
- if !approx_printing_flag
-    then float_of_rational_string r
-    else string_of_big_int r.numerator ^ "/" ^ string_of_big_int r.denominator
-
-(* XL: j'ai puissamment simplifie "ratio_of_string" en virant la notation
-   scientifique.
-  | I have strongly simplified "ratio_of_string" by deleting scientific notation
-*)
-
-let ratio_of_string s =
-  try
-    let n = String.index s '/' in
-    create_ratio (sys_big_int_of_string s 0 n)
-                 (sys_big_int_of_string s (n+1) (String.length s - n - 1))
-  with Not_found ->
-    { numerator = big_int_of_string s;
-      denominator = unit_big_int;
-      normalized = true }
-
-(* Coercion with type float *)
-
-let float_of_ratio 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
-
-
-let power_ratio_positive_int r n =
-  create_ratio (power_big_int_positive_int (r.numerator) n)
-               (power_big_int_positive_int (r.denominator) n)
-
-let power_ratio_positive_big_int r bi =
-  create_ratio (power_big_int_positive_big_int (r.numerator) bi)
-               (power_big_int_positive_big_int (r.denominator) bi)

diff --git a/otherlibs/num/ratio.mli b/otherlibs/num/ratio.mli
deleted file mode 100644 (file)
index 4a76505..0000000
--- a/otherlibs/num/ratio.mli
+++ /dev/null
@@ -1,93 +0,0 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                 OCaml                                  *)
-(*                                                                        *)
-(*     Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt       *)
-(*                                                                        *)
-(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
-(** Operation on rational numbers.
-
-    This module is used to support the implementation of {!Num} and
-    should not be called directly. *)
-
-open Nat
-open Big_int
-
-(* Rationals (type [ratio]) are arbitrary-precision rational numbers,
-   plus the special elements [1/0] (infinity) and [0/0] (undefined).
-   In constrast with numbers (type [num]), the special cases of
-   small integers and big integers are not optimized specially. *)
-
-type ratio
-
-(**/**)
-
-val null_denominator : ratio -> bool
-val numerator_ratio : ratio -> big_int
-val denominator_ratio : ratio -> big_int
-val sign_ratio : ratio -> int
-val normalize_ratio : ratio -> ratio
-val cautious_normalize_ratio : ratio -> ratio
-val cautious_normalize_ratio_when_printing : ratio -> ratio
-val create_ratio : big_int -> big_int -> ratio (* assumes nothing *)
-val create_normalized_ratio : big_int -> big_int -> ratio
-                              (* assumes normalized argument *)
-val is_normalized_ratio : ratio -> bool
-val report_sign_ratio : ratio -> big_int -> big_int
-val abs_ratio : ratio -> ratio
-val is_integer_ratio : ratio -> bool
-val add_ratio : ratio -> ratio -> ratio
-val minus_ratio : ratio -> ratio
-val add_int_ratio : int -> ratio -> ratio
-val add_big_int_ratio : big_int -> ratio -> ratio
-val sub_ratio : ratio -> ratio -> ratio
-val mult_ratio : ratio -> ratio -> ratio
-val mult_int_ratio : int -> ratio -> ratio
-val mult_big_int_ratio : big_int -> ratio -> ratio
-val square_ratio : ratio -> ratio
-val inverse_ratio : ratio -> ratio
-val div_ratio : ratio -> ratio -> ratio
-val integer_ratio : ratio -> big_int
-val floor_ratio : ratio -> big_int
-val round_ratio : ratio -> big_int
-val ceiling_ratio : ratio -> big_int
-val eq_ratio : ratio -> ratio -> bool
-val compare_ratio : ratio -> ratio -> int
-val lt_ratio : ratio -> ratio -> bool
-val le_ratio : ratio -> ratio -> bool
-val gt_ratio : ratio -> ratio -> bool
-val ge_ratio : ratio -> ratio -> bool
-val max_ratio : ratio -> ratio -> ratio
-val min_ratio : ratio -> ratio -> ratio
-val eq_big_int_ratio : big_int -> ratio -> bool
-val compare_big_int_ratio : big_int -> ratio -> int
-val lt_big_int_ratio : big_int -> ratio -> bool
-val le_big_int_ratio : big_int -> ratio -> bool
-val gt_big_int_ratio : big_int -> ratio -> bool
-val ge_big_int_ratio : big_int -> ratio -> bool
-val int_of_ratio : ratio -> int
-val ratio_of_int : int -> ratio
-val ratio_of_nat : nat -> ratio
-val nat_of_ratio : ratio -> nat
-val ratio_of_big_int : big_int -> ratio
-val big_int_of_ratio : ratio -> big_int
-val div_int_ratio : int -> ratio -> ratio
-val div_ratio_int : ratio -> int -> ratio
-val div_big_int_ratio : big_int -> ratio -> ratio
-val div_ratio_big_int : ratio -> big_int -> ratio
-val approx_ratio_fix : int -> ratio -> string
-val approx_ratio_exp : int -> ratio -> string
-val float_of_rational_string : ratio -> string
-val string_of_ratio : ratio -> string
-val ratio_of_string : string -> ratio
-val float_of_ratio : ratio -> float
-val power_ratio_positive_int : ratio -> int -> ratio
-val power_ratio_positive_big_int : ratio -> big_int -> ratio

diff --git a/otherlibs/raw_spacetime_lib/.depend b/otherlibs/raw_spacetime_lib/.depend
index 99c90a4aae9c72bf0e3b424058405e63806567c5..18fc1804b25151ea21046d5fe3b6ae3db53fdea6 100644 (file)
--- a/otherlibs/raw_spacetime_lib/.depend
+++ b/otherlibs/raw_spacetime_lib/.depend
@@ -1,54 +1,3 @@
-aProf.cmi :
-camlinternalAProf.cmi :
-aProf.cmo : aProf.cmi
-aProf.cmx : aProf.cmi
-camlinternalAProf.cmo : camlinternalAProf.cmi
-camlinternalAProf.cmx : camlinternalAProf.cmi
-aProf.cmi :
-camlinternalAProf.cmi :
-aProf.cmo : camlinternalAProf.cmi aProf.cmi
-aProf.cmx : camlinternalAProf.cmx aProf.cmi
-camlinternalAProf.cmo : camlinternalAProf.cmi
-camlinternalAProf.cmx : camlinternalAProf.cmi
-aProf.cmi :
-rawAProf.cmi :
-aProf.cmo : aProf.cmi
-aProf.cmx : aProf.cmi
-rawAProf.cmo : rawAProf.cmi
-rawAProf.cmx : rawAProf.cmi
-aProf.cmo : rawAProf.cmi aProf.cmi
-aProf.cmx : rawAProf.cmx aProf.cmi
-aProf.cmi :
-rawAProf.cmo : rawAProf.cmi
-rawAProf.cmx : rawAProf.cmi
-rawAProf.cmi :
-raw_spacetime_lib.cmo : raw_spacetime_lib.cmi
-raw_spacetime_lib.cmx : raw_spacetime_lib.cmi
-raw_spacetime_lib.cmi :
-spacetime_lib.cmo : raw_spacetime_lib.cmi spacetime_lib.cmi
-spacetime_lib.cmx : raw_spacetime_lib.cmx spacetime_lib.cmi
-spacetime_lib.cmi :
-raw_spacetime_lib.cmo : raw_spacetime_lib.cmi
-raw_spacetime_lib.cmx : raw_spacetime_lib.cmi
-raw_spacetime_lib.cmi :
-raw_spacetime_lib.cmo : raw_spacetime_lib.cmi
-raw_spacetime_lib.cmx : raw_spacetime_lib.cmi
-raw_spacetime_lib.cmi :
-raw_spacetime_lib.cmo : raw_spacetime_lib.cmi
-raw_spacetime_lib.cmx : raw_spacetime_lib.cmi
-raw_spacetime_lib.cmi :
-raw_spacetime_lib.cmo : raw_spacetime_lib.cmi
-raw_spacetime_lib.cmx : raw_spacetime_lib.cmi
-raw_spacetime_lib.cmi :
-raw_spacetime_lib.cmo : raw_spacetime_lib.cmi
-raw_spacetime_lib.cmx : raw_spacetime_lib.cmi
-raw_spacetime_lib.cmi :
-raw_spacetime_lib.cmo : raw_spacetime_lib.cmi
-raw_spacetime_lib.cmx : raw_spacetime_lib.cmi
-raw_spacetime_lib.cmi :
-raw_spacetime_lib.cmo : raw_spacetime_lib.cmi
-raw_spacetime_lib.cmx : raw_spacetime_lib.cmi
-raw_spacetime_lib.cmi :
 raw_spacetime_lib.cmo : raw_spacetime_lib.cmi
 raw_spacetime_lib.cmx : raw_spacetime_lib.cmi
 raw_spacetime_lib.cmi :

diff --git a/otherlibs/raw_spacetime_lib/Makefile b/otherlibs/raw_spacetime_lib/Makefile
index 7e4bf2c7cdb63be30a17f52a37c29f27161190eb..4b40cabb68dff996089b47ee178e57e0608af068 100644 (file)
--- a/otherlibs/raw_spacetime_lib/Makefile
+++ b/otherlibs/raw_spacetime_lib/Makefile
@@ -22,7 +22,6 @@ CAMLRUN ?= $(ROOTDIR)/boot/ocamlrun
 CAMLC=$(CAMLRUN) $(ROOTDIR)/ocamlc -nostdlib -I $(ROOTDIR)/stdlib
 CAMLOPT=$(CAMLRUN) $(ROOTDIR)/ocamlopt -nostdlib \
         -I $(ROOTDIR)/stdlib
-CFLAGS=-I$(ROOTDIR)/byterun $(SHAREDCCCOMPOPTS) $(EXTRACFLAGS)
 
 # The remainder of this file could probably be simplified by including
 # ../Makefile.
@@ -30,7 +29,6 @@ CFLAGS=-I$(ROOTDIR)/byterun $(SHAREDCCCOMPOPTS) $(EXTRACFLAGS)
 LIBNAME=raw_spacetime_lib
 CAMLOBJS=raw_spacetime_lib.cmo
 
-CC=$(BYTECC)
 COMPFLAGS=-w +33..39 -warn-error A -bin-annot -g -safe-string $(EXTRACAMLFLAGS)
 
 CMIFILES=$(CAMLOBJS:.cmo=.cmi)
@@ -78,6 +76,6 @@ clean:: partialclean
        $(CAMLOPT) -c $(COMPFLAGS) $<
 
 depend:
-       $(CAMLRUN) $(ROOTDIR)/tools/ocamldep *.mli *.ml >> .depend
+       $(CAMLRUN) $(ROOTDIR)/tools/ocamldep *.mli *.ml > .depend
 
 include .depend

diff --git a/otherlibs/raw_spacetime_lib/raw_spacetime_lib.ml b/otherlibs/raw_spacetime_lib/raw_spacetime_lib.ml
index e1010a9f895733117476bffdc9fe35eaa31036d9..2592d39329cff23ff835361fea30244b05bea4d4 100644 (file)
--- a/otherlibs/raw_spacetime_lib/raw_spacetime_lib.ml
+++ b/otherlibs/raw_spacetime_lib/raw_spacetime_lib.ml
@@ -4,7 +4,7 @@
 (*                                                                        *)
 (*           Mark Shinwell and Leo White, Jane Street Europe              *)
 (*                                                                        *)
-(*   Copyright 2015--2016 Jane Street Group LLC                           *)
+(*   Copyright 2015--2017 Jane Street Group LLC                           *)
 (*                                                                        *)
 (*   All rights reserved.  This file is distributed under the terms of    *)
 (*   the GNU Lesser General Public License version 2.1, with the          *)
@@ -101,22 +101,31 @@ module Shape_table = struct
   let _ = Indirect_call 0L
   let _ = Allocation_point 0L
 
-  let part_of_shape_size = function
-    | Direct_call _
-    | Indirect_call _ -> 1
-    | Allocation_point _ -> 3
-
   type raw = (Int64.t * (part_of_shape list)) list
 
-  type t = part_of_shape list Int64_map.t
+  type t = {
+    shapes : part_of_shape list Int64_map.t;
+    call_counts : bool;
+  }
 
-  let demarshal chn : t =
+  let part_of_shape_size t = function
+    | Direct_call _ -> if t.call_counts then 2 else 1
+    | Indirect_call _ -> 1
+    | Allocation_point _ -> 3
+
+  let demarshal chn ~call_counts : t =
     let raw : raw = Marshal.from_channel chn in
-    List.fold_left (fun map (key, data) -> Int64_map.add key data map)
-      Int64_map.empty
-      raw
+    let shapes =
+      List.fold_left (fun map (key, data) -> Int64_map.add key data map)
+        Int64_map.empty
+        raw
+    in
+    { shapes;
+      call_counts;
+    }
 
-  let find_exn = Int64_map.find
+  let find_exn func_id t = Int64_map.find func_id t.shapes
+  let call_counts t = t.call_counts
 end
 
 module Annotation = struct
@@ -132,6 +141,7 @@ module Trace = struct
   type uninstrumented_node
 
   type t = node option
+  type trace = t
 
   (* This function unmarshals into malloc blocks, which mean that we
      obtain a straightforward means of writing [compare] on [node]s. *)
@@ -209,6 +219,16 @@ module Trace = struct
 
       let callee_node (type target) (t : target t) : target =
         callee_node t.node t.offset
+
+      external call_count : ocaml_node -> int -> int
+        = "caml_spacetime_only_works_for_native_code"
+          "caml_spacetime_ocaml_direct_call_point_call_count"
+
+      let call_count t =
+        if Shape_table.call_counts t.shape_table then
+          Some (call_count t.node t.offset)
+        else
+          None
     end
 
     module Indirect_call_point = struct
@@ -222,39 +242,59 @@ module Trace = struct
       module Callee = struct
         (* CR-soon mshinwell: we should think about the names again.  This is
            a "c_node" but it isn't foreign. *)
-        type t = foreign_node
+        type t = {
+          node : foreign_node;
+          call_counts : bool;
+        }
 
-        let is_null = foreign_node_is_null
+        let is_null t = foreign_node_is_null t.node
 
         (* CR-soon mshinwell: maybe rename ...c_node_call_site -> c_node_pc,
            since it isn't a call site in this case. *)
-        external callee : t -> Function_entry_point.t
+        external callee : foreign_node -> Function_entry_point.t
           = "caml_spacetime_only_works_for_native_code"
             "caml_spacetime_c_node_call_site"
 
+        let callee t = callee t.node
+
         (* This can return a node satisfying "is_null" in the case of an
            uninitialised tail call point.  See the comment in the C code. *)
-        external callee_node : t -> node
+        external callee_node : foreign_node -> node
           = "caml_spacetime_only_works_for_native_code"
             "caml_spacetime_c_node_callee_node" "noalloc"
 
-        external next : t -> foreign_node
+        let callee_node t = callee_node t.node
+
+        external call_count : foreign_node -> int
+          = "caml_spacetime_only_works_for_native_code"
+            "caml_spacetime_c_node_call_count"
+
+        let call_count t =
+          if t.call_counts then Some (call_count t.node)
+          else None
+
+        external next : foreign_node -> foreign_node
           = "caml_spacetime_only_works_for_native_code"
             "caml_spacetime_c_node_next" "noalloc"
 
         let next t =
-          let next = next t in
-          if foreign_node_is_null next then None
+          let next = { t with node = next t.node; } in
+          if foreign_node_is_null next.node then None
           else Some next
       end
 
-      external callees : ocaml_node -> int -> Callee.t
+      external callees : ocaml_node -> int -> foreign_node
         = "caml_spacetime_only_works_for_native_code"
           "caml_spacetime_ocaml_indirect_call_point_callees"
           "noalloc"
 
       let callees t =
-        let callees = callees t.node t.offset in
+        let callees =
+          { Callee.
+            node = callees t.node t.offset;
+            call_counts = Shape_table.call_counts t.shape_table;
+          }
+        in
         if Callee.is_null callees then None
         else Some callees
     end
@@ -317,7 +357,9 @@ module Trace = struct
         match t.remaining_layout with
         | [] -> None
         | part_of_shape::remaining_layout ->
-          let size = Shape_table.part_of_shape_size t.part_of_shape in
+          let size =
+            Shape_table.part_of_shape_size t.shape_table t.part_of_shape
+          in
           let offset = t.offset + size in
           assert (offset < Obj.size (Obj.repr t.node));
           let t =
@@ -351,7 +393,8 @@ module Trace = struct
           "caml_spacetime_compare_node" "noalloc"
 
       let fields t ~shape_table =
-        match Shape_table.find_exn (function_identifier t) shape_table with
+        let id = function_identifier t in
+        match Shape_table.find_exn id shape_table with
         | exception Not_found -> None
         | [] -> None
         | part_of_shape::remaining_layout ->
@@ -555,6 +598,7 @@ module Heap_snapshot = struct
       finaliser_traces_by_thread : Trace.t array;
       snapshots : heap_snapshot array;
       events : Event.t list;
+      call_counts : bool;
     }
 
     let pathname_suffix_trace = "trace"
@@ -586,17 +630,26 @@ module Heap_snapshot = struct
       let chn = open_in path in
       let magic_number : int = Marshal.from_channel chn in
       let magic_number_base = magic_number land 0xffff_ffff in
-      let version_number = magic_number lsr 32 in
+      let version_number = (magic_number lsr 32) land 0xffff in
+      let features = (magic_number lsr 48) land 0xffff in
       if magic_number_base <> 0xace00ace then begin
         failwith "Raw_spacetime_lib: not a Spacetime profiling file"
       end else begin
         match version_number with
         | 0 ->
+          let call_counts =
+            match features with
+            | 0 -> false
+            | 1 -> true
+            | _ ->
+              failwith "Raw_spacetime_lib: unknown Spacetime profiling file \
+                feature set"
+          in
           let snapshots, events = read_snapshots_and_events chn [] [] in
           let num_snapshots = Array.length snapshots in
           let time_of_writer_close : float = Marshal.from_channel chn in
           let frame_table = Frame_table.demarshal chn in
-          let shape_table = Shape_table.demarshal chn in
+          let shape_table = Shape_table.demarshal chn ~call_counts in
           let num_threads : int = Marshal.from_channel chn in
           let traces_by_thread = Array.init num_threads (fun _ -> None) in
           let finaliser_traces_by_thread =
@@ -617,6 +670,7 @@ module Heap_snapshot = struct
             finaliser_traces_by_thread;
             snapshots;
             events;
+            call_counts;
           }
         | _ ->
           failwith "Raw_spacetime_lib: unknown Spacetime profiling file \
@@ -640,5 +694,6 @@ module Heap_snapshot = struct
     let shape_table t = t.shape_table
     let time_of_writer_close t = t.time_of_writer_close
     let events t = t.events
+    let has_call_counts t = t.call_counts
   end
 end

diff --git a/otherlibs/raw_spacetime_lib/raw_spacetime_lib.mli b/otherlibs/raw_spacetime_lib/raw_spacetime_lib.mli
index 51bbc91f7a2c91947664c61e66508ac90982ec9f..051057dde41e23d795201eea60da3aae67e01dc2 100644 (file)
--- a/otherlibs/raw_spacetime_lib/raw_spacetime_lib.mli
+++ b/otherlibs/raw_spacetime_lib/raw_spacetime_lib.mli
@@ -4,7 +4,7 @@
 (*                                                                        *)
 (*           Mark Shinwell and Leo White, Jane Street Europe              *)
 (*                                                                        *)
-(*   Copyright 2015--2016 Jane Street Group LLC                           *)
+(*   Copyright 2015--2017 Jane Street Group LLC                           *)
 (*                                                                        *)
 (*   All rights reserved.  This file is distributed under the terms of    *)
 (*   the GNU Lesser General Public License version 2.1, with the          *)
@@ -97,6 +97,7 @@ module Trace : sig
       information required to decode profiling annotations written into
       values' headers. *)
   type t
+  type trace = t
 
   type node
   type ocaml_node
@@ -134,6 +135,11 @@ module Trace : sig
 
       (** The node corresponding to the callee. *)
       val callee_node : 'target t -> 'target
+
+      (** The number of times the callee was called.  Only available if the
+          compiler that recorded the Spacetime profile was configured with
+          "-with-spacetime-call-counts".  [None] will be returned otherwise. *)
+      val call_count : _ t -> int option
     end
 
     module Indirect_call_point : sig
@@ -154,6 +160,10 @@ module Trace : sig
         (** The node corresponding to the callee. *)
         val callee_node : t -> node
 
+        (** The number of times the callee was called.  This returns [None] in
+            the same circumstances as [Direct_call_point.call_count], above. *)
+        val call_count : t -> int option
+
         (** Move to the next callee to which this call point has branched.
             [None] is returned when the end of the list is reached. *)
         val next : t -> t option
@@ -218,7 +228,7 @@ module Trace : sig
     module Call_point : sig
       (** A value of type [t] corresponds to a call point from non-OCaml
           code (to either non-OCaml code, or OCaml code via the usual
-          assembly veneer). *)
+          assembly veneer).  Call counts are not available for such nodes. *)
       type t
 
       (** N.B. The address of the callee (of type [Function_entry_point.t]) is
@@ -345,5 +355,9 @@ module Heap_snapshot : sig
     val num_snapshots : t -> int
     val snapshot : t -> index:int -> heap_snapshot
     val events : t -> Event.t list
+
+    (** Returns [true] iff call count information was recorded in the
+        series. *)
+    val has_call_counts : t -> bool
   end
 end

diff --git a/otherlibs/str/.depend b/otherlibs/str/.depend
index 6c0795d8a02d92388617a13953effeac160972a0..f4d34d1a85043183985aa1920d60e41f8b92c875 100644 (file)
--- a/otherlibs/str/.depend
+++ b/otherlibs/str/.depend
@@ -1,7 +1,6 @@
-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 \
+strstubs.$(O): strstubs.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/alloc.h ../../byterun/caml/memory.h \
   ../../byterun/caml/fail.h
 str.cmo : str.cmi

diff --git a/otherlibs/str/Makefile b/otherlibs/str/Makefile
index 1e5d4bb2cf6c4956a98ff91ada3a46c9361ec4e1..5ec61d37749e2833d5ccc8993e77ce340627ca31 100644 (file)
--- a/otherlibs/str/Makefile
+++ b/otherlibs/str/Makefile
@@ -21,20 +21,16 @@ CLIBNAME=camlstr
 CAMLOBJS=str.cmo
 
 include ../Makefile
-
 str.cmo: str.cmi
 str.cmx: str.cmi
 
+.PHONY: depend
 depend:
-       $(CC) -MM $(CFLAGS) *.c > .depend
-       $(CAMLRUN) $(ROOTDIR)/tools/ocamldep -slash *.mli *.ml >> .depend
-
 ifeq "$(TOOLCHAIN)" "msvc"
-
-.depend.nt: .depend
-       sed -e 's/\.o/.$(O)/g' $< > $@
-
-include .depend.nt
+       $(error Dependencies cannot be regenerated using the MSVC ports)
 else
-include .depend
+       $(CC) -MM $(CPPFLAGS) *.c | sed -e 's/\.o/.$$(O)/g' > .depend
+       $(CAMLRUN) $(ROOTDIR)/tools/ocamldep -slash *.mli *.ml >> .depend
 endif
+
+include .depend

diff --git a/otherlibs/str/str.mli b/otherlibs/str/str.mli
index 256289c806460f3f15dbd43ef014b9f67c34040e..636e5812aff8569277501b87cfbe2ca183e500b9 100644 (file)
--- a/otherlibs/str/str.mli
+++ b/otherlibs/str/str.mli
@@ -16,7 +16,7 @@
 (** Regular expressions and high-level string processing *)
 
 
-(** {6 Regular expressions} *)
+(** {1 Regular expressions} *)
 
 
 type regexp
@@ -84,7 +84,7 @@ val regexp_string_case_fold : string -> regexp
    but the regexp matches in a case-insensitive way. *)
 
 
-(** {6 String matching and searching} *)
+(** {1 String matching and searching} *)
 
 
 val string_match : regexp -> string -> int -> bool
@@ -188,7 +188,7 @@ val group_end : int -> int
    the regular expression. *)
 
 
-(** {6 Replacement} *)
+(** {1 Replacement} *)
 
 
 val global_replace : regexp -> string -> string -> string
@@ -224,7 +224,7 @@ val replace_matched : string -> string -> string
    searching function. *)
 
 
-(** {6 Splitting} *)
+(** {1 Splitting} *)
 
 
 val split : regexp -> string -> string list
@@ -270,7 +270,7 @@ val bounded_full_split : regexp -> string -> int -> split_result list
    the latter are tagged [Text]. *)
 
 
-(** {6 Extracting substrings} *)
+(** {1 Extracting substrings} *)
 
 
 val string_before : string -> int -> string

diff --git a/otherlibs/str/strstubs.c b/otherlibs/str/strstubs.c
index 505b927ed4dc854443685b68d04784836a354158..51d7b7968718e046f1b90120cd3b897d1d142d19 100644 (file)
--- a/otherlibs/str/strstubs.c
+++ b/otherlibs/str/strstubs.c
@@ -286,18 +286,18 @@ static value re_match(value re,
     case ACCEPT:
       goto accept;
     case SIMPLEOPT: {
-      char * set = String_val(Field(cpool, Arg(instr)));
+      const char * set = String_val(Field(cpool, Arg(instr)));
       if (txt < endtxt && In_bitset(set, *txt, c)) txt++;
       break;
     }
     case SIMPLESTAR: {
-      char * set = String_val(Field(cpool, Arg(instr)));
+      const char * set = String_val(Field(cpool, Arg(instr)));
       while (txt < endtxt && In_bitset(set, *txt, c))
         txt++;
       break;
     }
     case SIMPLEPLUS: {
-      char * set = String_val(Field(cpool, Arg(instr)));
+      const char * set = String_val(Field(cpool, Arg(instr)));
       if (txt == endtxt) goto prefix_match;
       if (! In_bitset(set, *txt, c)) goto backtrack;
       txt++;
@@ -483,7 +483,8 @@ CAMLprim value re_replacement_text(value repl, value groups, value orig)
   CAMLparam3(repl, groups, orig);
   CAMLlocal1(res);
   mlsize_t start, end, len, n;
-  char * p, * q;
+  const char * p;
+  char * q;
   int c;
 
   len = 0;
@@ -517,7 +518,7 @@ CAMLprim value re_replacement_text(value repl, value groups, value orig)
   }
   res = caml_alloc_string(len);
   p = String_val(repl);
-  q = String_val(res);
+  q = (char *)String_val(res);
   n = caml_string_length(repl);
   while (n > 0) {
     c = *p++; n--;

diff --git a/otherlibs/systhreads/.depend b/otherlibs/systhreads/.depend
index 5181e939d281821a97b7c6e13472913c016622e0..7210c5fa03ec221dd12ac470a60525eba2405c08 100644 (file)
--- a/otherlibs/systhreads/.depend
+++ b/otherlibs/systhreads/.depend
@@ -1,16 +1,29 @@
-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
+st_stubs_b.$(O): st_stubs.c ../../byterun/caml/alloc.h \
+  ../../byterun/caml/misc.h ../../byterun/caml/config.h \
+  ../../byterun/caml/m.h ../../byterun/caml/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
+st_stubs_n.$(O): st_stubs.c ../../byterun/caml/alloc.h \
+  ../../byterun/caml/misc.h ../../byterun/caml/config.h \
+  ../../byterun/caml/m.h ../../byterun/caml/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/stack.h ../../byterun/caml/sys.h threads.h \
+  st_posix.h
 condition.cmo : mutex.cmi condition.cmi
 condition.cmx : mutex.cmx condition.cmi
 condition.cmi : mutex.cmi

diff --git a/otherlibs/systhreads/Makefile b/otherlibs/systhreads/Makefile
index 49130bd2df1364d8a3c4d959e7667cd1d104c7f2..b641f48463b30fdad889ce81d36b73164a89bfac 100644 (file)
--- a/otherlibs/systhreads/Makefile
+++ b/otherlibs/systhreads/Makefile
@@ -46,6 +46,11 @@ else # Windows
 HEADER = st_win32.h
 endif
 
+# Note: the header on which object files produced from st_stubs.c
+# should actually depend is known for sure only at compile-time.
+# That's why this dependency is handled in the Makefile directly
+# and removed from the output of the C compiler during make depend
+
 BYTECODE_C_OBJS=st_stubs_b.$(O)
 NATIVECODE_C_OBJS=st_stubs_n.$(O)
 
@@ -89,27 +94,17 @@ $(LIBNAME).cmxa: $(THREADS_NCOBJS)
 
 # The following lines produce two object files st_stubs_b.$(O) and
 # st_stubs_n.$(O) from the same source file st_stubs.c (it is compiled
-# twice, each time with different of options).
-# Since the source and object file have a different basename, the name of
-# the object file to produce must be given to the C compiler.
-# For gcc this is done with the -ofoo.$(O) option.
-# For msvc it's the /Fofoo.$(O) option.
-
-ifeq "$(TOOLCHAIN)" "msvc"
-  CCOUTPUT=/Fo
-else
-  CCOUTPUT=-o 
-endif
+# twice, each time with different options).
 
 st_stubs_b.$(O): st_stubs.c $(HEADER)
-       $(BYTECC) -I$(ROOTDIR)/byterun $(BYTECCCOMPOPTS) $(SHAREDCCCOMPOPTS) \
-         $(CCOUTPUT)$@ -c $<
+       $(CC) -c $(CFLAGS) $(CPPFLAGS) -I$(ROOTDIR)/byterun  \
+         $(SHAREDCCCOMPOPTS) $(OUTPUTOBJ)$@ $<
 
 st_stubs_n.$(O): st_stubs.c $(HEADER)
-       $(NATIVECC) -I$(ROOTDIR)/asmrun -I$(ROOTDIR)/byterun \
-         $(NATIVECCCOMPOPTS) $(SHAREDCCCOMPOPTS) -DNATIVE_CODE \
+       $(CC) $(CFLAGS) $(CPPFLAGS) -I$(ROOTDIR)/asmrun -I$(ROOTDIR)/byterun \
+         $(SHAREDCCCOMPOPTS) -DNATIVE_CODE \
          -DTARGET_$(ARCH) -DMODEL_$(MODEL) -DSYS_$(SYSTEM) \
-         $(CCOUTPUT)$@ -c $<
+         $(OUTPUTOBJ)$@ -c $<
 
 partialclean:
        rm -f *.cm*
@@ -148,12 +143,20 @@ installopt:
 .ml.cmx:
        $(CAMLOPT) -c $(COMPFLAGS) $(OPTCOMPFLAGS) $<
 
-ifeq "$(UNIX_OR_WIN32)" "unix"
-depend: $(GENFILES)
-       -$(CC) -MM -I../../byterun *.c > .depend
-       $(CAMLRUN) ../../tools/ocamldep -slash *.mli *.ml >> .depend
-else # Windows
+.PHONY: depend
+ifeq "$(TOOLCHAIN)" "msvc"
 depend:
+       $(error Dependencies cannot be regenerated using the MSVC ports)
+else
+depend:
+       $(CC) -MM $(CPPFLAGS) -I$(ROOTDIR)/byterun st_stubs.c \
+         | sed -e 's/st_stubs\.o/st_stubs_b.$$(O)/' \
+         -e 's/ st_\(posix\|win32\)\.h//g' > .depend
+       $(CC) -MM $(CPPFLAGS) -I$(ROOTDIR)/asmrun -I$(ROOTDIR)/byterun \
+         -DNATIVE_CODE -DTARGET_$(ARCH) -DMODEL_$(MODEL) -DSYS_$(SYSTEM) \
+         st_stubs.c | sed -e 's/st_stubs\.o/st_stubs_n.$$(O)/' \
+         -e 's/ st_\(posix\|win32\)\.h//g' >> .depend
+       $(CAMLRUN) ../../tools/ocamldep -slash *.mli *.ml >> .depend
 endif
 
 include .depend

diff --git a/otherlibs/systhreads/st_posix.h b/otherlibs/systhreads/st_posix.h
index a751ff32e08c0d817852f99d8ad281af96730fe9..e42b50c407f7bfb6402f668a533008318fcd0e35 100644 (file)
--- a/otherlibs/systhreads/st_posix.h
+++ b/otherlibs/systhreads/st_posix.h
@@ -116,7 +116,7 @@ static INLINE void st_tls_set(st_tlskey k, void * v)
 }
 
 /* The master lock.  This is a mutex that is held most of the time,
-   so we implement it in a slightly consoluted way to avoid
+   so we implement it in a slightly convoluted way to avoid
    all risks of busy-waiting.  Also, we count the number of waiting
    threads. */
 
@@ -167,10 +167,10 @@ typedef pthread_mutex_t * st_mutex;
 static int st_mutex_create(st_mutex * res)
 {
   int rc;
-  st_mutex m = malloc(sizeof(pthread_mutex_t));
+  st_mutex m = caml_stat_alloc_noexc(sizeof(pthread_mutex_t));
   if (m == NULL) return ENOMEM;
   rc = pthread_mutex_init(m, NULL);
-  if (rc != 0) { free(m); return rc; }
+  if (rc != 0) { caml_stat_free(m); return rc; }
   *res = m;
   return 0;
 }
@@ -179,7 +179,7 @@ static int st_mutex_destroy(st_mutex m)
 {
   int rc;
   rc = pthread_mutex_destroy(m);
-  free(m);
+  caml_stat_free(m);
   return rc;
 }
 
@@ -208,10 +208,10 @@ typedef pthread_cond_t * st_condvar;
 static int st_condvar_create(st_condvar * res)
 {
   int rc;
-  st_condvar c = malloc(sizeof(pthread_cond_t));
+  st_condvar c = caml_stat_alloc_noexc(sizeof(pthread_cond_t));
   if (c == NULL) return ENOMEM;
   rc = pthread_cond_init(c, NULL);
-  if (rc != 0) { free(c); return rc; }
+  if (rc != 0) { caml_stat_free(c); return rc; }
   *res = c;
   return 0;
 }
@@ -220,7 +220,7 @@ static int st_condvar_destroy(st_condvar c)
 {
   int rc;
   rc = pthread_cond_destroy(c);
-  free(c);
+  caml_stat_free(c);
   return rc;
 }
 
@@ -250,12 +250,12 @@ typedef struct st_event_struct {
 static int st_event_create(st_event * res)
 {
   int rc;
-  st_event e = malloc(sizeof(struct st_event_struct));
+  st_event e = caml_stat_alloc_noexc(sizeof(struct st_event_struct));
   if (e == NULL) return ENOMEM;
   rc = pthread_mutex_init(&e->lock, NULL);
-  if (rc != 0) { free(e); return rc; }
+  if (rc != 0) { caml_stat_free(e); return rc; }
   rc = pthread_cond_init(&e->triggered, NULL);
-  if (rc != 0) { pthread_mutex_destroy(&e->lock); free(e); return rc; }
+  if (rc != 0) { pthread_mutex_destroy(&e->lock); caml_stat_free(e); return rc; }
   e->status = 0;
   *res = e;
   return 0;
@@ -266,7 +266,7 @@ static int st_event_destroy(st_event e)
   int rc1, rc2;
   rc1 = pthread_mutex_destroy(&e->lock);
   rc2 = pthread_cond_destroy(&e->triggered);
-  free(e);
+  caml_stat_free(e);
   return rc1 != 0 ? rc1 : rc2;
 }
 

diff --git a/otherlibs/systhreads/st_stubs.c b/otherlibs/systhreads/st_stubs.c
index cd7daa7cfd760220cd149f96b42939eef097b8b9..f7816860e77c5738c4de3ca3342eb9e86541932d 100644 (file)
--- a/otherlibs/systhreads/st_stubs.c
+++ b/otherlibs/systhreads/st_stubs.c
@@ -64,7 +64,7 @@ struct caml_thread_descr {
 #define Start_closure(v) (((struct caml_thread_descr *)(v))->start_closure)
 #define Terminated(v) (((struct caml_thread_descr *)(v))->terminated)
 
-/* The infos on threads (allocated via malloc()) */
+/* The infos on threads (allocated via caml_stat_alloc()) */
 
 struct caml_thread_struct {
   value descr;                  /* The heap-allocated descriptor (root) */
@@ -337,7 +337,7 @@ static uintnat caml_thread_stack_usage(void)
 static caml_thread_t caml_thread_new_info(void)
 {
   caml_thread_t th;
-  th = (caml_thread_t) malloc(sizeof(struct caml_thread_struct));
+  th = (caml_thread_t) caml_stat_alloc_noexc(sizeof(struct caml_thread_struct));
   if (th == NULL) return NULL;
   th->descr = Val_unit;         /* filled later */
 #ifdef NATIVE_CODE
@@ -410,7 +410,7 @@ static void caml_thread_remove_info(caml_thread_t th)
 #ifndef NATIVE_CODE
   caml_stat_free(th->stack_low);
 #endif
-  if (th->backtrace_buffer != NULL) free(th->backtrace_buffer);
+  if (th->backtrace_buffer != NULL) caml_stat_free(th->backtrace_buffer);
 #ifndef WITH_SPACETIME
   caml_stat_free(th);
   /* CR-soon mshinwell: consider what to do about the Spacetime trace.  Could
@@ -505,7 +505,9 @@ CAMLprim value caml_thread_initialize(value unit)   /* ML */
   return Val_unit;
 }
 
-/* Cleanup the thread machinery on program exit or DLL unload. */
+/* Cleanup the thread machinery when the runtime is shut down. Joining the tick
+   thread take 25ms on average / 50ms in the worst case, so we don't do it on
+   program exit. */
 
 CAMLprim value caml_thread_cleanup(value unit)   /* ML */
 {
@@ -690,7 +692,7 @@ CAMLprim value caml_thread_uncaught_exception(value exn)  /* ML */
   char * msg = caml_format_exception(exn);
   fprintf(stderr, "Thread %d killed on uncaught exception %s\n",
           Int_val(Ident(curr_thread->descr)), msg);
-  free(msg);
+  caml_stat_free(msg);
   if (caml_backtrace_active) caml_print_exception_backtrace();
   fflush(stderr);
   return Val_unit;

diff --git a/otherlibs/systhreads/st_win32.h b/otherlibs/systhreads/st_win32.h
index fa447a9c1486303f17d8482fee05aa48883ced31..d24ea8cd0fe25e4ee3d42528a637c4e7affa46a8 100644 (file)
--- a/otherlibs/systhreads/st_win32.h
+++ b/otherlibs/systhreads/st_win32.h
@@ -22,6 +22,8 @@
 #include <stdio.h>
 #include <signal.h>
 
+#include <caml/osdeps.h>
+
 #define INLINE __inline
 
 #if 1
@@ -38,7 +40,7 @@ typedef DWORD st_retcode;
 
 #define SIGPREEMPTION SIGTERM
 
-/* Thread-local storage assocaiting a Win32 event to every thread. */
+/* Thread-local storage associating a Win32 event to every thread. */
 static DWORD st_thread_sem_key;
 
 /* OS-specific initialization */
@@ -158,7 +160,7 @@ typedef CRITICAL_SECTION * st_mutex;
 
 static DWORD st_mutex_create(st_mutex * res)
 {
-  st_mutex m = malloc(sizeof(CRITICAL_SECTION));
+  st_mutex m = caml_stat_alloc_noexc(sizeof(CRITICAL_SECTION));
   if (m == NULL) return ERROR_NOT_ENOUGH_MEMORY;
   InitializeCriticalSection(m);
   *res = m;
@@ -168,7 +170,7 @@ static DWORD st_mutex_create(st_mutex * res)
 static DWORD st_mutex_destroy(st_mutex m)
 {
   DeleteCriticalSection(m);
-  free(m);
+  caml_stat_free(m);
   return 0;
 }
 
@@ -222,7 +224,7 @@ typedef struct st_condvar_struct {
 
 static DWORD st_condvar_create(st_condvar * res)
 {
-  st_condvar c = malloc(sizeof(struct st_condvar_struct));
+  st_condvar c = caml_stat_alloc_noexc(sizeof(struct st_condvar_struct));
   if (c == NULL) return ERROR_NOT_ENOUGH_MEMORY;
   InitializeCriticalSection(&c->lock);
   c->waiters = NULL;
@@ -234,7 +236,7 @@ static DWORD st_condvar_destroy(st_condvar c)
 {
   TRACE1("st_condvar_destroy", c);
   DeleteCriticalSection(&c->lock);
-  free(c);
+  caml_stat_free(c);
   return 0;
 }
 
@@ -361,27 +363,28 @@ static DWORD st_event_wait(st_event e)
 
 static void st_check_error(DWORD retcode, char * msg)
 {
-  char err[1024];
-  int errlen, msglen;
+  wchar_t err[1024];
+  int errlen, msglen, ret;
   value str;
 
   if (retcode == 0) return;
   if (retcode == ERROR_NOT_ENOUGH_MEMORY) caml_raise_out_of_memory();
-  if (! FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM|FORMAT_MESSAGE_IGNORE_INSERTS,
+  ret = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM|FORMAT_MESSAGE_IGNORE_INSERTS,
                       NULL,
                       retcode,
                       0,
                       err,
-                      sizeof(err),
-                      NULL)) {
-    sprintf(err, "error code %lx", retcode);
+                      sizeof(err)/sizeof(wchar_t),
+                      NULL);
+  if (! ret) {
+    ret = swprintf(err, sizeof(err)/sizeof(wchar_t), L"error code %lx", retcode);
   }
   msglen = strlen(msg);
-  errlen = strlen(err);
+  errlen = win_wide_char_to_multi_byte(err, ret, NULL, 0);
   str = caml_alloc_string(msglen + 2 + errlen);
   memmove (&Byte(str, 0), msg, msglen);
   memmove (&Byte(str, msglen), ": ", 2);
-  memmove (&Byte(str, msglen + 2), err, errlen);
+  win_wide_char_to_multi_byte(err, ret, &Byte(str, msglen + 2), errlen);
   caml_raise_sys_error(str);
 }
 

diff --git a/otherlibs/systhreads/thread.ml b/otherlibs/systhreads/thread.ml
index c55ff3fe99da505f41a7208c83718c8fcd71e70b..ec05f395049c471b530f415484fd438abc884bb9 100644 (file)
--- a/otherlibs/systhreads/thread.ml
+++ b/otherlibs/systhreads/thread.ml
@@ -57,18 +57,17 @@ let preempt_signal =
   | "Win32" -> Sys.sigterm
   | _       -> Sys.sigvtalrm
 
-let _ =
+let () =
   Sys.set_signal preempt_signal (Sys.Signal_handle preempt);
-  thread_initialize();
-  at_exit
-    (fun () ->
-        thread_cleanup();
-        (* In case of DLL-embedded OCaml the preempt_signal handler
-           will point to nowhere after DLL unloading and an accidental
-           preempt_signal will crash the main program. So restore the
-           default handler. *)
-        Sys.set_signal preempt_signal Sys.Signal_default
-    )
+  thread_initialize ();
+  Callback.register "Thread.at_shutdown" (fun () ->
+    thread_cleanup();
+    (* In case of DLL-embedded OCaml the preempt_signal handler
+       will point to nowhere after DLL unloading and an accidental
+       preempt_signal will crash the main program. So restore the
+       default handler. *)
+    Sys.set_signal preempt_signal Sys.Signal_default
+  )
 
 (* Wait functions *)
 

diff --git a/otherlibs/systhreads/thread.mli b/otherlibs/systhreads/thread.mli
index 9b8a12679664828ab9f556bdaa8e34f29b41a34f..2eb38599a1487821fad019957f7450f9dd43bd9f 100644 (file)
--- a/otherlibs/systhreads/thread.mli
+++ b/otherlibs/systhreads/thread.mli
@@ -18,7 +18,7 @@
 type t
 (** The type of thread handles. *)
 
-(** {6 Thread creation and termination} *)
+(** {1 Thread creation and termination} *)
 
 val create : ('a -> 'b) -> 'a -> t
 (** [Thread.create funct arg] creates a new thread of control,
@@ -47,7 +47,7 @@ val exit : unit -> unit
 val kill : t -> unit
 (** Terminate prematurely the thread whose handle is given. *)
 
-(** {6 Suspending threads} *)
+(** {1 Suspending threads} *)
 
 val delay: float -> unit
 (** [delay d] suspends the execution of the calling thread for
@@ -102,7 +102,7 @@ val yield : unit -> unit
    telling the scheduler that now is a good time to
    switch to other threads. *)
 
-(** {6 Management of signals} *)
+(** {1 Management of signals} *)
 
 (** Signal handling follows the POSIX thread model: signals generated
   by a thread are delivered to that thread; signals generated externally

diff --git a/otherlibs/systhreads/threadUnix.mli b/otherlibs/systhreads/threadUnix.mli
index 9e8d927ee50490de38868fa3971deea063ad1d28..1fe1bcc8d196042eac78c005c6a40c4f77af4786 100644 (file)
--- a/otherlibs/systhreads/threadUnix.mli
+++ b/otherlibs/systhreads/threadUnix.mli
@@ -21,7 +21,7 @@
    (block the calling thread, if required, but do not block all threads
    in the process).  *)
 
-(** {6 Process handling} *)
+(** {1 Process handling} *)
 
 val execv : string -> string array -> unit
 val execve : string -> string array -> string array -> unit
@@ -30,13 +30,13 @@ val wait : unit -> int * Unix.process_status
 val waitpid : Unix.wait_flag list -> int -> int * Unix.process_status
 val system : string -> Unix.process_status
 
-(** {6 Basic input/output} *)
+(** {1 Basic input/output} *)
 
 val read : Unix.file_descr -> bytes -> int -> int -> int
 val write : Unix.file_descr -> bytes -> int -> int -> int
 val write_substring : Unix.file_descr -> string -> int -> int -> int
 
-(** {6 Input/output with timeout} *)
+(** {1 Input/output with timeout} *)
 
 val timed_read :
       Unix.file_descr ->
@@ -55,25 +55,25 @@ val timed_write_substring :
       Unix.file_descr -> string -> int -> int -> float -> int
 (** See {!ThreadUnix.timed_write}. *)
 
-(** {6 Polling} *)
+(** {1 Polling} *)
 
 val select :
   Unix.file_descr list -> Unix.file_descr list ->
   Unix.file_descr list -> float ->
         Unix.file_descr list * Unix.file_descr list * Unix.file_descr list
 
-(** {6 Pipes and redirections} *)
+(** {1 Pipes and redirections} *)
 
 val pipe : ?cloexec:bool -> unit -> Unix.file_descr * Unix.file_descr
 val open_process_in: string -> in_channel
 val open_process_out: string -> out_channel
 val open_process: string -> in_channel * out_channel
 
-(** {6 Time} *)
+(** {1 Time} *)
 
 val sleep : int -> unit
 
-(** {6 Sockets} *)
+(** {1 Sockets} *)
 
 val socket :
   ?cloexec:bool -> Unix.socket_domain -> Unix.socket_type -> int ->

diff --git a/otherlibs/threads/.depend b/otherlibs/threads/.depend
index f25df2a0df7dcadc69f7daceb70f3e65af4d9b0a..4e5534c2a674d0a9254e4cdf7ac413e3594124bf 100644 (file)
--- a/otherlibs/threads/.depend
+++ b/otherlibs/threads/.depend
@@ -1,15 +1,15 @@
 scheduler.o: scheduler.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/callback.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
+  ../../byterun/caml/m.h ../../byterun/caml/s.h \
+  ../../byterun/caml/mlvalues.h ../../byterun/caml/backtrace.h \
+  ../../byterun/caml/exec.h ../../byterun/caml/callback.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
 condition.cmo : thread.cmi mutex.cmi condition.cmi
 condition.cmx : thread.cmx mutex.cmx condition.cmi
 condition.cmi : mutex.cmi

diff --git a/otherlibs/threads/Makefile b/otherlibs/threads/Makefile
index a2a20e61319709e618b660b6946fca83d4cff92e..e6ccbf4491afc39cbfa1a9bfb7ea8d3ae492758b 100644 (file)
--- a/otherlibs/threads/Makefile
+++ b/otherlibs/threads/Makefile
@@ -19,8 +19,8 @@ include ../../config/Makefile
 CAMLRUN ?= ../../boot/ocamlrun
 CAMLYACC ?= ../../boot/ocamlyacc
 
-CC=$(BYTECC)
-CFLAGS=-I../../byterun $(BYTECCCOMPOPTS) $(SHAREDCCCOMPOPTS) -g
+CFLAGS += $(SHAREDCCCOMPOPTS)
+CPPFLAGS += -I../../byterun
 ROOTDIR=../..
 CAMLC=$(CAMLRUN) $(ROOTDIR)/ocamlc -nostdlib \
       -I $(ROOTDIR)/stdlib -I $(ROOTDIR)/otherlibs/unix
@@ -111,13 +111,13 @@ CMIFILES=thread.cmi mutex.cmi condition.cmi event.cmi threadUnix.cmi
 
 install:
        if test -f dllvmthreads.so; then \
-         cp dllvmthreads.so $(INSTALL_STUBLIBDIR)/.; \
+         cp dllvmthreads.so "$(INSTALL_STUBLIBDIR)"; \
        fi
-       mkdir -p $(INSTALL_LIBDIR)/vmthreads
-       cp libvmthreads.a $(INSTALL_LIBDIR)/vmthreads/libvmthreads.a
-       cd $(INSTALL_LIBDIR)/vmthreads; $(RANLIB) libvmthreads.a
+       mkdir -p "$(INSTALL_LIBDIR)/vmthreads"
+       cp libvmthreads.a "$(INSTALL_LIBDIR)/vmthreads"
+       cd "$(INSTALL_LIBDIR)/vmthreads"; $(RANLIB) libvmthreads.a
        cp $(CMIFILES) $(CMIFILES:.cmi=.mli) $(CMIFILES:.cmi=.cmti) \
-          threads.cma stdlib.cma unix.cma $(INSTALL_LIBDIR)/vmthreads
+          threads.cma stdlib.cma unix.cma "$(INSTALL_LIBDIR)/vmthreads"
 
 installopt:
 
@@ -129,8 +129,13 @@ installopt:
 .ml.cmo:
        $(CAMLC) -c $(COMPFLAGS) $<
 
+.PHONY: depend
 depend:
-       $(CC) -MM $(CFLAGS) *.c > .depend
+ifeq "$(TOOLCHAIN)" "msvc"
+       $(error Dependencies cannot be regenerated using the MSVC ports)
+else
+       $(CC) -MM $(CPPFLAGS) *.c > .depend
        $(CAMLRUN) ../../tools/ocamldep -slash *.mli *.ml >> .depend
+endif
 
 include .depend

diff --git a/otherlibs/threads/pervasives.ml b/otherlibs/threads/pervasives.ml
index 97cb52bc7f405ab738b7b7f76e4e88ad7872153f..470a1c5c54f925bffddbcfda344d49c422425b55 100644 (file)
--- a/otherlibs/threads/pervasives.ml
+++ b/otherlibs/threads/pervasives.ml
@@ -163,7 +163,9 @@ external float : int -> float = "%floatofint"
 external float_of_int : int -> float = "%floatofint"
 external truncate : float -> int = "%intoffloat"
 external int_of_float : float -> int = "%intoffloat"
-external float_of_bits : int64 -> float = "caml_int64_float_of_bits"
+external float_of_bits : int64 -> float
+  = "caml_int64_float_of_bits" "caml_int64_float_of_bits_unboxed"
+  [@@unboxed] [@@noalloc]
 let infinity =
   float_of_bits 0x7F_F0_00_00_00_00_00_00L
 let neg_infinity =
@@ -272,9 +274,8 @@ let valid_float_lexem s =
     | _ -> s
   in
   loop 0
-;;
 
-let string_of_float f = valid_float_lexem (format_float "%.12g" f);;
+let string_of_float f = valid_float_lexem (format_float "%.12g" f)
 
 external float_of_string : string -> float = "caml_float_of_string"
 
@@ -430,8 +431,7 @@ let seek_out oc pos = flush oc; seek_out_blocking oc pos
 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 = (try flush oc with _ -> ()); close_out_channel oc
+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 _ -> ())
@@ -549,7 +549,7 @@ 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 _ -> ());;
+let close_in_noerr ic = (try close_in ic with _ -> ())
 external set_binary_mode_in : in_channel -> bool -> unit
                             = "caml_ml_set_binary_mode"
 
@@ -607,13 +607,13 @@ type ('a, 'b, 'c, 'd) format4 = ('a, 'b, 'c, 'c, 'c, 'd) format6
 
 type ('a, 'b, 'c) format = ('a, 'b, 'c, 'c) format4
 
-let string_of_format (Format (fmt, str)) = str
+let string_of_format (Format (_fmt, str)) = str
 
 external format_of_string :
  ('a, 'b, 'c, 'd, 'e, 'f) format6 ->
  ('a, 'b, 'c, 'd, 'e, 'f) format6 = "%identity"
 
-let (^^) (Format (fmt1, str1)) (Format (fmt2, str2)) =
+let ( ^^ ) (Format (fmt1, str1)) (Format (fmt2, str2)) =
   Format (CamlinternalFormatBasics.concat_fmt fmt1 fmt2,
           str1 ^ "%," ^ str2)
 

diff --git a/otherlibs/threads/scheduler.c b/otherlibs/threads/scheduler.c
index fff4b177145a7274303eee116d62294e1821ed81..f434dc49ccf691114340c40d7cff7fe3a2b318c5 100644 (file)
--- a/otherlibs/threads/scheduler.c
+++ b/otherlibs/threads/scheduler.c
@@ -40,7 +40,7 @@
        defined(HAS_SETITIMER) && \
        defined(HAS_GETTIMEOFDAY) && \
        (defined(HAS_WAITPID) || defined(HAS_WAIT4)))
-#include "Cannot compile libthreads, system calls missing"
+#warning "Cannot compile libthreads, system calls missing"
 #endif
 
 #include <errno.h>
@@ -523,7 +523,7 @@ static void check_callback(void)
 
 value thread_yield(value unit)        /* ML */
 {
-  Assert(curr_thread != NULL);
+  CAMLassert(curr_thread != NULL);
   Assign(curr_thread->retval, Val_unit);
   return schedule_thread();
 }
@@ -534,7 +534,7 @@ static void thread_reschedule(void)
 {
   value accu;
 
-  Assert(curr_thread != NULL);
+  CAMLassert(curr_thread != NULL);
   /* Pop accu from event frame, making it look like a C_CALL frame
      followed by a RETURN frame */
   accu = *caml_extern_sp++;
@@ -558,7 +558,7 @@ value thread_request_reschedule(value unit)    /* ML */
 
 value thread_sleep(value unit)        /* ML */
 {
-  Assert(curr_thread != NULL);
+  CAMLassert(curr_thread != NULL);
   check_callback();
   curr_thread->status = SUSPENDED;
   return schedule_thread();
@@ -673,7 +673,7 @@ value thread_outchan_ready(value vchan, value vsize) /* ML */
 value thread_delay(value time)          /* ML */
 {
   double date = timeofday() + Double_val(time);
-  Assert(curr_thread != NULL);
+  CAMLassert(curr_thread != NULL);
   check_callback();
   curr_thread->status = BLOCKED_DELAY;
   Assign(curr_thread->delay, caml_copy_double(date));
@@ -685,7 +685,7 @@ value thread_delay(value time)          /* ML */
 value thread_join(value th)          /* ML */
 {
   check_callback();
-  Assert(curr_thread != NULL);
+  CAMLassert(curr_thread != NULL);
   if (((caml_thread_t)th)->status == KILLED) return Val_unit;
   curr_thread->status = BLOCKED_JOIN;
   Assign(curr_thread->joining, th);
@@ -696,7 +696,7 @@ value thread_join(value th)          /* ML */
 
 value thread_wait_pid(value pid)          /* ML */
 {
-  Assert(curr_thread != NULL);
+  CAMLassert(curr_thread != NULL);
   check_callback();
   curr_thread->status = BLOCKED_WAIT;
   curr_thread->waitpid = pid;
@@ -725,7 +725,7 @@ value thread_wakeup(value thread)     /* ML */
 
 value thread_self(value unit)         /* ML */
 {
-  Assert(curr_thread != NULL);
+  CAMLassert(curr_thread != NULL);
   return (value) curr_thread;
 }
 
@@ -758,7 +758,7 @@ value thread_kill(value thread)       /* ML */
   th->sp = NULL;
   th->trapsp = NULL;
   if (th->backtrace_buffer != NULL) {
-    free(th->backtrace_buffer);
+    caml_stat_free(th->backtrace_buffer);
     th->backtrace_buffer = NULL;
   }
   return retval;
@@ -771,7 +771,7 @@ value thread_uncaught_exception(value exn)  /* ML */
   char * msg = caml_format_exception(exn);
   fprintf(stderr, "Thread %d killed on uncaught exception %s\n",
           Int_val(curr_thread->ident), msg);
-  free(msg);
+  caml_stat_free(msg);
   if (caml_backtrace_active) caml_print_exception_backtrace();
   fflush(stderr);
   return Val_unit;

diff --git a/otherlibs/threads/thread.mli b/otherlibs/threads/thread.mli
index bf0c38047d26e8ccb6ce5aa6e6958f263180caf2..bd9b19e722085e861ed4a916f30a30ad9c8e5aa4 100644 (file)
--- a/otherlibs/threads/thread.mli
+++ b/otherlibs/threads/thread.mli
@@ -19,7 +19,7 @@ type t
 (** The type of thread handles. *)
 
 
-(** {6 Thread creation and termination} *)
+(** {1 Thread creation and termination} *)
 
 val create : ('a -> 'b) -> 'a -> t
 (** [Thread.create funct arg] creates a new thread of control,
@@ -49,7 +49,7 @@ val kill : t -> unit
 (** Terminate prematurely the thread whose handle is given.
    This functionality is available only with bytecode-level threads. *)
 
-(** {6 Suspending threads} *)
+(** {1 Suspending threads} *)
 
 val delay : float -> unit
 (** [delay d] suspends the execution of the calling thread for
@@ -112,7 +112,7 @@ val yield : unit -> unit
 
 (**/**)
 
-(** {6 Synchronization primitives}
+(** {1 Synchronization primitives}
 
    The following primitives provide the basis for implementing
    synchronization functions between threads. Their direct use is

diff --git a/otherlibs/threads/threadUnix.mli b/otherlibs/threads/threadUnix.mli
index 2b03ac9bce9c1eec8094e1d3deb6fa8ed1e81832..bd37f710fd157cf2cff92245ec22391bb41358d8 100644 (file)
--- a/otherlibs/threads/threadUnix.mli
+++ b/otherlibs/threads/threadUnix.mli
@@ -21,7 +21,7 @@
    (block the calling thread, if required, but do not block all threads
    in the process).  *)
 
-(** {6 Process handling} *)
+(** {1 Process handling} *)
 
 val execv : string -> string array -> unit
 val execve : string -> string array -> string array -> unit
@@ -30,7 +30,7 @@ val wait : unit -> int * Unix.process_status
 val waitpid : Unix.wait_flag list -> int -> int * Unix.process_status
 val system : string -> Unix.process_status
 
-(** {6 Basic input/output} *)
+(** {1 Basic input/output} *)
 
 val read : Unix.file_descr -> bytes -> int -> int -> int
 val write : Unix.file_descr -> bytes -> int -> int -> int
@@ -38,7 +38,7 @@ val single_write : Unix.file_descr -> bytes -> int -> int -> int
 val write_substring : Unix.file_descr -> string -> int -> int -> int
 val single_write_substring : Unix.file_descr -> string -> int -> int -> int
 
-(** {6 Input/output with timeout} *)
+(** {1 Input/output with timeout} *)
 
 val timed_read : Unix.file_descr -> bytes -> int -> int -> float -> int
 (** See {!ThreadUnix.timed_write}. *)
@@ -53,14 +53,14 @@ val timed_write_substring :
       Unix.file_descr -> string -> int -> int -> float -> int
 (** See {!ThreadUnix.timed_write}. *)
 
-(** {6 Polling} *)
+(** {1 Polling} *)
 
 val select :
   Unix.file_descr list -> Unix.file_descr list -> Unix.file_descr list ->
     float ->
     Unix.file_descr list * Unix.file_descr list * Unix.file_descr list
 
-(** {6 Pipes and redirections} *)
+(** {1 Pipes and redirections} *)
 
 val pipe : ?cloexec:bool -> unit -> Unix.file_descr * Unix.file_descr
 val open_process_in : string -> in_channel
@@ -69,11 +69,11 @@ val open_process : string -> in_channel * out_channel
 val open_process_full :
   string -> string array -> in_channel * out_channel * in_channel
 
-(** {6 Time} *)
+(** {1 Time} *)
 
 val sleep : int -> unit
 
-(** {6 Sockets} *)
+(** {1 Sockets} *)
 
 val socket :
   ?cloexec:bool -> Unix.socket_domain -> Unix.socket_type -> int ->

diff --git a/otherlibs/threads/unix.ml b/otherlibs/threads/unix.ml
index 9701cbd0e6ad98b874b0d3611d9abdc4331605c4..28d5a1dcbdafb0c6a1ab61e76701b3cc727b7680 100644 (file)
--- a/otherlibs/threads/unix.ml
+++ b/otherlibs/threads/unix.ml
@@ -159,7 +159,9 @@ let handle_unix_error f arg =
     exit 2
 
 external environment : unit -> string array = "unix_environment"
+external unsafe_environment : unit -> string array = "unix_environment_unsafe"
 external getenv: string -> string = "caml_sys_getenv"
+external unsafe_getenv: string -> string = "caml_sys_unsafe_getenv"
 external putenv: string -> string -> unit = "unix_putenv"
 
 type interval_timer =
@@ -318,6 +320,16 @@ module LargeFile =
     external fstat : file_descr -> stats = "unix_fstat_64"
   end
 
+external map_internal:
+   file_descr -> ('a, 'b) CamlinternalBigarray.kind
+              -> 'c CamlinternalBigarray.layout
+              -> bool -> int array -> int64
+              -> ('a, 'b, 'c) CamlinternalBigarray.genarray
+     = "caml_unix_map_file_bytecode" "caml_unix_map_file"
+
+let map_file fd ?(pos=0L) kind layout shared dims =
+  map_internal fd kind layout shared dims pos
+
 type access_permission =
     R_OK
   | W_OK

diff --git a/otherlibs/unix/.depend b/otherlibs/unix/.depend
index 2d9d23d391bcd086400c5186cf184405f65628c9..cf12de609173cf37adf254fc78516823f0582c2a 100644 (file)
--- a/otherlibs/unix/.depend
+++ b/otherlibs/unix/.depend
@@ -1,523 +1,448 @@
 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/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/alloc.h ../../byterun/caml/fail.h \
   ../../byterun/caml/memory.h ../../byterun/caml/signals.h unixsupport.h \
   socketaddr.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/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/alloc.h ../../byterun/caml/memory.h \
-  ../../byterun/caml/signals.h unixsupport.h
+  ../../byterun/caml/signals.h ../../byterun/caml/osdeps.h unixsupport.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/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/memory.h ../../byterun/caml/fail.h unixsupport.h \
   socketaddr.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 \
-  unixsupport.h socketaddr.h
+  ../../byterun/caml/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/s.h ../../byterun/caml/misc.h unixsupport.h
+bind.o: bind.c ../../byterun/caml/fail.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/s.h ../../byterun/caml/mlvalues.h unixsupport.h \
+  socketaddr.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/signals.h unixsupport.h
+  ../../byterun/caml/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/s.h ../../byterun/caml/misc.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 ../../byterun/caml/osdeps.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/signals.h unixsupport.h
+  ../../byterun/caml/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/s.h ../../byterun/caml/misc.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 ../../byterun/caml/osdeps.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/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/memory.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/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/memory.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/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/signals.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/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/memory.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 \
+connect.o: connect.c ../../byterun/caml/fail.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/s.h ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/signals.h unixsupport.h socketaddr.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/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/fail.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 unixsupport.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/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/s.h ../../byterun/caml/misc.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 unixsupport.h
+dup.o: dup.c ../../byterun/caml/mlvalues.h ../../byterun/caml/config.h \
+  ../../byterun/caml/m.h ../../byterun/caml/s.h \
+  ../../byterun/caml/misc.h unixsupport.h
+dup2.o: dup2.c ../../byterun/caml/mlvalues.h ../../byterun/caml/config.h \
+  ../../byterun/caml/m.h ../../byterun/caml/s.h \
+  ../../byterun/caml/misc.h unixsupport.h
+envir.o: envir.c ../../byterun/caml/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/s.h ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/misc.h ../../byterun/caml/alloc.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/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/alloc.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 unixsupport.h
+  ../../byterun/caml/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/s.h ../../byterun/caml/misc.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 unixsupport.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 unixsupport.h
+  ../../byterun/caml/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/s.h ../../byterun/caml/misc.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 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/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/memory.h ../../byterun/caml/osdeps.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 \
+exit.o: exit.c ../../byterun/caml/mlvalues.h ../../byterun/caml/config.h \
+  ../../byterun/caml/m.h ../../byterun/caml/s.h \
+  ../../byterun/caml/misc.h unixsupport.h
+fchmod.o: fchmod.c ../../byterun/caml/fail.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/s.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 \
+fchown.o: fchown.c ../../byterun/caml/fail.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/s.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 \
-  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 unixsupport.h
+fcntl.o: fcntl.c ../../byterun/caml/fail.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/s.h ../../byterun/caml/mlvalues.h unixsupport.h
+fork.o: fork.c ../../byterun/caml/mlvalues.h ../../byterun/caml/config.h \
+  ../../byterun/caml/m.h ../../byterun/caml/s.h \
+  ../../byterun/caml/misc.h ../../byterun/caml/debugger.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/io.h ../../byterun/caml/signals.h unixsupport.h
+  ../../byterun/caml/misc.h ../../byterun/caml/config.h \
+  ../../byterun/caml/m.h ../../byterun/caml/s.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/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/alloc.h ../../byterun/caml/fail.h \
   ../../byterun/caml/memory.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/fail.h unixsupport.h
+  ../../byterun/caml/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/s.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/alloc.h ../../byterun/caml/fail.h \
+  ../../byterun/caml/osdeps.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
 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
+  ../../byterun/caml/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/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
+  ../../byterun/caml/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/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
+  ../../byterun/caml/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/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/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/fail.h ../../byterun/caml/alloc.h \
   ../../byterun/caml/memory.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/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/alloc.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/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/alloc.h ../../byterun/caml/fail.h \
   ../../byterun/caml/memory.h ../../byterun/caml/signals.h unixsupport.h \
   socketaddr.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/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/alloc.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/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/alloc.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/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/alloc.h ../../byterun/caml/fail.h \
   ../../byterun/caml/memory.h ../../byterun/caml/signals.h unixsupport.h \
   socketaddr.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 \
-  unixsupport.h socketaddr.h
+  ../../byterun/caml/misc.h ../../byterun/caml/config.h \
+  ../../byterun/caml/m.h ../../byterun/caml/s.h \
+  ../../byterun/caml/mlvalues.h unixsupport.h socketaddr.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
+  ../../byterun/caml/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/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
+  ../../byterun/caml/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/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/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/alloc.h ../../byterun/caml/fail.h \
   ../../byterun/caml/memory.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/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/alloc.h ../../byterun/caml/memory.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/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/alloc.h ../../byterun/caml/fail.h \
   ../../byterun/caml/memory.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 \
-  unixsupport.h socketaddr.h
+  ../../byterun/caml/misc.h ../../byterun/caml/config.h \
+  ../../byterun/caml/m.h ../../byterun/caml/s.h \
+  ../../byterun/caml/mlvalues.h unixsupport.h socketaddr.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/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/alloc.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
+  ../../byterun/caml/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/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/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/alloc.h ../../byterun/caml/fail.h \
   ../../byterun/caml/memory.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/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/alloc.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
+  ../../byterun/caml/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/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/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/alloc.h ../../byterun/caml/fail.h \
   ../../byterun/caml/memory.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 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/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 \
-  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 \
+kill.o: kill.c ../../byterun/caml/mlvalues.h ../../byterun/caml/config.h \
+  ../../byterun/caml/m.h ../../byterun/caml/s.h \
+  ../../byterun/caml/misc.h ../../byterun/caml/fail.h unixsupport.h \
+  ../../byterun/caml/signals.h
+link.o: link.c ../../byterun/caml/mlvalues.h ../../byterun/caml/config.h \
+  ../../byterun/caml/m.h ../../byterun/caml/s.h \
+  ../../byterun/caml/misc.h ../../byterun/caml/memory.h \
+  ../../byterun/caml/signals.h unixsupport.h
+listen.o: listen.c ../../byterun/caml/fail.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/s.h ../../byterun/caml/mlvalues.h unixsupport.h
+lockf.o: lockf.c ../../byterun/caml/fail.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/s.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/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/alloc.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/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/memory.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 \
+mkfifo.o: mkfifo.c ../../byterun/caml/fail.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/s.h ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/memory.h ../../byterun/caml/signals.h unixsupport.h
+mmap.o: mmap.c ../../byterun/caml/bigarray.h ../../byterun/caml/config.h \
+  ../../byterun/caml/m.h ../../byterun/caml/s.h \
+  ../../byterun/caml/mlvalues.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/fail.h ../../byterun/caml/io.h \
+  ../../byterun/caml/signals.h ../../byterun/caml/sys.h unixsupport.h
+mmap_ba.o: mmap_ba.c ../../byterun/caml/alloc.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/s.h ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/bigarray.h ../../byterun/caml/custom.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
+nice.o: nice.c ../../byterun/caml/mlvalues.h ../../byterun/caml/config.h \
+  ../../byterun/caml/m.h ../../byterun/caml/s.h \
+  ../../byterun/caml/misc.h unixsupport.h
+open.o: open.c ../../byterun/caml/mlvalues.h ../../byterun/caml/config.h \
+  ../../byterun/caml/m.h ../../byterun/caml/s.h \
+  ../../byterun/caml/misc.h ../../byterun/caml/alloc.h \
   ../../byterun/caml/memory.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/memory.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/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/memory.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 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 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/signals.h unixsupport.h
+pipe.o: pipe.c ../../byterun/caml/mlvalues.h ../../byterun/caml/config.h \
+  ../../byterun/caml/m.h ../../byterun/caml/s.h \
+  ../../byterun/caml/misc.h ../../byterun/caml/alloc.h unixsupport.h
+putenv.o: putenv.c ../../byterun/caml/fail.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/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 unixsupport.h
+read.o: read.c ../../byterun/caml/mlvalues.h ../../byterun/caml/config.h \
+  ../../byterun/caml/m.h ../../byterun/caml/s.h \
+  ../../byterun/caml/misc.h ../../byterun/caml/memory.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/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/fail.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/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/memory.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/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/memory.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 \
-  unixsupport.h
+  ../../byterun/caml/misc.h ../../byterun/caml/config.h \
+  ../../byterun/caml/m.h ../../byterun/caml/s.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/signals.h unixsupport.h
+  ../../byterun/caml/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/s.h ../../byterun/caml/misc.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 ../../byterun/caml/osdeps.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/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/alloc.h ../../byterun/caml/fail.h \
   ../../byterun/caml/memory.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/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/alloc.h ../../byterun/caml/fail.h \
   ../../byterun/caml/memory.h ../../byterun/caml/signals.h unixsupport.h \
   socketaddr.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
+  ../../byterun/caml/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/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/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/alloc.h ../../byterun/caml/fail.h \
   ../../byterun/caml/memory.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 \
-  unixsupport.h
+setsid.o: setsid.c ../../byterun/caml/fail.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/s.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
+  ../../byterun/caml/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/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 \
-  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/misc.h ../../byterun/caml/config.h \
+  ../../byterun/caml/m.h ../../byterun/caml/s.h \
+  ../../byterun/caml/mlvalues.h unixsupport.h
+signals.o: signals.c ../../byterun/caml/alloc.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/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/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/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/signals.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 \
-  unixsupport.h
+socket.o: socket.c ../../byterun/caml/fail.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/s.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/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/alloc.h ../../byterun/caml/memory.h unixsupport.h \
   socketaddr.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/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/alloc.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/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/memory.h ../../byterun/caml/alloc.h \
   ../../byterun/caml/fail.h unixsupport.h socketaddr.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/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
+stat.o: stat.c ../../byterun/caml/mlvalues.h ../../byterun/caml/config.h \
+  ../../byterun/caml/m.h ../../byterun/caml/s.h \
+  ../../byterun/caml/misc.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/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/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/alloc.h ../../byterun/caml/fail.h unixsupport.h \
   socketaddr.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 \
+symlink.o: symlink.c ../../byterun/caml/fail.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/s.h ../../byterun/caml/mlvalues.h \
   ../../byterun/caml/memory.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/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/alloc.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 unixsupport.h
+time.o: time.c ../../byterun/caml/mlvalues.h ../../byterun/caml/config.h \
+  ../../byterun/caml/m.h ../../byterun/caml/s.h \
+  ../../byterun/caml/misc.h ../../byterun/caml/alloc.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/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/alloc.h ../../byterun/caml/memory.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/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/s.h ../../byterun/caml/misc.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 ../../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
+  ../../byterun/caml/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/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/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/alloc.h ../../byterun/caml/callback.h \
   ../../byterun/caml/memory.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/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/memory.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/fail.h \
+  ../../byterun/caml/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/s.h ../../byterun/caml/misc.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
+  ../../byterun/caml/signals.h ../../byterun/caml/osdeps.h unixsupport.h
+utimes.o: utimes.c ../../byterun/caml/fail.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/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/signals.h ../../byterun/caml/osdeps.h unixsupport.h
+wait.o: wait.c ../../byterun/caml/mlvalues.h ../../byterun/caml/config.h \
+  ../../byterun/caml/m.h ../../byterun/caml/s.h \
+  ../../byterun/caml/misc.h ../../byterun/caml/alloc.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/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/s.h ../../byterun/caml/misc.h \
   ../../byterun/caml/memory.h ../../byterun/caml/signals.h unixsupport.h
 unix.cmo : unix.cmi
 unix.cmx : unix.cmi

diff --git a/otherlibs/unix/Makefile b/otherlibs/unix/Makefile
index 39ef591792a139643b625634572ef32256ff8dc8..39dfdcaa4924cccca3ff6e1733e4d72ae79940fa 100644 (file)
--- a/otherlibs/unix/Makefile
+++ b/otherlibs/unix/Makefile
@@ -31,7 +31,8 @@ COBJS=accept.o access.o addrofstr.o alarm.o bind.o chdir.o chmod.o \
   getnameinfo.o getpeername.o getpid.o getppid.o getproto.o getpw.o \
   gettimeofday.o getserv.o getsockname.o getuid.o gmtime.o \
   initgroups.o isatty.o itimer.o kill.o link.o listen.o lockf.o lseek.o \
-  mkdir.o mkfifo.o nice.o open.o opendir.o pipe.o putenv.o read.o \
+  mkdir.o mkfifo.o mmap.o mmap_ba.o \
+  nice.o open.o opendir.o pipe.o putenv.o read.o \
   readdir.o readlink.o rename.o rewinddir.o rmdir.o select.o sendrecv.o \
   setgid.o setgroups.o setsid.o setuid.o shutdown.o signals.o \
   sleep.o socket.o socketaddr.o \
@@ -45,8 +46,13 @@ HEADERS=unixsupport.h socketaddr.h
 
 include ../Makefile
 
+.PHONY: depend
 depend:
-       $(CC) -MM $(CFLAGS) *.c > .depend
+ifeq "$(TOOLCHAIN)" "msvc"
+       $(error Dependencies cannot be regenerated using the MSVC ports)
+else
+       $(CC) -MM $(CPPFLAGS) *.c > .depend
        $(CAMLRUN) ../../tools/ocamldep -slash *.mli *.ml >> .depend
+endif
 
 include .depend

diff --git a/otherlibs/unix/access.c b/otherlibs/unix/access.c
index 0df09ed25ac565f9b56702d8d4dbadb827ba4e1f..4b6ba7f7a6f45dfb3a36adb4f9211263ef313d4d 100644 (file)
--- a/otherlibs/unix/access.c
+++ b/otherlibs/unix/access.c
@@ -17,6 +17,8 @@
 #include <caml/alloc.h>
 #include <caml/memory.h>
 #include <caml/signals.h>
+#define CAML_INTERNALS
+#include <caml/osdeps.h>
 #include "unixsupport.h"
 
 #ifdef HAS_UNISTD
@@ -49,14 +51,14 @@ static int access_permission_table[] = {
 CAMLprim value unix_access(value path, value perms)
 {
   CAMLparam2(path, perms);
-  char * p;
+  char_os * p;
   int ret, cv_flags;
 
   caml_unix_check_path(path, "access");
   cv_flags = caml_convert_flag_list(perms, access_permission_table);
-  p = caml_strdup(String_val(path));
+  p = caml_stat_strdup_to_os(String_val(path));
   caml_enter_blocking_section();
-  ret = access(p, cv_flags);
+  ret = access_os(p, cv_flags);
   caml_leave_blocking_section();
   caml_stat_free(p);
   if (ret == -1)

diff --git a/otherlibs/unix/chdir.c b/otherlibs/unix/chdir.c
index 244ad5d3c5b3983b845b865e97ed01ebc4f016a6..d6217dc5538914ba9f9cf8e26bf4393e90429192 100644 (file)
--- a/otherlibs/unix/chdir.c
+++ b/otherlibs/unix/chdir.c
@@ -13,20 +13,23 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 #include <caml/mlvalues.h>
 #include <caml/memory.h>
 #include <caml/signals.h>
+#include <caml/osdeps.h>
 #include "unixsupport.h"
 
 CAMLprim value unix_chdir(value path)
 {
   CAMLparam1(path);
-  char * p;
+  char_os * p;
   int ret;
   caml_unix_check_path(path, "chdir");
-  p = caml_strdup(String_val(path));
+  p = caml_stat_strdup_to_os(String_val(path));
   caml_enter_blocking_section();
-  ret = chdir(p);
+  ret = chdir_os(p);
   caml_leave_blocking_section();
   caml_stat_free(p);
   if (ret == -1) uerror("chdir", path);

diff --git a/otherlibs/unix/chmod.c b/otherlibs/unix/chmod.c
index cfdc1a3346b1d93d7c2db5e770cffdd4d8147acf..7aff4878fe32ebdc2f128a8fa382ebd6d8a8431e 100644 (file)
--- a/otherlibs/unix/chmod.c
+++ b/otherlibs/unix/chmod.c
@@ -13,22 +13,25 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 #include <sys/types.h>
 #include <sys/stat.h>
 #include <caml/mlvalues.h>
 #include <caml/memory.h>
 #include <caml/signals.h>
+#include <caml/osdeps.h>
 #include "unixsupport.h"
 
 CAMLprim value unix_chmod(value path, value perm)
 {
   CAMLparam2(path, perm);
-  char * p;
+  char_os * p;
   int ret;
   caml_unix_check_path(path, "chmod");
-  p = caml_strdup(String_val(path));
+  p = caml_stat_strdup_to_os(String_val(path));
   caml_enter_blocking_section();
-  ret = chmod(p, Int_val(perm));
+  ret = chmod_os(p, Int_val(perm));
   caml_leave_blocking_section();
   caml_stat_free(p);
   if (ret == -1) uerror("chmod", path);

diff --git a/otherlibs/unix/chown.c b/otherlibs/unix/chown.c
index f018e9e0a7a00fa34b897bd693ffc09c2cd312d3..4b53a2c02e5084bb97a6265f6f00037091e100fd 100644 (file)
--- a/otherlibs/unix/chown.c
+++ b/otherlibs/unix/chown.c
@@ -24,7 +24,7 @@ CAMLprim value unix_chown(value path, value uid, value gid)
   char * p;
   int ret;
   caml_unix_check_path(path, "chown");
-  p = caml_strdup(String_val(path));
+  p = caml_stat_strdup(String_val(path));
   caml_enter_blocking_section();
   ret = chown(p, Int_val(uid), Int_val(gid));
   caml_leave_blocking_section();

diff --git a/otherlibs/unix/chroot.c b/otherlibs/unix/chroot.c
index 7b87de72235e0367e68ebe24a3b04fbd4495fe4a..8da7710cbdf14c727108f34620715722261339ac 100644 (file)
--- a/otherlibs/unix/chroot.c
+++ b/otherlibs/unix/chroot.c
@@ -24,7 +24,7 @@ CAMLprim value unix_chroot(value path)
   char * p;
   int ret;
   caml_unix_check_path(path, "chroot");
-  p = caml_strdup(String_val(path));
+  p = caml_stat_strdup(String_val(path));
   caml_enter_blocking_section();
   ret = chroot(p);
   caml_leave_blocking_section();

diff --git a/otherlibs/unix/cstringv.c b/otherlibs/unix/cstringv.c
index 68441cfaa6dbac60b1311fcded574de3b327cf40..d537c6d83460120fcba288696eca9314a2b54cf9 100644 (file)
--- a/otherlibs/unix/cstringv.c
+++ b/otherlibs/unix/cstringv.c
@@ -13,22 +13,32 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 #include <errno.h>
 #include <caml/mlvalues.h>
 #include <caml/memory.h>
+#include <caml/osdeps.h>
 #include "unixsupport.h"
 
-char ** cstringvect(value arg, char * cmdname)
+char_os ** cstringvect(value arg, char * cmdname)
 {
-  char ** res;
+  char_os ** res;
   mlsize_t size, i;
 
   size = Wosize_val(arg);
   for (i = 0; i < size; i++)
     if (! caml_string_is_c_safe(Field(arg, i)))
       unix_error(EINVAL, cmdname, Field(arg, i));
-  res = (char **) caml_stat_alloc((size + 1) * sizeof(char *));
-  for (i = 0; i < size; i++) res[i] = String_val(Field(arg, i));
+  res = (char_os **) caml_stat_alloc((size + 1) * sizeof(char_os *));
+  for (i = 0; i < size; i++) res[i] = caml_stat_strdup_to_os(String_val(Field(arg, i)));
   res[size] = NULL;
   return res;
 }
+
+void cstringvect_free(char_os ** v)
+{
+  int i = 0;
+  while (v[i]) caml_stat_free(v[i++]);
+  caml_stat_free((char *)v);
+}

diff --git a/otherlibs/unix/envir.c b/otherlibs/unix/envir.c
index 3c6b54dc3a1258bcd182ad09b12505f5f752a0fb..3ad4b9caa0206e42a042408449a6687890303f7e 100644 (file)
--- a/otherlibs/unix/envir.c
+++ b/otherlibs/unix/envir.c
@@ -13,14 +13,22 @@
 /*                                                                        */
 /**************************************************************************/
 
+#include <caml/config.h>
+
+#ifdef HAS_UNISTD
+#include <unistd.h>
+#endif
+#include <sys/types.h>
+#ifdef HAS_GETAUXVAL
+#include <sys/auxv.h>
+#endif
+
 #include <caml/mlvalues.h>
 #include <caml/alloc.h>
 
-#ifndef _WIN32
 extern char ** environ;
-#endif
 
-CAMLprim value unix_environment(value unit)
+CAMLprim value unix_environment_unsafe(value unit)
 {
   if (environ != NULL) {
     return caml_copy_string_array((const char**)environ);
@@ -28,3 +36,33 @@ CAMLprim value unix_environment(value unit)
     return Atom(0);
   }
 }
+
+static char **secure_environ(void)
+{
+#ifdef HAS_GETAUXVAL
+  if (!getauxval(AT_SECURE))
+    return environ;
+  else
+   return NULL;
+#elif defined(HAS_ISSETUGID)
+  if (!issetugid ())
+    return environ;
+  else
+    return NULL;
+#else
+  if (geteuid () == getuid () && getegid () == getgid ())
+    return environ;
+  else
+    return NULL;
+#endif
+}
+
+CAMLprim value unix_environment(value unit)
+{
+  char **e = secure_environ();
+  if (e != NULL) {
+    return caml_copy_string_array((const char**)e);
+  } else {
+    return Atom(0);
+  }
+}

diff --git a/otherlibs/unix/execv.c b/otherlibs/unix/execv.c
index 58f2e45eec6e4982b59669cecdd8a67551a8e4e7..e751b19deb1aef9e09ff8caaf5596738830d24c8 100644 (file)
--- a/otherlibs/unix/execv.c
+++ b/otherlibs/unix/execv.c
@@ -13,17 +13,23 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 #include <caml/mlvalues.h>
 #include <caml/memory.h>
+#include <caml/osdeps.h>
 #include "unixsupport.h"
 
 CAMLprim value unix_execv(value path, value args)
 {
-  char ** argv;
+  char_os * wpath;
+  char_os ** argv;
   caml_unix_check_path(path, "execv");
   argv = cstringvect(args, "execv");
-  (void) execv(String_val(path), argv);
-  caml_stat_free((char *) argv);
+  wpath = caml_stat_strdup_to_os(String_val(path));
+  (void) execv_os(wpath, EXECV_CAST argv);
+  caml_stat_free(wpath);
+  cstringvect_free(argv);
   uerror("execv", path);
   return Val_unit;                  /* never reached, but suppress warnings */
                                 /* from smart compilers */

diff --git a/otherlibs/unix/execve.c b/otherlibs/unix/execve.c
index dfdef2999b7e2e6500a23034cf1de29a7826cc3d..bdce766b02b007beaa4100493a9956013dd95ed2 100644 (file)
--- a/otherlibs/unix/execve.c
+++ b/otherlibs/unix/execve.c
@@ -13,20 +13,26 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 #include <caml/mlvalues.h>
 #include <caml/memory.h>
+#include <caml/osdeps.h>
 #include "unixsupport.h"
 
 CAMLprim value unix_execve(value path, value args, value env)
 {
-  char ** argv;
-  char ** envp;
+  char_os ** argv;
+  char_os ** envp;
+  char_os * wpath;
   caml_unix_check_path(path, "execve");
   argv = cstringvect(args, "execve");
   envp = cstringvect(env, "execve");
-  (void) execve(String_val(path), argv, envp);
-  caml_stat_free((char *) argv);
-  caml_stat_free((char *) envp);
+  wpath = caml_stat_strdup_to_os(String_val(path));
+  (void) execve_os(wpath, EXECV_CAST argv, EXECV_CAST envp);
+  caml_stat_free(wpath);
+  cstringvect_free(argv);
+  cstringvect_free(envp);
   uerror("execve", path);
   return Val_unit;                  /* never reached, but suppress warnings */
                                 /* from smart compilers */

diff --git a/otherlibs/unix/execvp.c b/otherlibs/unix/execvp.c
index d521adcff7eff2df794edac1286530247cf6818b..1eb4316498ef53a982346ada670d4127bb976b97 100644 (file)
--- a/otherlibs/unix/execvp.c
+++ b/otherlibs/unix/execvp.c
@@ -13,42 +13,56 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define _GNU_SOURCE  /* helps to find execvpe() */
 #include <caml/mlvalues.h>
 #include <caml/memory.h>
 #define CAML_INTERNALS
 #include <caml/osdeps.h>
 #include "unixsupport.h"
-
-#ifndef _WIN32
-extern char ** environ;
-#endif
+#include "errno.h"
 
 CAMLprim value unix_execvp(value path, value args)
 {
-  char ** argv;
+  char_os ** argv;
+  char_os * wpath;
   caml_unix_check_path(path, "execvp");
   argv = cstringvect(args, "execvp");
-  (void) execvp(String_val(path), argv);
-  caml_stat_free((char *) argv);
+  wpath = caml_stat_strdup_to_os(String_val(path));
+  (void) execvp_os((const char_os *)wpath, EXECV_CAST argv);
+  caml_stat_free(wpath);
+  cstringvect_free(argv);
   uerror("execvp", path);
   return Val_unit;                  /* never reached, but suppress warnings */
                                     /* from smart compilers */
 }
 
+#ifdef HAS_EXECVPE
+
 CAMLprim value unix_execvpe(value path, value args, value env)
 {
-  char * exefile;
-  char ** argv;
-  char ** envp;
+  char_os ** argv;
+  char_os ** envp;
+  char_os * wpath;
   caml_unix_check_path(path, "execvpe");
-  exefile = caml_search_exe_in_path(String_val(path));
   argv = cstringvect(args, "execvpe");
   envp = cstringvect(env, "execvpe");
-  (void) execve(exefile, argv, envp);
-  caml_stat_free(exefile);
-  caml_stat_free((char *) argv);
-  caml_stat_free((char *) envp);
+  wpath = caml_stat_strdup_to_os(String_val(path));
+  (void) execvpe_os((const char_os *)wpath, EXECV_CAST argv, EXECV_CAST envp);
+  caml_stat_free(wpath);
+  cstringvect_free(argv);
+  cstringvect_free(envp);
   uerror("execvpe", path);
   return Val_unit;                  /* never reached, but suppress warnings */
                                     /* from smart compilers */
 }
+
+#else
+
+CAMLprim value unix_execvpe(value path, value args, value env)
+{
+  unix_error(ENOSYS, "execvpe", path);
+  return Val_unit;
+}
+
+#endif
+

diff --git a/otherlibs/unix/getaddrinfo.c b/otherlibs/unix/getaddrinfo.c
index 90c27dae9c35f9c9be8257516c09e0815d605dd2..ab605bd2755a23016cdf0f8c6dd65eac50c5a668 100644 (file)
--- a/otherlibs/unix/getaddrinfo.c
+++ b/otherlibs/unix/getaddrinfo.c
@@ -71,13 +71,13 @@ CAMLprim value unix_getaddrinfo(value vnode, value vserv, value vopts)
   if (caml_string_length(vnode) == 0) {
     node = NULL;
   } else {
-    node = caml_strdup(String_val(vnode));
+    node = caml_stat_strdup(String_val(vnode));
   }
   /* Extract "service" parameter */
   if (caml_string_length(vserv) == 0) {
     serv = NULL;
   } else {
-    serv = caml_strdup(String_val(vserv));
+    serv = caml_stat_strdup(String_val(vserv));
   }
   /* Parse options, set hints */
   memset(&hints, 0, sizeof(hints));

diff --git a/otherlibs/unix/getcwd.c b/otherlibs/unix/getcwd.c
index 74c8a07f084e441a54e65afd6f45adeec9982f6c..a38e409299825627d453a861af76be783916b30c 100644 (file)
--- a/otherlibs/unix/getcwd.c
+++ b/otherlibs/unix/getcwd.c
@@ -13,9 +13,12 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 #include <caml/mlvalues.h>
 #include <caml/alloc.h>
 #include <caml/fail.h>
+#include <caml/osdeps.h>
 #include "unixsupport.h"
 
 #if !defined (_WIN32) && !macintosh
@@ -34,19 +37,11 @@
 
 CAMLprim value unix_getcwd(value unit)
 {
-  char buff[PATH_MAX];
-  if (getcwd(buff, sizeof(buff)) == 0) uerror("getcwd", Nothing);
-  return caml_copy_string(buff);
-}
-
-#else
-#ifdef HAS_GETWD
-
-CAMLprim value unix_getcwd(value unit)
-{
-  char buff[PATH_MAX];
-  if (getwd(buff) == 0) uerror("getcwd", copy_string(buff));
-  return copy_string(buff);
+  char_os buff[PATH_MAX];
+  char_os * ret;
+  ret = getcwd_os(buff, sizeof(buff)/sizeof(*buff));
+  if (ret == 0) uerror("getcwd", Nothing);
+  return caml_copy_string_of_os(buff);
 }
 
 #else
@@ -55,4 +50,3 @@ CAMLprim value unix_getcwd(value unit)
 { caml_invalid_argument("getcwd not implemented"); }
 
 #endif
-#endif

diff --git a/otherlibs/unix/gethost.c b/otherlibs/unix/gethost.c
index 1c1f5efa03535e2a003de21c18f51de1b571055f..49e5bdeadb8c9b521723bbbf45da77de40c7f9ad 100644 (file)
--- a/otherlibs/unix/gethost.c
+++ b/otherlibs/unix/gethost.c
@@ -135,11 +135,7 @@ CAMLprim value unix_gethostbyname(value name)
 
   if (! caml_string_is_c_safe(name)) caml_raise_not_found();
 
-#if HAS_GETHOSTBYNAME_R || GETHOSTBYNAME_IS_REENTRANT
-  hostname = caml_strdup(String_val(name));
-#else
-  hostname = String_val(name);
-#endif
+  hostname = caml_stat_strdup(String_val(name));
 
 #if HAS_GETHOSTBYNAME_R == 5
   {
@@ -165,9 +161,7 @@ CAMLprim value unix_gethostbyname(value name)
 #endif
 #endif
 
-#if HAS_GETHOSTBYNAME_R || GETHOSTBYNAME_IS_REENTRANT
   caml_stat_free(hostname);
-#endif
 
   if (hp == (struct hostent *) NULL) caml_raise_not_found();
   return alloc_host_entry(hp);

diff --git a/otherlibs/unix/link.c b/otherlibs/unix/link.c
index 3179c060dc8e67ff25286deb979cdb439a58ee5b..6454aaed1ade4749cb9fe34115441667f05f5106 100644 (file)
--- a/otherlibs/unix/link.c
+++ b/otherlibs/unix/link.c
@@ -26,8 +26,8 @@ CAMLprim value unix_link(value path1, value path2)
   int ret;
   caml_unix_check_path(path1, "link");
   caml_unix_check_path(path2, "link");
-  p1 = caml_strdup(String_val(path1));
-  p2 = caml_strdup(String_val(path2));
+  p1 = caml_stat_strdup(String_val(path1));
+  p2 = caml_stat_strdup(String_val(path2));
   caml_enter_blocking_section();
   ret = link(p1, p2);
   caml_leave_blocking_section();

diff --git a/otherlibs/unix/mkdir.c b/otherlibs/unix/mkdir.c
index 93cb61cc9727bc891bba90403d50fc8d2497f674..0c1777816e42a9c0043edd33aa0131e63c97d857 100644 (file)
--- a/otherlibs/unix/mkdir.c
+++ b/otherlibs/unix/mkdir.c
@@ -26,7 +26,7 @@ CAMLprim value unix_mkdir(value path, value perm)
   char * p;
   int ret;
   caml_unix_check_path(path, "mkdir");
-  p = caml_strdup(String_val(path));
+  p = caml_stat_strdup(String_val(path));
   caml_enter_blocking_section();
   ret = mkdir(p, Int_val(perm));
   caml_leave_blocking_section();

diff --git a/otherlibs/unix/mkfifo.c b/otherlibs/unix/mkfifo.c
index 4b97c1c45bc42dd642fbc3f0e236c39aac26c99b..7914c877d1a02df39d1fe4a4e6785fea58efcb58 100644 (file)
--- a/otherlibs/unix/mkfifo.c
+++ b/otherlibs/unix/mkfifo.c
@@ -29,7 +29,7 @@ CAMLprim value unix_mkfifo(value path, value mode)
   char * p;
   int ret;
   caml_unix_check_path(path, "mkfifo");
-  p = caml_strdup(String_val(path));
+  p = caml_stat_strdup(String_val(path));
   caml_enter_blocking_section();
   ret = mkfifo(p, Int_val(mode));
   caml_leave_blocking_section();
@@ -52,7 +52,7 @@ CAMLprim value unix_mkfifo(value path, value mode)
   char * p;
   int ret;
   caml_unix_check_path(path, "mkfifo");
-  p = caml_strdup(String_val(path));
+  p = caml_stat_strdup(String_val(path));
   caml_enter_blocking_section();
   ret = mknod(p, (Int_val(mode) & 07777) | S_IFIFO, 0);
   caml_leave_blocking_section();

diff --git a/otherlibs/unix/mmap.c b/otherlibs/unix/mmap.c
new file mode 100644 (file)
index 0000000..e949f55
--- /dev/null
+++ b/otherlibs/unix/mmap.c
@@ -0,0 +1,227 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*          Manuel Serrano and Xavier Leroy, INRIA Rocquencourt           */
+/*                                                                        */
+/*   Copyright 2000 Institut National de Recherche en Informatique et     */
+/*     en Automatique.                                                    */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#define CAML_INTERNALS
+
+/* Needed (under Linux at least) to get pwrite's prototype in unistd.h.
+   Must be defined before the first system .h is included. */
+#define _XOPEN_SOURCE 600
+
+#include <stddef.h>
+#include "caml/bigarray.h"
+#include "caml/fail.h"
+#include "caml/io.h"
+#include "caml/mlvalues.h"
+#include "caml/signals.h"
+#include "caml/sys.h"
+#include "unixsupport.h"
+
+#include <errno.h>
+#ifdef HAS_UNISTD
+#include <unistd.h>
+#endif
+#ifdef HAS_MMAP
+#include <sys/types.h>
+#include <sys/mman.h>
+#include <sys/stat.h>
+#endif
+
+/* Temporary compatibility stuff so that this file can also be compiled
+   from otherlibs/bigarray/ and included in the bigarray library. */
+
+#ifdef IN_OCAML_BIGARRAY
+#define MAP_FILE_FUNCTION caml_ba_map_file
+#define MAP_FILE_FUNCTION_BYTECODE caml_ba_map_file_bytecode
+#define UNMAP_FILE_FUNCTION caml_ba_unmap_file
+#define ALLOC_FUNCTION caml_ba_mapped_alloc
+#define CAML_MAP_FILE "Bigarray.map_file"
+#define MAP_FILE_ERROR() caml_sys_error(NO_ARG)
+#else
+#define MAP_FILE_FUNCTION caml_unix_map_file
+#define MAP_FILE_FUNCTION_BYTECODE caml_unix_map_file_bytecode
+#define UNMAP_FILE_FUNCTION caml_unix_unmap_file
+#define ALLOC_FUNCTION caml_unix_mapped_alloc
+#define MAP_FILE_FUNCTION caml_unix_map_file
+#define CAML_MAP_FILE "Unix.map_file"
+#define MAP_FILE_ERROR() uerror("map_file", Nothing)
+#endif
+
+/* Defined in [mmap_ba.c] */
+CAMLextern value
+ALLOC_FUNCTION(int flags, int num_dims, void * data, intnat * dim);
+
+#if defined(HAS_MMAP)
+
+#ifndef MAP_FAILED
+#define MAP_FAILED ((void *) -1)
+#endif
+
+/* [caml_grow_file] function contributed by Gerd Stolpmann (PR#5543). */
+
+static int caml_grow_file(int fd, file_offset size)
+{
+  char c;
+  int p;
+
+  /* First use pwrite for growing - it is a conservative method, as it
+     can never happen that we shrink by accident
+   */
+#ifdef HAS_PWRITE
+  c = 0;
+  p = pwrite(fd, &c, 1, size - 1);
+#else
+
+  /* Emulate pwrite with lseek. This should only be necessary on ancient
+     systems nowadays
+   */
+  file_offset currpos;
+  currpos = lseek(fd, 0, SEEK_CUR);
+  if (currpos != -1) {
+    p = lseek(fd, size - 1, SEEK_SET);
+    if (p != -1) {
+      c = 0;
+      p = write(fd, &c, 1);
+      if (p != -1)
+        p = lseek(fd, currpos, SEEK_SET);
+    }
+  }
+  else p=-1;
+#endif
+#ifdef HAS_TRUNCATE
+  if (p == -1 && errno == ESPIPE) {
+    /* Plan B. Check if at least ftruncate is possible. There are
+       some non-seekable descriptor types that do not support pwrite
+       but ftruncate, like shared memory. We never get into this case
+       for real files, so there is no danger of truncating persistent
+       data by accident
+     */
+    p = ftruncate(fd, size);
+  }
+#endif
+  return p;
+}
+
+
+CAMLprim value MAP_FILE_FUNCTION(value vfd, value vkind, value vlayout,
+                                 value vshared, value vdim, value vstart)
+{
+  int fd, flags, major_dim, shared;
+  intnat num_dims, i;
+  intnat dim[CAML_BA_MAX_NUM_DIMS];
+  file_offset startpos, file_size, data_size;
+  struct stat st;
+  uintnat array_size, page, delta;
+  void * addr;
+
+  fd = Int_val(vfd);
+  flags = Caml_ba_kind_val(vkind) | Caml_ba_layout_val(vlayout);
+  startpos = File_offset_val(vstart);
+  num_dims = Wosize_val(vdim);
+  major_dim = flags & CAML_BA_FORTRAN_LAYOUT ? num_dims - 1 : 0;
+  /* Extract dimensions from OCaml array */
+  num_dims = Wosize_val(vdim);
+  if (num_dims < 1 || num_dims > CAML_BA_MAX_NUM_DIMS)
+    caml_invalid_argument(CAML_MAP_FILE ": bad number of dimensions");
+  for (i = 0; i < num_dims; i++) {
+    dim[i] = Long_val(Field(vdim, i));
+    if (dim[i] == -1 && i == major_dim) continue;
+    if (dim[i] < 0)
+      caml_invalid_argument(CAML_MAP_FILE ": negative dimension");
+  }
+  /* Determine file size. We avoid lseek here because it is fragile,
+     and because some mappable file types do not support it
+   */
+  caml_enter_blocking_section();
+  if (fstat(fd, &st) == -1) {
+    caml_leave_blocking_section();
+    MAP_FILE_ERROR();
+  }
+  file_size = st.st_size;
+  /* Determine array size in bytes (or size of array without the major
+     dimension if that dimension wasn't specified) */
+  array_size = caml_ba_element_size[flags & CAML_BA_KIND_MASK];
+  for (i = 0; i < num_dims; i++)
+    if (dim[i] != -1) array_size *= dim[i];
+  /* Check if the major dimension is unknown */
+  if (dim[major_dim] == -1) {
+    /* Determine major dimension from file size */
+    if (file_size < startpos) {
+      caml_leave_blocking_section();
+      caml_failwith(CAML_MAP_FILE ": file position exceeds file size");
+    }
+    data_size = file_size - startpos;
+    dim[major_dim] = (uintnat) (data_size / array_size);
+    array_size = dim[major_dim] * array_size;
+    if (array_size != data_size) {
+      caml_leave_blocking_section();
+      caml_failwith(CAML_MAP_FILE ": file size doesn't match array dimensions");
+    }
+  } else {
+    /* Check that file is large enough, and grow it otherwise */
+    if (file_size < startpos + array_size) {
+      if (caml_grow_file(fd, startpos + array_size) == -1) { /* PR#5543 */
+        caml_leave_blocking_section();
+        MAP_FILE_ERROR();
+      }
+    }
+  }
+  /* Determine offset so that the mapping starts at the given file pos */
+  page = sysconf(_SC_PAGESIZE);
+  delta = (uintnat) startpos % page;
+  /* Do the mmap */
+  shared = Bool_val(vshared) ? MAP_SHARED : MAP_PRIVATE;
+  if (array_size > 0)
+    addr = mmap(NULL, array_size + delta, PROT_READ | PROT_WRITE,
+                shared, fd, startpos - delta);
+  else
+    addr = NULL;                /* PR#5463 - mmap fails on empty region */
+  caml_leave_blocking_section();
+  if (addr == (void *) MAP_FAILED) MAP_FILE_ERROR();
+  addr = (void *) ((uintnat) addr + delta);
+  /* Build and return the OCaml bigarray */
+  return ALLOC_FUNCTION(flags, num_dims, addr, dim);
+}
+
+#else
+
+CAMLprim value MAP_FILE_FUNCTION(value vfd, value vkind, value vlayout,
+                                 value vshared, value vdim, value vpos)
+{
+  caml_invalid_argument("Unix.map_file: not supported");
+  return Val_unit;
+}
+
+#endif
+
+CAMLprim value MAP_FILE_FUNCTION_BYTECODE(value * argv, int argn)
+{
+  return MAP_FILE_FUNCTION(argv[0], argv[1], argv[2],
+                           argv[3], argv[4], argv[5]);
+}
+
+void UNMAP_FILE_FUNCTION(void * addr, uintnat len)
+{
+#if defined(HAS_MMAP)
+  uintnat page = sysconf(_SC_PAGESIZE);
+  uintnat delta = (uintnat) addr % page;
+  if (len == 0) return;         /* PR#5463 */
+  addr = (void *)((uintnat)addr - delta);
+  len  = len + delta;
+#if defined(_POSIX_SYNCHRONIZED_IO)
+  msync(addr, len, MS_ASYNC);   /* PR#3571 */
+#endif
+  munmap(addr, len);
+#endif
+}

diff --git a/otherlibs/unix/mmap_ba.c b/otherlibs/unix/mmap_ba.c
new file mode 100644 (file)
index 0000000..a9b227b
--- /dev/null
+++ b/otherlibs/unix/mmap_ba.c
@@ -0,0 +1,91 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*          Manuel Serrano and Xavier Leroy, INRIA Rocquencourt           */
+/*                                                                        */
+/*   Copyright 2000 Institut National de Recherche en Informatique et     */
+/*     en Automatique.                                                    */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#define CAML_INTERNALS
+
+#include "caml/alloc.h"
+#include "caml/bigarray.h"
+#include "caml/custom.h"
+#include "caml/memory.h"
+#include "caml/misc.h"
+
+/* Allocation of bigarrays for memory-mapped files.
+   This is the OS-independent part of [mmap.c]. */
+
+/* Temporary compatibility stuff so that this file can also be compiled
+   from otherlibs/bigarray/ and included in the bigarray library. */
+
+#ifdef IN_OCAML_BIGARRAY
+#define UNMAP_FILE_FUNCTION caml_ba_unmap_file
+#define ALLOC_FUNCTION caml_ba_mapped_alloc
+#else
+#define UNMAP_FILE_FUNCTION caml_unix_unmap_file
+#define ALLOC_FUNCTION caml_unix_mapped_alloc
+#endif
+
+CAMLextern void UNMAP_FILE_FUNCTION(void * addr, uintnat len);
+
+static void caml_ba_mapped_finalize(value v)
+{
+  struct caml_ba_array * b = Caml_ba_array_val(v);
+  CAMLassert(b->flags & CAML_BA_MANAGED_MASK == CAML_BA_MAPPED_FILE);
+  if (b->proxy == NULL) {
+    UNMAP_FILE_FUNCTION(b->data, caml_ba_byte_size(b));
+  } else {
+    if (-- b->proxy->refcount == 0) {
+      UNMAP_FILE_FUNCTION(b->proxy->data, b->proxy->size);
+      free(b->proxy);
+    }
+  }
+}
+
+/* Operation table for bigarrays representing memory-mapped files.
+   Only the finalization method differs from regular bigarrays. */
+
+static struct custom_operations caml_ba_mapped_ops = {
+  "_bigarray",
+  caml_ba_mapped_finalize,
+  caml_ba_compare,
+  caml_ba_hash,
+  caml_ba_serialize,
+  caml_ba_deserialize,
+  custom_compare_ext_default
+};
+
+/* [caml_ba_mapped_alloc] allocates a new bigarray object in the heap
+   corresponding to a memory-mapped file. */
+
+CAMLexport value
+ALLOC_FUNCTION(int flags, int num_dims, void * data, intnat * dim)
+{
+  uintnat asize;
+  int i;
+  value res;
+  struct caml_ba_array * b;
+  intnat dimcopy[CAML_BA_MAX_NUM_DIMS];
+
+  CAMLassert(num_dims >= 0 && num_dims <= CAML_BA_MAX_NUM_DIMS);
+  CAMLassert((flags & CAML_BA_KIND_MASK) <= CAML_BA_CHAR);
+  for (i = 0; i < num_dims; i++) dimcopy[i] = dim[i];
+  asize = SIZEOF_BA_ARRAY + num_dims * sizeof(intnat);
+  res = caml_alloc_custom(&caml_ba_mapped_ops, asize, 0, 1);
+  b = Caml_ba_array_val(res);
+  b->data = data;
+  b->num_dims = num_dims;
+  b->flags = flags | CAML_BA_MAPPED_FILE;
+  b->proxy = NULL;
+  for (i = 0; i < num_dims; i++) b->dim[i] = dimcopy[i];
+  return res;
+}

diff --git a/otherlibs/unix/open.c b/otherlibs/unix/open.c
index 1892d44c760ccc85f3f61f65a40f35b74dfe309e..859dbe446729ac097c51f639a5b910cdf2beddf3 100644 (file)
--- a/otherlibs/unix/open.c
+++ b/otherlibs/unix/open.c
@@ -73,7 +73,7 @@ CAMLprim value unix_open(value path, value flags, value perm)
 #if defined(O_CLOEXEC)
   if (cloexec) cv_flags |= O_CLOEXEC;
 #endif
-  p = caml_strdup(String_val(path));
+  p = caml_stat_strdup(String_val(path));
   /* open on a named FIFO can block (PR#1533) */
   caml_enter_blocking_section();
   fd = open(p, cv_flags, Int_val(perm));

diff --git a/otherlibs/unix/opendir.c b/otherlibs/unix/opendir.c
index 067cacc575b775584fbddb21567565083ba8f7f5..ead693d35277f86162515963b098258b83554571 100644 (file)
--- a/otherlibs/unix/opendir.c
+++ b/otherlibs/unix/opendir.c
@@ -33,7 +33,7 @@ CAMLprim value unix_opendir(value path)
   char * p;
 
   caml_unix_check_path(path, "opendir");
-  p = caml_strdup(String_val(path));
+  p = caml_stat_strdup(String_val(path));
   caml_enter_blocking_section();
   d = opendir(p);
   caml_leave_blocking_section();

diff --git a/otherlibs/unix/putenv.c b/otherlibs/unix/putenv.c
index f5709b699c515c51850dc21597155d0a03b422e4..76ec1b2d26a46c8331bd6d54136caec56bb2b86e 100644 (file)
--- a/otherlibs/unix/putenv.c
+++ b/otherlibs/unix/putenv.c
@@ -13,6 +13,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 #include <stdlib.h>
 #include <string.h>
 #include <errno.h>
@@ -20,6 +22,7 @@
 #include <caml/fail.h>
 #include <caml/memory.h>
 #include <caml/mlvalues.h>
+#include <caml/osdeps.h>
 
 #include "unixsupport.h"
 
@@ -27,19 +30,18 @@
 
 CAMLprim value unix_putenv(value name, value val)
 {
-  mlsize_t namelen = caml_string_length(name);
-  mlsize_t vallen = caml_string_length(val);
   char * s;
+  char_os * p;
+  int ret;
 
   if (! (caml_string_is_c_safe(name) && caml_string_is_c_safe(val)))
     unix_error(EINVAL, "putenv", name);
-  s = (char *) caml_stat_alloc(namelen + 1 + vallen + 1);
-  memmove (s, String_val(name), namelen);
-  s[namelen] = '=';
-  memmove (s + namelen + 1, String_val(val), vallen);
-  s[namelen + 1 + vallen] = 0;
-  if (putenv(s) == -1) {
-    caml_stat_free(s);
+  s = caml_stat_strconcat(3, name, "=", val);
+  p = caml_stat_strdup_to_os(s);
+  caml_stat_free(s);
+  ret = putenv_os(p);
+  if (ret == -1) {
+    caml_stat_free(p);
     uerror("putenv", name);
   }
   return Val_unit;

diff --git a/otherlibs/unix/readlink.c b/otherlibs/unix/readlink.c
index 4e9f04538e2c03e5f68af43f7de3deb854c3318f..05973e0eb5e39416cd361ddc75683a0cef070d85 100644 (file)
--- a/otherlibs/unix/readlink.c
+++ b/otherlibs/unix/readlink.c
@@ -39,7 +39,7 @@ CAMLprim value unix_readlink(value path)
   int len;
   char * p;
   caml_unix_check_path(path, "readlink");
-  p = caml_strdup(String_val(path));
+  p = caml_stat_strdup(String_val(path));
   caml_enter_blocking_section();
   len = readlink(p, buffer, sizeof(buffer) - 1);
   caml_leave_blocking_section();

diff --git a/otherlibs/unix/rename.c b/otherlibs/unix/rename.c
index bf13eab6f34ec13867b99970f91d9a877a45ac6a..c31e028b6233cb0870aff5e0b2bae83800a81f78 100644 (file)
--- a/otherlibs/unix/rename.c
+++ b/otherlibs/unix/rename.c
@@ -27,8 +27,8 @@ CAMLprim value unix_rename(value path1, value path2)
   int ret;
   caml_unix_check_path(path1, "rename");
   caml_unix_check_path(path2, "rename");
-  p1 = caml_strdup(String_val(path1));
-  p2 = caml_strdup(String_val(path2));
+  p1 = caml_stat_strdup(String_val(path1));
+  p2 = caml_stat_strdup(String_val(path2));
   caml_enter_blocking_section();
   ret = rename(p1, p2);
   caml_leave_blocking_section();

diff --git a/otherlibs/unix/rmdir.c b/otherlibs/unix/rmdir.c
index 9f9b4589eec0a04c00964a4c37a557efb6bb9d15..3405f193272799f41fa276fba897edbb1a7468bc 100644 (file)
--- a/otherlibs/unix/rmdir.c
+++ b/otherlibs/unix/rmdir.c
@@ -13,20 +13,23 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 #include <caml/mlvalues.h>
 #include <caml/memory.h>
 #include <caml/signals.h>
+#include <caml/osdeps.h>
 #include "unixsupport.h"
 
 CAMLprim value unix_rmdir(value path)
 {
   CAMLparam1(path);
-  char * p;
+  char_os * p;
   int ret;
   caml_unix_check_path(path, "rmdir");
-  p = caml_strdup(String_val(path));
+  p = caml_stat_strdup_to_os(String_val(path));
   caml_enter_blocking_section();
-  ret = rmdir(p);
+  ret = rmdir_os(p);
   caml_leave_blocking_section();
   caml_stat_free(p);
   if (ret == -1) uerror("rmdir", path);

diff --git a/otherlibs/unix/socketaddr.c b/otherlibs/unix/socketaddr.c
index 5f64021f316aab5599540dad5d68e754ce0da1ed..69fc52cc223b09d487f0fe5f61848e95dd33144b 100644 (file)
--- a/otherlibs/unix/socketaddr.c
+++ b/otherlibs/unix/socketaddr.c
@@ -35,8 +35,7 @@ CAMLexport value alloc_inet_addr(struct in_addr * a)
   /* Use a string rather than an abstract block so that it can be
      marshaled safely.  Remember that a is in network byte order,
      hence is marshaled in an endian-independent manner. */
-  res = caml_alloc_string(4);
-  memcpy(String_val(res), a, 4);
+  res = caml_alloc_initialized_string(4, (char *)a);
   return res;
 }
 
@@ -45,8 +44,7 @@ CAMLexport value alloc_inet_addr(struct in_addr * a)
 CAMLexport value alloc_inet6_addr(struct in6_addr * a)
 {
   value res;
-  res = caml_alloc_string(16);
-  memcpy(String_val(res), a, 16);
+  res = caml_alloc_initialized_string(16, (char *)a);
   return res;
 }
 
@@ -117,8 +115,7 @@ value alloc_sockaddr(union sock_addr_union * adr /*in*/,
       mlsize_t path_length =
         strnlen(adr->s_unix.sun_path,
                 adr_len - offsetof(struct sockaddr_un, sun_path));
-      n = caml_alloc_string(path_length);
-      memmove(String_val(n), adr->s_unix.sun_path, path_length);
+      n = caml_alloc_initialized_string(path_length, (char *)adr->s_unix.sun_path);
       Begin_root (n);
         res = caml_alloc_small(1, 0);
         Field(res,0) = n;

diff --git a/otherlibs/unix/stat.c b/otherlibs/unix/stat.c
index cd62dd0bbc80acfcfedc87dc8a0cd7092cf3662c..48d4a6bded02279ae04f6623e2a19e11a6871fce 100644 (file)
--- a/otherlibs/unix/stat.c
+++ b/otherlibs/unix/stat.c
@@ -85,7 +85,7 @@ CAMLprim value unix_stat(value path)
   struct stat buf;
   char * p;
   caml_unix_check_path(path, "stat");
-  p = caml_strdup(String_val(path));
+  p = caml_stat_strdup(String_val(path));
   caml_enter_blocking_section();
   ret = stat(p, &buf);
   caml_leave_blocking_section();
@@ -103,7 +103,7 @@ CAMLprim value unix_lstat(value path)
   struct stat buf;
   char * p;
   caml_unix_check_path(path, "lstat");
-  p = caml_strdup(String_val(path));
+  p = caml_stat_strdup(String_val(path));
   caml_enter_blocking_section();
 #ifdef HAS_SYMLINK
   ret = lstat(p, &buf);
@@ -138,7 +138,7 @@ CAMLprim value unix_stat_64(value path)
   struct stat buf;
   char * p;
   caml_unix_check_path(path, "stat");
-  p = caml_strdup(String_val(path));
+  p = caml_stat_strdup(String_val(path));
   caml_enter_blocking_section();
   ret = stat(p, &buf);
   caml_leave_blocking_section();
@@ -154,7 +154,7 @@ CAMLprim value unix_lstat_64(value path)
   struct stat buf;
   char * p;
   caml_unix_check_path(path, "lstat");
-  p = caml_strdup(String_val(path));
+  p = caml_stat_strdup(String_val(path));
   caml_enter_blocking_section();
 #ifdef HAS_SYMLINK
   ret = lstat(p, &buf);

diff --git a/otherlibs/unix/symlink.c b/otherlibs/unix/symlink.c
index 0bff3f6d7013d9670a2fd33a87f77e05fdb33a92..bbf3cfcb7a0c25c86415b286c8808870ea43bdc2 100644 (file)
--- a/otherlibs/unix/symlink.c
+++ b/otherlibs/unix/symlink.c
@@ -29,8 +29,8 @@ CAMLprim value unix_symlink(value to_dir, value path1, value path2)
   int ret;
   caml_unix_check_path(path1, "symlink");
   caml_unix_check_path(path2, "symlink");
-  p1 = caml_strdup(String_val(path1));
-  p2 = caml_strdup(String_val(path2));
+  p1 = caml_stat_strdup(String_val(path1));
+  p2 = caml_stat_strdup(String_val(path2));
   caml_enter_blocking_section();
   ret = symlink(p1, p2);
   caml_leave_blocking_section();

diff --git a/otherlibs/unix/truncate.c b/otherlibs/unix/truncate.c
index 4f333cbd9c13e97002ed2572c567f2edb2decf8b..e7c1f6cb4175902b380fcfa1fa622e5b5a74d5c6 100644 (file)
--- a/otherlibs/unix/truncate.c
+++ b/otherlibs/unix/truncate.c
@@ -34,7 +34,7 @@ CAMLprim value unix_truncate(value path, value len)
   char * p;
   int ret;
   caml_unix_check_path(path, "truncate");
-  p = caml_strdup(String_val(path));
+  p = caml_stat_strdup(String_val(path));
   caml_enter_blocking_section();
   ret = truncate(p, Long_val(len));
   caml_leave_blocking_section();
@@ -51,7 +51,7 @@ CAMLprim value unix_truncate_64(value path, value vlen)
   int ret;
   file_offset len = File_offset_val(vlen);
   caml_unix_check_path(path, "truncate");
-  p = caml_strdup(String_val(path));
+  p = caml_stat_strdup(String_val(path));
   caml_enter_blocking_section();
   ret = truncate(p, len);
   caml_leave_blocking_section();

diff --git a/otherlibs/unix/unix.ml b/otherlibs/unix/unix.ml
index fa7f90d1a3fdb5b20c3aa10945879bb04cb450f1..77a48d1f8ba6e8332e513a5caf5632414c2e9ff4 100644 (file)
--- a/otherlibs/unix/unix.ml
+++ b/otherlibs/unix/unix.ml
@@ -186,8 +186,9 @@ let handle_unix_error f arg =
     exit 2
 
 external environment : unit -> string array = "unix_environment"
+external unsafe_environment : unit -> string array = "unix_environment_unsafe"
 external getenv: string -> string = "caml_sys_getenv"
-(* external unsafe_getenv: string -> string = "caml_sys_unsafe_getenv" *)
+external unsafe_getenv: string -> string = "caml_sys_unsafe_getenv"
 external putenv: string -> string -> unit = "unix_putenv"
 
 type process_status =
@@ -202,7 +203,68 @@ type wait_flag =
 external execv : string -> string array -> 'a = "unix_execv"
 external execve : string -> string array -> string array -> 'a = "unix_execve"
 external execvp : string -> string array -> 'a = "unix_execvp"
-external execvpe : string -> string array -> string array -> 'a = "unix_execvpe"
+external execvpe_c :
+            string -> string array -> string array -> 'a = "unix_execvpe"
+
+let execvpe_ml name args env =
+  (* Try to execute the given file *)
+  let exec file =
+    try
+      execve file args env
+    with Unix_error(ENOEXEC, _, _) ->
+      (* Assume this is a script and try to execute through the shell *)
+      let argc = Array.length args in
+      (* Drop the original args.(0) if it is there *)
+      let new_args = Array.append
+        [| "/bin/sh"; file |]
+        (if argc = 0 then args else Array.sub args 1 (argc - 1)) in
+      execve new_args.(0) new_args env in
+  (* Try each path element in turn *)
+  let rec scan_dir eacces = function
+  | [] ->
+      (* No matching file was found (if [eacces = false]) or
+         a matching file was found but we got a "permission denied"
+         error while trying to execute it (if [eacces = true]).
+         Raise the error appropriate to each case. *)
+      raise (Unix_error((if eacces then EACCES else ENOENT),
+                        "execvpe", name))
+  | dir :: rem ->
+      let dir =  (* an empty path element means the current directory *)
+        if dir = "" then Filename.current_dir_name else dir in
+      try
+        exec (Filename.concat dir name)
+      with Unix_error(err, _, _) as exn ->
+        match err with
+        (* The following errors are treated as nonfatal, meaning that
+           we will ignore them and continue searching in the path.
+           Among those errors, EACCES is recorded specially so as
+           to produce the correct exception in the end.
+           To determine which errors are nonfatal, we looked at the
+           execvpe() sources in Glibc and in OpenBSD. *)
+        | EACCES ->
+            scan_dir true rem
+        | EISDIR|ELOOP|ENAMETOOLONG|ENODEV|ENOENT|ENOTDIR|ETIMEDOUT ->
+            scan_dir eacces rem
+        (* Other errors, e.g. E2BIG, are fatal and abort the search. *)
+        | _ ->
+            raise exn in
+  if String.contains name '/' then
+    (* If the command name contains "/" characters, don't search in path *)
+    exec name
+  else
+    (* Split path into elements and search in these elements *)
+    (try unsafe_getenv "PATH" with Not_found -> "/bin:/usr/bin")
+    |> String.split_on_char ':'
+    |> scan_dir false
+      (* [unsafe_getenv] and not [getenv] to be consistent with [execvp],
+         which looks up the PATH environment variable whether SUID or not. *)
+
+let execvpe name args env =
+  try  
+    execvpe_c name args env
+  with Unix_error(ENOSYS, _, _) ->
+    execvpe_ml name args env
+
 external fork : unit -> int = "unix_fork"
 external wait : unit -> int * process_status = "unix_wait"
 external waitpid : wait_flag list -> int -> int * process_status
@@ -343,6 +405,16 @@ module LargeFile =
     external fstat : file_descr -> stats = "unix_fstat_64"
   end
 
+external map_internal:
+   file_descr -> ('a, 'b) CamlinternalBigarray.kind
+              -> 'c CamlinternalBigarray.layout
+              -> bool -> int array -> int64
+              -> ('a, 'b, 'c) CamlinternalBigarray.genarray
+     = "caml_unix_map_file_bytecode" "caml_unix_map_file"
+
+let map_file fd ?(pos=0L) kind layout shared dims =
+  map_internal fd kind layout shared dims pos
+
 type access_permission =
     R_OK
   | W_OK

diff --git a/otherlibs/unix/unix.mli b/otherlibs/unix/unix.mli
index e414be00b38c6dd966f4cd687c164b86ef7867a9..bf968126a52b6a69c8a0f337ff42f8b91eb7a0e3 100644 (file)
--- a/otherlibs/unix/unix.mli
+++ b/otherlibs/unix/unix.mli
@@ -20,7 +20,7 @@
     exception whenever the underlying system call signals an error. *)
 
 
-(** {6 Error report} *)
+(** {1 Error report} *)
 
 
 type error =
@@ -116,12 +116,22 @@ val handle_unix_error : ('a -> 'b) -> 'a -> 'b
    describing the error and exits with code 2. *)
 
 
-(** {6 Access to the process environment} *)
+(** {1 Access to the process environment} *)
 
 
 val environment : unit -> string array
 (** Return the process environment, as an array of strings
-    with the format ``variable=value''. *)
+    with the format ``variable=value''.  The returned array
+    is empty if the process has special privileges. *)
+
+val unsafe_environment : unit -> string array
+(** Return the process environment, as an array of strings with the
+    format ``variable=value''.  Unlike {!environment}, this function
+    returns a populated array even if the process has special
+    privileges.  See the documentation for {!unsafe_getenv} for more
+    details.
+
+    @since 4.06.0 *)
 
 val getenv : string -> string
 (** Return the value associated to a variable in the process
@@ -131,7 +141,6 @@ val getenv : string -> string
 
    (This function is identical to {!Sys.getenv}. *)
 
-(*
 val unsafe_getenv : string -> string
 (** Return the value associated to a variable in the process
    environment.
@@ -143,8 +152,8 @@ val unsafe_getenv : string -> string
    for executables, the locations for temporary files or logs, and the
    like.
 
-   @raise Not_found if the variable is unbound.  *)
-*)
+   @raise Not_found if the variable is unbound.
+   @since 4.06.0  *)
 
 val putenv : string -> string -> unit
 (** [Unix.putenv name value] sets the value associated to a
@@ -153,7 +162,7 @@ val putenv : string -> string -> unit
    and [value] its new associated value. *)
 
 
-(** {6 Process handling} *)
+(** {1 Process handling} *)
 
 
 type process_status =
@@ -244,7 +253,7 @@ val nice : int -> int
    On Windows: not implemented. *)
 
 
-(** {6 Basic file input/output} *)
+(** {1 Basic file input/output} *)
 
 
 type file_descr
@@ -325,7 +334,7 @@ val single_write_substring : file_descr -> string -> int -> int -> int
     a byte sequence.
     @since 4.02.0 *)
 
-(** {6 Interfacing with the standard input/output library} *)
+(** {1 Interfacing with the standard input/output library} *)
 
 
 
@@ -371,7 +380,7 @@ val descr_of_out_channel : out_channel -> file_descr
 (** Return the descriptor corresponding to an output channel. *)
 
 
-(** {6 Seeking and truncating} *)
+(** {1 Seeking and truncating} *)
 
 
 type seek_command =
@@ -397,7 +406,7 @@ val ftruncate : file_descr -> int -> unit
   On Windows: not implemented. *)
 
 
-(** {6 File status} *)
+(** {1 File status} *)
 
 
 type file_kind =
@@ -440,7 +449,7 @@ val isatty : file_descr -> bool
 (** Return [true] if the given file descriptor refers to a terminal or
    console window, [false] otherwise. *)
 
-(** {6 File operations on large files} *)
+(** {1 File operations on large files} *)
 
 module LargeFile :
   sig
@@ -481,7 +490,60 @@ module LargeFile :
   regular integers (type [int]), thus allowing operating on files
   whose sizes are greater than [max_int]. *)
 
-(** {6 Operations on file names} *)
+(** {6 Mapping files into memory} *)
+
+val map_file :
+  file_descr -> ?pos:int64 -> ('a, 'b) CamlinternalBigarray.kind ->
+  'c CamlinternalBigarray.layout -> bool -> int array ->
+  ('a, 'b, 'c) CamlinternalBigarray.genarray
+(** Memory mapping of a file as a big array.
+  [map_file fd kind layout shared dims]
+  returns a big array of kind [kind], layout [layout],
+  and dimensions as specified in [dims].  The data contained in
+  this big array are the contents of the file referred to by
+  the file descriptor [fd] (as opened previously with
+  [Unix.openfile], for example).  The optional [pos] parameter
+  is the byte offset in the file of the data being mapped;
+  it defaults to 0 (map from the beginning of the file).
+
+  If [shared] is [true], all modifications performed on the array
+  are reflected in the file.  This requires that [fd] be opened
+  with write permissions.  If [shared] is [false], modifications
+  performed on the array are done in memory only, using
+  copy-on-write of the modified pages; the underlying file is not
+  affected.
+
+  [Genarray.map_file] is much more efficient than reading
+  the whole file in a big array, modifying that big array,
+  and writing it afterwards.
+
+  To adjust automatically the dimensions of the big array to
+  the actual size of the file, the major dimension (that is,
+  the first dimension for an array with C layout, and the last
+  dimension for an array with Fortran layout) can be given as
+  [-1].  [Genarray.map_file] then determines the major dimension
+  from the size of the file.  The file must contain an integral
+  number of sub-arrays as determined by the non-major dimensions,
+  otherwise [Failure] is raised.
+
+  If all dimensions of the big array are given, the file size is
+  matched against the size of the big array.  If the file is larger
+  than the big array, only the initial portion of the file is
+  mapped to the big array.  If the file is smaller than the big
+  array, the file is automatically grown to the size of the big array.
+  This requires write permissions on [fd].
+
+  Array accesses are bounds-checked, but the bounds are determined by
+  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 shrunk.
+
+  [Invalid_argument] or [Failure] may be raised in cases where argument
+  validation fails.
+  @since 4.06.0 *)
+
+(** {1 Operations on file names} *)
 
 
 val unlink : string -> unit
@@ -495,14 +557,19 @@ val unlink : string -> unit
 *)
 
 val rename : string -> string -> unit
-(** [rename old new] changes the name of a file from [old] to [new]. *)
+(** [rename old new] changes the name of a file from [old] to [new],
+    moving it between directories if needed.  If [new] already
+    exists, its contents will be replaced with those of [old].
+    Depending on the operating system, the metadata (permissions,
+    owner, etc) of [new] can either be preserved or be replaced by
+    those of [old].  *)
 
 val link : string -> string -> unit
 (** [link source dest] creates a hard link named [dest] to the file
    named [source]. *)
 
 
-(** {6 File permissions and ownership} *)
+(** {1 File permissions and ownership} *)
 
 
 type access_permission =
@@ -541,7 +608,7 @@ val access : string -> access_permission list -> unit
    tests for read permission instead. *)
 
 
-(** {6 Operations on file descriptors} *)
+(** {1 Operations on file descriptors} *)
 
 
 val dup : ?cloexec:bool -> file_descr -> file_descr
@@ -620,7 +687,7 @@ val clear_close_on_exec : file_descr -> unit
    See {!Unix.set_close_on_exec}.*)
 
 
-(** {6 Directories} *)
+(** {1 Directories} *)
 
 
 val mkdir : string -> file_perm -> unit
@@ -657,7 +724,7 @@ val closedir : dir_handle -> unit
 
 
 
-(** {6 Pipes and redirections} *)
+(** {1 Pipes and redirections} *)
 
 
 val pipe : ?cloexec:bool -> unit -> file_descr * file_descr
@@ -672,7 +739,7 @@ val mkfifo : string -> file_perm -> unit
    On Windows: not implemented. *)
 
 
-(** {6 High-level process and redirection management} *)
+(** {1 High-level process and redirection management} *)
 
 
 val create_process :
@@ -749,7 +816,7 @@ val close_process_full :
    and return its termination status. *)
 
 
-(** {6 Symbolic links} *)
+(** {1 Symbolic links} *)
 
 
 val symlink : ?to_dir:bool -> string -> string -> unit
@@ -795,7 +862,7 @@ val readlink : string -> string
 (** Read the contents of a symbolic link. *)
 
 
-(** {6 Polling} *)
+(** {1 Polling} *)
 
 
 val select :
@@ -813,7 +880,7 @@ val select :
    component). *)
 
 
-(** {6 Locking} *)
+(** {1 Locking} *)
 
 type lock_command =
     F_ULOCK       (** Unlock a region *)
@@ -858,7 +925,7 @@ val lockf : file_descr -> lock_command -> int -> unit
 *)
 
 
-(** {6 Signals}
+(** {1 Signals}
    Note: installation of signal handlers is performed via
    the functions {!Sys.signal} and {!Sys.set_signal}.
 *)
@@ -903,7 +970,7 @@ val pause : unit -> unit
   On Windows: not implemented (no inter-process signals on Windows). *)
 
 
-(** {6 Time functions} *)
+(** {1 Time functions} *)
 
 
 type process_times =
@@ -1019,7 +1086,7 @@ val setitimer :
    On Windows: not implemented. *)
 
 
-(** {6 User id, group id} *)
+(** {1 User id, group id} *)
 
 
 val getuid : unit -> int
@@ -1110,7 +1177,7 @@ val getgrgid : int -> group_entry
    On Windows, always raise [Not_found]. *)
 
 
-(** {6 Internet addresses} *)
+(** {1 Internet addresses} *)
 
 
 type inet_addr
@@ -1144,7 +1211,7 @@ val inet6_addr_loopback : inet_addr
 (** A special IPv6 address representing the host machine ([::1]). *)
 
 
-(** {6 Sockets} *)
+(** {1 Sockets} *)
 
 
 type socket_domain =
@@ -1262,7 +1329,7 @@ val sendto_substring :
     @since 4.02.0 *)
 
 
-(** {6 Socket options} *)
+(** {1 Socket options} *)
 
 
 type socket_bool_option =
@@ -1342,7 +1409,7 @@ val getsockopt_error : file_descr -> error option
     and clear it. *)
 
 
-(** {6 High-level network connection functions} *)
+(** {1 High-level network connection functions} *)
 
 
 val open_connection : sockaddr -> in_channel * out_channel
@@ -1368,7 +1435,7 @@ val establish_server : (in_channel -> out_channel -> unit) -> sockaddr -> unit
    On Windows, it is not implemented.  Use threads. *)
 
 
-(** {6 Host and protocol databases} *)
+(** {1 Host and protocol databases} *)
 
 
 type host_entry =
@@ -1483,7 +1550,7 @@ val getnameinfo : sockaddr -> getnameinfo_option list -> name_info
     @raise Not_found if an error occurs. *)
 
 
-(** {6 Terminal interface} *)
+(** {1 Terminal interface} *)
 
 
 (** The following functions implement the POSIX standard terminal

diff --git a/otherlibs/unix/unixLabels.mli b/otherlibs/unix/unixLabels.mli
index f1e68061f7358c2194c9419e4a8643bba50f2bf7..08b388b3bd2d000c5d6b699f4788bce1df0641ff 100644 (file)
--- a/otherlibs/unix/unixLabels.mli
+++ b/otherlibs/unix/unixLabels.mli
@@ -18,7 +18,7 @@
    add [module Unix = UnixLabels] in your implementation.
 *)
 
-(** {6 Error report} *)
+(** {1 Error report} *)
 
 
 type error = Unix.error =
@@ -114,7 +114,7 @@ val handle_unix_error : ('a -> 'b) -> 'a -> 'b
    describing the error and exits with code 2. *)
 
 
-(** {6 Access to the process environment} *)
+(** {1 Access to the process environment} *)
 
 
 val environment : unit -> string array
@@ -126,7 +126,6 @@ val getenv : string -> string
    environment. Raise [Not_found] if the variable is unbound.
    (This function is identical to [Sys.getenv].) *)
 
-(*
 val unsafe_getenv : string -> string
 (** Return the value associated to a variable in the process
    environment.
@@ -138,8 +137,8 @@ val unsafe_getenv : string -> string
    for executables, the locations for temporary files or logs, and the
    like.
 
-   @raise Not_found if the variable is unbound.  *)
-*)
+   @raise Not_found if the variable is unbound.
+   @since 4.06.0  *)
 
 val putenv : string -> string -> unit
 (** [Unix.putenv name value] sets the value associated to a
@@ -148,7 +147,7 @@ val putenv : string -> string -> unit
    and [value] its new associated value. *)
 
 
-(** {6 Process handling} *)
+(** {1 Process handling} *)
 
 
 type process_status = Unix.process_status =
@@ -228,7 +227,7 @@ val nice : int -> int
    lower priorities.) Return the new nice value. *)
 
 
-(** {6 Basic file input/output} *)
+(** {1 Basic file input/output} *)
 
 
 type file_descr = Unix.file_descr
@@ -308,7 +307,7 @@ val single_write_substring :
     a byte sequence.
     @since 4.02.0 *)
 
-(** {6 Interfacing with the standard input/output library} *)
+(** {1 Interfacing with the standard input/output library} *)
 
 
 
@@ -329,7 +328,7 @@ val descr_of_out_channel : out_channel -> file_descr
 (** Return the descriptor corresponding to an output channel. *)
 
 
-(** {6 Seeking and truncating} *)
+(** {1 Seeking and truncating} *)
 
 
 type seek_command = Unix.seek_command =
@@ -351,7 +350,7 @@ val ftruncate : file_descr -> len:int -> unit
    to the given size. *)
 
 
-(** {6 File status} *)
+(** {1 File status} *)
 
 
 type file_kind = Unix.file_kind =
@@ -394,7 +393,7 @@ val isatty : file_descr -> bool
 (** Return [true] if the given file descriptor refers to a terminal or
    console window, [false] otherwise. *)
 
-(** {6 File operations on large files} *)
+(** {1 File operations on large files} *)
 
 module LargeFile :
   sig
@@ -431,7 +430,60 @@ module LargeFile :
   whose sizes are greater than [max_int]. *)
 
 
-(** {6 Operations on file names} *)
+(** {1 Mapping files into memory} *)
+
+val map_file :
+  file_descr -> ?pos:int64 -> kind:('a, 'b) CamlinternalBigarray.kind ->
+  layout:'c CamlinternalBigarray.layout -> shared:bool -> dims:int array ->
+  ('a, 'b, 'c) CamlinternalBigarray.genarray
+(** Memory mapping of a file as a big array.
+  [map_file fd kind layout shared dims]
+  returns a big array of kind [kind], layout [layout],
+  and dimensions as specified in [dims].  The data contained in
+  this big array are the contents of the file referred to by
+  the file descriptor [fd] (as opened previously with
+  [Unix.openfile], for example).  The optional [pos] parameter
+  is the byte offset in the file of the data being mapped;
+  it defaults to 0 (map from the beginning of the file).
+
+  If [shared] is [true], all modifications performed on the array
+  are reflected in the file.  This requires that [fd] be opened
+  with write permissions.  If [shared] is [false], modifications
+  performed on the array are done in memory only, using
+  copy-on-write of the modified pages; the underlying file is not
+  affected.
+
+  [Genarray.map_file] is much more efficient than reading
+  the whole file in a big array, modifying that big array,
+  and writing it afterwards.
+
+  To adjust automatically the dimensions of the big array to
+  the actual size of the file, the major dimension (that is,
+  the first dimension for an array with C layout, and the last
+  dimension for an array with Fortran layout) can be given as
+  [-1].  [Genarray.map_file] then determines the major dimension
+  from the size of the file.  The file must contain an integral
+  number of sub-arrays as determined by the non-major dimensions,
+  otherwise [Failure] is raised.
+
+  If all dimensions of the big array are given, the file size is
+  matched against the size of the big array.  If the file is larger
+  than the big array, only the initial portion of the file is
+  mapped to the big array.  If the file is smaller than the big
+  array, the file is automatically grown to the size of the big array.
+  This requires write permissions on [fd].
+
+  Array accesses are bounds-checked, but the bounds are determined by
+  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 shrunk.
+
+  [Invalid_argument] or [Failure] may be raised in cases where argument
+  validation fails.
+  @since 4.06.0 *)
+
+(** {1 Operations on file names} *)
 
 
 val unlink : string -> unit
@@ -445,7 +497,7 @@ val link : src:string -> dst:string -> unit
    named [source]. *)
 
 
-(** {6 File permissions and ownership} *)
+(** {1 File permissions and ownership} *)
 
 
 type access_permission = Unix.access_permission =
@@ -477,7 +529,7 @@ val access : string -> perm:access_permission list -> unit
    file. Raise [Unix_error] otherwise. *)
 
 
-(** {6 Operations on file descriptors} *)
+(** {1 Operations on file descriptors} *)
 
 
 val dup : ?cloexec:bool -> file_descr -> file_descr
@@ -511,7 +563,7 @@ val clear_close_on_exec : file_descr -> unit
    See {!UnixLabels.set_close_on_exec}.*)
 
 
-(** {6 Directories} *)
+(** {1 Directories} *)
 
 
 val mkdir : string -> perm:file_perm -> unit
@@ -547,7 +599,7 @@ val closedir : dir_handle -> unit
 
 
 
-(** {6 Pipes and redirections} *)
+(** {1 Pipes and redirections} *)
 
 
 val pipe : ?cloexec:bool -> unit -> file_descr * file_descr
@@ -559,7 +611,7 @@ val mkfifo : string -> perm:file_perm -> unit
 (** Create a named pipe with the given permissions. *)
 
 
-(** {6 High-level process and redirection management} *)
+(** {1 High-level process and redirection management} *)
 
 
 val create_process :
@@ -636,7 +688,7 @@ val close_process_full :
    and return its termination status. *)
 
 
-(** {6 Symbolic links} *)
+(** {1 Symbolic links} *)
 
 
 val symlink : ?to_dir:bool -> src:string -> dst:string -> unit
@@ -654,7 +706,7 @@ val readlink : string -> string
 (** Read the contents of a link. *)
 
 
-(** {6 Polling} *)
+(** {1 Polling} *)
 
 
 val select :
@@ -671,7 +723,7 @@ val select :
    and over which an exceptional condition is pending (third
    component). *)
 
-(** {6 Locking} *)
+(** {1 Locking} *)
 
 
 type lock_command = Unix.lock_command =
@@ -710,7 +762,7 @@ val lockf : file_descr -> mode:lock_command -> len:int -> unit
    It returns immediately if successful, or fails otherwise. *)
 
 
-(** {6 Signals}
+(** {1 Signals}
    Note: installation of signal handlers is performed via
    the functions {!Sys.signal} and {!Sys.set_signal}.
 *)
@@ -746,7 +798,7 @@ val pause : unit -> unit
 (** Wait until a non-ignored, non-blocked signal is delivered. *)
 
 
-(** {6 Time functions} *)
+(** {1 Time functions} *)
 
 
 type process_times = Unix.process_times =
@@ -845,7 +897,7 @@ val setitimer :
    after its next expiration. *)
 
 
-(** {6 User id, group id} *)
+(** {1 User id, group id} *)
 
 
 val getuid : unit -> int
@@ -919,7 +971,7 @@ val getgrgid : int -> group_entry
    [Not_found]. *)
 
 
-(** {6 Internet addresses} *)
+(** {1 Internet addresses} *)
 
 
 type inet_addr = Unix.inet_addr
@@ -953,7 +1005,7 @@ val inet6_addr_loopback : inet_addr
 (** A special IPv6 address representing the host machine ([::1]). *)
 
 
-(** {6 Sockets} *)
+(** {1 Sockets} *)
 
 
 type socket_domain = Unix.socket_domain =
@@ -1070,7 +1122,7 @@ val sendto_substring :
 
 
 
-(** {6 Socket options} *)
+(** {1 Socket options} *)
 
 
 type socket_bool_option =
@@ -1148,7 +1200,7 @@ val getsockopt_error : file_descr -> error option
 (** Return the error condition associated with the given socket,
     and clear it. *)
 
-(** {6 High-level network connection functions} *)
+(** {1 High-level network connection functions} *)
 
 
 val open_connection : sockaddr -> in_channel * out_channel
@@ -1171,7 +1223,7 @@ val establish_server :
    never returns normally. *)
 
 
-(** {6 Host and protocol databases} *)
+(** {1 Host and protocol databases} *)
 
 
 type host_entry = Unix.host_entry =
@@ -1286,7 +1338,7 @@ val getnameinfo : sockaddr -> getnameinfo_option list -> name_info
     Raise [Not_found] if an error occurs. *)
 
 
-(** {6 Terminal interface} *)
+(** {1 Terminal interface} *)
 
 
 (** The following functions implement the POSIX standard terminal

diff --git a/otherlibs/unix/unixsupport.c b/otherlibs/unix/unixsupport.c
index b3ff8a4bf8a8e0cf273ac5045bd2d62ba7610121..9bbb9343d60effcf638a9784e9198550ea5918d2 100644 (file)
--- a/otherlibs/unix/unixsupport.c
+++ b/otherlibs/unix/unixsupport.c
@@ -285,7 +285,7 @@ extern int code_of_unix_error (value error)
   }
 }
 
-void unix_error(int errcode, char *cmdname, value cmdarg)
+void unix_error(int errcode, const char *cmdname, value cmdarg)
 {
   value res;
   value name = Val_unit, err = Val_unit, arg = Val_unit;
@@ -309,12 +309,12 @@ void unix_error(int errcode, char *cmdname, value cmdarg)
   caml_raise(res);
 }
 
-void uerror(char *cmdname, value cmdarg)
+void uerror(const char *cmdname, value cmdarg)
 {
   unix_error(errno, cmdname, cmdarg);
 }
 
-void caml_unix_check_path(value path, char * cmdname)
+void caml_unix_check_path(value path, const char * cmdname)
 {
   if (! caml_string_is_c_safe(path)) unix_error(ENOENT, cmdname, path);
 }

diff --git a/otherlibs/unix/unixsupport.h b/otherlibs/unix/unixsupport.h
index 41698e648f02cd49f6ac92a6af67374c6ebb18cb..fe345466de7f4a85e48b569cf26cf92c3e605c67 100644 (file)
--- a/otherlibs/unix/unixsupport.h
+++ b/otherlibs/unix/unixsupport.h
@@ -30,20 +30,21 @@ extern value unix_error_of_code (int errcode);
 extern int code_of_unix_error (value error);
 
 CAMLnoreturn_start
-extern void unix_error (int errcode, char * cmdname, value arg)
+extern void unix_error (int errcode, const char * cmdname, value arg)
 CAMLnoreturn_end;
 
 CAMLnoreturn_start
-extern void uerror (char * cmdname, value arg)
+extern void uerror (const char * cmdname, value arg)
 CAMLnoreturn_end;
 
-extern void caml_unix_check_path(value path, char * cmdname);
+extern void caml_unix_check_path(value path, const char * cmdname);
 
 #define UNIX_BUFFER_SIZE 65536
 
 #define DIR_Val(v) *((DIR **) &Field(v, 0))
 
 extern char ** cstringvect(value arg, char * cmdname);
+extern void cstringvect_free(char **);
 
 extern int unix_cloexec_default;
 extern int unix_cloexec_p(value cloexec);
@@ -54,4 +55,6 @@ extern void unix_clear_cloexec(int fd, char * cmdname, value arg);
 }
 #endif
 
+#define EXECV_CAST
+
 #endif /* CAML_UNIXSUPPORT_H */

diff --git a/otherlibs/unix/unlink.c b/otherlibs/unix/unlink.c
index c06dd3632aaef3fcf9f3632e298ded768a26b5d9..578125f58b58c73913de52fa64508820d5b36416 100644 (file)
--- a/otherlibs/unix/unlink.c
+++ b/otherlibs/unix/unlink.c
@@ -13,20 +13,23 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 #include <caml/mlvalues.h>
 #include <caml/memory.h>
 #include <caml/signals.h>
+#include <caml/osdeps.h>
 #include "unixsupport.h"
 
 CAMLprim value unix_unlink(value path)
 {
   CAMLparam1(path);
-  char * p;
+  char_os * p;
   int ret;
   caml_unix_check_path(path, "unlink");
-  p = caml_strdup(String_val(path));
+  p = caml_stat_strdup_to_os(String_val(path));
   caml_enter_blocking_section();
-  ret = unlink(p);
+  ret = unlink_os(p);
   caml_leave_blocking_section();
   caml_stat_free(p);
   if (ret == -1) uerror("unlink", path);

diff --git a/otherlibs/unix/utimes.c b/otherlibs/unix/utimes.c
index f60fbbcecd044df34e05ac6afc9615133d56a8b5..e90555b883b53657e8fb1c35085fdc541ad49c41 100644 (file)
--- a/otherlibs/unix/utimes.c
+++ b/otherlibs/unix/utimes.c
@@ -13,10 +13,13 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 #include <caml/fail.h>
 #include <caml/mlvalues.h>
 #include <caml/memory.h>
 #include <caml/signals.h>
+#include <caml/osdeps.h>
 #include "unixsupport.h"
 
 #if defined(HAS_UTIMES)
@@ -43,7 +46,7 @@ CAMLprim value unix_utimes(value path, value atime, value mtime)
     tv[1].tv_usec = (mt - tv[1].tv_sec) * 1000000;
     t = tv;
   }
-  p = caml_strdup(String_val(path));
+  p = caml_stat_strdup(String_val(path));
   caml_enter_blocking_section();
   ret = utimes(p, t);
   caml_leave_blocking_section();
@@ -64,23 +67,27 @@ CAMLprim value unix_utimes(value path, value atime, value mtime)
 CAMLprim value unix_utimes(value path, value atime, value mtime)
 {
   CAMLparam3(path, atime, mtime);
+#ifdef _WIN32
+  struct _utimbuf times, * t;
+#else
   struct utimbuf times, * t;
-  char * p;
+#endif
+  char_os * p;
   int ret;
   double at, mt;
   caml_unix_check_path(path, "utimes");
   at = Double_val(atime);
   mt = Double_val(mtime);
   if (at == 0.0 && mt == 0.0) {
-    t = (struct utimbuf *) NULL;
+    t = NULL;
   } else {
     times.actime = at;
     times.modtime = mt;
     t = &times;
   }
-  p = caml_strdup(String_val(path));
+  p = caml_stat_strdup_to_os(String_val(path));
   caml_enter_blocking_section();
-  ret = utime(p, t);
+  ret = utime_os(p, t);
   caml_leave_blocking_section();
   caml_stat_free(p);
   if (ret == -1) uerror("utimes", path);

diff --git a/otherlibs/win32graph/Makefile b/otherlibs/win32graph/Makefile
index 244820bae7212501825dbfcd05748c891aac633d..85d683c54a70e07b67b512248afb35f1979446e9 100644 (file)
--- a/otherlibs/win32graph/Makefile
+++ b/otherlibs/win32graph/Makefile
@@ -27,6 +27,7 @@ graphics.ml: ../graph/graphics.ml
 graphics.mli: ../graph/graphics.mli
        cp ../graph/graphics.mli graphics.mli
 
+.PHONY:
 depend:
 
 graphics.cmo: graphics.cmi

diff --git a/otherlibs/win32graph/draw.c b/otherlibs/win32graph/draw.c
index 209b76a6dc8bded22537ec7a8e599f9e8dfef89c..d33d12b616cd03c5ff2a0e1a17a09bfbdcfc3db6 100644 (file)
--- a/otherlibs/win32graph/draw.c
+++ b/otherlibs/win32graph/draw.c
@@ -116,10 +116,10 @@ CAMLprim value caml_gr_draw_text(value text,value x)
         SetTextAlign(grwindow.gcBitmap, TA_UPDATECP|TA_BOTTOM);
         SetTextAlign(grwindow.gc, TA_UPDATECP|TA_BOTTOM);
         if (grremember_mode) {
-                TextOut(grwindow.gcBitmap,0,0,(char *)text,x);
+                TextOutA(grwindow.gcBitmap,0,0,String_val(text),x);
         }
         if(grdisplay_mode) {
-                TextOut(grwindow.gc,0,0,(char *)text,x);
+                TextOutA(grwindow.gc,0,0,String_val(text),x);
         }
         GetCurrentPosition(grwindow.gc,&pt);
         grwindow.grx = pt.x;
@@ -185,7 +185,7 @@ CAMLprim value caml_gr_circle(value x,value y,value radius)
 
 CAMLprim value caml_gr_set_window_title(value text)
 {
-        SetWindowText(grwindow.hwnd,(char *)text);
+        SetWindowTextA(grwindow.hwnd,(char *)text);
         return Val_unit;
 }
 
@@ -370,7 +370,7 @@ CAMLprim value caml_gr_text_size(value str)
         mlsize_t len = caml_string_length(str);
         if (len > 32767) len = 32767;
 
-        GetTextExtentPoint(grwindow.gc,String_val(str), len,&extent);
+        GetTextExtentPointA(grwindow.gc,String_val(str), len,&extent);
 
         res = caml_alloc_tuple(2);
         Field(res, 0) = Val_long(extent.cx);
@@ -387,7 +387,7 @@ CAMLprim value caml_gr_fill_poly(value vect)
         if (n_points < 3)
                 gr_fail("fill_poly: not enough points",0);
 
-        poly = (POINT *)malloc(n_points*sizeof(POINT));
+        poly = (POINT *)caml_stat_alloc(n_points*sizeof(POINT));
 
         p = poly;
         for( i = 0; i < n_points; i++ ){
@@ -403,7 +403,7 @@ CAMLprim value caml_gr_fill_poly(value vect)
                 SelectObject(grwindow.gcBitmap,grwindow.CurrentBrush);
                 Polygon(grwindow.gc,poly,n_points);
         }
-        free(poly);
+        caml_stat_free(poly);
 
         return Val_unit;
 }

diff --git a/otherlibs/win32graph/open.c b/otherlibs/win32graph/open.c
index 7e3b77de09fc40d5b476d96c41dc2ba9f2ecb577..e5e988d153bd0c2a80a0fdab1aeed3197be7fff0 100644 (file)
--- a/otherlibs/win32graph/open.c
+++ b/otherlibs/win32graph/open.c
@@ -44,15 +44,15 @@ HANDLE hInst;
 
 HFONT CreationFont(char *name)
 {
-   LOGFONT CurrentFont;
-   memset(&CurrentFont, 0, sizeof(LOGFONT));
+   LOGFONTA CurrentFont;
+   memset(&CurrentFont, 0, sizeof(LOGFONTA));
    CurrentFont.lfCharSet = ANSI_CHARSET;
    CurrentFont.lfWeight = FW_NORMAL;
    CurrentFont.lfHeight = grwindow.CurrentFontSize;
    CurrentFont.lfPitchAndFamily = (BYTE) (FIXED_PITCH | FF_MODERN);
    strncpy(CurrentFont.lfFaceName, name, sizeof(CurrentFont.lfFaceName));
    CurrentFont.lfFaceName[sizeof(CurrentFont.lfFaceName) - 1] = 0;
-   return (CreateFontIndirect(&CurrentFont));
+   return (CreateFontIndirectA(&CurrentFont));
 }
 
 void SetCoordinates(HWND hwnd)
@@ -112,7 +112,7 @@ static LRESULT CALLBACK GraphicsWndProc(HWND hwnd,UINT msg,WPARAM wParam,
 
 int DoRegisterClass(void)
 {
-        WNDCLASS wc;
+        WNDCLASSA wc;
 
         memset(&wc,0,sizeof(WNDCLASS));
         wc.style = CS_HREDRAW|CS_VREDRAW|CS_OWNDC ;
@@ -123,7 +123,7 @@ int DoRegisterClass(void)
         wc.lpszMenuName = 0;
         wc.hCursor = LoadCursor(NULL,IDC_ARROW);
         wc.hIcon = 0;
-        return RegisterClass(&wc);
+        return RegisterClassA(&wc);
 }
 
 static value gr_reset(void)
@@ -212,12 +212,12 @@ static DWORD WINAPI gr_open_graph_internal(value arg)
         return 1;
       }
     }
-    grwindow.hwnd = CreateWindow(szOcamlWindowClass,
-                                 WINDOW_NAME,
-                                 WS_OVERLAPPEDWINDOW,
-                                 x,y,
-                                 w,h,
-                                 NULL,0,hInst,NULL);
+    grwindow.hwnd = CreateWindowA(szOcamlWindowClass,
+                                  WINDOW_NAME,
+                                  WS_OVERLAPPEDWINDOW,
+                                  x,y,
+                                  w,h,
+                                  NULL,0,hInst,NULL);
     if (grwindow.hwnd == NULL) {
       open_graph_errmsg = "Cannot create window";
       SetEvent(open_graph_event);

diff --git a/otherlibs/win32unix/.depend b/otherlibs/win32unix/.depend
index a608240cdf2e272c09d762231dbca4c1c0251574..000683a02710c2898b453e0697a6eeec9584608b 100644 (file)
--- a/otherlibs/win32unix/.depend
+++ b/otherlibs/win32unix/.depend
@@ -1,5 +1,18 @@
-unix.cmo: unix.cmi
-unix.cmx: unix.cmi
-unixLabels.cmo: unix.cmi unixLabels.cmi
-unixLabels.cmx: unix.cmx unixLabels.cmi
-unixLabels.cmi: unix.cmi
+windbug.$(O): windbug.c windbug.h
+cst2constr.$(O): cst2constr.c ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/s.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/fail.h ../unix/cst2constr.h
+mmap_ba.$(O): mmap_ba.c ../../byterun/caml/alloc.h ../../byterun/caml/misc.h \
+  ../../byterun/caml/config.h ../../byterun/caml/m.h \
+  ../../byterun/caml/s.h ../../byterun/caml/mlvalues.h \
+  ../../byterun/caml/bigarray.h ../../byterun/caml/custom.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
+unix.cmo : unix.cmi
+unix.cmx : unix.cmi
+unix.cmi :
+unixLabels.cmo : unix.cmi unixLabels.cmi
+unixLabels.cmx : unix.cmx unixLabels.cmi
+unixLabels.cmi : unix.cmi

diff --git a/otherlibs/win32unix/Makefile b/otherlibs/win32unix/Makefile
index 3824905b61aa2195f3413c07548c163760488e50..d2b4ef4b036a58e386de10fbef6800ea1cd873c7 100644 (file)
--- a/otherlibs/win32unix/Makefile
+++ b/otherlibs/win32unix/Makefile
@@ -19,10 +19,10 @@
 
 # Files in this directory
 WIN_FILES = accept.c bind.c channels.c close.c \
-  close_on.c connect.c createprocess.c dup.c dup2.c errmsg.c \
-  getpeername.c getpid.c getsockname.c gettimeofday.c \
+  close_on.c connect.c createprocess.c dup.c dup2.c errmsg.c envir.c \
+  getpeername.c getpid.c getsockname.c gettimeofday.c isatty.c \
   link.c listen.c lockf.c lseek.c nonblock.c \
-  mkdir.c open.c pipe.c read.c readlink.c rename.c \
+  mkdir.c mmap.c open.c pipe.c read.c readlink.c rename.c \
   select.c sendrecv.c \
   shutdown.c sleep.c socket.c sockopt.c startup.c stat.c \
   symlink.c system.c times.c unixsupport.c windir.c winwait.c write.c \
@@ -30,10 +30,10 @@ WIN_FILES = accept.c bind.c channels.c close.c \
 
 # Files from the ../unix directory
 UNIX_FILES = access.c addrofstr.c chdir.c chmod.c cst2constr.c \
-  cstringv.c envir.c execv.c execve.c execvp.c \
+  cstringv.c execv.c execve.c execvp.c \
   exit.c getaddrinfo.c getcwd.c gethost.c gethostname.c \
   getnameinfo.c getproto.c \
-  getserv.c gmtime.c putenv.c rmdir.c \
+  getserv.c gmtime.c mmap_ba.c putenv.c rmdir.c \
   socketaddr.c strofaddr.c time.c unlink.c utimes.c
 
 UNIX_CAML_FILES = unix.mli unixLabels.mli unixLabels.ml
@@ -60,8 +60,16 @@ clean::
 $(UNIX_FILES) $(UNIX_CAML_FILES): %: ../unix/%
        cp ../unix/$* $*
 
+.PHONY: depend
+ifeq "$(TOOLCHAIN)" "msvc"
 depend:
-
-$(COBJS): unixsupport.h
+       $(error Dependencies cannot be regenerated using the MSVC ports)
+else
+depend: $(ALL_FILES) $(UNIX_CAML_FILES) unix.ml
+       $(CC) -MM $(CPPFLAGS) -I../unix $(ALL_FILES) \
+         | sed -e 's/\.o/.$$(O)/g' > .depend
+       $(CAMLRUN) $(ROOTDIR)/tools/ocamldep -slash $(UNIX_CAML_FILES) \
+         unix.ml >> .depend
+endif
 
 include .depend

diff --git a/otherlibs/win32unix/channels.c b/otherlibs/win32unix/channels.c
index 0347bd38a884f3e52a5c1b7cdb1aa90fc44c45fd..2749a766bd888a898ba0258f80786e5ac73075f9 100644 (file)
--- a/otherlibs/win32unix/channels.c
+++ b/otherlibs/win32unix/channels.c
@@ -50,6 +50,8 @@ CAMLprim value win_inchannel_of_filedescr(value handle)
   fflush(stdin);
 #endif
   chan = caml_open_descriptor_in(win_CRT_fd_of_filedescr(handle));
+  chan->flags |= CHANNEL_FLAG_MANAGED_BY_GC;
+                 /* as in caml_ml_open_descriptor_in() */
   if (Descr_kind_val(handle) == KIND_SOCKET)
     chan->flags |= CHANNEL_FLAG_FROM_SOCKET;
   vchan = caml_alloc_channel(chan);
@@ -64,6 +66,8 @@ CAMLprim value win_outchannel_of_filedescr(value handle)
   struct channel * chan;
 
   chan = caml_open_descriptor_out(win_CRT_fd_of_filedescr(handle));
+  chan->flags |= CHANNEL_FLAG_MANAGED_BY_GC;
+                 /* as in caml_ml_open_descriptor_out() */
   if (Descr_kind_val(handle) == KIND_SOCKET)
     chan->flags |= CHANNEL_FLAG_FROM_SOCKET;
   vchan = caml_alloc_channel(chan);

diff --git a/otherlibs/win32unix/createprocess.c b/otherlibs/win32unix/createprocess.c
index 8c855aa19ae6f5dd700201d580997f7c401cc9c7..e1a13441cbb77a5b704503f343f40607e6c139e7 100644 (file)
--- a/otherlibs/win32unix/createprocess.c
+++ b/otherlibs/win32unix/createprocess.c
@@ -24,42 +24,30 @@
 
 static int win_has_console(void);
 
-value win_create_process_native(value cmd, value cmdline, value env,
-                                value fd1, value fd2, value fd3)
+static DWORD do_create_process_native(wchar_t * exefile, wchar_t * cmdline, wchar_t * env,
+                                      HANDLE fd1, HANDLE fd2, HANDLE fd3, HANDLE * hProcess)
 {
   PROCESS_INFORMATION pi;
   STARTUPINFO si;
-  char * exefile, * envp;
   DWORD flags, err;
   HANDLE hp;
 
-  caml_unix_check_path(cmd, "create_process");
-  if (! caml_string_is_c_safe(cmdline))
-    unix_error(EINVAL, "create_process", cmdline);
-  /* [env] is checked for null bytes at construction time, see unix.ml */
-
   err = ERROR_SUCCESS;
-  exefile = caml_search_exe_in_path(String_val(cmd));
-  if (env != Val_int(0)) {
-    envp = String_val(Field(env, 0));
-  } else {
-    envp = NULL;
-  }
   /* Prepare stdin/stdout/stderr redirection */
   ZeroMemory(&si, sizeof(STARTUPINFO));
   si.cb = sizeof(STARTUPINFO);
   si.dwFlags = STARTF_USESTDHANDLES;
   /* Duplicate the handles fd1, fd2, fd3 to make sure they are inheritable */
   hp = GetCurrentProcess();
-  if (! DuplicateHandle(hp, Handle_val(fd1), hp, &(si.hStdInput),
+  if (! DuplicateHandle(hp, fd1, hp, &(si.hStdInput),
                         0, TRUE, DUPLICATE_SAME_ACCESS)) {
     err = GetLastError(); goto ret1;
   }
-  if (! DuplicateHandle(hp, Handle_val(fd2), hp, &(si.hStdOutput),
+  if (! DuplicateHandle(hp, fd2, hp, &(si.hStdOutput),
                         0, TRUE, DUPLICATE_SAME_ACCESS)) {
     err = GetLastError(); goto ret2;
   }
-  if (! DuplicateHandle(hp, Handle_val(fd3), hp, &(si.hStdError),
+  if (! DuplicateHandle(hp, fd3, hp, &(si.hStdError),
                         0, TRUE, DUPLICATE_SAME_ACCESS)) {
     err = GetLastError(); goto ret3;
   }
@@ -74,9 +62,10 @@ value win_create_process_native(value cmd, value cmdline, value env,
     si.dwFlags = (STARTF_USESHOWWINDOW | STARTF_USESTDHANDLES);
     si.wShowWindow = SW_HIDE;
   }
+  flags |= CREATE_UNICODE_ENVIRONMENT;
   /* Create the process */
-  if (! CreateProcess(exefile, String_val(cmdline), NULL, NULL,
-                      TRUE, flags, envp, NULL, &si, &pi)) {
+  if (! CreateProcess(exefile, cmdline, NULL, NULL,
+                      TRUE, flags, env, NULL, &si, &pi)) {
     err = GetLastError(); goto ret4;
   }
   CloseHandle(pi.hThread);
@@ -87,6 +76,43 @@ value win_create_process_native(value cmd, value cmdline, value env,
  ret2:
   CloseHandle(si.hStdInput);
  ret1:
+  *hProcess = (err == ERROR_SUCCESS) ? pi.hProcess : NULL;
+  return err;
+}
+
+value win_create_process_native(value cmd, value cmdline, value env,
+                               value fd1, value fd2, value fd3)
+{
+  wchar_t * exefile, * wcmdline, * wenv, * wcmd;
+  HANDLE hProcess;
+  DWORD err;
+  int size;
+
+  caml_unix_check_path(cmd, "create_process");
+  if (! caml_string_is_c_safe(cmdline))
+    unix_error(EINVAL, "create_process", cmdline);
+  /* [env] is checked for null bytes at construction time, see unix.ml */
+
+  wcmd = caml_stat_strdup_to_utf16(String_val(cmd));
+  exefile = caml_search_exe_in_path(wcmd);
+  caml_stat_free(wcmd);
+  wcmdline = caml_stat_strdup_to_utf16(String_val(cmdline));
+
+  if (env != Val_int(0)) {
+    env = Field(env, 0);
+    size = win_multi_byte_to_wide_char(String_val(env), caml_string_length(env), NULL, 0);
+    wenv = caml_stat_alloc((size + 1)*sizeof(wchar_t));
+    win_multi_byte_to_wide_char(String_val(env), caml_string_length(env), wenv, size);
+    wenv[size] = 0;
+  } else {
+    wenv = NULL;
+  }
+
+  err = do_create_process_native(exefile, wcmdline, wenv,
+                                 Handle_val(fd1), Handle_val(fd2), Handle_val(fd3), &hProcess);
+
+  if (wenv != NULL) caml_stat_free(wenv);
+  caml_stat_free(wcmdline);
   caml_stat_free(exefile);
   if (err != ERROR_SUCCESS) {
     win32_maperr(err);
@@ -94,7 +120,7 @@ value win_create_process_native(value cmd, value cmdline, value env,
   }
   /* Return the process handle as pseudo-PID
      (this is consistent with the wait() emulation in the MSVC C library */
-  return Val_long(pi.hProcess);
+  return Val_long(hProcess);
 }
 
 CAMLprim value win_create_process(value * argv, int argn)
@@ -108,7 +134,7 @@ static int win_has_console(void)
   HANDLE h, log;
   int i;
 
-  h = CreateFile("CONOUT$", GENERIC_WRITE, FILE_SHARE_WRITE, NULL,
+  h = CreateFile(L"CONOUT$", GENERIC_WRITE, FILE_SHARE_WRITE, NULL,
                  OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL);
   if (h == INVALID_HANDLE_VALUE) {
     return 0;

diff --git a/otherlibs/win32unix/envir.c b/otherlibs/win32unix/envir.c
new file mode 100644 (file)
index 0000000..3324d6d
--- /dev/null
+++ b/otherlibs/win32unix/envir.c
@@ -0,0 +1,34 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           */
+/*                                                                        */
+/*   Copyright 1996 Institut National de Recherche en Informatique et     */
+/*     en Automatique.                                                    */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#define CAML_INTERNALS
+
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include <caml/memory.h>
+#include <caml/osdeps.h>
+
+#include <Windows.h>
+#include <stdlib.h>
+
+CAMLprim value unix_environment(value unit)
+{
+  /* Win32 doesn't have a notion of setuid bit, so accessing environ is safe. */
+  if (_wenviron != NULL) {
+    return caml_alloc_array((void *)caml_copy_string_of_utf16, (const char**)_wenviron);
+  } else {
+    return Atom(0);
+  }
+}

diff --git a/otherlibs/win32unix/errmsg.c b/otherlibs/win32unix/errmsg.c
index 16a93ed4ea65d474cfeb2ad4ebda7202a7ff86fe..aea3fd0bbc68097275da87b6a415ef3f6411f71b 100644 (file)
--- a/otherlibs/win32unix/errmsg.c
+++ b/otherlibs/win32unix/errmsg.c
@@ -13,11 +13,14 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 #include <stdio.h>
 #include <errno.h>
 #include <string.h>
 #include <caml/mlvalues.h>
 #include <caml/alloc.h>
+#include <caml/osdeps.h>
 #include "unixsupport.h"
 
 extern int error_table[];
@@ -25,7 +28,7 @@ extern int error_table[];
 CAMLprim value unix_error_message(value err)
 {
   int errnum;
-  char buffer[512];
+  wchar_t buffer[512];
 
   errnum = Is_block(err) ? Int_val(Field(err, 0)) : error_table[Int_val(err)];
   if (errnum > 0)
@@ -35,9 +38,9 @@ CAMLprim value unix_error_message(value err)
                     -errnum,
                     0,
                     buffer,
-                    sizeof(buffer),
+                    sizeof(buffer)/sizeof(wchar_t),
                     NULL))
-    return caml_copy_string(buffer);
-  sprintf(buffer, "unknown error #%d", errnum);
-  return caml_copy_string(buffer);
+    return caml_copy_string_of_utf16(buffer);
+  swprintf(buffer, sizeof(buffer)/sizeof(wchar_t), L"unknown error #%d", errnum);
+  return caml_copy_string_of_utf16(buffer);
 }

diff --git a/otherlibs/win32unix/isatty.c b/otherlibs/win32unix/isatty.c
new file mode 100644 (file)
index 0000000..5f0999e
--- /dev/null
+++ b/otherlibs/win32unix/isatty.c
@@ -0,0 +1,24 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*                 David Allsopp, OCaml Labs, Cambridge.                  */
+/*                                                                        */
+/*   Copyright 2017 MetaStack Solutions Ltd.                              */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <caml/mlvalues.h>
+#include "unixsupport.h"
+
+CAMLprim value unix_isatty(value fd)
+{
+  DWORD lpMode;
+  HANDLE hFile = Handle_val(fd);
+  return (Val_bool((GetFileType(hFile) == FILE_TYPE_CHAR)
+                   && GetConsoleMode(hFile, &lpMode)));
+}

diff --git a/otherlibs/win32unix/link.c b/otherlibs/win32unix/link.c
index 54897de1cb93266b37eeaab71302c5bd67b93fe8..51dc7c064fd42037be99855c13952406ff7a0c8c 100644 (file)
--- a/otherlibs/win32unix/link.c
+++ b/otherlibs/win32unix/link.c
@@ -13,15 +13,19 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 #include <caml/mlvalues.h>
 #include <caml/fail.h>
+#include <caml/memory.h>
+#include <caml/osdeps.h>
 #include "unixsupport.h"
 #include <windows.h>
 
 typedef
 BOOL (WINAPI *tCreateHardLink)(
-  LPCTSTR lpFileName,
-  LPCTSTR lpExistingFileName,
+  LPCWSTR lpFileName,
+  LPCWSTR lpExistingFileName,
   LPSECURITY_ATTRIBUTES lpSecurityAttributes
 );
 
@@ -29,14 +33,25 @@ CAMLprim value unix_link(value path1, value path2)
 {
   HMODULE hModKernel32;
   tCreateHardLink pCreateHardLink;
-  hModKernel32 = GetModuleHandle("KERNEL32.DLL");
+  BOOL result;
+  wchar_t * wpath1, * wpath2;
+  hModKernel32 = GetModuleHandle(L"KERNEL32.DLL");
   pCreateHardLink =
-    (tCreateHardLink) GetProcAddress(hModKernel32, "CreateHardLinkA");
+    (tCreateHardLink) GetProcAddress(hModKernel32, "CreateHardLinkW");
   if (pCreateHardLink == NULL)
     caml_invalid_argument("Unix.link not implemented");
   caml_unix_check_path(path1, "link");
   caml_unix_check_path(path2, "link");
-  if (! pCreateHardLink(String_val(path2), String_val(path1), NULL)) {
+
+  wpath1 = caml_stat_strdup_to_utf16(String_val(path1));
+  wpath2 = caml_stat_strdup_to_utf16(String_val(path2));
+
+  result = pCreateHardLink(wpath2, wpath1, NULL);
+
+  caml_stat_free(wpath1);
+  caml_stat_free(wpath2);
+
+  if (! result) {
     win32_maperr(GetLastError());
     uerror("link", path2);
   }

diff --git a/otherlibs/win32unix/mkdir.c b/otherlibs/win32unix/mkdir.c
index 7aaf040a85d7ccc621e4446f7321c8907e313805..1b2a33a526e6bd557800a32403666495de135b0a 100644 (file)
--- a/otherlibs/win32unix/mkdir.c
+++ b/otherlibs/win32unix/mkdir.c
@@ -13,13 +13,22 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 #include <caml/mlvalues.h>
+#include <caml/osdeps.h>
+#include <caml/memory.h>
 #include "unixsupport.h"
 
 CAMLprim value unix_mkdir(path, perm)
      value path, perm;
 {
+  int err;
+  wchar_t * wpath;
   caml_unix_check_path(path, "mkdir");
-  if (_mkdir(String_val(path)) == -1) uerror("mkdir", path);
+  wpath = caml_stat_strdup_to_utf16(String_val(path));
+  err = _wmkdir(wpath);
+  caml_stat_free(wpath);
+  if (err == -1) uerror("mkdir", path);
   return Val_unit;
 }

diff --git a/otherlibs/win32unix/mmap.c b/otherlibs/win32unix/mmap.c
new file mode 100644 (file)
index 0000000..75cfb2a
--- /dev/null
+++ b/otherlibs/win32unix/mmap.c
@@ -0,0 +1,187 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*          Manuel Serrano and Xavier Leroy, INRIA Rocquencourt           */
+/*                                                                        */
+/*   Copyright 2000 Institut National de Recherche en Informatique et     */
+/*     en Automatique.                                                    */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#define CAML_INTERNALS
+
+#include <stddef.h>
+#include "caml/alloc.h"
+#include "caml/bigarray.h"
+#include "caml/fail.h"
+#include "caml/io.h"
+#include "caml/mlvalues.h"
+#include "caml/signals.h"
+#include "caml/sys.h"
+#include "caml/osdeps.h"
+#include "unixsupport.h"
+
+/* Temporary compatibility stuff so that this file can also be compiled
+   from otherlibs/bigarray/ and included in the bigarray library. */
+
+#ifdef IN_OCAML_BIGARRAY
+#define MAP_FILE_FUNCTION caml_ba_map_file
+#define MAP_FILE_FUNCTION_BYTECODE caml_ba_map_file_bytecode
+#define UNMAP_FILE_FUNCTION caml_ba_unmap_file
+#define ALLOC_FUNCTION caml_ba_mapped_alloc
+#define CAML_MAP_FILE "Bigarray.map_file"
+static void caml_ba_sys_error(void);
+#define MAP_FILE_ERROR() caml_ba_sys_error()
+#else
+#define MAP_FILE_FUNCTION caml_unix_map_file
+#define MAP_FILE_FUNCTION_BYTECODE caml_unix_map_file_bytecode
+#define UNMAP_FILE_FUNCTION caml_unix_unmap_file
+#define ALLOC_FUNCTION caml_unix_mapped_alloc
+#define MAP_FILE_FUNCTION caml_unix_map_file
+#define CAML_MAP_FILE "Unix.map_file"
+#define MAP_FILE_ERROR() \
+  do { win32_maperr(GetLastError()); uerror("map_file", Nothing); } while(0)
+#endif
+
+/* Defined in [mmap_ba.c] */
+CAMLextern value
+ALLOC_FUNCTION(int flags, int num_dims, void * data, intnat * dim);
+
+#ifndef INVALID_SET_FILE_POINTER
+#define INVALID_SET_FILE_POINTER (-1)
+#endif
+
+static __int64 caml_set_file_pointer(HANDLE h, __int64 dist, DWORD mode)
+{
+  LARGE_INTEGER i;
+  DWORD err;
+
+  i.QuadPart = dist;
+  i.LowPart = SetFilePointer(h, i.LowPart, &i.HighPart, mode);
+  if (i.LowPart == INVALID_SET_FILE_POINTER) return -1;
+  return i.QuadPart;
+}
+
+CAMLprim value MAP_FILE_FUNCTION(value vfd, value vkind, value vlayout,
+                                 value vshared, value vdim, value vstart)
+{
+  HANDLE fd, fmap;
+  int flags, major_dim, mode, perm;
+  intnat num_dims, i;
+  intnat dim[CAML_BA_MAX_NUM_DIMS];
+  __int64 currpos, startpos, file_size, data_size;
+  uintnat array_size, page, delta;
+  char c;
+  void * addr;
+  LARGE_INTEGER li;
+  SYSTEM_INFO sysinfo;
+
+  fd = Handle_val(vfd);
+  flags = Caml_ba_kind_val(vkind) | Caml_ba_layout_val(vlayout);
+  startpos = Int64_val(vstart);
+  num_dims = Wosize_val(vdim);
+  major_dim = flags & CAML_BA_FORTRAN_LAYOUT ? num_dims - 1 : 0;
+  /* Extract dimensions from OCaml array */
+  num_dims = Wosize_val(vdim);
+  if (num_dims < 1 || num_dims > CAML_BA_MAX_NUM_DIMS)
+    caml_invalid_argument(CAML_MAP_FILE ": bad number of dimensions");
+  for (i = 0; i < num_dims; i++) {
+    dim[i] = Long_val(Field(vdim, i));
+    if (dim[i] == -1 && i == major_dim) continue;
+    if (dim[i] < 0)
+      caml_invalid_argument(CAML_MAP_FILE ": negative dimension");
+  }
+  /* Determine file size */
+  currpos = caml_set_file_pointer(fd, 0, FILE_CURRENT);
+  if (currpos == -1) MAP_FILE_ERROR();
+  file_size = caml_set_file_pointer(fd, 0, FILE_END);
+  if (file_size == -1) MAP_FILE_ERROR();
+  /* Determine array size in bytes (or size of array without the major
+     dimension if that dimension wasn't specified) */
+  array_size = caml_ba_element_size[flags & CAML_BA_KIND_MASK];
+  for (i = 0; i < num_dims; i++)
+    if (dim[i] != -1) array_size *= dim[i];
+  /* Check if the first/last dimension is unknown */
+  if (dim[major_dim] == -1) {
+    /* Determine first/last dimension from file size */
+    if (file_size < startpos)
+      caml_failwith(CAML_MAP_FILE ": file position exceeds file size");
+    data_size = file_size - startpos;
+    dim[major_dim] = (uintnat) (data_size / array_size);
+    array_size = dim[major_dim] * array_size;
+    if (array_size != data_size)
+      caml_failwith(CAML_MAP_FILE ": file size doesn't match array dimensions");
+  }
+  /* Restore original file position */
+  caml_set_file_pointer(fd, currpos, FILE_BEGIN);
+  /* Create the file mapping */
+  if (Bool_val(vshared)) {
+    perm = PAGE_READWRITE;
+    mode = FILE_MAP_WRITE;
+  } else {
+    perm = PAGE_READONLY;       /* doesn't work under Win98 */
+    mode = FILE_MAP_COPY;
+  }
+  li.QuadPart = startpos + array_size;
+  fmap = CreateFileMapping(fd, NULL, perm, li.HighPart, li.LowPart, NULL);
+  if (fmap == NULL) MAP_FILE_ERROR();
+  /* Determine offset so that the mapping starts at the given file pos */
+  GetSystemInfo(&sysinfo);
+  delta = (uintnat) (startpos % sysinfo.dwAllocationGranularity);
+  /* Map the mapping in memory */
+  li.QuadPart = startpos - delta;
+  addr =
+    MapViewOfFile(fmap, mode, li.HighPart, li.LowPart, array_size + delta);
+  if (addr == NULL) MAP_FILE_ERROR();
+  addr = (void *) ((uintnat) addr + delta);
+  /* Close the file mapping */
+  CloseHandle(fmap);
+  /* Build and return the OCaml bigarray */
+  return ALLOC_FUNCTION(flags, num_dims, addr, dim);
+}
+
+CAMLprim value MAP_FILE_FUNCTION_BYTECODE(value * argv, int argn)
+{
+  return MAP_FILE_FUNCTION(argv[0], argv[1], argv[2],
+                           argv[3], argv[4], argv[5]);
+}
+
+void UNMAP_FILE_FUNCTION(void * addr, uintnat len)
+{
+  SYSTEM_INFO sysinfo;
+  uintnat delta;
+
+  GetSystemInfo(&sysinfo);
+  delta = (uintnat) addr % sysinfo.dwAllocationGranularity;
+  UnmapViewOfFile((void *)((uintnat)addr - delta));
+}
+
+#ifdef IN_OCAML_BIGARRAY
+
+/* This function reports a Win32 error as a Sys_error exception.
+   It is included for backward compatibility with the old
+   Bigarray.*.map_file implementation.  */
+
+static void caml_ba_sys_error(void)
+{
+  wchar_t buffer[512];
+  DWORD errnum;
+
+  errnum = GetLastError();
+  if (!FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM|FORMAT_MESSAGE_IGNORE_INSERTS,
+                     NULL,
+                     errnum,
+                     0,
+                     buffer,
+                     sizeof(buffer)/sizeof(wchar_t),
+                     NULL))
+    swprintf(buffer, sizeof(buffer)/sizeof(wchar_t), L"Unknown error %ld\n", errnum);
+  caml_raise_sys_error(caml_copy_string_of_utf16(buffer));
+}
+
+#endif

diff --git a/otherlibs/win32unix/open.c b/otherlibs/win32unix/open.c
index cff952590ae28b08d2863cd483f852a810c6971f..5a56d92dc5a23f898b522b45c10775895946a92a 100644 (file)
--- a/otherlibs/win32unix/open.c
+++ b/otherlibs/win32unix/open.c
@@ -13,8 +13,12 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 #include <caml/mlvalues.h>
 #include <caml/alloc.h>
+#include <caml/osdeps.h>
+#include <caml/memory.h>
 #include "unixsupport.h"
 #include <fcntl.h>
 
@@ -42,6 +46,7 @@ CAMLprim value unix_open(value path, value flags, value perm)
   int fileaccess, createflags, fileattrib, filecreate, sharemode, cloexec;
   SECURITY_ATTRIBUTES attr;
   HANDLE h;
+  wchar_t * wpath;
 
   caml_unix_check_path(path, "open");
   fileaccess = caml_convert_flag_list(flags, open_access_flags);
@@ -73,9 +78,11 @@ CAMLprim value unix_open(value path, value flags, value perm)
                       : cloexec & KEEPEXEC ? TRUE
                                            : !unix_cloexec_default;
 
-  h = CreateFile(String_val(path), fileaccess,
+  wpath = caml_stat_strdup_to_utf16(String_val(path));
+  h = CreateFile(wpath, fileaccess,
                  sharemode, &attr,
                  filecreate, fileattrib, NULL);
+  caml_stat_free(wpath);
   if (h == INVALID_HANDLE_VALUE) {
     win32_maperr(GetLastError());
     uerror("open", path);

diff --git a/otherlibs/win32unix/readlink.c b/otherlibs/win32unix/readlink.c
index 7b20614cb7b44fd799dd2dcdeeb64db0f721cc0c..b57e525ce5566ead827924e7d7fee2ff1fe15187 100644 (file)
--- a/otherlibs/win32unix/readlink.c
+++ b/otherlibs/win32unix/readlink.c
@@ -12,11 +12,14 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 #include <caml/mlvalues.h>
 #include <caml/memory.h>
 #include <caml/alloc.h>
 #include <caml/fail.h>
 #include <caml/signals.h>
+#include <caml/osdeps.h>
 #include "unixsupport.h"
 #include <errno.h>
 #include <winioctl.h>
@@ -26,10 +29,10 @@ CAMLprim value unix_readlink(value opath)
   CAMLparam1(opath);
   CAMLlocal1(result);
   HANDLE h;
-  char* path;
+  wchar_t* path;
   DWORD attributes;
   caml_unix_check_path(opath, "readlink");
-  path = caml_strdup(String_val(opath));
+  path = caml_stat_strdup_to_utf16(String_val(opath));
 
   caml_enter_blocking_section();
   attributes = GetFileAttributes(path);
@@ -72,25 +75,12 @@ CAMLprim value unix_readlink(value opath)
         if (point->ReparseTag == IO_REPARSE_TAG_SYMLINK) {
           int cbLen = point->SymbolicLinkReparseBuffer.SubstituteNameLength / sizeof(WCHAR);
           int len;
-          len = WideCharToMultiByte(
-                  CP_THREAD_ACP,
-                  0,
-                  point->SymbolicLinkReparseBuffer.PathBuffer + point->SymbolicLinkReparseBuffer.SubstituteNameOffset / 2,
-                  cbLen,
-                  NULL,
-                  0,
-                  NULL,
-                  NULL);
+          len = win_wide_char_to_multi_byte(point->SymbolicLinkReparseBuffer.PathBuffer + point->SymbolicLinkReparseBuffer.SubstituteNameOffset / sizeof(WCHAR), cbLen, NULL, 0);
           result = caml_alloc_string(len);
-          WideCharToMultiByte(
-            CP_THREAD_ACP,
-            0,
-            point->SymbolicLinkReparseBuffer.PathBuffer + point->SymbolicLinkReparseBuffer.SubstituteNameOffset / 2,
+          win_wide_char_to_multi_byte(point->SymbolicLinkReparseBuffer.PathBuffer + point->SymbolicLinkReparseBuffer.SubstituteNameOffset / sizeof(WCHAR),
             cbLen,
             String_val(result),
-            len,
-            NULL,
-            NULL);
+            len);
           CloseHandle(h);
         }
         else {

diff --git a/otherlibs/win32unix/rename.c b/otherlibs/win32unix/rename.c
index 155a73fb9415a4a8f32510625bb6ab55fbb2ee44..9bab6aef1faa991dfea2506207271c0edb740965 100644 (file)
--- a/otherlibs/win32unix/rename.c
+++ b/otherlibs/win32unix/rename.c
@@ -13,30 +13,28 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 #include <stdio.h>
 #include <caml/mlvalues.h>
+#include <caml/osdeps.h>
+#include <caml/memory.h>
 #include "unixsupport.h"
 
 CAMLprim value unix_rename(value path1, value path2)
 {
-  static int supports_MoveFileEx = -1; /* don't know yet */
+  wchar_t * wpath1, * wpath2;
   BOOL ok;
 
   caml_unix_check_path(path1, "rename");
   caml_unix_check_path(path2, "rename");
-  if (supports_MoveFileEx < 0) {
-    OSVERSIONINFO VersionInfo;
-    VersionInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
-    supports_MoveFileEx =
-      (GetVersionEx(&VersionInfo) != 0)
-      && (VersionInfo.dwPlatformId == VER_PLATFORM_WIN32_NT);
-  }
-  if (supports_MoveFileEx > 0)
-    ok = MoveFileEx(String_val(path1), String_val(path2),
-                    MOVEFILE_REPLACE_EXISTING | MOVEFILE_WRITE_THROUGH |
-                    MOVEFILE_COPY_ALLOWED);
-  else
-    ok = MoveFile(String_val(path1), String_val(path2));
+  wpath1 = caml_stat_strdup_to_utf16(String_val(path1));
+  wpath2 = caml_stat_strdup_to_utf16(String_val(path2));
+  ok = MoveFileEx(wpath1, wpath2,
+                  MOVEFILE_REPLACE_EXISTING | MOVEFILE_WRITE_THROUGH |
+                  MOVEFILE_COPY_ALLOWED);
+  caml_stat_free(wpath1);
+  caml_stat_free(wpath2);
   if (! ok) {
     win32_maperr(GetLastError());
     uerror("rename", path1);

diff --git a/otherlibs/win32unix/stat.c b/otherlibs/win32unix/stat.c
index 45360a069e919ad8f09581fb2261cc4c55566ee2..94c2490b6b639ed77f26069f8ce9202550ac1b56 100644 (file)
--- a/otherlibs/win32unix/stat.c
+++ b/otherlibs/win32unix/stat.c
@@ -12,11 +12,14 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 #include <errno.h>
 #include <caml/mlvalues.h>
 #include <caml/memory.h>
 #include <caml/alloc.h>
 #include <caml/signals.h>
+#include <caml/osdeps.h>
 #include "unixsupport.h"
 #include "cst2constr.h"
 #define _INTEGRAL_MAX_BITS 64
@@ -137,11 +140,11 @@ static int convert_time(FILETIME* time, __time64_t* result, __time64_t def)
 }
 
 /* path allocated outside the OCaml heap */
-static int safe_do_stat(int do_lstat, int use_64, char* path, mlsize_t l, HANDLE fstat, __int64* st_ino, struct _stat64* res)
+static int safe_do_stat(int do_lstat, int use_64, wchar_t* path, HANDLE fstat, __int64* st_ino, struct _stat64* res)
 {
   BY_HANDLE_FILE_INFORMATION info;
   int i;
-  char* ptr;
+  wchar_t* ptr;
   char c;
   HANDLE h;
   unsigned short mode;
@@ -279,10 +282,10 @@ static int safe_do_stat(int do_lstat, int use_64, char* path, mlsize_t l, HANDLE
    * emulated using GetFinalPathNameByHandle, but the pre-Vista emulation is a
    * bit too much effort for a simulated value, so it's simply ignored!
    */
-  if (path && (ptr = strrchr(path, '.')) && (!_stricmp(ptr, ".exe") ||
-                                             !_stricmp(ptr, ".cmd") ||
-                                             !_stricmp(ptr, ".bat") ||
-                                             !_stricmp(ptr, ".com"))) {
+  if (path && (ptr = wcsrchr(path, '.')) && (!_wcsicmp(ptr, L".exe") ||
+                                             !_wcsicmp(ptr, L".cmd") ||
+                                             !_wcsicmp(ptr, L".bat") ||
+                                             !_wcsicmp(ptr, L".com"))) {
     mode |= _S_IEXEC;
   }
   mode |= (mode & 0700) >> 3;
@@ -294,13 +297,13 @@ static int safe_do_stat(int do_lstat, int use_64, char* path, mlsize_t l, HANDLE
   return 1;
 }
 
-static int do_stat(int do_lstat, int use_64, char* opath, mlsize_t l, HANDLE fstat, __int64* st_ino, struct _stat64* res)
+static int do_stat(int do_lstat, int use_64, char* opath, HANDLE fstat, __int64* st_ino, struct _stat64* res)
 {
-  char* path;
+  wchar_t* wpath;
   int ret;
-  path = caml_strdup(opath);
-  ret = safe_do_stat(do_lstat, use_64, path, l, fstat, st_ino, res);
-  caml_stat_free(path);
+  wpath = caml_stat_strdup_to_utf16(opath);
+  ret = safe_do_stat(do_lstat, use_64, wpath, fstat, st_ino, res);
+  caml_stat_free(wpath);
   return ret;
 }
 
@@ -310,7 +313,7 @@ CAMLprim value unix_stat(value path)
   __int64 st_ino;
 
   caml_unix_check_path(path, "stat");
-  if (!do_stat(0, 0, String_val(path), caml_string_length(path), NULL, &st_ino, &buf)) {
+  if (!do_stat(0, 0, String_val(path), NULL, &st_ino, &buf)) {
     uerror("stat", path);
   }
   return stat_aux(0, st_ino, &buf);
@@ -322,7 +325,7 @@ CAMLprim value unix_stat_64(value path)
   __int64 st_ino;
 
   caml_unix_check_path(path, "stat");
-  if (!do_stat(0, 1, String_val(path), caml_string_length(path), NULL, &st_ino, &buf)) {
+  if (!do_stat(0, 1, String_val(path), NULL, &st_ino, &buf)) {
     uerror("stat", path);
   }
   return stat_aux(1, st_ino, &buf);
@@ -334,7 +337,7 @@ CAMLprim value unix_lstat(value path)
   __int64 st_ino;
 
   caml_unix_check_path(path, "lstat");
-  if (!do_stat(1, 0, String_val(path), caml_string_length(path), NULL, &st_ino, &buf)) {
+  if (!do_stat(1, 0, String_val(path), NULL, &st_ino, &buf)) {
     uerror("lstat", path);
   }
   return stat_aux(0, st_ino, &buf);
@@ -346,7 +349,7 @@ CAMLprim value unix_lstat_64(value path)
   __int64 st_ino;
 
   caml_unix_check_path(path, "lstat");
-  if (!do_stat(1, 1, String_val(path), caml_string_length(path), NULL, &st_ino, &buf)) {
+  if (!do_stat(1, 1, String_val(path), NULL, &st_ino, &buf)) {
     uerror("lstat", path);
   }
   return stat_aux(1, st_ino, &buf);
@@ -368,7 +371,7 @@ static value do_fstat(value handle, int use_64)
   ft = GetFileType(h) & ~FILE_TYPE_REMOTE;
   switch(ft) {
   case FILE_TYPE_DISK:
-    if (!safe_do_stat(0, use_64, NULL, 0, Handle_val(handle), &st_ino, &buf)) {
+    if (!safe_do_stat(0, use_64, NULL, Handle_val(handle), &st_ino, &buf)) {
       uerror("fstat", Nothing);
     }
     break;

diff --git a/otherlibs/win32unix/symlink.c b/otherlibs/win32unix/symlink.c
index 326cefcbb948a524463ec4c3e496d09eddc72225..1336ba6cc3646f56182d4372b7335393619c2d8f 100644 (file)
--- a/otherlibs/win32unix/symlink.c
+++ b/otherlibs/win32unix/symlink.c
@@ -12,6 +12,8 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 /*
  * Windows Vista functions enabled
  */
@@ -23,9 +25,10 @@
 #include <caml/alloc.h>
 #include <caml/fail.h>
 #include <caml/signals.h>
+#include <caml/osdeps.h>
 #include "unixsupport.h"
 
-typedef BOOLEAN (WINAPI *LPFN_CREATESYMBOLICLINK) (LPTSTR, LPTSTR, DWORD);
+typedef BOOLEAN (WINAPI *LPFN_CREATESYMBOLICLINK) (LPWSTR, LPWSTR, DWORD);
 
 static LPFN_CREATESYMBOLICLINK pCreateSymbolicLink = NULL;
 static int no_symlink = 0;
@@ -35,8 +38,8 @@ CAMLprim value unix_symlink(value to_dir, value osource, value odest)
   CAMLparam3(to_dir, osource, odest);
   DWORD flags = (Bool_val(to_dir) ? SYMBOLIC_LINK_FLAG_DIRECTORY : 0);
   BOOLEAN result;
-  LPTSTR source;
-  LPTSTR dest;
+  LPWSTR source;
+  LPWSTR dest;
   caml_unix_check_path(osource, "symlink");
   caml_unix_check_path(odest, "symlink");
 
@@ -46,14 +49,14 @@ again:
   }
 
   if (!pCreateSymbolicLink) {
-    pCreateSymbolicLink = (LPFN_CREATESYMBOLICLINK)GetProcAddress(GetModuleHandle("kernel32"), "CreateSymbolicLinkA");
+    pCreateSymbolicLink = (LPFN_CREATESYMBOLICLINK)GetProcAddress(GetModuleHandle(L"kernel32"), "CreateSymbolicLinkW");
     no_symlink = !pCreateSymbolicLink;
     goto again;
   }
 
   /* Copy source and dest outside the OCaml heap */
-  source = caml_strdup(String_val(osource));
-  dest = caml_strdup(String_val(odest));
+  source = caml_stat_strdup_to_utf16(String_val(osource));
+  dest = caml_stat_strdup_to_utf16(String_val(odest));
 
   caml_enter_blocking_section();
   result = pCreateSymbolicLink(dest, source, flags);

diff --git a/otherlibs/win32unix/system.c b/otherlibs/win32unix/system.c
index a7946b6e927f170b7553489f20e2e36985618f74..39a47582a2e98f1dc2565ed8a69b1c6eee5a7f39 100644 (file)
--- a/otherlibs/win32unix/system.c
+++ b/otherlibs/win32unix/system.c
@@ -13,10 +13,13 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 #include <caml/mlvalues.h>
 #include <caml/memory.h>
 #include <caml/alloc.h>
 #include <caml/signals.h>
+#include <caml/osdeps.h>
 #include "unixsupport.h"
 #include <process.h>
 #include <stdio.h>
@@ -26,16 +29,13 @@ CAMLprim value win_system(cmd)
 {
   int ret;
   value st;
-  char *buf;
-  intnat len;
+  wchar_t *buf;
 
   caml_unix_check_path(cmd, "system");
-  len = caml_string_length (cmd);
-  buf = caml_stat_alloc (len + 1);
-  memmove (buf, String_val (cmd), len + 1);
+  buf = caml_stat_strdup_to_utf16 (String_val (cmd));
   caml_enter_blocking_section();
   _flushall();
-  ret = system(buf);
+  ret = _wsystem(buf);
   caml_leave_blocking_section();
   caml_stat_free(buf);
   if (ret == -1) uerror("system", Nothing);

diff --git a/otherlibs/win32unix/unix.ml b/otherlibs/win32unix/unix.ml
index 7fa865aa4f7a4b96a686fcb4acdebed53ed30053..9d53a8e5065bced34903021d48a1ba93eaf07ee0 100644 (file)
--- a/otherlibs/win32unix/unix.ml
+++ b/otherlibs/win32unix/unix.ml
@@ -121,8 +121,10 @@ let handle_unix_error f arg =
     exit 2
 
 external environment : unit -> string array = "unix_environment"
+(* On Win32 environment access is always considered safe. *)
+let unsafe_environment = environment
 external getenv: string -> string = "caml_sys_getenv"
-(* external unsafe_getenv: string -> string = "caml_sys_unsafe_getenv" *)
+external unsafe_getenv: string -> string = "caml_sys_unsafe_getenv"
 external putenv: string -> string -> unit = "unix_putenv"
 
 type process_status =
@@ -257,8 +259,7 @@ type stats =
 external stat : string -> stats = "unix_stat"
 external lstat : string -> stats = "unix_lstat"
 external fstat : file_descr -> stats = "unix_fstat"
-let isatty fd =
-  match (fstat fd).st_kind with S_CHR -> true | _ -> false
+external isatty : file_descr -> bool = "unix_isatty"
 
 (* Operations on file names *)
 
@@ -295,6 +296,18 @@ module LargeFile =
     external fstat : file_descr -> stats = "unix_fstat_64"
   end
 
+(* Mapping files into memory *)
+
+external map_internal:
+   file_descr -> ('a, 'b) CamlinternalBigarray.kind
+              -> 'c CamlinternalBigarray.layout
+              -> bool -> int array -> int64
+              -> ('a, 'b, 'c) CamlinternalBigarray.genarray
+     = "caml_unix_map_file_bytecode" "caml_unix_map_file"
+
+let map_file fd ?(pos=0L) kind layout shared dims =
+  map_internal fd kind layout shared dims pos
+
 (* File permissions and ownership *)
 
 type access_permission =
@@ -382,6 +395,17 @@ let mkfifo _name _perm = invalid_arg "Unix.mkfifo not implemented"
 external readlink : string -> string = "unix_readlink"
 external symlink_stub : bool -> string -> string -> unit = "unix_symlink"
 
+(* See https://caml.inria.fr/mantis/view.php?id=7564.
+   The Windows API used to create symbolic links does not normalize the target
+   of a symbolic link, so we do it here.  Note that we cannot use the native
+   Windows call GetFullPathName to do this because we need relative paths to
+   stay relative. *)
+let normalize_slashes path =
+  if String.length path >= 4 && path.[0] = '\\' && path.[1] = '\\' && path.[2] = '?' && path.[3] = '\\' then
+    path
+  else
+    String.init (String.length path) (fun i -> match path.[i] with '/' -> '\\' | c -> c)
+
 let symlink ?to_dir source dest =
   let to_dir =
     match to_dir with
@@ -393,7 +417,8 @@ let symlink ?to_dir source dest =
         with _ ->
           false
   in
-    symlink_stub to_dir source dest
+  let source = normalize_slashes source in
+  symlink_stub to_dir source dest
 
 external has_symlink : unit -> bool = "unix_has_symlink"
 
@@ -551,7 +576,7 @@ type msg_flag =
   | MSG_DONTROUTE
   | MSG_PEEK
 
-external socket : 
+external socket :
   ?cloexec: bool -> socket_domain -> socket_type -> int -> file_descr
   = "unix_socket"
 let socketpair ?cloexec:_ _dom _ty _proto = invalid_arg "Unix.socketpair not implemented"
@@ -940,7 +965,7 @@ let open_process_full cmd env =
     with e ->
       close out_read; close out_write;
       close in_read; close in_write;
-      close err_read; close err_write; 
+      close err_read; close err_write;
       raise e
   end;
   close out_read;

diff --git a/otherlibs/win32unix/unixsupport.c b/otherlibs/win32unix/unixsupport.c
index ced62fd821f87126d62cacf4b16c8b97d46e6b39..4ed2383b3bbe3262d933eb460893482d336cf554 100644 (file)
--- a/otherlibs/win32unix/unixsupport.c
+++ b/otherlibs/win32unix/unixsupport.c
@@ -280,7 +280,7 @@ value unix_error_of_code (int errcode)
   return err;
 }
 
-void unix_error(int errcode, char *cmdname, value cmdarg)
+void unix_error(int errcode, const char *cmdname, value cmdarg)
 {
   value res;
   value name = Val_unit, err = Val_unit, arg = Val_unit;
@@ -305,12 +305,12 @@ void unix_error(int errcode, char *cmdname, value cmdarg)
   caml_raise(res);
 }
 
-void uerror(char * cmdname, value cmdarg)
+void uerror(const char * cmdname, value cmdarg)
 {
   unix_error(errno, cmdname, cmdarg);
 }
 
-void caml_unix_check_path(value path, char * cmdname)
+void caml_unix_check_path(value path, const char * cmdname)
 {
   if (! caml_string_is_c_safe(path)) unix_error(ENOENT, cmdname, path);
 }

diff --git a/otherlibs/win32unix/unixsupport.h b/otherlibs/win32unix/unixsupport.h
index 139e179c3283cf4c78be1cd780d8bd93f11a3327..09ebaca9f3d8dc4c6dacb15ceaffa82245f61192 100644 (file)
--- a/otherlibs/win32unix/unixsupport.h
+++ b/otherlibs/win32unix/unixsupport.h
@@ -61,16 +61,17 @@ extern void win32_maperr(DWORD errcode);
 extern value unix_error_of_code (int errcode);
 
 CAMLnoreturn_start
-extern void unix_error (int errcode, char * cmdname, value arg)
+extern void unix_error (int errcode, const char * cmdname, value arg)
 CAMLnoreturn_end;
 
 CAMLnoreturn_start
-extern void uerror (char * cmdname, value arg)
+extern void uerror (const char * cmdname, value arg)
 CAMLnoreturn_end;
 
-extern void caml_unix_check_path(value path, char * cmdname);
+extern void caml_unix_check_path(value path, const char * cmdname);
 extern value unix_freeze_buffer (value);
-extern char ** cstringvect(value arg, char * cmdname);
+extern wchar_t ** cstringvect(value arg, char * cmdname);
+extern void cstringvect_free(wchar_t **);
 
 extern int unix_cloexec_default;
 extern int unix_cloexec_p(value cloexec);
@@ -127,4 +128,6 @@ typedef struct _REPARSE_DATA_BUFFER
 } REPARSE_DATA_BUFFER, *PREPARSE_DATA_BUFFER;
 #endif
 
+#define EXECV_CAST (const char_os * const *)
+
 #endif /* CAML_UNIXSUPPORT_H */

diff --git a/otherlibs/win32unix/windir.c b/otherlibs/win32unix/windir.c
index b0746d51caec8f3429f044c23c540381256b574a..b287a8ea5d99d39ad3d21a4bd349657bef7cb3b1 100644 (file)
--- a/otherlibs/win32unix/windir.c
+++ b/otherlibs/win32unix/windir.c
@@ -13,24 +13,30 @@
 /*                                                                        */
 /**************************************************************************/
 
+#define CAML_INTERNALS
+
 #include <caml/mlvalues.h>
 #include <caml/memory.h>
 #include <errno.h>
 #include <caml/alloc.h>
 #include <caml/fail.h>
+#include <caml/osdeps.h>
 #include "unixsupport.h"
 
 CAMLprim value win_findfirst(value name)
 {
   HANDLE h;
   value v;
-  WIN32_FIND_DATA fileinfo;
+  WIN32_FIND_DATAW fileinfo;
   value valname = Val_unit;
   value valh = Val_unit;
+  wchar_t * wname;
 
   caml_unix_check_path(name, "opendir");
   Begin_roots2 (valname,valh);
-    h = FindFirstFile(String_val(name),&fileinfo);
+    wname = caml_stat_strdup_to_utf16(String_val(name));
+    h = FindFirstFile(wname,&fileinfo);
+    caml_stat_free(wname);
     if (h == INVALID_HANDLE_VALUE) {
       DWORD err = GetLastError();
       if (err == ERROR_NO_MORE_FILES)
@@ -40,7 +46,7 @@ CAMLprim value win_findfirst(value name)
         uerror("opendir", Nothing);
       }
     }
-    valname = caml_copy_string(fileinfo.cFileName);
+    valname = caml_copy_string_of_utf16(fileinfo.cFileName);
     valh = win_alloc_handle(h);
     v = caml_alloc_small(2, 0);
     Field(v,0) = valname;
@@ -51,7 +57,7 @@ CAMLprim value win_findfirst(value name)
 
 CAMLprim value win_findnext(value valh)
 {
-  WIN32_FIND_DATA fileinfo;
+  WIN32_FIND_DATAW fileinfo;
   BOOL retcode;
 
   retcode = FindNextFile(Handle_val(valh), &fileinfo);
@@ -64,7 +70,7 @@ CAMLprim value win_findnext(value valh)
       uerror("readdir", Nothing);
     }
   }
-  return caml_copy_string(fileinfo.cFileName);
+  return caml_copy_string_of_utf16(fileinfo.cFileName);
 }
 
 CAMLprim value win_findclose(value valh)

diff --git a/otherlibs/win32unix/winlist.h b/otherlibs/win32unix/winlist.h
index f5040060063ab2a4349993853bca4b24542c4da2..285d507b7f1e0d3114276725eb23aed85a31243c 100644 (file)
--- a/otherlibs/win32unix/winlist.h
+++ b/otherlibs/win32unix/winlist.h
@@ -46,10 +46,10 @@ LPLIST list_next (LPLIST);
 
 #define LIST_NEXT(T, e) ((T)(list_next((LPLIST)(e))))
 
-/* Get number of element */
+/* Get the number of elements */
 int list_length (LPLIST);
 
-/* Concat two list. */
+/* Concatenate two lists */
 LPLIST list_concat (LPLIST, LPLIST);
 
 #endif /* _WINLIST_H */

diff --git a/otherlibs/win32unix/winwait.c b/otherlibs/win32unix/winwait.c
index 2bf539f2d43d30cac72e162aa3babad9ee4b6c25..90cc6db6d019a765bba9c7e7f864e04e45679ad2 100644 (file)
--- a/otherlibs/win32unix/winwait.c
+++ b/otherlibs/win32unix/winwait.c
@@ -52,10 +52,21 @@ CAMLprim value win_waitpid(value vflags, value vpid_req)
     retcode = WaitForSingleObject(pid_req, INFINITE);
     if (retcode == WAIT_FAILED) err = GetLastError();
     caml_leave_blocking_section();
-    if (err) {
-      win32_maperr(err);
-      uerror("waitpid", Nothing);
-    }
+  } else {
+    /* GPR#1155: we don't rely solely on GetExitCodeProcess to
+       determine whether the process has terminated or not. This is
+       because GetExitCodeProcess might return that the process has
+       terminated before the resources associated with the process are
+       released. This can be a problem since by default one cannot
+       delete a file or directory that is still in use. */
+    retcode = WaitForSingleObject(pid_req, 0);
+    if (retcode == WAIT_TIMEOUT)
+      return alloc_process_status((HANDLE) 0, 0);
+    if (retcode == WAIT_FAILED) err = GetLastError();
+  }
+  if (err) {
+    win32_maperr(err);
+    uerror("waitpid", Nothing);
   }
   if (! GetExitCodeProcess(pid_req, &status)) {
     win32_maperr(GetLastError());

diff --git a/otherlibs/win32unix/winworker.h b/otherlibs/win32unix/winworker.h
index c3a5dd0e38b7f3aa0db3a8bbc482962283eb29c8..a807f6b78cf77a0e996da065d269bcdbef76aced 100644 (file)
--- a/otherlibs/win32unix/winworker.h
+++ b/otherlibs/win32unix/winworker.h
@@ -23,7 +23,7 @@
 
 /* Pool of worker threads.
  *
- * These functions help to manage a pool of worker thread and submit task to
+ * These functions help to manage a pool of worker threads and submit task to
  * the pool. It helps to reduce the number of thread creation.
  *
  * Each worker are started in alertable wait state and jobs are submitted as
@@ -40,7 +40,7 @@ typedef WORKER *LPWORKER;
  * This function will be called using the data following:
  * - hStop must be watched for change, since it represents an external command
  *   to stop the call. This event is shared through the WORKER structure, which
- *   can be access throuhg worker_job_event_done.
+ *   can be accessed through worker_job_event_done.
  * - data is user provided data for the function.
  */
 typedef void (*WORKERFUNC) (HANDLE, void *);

diff --git a/parsing/ast_helper.ml b/parsing/ast_helper.ml
index ac1fc40da5ceb41a8d57e4cd60964fab94748d42..2c28493395f1213bd0741a9b5ddd03221d6e2d24 100644 (file)
--- a/parsing/ast_helper.ml
+++ b/parsing/ast_helper.ml
@@ -87,8 +87,7 @@ module Typ = struct
         | Ptyp_constr(longident, lst) ->
             Ptyp_constr(longident, List.map loop lst)
         | Ptyp_object (lst, o) ->
-            Ptyp_object
-              (List.map (fun (s, attrs, t) -> (s, attrs, loop t)) lst, o)
+            Ptyp_object (List.map loop_object_field lst, o)
         | Ptyp_class (longident, lst) ->
             Ptyp_class (longident, List.map loop lst)
         | Ptyp_alias(core_type, string) ->
@@ -113,6 +112,12 @@ module Typ = struct
             Rtag(label,attrs,flag,List.map loop lst)
         | Rinherit t ->
             Rinherit (loop t)
+    and loop_object_field =
+      function
+        | Otag(label, attrs, t) ->
+            Otag(label, attrs, loop t)
+        | Oinherit t ->
+            Oinherit (loop t)
     in
     loop t
 
@@ -286,6 +291,7 @@ module Cl = struct
   let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcl_let (a, b, c))
   let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pcl_constraint (a, b))
   let extension ?loc ?attrs a = mk ?loc ?attrs (Pcl_extension a)
+  let open_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcl_open (a, b, c))
 end
 
 module Cty = struct
@@ -301,6 +307,7 @@ module Cty = struct
   let signature ?loc ?attrs a = mk ?loc ?attrs (Pcty_signature a)
   let arrow ?loc ?attrs a b c = mk ?loc ?attrs (Pcty_arrow (a, b, c))
   let extension ?loc ?attrs a = mk ?loc ?attrs (Pcty_extension a)
+  let open_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcty_open (a, b, c))
 end
 
 module Ctf = struct

diff --git a/parsing/ast_helper.mli b/parsing/ast_helper.mli
index 0a216bdb56ea7c217d0558d33886668928178051..efc1dfcad5cd83645e9c7af1c5038bcb0a95a55c 100644 (file)
--- a/parsing/ast_helper.mli
+++ b/parsing/ast_helper.mli
@@ -24,7 +24,7 @@ type str = string loc
 type loc = Location.t
 type attrs = attribute list
 
-(** {2 Default locations} *)
+(** {1 Default locations} *)
 
 val default_loc: loc ref
     (** Default value for all optional location arguments. *)
@@ -33,7 +33,7 @@ val with_default_loc: loc -> (unit -> 'a) -> 'a
     (** Set the [default_loc] within the scope of the execution
         of the provided function. *)
 
-(** {2 Constants} *)
+(** {1 Constants} *)
 
 module Const : sig
   val char : char -> constant
@@ -46,7 +46,7 @@ module Const : sig
   val float : ?suffix:char -> string -> constant
 end
 
-(** {2 Core language} *)
+(** {1 Core language} *)
 
 (** Type expressions *)
 module Typ :
@@ -60,9 +60,8 @@ module Typ :
                -> core_type
     val tuple: ?loc:loc -> ?attrs:attrs -> core_type list -> core_type
     val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type
-    val object_: ?loc:loc -> ?attrs:attrs ->
-                  (str * attributes * core_type) list -> closed_flag ->
-                  core_type
+    val object_: ?loc:loc -> ?attrs:attrs -> object_field list
+                   -> closed_flag -> core_type
     val class_: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type
     val alias: ?loc:loc -> ?attrs:attrs -> core_type -> string -> core_type
     val variant: ?loc:loc -> ?attrs:attrs -> row_field list -> closed_flag
@@ -217,7 +216,7 @@ module Te:
       str -> lid -> extension_constructor
   end
 
-(** {2 Module language} *)
+(** {1 Module language} *)
 
 (** Module type expressions *)
 module Mty:
@@ -340,7 +339,7 @@ module Vb:
   end
 
 
-(** {2 Class language} *)
+(** {1 Class language} *)
 
 (** Class type expressions *)
 module Cty:
@@ -353,6 +352,8 @@ module Cty:
     val arrow: ?loc:loc -> ?attrs:attrs -> arg_label -> core_type ->
       class_type -> class_type
     val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_type
+    val open_: ?loc:loc -> ?attrs:attrs -> override_flag -> lid -> class_type
+               -> class_type
   end
 
 (** Class type fields *)
@@ -391,6 +392,8 @@ module Cl:
     val constraint_: ?loc:loc -> ?attrs:attrs -> class_expr -> class_type ->
       class_expr
     val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_expr
+    val open_: ?loc:loc -> ?attrs:attrs -> override_flag -> lid -> class_expr
+               -> class_expr
   end
 
 (** Class fields *)

diff --git a/parsing/ast_iterator.ml b/parsing/ast_iterator.ml
index 8518438d829c077195eb48182a070ad4a6c24483..aa601e6419b458e1e51d6f2fd6972bc1e0bc09e1 100755 (executable)
--- a/parsing/ast_iterator.ml
+++ b/parsing/ast_iterator.ml
@@ -87,6 +87,11 @@ module T = struct
         sub.attributes sub attrs; List.iter (sub.typ sub) tl
     | Rinherit t -> sub.typ sub t
 
+  let object_field sub = function
+    | Otag (_, attrs, t) ->
+        sub.attributes sub attrs; sub.typ sub t
+    | Oinherit t -> sub.typ sub t
+
   let iter sub {ptyp_desc = desc; ptyp_loc = loc; ptyp_attributes = attrs} =
     sub.location sub loc;
     sub.attributes sub attrs;
@@ -98,9 +103,8 @@ module T = struct
     | Ptyp_tuple tyl -> List.iter (sub.typ sub) tyl
     | Ptyp_constr (lid, tl) ->
         iter_loc sub lid; List.iter (sub.typ sub) tl
-    | Ptyp_object (l, _o) ->
-        let f (_, a, t) = sub.attributes sub a; sub.typ sub t in
-        List.iter f l
+    | Ptyp_object (ol, _o) ->
+        List.iter (object_field sub) ol
     | Ptyp_class (lid, tl) ->
         iter_loc sub lid; List.iter (sub.typ sub) tl
     | Ptyp_alias (t, _) -> sub.typ sub t
@@ -182,6 +186,8 @@ module CT = struct
     | Pcty_arrow (_lab, t, ct) ->
         sub.typ sub t; sub.class_type sub ct
     | Pcty_extension x -> sub.extension sub x
+    | Pcty_open (_ovf, lid, e) ->
+        iter_loc sub lid; sub.class_type sub e
 
   let iter_field sub {pctf_desc = desc; pctf_loc = loc; pctf_attributes = attrs}
     =
@@ -226,7 +232,8 @@ module MT = struct
         iter_loc sub lid; sub.type_declaration sub d
     | Pwith_module (lid, lid2) ->
         iter_loc sub lid; iter_loc sub lid2
-    | Pwith_typesubst d -> sub.type_declaration sub d
+    | Pwith_typesubst (lid, d) ->
+        iter_loc sub lid; sub.type_declaration sub d
     | Pwith_modsubst (s, lid) ->
         iter_loc sub s; iter_loc sub lid
 
@@ -427,6 +434,8 @@ module CE = struct
     | Pcl_constraint (ce, ct) ->
         sub.class_expr sub ce; sub.class_type sub ct
     | Pcl_extension x -> sub.extension sub x
+    | Pcl_open (_ovf, lid, e) ->
+        iter_loc sub lid; sub.class_expr sub e
 
   let iter_kind sub = function
     | Cfk_concrete (_o, e) -> sub.expr sub e

diff --git a/parsing/ast_iterator.mli b/parsing/ast_iterator.mli
index 28df9af1372274878734fa4ea056fe4a05566147..bd8e0816873fe98b535fd6edbd504596110074fc 100755 (executable)
--- a/parsing/ast_iterator.mli
+++ b/parsing/ast_iterator.mli
@@ -19,7 +19,7 @@
 
 open Parsetree
 
-(** {2 A generic Parsetree iterator} *)
+(** {1 A generic Parsetree iterator} *)
 
 type iterator = {
   attribute: iterator -> attribute -> unit;

diff --git a/parsing/ast_mapper.ml b/parsing/ast_mapper.ml
index d58663ec26e07ee1d167a76d9e2867ec4e893f73..783d0e2eea50da52aba04547a01156a90bf03c47 100644 (file)
--- a/parsing/ast_mapper.ml
+++ b/parsing/ast_mapper.ml
@@ -85,9 +85,15 @@ module T = struct
 
   let row_field sub = function
     | Rtag (l, attrs, b, tl) ->
-        Rtag (l, sub.attributes sub attrs, b, List.map (sub.typ sub) tl)
+        Rtag (map_loc sub l, sub.attributes sub attrs,
+              b, List.map (sub.typ sub) tl)
     | Rinherit t -> Rinherit (sub.typ sub t)
 
+  let object_field sub = function
+    | Otag (l, attrs, t) ->
+        Otag (map_loc sub l, sub.attributes sub attrs, sub.typ sub t)
+    | Oinherit t -> Oinherit (sub.typ sub t)
+
   let map sub {ptyp_desc = desc; ptyp_loc = loc; ptyp_attributes = attrs} =
     let open Typ in
     let loc = sub.location sub loc in
@@ -101,9 +107,7 @@ module T = struct
     | Ptyp_constr (lid, tl) ->
         constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl)
     | Ptyp_object (l, o) ->
-        let f (s, a, t) =
-          (map_loc sub s, sub.attributes sub a, sub.typ sub t) in
-        object_ ~loc ~attrs (List.map f l) o
+        object_ ~loc ~attrs (List.map (object_field sub) l) o
     | Ptyp_class (lid, tl) ->
         class_ ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl)
     | Ptyp_alias (t, s) -> alias ~loc ~attrs (sub.typ sub t) s
@@ -191,6 +195,8 @@ module CT = struct
     | Pcty_arrow (lab, t, ct) ->
         arrow ~loc ~attrs lab (sub.typ sub t) (sub.class_type sub ct)
     | Pcty_extension x -> extension ~loc ~attrs (sub.extension sub x)
+    | Pcty_open (ovf, lid, ct) ->
+        open_ ~loc ~attrs ovf (map_loc sub lid) (sub.class_type sub ct)
 
   let map_field sub {pctf_desc = desc; pctf_loc = loc; pctf_attributes = attrs}
     =
@@ -240,7 +246,8 @@ module MT = struct
         Pwith_type (map_loc sub lid, sub.type_declaration sub d)
     | Pwith_module (lid, lid2) ->
         Pwith_module (map_loc sub lid, map_loc sub lid2)
-    | Pwith_typesubst d -> Pwith_typesubst (sub.type_declaration sub d)
+    | Pwith_typesubst (lid, d) ->
+        Pwith_typesubst (map_loc sub lid, sub.type_declaration sub d)
     | Pwith_modsubst (s, lid) ->
         Pwith_modsubst (map_loc sub s, map_loc sub lid)
 
@@ -451,6 +458,8 @@ module CE = struct
     | Pcl_constraint (ce, ct) ->
         constraint_ ~loc ~attrs (sub.class_expr sub ce) (sub.class_type sub ct)
     | Pcl_extension x -> extension ~loc ~attrs (sub.extension sub x)
+    | Pcl_open (ovf, lid, ce) ->
+        open_ ~loc ~attrs ovf (map_loc sub lid) (sub.class_expr sub ce)
 
   let map_kind sub = function
     | Cfk_concrete (o, e) -> Cfk_concrete (o, sub.expr sub e)
@@ -716,6 +725,8 @@ module PpxContext = struct
         lid "open_modules", make_list make_string !Clflags.open_modules;
         lid "for_package",  make_option make_string !Clflags.for_package;
         lid "debug",        make_bool !Clflags.debug;
+        lid "use_threads",  make_bool !Clflags.use_threads;
+        lid "use_vmthreads", make_bool !Clflags.use_vmthreads;
         get_cookies ()
       ]
     in
@@ -782,6 +793,10 @@ module PpxContext = struct
           Clflags.for_package := get_option get_string payload
       | "debug" ->
           Clflags.debug := get_bool payload
+      | "use_threads" ->
+          Clflags.use_threads := get_bool payload
+      | "use_vmthreads" ->
+          Clflags.use_vmthreads := get_bool payload
       | "cookies" ->
           let l = get_list (get_pair get_string (fun x -> x)) payload in
           cookies :=
@@ -804,9 +819,10 @@ end
 
 let ppx_context = PpxContext.make
 
-let ext_of_exn exn =
+let extension_of_exn exn =
   match error_of_exn exn with
-  | Some error -> extension_of_error error
+  | Some (`Ok error) -> extension_of_error error
+  | Some `Already_displayed -> { loc = Location.none; txt = "ocaml.error" }, PStr []
   | None -> raise exn
 
 
@@ -824,7 +840,7 @@ let apply_lazy ~source ~target mapper =
         let mapper = mapper () in
         mapper.structure mapper ast
       with exn ->
-        [{pstr_desc = Pstr_extension (ext_of_exn exn, []);
+        [{pstr_desc = Pstr_extension (extension_of_exn exn, []);
           pstr_loc  = Location.none}]
     in
     let fields = PpxContext.update_cookies fields in
@@ -843,7 +859,7 @@ let apply_lazy ~source ~target mapper =
         let mapper = mapper () in
         mapper.signature mapper ast
       with exn ->
-        [{psig_desc = Psig_extension (ext_of_exn exn, []);
+        [{psig_desc = Psig_extension (extension_of_exn exn, []);
           psig_loc  = Location.none}]
     in
     let fields = PpxContext.update_cookies fields in
@@ -910,7 +926,7 @@ let run_main mapper =
       let mapper () =
         try mapper (Array.to_list (Array.sub a 1 (n - 3)))
         with exn ->
-          (* PR #6463 *)
+          (* PR#6463 *)
           let f _ _ = raise exn in
           {default_mapper with structure = f; signature = f}
       in

diff --git a/parsing/ast_mapper.mli b/parsing/ast_mapper.mli
index 8889d2f3b2b986e1a31dd9a7b9761cbb1e9aed36..85b59e9c37d57f272aee473923a5d36eaeab0281 100644 (file)
--- a/parsing/ast_mapper.mli
+++ b/parsing/ast_mapper.mli
@@ -50,7 +50,7 @@ let () =
 
 open Parsetree
 
-(** {2 A generic Parsetree mapper} *)
+(** {1 A generic Parsetree mapper} *)
 
 type mapper = {
   attribute: mapper -> attribute -> attribute;
@@ -106,7 +106,7 @@ type mapper = {
 val default_mapper: mapper
 (** A default mapper, which implements a "deep identity" mapping. *)
 
-(** {2 Apply mappers to compilation units} *)
+(** {1 Apply mappers to compilation units} *)
 
 val tool_name: unit -> string
 (** Can be used within a ppx preprocessor to know which tool is
@@ -131,7 +131,7 @@ val run_main: (string list -> mapper) -> unit
     function implements proper error reporting for uncaught
     exceptions. *)
 
-(** {2 Registration API} *)
+(** {1 Registration API} *)
 
 val register_function: (string -> (string list -> mapper) -> unit) ref
 
@@ -153,7 +153,7 @@ val register: string -> (string list -> mapper) -> unit
     the ppx driver.  *)
 
 
-(** {2 Convenience functions to write mappers} *)
+(** {1 Convenience functions to write mappers} *)
 
 val map_opt: ('a -> 'b) -> 'a option -> 'b option
 
@@ -167,7 +167,7 @@ val attribute_of_warning: Location.t -> string -> attribute
     inserted in a generated Parsetree.  The compiler will be
     responsible for reporting the warning. *)
 
-(** {2 Helper functions to call external mappers} *)
+(** {1 Helper functions to call external mappers} *)
 
 val add_ppx_context_str:
     tool_name:string -> Parsetree.structure -> Parsetree.structure
@@ -190,7 +190,7 @@ val drop_ppx_context_sig:
     restore:bool -> Parsetree.signature -> Parsetree.signature
 (** Same as [drop_ppx_context_str], but for signatures. *)
 
-(** {2 Cookies} *)
+(** {1 Cookies} *)
 
 (** Cookies are used to pass information from a ppx processor to
     a further invocation of itself, when called from the OCaml

diff --git a/parsing/builtin_attributes.ml b/parsing/builtin_attributes.ml
index bdbefcdf5ef8d0947d537f4d814bae2e9908479a..a8eb33b6076c7743335c8c066338688f8ceb383e 100755 (executable)
--- a/parsing/builtin_attributes.ml
+++ b/parsing/builtin_attributes.ml
@@ -25,6 +25,11 @@ let string_of_payload = function
       string_of_cst c
   | _ -> None
 
+let string_of_opt_payload p =
+  match string_of_payload p with
+  | Some s -> s
+  | None -> ""
+
 let rec error_of_extension ext =
   match ext with
   | ({txt = ("ocaml.error"|"error") as txt; loc}, p) ->
@@ -39,6 +44,7 @@ let rec error_of_extension ext =
       | [] -> []
     in
     begin match p with
+    | PStr [] -> raise Location.Already_displayed_error
     | PStr({pstr_desc=Pstr_eval
               ({pexp_desc=Pexp_constant(Pconst_string(msg,_))}, _)}::
            {pstr_desc=Pstr_eval
@@ -53,35 +59,45 @@ let rec error_of_extension ext =
   | ({txt; loc}, _) ->
       Location.errorf ~loc "Uninterpreted extension '%s'." txt
 
+let cat s1 s2 =
+  if s2 = "" then s1 else s1 ^ "\n" ^ s2
+
 let rec deprecated_of_attrs = function
   | [] -> None
   | ({txt = "ocaml.deprecated"|"deprecated"; _}, p) :: _ ->
-      begin match string_of_payload p with
-      | Some txt ->  Some txt
-      | None -> Some ""
-      end
+      Some (string_of_opt_payload p)
   | _ :: tl -> deprecated_of_attrs tl
 
 let check_deprecated loc attrs s =
   match deprecated_of_attrs attrs with
   | None -> ()
-  | Some "" -> Location.prerr_warning loc (Warnings.Deprecated s)
-  | Some txt ->
-      Location.prerr_warning loc (Warnings.Deprecated (s ^ "\n" ^ txt))
+  | Some txt -> Location.deprecated loc (cat s txt)
 
-let rec check_deprecated_mutable loc attrs s =
-  match attrs with
-  | [] -> ()
+let check_deprecated_inclusion ~def ~use loc attrs1 attrs2 s =
+  match deprecated_of_attrs attrs1, deprecated_of_attrs attrs2 with
+  | None, _ | Some _, Some _ -> ()
+  | Some txt, None -> Location.deprecated ~def ~use loc (cat s txt)
+
+let rec deprecated_mutable_of_attrs = function
+  | [] -> None
   | ({txt = "ocaml.deprecated_mutable"|"deprecated_mutable"; _}, p) :: _ ->
-      let txt =
-        match string_of_payload p with
-        | Some txt -> "\n" ^ txt
-        | None -> ""
-      in
-      Location.prerr_warning loc
-        (Warnings.Deprecated (Printf.sprintf "mutating field %s%s"
-           s txt))
-  | _ :: tl -> check_deprecated_mutable loc tl s
+      Some (string_of_opt_payload p)
+  | _ :: tl -> deprecated_mutable_of_attrs tl
+
+let check_deprecated_mutable loc attrs s =
+  match deprecated_mutable_of_attrs attrs with
+  | None -> ()
+  | Some txt ->
+      Location.deprecated loc (Printf.sprintf "mutating field %s" (cat s txt))
+
+let check_deprecated_mutable_inclusion ~def ~use loc attrs1 attrs2 s =
+  match deprecated_mutable_of_attrs attrs1,
+        deprecated_mutable_of_attrs attrs2
+  with
+  | None, _ | Some _, Some _ -> ()
+  | Some txt, None ->
+      Location.deprecated ~def ~use loc
+        (Printf.sprintf "mutating field %s" (cat s txt))
 
 let rec deprecated_of_sig = function
   | {psig_desc = Psig_attribute a} :: tl ->
@@ -101,42 +117,7 @@ let rec deprecated_of_str = function
   | _ -> None
 
 
-let emit_external_warnings =
-  (* Note: this is run as a preliminary pass when type-checking an
-     interface or implementation.  This allows to cover all kinds of
-     attributes, but the drawback is that it doesn't take local
-     configuration of warnings (with '@@warning'/'@@warnerror'
-     attributes) into account.  We should rather check for
-     'ppwarning' attributes during the actual type-checking, making
-     sure to cover all contexts (easier and more ugly alternative:
-     duplicate here the logic which control warnings locally). *)
-  let open Ast_iterator in
-  {
-    default_iterator with
-    attribute = (fun _ a ->
-        match a with
-        | {txt="ocaml.ppwarning"|"ppwarning"},
-          PStr[{pstr_desc=Pstr_eval({pexp_desc=Pexp_constant
-                                         (Pconst_string (s, _))},_);
-                pstr_loc}] ->
-            Location.prerr_warning pstr_loc (Warnings.Preprocessor s)
-        | _ -> ()
-      )
-  }
-
-
-let warning_scope = ref []
-
-let warning_enter_scope () =
-  warning_scope := (Warnings.backup ()) :: !warning_scope
-let warning_leave_scope () =
-  match !warning_scope with
-  | [] -> assert false
-  | hd :: tl ->
-      Warnings.restore hd;
-      warning_scope := tl
-
-let warning_attribute attrs =
+let warning_attribute ?(ppwarning = true) =
   let process loc txt errflag payload =
     match string_of_payload payload with
     | Some s ->
@@ -151,26 +132,28 @@ let warning_attribute attrs =
           (Warnings.Attribute_payload
              (txt, "A single string literal is expected"))
   in
-  List.iter
-    (function
-      | ({txt = ("ocaml.warning"|"warning") as txt; loc}, payload) ->
-          process loc txt false payload
-      | ({txt = ("ocaml.warnerror"|"warnerror") as txt; loc}, payload) ->
-          process loc txt true payload
-      | _ ->
-          ()
-    )
-    attrs
-
-let with_warning_attribute attrs f =
+  function
+  | ({txt = ("ocaml.warning"|"warning") as txt; loc}, payload) ->
+      process loc txt false payload
+  | ({txt = ("ocaml.warnerror"|"warnerror") as txt; loc}, payload) ->
+      process loc txt true payload
+  | {txt="ocaml.ppwarning"|"ppwarning"},
+    PStr[{pstr_desc=Pstr_eval({pexp_desc=Pexp_constant
+                                   (Pconst_string (s, _))},_);
+          pstr_loc}] when ppwarning ->
+      Location.prerr_warning pstr_loc (Warnings.Preprocessor s)
+  | _ ->
+      ()
+
+let warning_scope ?ppwarning attrs f =
+  let prev = Warnings.backup () in
   try
-    warning_enter_scope ();
-    warning_attribute attrs;
+    List.iter (warning_attribute ?ppwarning) (List.rev attrs);
     let ret = f () in
-    warning_leave_scope ();
+    Warnings.restore prev;
     ret
   with exn ->
-    warning_leave_scope ();
+    Warnings.restore prev;
     raise exn
 
 

diff --git a/parsing/builtin_attributes.mli b/parsing/builtin_attributes.mli
index 9add63733f995de2d459a29e78ea07a09927ec1e..056316a697da7837268fcbb0b5034187baac85a6 100755 (executable)
--- a/parsing/builtin_attributes.mli
+++ b/parsing/builtin_attributes.mli
@@ -29,21 +29,42 @@
 
 
 val check_deprecated: Location.t -> Parsetree.attributes -> string -> unit
+val check_deprecated_inclusion:
+  def:Location.t -> use:Location.t -> Location.t -> Parsetree.attributes ->
+  Parsetree.attributes -> string -> unit
 val deprecated_of_attrs: Parsetree.attributes -> string option
 val deprecated_of_sig: Parsetree.signature -> string option
 val deprecated_of_str: Parsetree.structure -> string option
 
 val check_deprecated_mutable:
     Location.t -> Parsetree.attributes -> string -> unit
+val check_deprecated_mutable_inclusion:
+  def:Location.t -> use:Location.t -> Location.t -> Parsetree.attributes ->
+  Parsetree.attributes -> string -> unit
 
 val error_of_extension: Parsetree.extension -> Location.error
 
-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 warning_attribute: ?ppwarning:bool -> Parsetree.attribute -> unit
+  (** Apply warning settings from the specified attribute.
+      "ocaml.warning"/"ocaml.warnerror" (and variants without the prefix)
+      are processed and other attributes are ignored.
 
-val emit_external_warnings: Ast_iterator.iterator
+      Also implement ocaml.ppwarning (unless ~ppwarning:false is
+      passed).
+  *)
+
+val warning_scope:
+  ?ppwarning:bool ->
+  Parsetree.attributes -> (unit -> 'a) -> 'a
+  (** Execute a function in a new scope for warning settings.  This
+      means that the effect of any call to [warning_attribute] during
+      the execution of this function will be discarded after
+      execution.
+
+      The function also takes a list of attributes which are processed
+      with [warning_attribute] in the fresh scope before the function
+      is executed.
+  *)
 
 val warn_on_literal_pattern: Parsetree.attributes -> bool
 val explicit_arity: Parsetree.attributes -> bool

diff --git a/parsing/depend.ml b/parsing/depend.ml
index 8703ffe0199f050055e070bfdaf8dceea0401015..e0851d761004845f1a4a5717660b355829d2c896 100644 (file)
--- a/parsing/depend.ml
+++ b/parsing/depend.ml
@@ -18,6 +18,8 @@ open Location
 open Longident
 open Parsetree
 
+let pp_deps = ref []
+
 module StringSet = Set.Make(struct type t = string let compare = compare end)
 module StringMap = Map.Make(String)
 
@@ -102,7 +104,10 @@ let rec add_type bv ty =
   | Ptyp_arrow(_, t1, t2) -> add_type bv t1; add_type bv t2
   | Ptyp_tuple tl -> List.iter (add_type bv) tl
   | Ptyp_constr(c, tl) -> add bv c; List.iter (add_type bv) tl
-  | Ptyp_object (fl, _) -> List.iter (fun (_, _, t) -> add_type bv t) fl
+  | Ptyp_object (fl, _) ->
+      List.iter
+       (function Otag (_, _, t) -> add_type bv t
+         | Oinherit t -> add_type bv t) fl
   | Ptyp_class(c, tl) -> add bv c; List.iter (add_type bv) tl
   | Ptyp_alias(t, _) -> add_type bv t
   | Ptyp_variant(fl, _, _) ->
@@ -165,6 +170,8 @@ let rec add_class_type bv cty =
   | Pcty_arrow(_, ty1, cty2) ->
       add_type bv ty1; add_class_type bv cty2
   | Pcty_extension e -> handle_extension e
+  | Pcty_open (_ovf, m, e) ->
+      let bv = open_module bv m.txt in add_class_type bv e
 
 and add_class_type_field bv pctf =
   match pctf.pctf_desc with
@@ -300,7 +307,7 @@ and add_modtype bv mty =
         (function
           | Pwith_type (_, td) -> add_type_declaration bv td
           | Pwith_module (_, lid) -> addmodule bv lid
-          | Pwith_typesubst td -> add_type_declaration bv td
+          | Pwith_typesubst (_, td) -> add_type_declaration bv td
           | Pwith_modsubst (_, lid) -> addmodule bv lid
         )
         cstrl
@@ -500,6 +507,8 @@ and add_class_expr bv ce =
   | Pcl_constraint(ce, ct) ->
       add_class_expr bv ce; add_class_type bv ct
   | Pcl_extension e -> handle_extension e
+  | Pcl_open (_ovf, m, e) ->
+      let bv = open_module bv m.txt in add_class_expr bv e
 
 and add_class_field bv pcf =
   match pcf.pcf_desc with

diff --git a/parsing/depend.mli b/parsing/depend.mli
index e34abbe7fce817f7bea25774bd30bb6499ed09ea..6efd5e09ed981ef6aee8b97c7d4207b0de6ad8cf 100644 (file)
--- a/parsing/depend.mli
+++ b/parsing/depend.mli
@@ -26,6 +26,9 @@ val weaken_map : StringSet.t -> map_tree -> map_tree
 
 val free_structure_names : StringSet.t ref
 
+(* dependencies found by preprocessing tools (plugins) *)
+val pp_deps : string list ref
+
 val open_module : bound_map -> Longident.t -> bound_map
 
 val add_use_file : bound_map -> Parsetree.toplevel_phrase list -> unit

diff --git a/parsing/docstrings.ml b/parsing/docstrings.ml
index 5524aea20978386173d7a4f6d6e13545da711d36..5de6d4d4fa73d44abfd28a5710c8b8c882d4f37a 100644 (file)
--- a/parsing/docstrings.ml
+++ b/parsing/docstrings.ml
@@ -125,7 +125,7 @@ let add_info_attrs info attrs =
   | None | Some {ds_body=""; _} -> attrs
   | Some ds -> attrs @ [info_attr ds]
 
-(* Docstrings not attached to a specifc item *)
+(* Docstrings not attached to a specific item *)
 
 type text = docstring list
 

diff --git a/parsing/docstrings.mli b/parsing/docstrings.mli
index 500ecbf08362530e9ff1169c9911152c1be2ef07..892a80e278c82c621726361a190bdd10590cb798 100644 (file)
--- a/parsing/docstrings.mli
+++ b/parsing/docstrings.mli
@@ -21,7 +21,7 @@ val init : unit -> unit
 (** Emit warnings for unattached and ambiguous docstrings *)
 val warn_bad_docstrings : unit -> unit
 
-(** {3 Docstrings} *)
+(** {2 Docstrings} *)
 
 (** Documentation comments *)
 type docstring
@@ -38,7 +38,7 @@ val docstring_body : docstring -> string
 (** Get the location of a docstring *)
 val docstring_loc : docstring -> Location.t
 
-(** {3 Set functions}
+(** {2 Set functions}
 
    These functions are used by the lexer to associate docstrings to
    the locations of tokens. *)
@@ -58,7 +58,7 @@ 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}
+(** {2 Items}
 
     The {!docs} type represents documentation attached to an item. *)
 
@@ -93,7 +93,7 @@ val mark_symbol_docs : unit -> unit
     two positions (for ambiguity warnings) *)
 val mark_rhs_docs : int -> int -> unit
 
-(** {3 Fields and constructors}
+(** {2 Fields and constructors}
 
     The {!info} type represents documentation attached to a field or
     constructor. *)
@@ -114,7 +114,7 @@ val symbol_info : unit -> info
 (** Fetch the field info following the symbol at a given position. *)
 val rhs_info : int -> info
 
-(** {3 Unattached comments}
+(** {2 Unattached comments}
 
     The {!text} type represents documentation which is not attached to
     anything. *)
@@ -137,7 +137,7 @@ val symbol_text_lazy : unit -> text Lazy.t
 val rhs_text : int -> text
 val rhs_text_lazy : int -> text Lazy.t
 
-(** {3 Extra text}
+(** {2 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

diff --git a/parsing/lexer.mll b/parsing/lexer.mll
index a485f3ed50ab9a30961dbf8ae8f493a492844d83..1e385a044a931dad0c4bd98d685295ac826c32fa 100644 (file)
--- a/parsing/lexer.mll
+++ b/parsing/lexer.mll
@@ -99,35 +99,14 @@ let keyword_table =
 
 (* To buffer string literals *)
 
-let initial_string_buffer = Bytes.create 256
-let string_buff = ref initial_string_buffer
-let string_index = ref 0
-
-let reset_string_buffer () =
-  string_buff := initial_string_buffer;
-  string_index := 0
-
-let store_string_char c =
-  if !string_index >= Bytes.length !string_buff then begin
-    let new_buff = Bytes.create (Bytes.length (!string_buff) * 2) in
-    Bytes.blit !string_buff 0 new_buff 0 (Bytes.length !string_buff);
-    string_buff := new_buff
-  end;
-  Bytes.unsafe_set !string_buff !string_index c;
-  incr string_index
-
-let store_string s =
-  for i = 0 to String.length s - 1 do
-    store_string_char s.[i];
-  done
-
-let store_lexeme lexbuf =
-  store_string (Lexing.lexeme lexbuf)
-
-let get_stored_string () =
-  let s = Bytes.sub_string !string_buff 0 !string_index in
-  string_buff := initial_string_buffer;
-  s
+let string_buffer = Buffer.create 256
+let reset_string_buffer () = Buffer.reset string_buffer
+let get_stored_string () = Buffer.contents string_buffer
+
+let store_string_char c = Buffer.add_char string_buffer c
+let store_string_utf_8_uchar u = Buffer.add_utf_8_uchar string_buffer u
+let store_string s = Buffer.add_string string_buffer s
+let store_lexeme lexbuf = store_string (Lexing.lexeme lexbuf)
 
 (* To store the position of the beginning of a string and comment *)
 let string_start_loc = ref Location.none;;
@@ -141,6 +120,9 @@ let print_warnings = ref true
 let store_escaped_char lexbuf c =
   if in_comment () then store_lexeme lexbuf else store_string_char c
 
+let store_escaped_uchar lexbuf u =
+  if in_comment () then store_lexeme lexbuf else store_string_utf_8_uchar u
+
 let with_comment_buffer comment lexbuf =
   let start_loc = Location.curr lexbuf  in
   comment_start_loc := [start_loc];
@@ -153,6 +135,21 @@ let with_comment_buffer comment lexbuf =
 
 (* To translate escape sequences *)
 
+let hex_digit_value d = (* assert (d in '0'..'9' 'a'..'f' 'A'..'F') *)
+  let d = Char.code d in
+  if d >= 97 then d - 87 else
+  if d >= 65 then d - 55 else
+  d - 48
+
+let hex_num_value lexbuf ~first ~last =
+  let rec loop acc i = match i > last with
+  | true -> acc
+  | false ->
+      let value = hex_digit_value (Lexing.lexeme_char lexbuf i) in
+      loop (16 * acc + value) (i + 1)
+  in
+  loop 0 first
+
 let char_for_backslash = function
   | 'n' -> '\010'
   | 'r' -> '\013'
@@ -178,17 +175,24 @@ let char_for_octal_code lexbuf i =
   Char.chr c
 
 let char_for_hexadecimal_code lexbuf i =
-  let d1 = Char.code (Lexing.lexeme_char lexbuf i) in
-  let val1 = if d1 >= 97 then d1 - 87
-             else if d1 >= 65 then d1 - 55
-             else d1 - 48
-  in
-  let d2 = Char.code (Lexing.lexeme_char lexbuf (i+1)) in
-  let val2 = if d2 >= 97 then d2 - 87
-             else if d2 >= 65 then d2 - 55
-             else d2 - 48
+  let byte = hex_num_value lexbuf ~first:i ~last:(i+1) in
+  Char.chr byte
+
+let uchar_for_uchar_escape lexbuf =
+  let err e =
+    raise
+      (Error (Illegal_escape (Lexing.lexeme lexbuf ^ e), Location.curr lexbuf))
   in
-  Char.chr (val1 * 16 + val2)
+  let len = Lexing.lexeme_end lexbuf - Lexing.lexeme_start lexbuf in
+  let first = 3 (* skip opening \u{ *) in
+  let last = len - 2 (* skip closing } *) in
+  let digit_count = last - first + 1 in
+  match digit_count > 6 with
+  | true -> err ", too many digits, expected 1 to 6 hexadecimal digits"
+  | false ->
+      let cp = hex_num_value lexbuf ~first ~last in
+      if Uchar.is_valid cp then Uchar.unsafe_of_int cp else
+      err (", " ^ Printf.sprintf "%X" cp ^ " is not a Unicode scalar value")
 
 (* recover the name from a LABEL or OPTLABEL token *)
 
@@ -222,9 +226,7 @@ let escaped_newlines = ref false
 (* Warn about Latin-1 characters used in idents *)
 
 let warn_latin1 lexbuf =
-  Location.prerr_warning (Location.curr lexbuf)
-    (Warnings.Deprecated "ISO-Latin1 characters in identifiers")
-;;
+  Location.deprecated (Location.curr lexbuf)"ISO-Latin1 characters in identifiers"
 
 let handle_docstrings = ref true
 let comment_list = ref []
@@ -290,8 +292,12 @@ let identchar_latin1 =
   ['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9']
 let symbolchar =
   ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~']
+let dotsymbolchar =
+  ['!' '$' '%' '&' '*' '+' '-' '/' ':' '=' '>' '?' '@' '^' '|' '~']
 let decimal_literal =
   ['0'-'9'] ['0'-'9' '_']*
+let hex_digit =
+  ['0'-'9' 'A'-'F' 'a'-'f']
 let hex_literal =
   '0' ['x' 'X'] ['0'-'9' 'A'-'F' 'a'-'f']['0'-'9' 'A'-'F' 'a'-'f' '_']*
 let oct_literal =
@@ -463,6 +469,7 @@ rule token = parse
   | "->" { MINUSGREATER }
   | "."  { DOT }
   | ".." { DOTDOT }
+  | "." (dotsymbolchar symbolchar* as s) { DOTOP s }
   | ":"  { COLON }
   | "::" { COLONCOLON }
   | ":=" { COLONEQUAL }
@@ -526,7 +533,7 @@ and comment = parse
     "(*"
       { comment_start_loc := (Location.curr lexbuf) :: !comment_start_loc;
         store_lexeme lexbuf;
-        comment lexbuf;
+        comment lexbuf
       }
   | "*)"
       { match !comment_start_loc with
@@ -534,7 +541,7 @@ and comment = parse
         | [_] -> comment_start_loc := []; Location.curr lexbuf
         | _ :: l -> comment_start_loc := l;
                   store_lexeme lexbuf;
-                  comment lexbuf;
+                  comment lexbuf
        }
   | "\""
       {
@@ -629,6 +636,9 @@ and string = parse
   | '\\' 'x' ['0'-'9' 'a'-'f' 'A'-'F'] ['0'-'9' 'a'-'f' 'A'-'F']
       { store_escaped_char lexbuf (char_for_hexadecimal_code lexbuf 2);
          string lexbuf }
+  | '\\' 'u' '{' hex_digit+ '}'
+        { store_escaped_uchar lexbuf (uchar_for_uchar_escape lexbuf);
+          string lexbuf }
   | '\\' _
       { if not (in_comment ()) then begin
 (*  Should be an error, but we are very lax.
@@ -700,10 +710,10 @@ and skip_hash_bang = parse
     | Initial  (* There have been no docstrings yet *)
     | After of docstring list
         (* There have been docstrings, none of which were
-           preceeded by a blank line *)
+           preceded 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 *)
+           preceded by a blank line *)
 
   and docstring = Docstrings.docstring
 

diff --git a/parsing/location.ml b/parsing/location.ml
index abe47ef00357eb463f7f9b241011daaa89c40cf9..7fd915ce5c7e2b2d4611406b367162662720d57d 100644 (file)
--- a/parsing/location.ml
+++ b/parsing/location.ml
@@ -19,7 +19,7 @@ let absname = ref false
     (* This reference should be in Clflags, but it would create an additional
        dependency and make bootstrapping Camlp4 more difficult. *)
 
-type t = { loc_start: position; loc_end: position; loc_ghost: bool };;
+type t = Warnings.loc = { loc_start: position; loc_end: position; loc_ghost: bool };;
 
 let in_file name =
   let loc = {
@@ -144,7 +144,7 @@ let highlight_dumb ppf lb loc =
     end
   done;
   (* Print character location (useful for Emacs) *)
-  Format.fprintf ppf "Characters %i-%i:@."
+  Format.fprintf ppf "@[<v>Characters %i-%i:@,"
                  loc.loc_start.pos_cnum loc.loc_end.pos_cnum;
   (* Print the input, underlining the location *)
   Format.pp_print_string ppf "  ";
@@ -155,7 +155,7 @@ let highlight_dumb ppf lb loc =
     | '\n' ->
       if !line = !line_start && !line = !line_end then begin
         (* loc is on one line: underline location *)
-        Format.fprintf ppf "@.  ";
+        Format.fprintf ppf "@,  ";
         for _i = !pos_at_bol to loc.loc_start.pos_cnum - 1 do
           Format.pp_print_char ppf ' '
         done;
@@ -164,7 +164,7 @@ let highlight_dumb ppf lb loc =
         done
       end;
       if !line >= !line_start && !line <= !line_end then begin
-        Format.fprintf ppf "@.";
+        Format.fprintf ppf "@,";
         if pos < loc.loc_end.pos_cnum then Format.pp_print_string ppf "  "
       end;
       incr line;
@@ -191,7 +191,8 @@ let highlight_dumb ppf lb loc =
       else if !line > !line_start && !line < !line_end then
         (* intermediate line of multiline loc: print whole line *)
         Format.pp_print_char ppf c
-  done
+  done;
+  Format.fprintf ppf "@]"
 
 (* Highlight the location using one of the supported modes. *)
 
@@ -272,20 +273,22 @@ let print_loc ppf loc =
   end
 ;;
 
-let print ppf loc =
+let default_printer ppf loc =
   setup_colors ();
   if loc.loc_start.pos_fname = "//toplevel//"
   && highlight_locations ppf [loc] then ()
-  else fprintf ppf "@{<loc>%a@}%s@." print_loc loc msg_colon
+  else fprintf ppf "@{<loc>%a@}%s@," print_loc loc msg_colon
 ;;
 
+let printer = ref default_printer
+let print ppf loc = !printer ppf loc
+
 let error_prefix = "Error"
 let warning_prefix = "Warning"
 
-let print_error_prefix ppf () =
+let print_error_prefix ppf =
   setup_colors ();
-  fprintf ppf "@{<error>%s@}:" error_prefix;
-  ()
+  fprintf ppf "@{<error>%s@}" error_prefix;
 ;;
 
 let print_compact ppf loc =
@@ -300,18 +303,29 @@ let print_compact ppf loc =
 ;;
 
 let print_error ppf loc =
-  print ppf loc;
-  print_error_prefix ppf ()
+  fprintf ppf "%a%t:" print loc print_error_prefix;
 ;;
 
 let print_error_cur_file ppf () = print_error ppf (in_file !input_name);;
 
 let default_warning_printer loc ppf w =
-  if Warnings.is_active w then begin
+  match Warnings.report w with
+  | `Inactive -> ()
+  | `Active { Warnings. number; message; is_error; sub_locs } ->
     setup_colors ();
+    fprintf ppf "@[<v>";
     print ppf loc;
-    fprintf ppf "@{<warning>%s@} %a@." warning_prefix Warnings.print w
-  end
+    if is_error
+    then
+      fprintf ppf "%t (%s %d): %s@," print_error_prefix
+           (String.uncapitalize_ascii warning_prefix) number message
+    else fprintf ppf "@{<warning>%s@} %d: %s@," warning_prefix number message;
+    List.iter
+      (fun (loc, msg) ->
+         if loc <> none then fprintf ppf "  %a  %s@," print loc msg
+      )
+      sub_locs;
+    fprintf ppf "@]"
 ;;
 
 let warning_printer = ref default_warning_printer ;;
@@ -377,15 +391,20 @@ let error_of_exn : (exn -> error option) list ref = ref []
 
 let register_error_of_exn f = error_of_exn := f :: !error_of_exn
 
+exception Already_displayed_error = Warnings.Errors
+
 let error_of_exn exn =
-  let rec loop = function
-    | [] -> None
-    | f :: rest ->
-        match f exn with
-        | Some _ as r -> r
-        | None -> loop rest
-  in
-  loop !error_of_exn
+  match exn with
+  | Already_displayed_error -> Some `Already_displayed
+  | _ ->
+     let rec loop = function
+       | [] -> None
+       | f :: rest ->
+          match f exn with
+          | Some error -> Some (`Ok error)
+          | None -> loop rest
+     in
+     loop !error_of_exn
 
 let rec default_error_reporter ppf ({loc; msg; sub; if_highlight} as err) =
   let highlighted =
@@ -401,8 +420,9 @@ let rec default_error_reporter ppf ({loc; msg; sub; if_highlight} as err) =
   if highlighted then
     Format.pp_print_string ppf if_highlight
   else begin
-    fprintf ppf "%a%a %s" print loc print_error_prefix () msg;
-    List.iter (Format.fprintf ppf "@\n@[<2>%a@]" default_error_reporter) sub
+    fprintf ppf "@[<v>%a %s" print_error loc msg;
+    List.iter (Format.fprintf ppf "@,@[<2>%a@]" default_error_reporter) sub;
+    fprintf ppf "@]"
   end
 
 let error_reporter = ref default_error_reporter
@@ -423,16 +443,12 @@ let () =
       | Sys_error msg ->
           Some (errorf ~loc:(in_file !input_name)
                 "I/O error: %s" msg)
-      | Warnings.Errors n ->
-          Some
-            (errorf ~loc:(in_file !input_name)
-             "Some fatal warnings were triggered (%d occurrences)" n)
 
       | Misc.HookExnWrapper {error = e; hook_name;
                              hook_info={Misc.sourcefile}} ->
           let sub = match error_of_exn e with
-            | None -> error (Printexc.to_string e)
-            | Some err -> err
+            | None | Some `Already_displayed -> error (Printexc.to_string e)
+            | Some (`Ok err) -> err
           in
           Some
             (errorf ~loc:(in_file sourcefile)
@@ -444,12 +460,12 @@ let () =
 external reraise : exn -> 'a = "%reraise"
 
 let rec report_exception_rec n ppf exn =
-  try match error_of_exn exn with
-  | Some err ->
-      fprintf ppf "@[%a@]@." report_error err
-  | None -> reraise exn
-  with exn when n > 0 ->
-    report_exception_rec (n-1) ppf exn
+  try
+    match error_of_exn exn with
+    | None -> reraise exn
+    | Some `Already_displayed -> ()
+    | Some (`Ok err) -> fprintf ppf "@[%a@]@." report_error err
+  with exn when n > 0 -> report_exception_rec (n-1) ppf exn
 
 let report_exception ppf exn = report_exception_rec 5 ppf exn
 
@@ -467,3 +483,6 @@ let raise_errorf ?(loc = none) ?(sub = []) ?(if_highlight = "") =
   pp_ksprintf
     ~before:print_phanton_error_prefix
     (fun msg -> raise (Error ({loc; msg; sub; if_highlight})))
+
+let deprecated ?(def = none) ?(use = none) loc msg =
+  prerr_warning loc (Warnings.Deprecated (msg, def, use))

diff --git a/parsing/location.mli b/parsing/location.mli
index 4a7ac9596075fe2fe7c338fa1d0fd7b3a7e85e0d..c3e7c653578faa856455729579a1ed6db33e2ca2 100644 (file)
--- a/parsing/location.mli
+++ b/parsing/location.mli
@@ -17,7 +17,7 @@
 
 open Format
 
-type t = {
+type t = Warnings.loc = {
   loc_start: Lexing.position;
   loc_end: Lexing.position;
   loc_ghost: bool;
@@ -63,6 +63,9 @@ val prerr_warning: t -> Warnings.t -> unit
 val echo_eof: unit -> unit
 val reset: unit -> unit
 
+val default_printer : formatter -> t -> unit
+val printer : (formatter -> t -> unit) ref
+
 val warning_printer : (t -> formatter -> Warnings.t -> unit) ref
 (** Hook for intercepting warnings. *)
 
@@ -92,7 +95,7 @@ val show_filename: string -> string
 
 val absname: bool ref
 
-(* Support for located errors *)
+(** Support for located errors *)
 
 type error =
   {
@@ -102,11 +105,9 @@ type error =
     if_highlight: string; (* alternative message if locations are highlighted *)
   }
 
+exception Already_displayed_error
 exception Error of error
 
-val print_error_prefix: formatter -> unit -> unit
-  (* print the prefix "Error:" possibly with style *)
-
 val error: ?loc:t -> ?sub:error list -> ?if_highlight:string -> string -> error
 
 val errorf: ?loc:t -> ?sub:error list -> ?if_highlight:string
@@ -119,15 +120,15 @@ val error_of_printer: t -> (formatter -> 'a -> unit) -> 'a -> error
 
 val error_of_printer_file: (formatter -> 'a -> unit) -> 'a -> error
 
-val error_of_exn: exn -> error option
+val error_of_exn: exn -> [ `Ok of error | `Already_displayed ] option
 
 val register_error_of_exn: (exn -> error option) -> unit
-  (* Each compiler module which defines a custom type of exception
-     which can surface as a user-visible error should register
-     a "printer" for this exception using [register_error_of_exn].
-     The result of the printer is an [error] value containing
-     a location, a message, and optionally sub-messages (each of them
-     being located as well). *)
+(** Each compiler module which defines a custom type of exception
+    which can surface as a user-visible error should register
+    a "printer" for this exception using [register_error_of_exn].
+    The result of the printer is an [error] value containing
+    a location, a message, and optionally sub-messages (each of them
+    being located as well). *)
 
 val report_error: formatter -> error -> unit
 
@@ -138,4 +139,6 @@ 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. *)
+(** Reraise the exception if it is unknown. *)
+
+val deprecated: ?def:t -> ?use:t -> t -> string -> unit

diff --git a/parsing/longident.ml b/parsing/longident.ml
index 04677ca099b508db6e57582e4819b637b4ef22bf..6f5d5398363a72b03f4a4c91c35174b52256a3d2 100644 (file)
--- a/parsing/longident.ml
+++ b/parsing/longident.ml
@@ -37,8 +37,13 @@ let rec split_at_dots s pos =
   with Not_found ->
     [String.sub s pos (String.length s - pos)]
 
+let unflatten l =
+  match l with
+  | [] -> None
+  | hd :: tl -> Some (List.fold_left (fun p s -> Ldot(p, s)) (Lident hd) tl)
+
 let parse s =
-  match split_at_dots s 0 with
-    [] -> Lident ""  (* should not happen, but don't put assert false
-                        so as not to crash the toplevel (see Genprintval) *)
-  | hd :: tl -> List.fold_left (fun p s -> Ldot(p, s)) (Lident hd) tl
+  match unflatten (split_at_dots s 0) with
+  | None -> Lident ""  (* should not happen, but don't put assert false
+                          so as not to crash the toplevel (see Genprintval) *)
+  | Some v -> v

diff --git a/parsing/longident.mli b/parsing/longident.mli
index c7e7f3d27eedc4a5ee3d5f5d80fe84bc1c300715..5ffb16a812814dc92281031444d6c8a760a2cd00 100644 (file)
--- a/parsing/longident.mli
+++ b/parsing/longident.mli
@@ -21,5 +21,6 @@ type t =
   | Lapply of t * t
 
 val flatten: t -> string list
+val unflatten: string list -> t option
 val last: t -> string
 val parse: string -> t

diff --git a/parsing/parser.mly b/parsing/parser.mly
index f444810ede9d6bf07087c8b2c9b7f77ca4c7aead..3da1669b1a58abdf21f9f12db78bfcb9a70cba86 100644 (file)
--- a/parsing/parser.mly
+++ b/parsing/parser.mly
@@ -260,6 +260,8 @@ let mkpat_attrs d attrs =
 
 let wrap_class_attrs body attrs =
   {body with pcl_attributes = attrs @ body.pcl_attributes}
+let wrap_class_type_attrs body attrs =
+  {body with pcty_attributes = attrs @ body.pcty_attributes}
 let wrap_mod_attrs body attrs =
   {body with pmod_attributes = attrs @ body.pmod_attributes}
 let wrap_mty_attrs body attrs =
@@ -463,6 +465,7 @@ let package_type_of_module_type pmty =
 %token <string> INFIXOP2
 %token <string> INFIXOP3
 %token <string> INFIXOP4
+%token <string> DOTOP
 %token INHERIT
 %token INITIALIZER
 %token <string * char option> INT
@@ -595,7 +598,7 @@ The precedences must be listed from low to high.
 %nonassoc HASH                         /* simple_expr/toplevel_directive */
 %left     HASHOP
 %nonassoc below_DOT
-%nonassoc DOT
+%nonassoc DOT DOTOP
 /* Finally, the first tokens of simple_expr are above everything else. */
 %nonassoc BACKQUOTE BANG BEGIN CHAR FALSE FLOAT INT
           LBRACE LBRACELESS LBRACKET LBRACKETBAR LIDENT LPAREN
@@ -1033,6 +1036,8 @@ class_expr:
       { mkclass(Pcl_apply($1, List.rev $2)) }
   | let_bindings IN class_expr
       { class_of_let_bindings $1 $3 }
+  | LET OPEN override_flag attributes mod_longident IN class_expr
+      { wrap_class_attrs (mkclass(Pcl_open($3, mkrhs $5 5, $7))) $4 }
   | class_expr attribute
       { Cl.attr $1 $2 }
   | extension
@@ -1165,6 +1170,8 @@ class_signature:
       { Cty.attr $1 $2 }
   | extension
       { mkcty(Pcty_extension $1) }
+  | LET OPEN override_flag attributes mod_longident IN class_signature
+      { wrap_class_type_attrs (mkcty(Pcty_open($3, mkrhs $5 5, $7))) $4 }
 ;
 class_sig_body:
     class_self_type class_sig_fields
@@ -1260,7 +1267,7 @@ and_class_type_declaration:
 
 seq_expr:
   | expr        %prec below_SEMI  { $1 }
-  | expr SEMI                     { reloc_exp $1 }
+  | expr SEMI                     { $1 }
   | expr SEMI seq_expr            { mkexp(Pexp_sequence($1, $3)) }
   | expr SEMI PERCENT attr_id seq_expr
       { let seq = mkexp(Pexp_sequence ($1, $5)) in
@@ -1351,8 +1358,6 @@ expr:
       { mkexp_attrs(Pexp_for($3, $5, $7, $6, $9)) $2 }
   | expr COLONCOLON expr
       { mkexp_cons (rhs_loc 2) (ghexp(Pexp_tuple[$1;$3])) (symbol_rloc()) }
-  | LPAREN COLONCOLON RPAREN LPAREN expr COMMA expr RPAREN
-      { mkexp_cons (rhs_loc 2) (ghexp(Pexp_tuple[$5;$7])) (symbol_rloc()) }
   | expr INFIXOP0 expr
       { mkinfix $1 $2 $3 }
   | expr INFIXOP1 expr
@@ -1407,6 +1412,24 @@ expr:
                          [Nolabel,$1; Nolabel,$4; Nolabel,$7])) }
   | simple_expr DOT LBRACE expr RBRACE LESSMINUS expr
       { bigarray_set $1 $4 $7 }
+  | simple_expr DOTOP LBRACKET expr RBRACKET LESSMINUS expr
+      { let id = mkexp @@ Pexp_ident( ghloc @@ Lident ("." ^ $2 ^ "[]<-")) in
+        mkexp @@ Pexp_apply(id , [Nolabel, $1; Nolabel, $4; Nolabel, $7]) }
+  | simple_expr DOTOP LPAREN expr RPAREN LESSMINUS expr
+      { let id = mkexp @@ Pexp_ident( ghloc @@ Lident ("." ^ $2 ^ "()<-")) in
+        mkexp @@ Pexp_apply(id , [Nolabel, $1; Nolabel, $4; Nolabel, $7]) }
+  | simple_expr DOTOP LBRACE expr RBRACE LESSMINUS expr
+      { let id = mkexp @@ Pexp_ident( ghloc @@ Lident ("." ^ $2 ^ "{}<-")) in
+        mkexp @@ Pexp_apply(id , [Nolabel, $1; Nolabel, $4; Nolabel, $7]) }
+  | simple_expr DOT mod_longident DOTOP LBRACKET expr RBRACKET LESSMINUS expr
+      { let id = mkexp @@ Pexp_ident( ghloc @@ Ldot($3,"." ^ $4 ^ "[]<-")) in
+        mkexp @@ Pexp_apply(id , [Nolabel, $1; Nolabel, $6; Nolabel, $9]) }
+  | simple_expr DOT mod_longident DOTOP LPAREN expr RPAREN LESSMINUS expr
+      { let id = mkexp @@ Pexp_ident( ghloc @@ Ldot($3, "." ^ $4 ^ "()<-")) in
+        mkexp @@ Pexp_apply(id , [Nolabel, $1; Nolabel, $6; Nolabel, $9]) }
+  | simple_expr DOT mod_longident DOTOP LBRACE expr RBRACE LESSMINUS expr
+      { let id = mkexp @@ Pexp_ident( ghloc @@ Ldot($3, "." ^ $4 ^ "{}<-")) in
+        mkexp @@ Pexp_apply(id , [Nolabel, $1; Nolabel, $6; Nolabel, $9]) }
   | label LESSMINUS expr
       { mkexp(Pexp_setinstvar(mkrhs $1 1, $3)) }
   | ASSERT ext_attributes simple_expr %prec below_HASH
@@ -1463,6 +1486,36 @@ simple_expr:
                          [Nolabel,$1; Nolabel,$4])) }
   | simple_expr DOT LBRACKET seq_expr error
       { unclosed "[" 3 "]" 5 }
+  | simple_expr DOTOP LBRACKET expr RBRACKET
+      { let id = mkexp @@ Pexp_ident( ghloc @@ Lident ("." ^ $2 ^ "[]")) in
+        mkexp @@ Pexp_apply(id, [Nolabel, $1; Nolabel, $4]) }
+  | simple_expr DOTOP LBRACKET expr error
+      { unclosed "[" 3 "]" 5 }
+  | simple_expr DOTOP LPAREN expr RPAREN
+      { let id = mkexp @@ Pexp_ident( ghloc @@ Lident ("." ^ $2 ^ "()")) in
+        mkexp @@ Pexp_apply(id, [Nolabel, $1; Nolabel, $4]) }
+  | simple_expr DOTOP LPAREN expr error
+      { unclosed "(" 3 ")" 5 }
+  | simple_expr DOTOP LBRACE expr RBRACE
+      { let id = mkexp @@ Pexp_ident( ghloc @@ Lident ("." ^ $2 ^ "{}")) in
+        mkexp @@ Pexp_apply(id, [Nolabel, $1; Nolabel, $4]) }
+  | simple_expr DOTOP LBRACE expr error
+      { unclosed "{" 3 "}" 5 }
+  | simple_expr DOT mod_longident DOTOP LBRACKET expr RBRACKET
+      { let id = mkexp @@ Pexp_ident( ghloc @@ Ldot($3, "." ^ $4 ^ "[]")) in
+        mkexp @@ Pexp_apply(id, [Nolabel, $1; Nolabel, $6]) }
+  | simple_expr DOT mod_longident DOTOP LBRACKET expr error
+      { unclosed "[" 5 "]" 7 }
+  | simple_expr DOT mod_longident DOTOP LPAREN expr RPAREN
+      { let id = mkexp @@ Pexp_ident( ghloc @@ Ldot($3, "." ^ $4 ^ "()")) in
+        mkexp @@ Pexp_apply(id, [Nolabel, $1; Nolabel, $6]) }
+  | simple_expr DOT mod_longident DOTOP LPAREN expr error
+      { unclosed "(" 5 ")" 7 }
+  | simple_expr DOT mod_longident DOTOP LBRACE expr RBRACE
+      { let id = mkexp @@ Pexp_ident( ghloc @@ Ldot($3, "." ^ $4 ^ "{}")) in
+        mkexp @@ Pexp_apply(id, [Nolabel, $1; Nolabel, $6]) }
+  | simple_expr DOT mod_longident DOTOP LBRACE expr error
+      { unclosed "{" 5 "}" 7 }
   | simple_expr DOT LBRACE expr RBRACE
       { bigarray_get $1 $4 }
   | simple_expr DOT LBRACE expr_comma_list error
@@ -1572,8 +1625,18 @@ lident_list:
   | LIDENT lident_list                { mkrhs $1 1 :: $2 }
 ;
 let_binding_body:
-    val_ident fun_binding
+    val_ident strict_binding
       { (mkpatvar $1 1, $2) }
+  | val_ident type_constraint EQUAL seq_expr
+      { let v = mkpatvar $1 1 in (* PR#7344 *)
+        let t =
+          match $2 with
+            Some t, None -> t
+          | _, Some t -> t
+          | _ -> assert false
+        in
+        (ghpat(Ppat_constraint(v, ghtyp(Ptyp_poly([],t)))),
+         mkexp_constraint $4 $2) }
   | val_ident COLON typevar_list DOT core_type EQUAL seq_expr
       { (ghpat(Ppat_constraint(mkpatvar $1 1,
                                ghtyp(Ptyp_poly(List.rev $3,$5)))),
@@ -1733,10 +1796,6 @@ pattern_gen:
       { mkpat(Ppat_construct(mkrhs $1 1, Some $2)) }
   | name_tag pattern %prec prec_constr_appl
       { mkpat(Ppat_variant($1, Some $2)) }
-  | LPAREN COLONCOLON RPAREN LPAREN pattern COMMA pattern RPAREN
-      { mkpat_cons (rhs_loc 2) (ghpat(Ppat_tuple[$5;$7])) (symbol_rloc()) }
-  | LPAREN COLONCOLON RPAREN LPAREN pattern COMMA pattern error
-      { unclosed "(" 4 ")" 8 }
   | LAZY ext_attributes simple_pattern
       { mkpat_attrs (Ppat_lazy $3) $2}
 ;
@@ -1916,12 +1975,14 @@ type_kind:
       { (Ptype_variant(List.rev $3), Private, None) }
   | EQUAL DOTDOT
       { (Ptype_open, Public, None) }
+  | EQUAL PRIVATE DOTDOT
+      { (Ptype_open, Private, None) }
   | 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 DOTDOT
+      { (Ptype_open, $4, Some $2) }
   | EQUAL core_type EQUAL private_flag LBRACE label_declarations RBRACE
       { (Ptype_record $6, $4, Some $2) }
 ;
@@ -1943,11 +2004,6 @@ optional_type_variable:
 ;
 
 
-type_parameters:
-    /*empty*/                                   { [] }
-  | type_parameter                              { [$1] }
-  | LPAREN type_parameter_list RPAREN           { List.rev $2 }
-;
 type_parameter:
     type_variance type_variable                   { $2, $1 }
 ;
@@ -2111,8 +2167,8 @@ with_constraints:
   | with_constraints AND with_constraint        { $3 :: $1 }
 ;
 with_constraint:
-    TYPE type_parameters label_longident with_type_binder core_type_no_attr
-    constraints
+    TYPE optional_type_parameters label_longident with_type_binder
+    core_type_no_attr constraints
       { Pwith_type
           (mkrhs $3 3,
            (Type.mk (mkrhs (Longident.last $3) 3)
@@ -2123,15 +2179,16 @@ 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_no_attr
+  | TYPE optional_type_parameters label_longident COLONEQUAL core_type_no_attr
       { Pwith_typesubst
-          (Type.mk (mkrhs $3 3)
+         (mkrhs $3 3,
+           (Type.mk (mkrhs (Longident.last $3) 3)
              ~params:$2
              ~manifest:$5
-             ~loc:(symbol_rloc())) }
+             ~loc:(symbol_rloc()))) }
   | MODULE mod_longident EQUAL mod_ext_longident
       { Pwith_module (mkrhs $2 2, mkrhs $4 4) }
-  | MODULE UIDENT COLONEQUAL mod_ext_longident
+  | MODULE mod_longident COLONEQUAL mod_ext_longident
       { Pwith_modsubst (mkrhs $2 2, mkrhs $4 4) }
 ;
 with_type_binder:
@@ -2254,9 +2311,10 @@ row_field:
 ;
 tag_field:
     name_tag OF opt_ampersand amper_type_list attributes
-      { Rtag ($1, add_info_attrs (symbol_info ()) $5, $3, List.rev $4) }
+      { Rtag (mkrhs $1 1, add_info_attrs (symbol_info ()) $5,
+               $3, List.rev $4) }
   | name_tag attributes
-      { Rtag ($1, add_info_attrs (symbol_info ()) $2, true, []) }
+      { Rtag (mkrhs $1 1, add_info_attrs (symbol_info ()) $2, true, []) }
 ;
 opt_ampersand:
     AMPERSAND                                   { true }
@@ -2284,14 +2342,17 @@ core_type_list:
   | core_type_list STAR simple_core_type        { $3 :: $1 }
 ;
 meth_list:
-    field_semi meth_list                     { let (f, c) = $2 in ($1 :: f, c) }
+    field_semi meth_list                        { let (f, c) = $2 in ($1 :: f, c) }
+  | inherit_field_semi meth_list                { let (f, c) = $2 in ($1 :: f, c) }
   | field_semi                                  { [$1], Closed }
   | field                                       { [$1], Closed }
+  | inherit_field_semi                          { [$1], Closed }
+  | simple_core_type                            { [Oinherit $1], Closed }
   | DOTDOT                                      { [], Open }
 ;
 field:
   label COLON poly_type_no_attr attributes
-    { (mkrhs $1 1, add_info_attrs (symbol_info ()) $4, $3) }
+    { Otag (mkrhs $1 1, add_info_attrs (symbol_info ()) $4, $3) }
 ;
 
 field_semi:
@@ -2301,9 +2362,12 @@ field_semi:
         | Some _ as info_before_semi -> info_before_semi
         | None -> symbol_info ()
       in
-      (mkrhs $1 1, add_info_attrs info ($4 @ $6), $3) }
+      ( Otag (mkrhs $1 1, add_info_attrs info ($4 @ $6), $3)) }
 ;
 
+inherit_field_semi:
+  simple_core_type SEMI { Oinherit $1 }
+
 label:
     LIDENT                                      { $1 }
 ;
@@ -2344,7 +2408,13 @@ operator:
   | INFIXOP2                                    { $1 }
   | INFIXOP3                                    { $1 }
   | INFIXOP4                                    { $1 }
-  | HASHOP                                     { $1 }
+  | DOTOP LPAREN RPAREN                         { "."^ $1 ^"()" }
+  | DOTOP LPAREN RPAREN LESSMINUS               { "."^ $1 ^ "()<-" }
+  | DOTOP LBRACKET RBRACKET                     { "."^ $1 ^"[]" }
+  | DOTOP LBRACKET RBRACKET LESSMINUS           { "."^ $1 ^ "[]<-" }
+  | DOTOP LBRACE RBRACE                         { "."^ $1 ^"{}" }
+  | DOTOP LBRACE RBRACE LESSMINUS               { "."^ $1 ^ "{}<-" }
+  | HASHOP                                      { $1 }
   | BANG                                        { "!" }
   | PLUS                                        { "+" }
   | PLUSDOT                                     { "+." }
@@ -2366,7 +2436,6 @@ constr_ident:
     UIDENT                                      { $1 }
   | LBRACKET RBRACKET                           { "[]" }
   | LPAREN RPAREN                               { "()" }
-  /* | COLONCOLON                               { "::" } */
   | LPAREN COLONCOLON RPAREN                    { "::" }
   | FALSE                                       { "false" }
   | TRUE                                        { "true" }
@@ -2378,8 +2447,10 @@ val_longident:
 ;
 constr_longident:
     mod_longident       %prec below_DOT         { $1 }
+  | mod_longident DOT LPAREN COLONCOLON RPAREN  { Ldot($1,"::") }
   | LBRACKET RBRACKET                           { Lident "[]" }
   | LPAREN RPAREN                               { Lident "()" }
+  | LPAREN COLONCOLON RPAREN                    { Lident "::" }
   | FALSE                                       { Lident "false" }
   | TRUE                                        { Lident "true" }
 ;

diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli
index 1155ddc9ec0fd0972011b78fd7c16be83c8694f7..852a526b10c8ab5a76bc2012e58775931799f5d1 100644 (file)
--- a/parsing/parsetree.mli
+++ b/parsing/parsetree.mli
@@ -37,7 +37,7 @@ type constant =
      Suffixes are rejected by the typechecker.
   *)
 
-(** {2 Extension points} *)
+(** {1 Extension points} *)
 
 type attribute = string loc * payload
        (* [@id ARG]
@@ -62,7 +62,7 @@ and payload =
   | PTyp of core_type  (* : T *)
   | PPat of pattern * expression option  (* ? P  or  ? P when E *)
 
-(** {2 Core language} *)
+(** {1 Core language} *)
 
 (* Type expressions *)
 
@@ -81,7 +81,7 @@ and core_type_desc =
   | Ptyp_arrow of arg_label * core_type * core_type
         (* T1 -> T2       Simple
            ~l:T1 -> T2    Labelled
-           ?l:T1 -> T2    Otional
+           ?l:T1 -> T2    Optional
          *)
   | Ptyp_tuple of core_type list
         (* T1 * ... * Tn
@@ -93,7 +93,7 @@ and core_type_desc =
            T tconstr
            (T1, ..., Tn) tconstr
          *)
-  | Ptyp_object of (string loc * attributes * core_type) list * closed_flag
+  | Ptyp_object of object_field list * closed_flag
         (* < l1:T1; ...; ln:Tn >     (flag = Closed)
            < l1:T1; ...; ln:Tn; .. > (flag = Open)
          *)
@@ -142,7 +142,7 @@ and package_type = Longident.t loc * (Longident.t loc * core_type) list
        *)
 
 and row_field =
-  | Rtag of label * attributes * bool * core_type list
+  | Rtag of label loc * attributes * bool * core_type list
         (* [`A]                   ( true,  [] )
            [`A of T]              ( false, [T] )
            [`A of T1 & .. & Tn]   ( false, [T1;...Tn] )
@@ -158,6 +158,10 @@ and row_field =
   | Rinherit of core_type
         (* [ T ] *)
 
+and object_field =
+  | Otag of label loc * attributes * core_type
+  | Oinherit of core_type
+
 (* Patterns *)
 
 and pattern =
@@ -310,13 +314,13 @@ and expression_desc =
         (* (E :> T)        (None, T)
            (E : T0 :> T)   (Some T0, T)
          *)
-  | Pexp_send of expression * string loc
+  | Pexp_send of expression * label loc
         (*  E # m *)
   | Pexp_new of Longident.t loc
         (* new M.c *)
-  | Pexp_setinstvar of string loc * expression
+  | Pexp_setinstvar of label loc * expression
         (* x <- 2 *)
-  | Pexp_override of (string loc * expression) list
+  | Pexp_override of (label loc * expression) list
         (* {< x1 = E1; ...; Xn = En >} *)
   | Pexp_letmodule of string loc * module_expr * expression
         (* let module M = ME in E *)
@@ -414,7 +418,7 @@ and label_declaration =
      pld_mutable: mutable_flag;
      pld_type: core_type;
      pld_loc: Location.t;
-     pld_attributes: attributes; (* l [@id1] [@id2] : T *)
+     pld_attributes: attributes; (* l : T [@id1] [@id2] *)
     }
 
 (*  { ...; l: T; ... }            (mutable=Immutable)
@@ -429,7 +433,7 @@ and constructor_declaration =
      pcd_args: constructor_arguments;
      pcd_res: core_type option;
      pcd_loc: Location.t;
-     pcd_attributes: attributes; (* C [@id1] [@id2] of ... *)
+     pcd_attributes: attributes; (* C of ... [@id1] [@id2] *)
     }
 
 and constructor_arguments =
@@ -462,7 +466,7 @@ and extension_constructor =
      pext_name: string loc;
      pext_kind : extension_constructor_kind;
      pext_loc : Location.t;
-     pext_attributes: attributes; (* C [@id1] [@id2] of ... *)
+     pext_attributes: attributes; (* C of ... [@id1] [@id2] *)
     }
 
 and extension_constructor_kind =
@@ -477,7 +481,7 @@ and extension_constructor_kind =
          | C = D
        *)
 
-(** {2 Class language} *)
+(** {1 Class language} *)
 
 (* Type expressions for the class language *)
 
@@ -501,6 +505,8 @@ and class_type_desc =
          *)
   | Pcty_extension of extension
         (* [%id] *)
+  | Pcty_open of override_flag * Longident.t loc * class_type
+        (* let open M in CT *)
 
 and class_signature =
     {
@@ -521,9 +527,9 @@ and class_type_field =
 and class_type_field_desc =
   | Pctf_inherit of class_type
         (* inherit CT *)
-  | Pctf_val of (string loc * mutable_flag * virtual_flag * core_type)
+  | Pctf_val of (label loc * mutable_flag * virtual_flag * core_type)
         (* val x: T *)
-  | Pctf_method  of (string loc * private_flag * virtual_flag * core_type)
+  | Pctf_method  of (label loc * private_flag * virtual_flag * core_type)
         (* method x: T
 
            Note: T can be a Ptyp_poly.
@@ -590,7 +596,10 @@ and class_expr_desc =
   | Pcl_constraint of class_expr * class_type
         (* (CE : CT) *)
   | Pcl_extension of extension
-        (* [%id] *)
+  (* [%id] *)
+  | Pcl_open of override_flag * Longident.t loc * class_expr
+  (* let open M in CE *)
+
 
 and class_structure =
     {
@@ -615,11 +624,11 @@ and class_field_desc =
            inherit! CE
            inherit! CE as x
          *)
-  | Pcf_val of (string loc * mutable_flag * class_field_kind)
+  | Pcf_val of (label loc * mutable_flag * class_field_kind)
         (* val x = E
            val virtual x: T
          *)
-  | Pcf_method of (string loc * private_flag * class_field_kind)
+  | Pcf_method of (label loc * private_flag * class_field_kind)
         (* method x = E            (E can be a Pexp_poly)
            method virtual x: T     (T can be a Ptyp_poly)
          *)
@@ -638,7 +647,7 @@ and class_field_kind =
 
 and class_declaration = class_expr class_infos
 
-(** {2 Module language} *)
+(** {1 Module language} *)
 
 (* Type expressions for the module language *)
 
@@ -758,10 +767,10 @@ and with_constraint =
            the name of the type_declaration. *)
   | Pwith_module of Longident.t loc * Longident.t loc
         (* with module X.Y = Z *)
-  | Pwith_typesubst of type_declaration
-        (* with type t := ... *)
-  | Pwith_modsubst of string loc * Longident.t loc
-        (* with module X := Z *)
+  | Pwith_typesubst of Longident.t loc * type_declaration
+        (* with type X.t := ..., same format as [Pwith_type] *)
+  | Pwith_modsubst of Longident.t loc * Longident.t loc
+        (* with module X.Y := Z *)
 
 (* Value expressions for the module language *)
 
@@ -849,7 +858,7 @@ and module_binding =
     }
 (* X = ME *)
 
-(** {2 Toplevel} *)
+(** {1 Toplevel} *)
 
 (* Toplevel phrases *)
 

diff --git a/parsing/pprintast.ml b/parsing/pprintast.ml
index c6f48d16bffbf1026b2695ea671e1976b77ea214..998365a797419469cc553e544a8b54b10492bd0e 100644 (file)
--- a/parsing/pprintast.ml
+++ b/parsing/pprintast.ml
@@ -30,10 +30,11 @@ open Ast_helper
 
 let prefix_symbols  = [ '!'; '?'; '~' ] ;;
 let infix_symbols = [ '='; '<'; '>'; '@'; '^'; '|'; '&'; '+'; '-'; '*'; '/';
-                      '$'; '%' ]
+                      '$'; '%'; '#' ]
+
 (* type fixity = Infix| Prefix  *)
 let special_infix_strings =
-  ["asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or"; ":="; "!=" ]
+  ["asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or"; ":="; "!="; "::" ]
 
 (* determines if the string is an infix string.
    checks backwards, first allowing a renaming postfix ("_102") which
@@ -44,17 +45,22 @@ let fixity_of_string  = function
   | s when List.mem s special_infix_strings -> `Infix s
   | s when List.mem s.[0] infix_symbols -> `Infix s
   | s when List.mem s.[0] prefix_symbols -> `Prefix s
+  | s when s.[0] = '.' -> `Mixfix s
   | _ -> `Normal
 
 let view_fixity_of_exp = function
-  | {pexp_desc = Pexp_ident {txt=Lident l;_};_} -> fixity_of_string l
+  | {pexp_desc = Pexp_ident {txt=Lident l;_}; pexp_attributes = []} ->
+      fixity_of_string l
   | _ -> `Normal
 
 let is_infix  = function  | `Infix _ -> true | _  -> false
+let is_mixfix = function `Mixfix _ -> true | _ -> false
 
 (* which identifiers are in fact operators needing parentheses *)
 let needs_parens txt =
-  is_infix (fixity_of_string txt)
+  let fix = fixity_of_string txt in
+  is_infix fix
+  || is_mixfix fix
   || List.mem txt.[0] prefix_symbols
 
 (* some infixes need spaces around parens to avoid clashes with comment
@@ -103,11 +109,15 @@ let view_expr x =
   | Pexp_construct ( {txt= Lident "[]";_},_) -> `nil
   | Pexp_construct ( {txt= Lident"::";_},Some _) ->
       let rec loop exp acc = match exp with
-          | {pexp_desc=Pexp_construct ({txt=Lident "[]";_},_);_} ->
+          | {pexp_desc=Pexp_construct ({txt=Lident "[]";_},_);
+             pexp_attributes = []} ->
               (List.rev acc,true)
           | {pexp_desc=
              Pexp_construct ({txt=Lident "::";_},
-                             Some ({pexp_desc= Pexp_tuple([e1;e2]);_}));_} ->
+                             Some ({pexp_desc= Pexp_tuple([e1;e2]);
+                                    pexp_attributes = []}));
+             pexp_attributes = []}
+            ->
               loop e2 (e1::acc)
           | e -> (List.rev (e::acc),false) in
       let (ls,b) = loop x []  in
@@ -245,6 +255,8 @@ and core_type ctxt f x =
           (type_with_label ctxt) (l,ct1) (core_type ctxt) ct2
     | Ptyp_alias (ct, s) ->
         pp f "@[<2>%a@;as@;'%s@]" (core_type1 ctxt) ct s
+    | Ptyp_poly ([], ct) ->
+        core_type ctxt f ct
     | Ptyp_poly (sl, ct) ->
         pp f "@[<2>%a%a@]"
           (fun f l ->
@@ -269,13 +281,13 @@ and core_type1 ctxt f x =
           (fun f l -> match l with
              |[] -> ()
              |[x]-> pp f "%a@;" (core_type1 ctxt)  x
-             | _ -> list ~first:"(" ~last:")@;" (core_type ctxt) ~sep:"," f l)
+             | _ -> list ~first:"(" ~last:")@;" (core_type ctxt) ~sep:",@;" f l)
           l longident_loc li
     | Ptyp_variant (l, closed, low) ->
         let type_variant_helper f x =
           match x with
           | Rtag (l, attrs, _, ctl) ->
-              pp f "@[<2>%a%a@;%a@]" string_quot l
+              pp f "@[<2>%a%a@;%a@]" string_quot l.txt
                 (fun f l -> match l with
                    |[] -> ()
                    | _ -> pp f "@;of@;%a"
@@ -300,9 +312,12 @@ and core_type1 ctxt f x =
                  pp f ">@ %a"
                    (list string_quot) xs) low
     | Ptyp_object (l, o) ->
-        let core_field_type f (s, attrs, ct) =
-          pp f "@[<hov2>%s: %a@ %a@ @]" s.txt
-            (core_type ctxt) ct (attributes ctxt) attrs (* Cf #7200 *)
+        let core_field_type f = function
+          | Otag (l, attrs, ct) ->
+            pp f "@[<hov2>%s: %a@ %a@ @]" l.txt
+              (core_type ctxt) ct (attributes ctxt) attrs (* Cf #7200 *)
+          | Oinherit ct ->
+            pp f "@[<hov2>%a@ @]" (core_type ctxt) ct
         in
         let field_var f = function
           | Asttypes.Closed -> ()
@@ -332,7 +347,7 @@ and core_type1 ctxt f x =
 (* be cautious when use [pattern], [pattern1] is preferred *)
 and pattern ctxt f x =
   let rec list_of_pattern acc = function (* only consider ((A|B)|C)*)
-    | {ppat_desc= Ppat_or (p1,p2);_} ->
+    | {ppat_desc= Ppat_or (p1,p2); ppat_attributes = []} ->
         list_of_pattern  (p2::acc) p1
     | x -> x::acc
   in
@@ -353,7 +368,9 @@ and pattern1 ctxt (f:Format.formatter) (x:pattern) : unit =
     | {ppat_desc =
          Ppat_construct
            ({ txt = Lident("::") ;_},
-            Some ({ppat_desc = Ppat_tuple([pat1; pat2]);_})); _}
+            Some ({ppat_desc = Ppat_tuple([pat1; pat2]);_}));
+       ppat_attributes = []}
+
       ->
         pp f "%a::%a" (simple_pattern ctxt) pat1 pattern_list_helper pat2 (*RA*)
     | p -> pattern1 ctxt f p
@@ -370,7 +387,7 @@ and pattern1 ctxt (f:Format.formatter) (x:pattern) : unit =
         else
           (match po with
            | Some x -> pp f "%a@;%a"  longident_loc li (simple_pattern ctxt) x
-           | None -> pp f "%a@;"longident_loc li )
+           | None -> pp f "%a" longident_loc li)
     | _ -> simple_pattern ctxt f x
 
 and simple_pattern ctxt (f:Format.formatter) (x:pattern) : unit =
@@ -387,8 +404,11 @@ and simple_pattern ctxt (f:Format.formatter) (x:pattern) : unit =
         pp f "#%a" longident_loc li
     | Ppat_record (l, closed) ->
         let longident_x_pattern f (li, p) =
-          match (li,p.ppat_desc) with
-          | ({txt=Lident s;_ },Ppat_var {txt;_} ) when s = txt ->
+          match (li,p) with
+          | ({txt=Lident s;_ },
+             {ppat_desc=Ppat_var {txt;_};
+              ppat_attributes=[]; _})
+            when s = txt ->
               pp f "@[<2>%a@]"  longident_loc li
           | _ ->
               pp f "@[<2>%a@;=@;%a@]" longident_loc li (pattern1 ctxt) p
@@ -400,7 +420,7 @@ and simple_pattern ctxt (f:Format.formatter) (x:pattern) : unit =
             pp f "@[<2>{@;%a;_}@]" (list longident_x_pattern ~sep:";@;") l
         end
     | Ppat_tuple l ->
-        pp f "@[<1>(%a)@]" (list  ~sep:"," (pattern1 ctxt))  l (* level1*)
+        pp f "@[<1>(%a)@]" (list  ~sep:",@;" (pattern1 ctxt))  l (* level1*)
     | Ppat_constant (c) -> pp f "%a" constant c
     | Ppat_interval (c1, c2) -> pp f "%a..%a" constant c1 constant c2
     | Ppat_variant (l,None) ->  pp f "`%s" l
@@ -427,8 +447,9 @@ and label_exp ctxt f (l,opt,p) =
       (* single case pattern parens needed here *)
       pp f "%a@ " (simple_pattern ctxt) p
   | Optional rest ->
-      begin match p.ppat_desc with
-      | Ppat_var {txt;_} when txt = rest ->
+      begin match p with
+      | {ppat_desc = Ppat_var {txt;_}; ppat_attributes = []}
+        when txt = rest ->
           (match opt with
            | Some o -> pp f "?(%s=@;%a)@;" rest  (expression ctxt) o
            | None -> pp f "?%s@ " rest)
@@ -439,8 +460,9 @@ and label_exp ctxt f (l,opt,p) =
                  rest (pattern1 ctxt) p (expression ctxt) o
            | None -> pp f "?%s:%a@;" rest (simple_pattern ctxt) p)
       end
-  | Labelled l -> match p.ppat_desc with
-    | Ppat_var {txt;_} when txt = l ->
+  | Labelled l -> match p with
+    | {ppat_desc  = Ppat_var {txt;_}; ppat_attributes = []}
+      when txt = l ->
         pp f "~%s@;" l
     | _ ->  pp f "~%s:%a@;" l (simple_pattern ctxt) p
 
@@ -450,39 +472,66 @@ and sugar_expr ctxt f e =
   | Pexp_apply ({ pexp_desc = Pexp_ident {txt = id; _};
                   pexp_attributes=[]; _}, args)
     when List.for_all (fun (lab, _) -> lab = Nolabel) args -> begin
+      let print_indexop a path_prefix assign left right print_index indices
+          rem_args =
+        let print_path ppf = function
+          | None -> ()
+          | Some m -> pp ppf ".%a" longident m in
+        match assign, rem_args with
+            | false, [] ->
+              pp f "@[%a%a%s%a%s@]"
+                (simple_expr ctxt) a print_path path_prefix
+                left (list ~sep:"," print_index) indices right; true
+            | true, [v] ->
+              pp f "@[%a%a%s%a%s@ <-@;<1 2>%a@]"
+                (simple_expr ctxt) a print_path path_prefix
+                left (list ~sep:"," print_index) indices right
+                (simple_expr ctxt) v; true
+            | _ -> false in
       match id, List.map snd args with
       | Lident "!", [e] ->
         pp f "@[<hov>!%a@]" (simple_expr ctxt) e; true
       | Ldot (path, ("get"|"set" as func)), a :: other_args -> begin
-          let print left right print_index indexes rem_args =
-            match func, rem_args with
-            | "get", [] ->
-              pp f "@[%a.%s%a%s@]"
-                (simple_expr ctxt) a
-                left (list ~sep:"," print_index) indexes right; true
-            | "set", [v] ->
-              pp f "@[%a.%s%a%s@ <-@;<1 2>%a@]"
-                (simple_expr ctxt) a
-                left (list ~sep:"," print_index) indexes right
-                (simple_expr ctxt) v; true
-            | _ -> false
-          in
+          let assign = func = "set" in
+          let print = print_indexop a None assign in
           match path, other_args with
           | Lident "Array", i :: rest ->
-            print "(" ")" (expression ctxt) [i] rest
+            print ".(" ")" (expression ctxt) [i] rest
           | Lident "String", i :: rest ->
-            print "[" "]" (expression ctxt) [i] rest
+            print ".[" "]" (expression ctxt) [i] rest
           | Ldot (Lident "Bigarray", "Array1"), i1 :: rest ->
-            print "{" "}" (simple_expr ctxt) [i1] rest
+            print ".{" "}" (simple_expr ctxt) [i1] rest
           | Ldot (Lident "Bigarray", "Array2"), i1 :: i2 :: rest ->
-            print "{" "}" (simple_expr ctxt) [i1; i2] rest
+            print ".{" "}" (simple_expr ctxt) [i1; i2] rest
           | Ldot (Lident "Bigarray", "Array3"), i1 :: i2 :: i3 :: rest ->
-            print "{" "}" (simple_expr ctxt) [i1; i2; i3] rest
+            print ".{" "}" (simple_expr ctxt) [i1; i2; i3] rest
           | Ldot (Lident "Bigarray", "Genarray"),
             {pexp_desc = Pexp_array indexes; pexp_attributes = []} :: rest ->
-            print "{" "}" (simple_expr ctxt) indexes rest
+              print ".{" "}" (simple_expr ctxt) indexes rest
           | _ -> false
         end
+      | (Lident s | Ldot(_,s)) , a :: i :: rest
+        when s.[0] = '.' ->
+          let n = String.length s in
+          (* extract operator:
+             assignment operators end with [right_bracket ^ "<-"],
+             access operators end with [right_bracket] directly
+          *)
+          let assign = s.[n - 1] = '-'  in
+          let kind =
+            (* extract the right end bracket *)
+            if assign then s.[n - 3] else s.[n - 1] in
+          let left, right = match kind with
+            | ')' -> '(', ")"
+            | ']' -> '[', "]"
+            | '}' -> '{', "}"
+            | _ -> assert false in
+          let path_prefix = match id with
+            | Ldot(m,_) -> Some m
+            | _ -> None in
+          let left = String.sub s 0 (1+String.index s left) in
+          print_indexop a path_prefix assign left right
+            (expression ctxt) [i] rest
       | _ -> false
     end
   | _ -> false
@@ -501,7 +550,7 @@ and expression ctxt f x =
         when ctxt.semi ->
         paren true (expression reset_ctxt) f x
     | Pexp_fun (l, e0, p, e) ->
-        pp f "@[<2>fun@;%a@;->@;%a@]"
+        pp f "@[<2>fun@;%a->@;%a@]"
           (label_exp ctxt) (l, e0, p)
           (expression ctxt) e
     | Pexp_function l ->
@@ -516,7 +565,7 @@ and expression ctxt f x =
           (expression reset_ctxt) e  (case_list ctxt) l
     | Pexp_let (rf, l, e) ->
         (* pp f "@[<2>let %a%a in@;<1 -2>%a@]"
-           (*no identation here, a new line*) *)
+           (*no indentation here, a new line*) *)
         (*   rec_flag rf *)
         pp f "@[<2>%a in@;<1 -2>%a@]"
           (bindings reset_ctxt) (rf,l)
@@ -584,7 +633,7 @@ and expression ctxt f x =
              | None -> () (* pp f "()" *)) eo
     | Pexp_sequence _ ->
         let rec sequence_helper acc = function
-          | {pexp_desc=Pexp_sequence(e1,e2);_} ->
+          | {pexp_desc=Pexp_sequence(e1,e2); pexp_attributes = []} ->
               sequence_helper (e1::acc) e2
           | v -> List.rev (v::acc) in
         let lst = sequence_helper [] x in
@@ -675,8 +724,9 @@ and simple_expr ctxt f x =
     | Pexp_variant (l, None) -> pp f "`%s" l
     | Pexp_record (l, eo) ->
         let longident_x_expression f ( li, e) =
-          match e.pexp_desc with
-          |  Pexp_ident {txt;_} when li.txt = txt ->
+          match e with
+          |  {pexp_desc=Pexp_ident {txt;_};
+              pexp_attributes=[]; _} when li.txt = txt ->
               pp f "@[<hov2>%a@]" longident_loc li
           | _ ->
               pp f "@[<hov2>%a@;=@;%a@]" longident_loc li (simple_expr ctxt) e
@@ -755,9 +805,9 @@ and class_signature ctxt f { pcsig_self = ct; pcsig_fields = l ;_} =
         item_attributes ctxt f x.pctf_attributes
   in
   pp f "@[<hv0>@[<hv2>object@[<1>%a@]@ %a@]@ end@]"
-    (fun f ct -> match ct.ptyp_desc with
-       | Ptyp_any -> ()
-       | _ -> pp f " (%a)" (core_type ctxt) ct) ct
+    (fun f -> function
+         {ptyp_desc=Ptyp_any; ptyp_attributes=[]; _} -> ()
+       | ct -> pp f " (%a)" (core_type ctxt) ct) ct
     (list class_type_field ~sep:"@;") l
 
 (* call [class_signature] called by [class_signature] *)
@@ -780,6 +830,9 @@ and class_type ctxt f x =
   | Pcty_extension e ->
       extension ctxt f e;
       attributes ctxt f x.pcty_attributes
+  | Pcty_open (ovf, lid, e) ->
+      pp f "@[<2>let open%s %a in@;%a@]" (override ovf) longident_loc lid
+        (class_type ctxt) e
 
 (* [class type a = object end] *)
 and class_type_declaration_list ctxt f l =
@@ -836,11 +889,12 @@ and class_field ctxt f x =
       pp f "@[<2>method%s %a%a@]%a"
         (override ovf)
         private_flag pf
-        (fun f e -> match e.pexp_desc with
-           | Pexp_poly (e, Some ct) ->
+        (fun f -> function
+           | {pexp_desc=Pexp_poly (e, Some ct); pexp_attributes=[]; _} ->
                pp f "%s :@;%a=@;%a"
                  s.txt (core_type ctxt) ct (expression ctxt) e
-           | Pexp_poly (e,None) -> bind e
+           | {pexp_desc=Pexp_poly (e, None); pexp_attributes=[]; _} ->
+               bind e
            | _ -> bind e) e
         (item_attributes ctxt) x.pcf_attributes
   | Pcf_constraint (ct1, ct2) ->
@@ -895,6 +949,9 @@ and class_expr ctxt f x =
           (class_expr ctxt) ce
           (class_type ctxt) ct
     | Pcl_extension e -> extension ctxt f e
+    | Pcl_open (ovf, lid, e) ->
+        pp f "@[<2>let open%s %a in@;%a@]" (override ovf) longident_loc lid
+          (class_expr ctxt) e
 
 and module_type ctxt f x =
   if x.pmty_attributes <> [] then begin
@@ -927,14 +984,14 @@ and module_type ctxt f x =
                 ls longident_loc li (type_declaration ctxt) td
           | Pwith_module (li, li2) ->
               pp f "module %a =@ %a" longident_loc li longident_loc li2;
-          | Pwith_typesubst ({ptype_params=ls;_} as td) ->
+          | Pwith_typesubst (li, ({ptype_params=ls;_} as td)) ->
               let ls = List.map fst ls in
-              pp f "type@ %a %s :=@ %a"
+              pp f "type@ %a %a :=@ %a"
                 (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")")
-                ls td.ptype_name.txt
+                ls longident_loc li
                 (type_declaration ctxt) td
-          | Pwith_modsubst (s, li2) ->
-              pp f "module %s :=@ %a" s.txt longident_loc li2 in
+          | Pwith_modsubst (li, li2) ->
+             pp f "module %a :=@ %a" longident_loc li longident_loc li2 in
         (match l with
          | [] -> pp f "@[<hov2>%a@]" (module_type ctxt) mt
          | _ -> pp f "@[<hov2>(%a@ with@ %a)@]"
@@ -975,7 +1032,8 @@ and signature_item ctxt f x : unit =
               (class_description "class") x
               (list ~sep:"@," (class_description "and")) xs
       end
-  | Psig_module ({pmd_type={pmty_desc=Pmty_alias alias};_} as pmd) ->
+  | Psig_module ({pmd_type={pmty_desc=Pmty_alias alias;
+                            pmty_attributes=[]; _};_} as pmd) ->
       pp f "@[<hov>module@ %s@ =@ %a@]%a" pmd.pmd_name.txt
         longident_loc alias
         (item_attributes ctxt) pmd.pmd_attributes
@@ -1085,15 +1143,18 @@ and binding ctxt f {pvb_pat=p; pvb_expr=x; _} =
   let tyvars_str tyvars = List.map (fun v -> v.txt) tyvars in
   let is_desugared_gadt p e =
     let gadt_pattern =
-      match p.ppat_desc with
-      | Ppat_constraint({ppat_desc=Ppat_var _} as pat,
-                        {ptyp_desc=Ptyp_poly (args_tyvars, rt)}) ->
-        Some (pat, args_tyvars, rt)
+      match p with
+      | {ppat_desc=Ppat_constraint({ppat_desc=Ppat_var _} as pat,
+                                   {ptyp_desc=Ptyp_poly (args_tyvars, rt)});
+         ppat_attributes=[]}->
+          Some (pat, args_tyvars, rt)
       | _ -> None in
     let rec gadt_exp tyvars e =
-      match e.pexp_desc with
-      | Pexp_newtype (tyvar, e) -> gadt_exp (tyvar :: tyvars) e
-      | Pexp_constraint (e, ct) -> Some (List.rev tyvars, e, ct)
+      match e with
+      | {pexp_desc=Pexp_newtype (tyvar, e); pexp_attributes=[]} ->
+          gadt_exp (tyvar :: tyvars) e
+      | {pexp_desc=Pexp_constraint (e, ct); pexp_attributes=[]} ->
+          Some (List.rev tyvars, e, ct)
       | _ -> None in
     let gadt_exp = gadt_exp [] e in
     match gadt_pattern, gadt_exp with
@@ -1106,23 +1167,27 @@ and binding ctxt f {pvb_pat=p; pvb_expr=x; _} =
   if x.pexp_attributes <> []
   then pp f "%a@;=@;%a" (pattern ctxt) p (expression ctxt) x else
   match is_desugared_gadt p x with
+  | Some (p, [], ct, e) ->
+      pp f "%a@;: %a@;=@;%a"
+        (simple_pattern ctxt) p (core_type ctxt) ct (expression ctxt) e
   | Some (p, tyvars, ct, e) -> begin
-    pp f "%a@;: type@;%a.%a@;=@;%a"
+    pp f "%a@;: type@;%a.@;%a@;=@;%a"
     (simple_pattern ctxt) p (list pp_print_string ~sep:"@;")
     (tyvars_str tyvars) (core_type ctxt) ct (expression ctxt) e
     end
   | None -> begin
-      match (x.pexp_desc,p.ppat_desc) with
-      | ( _ , Ppat_constraint( p ,ty)) -> (* special case for the first*)
-          begin match ty.ptyp_desc with
-          | Ptyp_poly _ ->
+      match p with
+      | {ppat_desc=Ppat_constraint(p ,ty);
+         ppat_attributes=[]} -> (* special case for the first*)
+          begin match ty with
+          | {ptyp_desc=Ptyp_poly _; ptyp_attributes=[]} ->
               pp f "%a@;:@;%a@;=@;%a" (simple_pattern ctxt) p
                 (core_type ctxt) ty (expression ctxt) x
           | _ ->
               pp f "(%a@;:@;%a)@;=@;%a" (simple_pattern ctxt) p
                 (core_type ctxt) ty (expression ctxt) x
           end
-      | (_, Ppat_var _) ->
+      | {ppat_desc=Ppat_var _; ppat_attributes=[]} ->
           pp f "%a@ %a" (simple_pattern ctxt) p pp_print_pexp_function x
       | _ ->
           pp f "%a@;=@;%a" (pattern ctxt) p (expression ctxt) x
@@ -1131,7 +1196,7 @@ and binding ctxt f {pvb_pat=p; pvb_expr=x; _} =
 (* [in] is not printed *)
 and bindings ctxt f (rf,l) =
   let binding kwd rf f x =
-    pp f "@[<2>%s %a%a@]@ %a" kwd rec_flag rf
+    pp f "@[<2>%s %a%a@]%a" kwd rec_flag rf
       (binding ctxt) x (item_attributes ctxt) x.pvb_attributes
   in
   match l with
@@ -1156,24 +1221,24 @@ and structure_item ctxt f x =
   | Pstr_typext te -> type_extension ctxt f te
   | Pstr_exception ed -> exception_declaration ctxt f ed
   | Pstr_module x ->
-      let rec module_helper me =
-        match me.pmod_desc with
-        | Pmod_functor(s,mt,me') when me.pmod_attributes = [] ->
+      let rec module_helper = function
+        | {pmod_desc=Pmod_functor(s,mt,me'); pmod_attributes = []} ->
             if mt = None then pp f "()"
             else Misc.may (pp f "(%s:%a)" s.txt (module_type ctxt)) mt;
             module_helper me'
-        | _ -> me
+        | me -> me
       in
       pp f "@[<hov2>module %s%a@]%a"
         x.pmb_name.txt
         (fun f me ->
            let me = module_helper me in
-           match me.pmod_desc with
-           | Pmod_constraint
-               (me',
-                ({pmty_desc=(Pmty_ident (_)
-                            | Pmty_signature (_));_} as mt))
-             when me.pmod_attributes = [] ->
+           match me with
+           | {pmod_desc=
+                Pmod_constraint
+                  (me',
+                   ({pmty_desc=(Pmty_ident (_)
+                               | Pmty_signature (_));_} as mt));
+              pmod_attributes = []} ->
                pp f " :@;%a@;=@;%a@;"
                  (module_type ctxt) mt (module_expr ctxt) me'
            | _ -> pp f " =@ %a" (module_expr ctxt) me
@@ -1196,16 +1261,15 @@ and structure_item ctxt f x =
         (item_attributes ctxt) attrs
   | Pstr_class l ->
       let extract_class_args cl =
-        let rec loop acc cl =
-          match cl.pcl_desc with
-          | Pcl_fun (l, eo, p, cl') when cl.pcl_attributes = [] ->
+        let rec loop acc = function
+          | {pcl_desc=Pcl_fun (l, eo, p, cl'); pcl_attributes = []} ->
               loop ((l,eo,p) :: acc) cl'
-          | _ -> List.rev acc, cl
+          | cl -> List.rev acc, cl
         in
         let args, cl = loop [] cl in
         let constr, cl =
-          match cl.pcl_desc with
-          | Pcl_constraint (cl', ct) when cl.pcl_attributes = [] ->
+          match cl with
+          | {pcl_desc=Pcl_constraint (cl', ct); pcl_attributes = []} ->
               Some ct, cl'
           | _ -> None, cl
         in
@@ -1270,7 +1334,7 @@ and type_param ctxt f (ct, a) =
 
 and type_params ctxt f = function
   | [] -> ()
-  | l -> pp f "%a " (list (type_param ctxt) ~first:"(" ~last:")" ~sep:",") l
+  | l -> pp f "%a " (list (type_param ctxt) ~first:"(" ~last:")" ~sep:",@;") l
 
 and type_def_list ctxt f (rf, l) =
   let type_decl kwd rf f x =
@@ -1385,7 +1449,7 @@ and constructor_declaration ctxt f (name, args, res, attrs) =
         (fun f -> function
            | Pcstr_tuple [] -> core_type1 ctxt f r
            | Pcstr_tuple l -> pp f "%a@;->@;%a"
-                                (list (core_type1 ctxt) ~sep:"*@;") l
+                                (list (core_type1 ctxt) ~sep:"@;*@;") l
                                 (core_type1 ctxt) r
            | Pcstr_record l ->
                pp f "%a@;->@;%a" (record_declaration ctxt) l (core_type1 ctxt) r
@@ -1412,8 +1476,9 @@ and case_list ctxt f l : unit =
   list aux f l ~sep:""
 
 and label_x_expression_param ctxt f (l,e) =
-  let simple_name = match e.pexp_desc with
-    | Pexp_ident {txt=Lident l;_} -> Some l
+  let simple_name = match e with
+    | {pexp_desc=Pexp_ident {txt=Lident l;_};
+       pexp_attributes=[]} -> Some l
     | _ -> None
   in match l with
   | Nolabel  -> expression2 ctxt f e (* level 2*)

diff --git a/parsing/printast.ml b/parsing/printast.ml
index 6e167b3e47be5565aba462bb97c037d7697dca6f..62ccc04b0ae97b93fd1afd5b58f1774c73764e28 100644 (file)
--- a/parsing/printast.ml
+++ b/parsing/printast.ml
@@ -163,13 +163,16 @@ let rec core_type i ppf x =
   | Ptyp_object (l, c) ->
       line i ppf "Ptyp_object %a\n" fmt_closed_flag c;
       let i = i + 1 in
-      List.iter
-        (fun (s, attrs, t) ->
-          line i ppf "method %s\n" s.txt;
-          attributes i ppf attrs;
-          core_type (i + 1) ppf t
-        )
-        l
+      List.iter (
+        function
+          | Otag (l, attrs, t) ->
+            line i ppf "method %s\n" l.txt;
+            attributes i ppf attrs;
+            core_type (i + 1) ppf t
+          | Oinherit ct ->
+              line i ppf "Oinherit\n";
+              core_type (i + 1) ppf ct
+      ) l
   | Ptyp_class (li, l) ->
       line i ppf "Ptyp_class %a\n" fmt_longident_loc li;
       list i core_type ppf l
@@ -482,6 +485,10 @@ and class_type i ppf x =
   | Pcty_extension (s, arg) ->
       line i ppf "Pcty_extension \"%s\"\n" s.txt;
       payload i ppf arg
+  | Pcty_open (ovf, m, e) ->
+      line i ppf "Pcty_open %a \"%a\"\n" fmt_override_flag ovf
+        fmt_longident_loc m;
+      class_type i ppf e
 
 and class_signature i ppf cs =
   line i ppf "class_signature\n";
@@ -569,6 +576,10 @@ and class_expr i ppf x =
   | Pcl_extension (s, arg) ->
       line i ppf "Pcl_extension \"%s\"\n" s.txt;
       payload i ppf arg
+  | Pcl_open (ovf, m, e) ->
+      line i ppf "Pcl_open %a \"%a\"\n" fmt_override_flag ovf
+        fmt_longident_loc m;
+      class_expr i ppf e
 
 and class_structure i ppf { pcstr_self = p; pcstr_fields = l } =
   line i ppf "class_structure\n";
@@ -711,17 +722,17 @@ and with_constraint i ppf x =
   | Pwith_type (lid, td) ->
       line i ppf "Pwith_type %a\n" fmt_longident_loc lid;
       type_declaration (i+1) ppf td;
-  | Pwith_typesubst (td) ->
-      line i ppf "Pwith_typesubst\n";
+  | Pwith_typesubst (lid, td) ->
+      line i ppf "Pwith_typesubst %a\n" fmt_longident_loc lid;
       type_declaration (i+1) ppf td;
   | Pwith_module (lid1, lid2) ->
       line i ppf "Pwith_module %a = %a\n"
         fmt_longident_loc lid1
         fmt_longident_loc lid2;
-  | Pwith_modsubst (s, li) ->
+  | Pwith_modsubst (lid1, lid2) ->
       line i ppf "Pwith_modsubst %a = %a\n"
-        fmt_string_loc s
-        fmt_longident_loc li;
+        fmt_longident_loc lid1
+        fmt_longident_loc lid2;
 
 and module_expr i ppf x =
   line i ppf "module_expr %a\n" fmt_location x.pmod_loc;
@@ -878,7 +889,7 @@ and label_x_expression i ppf (l,e) =
 and label_x_bool_x_core_type_list i ppf x =
   match x with
     Rtag (l, attrs, b, ctl) ->
-      line i ppf "Rtag \"%s\" %s\n" l (string_of_bool b);
+      line i ppf "Rtag \"%s\" %s\n" l.txt (string_of_bool b);
       attributes (i+1) ppf attrs;
       list (i+1) core_type ppf ctl
   | Rinherit (ct) ->

diff --git a/stdlib/.depend b/stdlib/.depend
index 961b1fd74ce118b0ebffe7fe936ac92c924b91f3..4ac015ad66474c1139b2824a7ab98109ae8e4722 100644 (file)
--- a/stdlib/.depend
+++ b/stdlib/.depend
@@ -9,9 +9,9 @@ array.cmi :
 arrayLabels.cmo : array.cmi arrayLabels.cmi
 arrayLabels.cmx : array.cmx arrayLabels.cmi
 arrayLabels.cmi :
-buffer.cmo : sys.cmi string.cmi bytes.cmi buffer.cmi
-buffer.cmx : sys.cmx string.cmx bytes.cmx buffer.cmi
-buffer.cmi :
+buffer.cmo : uchar.cmi sys.cmi string.cmi char.cmi bytes.cmi buffer.cmi
+buffer.cmx : uchar.cmx sys.cmx string.cmx char.cmx bytes.cmx buffer.cmi
+buffer.cmi : uchar.cmi
 bytes.cmo : pervasives.cmi char.cmi bytes.cmi
 bytes.cmx : pervasives.cmx char.cmx bytes.cmi
 bytes.cmi :
@@ -21,6 +21,8 @@ bytesLabels.cmi :
 callback.cmo : obj.cmi callback.cmi
 callback.cmx : obj.cmx callback.cmi
 callback.cmi :
+camlinternalBigarray.cmo : complex.cmi
+camlinternalBigarray.cmx : complex.cmx
 camlinternalFormat.cmo : sys.cmi string.cmi char.cmi \
     camlinternalFormatBasics.cmi bytes.cmi buffer.cmi camlinternalFormat.cmi
 camlinternalFormat.cmx : sys.cmx string.cmx char.cmx \
@@ -61,9 +63,9 @@ filename.cmo : sys.cmi string.cmi random.cmi printf.cmi lazy.cmi buffer.cmi \
 filename.cmx : sys.cmx string.cmx random.cmx printf.cmx lazy.cmx buffer.cmx \
     filename.cmi
 filename.cmi :
-format.cmo : string.cmi pervasives.cmi camlinternalFormatBasics.cmi \
+format.cmo : string.cmi pervasives.cmi list.cmi camlinternalFormatBasics.cmi \
     camlinternalFormat.cmi buffer.cmi format.cmi
-format.cmx : string.cmx pervasives.cmx camlinternalFormatBasics.cmx \
+format.cmx : string.cmx pervasives.cmx list.cmx camlinternalFormatBasics.cmx \
     camlinternalFormat.cmx buffer.cmx format.cmi
 format.cmi : pervasives.cmi buffer.cmi
 gc.cmo : sys.cmi string.cmi printf.cmi gc.cmi
@@ -192,14 +194,16 @@ array.cmo : array.cmi
 array.p.cmx : array.cmi
 arrayLabels.cmo : array.cmi arrayLabels.cmi
 arrayLabels.p.cmx : array.cmx arrayLabels.cmi
-buffer.cmo : sys.cmi string.cmi bytes.cmi buffer.cmi
-buffer.p.cmx : sys.cmx string.cmx bytes.cmx buffer.cmi
+buffer.cmo : uchar.cmi sys.cmi string.cmi char.cmi bytes.cmi buffer.cmi
+buffer.p.cmx : uchar.cmx sys.cmx string.cmx char.cmx bytes.cmx buffer.cmi
 bytes.cmo : pervasives.cmi char.cmi bytes.cmi
 bytes.p.cmx : pervasives.cmx char.cmx bytes.cmi
 bytesLabels.cmo : bytes.cmi bytesLabels.cmi
 bytesLabels.p.cmx : bytes.cmx bytesLabels.cmi
 callback.cmo : obj.cmi callback.cmi
 callback.p.cmx : obj.cmx callback.cmi
+camlinternalBigarray.cmo : complex.cmi
+camlinternalBigarray.p.cmx : complex.cmx
 camlinternalFormat.cmo : sys.cmi string.cmi char.cmi \
     camlinternalFormatBasics.cmi bytes.cmi buffer.cmi camlinternalFormat.cmi
 camlinternalFormat.p.cmx : sys.cmx string.cmx char.cmx \
@@ -230,9 +234,9 @@ filename.cmo : sys.cmi string.cmi random.cmi printf.cmi lazy.cmi buffer.cmi \
     filename.cmi
 filename.p.cmx : sys.cmx string.cmx random.cmx printf.cmx lazy.cmx buffer.cmx \
     filename.cmi
-format.cmo : string.cmi pervasives.cmi camlinternalFormatBasics.cmi \
+format.cmo : string.cmi pervasives.cmi list.cmi camlinternalFormatBasics.cmi \
     camlinternalFormat.cmi buffer.cmi format.cmi
-format.p.cmx : string.cmx pervasives.cmx camlinternalFormatBasics.cmx \
+format.p.cmx : string.cmx pervasives.cmx list.cmx camlinternalFormatBasics.cmx \
     camlinternalFormat.cmx buffer.cmx format.cmi
 gc.cmo : sys.cmi string.cmi printf.cmi gc.cmi
 gc.p.cmx : sys.cmx string.cmx printf.cmx gc.cmi

diff --git a/stdlib/Makefile b/stdlib/Makefile
index 004329a7e654752c3e8f4fc890ee3048b5382525..5f7bde13e3b1961cd56e64ee8bf8abeaabe521d0 100644 (file)
--- a/stdlib/Makefile
+++ b/stdlib/Makefile
@@ -48,7 +48,7 @@ OTHERS=list.cmo char.cmo uchar.cmo bytes.cmo string.cmo sys.cmo \
   filename.cmo complex.cmo \
   arrayLabels.cmo listLabels.cmo bytesLabels.cmo \
   stringLabels.cmo moreLabels.cmo stdLabels.cmo \
-  spacetime.cmo
+  spacetime.cmo camlinternalBigarray.cmo
 
 .PHONY: all
 all: stdlib.cma std_exit.cmo camlheader target_camlheader camlheader_ur
@@ -138,14 +138,14 @@ $(CAMLHEADERS): $(HEADERPROGRAM) ../config/Makefile
 ifeq "$(UNIX_OR_WIN32)" "unix"
 $(CAMLHEADERS):
        for suff in '' d i; do \
-         $(BYTECC) $(BYTECCCOMPOPTS) $(BYTECCLINKOPTS) \
+         $(CC) $(CFLAGS) $(CPPFLAGS) -I../byterun $(LDFLAGS) \
                    -DRUNTIME_NAME='"$(BINDIR)/ocamlrun'$$suff'"' \
-                   header.c -o tmpheader$(EXE) && \
+                   header.c $(OUTPUTEXE)tmpheader$(EXE) && \
          strip tmpheader$(EXE) && \
          mv tmpheader$(EXE) camlheader$$suff && \
-         $(BYTECC) $(BYTECCCOMPOPTS) $(BYTECCLINKOPTS) \
+         $(CC) $(CFLAGS) $(CPPFLAGS) -I../byterun $(LDFLAGS) \
                    -DRUNTIME_NAME='"$(TARGET_BINDIR)/ocamlrun'$$suff'"' \
-                   header.c -o tmpheader$(EXE) && \
+                   header.c $(OUTPUTEXE)tmpheader$(EXE) && \
          strip tmpheader$(EXE) && \
          mv tmpheader$(EXE) target_camlheader$$suff; \
        done && \
@@ -156,25 +156,25 @@ else # Windows
 # TODO: see whether there is a way to further merge the rules below
 # with those above
 
-camlheader target_camlheader camlheader_ur:
-       $(BYTECC) $(BYTECCCOMPOPTS) -c -I../byterun \
-                 -DRUNTIME_NAME='"ocamlrun"' headernt.c
+camlheader target_camlheader camlheader_ur: headernt.c
+       $(CC) -c $(CFLAGS) $(CPPFLAGS) -I../byterun \
+                 -DRUNTIME_NAME='"ocamlrun"' $(OUTPUTOBJ)headernt.$(O) $<
        $(MKEXE) -o tmpheader.exe headernt.$(O) $(EXTRALIBS)
        rm -f camlheader.exe
        mv tmpheader.exe camlheader
        cp camlheader target_camlheader
        cp camlheader camlheader_ur
 
-camlheaderd target_camlheaderd:
-       $(BYTECC) $(BYTECCCOMPOPTS) -c -I../byterun \
-                 -DRUNTIME_NAME='"ocamlrund"' headernt.c
+camlheaderd target_camlheaderd: headernt.c
+       $(CC) -c $(CFLAGS) $(CPPFLAGS) -I../byterun \
+                 -DRUNTIME_NAME='"ocamlrund"' $(OUTPUTOBJ)headernt.$(O) $<
        $(MKEXE) -o tmpheader.exe headernt.$(O) $(EXTRALIBS)
        mv tmpheader.exe camlheaderd
        cp camlheaderd target_camlheaderd
 
-camlheaderi:
-       $(BYTECC) $(BYTECCCOMPOPTS) -c -I../byterun \
-                 -DRUNTIME_NAME='"ocamlruni"' headernt.c
+camlheaderi: headernt.c
+       $(CC) -c $(CFLAGS) $(CPPFLAGS) -I../byterun \
+                 -DRUNTIME_NAME='"ocamlruni"' $(OUTPUTOBJ)headernt.$(O)
        $(MKEXE) -o tmpheader.exe headernt.$(O) $(EXTRALIBS)
        mv tmpheader.exe camlheaderi
 

diff --git a/stdlib/arg.ml b/stdlib/arg.ml
index 0f9095a7f48a1fb0bc35562900094224d1341433..e315e51121e89c61f4469bfc78b7e156b03f7ec1 100644 (file)
--- a/stdlib/arg.ml
+++ b/stdlib/arg.ml
@@ -309,8 +309,13 @@ let second_word s =
     else if s.[n] = ' ' then loop (n+1)
     else n
   in
-  try loop (String.index s ' ')
-  with Not_found -> len
+  match String.index s '\t' with
+  | n -> loop (n+1)
+  | exception Not_found ->
+      begin match String.index s ' ' with
+      | n -> loop (n+1)
+      | exception Not_found -> len
+      end
 
 
 let max_arg_len cur (kwd, spec, doc) =
@@ -319,6 +324,10 @@ let max_arg_len cur (kwd, spec, doc) =
   | _ -> max cur (String.length kwd + second_word doc)
 
 
+let replace_leading_tab s =
+  let seen = ref false in
+  String.map (function '\t' when not !seen -> seen := true; ' ' | c -> c) s
+
 let add_padding len ksd =
   match ksd with
   | (_, _, "") ->
@@ -328,16 +337,16 @@ let add_padding len ksd =
   | (kwd, (Symbol _ as spec), msg) ->
       let cutcol = second_word msg in
       let spaces = String.make ((max 0 (len - cutcol)) + 3) ' ' in
-      (kwd, spec, "\n" ^ spaces ^ msg)
+      (kwd, spec, "\n" ^ spaces ^ replace_leading_tab msg)
   | (kwd, spec, msg) ->
       let cutcol = second_word msg in
       let kwd_len = String.length kwd in
       let diff = len - kwd_len - cutcol in
       if diff <= 0 then
-        (kwd, spec, msg)
+        (kwd, spec, replace_leading_tab msg)
       else
         let spaces = String.make diff ' ' in
-        let prefix = String.sub msg 0 cutcol in
+        let prefix = String.sub (replace_leading_tab msg) 0 cutcol in
         let suffix = String.sub msg cutcol (String.length msg - cutcol) in
         (kwd, spec, prefix ^ spaces ^ suffix)
 

diff --git a/stdlib/arg.mli b/stdlib/arg.mli
index e7d942edea4b234384bfa5429caf53acd9d4ef30..6b6ee9e4023b756b326833f615f7e3f57a00b27a 100644 (file)
--- a/stdlib/arg.mli
+++ b/stdlib/arg.mli
@@ -168,14 +168,13 @@ val usage_string : (key * spec * doc) list -> usage_msg -> string
     if provided with the same parameters. *)
 
 val align: ?limit: int -> (key * spec * doc) list -> (key * spec * doc) list
-(** Align the documentation strings by inserting spaces at the first
-    space, according to the length of the keyword.  Use a
-    space as the first character in a doc string if you want to
-    align the whole string.  The doc strings corresponding to
-    [Symbol] arguments are aligned on the next line.
-    @param limit options with keyword and message longer than
-    [limit] will not be used to compute the alignement.
-*)
+(** Align the documentation strings by inserting spaces at the first alignment
+    separator (tab or, if tab is not found, space), according to the length of
+    the keyword.  Use a alignment separator as the first character in a doc
+    string if you want to align the whole string.  The doc strings corresponding
+    to [Symbol] arguments are aligned on the next line.
+    @param limit options with keyword and message longer than [limit] will not
+    be used to compute the alignment. *)
 
 val current : int ref
 (** Position (in {!Sys.argv}) of the argument being processed.  You can

diff --git a/stdlib/array.ml b/stdlib/array.ml
index a4270f278a6c12d31750f9f4f2542129097728b8..9b545878478ceb98c5c03e4080911373b25c0958 100644 (file)
--- a/stdlib/array.ml
+++ b/stdlib/array.ml
@@ -30,6 +30,16 @@ external unsafe_blit :
 external create_float: int -> float array = "caml_make_float_vect"
 let make_float = create_float
 
+module Floatarray = struct
+  external create : int -> floatarray = "caml_floatarray_create"
+  external length : floatarray -> int = "%floatarray_length"
+  external get : floatarray -> int -> float = "%floatarray_safe_get"
+  external set : floatarray -> int -> float -> unit = "%floatarray_safe_set"
+  external unsafe_get : floatarray -> int -> float = "%floatarray_unsafe_get"
+  external unsafe_set : floatarray -> int -> float -> unit
+      = "%floatarray_unsafe_set"
+end
+
 let init l f =
   if l = 0 then [||] else
   if l < 0 then invalid_arg "Array.init"

diff --git a/stdlib/array.mli b/stdlib/array.mli
index b89cd6b638d8d1b221d2b219253ea57c03947e8c..bfad5317cab24a5639545a42db8f02d3273d5d23 100644 (file)
--- a/stdlib/array.mli
+++ b/stdlib/array.mli
@@ -134,7 +134,7 @@ val of_list : 'a list -> 'a array
    of [l]. *)
 
 
-(** {6 Iterators} *)
+(** {1 Iterators} *)
 
 
 val iter : ('a -> unit) -> 'a array -> unit
@@ -168,7 +168,7 @@ val fold_right : ('b -> 'a -> 'a) -> 'b array -> 'a -> 'a
    where [n] is the length of the array [a]. *)
 
 
-(** {6 Iterators on two arrays} *)
+(** {1 Iterators on two arrays} *)
 
 
 val iter2 : ('a -> 'b -> unit) -> 'a array -> 'b array -> unit
@@ -185,7 +185,7 @@ val map2 : ('a -> 'b -> 'c) -> 'a array -> 'b array -> 'c array
    @since 4.03.0 *)
 
 
-(** {6 Array scanning} *)
+(** {1 Array scanning} *)
 
 
 val for_all : ('a -> bool) -> 'a array -> bool
@@ -211,7 +211,7 @@ val memq : 'a -> 'a array -> bool
    @since 4.03.0 *)
 
 
-(** {6 Sorting} *)
+(** {1 Sorting} *)
 
 
 val sort : ('a -> 'a -> int) -> 'a array -> unit
@@ -257,9 +257,19 @@ val fast_sort : ('a -> 'a -> int) -> 'a array -> unit
 
 
 (**/**)
-(** {6 Undocumented functions} *)
+(** {1 Undocumented functions} *)
 
 (* The following is for system use only. Do not call directly. *)
 
 external unsafe_get : 'a array -> int -> 'a = "%array_unsafe_get"
 external unsafe_set : 'a array -> int -> 'a -> unit = "%array_unsafe_set"
+
+module Floatarray : sig
+  external create : int -> floatarray = "caml_floatarray_create"
+  external length : floatarray -> int = "%floatarray_length"
+  external get : floatarray -> int -> float = "%floatarray_safe_get"
+  external set : floatarray -> int -> float -> unit = "%floatarray_safe_set"
+  external unsafe_get : floatarray -> int -> float = "%floatarray_unsafe_get"
+  external unsafe_set : floatarray -> int -> float -> unit
+      = "%floatarray_unsafe_set"
+end

diff --git a/stdlib/arrayLabels.mli b/stdlib/arrayLabels.mli
index 868f73a57e870cf9e94a25b376e5ee6d9aae786d..0b9fe0c9bcb0f3ab94dc1e3426f253ca6bfbd73c 100644 (file)
--- a/stdlib/arrayLabels.mli
+++ b/stdlib/arrayLabels.mli
@@ -211,7 +211,7 @@ val make_float: int -> float array
     {!Array.create_float}. *)
 
 
-(** {6 Sorting} *)
+(** {1 Sorting} *)
 
 
 val sort : cmp:('a -> 'a -> int) -> 'a array -> unit
@@ -258,9 +258,19 @@ val fast_sort : cmp:('a -> 'a -> int) -> 'a array -> unit
 
 (**/**)
 
-(** {6 Undocumented functions} *)
+(** {1 Undocumented functions} *)
 
 (* The following is for system use only. Do not call directly. *)
 
 external unsafe_get : 'a array -> int -> 'a = "%array_unsafe_get"
 external unsafe_set : 'a array -> int -> 'a -> unit = "%array_unsafe_set"
+
+module Floatarray : sig
+  external create : int -> floatarray = "caml_floatarray_create"
+  external length : floatarray -> int = "%floatarray_length"
+  external get : floatarray -> int -> float = "%floatarray_safe_get"
+  external set : floatarray -> int -> float -> unit = "%floatarray_safe_set"
+  external unsafe_get : floatarray -> int -> float = "%floatarray_unsafe_get"
+  external unsafe_set : floatarray -> int -> float -> unit
+      = "%floatarray_unsafe_set"
+end

diff --git a/stdlib/buffer.ml b/stdlib/buffer.ml
index 908909fa7c83aee4f4e6f00f2fd32a8b848a368c..0b03b560bb0762868d8aa2b7832ca1f745c4254f 100644 (file)
--- a/stdlib/buffer.ml
+++ b/stdlib/buffer.ml
@@ -80,6 +80,84 @@ let add_char b c =
   Bytes.unsafe_set b.buffer pos c;
   b.position <- pos + 1
 
+ let add_utf_8_uchar b u = match Uchar.to_int u with
+ | u when u < 0 -> assert false
+ | u when u <= 0x007F ->
+     add_char b (Char.unsafe_chr u)
+ | u when u <= 0x07FF ->
+     let pos = b.position in
+     if pos + 2 > b.length then resize b 2;
+     Bytes.unsafe_set b.buffer (pos    )
+       (Char.unsafe_chr (0xC0 lor (u lsr 6)));
+     Bytes.unsafe_set b.buffer (pos + 1)
+       (Char.unsafe_chr (0x80 lor (u land 0x3F)));
+     b.position <- pos + 2
+ | u when u <= 0xFFFF ->
+     let pos = b.position in
+     if pos + 3 > b.length then resize b 3;
+     Bytes.unsafe_set b.buffer (pos    )
+       (Char.unsafe_chr (0xE0 lor (u lsr 12)));
+     Bytes.unsafe_set b.buffer (pos + 1)
+       (Char.unsafe_chr (0x80 lor ((u lsr 6) land 0x3F)));
+     Bytes.unsafe_set b.buffer (pos + 2)
+       (Char.unsafe_chr (0x80 lor (u land 0x3F)));
+     b.position <- pos + 3
+ | u when u <= 0x10FFFF ->
+     let pos = b.position in
+     if pos + 4 > b.length then resize b 4;
+     Bytes.unsafe_set b.buffer (pos    )
+       (Char.unsafe_chr (0xF0 lor (u lsr 18)));
+     Bytes.unsafe_set b.buffer (pos + 1)
+       (Char.unsafe_chr (0x80 lor ((u lsr 12) land 0x3F)));
+     Bytes.unsafe_set b.buffer (pos + 2)
+       (Char.unsafe_chr (0x80 lor ((u lsr 6) land 0x3F)));
+     Bytes.unsafe_set b.buffer (pos + 3)
+       (Char.unsafe_chr (0x80 lor (u land 0x3F)));
+     b.position <- pos + 4
+ | _ -> assert false
+
+ let add_utf_16be_uchar b u = match Uchar.to_int u with
+ | u when u < 0 -> assert false
+ | u when u <= 0xFFFF ->
+     let pos = b.position in
+     if pos + 2 > b.length then resize b 2;
+     Bytes.unsafe_set b.buffer (pos    ) (Char.unsafe_chr (u lsr 8));
+     Bytes.unsafe_set b.buffer (pos + 1) (Char.unsafe_chr (u land 0xFF));
+     b.position <- pos + 2
+ | u when u <= 0x10FFFF ->
+     let u' = u - 0x10000 in
+     let hi = 0xD800 lor (u' lsr 10) in
+     let lo = 0xDC00 lor (u' land 0x3FF) in
+     let pos = b.position in
+     if pos + 4 > b.length then resize b 4;
+     Bytes.unsafe_set b.buffer (pos    ) (Char.unsafe_chr (hi lsr 8));
+     Bytes.unsafe_set b.buffer (pos + 1) (Char.unsafe_chr (hi land 0xFF));
+     Bytes.unsafe_set b.buffer (pos + 2) (Char.unsafe_chr (lo lsr 8));
+     Bytes.unsafe_set b.buffer (pos + 3) (Char.unsafe_chr (lo land 0xFF));
+     b.position <- pos + 4
+ | _ -> assert false
+
+ let add_utf_16le_uchar b u = match Uchar.to_int u with
+ | u when u < 0 -> assert false
+ | u when u <= 0xFFFF ->
+     let pos = b.position in
+     if pos + 2 > b.length then resize b 2;
+     Bytes.unsafe_set b.buffer (pos    ) (Char.unsafe_chr (u land 0xFF));
+     Bytes.unsafe_set b.buffer (pos + 1) (Char.unsafe_chr (u lsr 8));
+     b.position <- pos + 2
+ | u when u <= 0x10FFFF ->
+     let u' = u - 0x10000 in
+     let hi = 0xD800 lor (u' lsr 10) in
+     let lo = 0xDC00 lor (u' land 0x3FF) in
+     let pos = b.position in
+     if pos + 4 > b.length then resize b 4;
+     Bytes.unsafe_set b.buffer (pos    ) (Char.unsafe_chr (hi land 0xFF));
+     Bytes.unsafe_set b.buffer (pos + 1) (Char.unsafe_chr (hi lsr 8));
+     Bytes.unsafe_set b.buffer (pos + 2) (Char.unsafe_chr (lo land 0xFF));
+     Bytes.unsafe_set b.buffer (pos + 3) (Char.unsafe_chr (lo lsr 8));
+     b.position <- pos + 4
+ | _ -> assert false
+
 let add_substring b s offset len =
   if offset < 0 || len < 0 || offset > String.length s - len
   then invalid_arg "Buffer.add_substring/add_subbytes";

diff --git a/stdlib/buffer.mli b/stdlib/buffer.mli
index 71d87970ea0d103bfb84df15546a4bda2f93b07f..21baaad6cad0898cb7476863f6efeda6e9f49b63 100644 (file)
--- a/stdlib/buffer.mli
+++ b/stdlib/buffer.mli
@@ -85,6 +85,26 @@ val reset : t -> unit
 val add_char : t -> char -> unit
 (** [add_char b c] appends the character [c] at the end of buffer [b]. *)
 
+val add_utf_8_uchar : t -> Uchar.t -> unit
+(** [add_utf_8_uchar b u] appends the {{:https://tools.ietf.org/html/rfc3629}
+    UTF-8} encoding of [u] at the end of buffer [b].
+
+    @since 4.06.0 *)
+
+val add_utf_16le_uchar : t -> Uchar.t -> unit
+(** [add_utf_16le_uchar b u] appends the
+    {{:https://tools.ietf.org/html/rfc2781}UTF-16LE} encoding of [u]
+    at the end of buffer [b].
+
+    @since 4.06.0 *)
+
+val add_utf_16be_uchar : t -> Uchar.t -> unit
+(** [add_utf_16be_uchar b u] appends the
+    {{:https://tools.ietf.org/html/rfc2781}UTF-16BE} encoding of [u]
+    at the end of buffer [b].
+
+    @since 4.06.0 *)
+
 val add_string : t -> string -> unit
 (** [add_string b s] appends the string [s] at the end of buffer [b]. *)
 

diff --git a/stdlib/bytes.mli b/stdlib/bytes.mli
index dc530787689badf51ddfe0ba6b1666ef3c42eb08..3bef5b4abb3d2bc154af11345b3d7be5018213fa 100644 (file)
--- a/stdlib/bytes.mli
+++ b/stdlib/bytes.mli
@@ -318,7 +318,7 @@ val equal: t -> t -> bool
 (** The equality function for byte sequences.
     @since 4.03.0 *)
 
-(** {4 Unsafe conversions (for advanced users)}
+(** {3 Unsafe conversions (for advanced users)}
 
     This section describes unsafe, low-level conversion functions
     between [bytes] and [string]. They do not copy the internal data;

diff --git a/stdlib/bytesLabels.mli b/stdlib/bytesLabels.mli
index 9848f32d7e09802bd0c45b49968a8f76c5551b4a..35399832d9767bdca0483c1e4367e2e1673b36a8 100644 (file)
--- a/stdlib/bytesLabels.mli
+++ b/stdlib/bytesLabels.mli
@@ -73,7 +73,7 @@ val sub : bytes -> pos:int -> len:int -> bytes
     Raise [Invalid_argument] if [start] and [len] do not designate a
     valid range of [s]. *)
 
-val sub_string : bytes -> int -> int -> string
+val sub_string : bytes -> pos:int -> len:int -> string
 (** Same as [sub] but return a string instead of a byte sequence. *)
 
 val extend : bytes -> left:int -> right:int -> bytes

diff --git a/stdlib/camlinternalBigarray.ml b/stdlib/camlinternalBigarray.ml
new file mode 100644 (file)
index 0000000..04d908b
--- /dev/null
+++ b/stdlib/camlinternalBigarray.ml
@@ -0,0 +1,54 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*          Manuel Serrano and Xavier Leroy, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 2000 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Bigarray types. These must be kept in sync with the tables in
+   ../typing/typeopt.ml *)
+
+type float32_elt = Float32_elt
+type float64_elt = Float64_elt
+type int8_signed_elt = Int8_signed_elt
+type int8_unsigned_elt = Int8_unsigned_elt
+type int16_signed_elt = Int16_signed_elt
+type int16_unsigned_elt = Int16_unsigned_elt
+type int32_elt = Int32_elt
+type int64_elt = Int64_elt
+type int_elt = Int_elt
+type nativeint_elt = Nativeint_elt
+type complex32_elt = Complex32_elt
+type complex64_elt = Complex64_elt
+
+type ('a, 'b) kind =
+    Float32 : (float, float32_elt) kind
+  | Float64 : (float, float64_elt) kind
+  | Int8_signed : (int, int8_signed_elt) kind
+  | Int8_unsigned : (int, int8_unsigned_elt) kind
+  | Int16_signed : (int, int16_signed_elt) kind
+  | Int16_unsigned : (int, int16_unsigned_elt) kind
+  | Int32 : (int32, int32_elt) kind
+  | Int64 : (int64, int64_elt) kind
+  | Int : (int, int_elt) kind
+  | Nativeint : (nativeint, nativeint_elt) kind
+  | Complex32 : (Complex.t, complex32_elt) kind
+  | Complex64 : (Complex.t, complex64_elt) kind
+  | Char : (char, int8_unsigned_elt) kind
+
+type c_layout = C_layout_typ
+type fortran_layout = Fortran_layout_typ
+
+type 'a layout =
+    C_layout: c_layout layout
+  | Fortran_layout: fortran_layout layout
+
+type ('a, 'b, 'c) genarray

diff --git a/stdlib/camlinternalFormat.ml b/stdlib/camlinternalFormat.ml
index 9c0574dd796ea7950f48765fd4e2b9873ea0251f..3d8369aac87aacd931b7ca6a66f0e7ae4ecff5b4 100644 (file)
--- a/stdlib/camlinternalFormat.ml
+++ b/stdlib/camlinternalFormat.ml
@@ -96,8 +96,8 @@ fun ign fmt -> match ign with
   | Ignored_float (pad_opt, prec_opt) ->
     Param_format_EBB
       (Float (Float_f, pad_of_pad_opt pad_opt, prec_of_prec_opt prec_opt, fmt))
-  | Ignored_bool ->
-    Param_format_EBB (Bool fmt)
+  | Ignored_bool pad_opt ->
+    Param_format_EBB (Bool (pad_of_pad_opt pad_opt, fmt))
   | Ignored_format_arg (pad_opt, fmtty) ->
     Param_format_EBB (Format_arg (pad_opt, fmtty, fmt))
   | Ignored_format_subst (pad_opt, fmtty) ->
@@ -403,7 +403,7 @@ let bprint_precision : type a b . buffer -> (a, b) precision -> unit =
 
 (***)
 
-(* Print the optionnal '+', ' ' or '#' associated to an int conversion. *)
+(* Print the optional '+', ' ' or '#' associated to an int conversion. *)
 let bprint_iconv_flag buf iconv = match iconv with
   | Int_pd | Int_pi -> buffer_add_char buf '+'
   | Int_sd | Int_si -> buffer_add_char buf ' '
@@ -431,7 +431,7 @@ let bprint_altint_fmt buf ign_flag iconv pad prec c =
 
 (***)
 
-(* Print the optionnal '+' associated to a float conversion. *)
+(* Print the optional '+' associated to a float conversion. *)
 let bprint_fconv_flag buf fconv = match fconv with
   | Float_pf | Float_pe | Float_pE
   | Float_pg | Float_pG | Float_ph | Float_pH ->
@@ -564,9 +564,10 @@ let bprint_fmt buf fmt =
     | Caml_char rest ->
       buffer_add_char buf '%'; bprint_ignored_flag buf ign_flag;
       buffer_add_char buf 'C'; fmtiter rest false;
-    | Bool rest ->
+    | Bool (pad, rest) ->
       buffer_add_char buf '%'; bprint_ignored_flag buf ign_flag;
-      buffer_add_char buf 'B'; fmtiter rest false;
+      bprint_padding buf pad; buffer_add_char buf 'B';
+      fmtiter rest false;
     | Alpha rest ->
       buffer_add_char buf '%'; bprint_ignored_flag buf ign_flag;
       buffer_add_char buf 'a'; fmtiter rest false;
@@ -884,7 +885,7 @@ fun fmtty -> match fmtty with
 
   | Char rest                  -> Char_ty (fmtty_of_fmt rest)
   | Caml_char rest             -> Char_ty (fmtty_of_fmt rest)
-  | Bool rest                  -> Bool_ty (fmtty_of_fmt rest)
+  | Bool (pad, rest)           -> fmtty_of_padding_fmtty pad (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)
@@ -932,7 +933,7 @@ fun ign fmt -> match ign with
   | Ignored_nativeint (_, _)        -> fmtty_of_fmt fmt
   | Ignored_int64 (_, _)            -> fmtty_of_fmt fmt
   | Ignored_float (_, _)            -> fmtty_of_fmt fmt
-  | Ignored_bool                    -> fmtty_of_fmt fmt
+  | Ignored_bool _                  -> fmtty_of_fmt fmt
   | Ignored_format_arg _            -> fmtty_of_fmt fmt
   | Ignored_format_subst (_, fmtty) -> concat_fmtty fmtty (fmtty_of_fmt fmt)
   | Ignored_reader                  -> Ignored_reader_ty (fmtty_of_fmt fmt)
@@ -992,7 +993,7 @@ fun pad prec fmtty -> match prec, type_padding pad fmtty with
 (* Type a format according to an fmtty. *)
 (* If typing succeed, generate a copy of the format with the same
     type parameters as the fmtty. *)
-(* Raise a Failure with an error message in case of type mismatch. *)
+(* Raise [Failure] with an error message in case of type mismatch. *)
 let rec type_format :
   type a1 b1 c1 d1 e1 f1
        a2 b2 c2 d2 e2 f2  .
@@ -1065,9 +1066,13 @@ and type_format_gen :
       Fmt_fmtty_EBB (Float (fconv, pad, prec, fmt'), fmtty')
     | Padprec_fmtty_EBB (_, _, _) -> raise Type_mismatch
   )
-  | Bool fmt_rest, Bool_ty fmtty_rest ->
-    let Fmt_fmtty_EBB (fmt', fmtty') = type_format_gen fmt_rest fmtty_rest in
-    Fmt_fmtty_EBB (Bool fmt', fmtty')
+  | Bool (pad, fmt_rest), _ -> (
+    match type_padding pad fmtty with
+    | Padding_fmtty_EBB (pad, Bool_ty fmtty_rest) ->
+      let Fmt_fmtty_EBB (fmt', fmtty') = type_format_gen fmt_rest fmtty_rest in
+      Fmt_fmtty_EBB (Bool (pad, fmt'), fmtty')
+    | Padding_fmtty_EBB (_, _) -> raise Type_mismatch
+  )
   | Flush fmt_rest, fmtty_rest ->
     let Fmt_fmtty_EBB (fmt', fmtty') = type_format_gen fmt_rest fmtty_rest in
     Fmt_fmtty_EBB (Flush fmt', fmtty')
@@ -1155,7 +1160,7 @@ fun ign fmt fmtty -> match ign with
   | Ignored_nativeint _        as ign' -> type_ignored_param_one ign' fmt fmtty
   | Ignored_int64 _            as ign' -> type_ignored_param_one ign' fmt fmtty
   | Ignored_float _            as ign' -> type_ignored_param_one ign' fmt fmtty
-  | Ignored_bool               as ign' -> type_ignored_param_one ign' fmt fmtty
+  | Ignored_bool _             as ign' -> type_ignored_param_one ign' fmt fmtty
   | Ignored_scan_char_set _    as ign' -> type_ignored_param_one ign' fmt fmtty
   | Ignored_scan_get_counter _ as ign' -> type_ignored_param_one ign' fmt fmtty
   | Ignored_scan_next_char     as ign' -> type_ignored_param_one ign' fmt fmtty
@@ -1304,7 +1309,7 @@ let recast :
 (******************************************************************************)
                              (* Printing tools *)
 
-(* Add padding spaces arround a string. *)
+(* Add padding spaces around a string. *)
 let fix_padding padty width str =
   let len = String.length str in
   let width, padty =
@@ -1487,9 +1492,9 @@ fun k o acc fmt -> match fmt with
       let new_acc = Acc_data_string (acc, format_caml_char c) in
       make_printf k o new_acc rest
   | String (pad, rest) ->
-    make_string_padding k o acc rest pad (fun str -> str)
+    make_padding k o acc rest pad (fun str -> str)
   | Caml_string (pad, rest) ->
-    make_string_padding k o acc rest pad string_to_caml_string
+    make_padding k o acc rest pad string_to_caml_string
   | Int (iconv, pad, prec, rest) ->
     make_int_padding_precision k o acc rest pad prec convert_int iconv
   | Int32 (iconv, pad, prec, rest) ->
@@ -1500,8 +1505,8 @@ fun k o acc fmt -> match fmt with
     make_int_padding_precision k o acc rest pad prec convert_int64 iconv
   | Float (fconv, pad, prec, rest) ->
     make_float_padding_precision k o acc rest pad prec fconv
-  | Bool rest ->
-    fun b -> make_printf k o (Acc_data_string (acc, string_of_bool b)) rest
+  | Bool (pad, rest) ->
+    make_padding k o acc rest pad string_of_bool
   | Alpha rest ->
     fun f x -> make_printf k o (Acc_delay (acc, fun o -> f o x)) rest
   | Theta rest ->
@@ -1582,7 +1587,7 @@ fun k o acc ign fmt -> match ign with
   | Ignored_nativeint (_, _)        -> make_invalid_arg k o acc fmt
   | Ignored_int64 (_, _)            -> make_invalid_arg k o acc fmt
   | Ignored_float (_, _)            -> make_invalid_arg k o acc fmt
-  | Ignored_bool                    -> make_invalid_arg k o acc fmt
+  | Ignored_bool _                  -> make_invalid_arg k o acc fmt
   | Ignored_format_arg _            -> make_invalid_arg k o acc fmt
   | Ignored_format_subst (_, fmtty) -> make_from_fmtty k o acc fmtty fmt
   | Ignored_reader                  -> assert false
@@ -1625,7 +1630,7 @@ fun k o acc fmt ->
   make_printf k o (Acc_invalid_arg (acc, "Printf: bad conversion %_")) fmt
 
 (* Fix padding, take it as an extra integer argument if needed. *)
-and make_string_padding : type x z a b c d e f .
+and make_padding : type x z a b c d e f .
     (b -> (b, c) acc -> f) -> b -> (b, c) acc ->
     (a, b, c, d, e, f) fmt ->
     (x, z -> a) padding -> (z -> string) -> x =
@@ -1774,8 +1779,12 @@ let rec make_iprintf : type a b c d e f.
         fn_of_padding_precision k o rest pad prec
     | Float (_, pad, prec, rest) ->
         fn_of_padding_precision k o rest pad prec
-    | Bool rest ->
+    | Bool (No_padding, rest) ->
         const (make_iprintf k o rest)
+    | Bool (Lit_padding _, rest) ->
+        const (make_iprintf k o rest)
+    | Bool (Arg_padding _, rest) ->
+        const (const (make_iprintf k o rest))
     | Alpha rest ->
         const (const (make_iprintf k o rest))
     | Theta rest ->
@@ -1910,9 +1919,9 @@ let rec strput_acc b acc = match acc with
   | End_of_acc               -> ()
 
 (******************************************************************************)
-                          (* Error managment *)
+                          (* Error management *)
 
-(* Raise a Failure with a pretty-printed error message. *)
+(* Raise [Failure] with a pretty-printed error message. *)
 let failwith_message (Format (fmt, _)) =
   let buf = Buffer.create 256 in
   let k () acc = strput_acc buf acc; failwith (Buffer.contents buf) in
@@ -1984,7 +1993,7 @@ fun prec fmt -> match prec with
   | Lit_precision p -> Precision_fmt_EBB (Lit_precision p, fmt)
   | Arg_precision   -> Precision_fmt_EBB (Arg_precision, fmt)
 
-(* Create a padprec_fmt_ebb forma a padding, a precision and a format. *)
+(* Create a padprec_fmt_ebb from a padding, a precision and a format. *)
 (* Copy the padding and the precision to disjoin type parameters of arguments
    and result. *)
 let make_padprec_fmt_ebb : type x y z t .
@@ -2002,7 +2011,7 @@ fun pad prec fmt ->
                              (* Format parsing *)
 
 (* Parse a string representing a format and create a fmt_ebb. *)
-(* Raise an Failure exception in case of invalid format. *)
+(* Raise [Failure] in case of invalid format. *)
 let fmt_ebb_of_string ?legacy_behavior str =
   (* Parameters naming convention:                                    *)
   (*   - lit_start: start of the literal sequence.                    *)
@@ -2030,20 +2039,20 @@ let fmt_ebb_of_string ?legacy_behavior str =
 
       A typical example would be "%+ d": specifying both '+' (if the
       number is positive, pad with a '+' to get the same width as
-      negative numbres) and ' ' (if the number is positive, pad with
+      negative numbers) and ' ' (if the number is positive, pad with
       a space) does not make sense, but the legacy (< 4.02)
       implementation was happy to just ignore the space.
   *)
   in
 
-  (* Raise a Failure with a friendly error message. *)
+  (* Raise [Failure] with a friendly error message. *)
   let invalid_format_message str_ind msg =
     failwith_message
       "invalid format %S: at character number %d, %s"
-      str str_ind msg;
+      str str_ind msg
   in
 
-  (* Used when the end of the format (or the current sub-format) was encoutered
+  (* Used when the end of the format (or the current sub-format) was encountered
       unexpectedly. *)
   let unexpected_end_of_format end_ind =
     invalid_format_message end_ind
@@ -2055,7 +2064,7 @@ let fmt_ebb_of_string ?legacy_behavior str =
     invalid_format_message str_ind
       "non-zero widths are unsupported for %c conversions"
   in
-  (* Raise Failure with a friendly error message about an option dependencie
+  (* Raise [Failure] with a friendly error message about an option dependency
      problem. *)
   let invalid_format_without str_ind c s =
     failwith_message
@@ -2063,7 +2072,7 @@ let fmt_ebb_of_string ?legacy_behavior str =
       str str_ind c s
   in
 
-  (* Raise Failure with a friendly error message about an unexpected
+  (* Raise [Failure] with a friendly error message about an unexpected
      character. *)
   let expected_character str_ind expected read =
     failwith_message
@@ -2196,7 +2205,7 @@ let fmt_ebb_of_string ?legacy_behavior str =
     | '0' .. '9' -> parse_literal minus str_ind
     | ('+' | '-') as symb when legacy_behavior ->
       (* Legacy mode would accept and ignore '+' or '-' before the
-         integer describing the desired precision; not that this
+         integer describing the desired precision; note that this
          cannot happen for padding width, as '+' and '-' already have
          a semantics there.
 
@@ -2271,7 +2280,7 @@ let fmt_ebb_of_string ?legacy_behavior str =
          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
+         interpretation for compatibility, 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
@@ -2448,9 +2457,15 @@ let fmt_ebb_of_string ?legacy_behavior str =
           make_padprec_fmt_ebb (get_pad ()) (get_prec ()) fmt_rest in
         Fmt_EBB (Float (fconv, pad', prec', fmt_rest'))
     | 'b' | 'B' ->
+      let pad = check_no_0 symb (get_padprec ()) in
       let Fmt_EBB fmt_rest = parse str_ind end_ind in
-      if get_ign () then Fmt_EBB (Ignored_param (Ignored_bool, fmt_rest))
-      else Fmt_EBB (Bool fmt_rest)
+      if get_ign () then
+        let ignored = Ignored_bool (get_padprec_opt '_') in
+        Fmt_EBB (Ignored_param (ignored, fmt_rest))
+      else
+        let Padding_fmt_EBB (pad', fmt_rest') =
+          make_padding_fmt_ebb pad fmt_rest in
+        Fmt_EBB (Bool (pad', fmt_rest'))
     | 'a' ->
       let Fmt_EBB fmt_rest = parse str_ind end_ind in
       Fmt_EBB (Alpha fmt_rest)
@@ -2591,7 +2606,7 @@ let fmt_ebb_of_string ?legacy_behavior str =
     )
     | _ -> ()
 
-  (* Try to read the optionnal <name> after "@{" or "@[". *)
+  (* Try to read the optional <name> after "@{" or "@[". *)
   and parse_tag : type e f . bool -> int -> int -> (_, _, e, f) fmt_ebb =
   fun is_open_tag str_ind end_ind ->
     try
@@ -2617,7 +2632,7 @@ let fmt_ebb_of_string ?legacy_behavior str =
         if is_open_tag then Open_tag sub_format else Open_box sub_format in
       Fmt_EBB (Formatting_gen (formatting, fmt_rest))
 
-  (* Try to read the optionnal <width offset> after "@;". *)
+  (* Try to read the optional <width offset> after "@;". *)
   and parse_good_break : type e f . int -> int -> (_, _, e, f) fmt_ebb =
   fun str_ind end_ind ->
     let next_ind, formatting_lit =
@@ -2688,14 +2703,14 @@ let fmt_ebb_of_string ?legacy_behavior str =
     let fail_single_percent str_ind =
       failwith_message
         "invalid format %S: '%%' alone is not accepted in character sets, \
-         use %%%% instead at position %d." str str_ind;
+         use %%%% instead at position %d." str str_ind
     in
 
     (* Parse the first character of a char set. *)
     let rec parse_char_set_start str_ind end_ind =
       if str_ind = end_ind then unexpected_end_of_format end_ind;
       let c = str.[str_ind] in
-      parse_char_set_after_char (str_ind + 1) end_ind c;
+      parse_char_set_after_char (str_ind + 1) end_ind c
 
     (* Parse the content of a char set until the first ']'. *)
     and parse_char_set_content str_ind end_ind =
@@ -2705,9 +2720,9 @@ let fmt_ebb_of_string ?legacy_behavior str =
         str_ind + 1
       | '-' ->
         add_char '-';
-        parse_char_set_content (str_ind + 1) end_ind;
+        parse_char_set_content (str_ind + 1) end_ind
       | c ->
-        parse_char_set_after_char (str_ind + 1) end_ind c;
+        parse_char_set_after_char (str_ind + 1) end_ind c
 
     (* Test for range in char set. *)
     and parse_char_set_after_char str_ind end_ind c =
@@ -2838,10 +2853,10 @@ let fmt_ebb_of_string ?legacy_behavior str =
           search_subformat_end (sub_end + 2) end_ind c
         | '}' ->
           (* Error: %(...%}. *)
-          expected_character (str_ind + 1) "character ')'" '}';
+          expected_character (str_ind + 1) "character ')'" '}'
         | ')' ->
           (* Error: %{...%). *)
-          expected_character (str_ind + 1) "character '}'" ')';
+          expected_character (str_ind + 1) "character '}'" ')'
         | _ ->
           search_subformat_end (str_ind + 2) end_ind c
         end
@@ -2924,14 +2939,14 @@ let fmt_ebb_of_string ?legacy_behavior str =
       else incompatible_flag pct_ind str_ind symb "'+'"
     | false, false, _ -> assert false
 
-  (* Raise a Failure with a friendly error message about incompatible options.*)
+  (* Raise [Failure] with a friendly error message about incompatible options.*)
   and incompatible_flag : type a . int -> int -> char -> string -> a =
     fun pct_ind str_ind symb option ->
       let subfmt = String.sub str pct_ind (str_ind - pct_ind) in
       failwith_message
         "invalid format %S: at character number %d, \
          %s is incompatible with '%c' in sub-format %S"
-        str pct_ind option symb subfmt;
+        str pct_ind option symb subfmt
 
   in parse 0 (String.length str)
 
@@ -2939,7 +2954,7 @@ let fmt_ebb_of_string ?legacy_behavior str =
                   (* Guarded string to format conversions *)
 
 (* Convert a string to a format according to an fmtty. *)
-(* Raise a Failure with an error message in case of type mismatch. *)
+(* Raise [Failure] with an error message in case of type mismatch. *)
 let format_of_string_fmtty str fmtty =
   let Fmt_EBB fmt = fmt_ebb_of_string str in
   try Format (type_format fmt fmtty, str)
@@ -2949,7 +2964,7 @@ let format_of_string_fmtty str fmtty =
       str (string_of_fmtty fmtty)
 
 (* Convert a string to a format compatible with an other format. *)
-(* Raise a Failure with an error message in case of type mismatch. *)
+(* Raise [Failure] with an error message in case of type mismatch. *)
 let format_of_string_format str (Format (fmt', str')) =
   let Fmt_EBB fmt = fmt_ebb_of_string str in
   try Format (type_format fmt (fmtty_of_fmt fmt'), str)

diff --git a/stdlib/camlinternalFormatBasics.ml b/stdlib/camlinternalFormatBasics.ml
index 9dbd563d7a9e8da4172509ecd2cf2bcd8feb90d5..0474342628a684b510694262b4291ba8bd2efc90 100644 (file)
--- a/stdlib/camlinternalFormatBasics.ml
+++ b/stdlib/camlinternalFormatBasics.ml
@@ -189,7 +189,7 @@ to transpose between related format types.
 NOTE [1]: the typing of Format_subst_ty requires not one format type, but
 two, one to establish the link between the format argument and the
 first six parameters, and the other for the link between the format
-argumant and the last six parameters.
+argument and the last six parameters.
 
 | Format_subst_ty :                                         (* %(...%) *)
     ('g, 'h, 'i, 'j, 'k, 'l,
@@ -214,7 +214,7 @@ function that proves that the relation is transitive
   -> ('a1, 'b1, 'c1, 'd1, 'e1, 'f1,
       'a3, 'b3, 'c3, 'd3, 'e3, 'f3) fmtty_rel
 
-does assume that the two input have exactly the same term structure
+does assume that the two inputs have exactly the same term structure
 (and is only every used for argument witnesses of the
 Format_subst_ty constructor).
 *)
@@ -232,7 +232,7 @@ type block_type =
                  when it leads to a new indentation of the current line *)
   | Pp_fits   (* Internal usage: when a block fits on a single line *)
 
-(* Formatting element used by the Format pretty-printter. *)
+(* Formatting element used by the Format pretty-printer. *)
 type formatting_lit =
   | Close_box                                           (* @]   *)
   | Close_tag                                           (* @}   *)
@@ -245,7 +245,7 @@ type formatting_lit =
   | Escaped_percent                                     (* @%%  *)
   | Scan_indic of char                                  (* @X   *)
 
-(* Formatting element used by the Format pretty-printter. *)
+(* Formatting element used by the Format pretty-printer. *)
 type ('a, 'b, 'c, 'd, 'e, 'f) formatting_gen =
   | Open_tag : ('a, 'b, 'c, 'd, 'e, 'f) format6 ->      (* @{   *)
     ('a, 'b, 'c, 'd, 'e, 'f) formatting_gen
@@ -390,8 +390,8 @@ and ('a, 'b, 'c, 'd, 'e, 'f) fmt =
       ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
         ('x, 'b, 'c, 'd, 'e, 'f) fmt
   | Bool :                                                   (* %[bB] *)
-      ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
-        (bool -> 'a, 'b, 'c, 'd, 'e, 'f) fmt
+      ('x, bool -> 'a) padding * ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
+        ('x, 'b, 'c, 'd, 'e, 'f) fmt
   | Flush :                                                  (* %! *)
       ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
         ('a, 'b, 'c, 'd, 'e, 'f) fmt
@@ -452,7 +452,7 @@ and ('a, 'b, 'c, 'd, 'e, 'f) fmt =
      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
+     intended for custom processors that wish to rely on the
      stdlib-defined format GADTs.
 
      For instance a pre-processor could choose to interpret strings
@@ -499,7 +499,7 @@ and ('a, 'b, 'c, 'd, 'e, 'f) ignored =
   | Ignored_float :                                          (* %_f *)
       pad_option * prec_option -> ('a, 'b, 'c, 'd, 'd, 'a) ignored
   | Ignored_bool :                                           (* %_B *)
-      ('a, 'b, 'c, 'd, 'd, 'a) ignored
+      pad_option -> ('a, 'b, 'c, 'd, 'd, 'a) ignored
   | Ignored_format_arg :                                     (* %_{...%} *)
       pad_option * ('g, 'h, 'i, 'j, 'k, 'l) fmtty ->
         ('a, 'b, 'c, 'd, 'd, 'a) ignored
@@ -642,8 +642,8 @@ fun fmt1 fmt2 -> match fmt1 with
     Char (concat_fmt rest fmt2)
   | Caml_char rest ->
     Caml_char (concat_fmt rest fmt2)
-  | Bool rest ->
-    Bool (concat_fmt rest fmt2)
+  | Bool (pad, rest) ->
+    Bool (pad, concat_fmt rest fmt2)
   | Alpha rest ->
     Alpha (concat_fmt rest fmt2)
   | Theta rest ->

diff --git a/stdlib/camlinternalFormatBasics.mli b/stdlib/camlinternalFormatBasics.mli
index aba9f6f4a7cf478056bf54893122067072b024be..3c351ef702742647c9b3a21831789e090629a582 100644 (file)
--- a/stdlib/camlinternalFormatBasics.mli
+++ b/stdlib/camlinternalFormatBasics.mli
@@ -201,8 +201,8 @@ and ('a, 'b, 'c, 'd, 'e, 'f) fmt =
     ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
       ('x, 'b, 'c, 'd, 'e, 'f) fmt
 | Bool :                                                   (* %[bB] *)
-    ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
-      (bool -> 'a, 'b, 'c, 'd, 'e, 'f) fmt
+    ('x, bool -> 'a) padding * ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
+      ('x, 'b, 'c, 'd, 'e, 'f) fmt
 | Flush :                                                  (* %! *)
     ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
       ('a, 'b, 'c, 'd, 'e, 'f) fmt
@@ -288,7 +288,7 @@ and ('a, 'b, 'c, 'd, 'e, 'f) ignored =
   | Ignored_float :
       pad_option * prec_option -> ('a, 'b, 'c, 'd, 'd, 'a) ignored
   | Ignored_bool :
-      ('a, 'b, 'c, 'd, 'd, 'a) ignored
+      pad_option -> ('a, 'b, 'c, 'd, 'd, 'a) ignored
   | Ignored_format_arg :
       pad_option * ('g, 'h, 'i, 'j, 'k, 'l) fmtty ->
         ('a, 'b, 'c, 'd, 'd, 'a) ignored

diff --git a/stdlib/camlinternalMod.ml b/stdlib/camlinternalMod.ml
index 9e2619263e09ffd4e5a9a3ef615415910e416074..5ccf92893b2da7043305cda23f8a857fadb5d400 100644 (file)
--- a/stdlib/camlinternalMod.ml
+++ b/stdlib/camlinternalMod.ml
@@ -50,7 +50,7 @@ let rec update_mod shape o n =
   match shape with
   | Function ->
       if Obj.tag n = Obj.closure_tag && Obj.size n <= Obj.size o
-      then begin overwrite o n; Obj.truncate o (Obj.size n) (* PR #4008 *) end
+      then begin overwrite o n; Obj.truncate o (Obj.size n) (* PR#4008 *) end
       else overwrite o (Obj.repr (fun x -> (Obj.obj n : _ -> _) x))
   | Lazy ->
       if Obj.tag n = Obj.lazy_tag then

diff --git a/stdlib/camlinternalOO.mli b/stdlib/camlinternalOO.mli
index 7c7e0013baf3cee188f335aa0f8d0206d616c68c..b6ffc70d7fcd2f32830c0f9a205b91cb9ddf24be 100644 (file)
--- a/stdlib/camlinternalOO.mli
+++ b/stdlib/camlinternalOO.mli
@@ -17,7 +17,7 @@
     All functions in this module are for system use only, not for the
     casual user. *)
 
-(** {6 Classes} *)
+(** {1 Classes} *)
 
 type tag
 type label
@@ -57,7 +57,7 @@ val dummy_class :
     string * int * int ->
     (t * (table -> Obj.t -> t) * (Obj.t -> t) * Obj.t)
 
-(** {6 Objects} *)
+(** {1 Objects} *)
 
 val copy : (< .. > as 'a) -> 'a
 val create_object : table -> obj
@@ -71,12 +71,12 @@ external sendself : obj -> label -> t = "%sendself"
 external get_public_method : obj -> tag -> closure
     = "caml_get_public_method" [@@noalloc]
 
-(** {6 Table cache} *)
+(** {1 Table cache} *)
 
 type tables
 val lookup_tables : tables -> closure array -> tables
 
-(** {6 Builtins to reduce code size} *)
+(** {1 Builtins to reduce code size} *)
 
 (*
 val get_const : t -> closure
@@ -132,7 +132,7 @@ type impl =
   | SendMeth
   | Closure of closure
 
-(** {6 Parameters} *)
+(** {1 Parameters} *)
 
 (* currently disabled *)
 type params =
@@ -144,7 +144,7 @@ type params =
 
 val params : params
 
-(** {6 Statistics} *)
+(** {1 Statistics} *)
 
 type stats =
   { classes : int;

diff --git a/stdlib/ephemeron.mli b/stdlib/ephemeron.mli
index 46d3aad361dcd60b0f2d528a89ade4cb03b5b3d3..efa5f661aa4cb1238d1eb433af4133cda7309227 100644 (file)
--- a/stdlib/ephemeron.mli
+++ b/stdlib/ephemeron.mli
@@ -15,14 +15,12 @@
 
 (** Ephemerons and weak hash table *)
 
-(** Ephemerons and weak hash table
-
-    Ephemerons and weak hash table are useful when one wants to cache
+(** Ephemerons and weak hash table are useful when one wants to cache
     or memorize the computation of a function, as long as the
     arguments and the function are used, without creating memory leaks
     by continuously keeping old computation results that are not
     useful anymore because one argument or the function is freed. An
-    implementation using {Hashtbl.t} is not suitable because all
+    implementation using {!Hashtbl.t} is not suitable because all
     associations would keep in memory the arguments and the result.
 
     Ephemerons can also be used for "adding" a field to an arbitrary

diff --git a/stdlib/format.ml b/stdlib/format.ml
index 8caa18f5a36824d38bb1ab59ed5576b2f66a7349..e02ffae1f22b90000007046e5151db3ca54343d0 100644 (file)
--- a/stdlib/format.ml
+++ b/stdlib/format.ml
@@ -31,15 +31,15 @@ external int_of_size : size -> int = "%identity"
 
 (* The pretty-printing boxes definition:
    a pretty-printing box is either
-   - hbox: horizontal (no split in the line)
-   - vbox: vertical (the line is splitted at every break hint)
-   - hvbox: horizontal/vertical
+   - hbox: horizontal box (no line splitting)
+   - vbox: vertical box (every break hint splits the line)
+   - hvbox: horizontal/vertical box
      (the box behaves as an horizontal box if it fits on
       the current line, otherwise the box behaves as a vertical box)
-   - hovbox: horizontal or vertical
-     (the box is compacting material, printing as much material on every
-     lines)
-   - box: horizontal or vertical with box enhanced structure
+   - hovbox: horizontal or vertical compacting box
+     (the box is compacting material, printing as much material as possible
+      on every lines)
+   - box: horizontal or vertical compacting box with enhanced box structure
      (the box behaves as an horizontal or vertical box but break hints split
       the line if splitting would move to the left)
 *)
@@ -63,7 +63,7 @@ type pp_token =
   | Pp_if_newline              (* to do something only if this very
                                   line has been broken *)
   | Pp_open_tag of tag         (* opening a tag name *)
-  | Pp_close_tag               (* closing the most recently opened tag *)
+  | Pp_close_tag               (* closing the most recently open tag *)
 
 and tag = string
 
@@ -164,9 +164,9 @@ type formatter = {
   mutable pp_left_total : int;
   (* Total width of tokens ever put in queue. *)
   mutable pp_right_total : int;
-  (* Current number of opened boxes. *)
+  (* Current number of open boxes. *)
   mutable pp_curr_depth : int;
-  (* Maximum number of boxes which can be simultaneously opened. *)
+  (* Maximum number of boxes which can be simultaneously open. *)
   mutable pp_max_boxes : int;
   (* Ellipsis string. *)
   mutable pp_ellipsis : string;
@@ -176,8 +176,10 @@ type formatter = {
   mutable pp_out_flush : unit -> unit;
   (* Output of new lines. *)
   mutable pp_out_newline : unit -> unit;
-  (* Output of indentation spaces. *)
+  (* Output of break hints spaces. *)
   mutable pp_out_spaces : int -> unit;
+  (* Output of indentation of new lines. *)
+  mutable pp_out_indent : int -> unit;
   (* Are tags printed ? *)
   mutable pp_print_tags : bool;
   (* Are tags marked ? *)
@@ -207,6 +209,7 @@ type formatter_out_functions = {
   out_flush : unit -> unit;
   out_newline : unit -> unit;
   out_spaces : int -> unit;
+  out_indent : int -> unit;
 }
 
 
@@ -284,6 +287,7 @@ let pp_infinity = 1000000010
 let pp_output_string state s = state.pp_out_string s 0 (String.length s)
 and pp_output_newline state = state.pp_out_newline ()
 and pp_output_spaces state n = state.pp_out_spaces n
+and pp_output_indent state n = state.pp_out_indent n
 
 (* To format a break, indenting a new line. *)
 let break_new_line state offset width =
@@ -294,7 +298,7 @@ let break_new_line state offset width =
   let real_indent = min state.pp_max_indent indent in
   state.pp_current_indent <- real_indent;
   state.pp_space_left <- state.pp_margin - state.pp_current_indent;
-  pp_output_spaces state state.pp_current_indent
+  pp_output_indent state state.pp_current_indent
 
 
 (* To force a line break inside a box: no offset is added. *)
@@ -380,7 +384,7 @@ let format_pp_token state size = function
         | [] -> [n]
         | x :: l as ls -> if n < x then n :: ls else x :: add_tab n l in
       tabs := add_tab (state.pp_margin - state.pp_space_left) !tabs
-    | [] -> () (* No opened tabulation box. *)
+    | [] -> () (* No open tabulation box. *)
     end
 
   | Pp_tbreak (n, off) ->
@@ -402,13 +406,13 @@ let format_pp_token state size = function
       if offset >= 0
       then break_same_line state (offset + n)
       else break_new_line state (tab + off) state.pp_margin
-    | [] -> () (* No opened tabulation box. *)
+    | [] -> () (* No open tabulation box. *)
     end
 
   | Pp_newline ->
     begin match state.pp_format_stack with
     | Format_elem (_, width) :: _ -> break_line state width
-    | [] -> pp_output_newline state (* No opened box. *)
+    | [] -> pp_output_newline state (* No open box. *)
     end
 
   | Pp_if_newline ->
@@ -437,7 +441,7 @@ let format_pp_token state size = function
       | Pp_vbox -> break_new_line state off width
       | Pp_hbox -> break_same_line state n
       end
-    | [] -> () (* No opened box. *)
+    | [] -> () (* No open box. *)
     end
 
    | Pp_open_tag tag_name ->
@@ -575,7 +579,7 @@ let pp_open_box_gen state indent br_ty =
   then enqueue_string state state.pp_ellipsis
 
 
-(* The box which is always opened. *)
+(* The box which is always open. *)
 let pp_open_sys_box state = pp_open_box_gen state 0 Pp_hovbox
 
 (* Close a box, setting sizes of its sub boxes. *)
@@ -667,9 +671,15 @@ let pp_rinit state =
   state.pp_space_left <- state.pp_margin;
   pp_open_sys_box state
 
+let clear_tag_stack state =
+  List.iter
+    (fun _ -> pp_close_tag state ())
+    state.pp_tag_stack
+
 
 (* Flushing pretty-printer queue. *)
 let pp_flush_queue state b =
+  clear_tag_stack state;
   while state.pp_curr_depth > 1 do
     pp_close_box state ()
   done;
@@ -678,7 +688,6 @@ let pp_flush_queue state b =
   if b then pp_output_newline state;
   pp_rinit state
 
-
 (*
 
   Procedures to format values and use boxes.
@@ -722,9 +731,14 @@ and pp_open_hovbox state indent = pp_open_box_gen state indent Pp_hovbox
 and pp_open_box state indent = pp_open_box_gen state indent Pp_box
 
 
-(* Printing all queued text.
-   [print_newline] prints a new line after flushing the queue.
-   [print_flush] on flush the queue without adding a newline. *)
+(* Printing queued text.
+
+   [pp_print_flush] prints all pending items in the pretty-printer queue and
+   then flushes the low level output device of the formatter to actually
+   display printing material.
+
+   [pp_print_newline] behaves as [pp_print_flush] after printing an additional
+   new line. *)
 let pp_print_newline state () =
   pp_flush_queue state true; state.pp_out_flush ()
 and pp_print_flush state () =
@@ -873,18 +887,20 @@ let pp_set_formatter_out_functions state {
       out_flush = g;
       out_newline = h;
       out_spaces = i;
+      out_indent = j;
     } =
   state.pp_out_string <- f;
   state.pp_out_flush <- g;
   state.pp_out_newline <- h;
-  state.pp_out_spaces <- i
-
+  state.pp_out_spaces <- i;
+  state.pp_out_indent <- j
 
 let pp_get_formatter_out_functions state () = {
   out_string = state.pp_out_string;
   out_flush = state.pp_out_flush;
   out_newline = state.pp_out_newline;
   out_spaces = state.pp_out_spaces;
+  out_indent = state.pp_out_indent;
 }
 
 
@@ -896,9 +912,6 @@ let pp_get_formatter_output_functions state () =
   (state.pp_out_string, state.pp_out_flush)
 
 
-let pp_flush_formatter state =
-  pp_flush_queue state false
-
 (* The default function to output new lines. *)
 let display_newline state () = state.pp_out_string "\n" 0  1
 
@@ -913,14 +926,17 @@ let rec display_blanks state n =
   end
 
 
+(* The default function to output indentation of new lines. *)
+let display_indent = display_blanks
+
 (* Setting a formatter basic output functions as printing to a given
    [Pervasive.out_channel] value. *)
-let pp_set_formatter_out_channel state os =
-  state.pp_out_string <- output_substring os;
-  state.pp_out_flush <- (fun () -> flush os);
+let pp_set_formatter_out_channel state oc =
+  state.pp_out_string <- output_substring oc;
+  state.pp_out_flush <- (fun () -> flush oc);
   state.pp_out_newline <- display_newline state;
-  state.pp_out_spaces <- display_blanks state
-
+  state.pp_out_spaces <- display_blanks state;
+  state.pp_out_indent <- display_indent state
 
 (*
 
@@ -934,9 +950,9 @@ let default_pp_mark_close_tag s = "</" ^ s ^ ">"
 let default_pp_print_open_tag = ignore
 let default_pp_print_close_tag = ignore
 
-(* Bulding a formatter given its basic output functions.
+(* Building a formatter given its basic output functions.
    Other fields get reasonable default values. *)
-let pp_make_formatter f g h i =
+let pp_make_formatter f g h i j =
   (* The initial state of the formatter contains a dummy box. *)
   let pp_queue = make_queue () in
   let sys_tok =
@@ -967,6 +983,7 @@ let pp_make_formatter f g h i =
     pp_out_flush = g;
     pp_out_newline = h;
     pp_out_spaces = i;
+    pp_out_indent = j;
     pp_print_tags = false;
     pp_mark_tags = false;
     pp_mark_open_tag = default_pp_mark_open_tag;
@@ -977,11 +994,23 @@ let pp_make_formatter f g h i =
   }
 
 
-(* Make a formatter with default functions to output spaces and new lines. *)
+(* Build a formatter out of its out functions. *)
+let formatter_of_out_functions out_funs =
+  pp_make_formatter
+    out_funs.out_string
+    out_funs.out_flush
+    out_funs.out_newline
+    out_funs.out_spaces
+    out_funs.out_indent
+
+
+(* Make a formatter with default functions to output spaces,
+  indentation, and new lines. *)
 let make_formatter output flush =
-  let ppf = pp_make_formatter output flush ignore ignore in
+  let ppf = pp_make_formatter output flush ignore ignore ignore in
   ppf.pp_out_newline <- display_newline ppf;
   ppf.pp_out_spaces <- display_blanks ppf;
+  ppf.pp_out_indent <- display_indent ppf;
   ppf
 
 
@@ -1012,7 +1041,7 @@ and str_formatter = formatter_of_buffer stdbuf
 
 
 (* [flush_buffer_formatter buf ppf] flushes formatter [ppf],
-   then return the contents of buffer [buff] thst is reset.
+   then returns the contents of buffer [buf] that is reset.
    Formatter [ppf] is supposed to print to buffer [buf], otherwise this
    function is not really useful. *)
 let flush_buffer_formatter buf ppf =
@@ -1025,6 +1054,66 @@ let flush_buffer_formatter buf ppf =
 (* Flush [str_formatter] and get the contents of [stdbuf]. *)
 let flush_str_formatter () = flush_buffer_formatter stdbuf str_formatter
 
+(*
+  Symbolic pretty-printing
+*)
+
+(*
+  Symbolic pretty-printing is pretty-printing with no low level output.
+
+  When using a symbolic formatter, all regular pretty-printing activities
+  occur but output material is symbolic and stored in a buffer of output
+  items. At the end of pretty-printing, flushing the output buffer allows
+  post-processing of symbolic output before low level output operations.
+*)
+
+type symbolic_output_item =
+  | Output_flush
+  | Output_newline
+  | Output_string of string
+  | Output_spaces of int
+  | Output_indent of int
+
+type symbolic_output_buffer = {
+  mutable symbolic_output_contents : symbolic_output_item list;
+}
+
+let make_symbolic_output_buffer () =
+  { symbolic_output_contents = [] }
+
+let clear_symbolic_output_buffer sob =
+  sob.symbolic_output_contents <- []
+
+let get_symbolic_output_buffer sob =
+  List.rev sob.symbolic_output_contents
+
+let flush_symbolic_output_buffer sob =
+  let items = get_symbolic_output_buffer sob in
+  clear_symbolic_output_buffer sob;
+  items
+
+let add_symbolic_output_item sob item =
+  sob.symbolic_output_contents <- item :: sob.symbolic_output_contents
+
+let formatter_of_symbolic_output_buffer sob =
+  let symbolic_flush sob () =
+    add_symbolic_output_item sob Output_flush
+  and symbolic_newline sob () =
+    add_symbolic_output_item sob Output_newline
+  and symbolic_string sob s i n =
+    add_symbolic_output_item sob (Output_string (String.sub s i n))
+  and symbolic_spaces sob n =
+    add_symbolic_output_item sob (Output_spaces n)
+  and symbolic_indent sob n =
+    add_symbolic_output_item sob (Output_indent n) in
+
+  let f = symbolic_string sob
+  and g = symbolic_flush sob
+  and h = symbolic_newline sob
+  and i = symbolic_spaces sob
+  and j = symbolic_indent sob in
+  pp_make_formatter f g h i j
+
 (*
 
   Basic functions on the 'standard' formatter
@@ -1295,7 +1384,6 @@ let pp_set_all_formatter_output_functions state
   state.pp_out_newline <- h;
   state.pp_out_spaces <- i
 
-
 (* Deprecated : subsumed by pp_get_formatter_out_functions *)
 let pp_get_all_formatter_output_functions state () =
   (state.pp_out_string, state.pp_out_flush,
@@ -1313,10 +1401,12 @@ let get_all_formatter_output_functions =
 
 
 (* Deprecated : error prone function, do not use it.
-   Define a formatter of your own writing to the buffer,
-   as in
+   This function is neither compositional nor incremental, since it flushes
+   the pretty-printer queue at each call.
+   To get the same functionality, define a formatter of your own writing to
+   the buffer argument, as in
    let ppf = formatter_of_buffer b
-   then use {!fprintf ppf} as useual. *)
+   then use {!fprintf ppf} as usual. *)
 let bprintf b (Format (fmt, _) : ('a, formatter, unit) format) =
   let k ppf acc = output_acc ppf acc; pp_flush_queue ppf false in
   make_printf k (formatter_of_buffer b) End_of_acc fmt

diff --git a/stdlib/format.mli b/stdlib/format.mli
index 7ff5fda2cb39320968a70b6b30ed85284762106f..404118b69e05f24994f04ed4890db3049bdfc99f 100644 (file)
--- a/stdlib/format.mli
+++ b/stdlib/format.mli
@@ -13,13 +13,35 @@
 (*                                                                        *)
 (**************************************************************************)
 
-(** Pretty printing.
+(** Pretty-printing.
 
    This module implements a pretty-printing facility to format values
-   within 'pretty-printing boxes'. The pretty-printer splits lines
-   at specified break hints, and indents lines according to the box
-   structure.
+   within {{!boxes}'pretty-printing boxes'} and {{!tags}'semantic tags'}
+   combined with a set of {{!fpp}printf-like functions}.
+   The pretty-printer splits lines at specified {{!breaks}break hints},
+   and indents lines according to the box structure.
+   Similarly, {{!tags}semantic tags} can be used to decouple text
+   presentation from its contents.
+
+   This pretty-printing facility is implemented as an overlay on top of
+   abstract {{!section:formatter}formatters} which provide basic output
+   functions.
+   Some formatters are predefined, notably:
+   - {!std_formatter} outputs to {{!Pervasives.stdout}stdout}
+   - {!err_formatter} outputs to {{!Pervasives.stderr}stderr}
+
+   Most functions in the {!Format} module come in two variants:
+   a short version that operates on {!std_formatter} and the
+   generic version prefixed by [pp_] that takes a formatter
+   as its first argument.
+
+   More formatters can be created with {!formatter_of_out_channel},
+   {!formatter_of_buffer}, {!formatter_of_symbolic_output_buffer}
+   or using {{!section:formatter}custom formatters}.
 
+*)
+
+(** {1 Introduction}
    For a gentle introduction to the basics of pretty-printing using
    [Format], read
    {{:http://caml.inria.fr/resources/doc/guides/format.en.html}
@@ -27,14 +49,14 @@
 
    You may consider this module as providing an extension to the
    [printf] facility to provide automatic line splitting. The addition of
-   pretty-printing annotations to your regular [printf] formats gives you
-   fancy indentation and line breaks.
+   pretty-printing annotations to your regular [printf] format strings gives
+   you fancy indentation and line breaks.
    Pretty-printing annotations are described below in the documentation of
    the function {!Format.fprintf}.
 
-   You may also use the explicit box management and printing functions
-   provided by this module. This style is more basic but more verbose
-   than the [fprintf] concise formats.
+   You may also use the explicit pretty-printing box management and printing
+   functions provided by this module. This style is more basic but more
+   verbose than the concise [fprintf] format strings.
 
    For instance, the sequence
    [open_box 0; print_string "x ="; print_space ();
@@ -44,83 +66,184 @@
    [printf "@[x =@ %i@]@." 1].
 
    Rule of thumb for casual users of this library:
- - use simple boxes (as obtained by [open_box 0]);
- - use simple break hints (as obtained by [print_cut ()] that outputs a
+ - use simple pretty-printing boxes (as obtained by [open_box 0]);
+ - use simple break hints as obtained by [print_cut ()] that outputs a
    simple break hint, or by [print_space ()] that outputs a space
-   indicating a break hint);
- - once a box is opened, display its material with basic printing
-   functions (e. g. [print_int] and [print_string]);
- - when the material for a box has been printed, call [close_box ()] to
-   close the box;
- - at the end of your routine, flush the pretty-printer to display all the
-   remaining material, e.g. evaluate [print_newline ()].
-
-   The behaviour of pretty-printing commands is unspecified
-   if there is no opened pretty-printing box. Each box opened via
+   indicating a break hint;
+ - once a pretty-printing box is open, display its material with basic
+   printing functions (e. g. [print_int] and [print_string]);
+ - when the material for a pretty-printing box has been printed, call
+   [close_box ()] to close the box;
+ - at the end of pretty-printing, flush the pretty-printer to display all
+   the remaining material, e.g. evaluate [print_newline ()].
+
+   The behavior of pretty-printing commands is unspecified
+   if there is no open pretty-printing box. Each box opened by
    one of the [open_] functions below must be closed using [close_box]
    for proper formatting. Otherwise, some of the material printed in the
    boxes may not be output, or may be formatted incorrectly.
 
-   In case of interactive use, the system closes all opened boxes and
-   flushes all pending text (as with the [print_newline] function)
-   after each phrase. Each phrase is therefore executed in the initial
-   state of the pretty-printer.
+   In case of interactive use, each phrase is executed in the initial state
+   of the standard pretty-printer: after each phrase execution, the
+   interactive system closes all open pretty-printing boxes, flushes all
+   pending text, and resets the standard pretty-printer.
+
+   Warning: mixing calls to pretty-printing functions of this module with
+   calls to {!Pervasives} low level output functions is error prone.
+
+   The pretty-printing functions output material that is delayed in the
+   pretty-printer queue and stacks in order to compute proper line
+   splitting. In contrast, basic I/O output functions write directly in
+   their output device. As a consequence, the output of a basic I/O function
+   may appear before the output of a pretty-printing function that has been
+   called before. For instance,
+   [
+    Pervasives.print_string "<";
+    Format.print_string "PRETTY";
+    Pervasives.print_string ">";
+    Format.print_string "TEXT";
+   ]
+   leads to output [<>PRETTYTEXT].
 
-   Warning: the material output by the following functions is delayed
-   in the pretty-printer queue in order to compute the proper line
-   splitting. Hence, you should not mix calls to the printing functions
-   of the basic I/O system with calls to the functions of this module:
-   this could result in some strange output seemingly unrelated with
-   the evaluation order of printing commands.
 *)
 
-(** {6 Boxes} *)
+type formatter
+(** Abstract data corresponding to a pretty-printer (also called a
+    formatter) and all its machinery. See also {!section:formatter}. *)
+
+(** {1:boxes Pretty-printing boxes} *)
+
+(** The pretty-printing engine uses the concepts of pretty-printing box and
+  break hint to drive indentation and line splitting behavior of the
+  pretty-printer.
+
+  Each different pretty-printing box kind introduces a specific line splitting
+  policy:
+
+  - within an {e horizontal} box, break hints never split the line (but the
+    line may be split in a box nested deeper),
+  - within a {e vertical} box, break hints always split the line,
+  - within an {e horizontal/vertical} box, if the box fits on the current line
+    then break hints never split the line, otherwise break hint always split
+    the line,
+  - within a {e compacting} box, a break hint never splits the line,
+    unless there is no more room on the current line.
+
+  Note that line splitting policy is box specific: the policy of a box does
+  not rule the policy of inner boxes. For instance, if a vertical box is
+  nested in an horizontal box, all break hints within the vertical box will
+  split the line.
+*)
 
+val pp_open_box : formatter -> int -> unit
 val open_box : int -> unit
-(** [open_box d] opens a new pretty-printing box
-   with offset [d].
+(** [pp_open_box ppf d] opens a new compacting pretty-printing box with
+    offset [d] in the formatter [ppf].
 
-   This box prints material as much as possible on every line.
+   Within this box, the pretty-printer prints as much as possible material on
+   every line.
 
    A break hint splits the line if there is no more room on the line to
    print the remainder of the box.
-   A break hint also splits the line if the splitting ``moves to the left''
-   (i.e. it gives an indentation smaller than the one of the current line).
+
+   Within this box, the pretty-printer emphasizes the box structure: a break
+   hint also splits the line if the splitting ``moves to the left''
+   (i.e. the new line gets an indentation smaller than the one of the current
+   line).
 
    This box is the general purpose pretty-printing box.
 
    If the pretty-printer splits the line in the box, offset [d] is added to
-   the current indentation. *)
+   the current indentation.
+*)
 
+
+val pp_close_box : formatter -> unit -> unit
 val close_box : unit -> unit
-(** Closes the most recently opened pretty-printing box. *)
+(** Closes the most recently open pretty-printing box. *)
+
+val pp_open_hbox : formatter -> unit -> unit
+val open_hbox : unit -> unit
+(** [pp_open_hbox ppf ()] opens a new 'horizontal' pretty-printing box.
+
+  This box prints material on a single line.
+
+  Break hints in a horizontal box never split the line.
+  (Line splitting may still occur inside boxes nested deeper).
+*)
+
+val pp_open_vbox : formatter -> int -> unit
+val open_vbox : int -> unit
+(** [pp_open_vbox ppf d] opens a new 'vertical' pretty-printing box
+  with offset [d].
+
+  This box prints material on as many lines as break hints in the box.
+
+  Every break hint in a vertical box splits the line.
+
+  If the pretty-printer splits the line in the box, [d] is added to the
+  current indentation.
+*)
+
+val pp_open_hvbox : formatter -> int -> unit
+val open_hvbox : int -> unit
+(** [pp_open_hvbox ppf d] opens a new 'horizontal/vertical' pretty-printing box
+  with offset [d].
+
+  This box behaves as an horizontal box if it fits on a single line,
+  otherwise it behaves as a vertical box.
 
-(** {6 Formatting functions} *)
+  If the pretty-printer splits the line in the box, [d] is added to the
+  current indentation.
+*)
 
+val pp_open_hovbox : formatter -> int -> unit
+val open_hovbox : int -> unit
+(** [pp_open_hovbox ppf d] opens a new 'horizontal-or-vertical'
+  pretty-printing box with offset [d].
+
+  This box prints material as much as possible on every line.
+
+  A break hint splits the line if there is no more room on the line to
+  print the remainder of the box.
+
+  If the pretty-printer splits the line in the box, [d] is added to the
+  current indentation.
+*)
+
+(** {1 Formatting functions} *)
+
+val pp_print_string : formatter -> string -> unit
 val print_string : string -> unit
-(** [print_string str] prints [str] in the current box. *)
+(** [pp_print_string ppf s] prints [s] in the current pretty-printing box. *)
 
+val pp_print_as : formatter -> 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]. *)
+(** [pp_print_as ppf len s] prints [s] in the current pretty-printing box.
+  The pretty-printer formats [s] as if it were of length [len].
+*)
 
+val pp_print_int : formatter -> int -> unit
 val print_int : int -> unit
-(** Prints an integer in the current box. *)
+(** Print an integer in the current pretty-printing box. *)
 
+val pp_print_float : formatter -> float -> unit
 val print_float : float -> unit
-(** Prints a floating point number in the current box. *)
+(** Print a floating point number in the current pretty-printing box. *)
 
+val pp_print_char : formatter -> char -> unit
 val print_char : char -> unit
-(** Prints a character in the current box. *)
+(** Print a character in the current pretty-printing box. *)
 
+val pp_print_bool : formatter -> bool -> unit
 val print_bool : bool -> unit
-(** Prints a boolean in the current box. *)
+(** Print a boolean in the current pretty-printing box. *)
 
-(** {6 Break hints} *)
+(** {1:breaks Break hints} *)
 
 (** A 'break hint' tells the pretty-printer to output some space or split the
-  line whichever way is more appropriate to the current box splitting rules.
+  line whichever way is more appropriate to the current pretty-printing box
+  splitting rules.
 
   Break hints are used to separate printing items and are mandatory to let
   the pretty-printer correctly split lines and indent items.
@@ -130,236 +253,385 @@ val print_bool : bool -> unit
   - the 'cut': split the line if appropriate.
 
   Note: the notions of space and line splitting are abstract for the
-  pretty-printing engine, since those notions can be completely defined
+  pretty-printing engine, since those notions can be completely redefined
   by the programmer.
   However, in the pretty-printer default setting, ``output a space'' simply
   means printing a space character (ASCII code 32) and ``split the line''
-  is printing a newline character (ASCII code 10).
-
+  means printing a newline character (ASCII code 10).
 *)
 
+val pp_print_space : formatter -> unit -> unit
 val print_space : unit -> unit
-(** [print_space ()] the 'space' break hint:
-  the pretty-printer may split the line at this
-  point, otherwise it prints one space.
-  It is equivalent to [print_break 1 0]. *)
+(** [pp_print_space ppf ()] emits a 'space' break hint:
+  the pretty-printer may split the line at this point,
+  otherwise it prints one space.
 
+  [pp_print_space ppf ()] is equivalent to [pp_print_break ppf 1 0].
+*)
+
+val pp_print_cut : formatter -> unit -> unit
 val print_cut : unit -> unit
-(** [print_cut ()] the 'cut' break hint:
-  the pretty-printer may split the line at this
-  point, otherwise it prints nothing.
-  It is equivalent to [print_break 0 0]. *)
+(** [pp_print_cut ppf ()] emits a 'cut' break hint:
+  the pretty-printer may split the line at this point,
+  otherwise it prints nothing.
 
+  [pp_print_cut ppf ()] is equivalent to [pp_print_break ppf 0 0].
+*)
+
+val pp_print_break : formatter -> int -> int -> unit
 val print_break : int -> int -> unit
-(** [print_break nspaces offset] the 'full' break hint:
-  the pretty-printer may split the line at this
-  point, otherwise it prints [nspaces] spaces.
+(** [pp_print_break ppf nspaces offset] emits a 'full' break hint:
+  the pretty-printer may split the line at this point,
+  otherwise it prints [nspaces] spaces.
 
   If the pretty-printer splits the line, [offset] is added to
   the current indentation.
 *)
 
-val print_flush : unit -> unit
-(** Flushes the pretty printer: all opened boxes are closed,
-  and all pending text is displayed. *)
+val pp_force_newline : formatter -> unit -> unit
+val force_newline : unit -> unit
+(** Force a new line in the current pretty-printing box.
 
-val print_newline : unit -> unit
-(** Equivalent to [print_flush] followed by a new line. *)
+  The pretty-printer must split the line at this point,
 
-val force_newline : unit -> unit
-(** Forces a new line in the current box.
-  Not the normal way of pretty-printing, since the new line does not reset
-  the current line count.
-  You should prefer using break hints within a vertcal box. *)
+  Not the normal way of pretty-printing, since imperative line splitting may
+  interfere with current line counters and box size calculation.
+  Using break hints within an enclosing vertical box is a better
+  alternative.
+*)
 
+val pp_print_if_newline : formatter -> unit -> unit
 val print_if_newline : unit -> unit
-(** Executes the next formatting command if the preceding line
+(** Execute the next formatting command if the preceding line
   has just been split. Otherwise, ignore the next formatting
-  command. *)
+  command.
+*)
 
-(** {6 Margin} *)
+(** {1 Pretty-printing termination} *)
 
+val pp_print_flush : formatter -> unit -> unit
+val print_flush : unit -> unit
+(** End of pretty-printing: resets the pretty-printer to initial state.
+
+  All open pretty-printing boxes are closed, all pending text is printed.
+  In addition, the pretty-printer low level output device is flushed to
+  ensure that all pending text is really displayed.
+
+  Note: never use [print_flush] in the normal course of a pretty-printing
+  routine, since the pretty-printer uses a complex buffering machinery to
+  properly indent the output; manually flushing those buffers at random
+  would conflict with the pretty-printer strategy and result to poor
+  rendering.
+
+  Only consider using [print_flush] when displaying all pending material is
+  mandatory (for instance in case of interactive use when you want the user
+  to read some text) and when resetting the pretty-printer state will not
+  disturb further pretty-printing.
+
+  Warning: If the output device of the pretty-printer is an output channel,
+  repeated calls to [print_flush] means repeated calls to {!Pervasives.flush}
+  to flush the out channel; these explicit flush calls could foil the
+  buffering strategy of output channels and could dramatically impact
+  efficiency.
+*)
+
+val pp_print_newline : formatter -> unit -> unit
+val print_newline : unit -> unit
+(** End of pretty-printing: resets the pretty-printer to initial state.
+
+  All open pretty-printing boxes are closed, all pending text is printed.
+
+  Equivalent to {!print_flush} followed by a new line.
+  See corresponding words of caution for {!print_flush}.
+
+  Note: this is not the normal way to output a new line;
+  the preferred method is using break hints within a vertical pretty-printing
+  box.
+*)
+
+(** {1 Margin} *)
+
+val pp_set_margin : formatter -> int -> unit
 val set_margin : int -> unit
-(** [set_margin d] sets the right margin to [d] (in characters):
+(** [pp_set_margin ppf d] sets the right margin to [d] (in characters):
   the pretty-printer splits lines that overflow the right margin according to
   the break hints given.
   Nothing happens if [d] is smaller than 2.
   If [d] is too large, the right margin is set to the maximum
-  admissible value (which is greater than [10^9]). *)
+  admissible value (which is greater than [10 ^ 9]).
+  If [d] is less than the current maximum indentation limit, the
+  maximum indentation limit is decreased while trying to preserve
+  a minimal ratio [max_indent/margin>=50%] and if possible
+  the current difference [margin - max_indent].
+*)
 
+val pp_get_margin : formatter -> unit -> int
 val get_margin : unit -> int
 (** Returns the position of the right margin. *)
 
-(** {6 Maximum indentation limit} *)
+(** {1 Maximum indentation limit} *)
 
+val pp_set_max_indent : formatter -> int -> unit
 val set_max_indent : int -> unit
-(** [set_max_indent d] sets the maximum indentation limit of lines to [d] (in
-  characters):
-  once this limit is reached, new boxes are rejected to the left,
-  if they do not fit on the current line.
+(** [pp_set_max_indent ppf d] sets the maximum indentation limit of lines
+  to [d] (in characters):
+  once this limit is reached, new pretty-printing boxes are rejected to the
+  left, if they do not fit on the current line.
+
   Nothing happens if [d] is smaller than 2.
   If [d] is too large, the limit is set to the maximum
-  admissible value (which is greater than [10 ^ 9]). *)
+  admissible value (which is greater than [10 ^ 9]).
+
+  If [d] is greater or equal than the current margin, it is ignored,
+  and the current maximum indentation limit is kept.
+*)
 
+val pp_get_max_indent : formatter -> unit -> int
 val get_max_indent : unit -> int
 (** Return the maximum indentation limit (in characters). *)
 
-(** {6 Formatting depth: maximum number of boxes allowed before ellipsis} *)
+(** {1 Maximum formatting depth} *)
+
+(** The maximum formatting depth is the maximum number of pretty-printing
+  boxes simultaneously open.
 
+  Material inside boxes nested deeper is printed as an ellipsis (more
+  precisely as the text returned by {!get_ellipsis_text} [()]).
+*)
+
+val pp_set_max_boxes : formatter -> int -> unit
 val set_max_boxes : int -> unit
-(** [set_max_boxes max] sets the maximum number of boxes simultaneously
-  opened.
+(** [pp_set_max_boxes ppf max] sets the maximum number of pretty-printing
+    boxes simultaneously open.
+
   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. *)
+  precisely as the text returned by {!get_ellipsis_text} [()]).
 
+  Nothing happens if [max] is smaller than 2.
+*)
+
+val pp_get_max_boxes : formatter -> unit -> int
 val get_max_boxes : unit -> int
-(** Returns the maximum number of boxes allowed before ellipsis. *)
+(** Returns the maximum number of pretty-printing boxes allowed before
+  ellipsis.
+*)
 
+val pp_over_max_boxes : formatter -> unit -> bool
 val over_max_boxes : unit -> bool
-(** Tests if the maximum number of boxes allowed have already been opened. *)
+(** Tests if the maximum number of pretty-printing boxes allowed have already
+  been opened.
+*)
 
-(** {6 Advanced formatting} *)
+(** {1 Tabulation boxes} *)
 
-val open_hbox : unit -> unit
-(** [open_hbox ()] opens a new 'horizontal' pretty-printing box.
+(**
 
-  This box prints material on a single line.
+  A {e tabulation box} prints material on lines divided into cells of fixed
+  length. A tabulation box provides a simple way to display vertical columns
+  of left adjusted text.
 
-  Break hints in a horizontal box never split the line.
-  (Line splitting may still occur inside boxes nested deeper). *)
+  This box features command [set_tab] to define cell boundaries, and command
+  [print_tab] to move from cell to cell and split the line when there is no
+  more cells to print on the line.
 
-val open_vbox : int -> unit
-(** [open_vbox d] opens a new 'vertical' pretty-printing box
-  with offset [d].
+  Note: printing within tabulation box is line directed, so arbitrary line
+  splitting inside a tabulation box leads to poor rendering. Yet, controlled
+  use of tabulation boxes allows simple printing of columns within
+  module {!Format}.
+*)
 
-  This box prints material on as many lines as break hints in the box.
+val pp_open_tbox : formatter -> unit -> unit
+val open_tbox : unit -> unit
+(** [open_tbox ()] opens a new tabulation box.
 
-  Every break hint in a vertical box splits the line.
+  This box prints lines separated into cells of fixed width.
 
-  If the pretty-printer splits the line in the box, [d] is added to the
-  current indentation. *)
+  Inside a tabulation box, special {e tabulation markers} defines points of
+  interest on the line (for instance to delimit cell boundaries).
+  Function {!Format.set_tab} sets a tabulation marker at insertion point.
 
-val open_hvbox : int -> unit
-(** [open_hvbox d] opens a new 'horizontal-vertical' pretty-printing box
-  with offset [d].
+  A tabulation box features specific {e tabulation breaks} to move to next
+  tabulation marker or split the line. Function {!Format.print_tbreak} prints
+  a tabulation break.
+*)
 
-  This box behaves as an horizontal box if it fits on a single line,
-  otherwise it behaves as a vertical box.
+val pp_close_tbox : formatter -> unit -> unit
+val close_tbox : unit -> unit
+(** Closes the most recently opened tabulation box. *)
 
-  If the pretty-printer splits the line in the box, [d] is added to the
-  current indentation. *)
+val pp_set_tab : formatter -> unit -> unit
+val set_tab : unit -> unit
+(** Sets a tabulation marker at current insertion point. *)
 
-val open_hovbox : int -> unit
-(** [open_hovbox d] opens a new 'horizontal-or-vertical' pretty-printing box
-  with offset [d].
+val pp_print_tab : formatter -> unit -> unit
+val print_tab : unit -> unit
+(** [print_tab ()] emits a 'next' tabulation break hint: if not already set on
+  a tabulation marker, the insertion point moves to the first tabulation
+  marker on the right, or the pretty-printer splits the line and insertion
+  point moves to the leftmost tabulation marker.
 
-  This box prints material as much as possible on every line.
+  It is equivalent to [print_tbreak 0 0]. *)
 
-  A break hint splits the line if there is no more room on the line to
-  print the remainder of the box.
+val pp_print_tbreak : formatter -> int -> int -> unit
+val print_tbreak : int -> int -> unit
+(** [print_tbreak nspaces offset] emits a 'full' tabulation break hint.
 
-  If the pretty-printer splits the line in the box, [d] is added to the
-  current indentation. *)
+  If not already set on a tabulation marker, the insertion point moves to the
+  first tabulation marker on the right and the pretty-printer prints
+  [nspaces] spaces.
 
-(** {6 Ellipsis} *)
+  If there is no next tabulation marker on the right, the pretty-printer
+  splits the line at this point, then insertion point moves to the leftmost
+  tabulation marker of the box.
 
+  If the pretty-printer splits the line, [offset] is added to
+  the current indentation.
+*)
+
+(** {1 Ellipsis} *)
+
+val pp_set_ellipsis_text : formatter -> 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). *)
+(** Set the text of the ellipsis printed when too many pretty-printing boxes
+  are open (a single dot, [.], by default).
+*)
 
+val pp_get_ellipsis_text : formatter -> unit -> string
 val get_ellipsis_text : unit -> string
 (** Return the text of the ellipsis. *)
 
-(** {6:tags Semantic Tags} *)
+(** {1:tags Semantic tags} *)
 
 type tag = string
 
-(** {i Semantic tags} (or simply {e tags}) are used to decorate printed
-  entities for user's defined purposes, e.g. setting font and giving size
-  indications for a display device, or marking delimitation of semantic
-  entities (e.g. HTML or TeX elements or terminal escape sequences).
-
-  By default, those tags do not influence line splitting calculation:
-  the tag 'markers' are not considered as part of the printing
-  material that drives line splitting (in other words, the length of
-  those strings is considered as zero for line splitting).
+(** {i Semantic tags} (or simply {e tags}) are user's defined delimiters
+  to associate user's specific operations to printed entities.
 
-  Thus, tag handling is in some sense transparent to pretty-printing
-  and does not interfere with usual indentation. Hence, a single
-  pretty printing routine can output both simple 'verbatim'
-  material or richer decorated output depending on the treatment of
-  tags. By default, tags are not active, hence the output is not
-  decorated with tag information. Once [set_tags] is set to [true],
-  the pretty printer engine honours tags and decorates the output
-  accordingly.
-
-  When a tag has been opened (or closed), it is both and successively
-  'printed' and 'marked'. Printing a tag means calling a
-  formatter specific function with the name of the tag as argument:
-  that 'tag printing' function can then print any regular material
+  Common usage of semantic tags is text decoration to get specific font or
+  text size rendering for a display device, or marking delimitation of
+  entities (e.g. HTML or TeX elements or terminal escape sequences).
+  More sophisticated usage of semantic tags could handle dynamic
+  modification of the pretty-printer behavior to properly print the material
+  within some specific tags.
+
+  In order to properly delimit printed entities, a semantic tag must be
+  opened before and closed after the entity. Semantic tags must be properly
+  nested like parentheses.
+
+  Tag specific operations occur any time a tag is opened or closed, At each
+  occurrence, two kinds of operations are performed {e tag-marking} and
+  {e tag-printing}:
+- The tag-marking operation is the simpler tag specific operation: it simply
+  writes a tag specific string into the output device of the
+  formatter. Tag-marking does not interfere with line-splitting computation.
+- The tag-printing operation is the more involved tag specific operation: it
+  can print arbitrary material to the formatter. Tag-printing is tightly
+  linked to the current pretty-printer operations.
+
+  Roughly speaking, tag-marking is commonly used to get a better rendering of
+  texts in the rendering device, while tag-printing allows fine tuning of
+  printing routines to print the same entity differently according to the
+  semantic tags (i.e. print additional material or even omit parts of the
+  output).
+
+  More precisely: when a semantic tag is opened or closed then both and
+  successive 'tag-printing' and 'tag-marking' operations occur:
+  - Tag-printing a semantic tag means calling the formatter specific function
+  [print_open_tag] (resp. [print_close_tag]) with the name of the tag as
+  argument: that tag-printing function can then print any regular material
   to the formatter (so that this material is enqueued as usual in the
-  formatter queue for further line splitting computation). Marking a
-  tag means to output an arbitrary string (the 'tag marker'),
-  directly into the output device of the formatter. Hence, the
-  formatter specific 'tag marking' function must return the tag
-  marker string associated to its tag argument. Being flushed
-  directly into the output device of the formatter, tag marker
-  strings are not considered as part of the printing material that
+  formatter queue for further line splitting computation).
+  - Tag-marking a semantic tag means calling the formatter specific function
+  [mark_open_tag] (resp. [mark_close_tag]) with the name of the tag as
+  argument: that tag-marking function can then return the 'tag-opening
+  marker' (resp. `tag-closing marker') for direct output into the output
+  device of the formatter.
+
+  Being written directly into the output device of the formatter, semantic
+  tag marker strings are not considered as part of the printing material that
   drives line splitting (in other words, the length of the strings
-  corresponding to tag markers is considered as zero for line
-  splitting). In addition, advanced users may take advantage of
-  the specificity of tag markers to be precisely output when the
-  pretty printer has already decided where to split the lines, and
-  precisely when the queue is flushed into the output device.
+  corresponding to tag markers is considered as zero for line splitting).
 
-  In the spirit of HTML tags, the default tag marking functions
-  output tags enclosed in "<" and ">": hence, the opening marker of
-  tag [t] is ["<t>"] and the closing marker ["</t>"].
+  Thus, semantic tag handling is in some sense transparent to pretty-printing
+  and does not interfere with usual indentation. Hence, a single
+  pretty-printing routine can output both simple 'verbatim' material or
+  richer decorated output depending on the treatment of tags. By default,
+  tags are not active, hence the output is not decorated with tag
+  information. Once [set_tags] is set to [true], the pretty-printer engine
+  honors tags and decorates the output accordingly.
+
+  Default tag-marking functions behave the HTML way: tags are enclosed in "<"
+  and ">"; hence, opening marker for tag [t] is ["<t>"] and closing marker is
+  ["</t>"].
 
-  Default tag printing functions just do nothing.
+  Default tag-printing functions just do nothing.
 
-  Tag marking and tag printing functions are user definable and can
-  be set by calling [set_formatter_tag_functions]. *)
+  Tag-marking and tag-printing functions are user definable and can
+  be set by calling {!set_formatter_tag_functions}.
 
+  Semantic tag operations may be set on or off with {!set_tags}.
+  Tag-marking operations may be set on or off with {!set_mark_tags}.
+  Tag-printing operations may be set on or off with {!set_print_tags}.
+*)
+
+val pp_open_tag : formatter -> string -> 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. *)
+(** [pp_open_tag ppf t] opens the semantic tag named [t].
 
+  The [print_open_tag] tag-printing function of the formatter is called with
+  [t] as argument; then the opening tag marker for [t], as given by
+  [mark_open_tag t], is written into the output device of the formatter.
+*)
+
+val pp_close_tag : formatter -> 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. *)
+(** [pp_close_tag ppf ()] closes the most recently opened semantic tag [t].
+
+  The closing tag marker, as given by [mark_close_tag t], is written into the
+  output device of the formatter; then the [print_close_tag] tag-printing
+  function of the formatter is called with [t] as argument.
+*)
 
+val pp_set_tags : formatter -> bool -> unit
 val set_tags : bool -> unit
-(** [set_tags b] turns on or off the treatment of tags (default is off). *)
+(** [pp_set_tags ppf b] turns on or off the treatment of semantic tags
+  (default is off).
+*)
 
+val pp_set_print_tags : formatter -> bool -> unit
 val set_print_tags : bool -> unit
-(** [set_print_tags b] turns on or off the printing of tags. *)
+(** [pp_set_print_tags ppf b] turns on or off the tag-printing operations. *)
 
+val pp_set_mark_tags : formatter -> bool -> unit
 val set_mark_tags : bool -> unit
-(** [set_mark_tags b] turns on or off the output of tag markers. *)
+(** [pp_set_mark_tags ppf b] turns on or off the tag-marking operations. *)
 
+val pp_get_print_tags : formatter -> unit -> bool
 val get_print_tags : unit -> bool
-(** Return the current status of tags printing. *)
+(** Return the current status of tag-printing operations. *)
 
+val pp_get_mark_tags : formatter -> unit -> bool
 val get_mark_tags : unit -> bool
-(** Return the current status of tags marking. *)
-
-(** {6 Redirecting the standard formatter output} *)
+(** Return the current status of tag-marking operations. *)
 
+(** {1 Redirecting the standard formatter output} *)
+val pp_set_formatter_out_channel :
+  formatter -> Pervasives.out_channel -> unit
 val set_formatter_out_channel : Pervasives.out_channel -> unit
-(** Redirect the pretty-printer output to the given channel.
+(** Redirect the standard 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.) *)
+   default output functions printing to the given channel.)
 
+  [set_formatter_out_channel] is equivalent to
+  {!pp_set_formatter_out_channel} [std_formatter].
+*)
+
+val pp_set_formatter_output_functions :
+  formatter -> (string -> int -> int -> unit) -> (unit -> unit) -> unit
 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
+(** [pp_set_formatter_output_functions ppf out flush] redirects the
+  standard pretty-printer output functions to the functions [out] and
   [flush].
 
   The [out] function performs all the pretty-printer string output.
@@ -369,51 +641,85 @@ val set_formatter_output_functions :
 
   The [flush] function is called whenever the pretty-printer is flushed
   (via conversion [%!], or pretty-printing indications [@?] or [@.], or
-  using low level functions [print_flush] or [print_newline]). *)
+  using low level functions [print_flush] or [print_newline]).
+*)
 
+val pp_get_formatter_output_functions :
+  formatter -> unit -> (string -> int -> int -> unit) * (unit -> unit)
 val get_formatter_output_functions :
   unit -> (string -> int -> int -> unit) * (unit -> unit)
-(** Return the current output functions of the pretty-printer. *)
+(** Return the current output functions of the standard pretty-printer. *)
 
-(** {6:meaning Changing the meaning of standard formatter pretty printing} *)
+(** {1:meaning Redefining formatter output} *)
 
 (** The [Format] module is versatile enough to let you completely redefine
-  the meaning of pretty printing: you may provide your own functions to define
-  how to handle indentation, line splitting, and even printing of all the
-  characters that have to be printed! *)
+  the meaning of pretty-printing output: you may provide your own functions
+  to define how to handle indentation, line splitting, and even printing of
+  all the characters that have to be printed!
+*)
+
+(** {2 Redefining output functions} *)
 
 type formatter_out_functions = {
   out_string : string -> int -> int -> unit;
   out_flush : unit -> unit;
   out_newline : unit -> unit;
   out_spaces : int -> unit;
-} (** @since 4.01.0 *)
+  out_indent : int -> unit;
+}
+(** The set of output functions specific to a formatter:
+- the [out_string] function performs all the pretty-printer string output.
+  It is called with a string [s], a start position [p], and a number of
+  characters [n]; it is supposed to output characters [p] to [p + n - 1] of
+  [s].
+- the [out_flush] function flushes the pretty-printer output device.
+- [out_newline] is called to open a new line when the pretty-printer splits
+  the line.
+- the [out_spaces] function outputs spaces when a break hint leads to spaces
+  instead of a line split. It is called with the number of spaces to output.
+- the [out_indent] function performs new line indentation when the
+  pretty-printer splits the line. It is called with the indentation value of
+  the new line.
+
+  By default:
+- fields [out_string] and [out_flush] are output device specific;
+  (e.g. {!Pervasives.output_string} and {!Pervasives.flush} for a
+   {!Pervasives.out_channel} device, or [Buffer.add_substring] and
+   {!Pervasives.ignore} for a [Buffer.t] output device),
+- field [out_newline] is equivalent to [out_string "\n" 0 1];
+- fields [out_spaces] and [out_indent] are equivalent to
+  [out_string (String.make n ' ') 0 n].
+  @since 4.01.0
+*)
 
+val pp_set_formatter_out_functions :
+  formatter -> 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
-  [set_formatter_output_functions]. In addition, the pretty-printer function
-  that outputs a newline is set to the function [f.out_newline] and
-  the function that outputs indentation spaces is set to the function
-  [f.out_spaces].
+(** [pp_set_formatter_out_functions ppf out_funs]
+  Set all the pretty-printer output functions of [ppf] to those of
+  argument [out_funs],
 
   This way, you can change the meaning of indentation (which can be
   something else than just printing space characters) and the meaning of new
   lines opening (which can be connected to any other action needed by the
-  application at hand). The two functions [f.out_spaces] and [f.out_newline]
-  are normally connected to [f.out_string] and [f.out_flush]: respective
-  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].
-  @since 4.01.0 *)
+  application at hand).
+
+  Reasonable defaults for functions [out_spaces] and [out_newline] are
+  respectively [out_funs.out_string (String.make n ' ') 0 n] and
+  [out_funs.out_string "\n" 0 1].
+  @since 4.01.0
+*)
 
+val pp_get_formatter_out_functions :
+  formatter -> unit -> formatter_out_functions
 val get_formatter_out_functions : unit -> formatter_out_functions
 (** Return the current output functions of the pretty-printer,
   including line splitting and indentation functions. Useful to record the
   current setting and restore it afterwards.
-  @since 4.01.0 *)
+  @since 4.01.0
+*)
 
-(** {6:tagsmeaning Changing the meaning of printing semantic tags} *)
+(** {1:tagsmeaning Redefining semantic tag operations} *)
 
 type formatter_tag_functions = {
   mark_open_tag : tag -> string;
@@ -421,185 +727,242 @@ 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
+(** The semantic 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 write
   those markers as 0 length tokens in the output device of the formatter.
-  [print] versions are the 'tag printing' functions that can perform
-  regular printing when a tag is closed or opened. *)
+  [print] versions are the 'tag-printing' functions that can perform
+  regular printing when a tag is closed or opened.
+*)
 
+val pp_set_formatter_tag_functions :
+  formatter -> 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].
+(** [pp_set_formatter_tag_functions ppf tag_funs] changes the meaning of
+  opening and closing semantic tag operations to use the functions in
+  [tag_funs] when printing on [ppf].
 
-  When opening a tag name [t], the string [t] is passed to the
-  opening tag marking function (the [mark_open_tag] field of the
+  When opening a semantic tag with name [t], the string [t] is passed to the
+  opening tag-marking function (the [mark_open_tag] field of the
   record [tag_funs]), that must return the opening tag marker for
-  that name. When the next call to [close_tag ()] happens, the tag
-  name [t] is sent back to the closing tag marking function (the
+  that name. When the next call to [close_tag ()] happens, the semantic tag
+  name [t] is sent back to the closing tag-marking function (the
   [mark_close_tag] field of record [tag_funs]), that must return a
   closing tag marker for that name.
 
-  The [print_] field of the record contains the functions that are
-  called at tag opening and tag closing time, to output regular
-  material in the pretty-printer queue. *)
+  The [print_] field of the record contains the tag-printing functions that
+  are called at tag opening and tag closing time, to output regular material
+  in the pretty-printer queue.
+*)
 
+val pp_get_formatter_tag_functions :
+  formatter -> 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
-(** Abstract data corresponding to a pretty-printer (also called a
-  formatter) and all its machinery.
-
-  Defining new pretty-printers permits unrelated output of material in
-  parallel on several output channels.
-  All the parameters of a pretty-printer are local to a formatter:
-  margin, maximum indentation limit, maximum number of boxes
-  simultaneously opened, ellipsis, and so on, are specific to
-  each pretty-printer and may be fixed independently.
-  Given a {!Pervasives.out_channel} output channel [oc], a new formatter
-  writing to that channel is simply obtained by calling
-  [formatter_of_out_channel oc].
-  Alternatively, the [make_formatter] function allocates a new
-  formatter with explicit output and flushing functions
-  (convenient to output material to strings for instance).
+(** Return the current semantic tag operation functions of the standard
+  pretty-printer. *)
+
+(** {1:formatter Defining formatters}
+
+  Defining new formatters permits unrelated output of material in
+  parallel on several output devices.
+  All the parameters of a formatter are local to the formatter:
+  right margin, maximum indentation limit, maximum number of pretty-printing
+  boxes simultaneously open, ellipsis, and so on, are specific to
+  each formatter and may be fixed independently.
+
+  For instance, given a {!Buffer.t} buffer [b], {!formatter_of_buffer} [b]
+  returns a new formatter using buffer [b] as its output device.
+  Similarly, given a {!Pervasives.out_channel} output channel [oc],
+  {!formatter_of_out_channel} [oc] returns a new formatter using
+  channel [oc] as its output device.
+
+  Alternatively, given [out_funs], a complete set of output functions for a
+  formatter, then {!formatter_of_out_functions} [out_funs] computes a new
+  formatter using those functions for output.
 *)
 
 val formatter_of_out_channel : out_channel -> formatter
-(** [formatter_of_out_channel oc] returns a new formatter that
-  writes to the corresponding channel [oc]. *)
+(** [formatter_of_out_channel oc] returns a new formatter writing
+  to the corresponding output channel [oc].
+*)
 
 val std_formatter : formatter
-(** The standard formatter used by the formatting functions
-  above. It is defined as [formatter_of_out_channel stdout]. *)
+(** The standard formatter to write to standard output.
+
+  It is defined as {!formatter_of_out_channel} {!Pervasives.stdout}.
+*)
 
 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]. *)
+(** A formatter to write to standard error.
+
+  It is defined as {!formatter_of_out_channel} {!Pervasives.stderr}.
+*)
 
 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. *)
+  buffer [b]. At the end of pretty-printing, the formatter must be flushed
+  using {!pp_print_flush} or {!pp_print_newline}, to print all the
+  pending material into the buffer.
+*)
 
 val stdbuf : Buffer.t
 (** The string buffer in which [str_formatter] writes. *)
 
 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]. *)
+(** A formatter to output to the {!stdbuf} string buffer.
+
+  [str_formatter] is defined as {!formatter_of_buffer} {!stdbuf}.
+*)
 
 val flush_str_formatter : unit -> string
 (** Returns the material printed with [str_formatter], flushes
-  the formatter and resets the corresponding buffer. *)
+  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
-  [make_formatter (Pervasives.output oc) (fun () -> Pervasives.flush oc)]. *)
+(** [make_formatter out flush] returns a new formatter that outputs with
+  function [out], and flushes with function [flush].
+
+  For instance, {[
+    make_formatter
+      (Pervasives.output oc)
+      (fun () -> Pervasives.flush oc) ]}
+  returns a formatter to the {!Pervasives.out_channel} [oc].
+*)
 
-(** {6 Basic functions to use with formatters} *)
+val formatter_of_out_functions :
+  formatter_out_functions -> formatter
+(** [formatter_of_out_functions out_funs] returns a new formatter that writes
+  with the set of output functions [out_funs].
 
-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_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
+  See definition of type {!formatter_out_functions} for the meaning of argument
+  [out_funs].
 
-val pp_set_formatter_output_functions :
-  formatter -> (string -> int -> int -> unit) -> (unit -> unit) -> unit
+  @since 4.06.0
+*)
 
-val pp_get_formatter_output_functions :
-  formatter -> unit -> (string -> int -> int -> unit) * (unit -> unit)
+(** {2:symbolic Symbolic pretty-printing} *)
 
-val pp_set_formatter_tag_functions :
-  formatter -> formatter_tag_functions -> unit
+(**
+  Symbolic pretty-printing is pretty-printing using a symbolic formatter,
+  i.e. a formatter that outputs symbolic pretty-printing items.
 
-val pp_get_formatter_tag_functions :
-  formatter -> unit -> formatter_tag_functions
+  When using a symbolic formatter, all regular pretty-printing activities
+  occur but output material is symbolic and stored in a buffer of output items.
+  At the end of pretty-printing, flushing the output buffer allows
+  post-processing of symbolic output before performing low level output
+  operations.
 
-val pp_set_formatter_out_functions :
-  formatter -> formatter_out_functions -> unit
-(** @since 4.01.0 *)
+  In practice, first define a symbolic output buffer [b] using:
+  - [let sob = make_symbolic_output_buffer ()].
+  Then define a symbolic formatter with:
+  - [let ppf = formatter_of_symbolic_output_buffer sob]
 
-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,
-   [print_string] is equal to [pp_print_string std_formatter].
-   @since 4.01.0 *)
+  Use symbolic formatter [ppf] as usual, and retrieve symbolic items at end
+  of pretty-printing by flushing symbolic output buffer [sob] with:
+  - [flush_symbolic_output_buffer sob].
+*)
+
+type symbolic_output_item =
+  | Output_flush (** symbolic flush command *)
+  | Output_newline (** symbolic newline command *)
+  | Output_string of string
+  (** [Output_string s]: symbolic output for string [s]*)
+  | Output_spaces of int
+  (** [Output_spaces n]: symbolic command to output [n] spaces *)
+  | Output_indent of int
+  (** [Output_indent i]: symbolic indentation of size [i] *)
+(** Items produced by symbolic pretty-printers
+    @since 4.06.0
+*)
+
+type symbolic_output_buffer
+(**
+  The output buffer of a symbolic pretty-printer.
+
+  @since 4.06.0
+*)
+
+val make_symbolic_output_buffer : unit -> symbolic_output_buffer
+(** [make_symbolic_output_buffer ()] returns a fresh buffer for
+  symbolic output.
+
+  @since 4.06.0
+*)
+
+val clear_symbolic_output_buffer : symbolic_output_buffer -> unit
+(** [clear_symbolic_output_buffer sob] resets buffer [sob].
+
+  @since 4.06.0
+*)
+
+val get_symbolic_output_buffer :
+  symbolic_output_buffer -> symbolic_output_item list
+(** [get_symbolic_output_buffer sob] returns the contents of buffer [sob].
+
+  @since 4.06.0
+*)
+
+val flush_symbolic_output_buffer :
+  symbolic_output_buffer -> symbolic_output_item list
+(** [flush_symbolic_output_buffer sob] returns the contents of buffer
+  [sob] and resets buffer [sob].
+  [flush_symbolic_output_buffer sob] is equivalent to
+  [let items = get_symbolic_output_buffer sob in
+   clear_symbolic_output_buffer sob; items]
+
+  @since 4.06.0
+*)
+
+val add_symbolic_output_item :
+  symbolic_output_buffer -> symbolic_output_item -> unit
+(** [add_symbolic_output_item sob itm] adds item [itm] to buffer [sob].
 
-val pp_flush_formatter : formatter -> unit
-(** [pp_flush_formatter fmt] flushes [fmt]'s internal queue, ensuring that all
-    the printing and flushing actions have been performed. In addition, this
-    operation will close all boxes and reset the state of the formatter.
+  @since 4.06.0
+*)
+
+val formatter_of_symbolic_output_buffer : symbolic_output_buffer -> formatter
+(** [formatter_of_symbolic_output_buffer sob] returns a symbolic formatter
+  that outputs to [symbolic_output_buffer] [sob].
 
-    This will not flush [fmt]'s output. In most cases, the user may want to use
-    {!pp_print_flush} instead.
-    @since 4.04.0 *)
+  @since 4.06.0
+*)
 
-(** {6 Convenience formatting functions.} *)
+(** {1 Convenience formatting functions.} *)
 
 val pp_print_list:
   ?pp_sep:(formatter -> unit -> unit) ->
   (formatter -> 'a -> unit) -> (formatter -> 'a list -> unit)
 (** [pp_print_list ?pp_sep pp_v ppf l] prints items of list [l],
   using [pp_v] to print each item, and calling [pp_sep]
-  between items ([pp_sep] defaults to {!pp_print_cut}).
+  between items ([pp_sep] defaults to {!pp_print_cut}.
   Does nothing on empty lists.
 
   @since 4.02.0
 *)
 
 val pp_print_text : formatter -> string -> unit
-(** [pp_print_text ppf s] prints [s] with spaces and newlines
-  respectively printed with {!pp_print_space} and
-  {!pp_force_newline}.
+(** [pp_print_text ppf s] prints [s] with spaces and newlines respectively
+  printed using {!pp_print_space} and {!pp_force_newline}.
 
   @since 4.02.0
 *)
 
-(** {6 [printf] like functions for pretty-printing.} *)
+(** {1:fpp Formatted pretty-printing} *)
+
+(**
+  Module [Format] provides a complete set of [printf] like functions for
+  pretty-printing using format string specifications.
+
+  Specific annotations may be added in the format strings to give
+  pretty-printing commands to the pretty-printing engine.
+
+  Those annotations are introduced in the format strings using the [@]
+  character. For instance, [@ ] means a space break, [@,] means a cut,
+  [@\[] opens a new box, and [@\]] closes the last open box.
+
+*)
 
 val fprintf : formatter -> ('a, formatter, unit) format -> 'a
 
@@ -607,7 +970,7 @@ val fprintf : formatter -> ('a, formatter, unit) format -> 'a
   according to the format string [fmt], and outputs the resulting string on
   the formatter [ff].
 
-  The format [fmt] is a character string which contains three types of
+  The format string [fmt] is a character string which contains three types of
   objects: plain characters and conversion specifications as specified in
   the {!Printf} module, and pretty-printing indications specific to the
   [Format] module.
@@ -618,15 +981,16 @@ val fprintf : formatter -> ('a, formatter, unit) format -> 'a
     box may be optionally specified with the following syntax:
     the [<] character, followed by an optional box type indication,
     then an optional integer offset, and the closing [>] character.
-    Box type is one of [h], [v], [hv], [b], or [hov].
-    '[h]' stands for an 'horizontal' box,
-    '[v]' stands for a 'vertical' box,
-    '[hv]' stands for an 'horizontal-vertical' box,
-    '[b]' stands for an 'horizontal-or-vertical' box demonstrating indentation,
-    '[hov]' stands a simple 'horizontal-or-vertical' box.
+    Pretty-printing box type is one of [h], [v], [hv], [b], or [hov].
+    '[h]' stands for an 'horizontal' pretty-printing box,
+    '[v]' stands for a 'vertical' pretty-printing box,
+    '[hv]' stands for an 'horizontal/vertical' pretty-printing box,
+    '[b]' stands for an 'horizontal-or-vertical' pretty-printing box
+    demonstrating indentation,
+    '[hov]' stands a simple 'horizontal-or-vertical' pretty-printing box.
     For instance, [@\[<hov 2>] opens an 'horizontal-or-vertical'
-    box with indentation 2 as obtained with [open_hovbox 2].
-    For more details about boxes, see the various box opening
+    pretty-printing box with indentation 2 as obtained with [open_hovbox 2].
+    For more details about pretty-printing boxes, see the various box opening
     functions [open_*box].
   - [@\]]: close the most recently opened pretty-printing box.
   - [@,]: output a 'cut' break hint, as with [print_cut ()].
@@ -638,31 +1002,31 @@ val fprintf : formatter -> ('a, formatter, unit) format -> 'a
     then an integer [offset], and a closing [>] character.
     If no parameters are provided, the good break defaults to a
     'space' break hint.
-  - [@.]: flush the pretty printer and split the line, as with
+  - [@.]: flush the pretty-printer and split the line, as with
     [print_newline ()].
   - [@<n>]: print the following item as if it were of length [n].
     Hence, [printf "@<0>%s" arg] prints [arg] as a zero length string.
     If [@<n>] is not followed by a conversion specification,
     then the following character of the format is printed as if
     it were of length [n].
-  - [@\{]: open a tag. The name of the tag may be optionally
+  - [@\{]: open a semantic tag. The name of the tag may be optionally
     specified with the following syntax:
     the [<] character, followed by an optional string
     specification, and the closing [>] character. The string
     specification is any character string that does not contain the
     closing character ['>']. If omitted, the tag name defaults to the
     empty string.
-    For more details about tags, see the functions [open_tag] and
-    [close_tag].
-  - [@\}]: close the most recently opened tag.
-  - [@?]: flush the pretty printer as with [print_flush ()].
+    For more details about semantic tags, see the functions {!open_tag} and
+    {!close_tag}.
+  - [@\}]: close the most recently opened semantic tag.
+  - [@?]: flush the pretty-printer as with [print_flush ()].
     This is equivalent to the conversion [%!].
   - [@\n]: force a newline, as with [force_newline ()], not the normal way
     of pretty-printing, you should prefer using break hints inside a vertical
-    box.
+    pretty-printing box.
 
-  Note: If you need to prevent the interpretation of a [@] character as a
-  pretty-printing indication, you must escape it with a [%] character.
+  Note: To prevent the interpretation of a [@] character as a
+  pretty-printing indication, escape it with a [%] character.
   Old quotation mode [@@] is deprecated since it is not compatible with
   formatted input interpretation of character ['@'].
 
@@ -700,16 +1064,18 @@ val asprintf : ('a, formatter, unit, string) format4 -> 'a
   returns a string containing the result of formatting the arguments.
   The type of [asprintf] is general enough to interact nicely with [%a]
   conversions.
+
   @since 4.01.0
 *)
 
 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
 *)
 
-(** Formatted output functions with continuations. *)
+(** Formatted Pretty-Printing with continuations. *)
 
 val kfprintf :
   (formatter -> 'a) -> formatter ->
@@ -722,6 +1088,7 @@ val ikfprintf :
   ('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
 *)
 
@@ -732,18 +1099,22 @@ val ksprintf : (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b
 val kasprintf : (string -> 'a) -> ('b, formatter, unit, 'a) format4 -> 'b
 (** Same as [asprintf] above, but instead of returning the string,
   passes it to the first argument.
+
   @since 4.03
 *)
 
-(** {6 Deprecated} *)
+(** {1 Deprecated} *)
 
 val bprintf : Buffer.t -> ('a, formatter, unit) format -> 'a
   [@@ocaml.deprecated]
 (** @deprecated This function is error prone. Do not use it.
+  This function is neither compositional nor incremental, since it flushes
+  the pretty-printer queue at each call.
 
   If you need to print to some buffer [b], you must first define a
   formatter writing to [b], using [let to_b = formatter_of_buffer b]; then
-  use regular calls to [Format.fprintf] on formatter [to_b]. *)
+  use regular calls to [Format.fprintf] with formatter [to_b].
+*)
 
 val kprintf : (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b
   [@@ocaml.deprecated "Use Format.ksprintf instead."]
@@ -779,45 +1150,3 @@ val pp_get_all_formatter_output_functions :
   (int -> unit)
 [@@ocaml.deprecated "Use Format.pp_get_formatter_out_functions instead."]
 (** @deprecated Subsumed by [pp_get_formatter_out_functions]. *)
-
-(** Tabulation boxes are deprecated. *)
-
-val pp_open_tbox : formatter -> unit -> unit
-[@@ocaml.deprecated "Tabulation boxes are not supported any more."]
-(** @deprecated since 4.03.0 *)
-
-val pp_close_tbox : formatter -> unit -> unit
-[@@ocaml.deprecated "Tabulation boxes are not supported any more."]
-(** @deprecated since 4.03.0 *)
-
-val pp_print_tbreak : formatter -> int -> int -> unit
-[@@ocaml.deprecated "Tabulation boxes are not supported any more."]
-(** @deprecated since 4.03.0 *)
-
-val pp_set_tab : formatter -> unit -> unit
-[@@ocaml.deprecated "Tabulation boxes are not supported any more."]
-(** @deprecated since 4.03.0 *)
-
-val pp_print_tab : formatter -> unit -> unit
-[@@ocaml.deprecated "Tabulation boxes are not supported any more."]
-(** @deprecated since 4.03.0 *)
-
-val open_tbox : unit -> unit
-[@@ocaml.deprecated "Tabulation boxes are not supported any more."]
-(** @deprecated since 4.03.0 *)
-
-val close_tbox : unit -> unit
-[@@ocaml.deprecated "Tabulation boxes are not supported any more."]
-(** @deprecated since 4.03.0 *)
-
-val print_tbreak : int -> int -> unit
-[@@ocaml.deprecated "Tabulation boxes are not supported any more."]
-(** @deprecated since 4.03.0 *)
-
-val set_tab : unit -> unit
-[@@ocaml.deprecated "Tabulation boxes are not supported any more."]
-(** @deprecated since 4.03.0 *)
-
-val print_tab : unit -> unit
-[@@ocaml.deprecated "Tabulation boxes are not supported any more."]
-(** @deprecated since 4.03.0 *)

diff --git a/stdlib/gc.mli b/stdlib/gc.mli
index 80020379355d0adb93465665900b04e59a1a2bb6..bae8c8bc9a20ead3489a4cc2a6879e4e334a6eb2 100644 (file)
--- a/stdlib/gc.mli
+++ b/stdlib/gc.mli
@@ -97,7 +97,7 @@ type control =
     mutable space_overhead : int;
     (** The major GC speed is computed from this parameter.
        This is the memory that will be "wasted" because the GC does not
-       immediatly collect unreachable blocks.  It is expressed as a
+       immediately collect unreachable blocks.  It is expressed as a
        percentage of the memory used for live data.
        The GC will work more (use more CPU time and collect
        blocks more eagerly) if [space_overhead] is smaller.

diff --git a/stdlib/hashtbl.mli b/stdlib/hashtbl.mli
index d3c0ef3e35f0d2310e2663ac98c8acaf33bf4bf0..6449c055d8291ac69f9242a0edacc9bd8aa83741 100644 (file)
--- a/stdlib/hashtbl.mli
+++ b/stdlib/hashtbl.mli
@@ -19,7 +19,7 @@
 *)
 
 
-(** {6 Generic interface} *)
+(** {1 Generic interface} *)
 
 
 type ('a, 'b) t
@@ -216,7 +216,7 @@ val stats : ('a, 'b) t -> statistics
    buckets by size.
    @since 4.00.0 *)
 
-(** {6 Functorial interface} *)
+(** {1 Functorial interface} *)
 
 (** The functorial interface allows the use of specific comparison
     and hash functions, either for performance/security concerns,
@@ -371,7 +371,7 @@ module MakeSeeded (H : SeededHashedType) : SeededS with type key = H.t
     @since 4.00.0 *)
 
 
-(** {6 The polymorphic hash functions} *)
+(** {1 The polymorphic hash functions} *)
 
 
 val hash : 'a -> int

diff --git a/stdlib/header.c b/stdlib/header.c
index 28408a51360dbd145f926e62d16dff6ad95240dd..426b064e2fdb439b3cfd43af5770c089def2e235 100644 (file)
--- a/stdlib/header.c
+++ b/stdlib/header.c
@@ -20,15 +20,15 @@
 #include <stdio.h>
 #include <stdlib.h>
 #include <string.h>
-#include "../config/s.h"
+#include "caml/s.h"
 #ifdef HAS_UNISTD
 #include <unistd.h>
 #endif
 #include <fcntl.h>
 #include <sys/types.h>
 #include <sys/stat.h>
-#include "../byterun/caml/mlvalues.h"
-#include "../byterun/caml/exec.h"
+#include "caml/mlvalues.h"
+#include "caml/exec.h"
 
 char * default_runtime_path = RUNTIME_NAME;
 

diff --git a/stdlib/headernt.c b/stdlib/headernt.c
index 9d4943b29eddeb6cc1a273c109c0685ab2aed0f2..be71e9465011058b1c19a4099ee0b36ecebbf7de 100644 (file)
--- a/stdlib/headernt.c
+++ b/stdlib/headernt.c
@@ -23,7 +23,6 @@
 #include "caml/exec.h"
 
 #ifndef __MINGW32__
-#pragma comment(linker , "/entry:headerentry")
 #pragma comment(linker , "/subsystem:console")
 #pragma comment(lib , "kernel32")
 #ifdef _UCRT
@@ -88,22 +87,38 @@ static BOOL WINAPI ctrl_handler(DWORD event)
     return FALSE;
 }
 
-#define msg_and_length(msg) msg , (sizeof(msg) - 1)
+#if WINDOWS_UNICODE
+#define CP CP_UTF8
+#else
+#define CP CP_THREAD_ACP
+#endif
+
+static void write_console(HANDLE hOut, WCHAR *wstr)
+{
+  DWORD consoleMode, numwritten, len;
+  static char str[MAX_PATH];
+
+  if (GetConsoleMode(hOut, &consoleMode) != 0) { /* The output stream is a Console */
+    WriteConsole(hOut, wstr, wcslen(wstr), &numwritten, NULL);
+  } else { /* The output stream is redirected */
+    len = WideCharToMultiByte(CP, 0, wstr, wcslen(wstr), str, sizeof(str), NULL, NULL);
+    WriteFile(hOut, str, len, &numwritten, NULL);
+  }
+}
 
-static __inline void __declspec(noreturn) run_runtime(char * runtime,
-         char * const cmdline)
+static __inline void __declspec(noreturn) run_runtime(wchar_t * runtime,
+         wchar_t * const cmdline)
 {
-  char path[MAX_PATH];
+  wchar_t path[MAX_PATH];
   STARTUPINFO stinfo;
   PROCESS_INFORMATION procinfo;
   DWORD retcode;
-  if (SearchPath(NULL, runtime, ".exe", MAX_PATH, path, &runtime) == 0) {
+  if (SearchPath(NULL, runtime, L".exe", sizeof(path)/sizeof(wchar_t), path, &runtime) == 0) {
     HANDLE errh;
-    DWORD numwritten;
     errh = GetStdHandle(STD_ERROR_HANDLE);
-    WriteFile(errh, msg_and_length("Cannot exec "), &numwritten, NULL);
-    WriteFile(errh, runtime, strlen(runtime), &numwritten, NULL);
-    WriteFile(errh, msg_and_length("\r\n"), &numwritten, NULL);
+    write_console(errh, L"Cannot exec ");
+    write_console(errh, runtime);
+    write_console(errh, L"\r\n");
     ExitProcess(2);
 #if _MSC_VER >= 1200
     __assume(0); /* Not reached */
@@ -123,11 +138,10 @@ static __inline void __declspec(noreturn) run_runtime(char * runtime,
   if (!CreateProcess(path, cmdline, NULL, NULL, TRUE, 0, NULL, NULL,
                      &stinfo, &procinfo)) {
     HANDLE errh;
-    DWORD numwritten;
     errh = GetStdHandle(STD_ERROR_HANDLE);
-    WriteFile(errh, msg_and_length("Cannot exec "), &numwritten, NULL);
-    WriteFile(errh, runtime, strlen(runtime), &numwritten, NULL);
-    WriteFile(errh, msg_and_length("\r\n"), &numwritten, NULL);
+    write_console(errh, L"Cannot exec ");
+    write_console(errh, runtime);
+    write_console(errh, L"\r\n");
     ExitProcess(2);
 #if _MSC_VER >= 1200
     __assume(0); /* Not reached */
@@ -143,36 +157,31 @@ static __inline void __declspec(noreturn) run_runtime(char * runtime,
 #endif
 }
 
-#ifdef __MINGW32__
-int main()
-#else
-void __declspec(noreturn) __cdecl headerentry()
-#endif
+int wmain(void)
 {
-  char truename[MAX_PATH];
-  char * cmdline = GetCommandLine();
+  wchar_t truename[MAX_PATH];
+  wchar_t * cmdline = GetCommandLine();
   char * runtime_path;
+  wchar_t wruntime_path[MAX_PATH];
   HANDLE h;
 
-  GetModuleFileName(NULL, truename, sizeof(truename));
+  GetModuleFileName(NULL, truename, sizeof(truename)/sizeof(wchar_t));
   h = CreateFile(truename, GENERIC_READ, FILE_SHARE_READ | FILE_SHARE_WRITE,
                  NULL, OPEN_EXISTING, 0, NULL);
   if (h == INVALID_HANDLE_VALUE ||
       (runtime_path = read_runtime_path(h)) == NULL) {
     HANDLE errh;
-    DWORD numwritten;
     errh = GetStdHandle(STD_ERROR_HANDLE);
-    WriteFile(errh, truename, strlen(truename), &numwritten, NULL);
-    WriteFile(errh, msg_and_length(" not found or is not a bytecode"
-                                   " executable file\r\n"),
-              &numwritten, NULL);
+    write_console(errh, truename);
+    write_console(errh, L" not found or is not a bytecode executable file\r\n");
     ExitProcess(2);
 #if _MSC_VER >= 1200
     __assume(0); /* Not reached */
 #endif
   }
   CloseHandle(h);
-  run_runtime(runtime_path , cmdline);
+  MultiByteToWideChar(CP, 0, runtime_path, -1, wruntime_path, sizeof(wruntime_path)/sizeof(wchar_t));
+  run_runtime(wruntime_path , cmdline);
 #if _MSC_VER >= 1200
     __assume(0); /* Not reached */
 #endif

diff --git a/stdlib/int32.mli b/stdlib/int32.mli
index 19d7897a22b226d5ddf8c12a88d25a376778d496..199d86f29b62d796236003a05a53f248916a521b 100644 (file)
--- a/stdlib/int32.mli
+++ b/stdlib/int32.mli
@@ -84,7 +84,7 @@ external logxor : int32 -> int32 -> int32 = "%int32_xor"
 (** Bitwise logical exclusive or. *)
 
 val lognot : int32 -> int32
-(** Bitwise logical negation *)
+(** Bitwise logical negation. *)
 
 external shift_left : int32 -> int -> int32 = "%int32_lsl"
 (** [Int32.shift_left x y] shifts [x] to the left by [y] bits.
@@ -128,10 +128,18 @@ external to_float : int32 -> float
 
 external of_string : string -> int32 = "caml_int32_of_string"
 (** Convert the given string to a 32-bit integer.
-   The string is read in decimal (by default) or in hexadecimal,
-   octal or binary if the string begins with [0x], [0o] or [0b]
-   respectively.
-   Raise [Failure "int_of_string"] if the given string is not
+   The string is read in decimal (by default, or if the string 
+   begins with [0u]) or in hexadecimal, octal or binary if the
+   string begins with [0x], [0o] or [0b] respectively.
+
+   The [0u] prefix reads the input as an unsigned integer in the range
+   [[0, 2*Int32.max_int+1]].  If the input exceeds {!Int32.max_int}
+   it is converted to the signed integer
+   [Int32.min_int + input - Int32.max_int - 1].
+
+   The [_] (underscore) character can appear anywhere in the string
+   and is ignored.
+   Raise [Failure "Int32.of_string"] if the given string is not
    a valid representation of an integer, or if the integer represented
    exceeds the range of integers representable in type [int32]. *)
 
@@ -174,7 +182,7 @@ val equal: t -> t -> bool
 
 (**/**)
 
-(** {6 Deprecated functions} *)
+(** {1 Deprecated functions} *)
 
 external format : string -> int32 -> string = "caml_int32_format"
 (** Do not use this deprecated function.  Instead,

diff --git a/stdlib/int64.mli b/stdlib/int64.mli
index d8aacd53fdb47355d40a85e9e8cedfcc3cbe3383..96f48a60402b1d1898519d36e3beb5a57c48d166 100644 (file)
--- a/stdlib/int64.mli
+++ b/stdlib/int64.mli
@@ -84,7 +84,7 @@ external logxor : int64 -> int64 -> int64 = "%int64_xor"
 (** Bitwise logical exclusive or. *)
 
 val lognot : int64 -> int64
-(** Bitwise logical negation *)
+(** Bitwise logical negation. *)
 
 external shift_left : int64 -> int -> int64 = "%int64_lsl"
 (** [Int64.shift_left x y] shifts [x] to the left by [y] bits.
@@ -150,10 +150,18 @@ external to_nativeint : int64 -> nativeint = "%int64_to_nativeint"
 
 external of_string : string -> int64 = "caml_int64_of_string"
 (** Convert the given string to a 64-bit integer.
-   The string is read in decimal (by default) or in hexadecimal,
-   octal or binary if the string begins with [0x], [0o] or [0b]
-   respectively.
-   Raise [Failure "int_of_string"] if the given string is not
+   The string is read in decimal (by default, or if the string 
+   begins with [0u]) or in hexadecimal, octal or binary if the
+   string begins with [0x], [0o] or [0b] respectively.
+
+   The [0u] prefix reads the input as an unsigned integer in the range
+   [[0, 2*Int64.max_int+1]].  If the input exceeds {!Int64.max_int}
+   it is converted to the signed integer
+   [Int64.min_int + input - Int64.max_int - 1].
+
+   The [_] (underscore) character can appear anywhere in the string
+   and is ignored.
+   Raise [Failure "Int64.of_string"] if the given string is not
    a valid representation of an integer, or if the integer represented
    exceeds the range of integers representable in type [int64]. *)
 
@@ -195,7 +203,7 @@ val equal: t -> t -> bool
 
 (**/**)
 
-(** {6 Deprecated functions} *)
+(** {1 Deprecated functions} *)
 
 external format : string -> int64 -> string = "caml_int64_format"
 (** Do not use this deprecated function.  Instead,

diff --git a/stdlib/lazy.ml b/stdlib/lazy.ml
index 65269613009079fca72ef94c6620e6990dcb1169..7dc1e9ddfe2a72e534ac90493af9a90ad447dd10 100644 (file)
--- a/stdlib/lazy.ml
+++ b/stdlib/lazy.ml
@@ -36,6 +36,8 @@
    The GC will magically change things from (2) to (3) according to its
    fancy.
 
+   If OCaml was configured with the -flat-float-array option (which is
+   currently the default), the following is also true:
    We cannot use representation (3) for a [float Lazy.t] because
    [caml_make_array] assumes that only a [float] value can have tag
    [Double_tag].

diff --git a/stdlib/lexing.mli b/stdlib/lexing.mli
index 31f15ce8f01127caebba82582f42f3c4c56018aa..397d20cbb15182c16e29e5546fa4f1e2d2a87119 100644 (file)
--- a/stdlib/lexing.mli
+++ b/stdlib/lexing.mli
@@ -15,7 +15,7 @@
 
 (** The run-time library for lexers generated by [ocamllex]. *)
 
-(** {6 Positions} *)
+(** {1 Positions} *)
 
 type position = {
   pos_fname : string;
@@ -43,7 +43,7 @@ val dummy_pos : position
  *)
 
 
-(** {6 Lexer buffers} *)
+(** {1 Lexer buffers} *)
 
 
 type lexbuf =
@@ -95,7 +95,7 @@ val from_function : (bytes -> int -> int) -> lexbuf
    provided. A return value of 0 means end of input. *)
 
 
-(** {6 Functions for lexer semantic actions} *)
+(** {1 Functions for lexer semantic actions} *)
 
 
 (** The following functions can be called from the semantic actions
@@ -140,7 +140,7 @@ val new_line : lexbuf -> unit
     @since 3.11.0
 *)
 
-(** {6 Miscellaneous functions} *)
+(** {1 Miscellaneous functions} *)
 
 val flush_input : lexbuf -> unit
 (** Discard the contents of the buffer and reset the current
@@ -149,7 +149,7 @@ val flush_input : lexbuf -> unit
 
 (**/**)
 
-(** {6  } *)
+(** {1  } *)
 
 (** The following definitions are used by the generated scanners only.
    They are not intended to be used directly by user programs. *)

diff --git a/stdlib/list.ml b/stdlib/list.ml
index 73b7d834b54f2ca86a3a4c69d4ff42c7b216ca4e..5b7b679f58625b5b98b6f157b20a8d2b806b5a9b 100644 (file)
--- a/stdlib/list.ml
+++ b/stdlib/list.ml
@@ -56,6 +56,21 @@ let rec rev_append l1 l2 =
 
 let rev l = rev_append l []
 
+let rec init_tailrec_aux acc i n f =
+  if i >= n then acc
+  else init_tailrec_aux (f i :: acc) (i+1) n f
+
+let rec init_aux i n f =
+  if i >= n then []
+  else
+    let r = f i in
+    r :: init_aux (i+1) n f
+
+let init len f =
+  if len < 0 then invalid_arg "List.init" else
+  if len > 10_000 then rev (init_tailrec_aux [] 0 len f)
+  else init_aux 0 len f
+
 let rec flatten = function
     [] -> []
   | l::r -> l @ flatten r
@@ -460,9 +475,11 @@ let rec compare_lengths l1 l2 =
 ;;
 
 let rec compare_length_with l n =
-  match l, n with
-  | [], 0 -> 0
-  | [], _ -> if n > 0 then -1 else 1
-  | _, 0 -> 1
-  | _ :: l, n -> compare_length_with l (n-1)
+  match l with
+  | [] ->
+    if n = 0 then 0 else
+      if n > 0 then -1 else 1
+  | _ :: l ->
+    if n <= 0 then 1 else
+      compare_length_with l (n-1)
 ;;

diff --git a/stdlib/list.mli b/stdlib/list.mli
index e8d6d392268a20396a7d83a135455d436e5aa50f..cdcd23cdf6d715692c6c7ca744be59444368ef99 100644 (file)
--- a/stdlib/list.mli
+++ b/stdlib/list.mli
@@ -73,6 +73,13 @@ val nth_opt: 'a list -> int -> 'a option
 val rev : 'a list -> 'a list
 (** List reversal. *)
 
+val init : int -> (int -> 'a) -> 'a list
+(** [List.init len f] is [f 0; f 1; ...; f (len-1)], evaluated left to right.
+
+    @raise Invalid_argument if len < 0.
+    @since 4.06.0
+*)
+
 val append : 'a list -> 'a list -> 'a list
 (** Concatenate two lists.  Same as the infix operator [@].
    Not tail-recursive (length of the first argument).  *)
@@ -92,7 +99,7 @@ val flatten : 'a list list -> 'a list
 (** An alias for [concat]. *)
 
 
-(** {6 Iterators} *)
+(** {1 Iterators} *)
 
 
 val iter : ('a -> unit) -> 'a list -> unit
@@ -133,7 +140,7 @@ val fold_right : ('a -> 'b -> 'b) -> 'a list -> 'b -> 'b
    [f a1 (f a2 (... (f an b) ...))].  Not tail-recursive. *)
 
 
-(** {6 Iterators on two lists} *)
+(** {1 Iterators on two lists} *)
 
 
 val iter2 : ('a -> 'b -> unit) -> 'a list -> 'b list -> unit
@@ -166,7 +173,7 @@ val fold_right2 : ('a -> 'b -> 'c -> 'c) -> 'a list -> 'b list -> 'c -> 'c
    to have different lengths.  Not tail-recursive. *)
 
 
-(** {6 List scanning} *)
+(** {1 List scanning} *)
 
 
 val for_all : ('a -> bool) -> 'a list -> bool
@@ -198,7 +205,7 @@ val memq : 'a -> 'a list -> bool
    equality to compare list elements. *)
 
 
-(** {6 List searching} *)
+(** {1 List searching} *)
 
 
 val find : ('a -> bool) -> 'a list -> 'a
@@ -229,7 +236,7 @@ val partition : ('a -> bool) -> 'a list -> 'a list * 'a list
    The order of the elements in the input list is preserved. *)
 
 
-(** {6 Association lists} *)
+(** {1 Association lists} *)
 
 
 val assoc : 'a -> ('a * 'b) list -> 'b
@@ -276,7 +283,7 @@ val remove_assq : 'a -> ('a * 'b) list -> ('a * 'b) list
    of structural equality to compare keys.  Not tail-recursive. *)
 
 
-(** {6 Lists of pairs} *)
+(** {1 Lists of pairs} *)
 
 
 val split : ('a * 'b) list -> 'a list * 'b list
@@ -293,7 +300,7 @@ val combine : 'a list -> 'b list -> ('a * 'b) list
    have different lengths.  Not tail-recursive. *)
 
 
-(** {6 Sorting} *)
+(** {1 Sorting} *)
 
 
 val sort : ('a -> 'a -> int) -> 'a list -> 'a list
@@ -333,7 +340,7 @@ val merge : ('a -> 'a -> int) -> 'a list -> 'a list -> 'a list
 (** Merge two lists:
     Assuming that [l1] and [l2] are sorted according to the
     comparison function [cmp], [merge cmp l1 l2] will return a
-    sorted list containting all the elements of [l1] and [l2].
+    sorted list containing all the elements of [l1] and [l2].
     If several elements compare equal, the elements of [l1] will be
     before the elements of [l2].
     Not tail-recursive (sum of the lengths of the arguments).

diff --git a/stdlib/listLabels.mli b/stdlib/listLabels.mli
index 52ded3f957bd71830f218ef03f19be566f5bf50a..d5d9cd400eb15a78ca23f501081a592325f5c0ff 100644 (file)
--- a/stdlib/listLabels.mli
+++ b/stdlib/listLabels.mli
@@ -73,14 +73,21 @@ val nth_opt: 'a list -> int -> 'a option
 val rev : 'a list -> 'a list
 (** List reversal. *)
 
+val init : len:int -> f:(int -> 'a) -> 'a list
+(** [List.init len f] is [f 0; f 1; ...; f (len-1)], evaluated left to right.
+
+    @raise Invalid_argument if [len < 0].
+    @since 4.06.0
+*)
+
 val append : 'a list -> 'a list -> 'a list
 (** Catenate two lists.  Same function as the infix operator [@].
    Not tail-recursive (length of the first argument).  The [@]
    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].
-   This is equivalent to {!List.rev}[ l1 @ l2], but [rev_append] is
+(** [List.rev_append l1 l2] reverses [l1] and concatenates it with [l2].
+   This is equivalent to [(]{!List.rev}[ l1) @ l2], but [rev_append] is
    tail-recursive and more efficient. *)
 
 val concat : 'a list list -> 'a list
@@ -94,7 +101,7 @@ val flatten : 'a list list -> 'a list
    (length of the argument + length of the longest sub-list). *)
 
 
-(** {6 Iterators} *)
+(** {1 Iterators} *)
 
 
 val iter : f:('a -> unit) -> 'a list -> unit
@@ -135,7 +142,7 @@ val fold_right : f:('a -> 'b -> 'b) -> 'a list -> init:'b -> 'b
    [f a1 (f a2 (... (f an b) ...))].  Not tail-recursive. *)
 
 
-(** {6 Iterators on two lists} *)
+(** {1 Iterators on two lists} *)
 
 
 val iter2 : f:('a -> 'b -> unit) -> 'a list -> 'b list -> unit
@@ -170,7 +177,7 @@ val fold_right2 :
    to have different lengths.  Not tail-recursive. *)
 
 
-(** {6 List scanning} *)
+(** {1 List scanning} *)
 
 
 val for_all : f:('a -> bool) -> 'a list -> bool
@@ -202,7 +209,7 @@ val memq : 'a -> set:'a list -> bool
    equality to compare list elements. *)
 
 
-(** {6 List searching} *)
+(** {1 List searching} *)
 
 
 val find : f:('a -> bool) -> 'a list -> 'a
@@ -234,7 +241,7 @@ val partition : f:('a -> bool) -> 'a list -> 'a list * 'a list
    The order of the elements in the input list is preserved. *)
 
 
-(** {6 Association lists} *)
+(** {1 Association lists} *)
 
 
 val assoc : 'a -> ('a * 'b) list -> 'b
@@ -282,7 +289,7 @@ val remove_assq : 'a -> ('a * 'b) list -> ('a * 'b) list
    of structural equality to compare keys.  Not tail-recursive. *)
 
 
-(** {6 Lists of pairs} *)
+(** {1 Lists of pairs} *)
 
 
 val split : ('a * 'b) list -> 'a list * 'b list
@@ -299,7 +306,7 @@ val combine : 'a list -> 'b list -> ('a * 'b) list
    have different lengths.  Not tail-recursive. *)
 
 
-(** {6 Sorting} *)
+(** {1 Sorting} *)
 
 
 val sort : cmp:('a -> 'a -> int) -> 'a list -> 'a list
@@ -339,7 +346,7 @@ val merge : cmp:('a -> 'a -> int) -> 'a list -> 'a list -> 'a list
 (** Merge two lists:
     Assuming that [l1] and [l2] are sorted according to the
     comparison function [cmp], [merge cmp l1 l2] will return a
-    sorted list containting all the elements of [l1] and [l2].
+    sorted list containing all the elements of [l1] and [l2].
     If several elements compare equal, the elements of [l1] will be
     before the elements of [l2].
     Not tail-recursive (sum of the lengths of the arguments).

diff --git a/stdlib/map.ml b/stdlib/map.ml
index 18659c496bb7c5d89b864227001e5a1ffd96dcb1..7d096dfb3c92e99369738b64939ea63d9bf359f7 100644 (file)
--- a/stdlib/map.ml
+++ b/stdlib/map.ml
@@ -27,6 +27,7 @@ module type S =
     val is_empty: 'a t -> bool
     val mem:  key -> 'a t -> bool
     val add: key -> 'a -> 'a t -> 'a t
+    val update: key -> ('a option -> 'a option) -> 'a t -> 'a t
     val singleton: key -> 'a -> 'a t
     val remove: key -> 'a t -> 'a t
     val merge:
@@ -65,47 +66,47 @@ module Make(Ord: OrderedType) = struct
 
     type 'a t =
         Empty
-      | Node of 'a t * key * 'a * 'a t * int
+      | Node of {l:'a t; v:key; d:'a; r:'a t; h:int}
 
     let height = function
         Empty -> 0
-      | Node(_,_,_,_,h) -> h
+      | Node {h} -> h
 
     let create l x d r =
       let hl = height l and hr = height r in
-      Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1))
+      Node{l; v=x; d; r; h=(if hl >= hr then hl + 1 else hr + 1)}
 
-    let singleton x d = Node(Empty, x, d, Empty, 1)
+    let singleton x d = Node{l=Empty; v=x; d; r=Empty; h=1}
 
     let bal l x d r =
-      let hl = match l with Empty -> 0 | Node(_,_,_,_,h) -> h in
-      let hr = match r with Empty -> 0 | Node(_,_,_,_,h) -> h in
+      let hl = match l with Empty -> 0 | Node {h} -> h in
+      let hr = match r with Empty -> 0 | Node {h} -> h in
       if hl > hr + 2 then begin
         match l with
           Empty -> invalid_arg "Map.bal"
-        | Node(ll, lv, ld, lr, _) ->
+        | Node{l=ll; v=lv; d=ld; r=lr} ->
             if height ll >= height lr then
               create ll lv ld (create lr x d r)
             else begin
               match lr with
                 Empty -> invalid_arg "Map.bal"
-              | Node(lrl, lrv, lrd, lrr, _)->
+              | Node{l=lrl; v=lrv; d=lrd; r=lrr}->
                   create (create ll lv ld lrl) lrv lrd (create lrr x d r)
             end
       end else if hr > hl + 2 then begin
         match r with
           Empty -> invalid_arg "Map.bal"
-        | Node(rl, rv, rd, rr, _) ->
+        | Node{l=rl; v=rv; d=rd; r=rr} ->
             if height rr >= height rl then
               create (create l x d rl) rv rd rr
             else begin
               match rl with
                 Empty -> invalid_arg "Map.bal"
-              | Node(rll, rlv, rld, rlr, _) ->
+              | Node{l=rll; v=rlv; d=rld; r=rlr} ->
                   create (create l x d rll) rlv rld (create rlr rv rd rr)
             end
       end else
-        Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1))
+        Node{l; v=x; d; r; h=(if hl >= hr then hl + 1 else hr + 1)}
 
     let empty = Empty
 
@@ -113,11 +114,11 @@ module Make(Ord: OrderedType) = struct
 
     let rec add x data = function
         Empty ->
-          Node(Empty, x, data, Empty, 1)
-      | Node(l, v, d, r, h) as m ->
+          Node{l=Empty; v=x; d=data; r=Empty; h=1}
+      | Node {l; v; d; r; h} as m ->
           let c = Ord.compare x v in
           if c = 0 then
-            if d == data then m else Node(l, x, data, r, h)
+            if d == data then m else Node{l; v=x; d=data; r; h}
           else if c < 0 then
             let ll = add x data l in
             if l == ll then m else bal ll v d r
@@ -128,7 +129,7 @@ module Make(Ord: OrderedType) = struct
     let rec find x = function
         Empty ->
           raise Not_found
-      | Node(l, v, d, r, _) ->
+      | Node {l; v; d; r} ->
           let c = Ord.compare x v in
           if c = 0 then d
           else find x (if c < 0 then l else r)
@@ -136,7 +137,7 @@ module Make(Ord: OrderedType) = struct
     let rec find_first_aux v0 d0 f = function
         Empty ->
           (v0, d0)
-      | Node(l, v, d, r, _) ->
+      | Node {l; v; d; r} ->
           if f v then
             find_first_aux v d f l
           else
@@ -145,7 +146,7 @@ module Make(Ord: OrderedType) = struct
     let rec find_first f = function
         Empty ->
           raise Not_found
-      | Node(l, v, d, r, _) ->
+      | Node {l; v; d; r} ->
           if f v then
             find_first_aux v d f l
           else
@@ -154,7 +155,7 @@ module Make(Ord: OrderedType) = struct
     let rec find_first_opt_aux v0 d0 f = function
         Empty ->
           Some (v0, d0)
-      | Node(l, v, d, r, _) ->
+      | Node {l; v; d; r} ->
           if f v then
             find_first_opt_aux v d f l
           else
@@ -163,7 +164,7 @@ module Make(Ord: OrderedType) = struct
     let rec find_first_opt f = function
         Empty ->
           None
-      | Node(l, v, d, r, _) ->
+      | Node {l; v; d; r} ->
           if f v then
             find_first_opt_aux v d f l
           else
@@ -172,7 +173,7 @@ module Make(Ord: OrderedType) = struct
     let rec find_last_aux v0 d0 f = function
         Empty ->
           (v0, d0)
-      | Node(l, v, d, r, _) ->
+      | Node {l; v; d; r} ->
           if f v then
             find_last_aux v d f r
           else
@@ -181,7 +182,7 @@ module Make(Ord: OrderedType) = struct
     let rec find_last f = function
         Empty ->
           raise Not_found
-      | Node(l, v, d, r, _) ->
+      | Node {l; v; d; r} ->
           if f v then
             find_last_aux v d f r
           else
@@ -190,7 +191,7 @@ module Make(Ord: OrderedType) = struct
     let rec find_last_opt_aux v0 d0 f = function
         Empty ->
           Some (v0, d0)
-      | Node(l, v, d, r, _) ->
+      | Node {l; v; d; r} ->
           if f v then
             find_last_opt_aux v d f r
           else
@@ -199,7 +200,7 @@ module Make(Ord: OrderedType) = struct
     let rec find_last_opt f = function
         Empty ->
           None
-      | Node(l, v, d, r, _) ->
+      | Node {l; v; d; r} ->
           if f v then
             find_last_opt_aux v d f r
           else
@@ -208,7 +209,7 @@ module Make(Ord: OrderedType) = struct
     let rec find_opt x = function
         Empty ->
           None
-      | Node(l, v, d, r, _) ->
+      | Node {l; v; d; r} ->
           let c = Ord.compare x v in
           if c = 0 then Some d
           else find_opt x (if c < 0 then l else r)
@@ -216,34 +217,34 @@ module Make(Ord: OrderedType) = struct
     let rec mem x = function
         Empty ->
           false
-      | Node(l, v, _, r, _) ->
+      | Node {l; v; r} ->
           let c = Ord.compare x v in
           c = 0 || mem x (if c < 0 then l else r)
 
     let rec min_binding = function
         Empty -> raise Not_found
-      | Node(Empty, x, d, _, _) -> (x, d)
-      | Node(l, _, _, _, _) -> min_binding l
+      | Node {l=Empty; v; d} -> (v, d)
+      | Node {l} -> min_binding l
 
     let rec min_binding_opt = function
         Empty -> None
-      | Node(Empty, x, d, _, _) -> Some (x, d)
-      | Node(l, _, _, _, _) -> min_binding_opt l
+      | Node {l=Empty; v; d} -> Some (v, d)
+      | Node {l}-> min_binding_opt l
 
     let rec max_binding = function
         Empty -> raise Not_found
-      | Node(_, x, d, Empty, _) -> (x, d)
-      | Node(_, _, _, r, _) -> max_binding r
+      | Node {v; d; r=Empty} -> (v, d)
+      | Node {r} -> max_binding r
 
     let rec max_binding_opt = function
         Empty -> None
-      | Node(_, x, d, Empty, _) -> Some (x, d)
-      | Node(_, _, _, r, _) -> max_binding_opt r
+      | Node {v; d; r=Empty} -> Some (v, d)
+      | Node {r} -> max_binding_opt r
 
     let rec remove_min_binding = function
         Empty -> invalid_arg "Map.remove_min_elt"
-      | Node(Empty, _, _, r, _) -> r
-      | Node(l, x, d, r, _) -> bal (remove_min_binding l) x d r
+      | Node {l=Empty; r} -> r
+      | Node {l; v; d; r} -> bal (remove_min_binding l) v d r
 
     let merge t1 t2 =
       match (t1, t2) with
@@ -256,50 +257,70 @@ module Make(Ord: OrderedType) = struct
     let rec remove x = function
         Empty ->
           Empty
-      | (Node(l, v, d, r, _) as t) ->
+      | (Node {l; v; d; r} as m) ->
           let c = Ord.compare x v in
           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 d r
+            let ll = remove x l in if l == ll then m else bal ll v d r
           else
-            let rr = remove x r in if r == rr then t else bal l v d rr
+            let rr = remove x r in if r == rr then m else bal l v d rr
+
+    let rec update x f = function
+        Empty ->
+          begin match f None with
+          | None -> Empty
+          | Some data -> Node{l=Empty; v=x; d=data; r=Empty; h=1}
+          end
+      | Node {l; v; d; r; h} as m ->
+          let c = Ord.compare x v in
+          if c = 0 then begin
+            match f (Some d) with
+            | None -> merge l r
+            | Some data ->
+                if d == data then m else Node{l; v=x; d=data; r; h}
+          end else if c < 0 then
+            let ll = update x f l in
+            if l == ll then m else bal ll v d r
+          else
+            let rr = update x f r in
+            if r == rr then m else bal l v d rr
 
     let rec iter f = function
         Empty -> ()
-      | Node(l, v, d, r, _) ->
+      | Node {l; v; d; r} ->
           iter f l; f v d; iter f r
 
     let rec map f = function
         Empty ->
           Empty
-      | Node(l, v, d, r, h) ->
+      | Node {l; v; d; r; h} ->
           let l' = map f l in
           let d' = f d in
           let r' = map f r in
-          Node(l', v, d', r', h)
+          Node{l=l'; v; d=d'; r=r'; h}
 
     let rec mapi f = function
         Empty ->
           Empty
-      | Node(l, v, d, r, h) ->
+      | Node {l; v; d; r; h} ->
           let l' = mapi f l in
           let d' = f v d in
           let r' = mapi f r in
-          Node(l', v, d', r', h)
+          Node{l=l'; v; d=d'; r=r'; h}
 
     let rec fold f m accu =
       match m with
         Empty -> accu
-      | Node(l, v, d, r, _) ->
+      | Node {l; v; d; r} ->
           fold f r (f v d (fold f l accu))
 
     let rec for_all p = function
         Empty -> true
-      | Node(l, v, d, r, _) -> p v d && for_all p l && for_all p r
+      | Node {l; v; d; r} -> p v d && for_all p l && for_all p r
 
     let rec exists p = function
         Empty -> false
-      | Node(l, v, d, r, _) -> p v d || exists p l || exists p r
+      | Node {l; v; d; r} -> p v d || exists p l || exists p r
 
     (* Beware: those two functions assume that the added k is *strictly*
        smaller (or bigger) than all the present keys in the tree; it
@@ -309,15 +330,15 @@ module Make(Ord: OrderedType) = struct
        respects this precondition.
     *)
 
-    let rec add_min_binding k v = function
-      | Empty -> singleton k v
-      | Node (l, x, d, r, _) ->
-        bal (add_min_binding k v l) x d r
+    let rec add_min_binding k x = function
+      | Empty -> singleton k x
+      | Node {l; v; d; r} ->
+        bal (add_min_binding k x l) v d r
 
-    let rec add_max_binding k v = function
-      | Empty -> singleton k v
-      | Node (l, x, d, r, _) ->
-        bal l x d (add_max_binding k v r)
+    let rec add_max_binding k x = function
+      | Empty -> singleton k x
+      | Node {l; v; d; r} ->
+        bal l v d (add_max_binding k x r)
 
     (* Same as create and bal, but no assumptions are made on the
        relative heights of l and r. *)
@@ -326,7 +347,7 @@ module Make(Ord: OrderedType) = struct
       match (l, r) with
         (Empty, _) -> add_min_binding v d r
       | (_, Empty) -> add_max_binding v d l
-      | (Node(ll, lv, ld, lr, lh), Node(rl, rv, rd, rr, rh)) ->
+      | (Node{l=ll; v=lv; d=ld; r=lr; h=lh}, Node{l=rl; v=rv; d=rd; r=rr; h=rh}) ->
           if lh > rh + 2 then bal ll lv ld (join lr v d r) else
           if rh > lh + 2 then bal (join l v d rl) rv rd rr else
           create l v d r
@@ -351,7 +372,7 @@ module Make(Ord: OrderedType) = struct
     let rec split x = function
         Empty ->
           (Empty, None, Empty)
-      | Node(l, v, d, r, _) ->
+      | Node {l; v; d; r} ->
           let c = Ord.compare x v in
           if c = 0 then (l, Some d, r)
           else if c < 0 then
@@ -362,10 +383,10 @@ module Make(Ord: OrderedType) = struct
     let rec merge f s1 s2 =
       match (s1, s2) with
         (Empty, Empty) -> Empty
-      | (Node (l1, v1, d1, r1, h1), _) when h1 >= height s2 ->
+      | (Node {l=l1; v=v1; d=d1; r=r1; h=h1}, _) when h1 >= height s2 ->
           let (l2, d2, r2) = split v1 s2 in
           concat_or_join (merge f l1 l2) v1 (f v1 (Some d1) d2) (merge f r1 r2)
-      | (_, Node (l2, v2, d2, r2, _)) ->
+      | (_, Node {l=l2; v=v2; d=d2; r=r2}) ->
           let (l1, d1, r1) = split v2 s1 in
           concat_or_join (merge f l1 l2) v2 (f v2 d1 (Some d2)) (merge f r1 r2)
       | _ ->
@@ -374,7 +395,7 @@ module Make(Ord: OrderedType) = struct
     let rec union f s1 s2 =
       match (s1, s2) with
       | (Empty, s) | (s, Empty) -> s
-      | (Node (l1, v1, d1, r1, h1), Node (l2, v2, d2, r2, h2)) ->
+      | (Node {l=l1; v=v1; d=d1; r=r1; h=h1}, Node {l=l2; v=v2; d=d2; r=r2; h=h2}) ->
           if h1 >= h2 then
             let (l2, d2, r2) = split v1 s2 in
             let l = union f l1 l2 and r = union f r1 r2 in
@@ -390,17 +411,17 @@ module Make(Ord: OrderedType) = struct
 
     let rec filter p = function
         Empty -> Empty
-      | Node(l, v, d, r, _) as t ->
+      | Node {l; v; d; r} as m ->
           (* call [p] in the expected left-to-right order *)
           let l' = filter p l in
           let pvd = p v d in
           let r' = filter p r in
-          if pvd then if l==l' && r==r' then t else join l' v d r'
+          if pvd then if l==l' && r==r' then m else join l' v d r'
           else concat l' r'
 
     let rec partition p = function
         Empty -> (Empty, Empty)
-      | Node(l, v, d, r, _) ->
+      | Node {l; v; d; r} ->
           (* call [p] in the expected left-to-right order *)
           let (lt, lf) = partition p l in
           let pvd = p v d in
@@ -414,7 +435,7 @@ module Make(Ord: OrderedType) = struct
     let rec cons_enum m e =
       match m with
         Empty -> e
-      | Node(l, v, d, r, _) -> cons_enum l (More(v, d, r, e))
+      | Node {l; v; d; r} -> cons_enum l (More(v, d, r, e))
 
     let compare cmp m1 m2 =
       let rec compare_aux e1 e2 =
@@ -443,11 +464,11 @@ module Make(Ord: OrderedType) = struct
 
     let rec cardinal = function
         Empty -> 0
-      | Node(l, _, _, r, _) -> cardinal l + 1 + cardinal r
+      | Node {l; r} -> cardinal l + 1 + cardinal r
 
     let rec bindings_aux accu = function
         Empty -> accu
-      | Node(l, v, d, r, _) -> bindings_aux ((v, d) :: bindings_aux accu r) l
+      | Node {l; v; d; r} -> bindings_aux ((v, d) :: bindings_aux accu r) l
 
     let bindings s =
       bindings_aux [] s

diff --git a/stdlib/map.mli b/stdlib/map.mli
index 331e2a72651a963d9a1f78b2f7ed4c979bec9b64..7552c480a516ce899e86b00b31896bcaa9821ff0 100644 (file)
--- a/stdlib/map.mli
+++ b/stdlib/map.mli
@@ -86,6 +86,19 @@ module type S =
        of [x] in [m] disappears.
        @before 4.03 Physical equality was not ensured. *)
 
+    val update: key -> ('a option -> 'a option) -> 'a t -> 'a t
+    (** [update x f m] returns a map containing the same bindings as
+        [m], except for the binding of [x]. Depending on the value of
+        [y] where [y] is [f (find_opt x m)], the binding of [x] is
+        added, removed or updated. If [y] is [None], the binding is
+        removed if it exists; otherwise, if [y] is [Some z] then [x]
+        is associated to [z] in the resulting map.  If [x] was already
+        bound in [m] to a value that is physically equal to [z], [m]
+        is returned unchanged (the result of the function is then
+        physically equal to [m]).
+        @since 4.06.0
+    *)
+
     val singleton: key -> 'a -> 'a t
     (** [singleton x y] returns the one-element map that contains a binding [y]
         for [x].

diff --git a/stdlib/marshal.mli b/stdlib/marshal.mli
index 2473365f4ac3c71809dafb51b0f209ef2faf48fe..28c22e902d60e2a3b8fba8ccfebf3850125bc803 100644 (file)
--- a/stdlib/marshal.mli
+++ b/stdlib/marshal.mli
@@ -29,14 +29,14 @@
    the [Marshal.from_*] functions is given as ['a], but this is
    misleading: the returned OCaml value does not possess type ['a]
    for all ['a]; it has one, unique type which cannot be determined
-   at compile-type.  The programmer should explicitly give the expected
+   at compile-time.  The programmer should explicitly give the expected
    type of the returned value, using the following syntax:
    - [(Marshal.from_channel chan : type)].
    Anything can happen at run-time if the object in the file does not
    belong to the given type.
 
    Values of extensible variant types, for example exceptions (of
-   extensible type [exn]), returned by the unmarhsaller should not be
+   extensible type [exn]), returned by the unmarshaller should not be
    pattern-matched over through [match ... with] or [try ... with],
    because unmarshalling does not preserve the information required for
    matching their constructors. Structural equalities with other

diff --git a/stdlib/moreLabels.mli b/stdlib/moreLabels.mli
index 824c9a23425ae5c5ed5429f7eb6813c442b2ddd0..95efcf8c8065a6556812ac27a3ef9cd2c67aee66 100644 (file)
--- a/stdlib/moreLabels.mli
+++ b/stdlib/moreLabels.mli
@@ -115,6 +115,7 @@ module Map : sig
       val is_empty: 'a t -> bool
       val mem : key -> 'a t -> bool
       val add : key:key -> data:'a -> 'a t -> 'a t
+      val update: key:key -> f:('a option -> 'a option) -> 'a t -> 'a t
       val singleton: key -> 'a -> 'a t
       val remove : key -> 'a t -> 'a t
       val merge:

diff --git a/stdlib/nativeint.mli b/stdlib/nativeint.mli
index b733318db4fa6d12d6bd31418b7f5883bd139653..a047ced5a6be4e3f3e3fe59fd3bfcc0f93fbdfd0 100644 (file)
--- a/stdlib/nativeint.mli
+++ b/stdlib/nativeint.mli
@@ -99,7 +99,7 @@ external logxor : nativeint -> nativeint -> nativeint = "%nativeint_xor"
 (** Bitwise logical exclusive or. *)
 
 val lognot : nativeint -> nativeint
-(** Bitwise logical negation *)
+(** Bitwise logical negation. *)
 
 external shift_left : nativeint -> int -> nativeint = "%nativeint_lsl"
 (** [Nativeint.shift_left x y] shifts [x] to the left by [y] bits.
@@ -158,10 +158,16 @@ external to_int32 : nativeint -> int32 = "%nativeint_to_int32"
 
 external of_string : string -> nativeint = "caml_nativeint_of_string"
 (** Convert the given string to a native integer.
-   The string is read in decimal (by default) or in hexadecimal,
-   octal or binary if the string begins with [0x], [0o] or [0b]
-   respectively.
-   Raise [Failure "int_of_string"] if the given string is not
+   The string is read in decimal (by default, or if the string 
+   begins with [0u]) or in hexadecimal, octal or binary if the
+   string begins with [0x], [0o] or [0b] respectively.
+
+   The [0u] prefix reads the input as an unsigned integer in the range
+   [[0, 2*Nativeint.max_int+1]].  If the input exceeds {!Nativeint.max_int}
+   it is converted to the signed integer
+   [Int64.min_int + input - Nativeint.max_int - 1].
+
+   Raise [Failure "Nativeint.of_string"] if the given string is not
    a valid representation of an integer, or if the integer represented
    exceeds the range of integers representable in type [nativeint]. *)
 
@@ -187,7 +193,7 @@ val equal: t -> t -> bool
 
 (**/**)
 
-(** {6 Deprecated functions} *)
+(** {1 Deprecated functions} *)
 
 external format : string -> nativeint -> string = "caml_nativeint_format"
 (** [Nativeint.format fmt n] return the string representation of the

diff --git a/stdlib/obj.ml b/stdlib/obj.ml
index 35b3925ae4d9818484764ad39fe2ea4fa1001d6a..6c5f4f9e014d22643b1c1793b0877f4d4daa3c05 100644 (file)
--- a/stdlib/obj.ml
+++ b/stdlib/obj.ml
@@ -28,11 +28,12 @@ external size : t -> int = "%obj_size"
 external reachable_words : t -> int = "caml_obj_reachable_words"
 external field : t -> int -> t = "%obj_field"
 external set_field : t -> int -> t -> unit = "%obj_set_field"
-external array_get: 'a array -> int -> 'a = "%array_safe_get"
-external array_set: 'a array -> int -> 'a -> unit = "%array_safe_set"
-let [@inline always] double_field x i = array_get (obj x : float array) i
+external floatarray_get : floatarray -> int -> float = "caml_floatarray_get"
+external floatarray_set :
+    floatarray -> int -> float -> unit = "caml_floatarray_set"
+let [@inline always] double_field x i = floatarray_get (obj x : floatarray) i
 let [@inline always] set_double_field x i v =
-  array_set (obj x : float array) i v
+  floatarray_set (obj x : floatarray) i v
 external new_block : int -> int -> t = "caml_obj_block"
 external dup : t -> t = "caml_obj_dup"
 external truncate : t -> int -> unit = "caml_obj_truncate"

diff --git a/stdlib/parsing.mli b/stdlib/parsing.mli
index baeae9ab5f067d0dae9b4771a4131dca22492147..73b9504d4fb1dba189e18d3eb059681a2a1ba13d 100644 (file)
--- a/stdlib/parsing.mli
+++ b/stdlib/parsing.mli
@@ -71,7 +71,7 @@ val set_trace: bool -> bool
 
 (**/**)
 
-(** {6  } *)
+(** {1  } *)
 
 (** The following definitions are used by the generated parsers only.
    They are not intended to be used directly by user programs. *)

diff --git a/stdlib/pervasives.ml b/stdlib/pervasives.ml
index fc7d92187c423a721d6566333851c882b90f62fc..faa421871a172d79cb432e246141147652c2dc64 100644 (file)
--- a/stdlib/pervasives.ml
+++ b/stdlib/pervasives.ml
@@ -187,7 +187,7 @@ external classify_float : (float [@unboxed]) -> fpclass =
 (* String and byte sequence operations -- more in modules String and Bytes *)
 
 external string_length : string -> int = "%string_length"
-external bytes_length : bytes -> int = "%string_length"
+external bytes_length : bytes -> int = "%bytes_length"
 external bytes_create : int -> bytes = "caml_create_bytes"
 external string_blit : string -> int -> bytes -> int -> int -> unit
                      = "caml_blit_string" [@@noalloc]
@@ -258,7 +258,6 @@ let int_of_string_opt s =
   try Some (int_of_string s)
   with Failure _ -> None
 
-
 external string_get : string -> int -> char = "%string_safe_get"
 
 let valid_float_lexem s =
@@ -271,7 +270,6 @@ let valid_float_lexem s =
   in
   loop 0
 
-
 let string_of_float f = valid_float_lexem (format_float "%.12g" f)
 
 external float_of_string : string -> float = "caml_float_of_string"
@@ -332,7 +330,13 @@ external out_channels_list : unit -> out_channel list
 let flush_all () =
   let rec iter = function
       [] -> ()
-    | a :: l -> (try flush a with _ -> ()); iter l
+    | a::l ->
+        begin try
+            flush a
+        with Sys_error _ ->
+          () (* ignore channels closed during a preceding flush. *)
+        end;
+        iter l
   in iter (out_channels_list ())
 
 external unsafe_output : out_channel -> bytes -> int -> int -> unit

diff --git a/stdlib/pervasives.mli b/stdlib/pervasives.mli
index 7bf88f8808565fd0636540ae18586353210f6624..af0cffee402de6d2da0e43908746662ece01664d 100644 (file)
--- a/stdlib/pervasives.mli
+++ b/stdlib/pervasives.mli
@@ -25,7 +25,7 @@
 *)
 
 
-(** {6 Exceptions} *)
+(** {1 Exceptions} *)
 
 external raise : exn -> 'a = "%raise"
 (** Raise the given exception value *)
@@ -46,7 +46,7 @@ exception Exit
     provided for use in your programs. *)
 
 
-(** {6 Comparisons} *)
+(** {1 Comparisons} *)
 
 external ( = ) : 'a -> 'a -> bool = "%equal"
 (** [e1 = e2] tests for structural equality of [e1] and [e2].
@@ -54,19 +54,24 @@ external ( = ) : 'a -> 'a -> bool = "%equal"
    if and only if their current contents are structurally equal,
    even if the two mutable objects are not the same physical object.
    Equality between functional values raises [Invalid_argument].
-   Equality between cyclic data structures may not terminate. *)
+   Equality between cyclic data structures may not terminate.
+   Left-associative operator at precedence level 4/11. *)
 
 external ( <> ) : 'a -> 'a -> bool = "%notequal"
-(** Negation of {!Pervasives.( = )}. *)
+(** Negation of {!Pervasives.( = )}.
+    Left-associative operator at precedence level 4/11. *)
 
 external ( < ) : 'a -> 'a -> bool = "%lessthan"
-(** See {!Pervasives.( >= )}. *)
+(** See {!Pervasives.( >= )}.
+    Left-associative operator at precedence level 4/11. *)
 
 external ( > ) : 'a -> 'a -> bool = "%greaterthan"
-(** See {!Pervasives.( >= )}. *)
+(** See {!Pervasives.( >= )}.
+    Left-associative operator at precedence level 4/11. *)
 
 external ( <= ) : 'a -> 'a -> bool = "%lessequal"
-(** See {!Pervasives.( >= )}. *)
+(** See {!Pervasives.( >= )}.
+    Left-associative operator at precedence level 4/11. *)
 
 external ( >= ) : 'a -> 'a -> bool = "%greaterequal"
 (** Structural ordering functions. These functions coincide with
@@ -76,7 +81,8 @@ external ( >= ) : 'a -> 'a -> bool = "%greaterequal"
    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. *)
+   Comparison between cyclic structures may not terminate.
+   Left-associative operator at precedence level 4/11. *)
 
 external compare : 'a -> 'a -> int = "%compare"
 (** [compare x y] returns [0] if [x] is equal to [y],
@@ -115,13 +121,15 @@ external ( == ) : 'a -> 'a -> bool = "%eq"
    also affects [e2].
    On non-mutable types, the behavior of [( == )] is
    implementation-dependent; however, it is guaranteed that
-   [e1 == e2] implies [compare e1 e2 = 0]. *)
+   [e1 == e2] implies [compare e1 e2 = 0].
+   Left-associative operator at precedence level 4/11. *)
 
 external ( != ) : 'a -> 'a -> bool = "%noteq"
-(** Negation of {!Pervasives.( == )}. *)
+(** Negation of {!Pervasives.( == )}.
+    Left-associative operator at precedence level 4/11. *)
 
 
-(** {6 Boolean operations} *)
+(** {1 Boolean operations} *)
 
 external not : bool -> bool = "%boolnot"
 (** The boolean negation. *)
@@ -129,22 +137,27 @@ external not : bool -> bool = "%boolnot"
 external ( && ) : bool -> bool -> bool = "%sequand"
 (** 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. *)
+   [e2] is not evaluated at all.
+   Right-associative operator at precedence level 3/11. *)
 
 external ( & ) : bool -> bool -> bool = "%sequand"
   [@@ocaml.deprecated "Use (&&) instead."]
-(** @deprecated {!Pervasives.( && )} should be used instead. *)
+(** @deprecated {!Pervasives.( && )} should be used instead.
+    Right-associative operator at precedence level 3/11. *)
 
 external ( || ) : bool -> bool -> bool = "%sequor"
 (** 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. *)
+   [e2] is not evaluated at all.
+   Right-associative operator at precedence level 2/11.
+*)
 
 external ( or ) : bool -> bool -> bool = "%sequor"
   [@@ocaml.deprecated "Use (||) instead."]
-(** @deprecated {!Pervasives.( || )} should be used instead.*)
+(** @deprecated {!Pervasives.( || )} should be used instead.
+    Right-associative operator at precedence level 2/11. *)
 
-(** {6 Debugging} *)
+(** {1 Debugging} *)
 
 external __LOC__ : string = "%loc_LOC"
 (** [__LOC__] returns the location at which this expression appears in
@@ -205,31 +218,37 @@ external __POS_OF__ : 'a -> (string * int * int * int) * 'a = "%loc_POS"
     @since 4.02.0
  *)
 
-(** {6 Composition operators} *)
+(** {1 Composition operators} *)
 
 external ( |> ) : 'a -> ('a -> 'b) -> 'b = "%revapply"
 (** Reverse-application operator: [x |> f |> g] is exactly equivalent
  to [g (f (x))].
+ Left-associative operator at precedence level 4/11.
    @since 4.01
-*)
+ *)
 
 external ( @@ ) : ('a -> 'b) -> 'a -> 'b = "%apply"
 (** Application operator: [g @@ f @@ x] is exactly equivalent to
  [g (f (x))].
+ Right-associative operator at precedence level 5/11.
    @since 4.01
 *)
 
-(** {6 Integer arithmetic} *)
+(** {1 Integer arithmetic} *)
 
 (** Integers are 31 bits wide (or 63 bits on 64-bit processors).
    All operations are taken modulo 2{^31} (or 2{^63}).
    They do not fail on overflow. *)
 
 external ( ~- ) : int -> int = "%negint"
-(** Unary negation. You can also write [- e] instead of [~- e]. *)
+(** Unary negation. You can also write [- e] instead of [~- e].
+    Unary operator at precedence level 9/11 for [- e]
+    and 11/11 for [~- e]. *)
 
 external ( ~+ ) : int -> int = "%identity"
 (** Unary addition. You can also write [+ e] instead of [~+ e].
+    Unary operator at precedence level 9/11 for [+ e]
+    and 11/11 for [~+ e].
     @since 3.12.0
 *)
 
@@ -240,13 +259,16 @@ external pred : int -> int = "%predint"
 (** [pred x] is [x - 1]. *)
 
 external ( + ) : int -> int -> int = "%addint"
-(** Integer addition. *)
+(** Integer addition.
+    Left-associative operator at precedence level 6/11. *)
 
 external ( - ) : int -> int -> int = "%subint"
-(** Integer subtraction. *)
+(** Integer subtraction.
+    Left-associative operator at precedence level 6/11. *)
 
 external ( * ) : int -> int -> int = "%mulint"
-(** Integer multiplication. *)
+(** Integer multiplication.
+    Left-associative operator at precedence level 7/11. *)
 
 external ( / ) : int -> int -> int = "%divint"
 (** Integer division.
@@ -254,7 +276,8 @@ external ( / ) : int -> int -> int = "%divint"
    Integer division rounds the real quotient of its arguments towards zero.
    More precisely, if [x >= 0] and [y > 0], [x / y] is the greatest integer
    less than or equal to the real quotient of [x] by [y].  Moreover,
-   [(- x) / y = x / (- y) = - (x / y)].  *)
+   [(- x) / y = x / (- y) = - (x / y)].
+   Left-associative operator at precedence level 7/11. *)
 
 external ( mod ) : int -> int -> int = "%modint"
 (** Integer remainder.  If [y] is not zero, the result
@@ -263,7 +286,8 @@ external ( mod ) : int -> int -> int = "%modint"
    [abs(x mod y) <= abs(y) - 1].
    If [y = 0], [x mod y] raises [Division_by_zero].
    Note that [x mod y] is negative only if [x < 0].
-   Raise [Division_by_zero] if [y] is zero. *)
+   Raise [Division_by_zero] if [y] is zero.
+   Left-associative operator at precedence level 7/11. *)
 
 val abs : int -> int
 (** Return the absolute value of the argument.  Note that this may be
@@ -276,16 +300,19 @@ val min_int : int
 (** The smallest representable integer. *)
 
 
-(** {7 Bitwise operations} *)
+(** {2 Bitwise operations} *)
 
 external ( land ) : int -> int -> int = "%andint"
-(** Bitwise logical and. *)
+(** Bitwise logical and.
+    Left-associative operator at precedence level 7/11. *)
 
 external ( lor ) : int -> int -> int = "%orint"
-(** Bitwise logical or. *)
+(** Bitwise logical or.
+    Left-associative operator at precedence level 7/11. *)
 
 external ( lxor ) : int -> int -> int = "%xorint"
-(** Bitwise logical exclusive or. *)
+(** Bitwise logical exclusive or.
+    Left-associative operator at precedence level 7/11. *)
 
 val lnot : int -> int
 (** Bitwise logical negation. *)
@@ -294,21 +321,24 @@ external ( lsl ) : int -> int -> int = "%lslint"
 (** [n lsl m] shifts [n] to the left by [m] bits.
    The result is unspecified if [m < 0] or [m >= bitsize],
    where [bitsize] is [32] on a 32-bit platform and
-   [64] on a 64-bit platform. *)
+   [64] on a 64-bit platform.
+   Right-associative operator at precedence level 8/11. *)
 
 external ( lsr ) : int -> int -> int = "%lsrint"
 (** [n lsr m] shifts [n] to the right by [m] bits.
    This is a logical shift: zeroes are inserted regardless of
    the sign of [n].
-   The result is unspecified if [m < 0] or [m >= bitsize]. *)
+   The result is unspecified if [m < 0] or [m >= bitsize].
+   Right-associative operator at precedence level 8/11. *)
 
 external ( asr ) : int -> int -> int = "%asrint"
 (** [n asr m] shifts [n] to the right by [m] bits.
    This is an arithmetic shift: the sign bit of [n] is replicated.
-   The result is unspecified if [m < 0] or [m >= bitsize]. *)
+   The result is unspecified if [m < 0] or [m >= bitsize].
+   Right-associative operator at precedence level 8/11. *)
 
 
-(** {6 Floating-point arithmetic}
+(** {1 Floating-point arithmetic}
 
    OCaml's floating-point numbers follow the
    IEEE 754 standard, using double precision (64 bits) numbers.
@@ -323,28 +353,37 @@ external ( asr ) : int -> int -> int = "%asrint"
 *)
 
 external ( ~-. ) : float -> float = "%negfloat"
-(** Unary negation. You can also write [-. e] instead of [~-. e]. *)
+(** Unary negation. You can also write [-. e] instead of [~-. e].
+    Unary operator at precedence level 9/11 for [-. e]
+    and 11/11 for [~-. e]. *)
 
 external ( ~+. ) : float -> float = "%identity"
 (** Unary addition. You can also write [+. e] instead of [~+. e].
+    Unary operator at precedence level 9/11 for [+. e]
+    and 11/11 for [~+. e].
     @since 3.12.0
 *)
 
 external ( +. ) : float -> float -> float = "%addfloat"
-(** Floating-point addition *)
+(** Floating-point addition.
+    Left-associative operator at precedence level 6/11. *)
 
 external ( -. ) : float -> float -> float = "%subfloat"
-(** Floating-point subtraction *)
+(** Floating-point subtraction.
+    Left-associative operator at precedence level 6/11. *)
 
 external ( *. ) : float -> float -> float = "%mulfloat"
-(** Floating-point multiplication *)
+(** Floating-point multiplication.
+    Left-associative operator at precedence level 7/11. *)
 
 external ( /. ) : float -> float -> float = "%divfloat"
-(** Floating-point division. *)
+(** Floating-point division.
+    Left-associative operator at precedence level 7/11. *)
 
 external ( ** ) : float -> float -> float = "caml_power_float" "pow"
   [@@unboxed] [@@noalloc]
-(** Exponentiation. *)
+(** Exponentiation.
+    Right-associative operator at precedence level 8/11. *)
 
 external sqrt : float -> float = "caml_sqrt_float" "sqrt"
   [@@unboxed] [@@noalloc]
@@ -525,16 +564,17 @@ external classify_float : (float [@unboxed]) -> fpclass =
    normal, subnormal, zero, infinite, or not a number. *)
 
 
-(** {6 String operations}
+(** {1 String operations}
 
    More string operations are provided in module {!String}.
 *)
 
 val ( ^ ) : string -> string -> string
-(** String concatenation. *)
+(** String concatenation.
+    Right-associative operator at precedence level 5/11. *)
 
 
-(** {6 Character operations}
+(** {1 Character operations}
 
    More character operations are provided in module {!Char}.
 *)
@@ -548,7 +588,7 @@ val char_of_int : int -> char
    outside the range 0--255. *)
 
 
-(** {6 Unit operations} *)
+(** {1 Unit operations} *)
 
 external ignore : 'a -> unit = "%ignore"
 (** Discard the value of its argument and return [()].
@@ -559,7 +599,7 @@ external ignore : 'a -> unit = "%ignore"
    avoids the warning. *)
 
 
-(** {6 String conversion functions} *)
+(** {1 String conversion functions} *)
 
 val string_of_bool : bool -> string
 (** Return the string representation of a boolean. As the returned values
@@ -583,9 +623,16 @@ val string_of_int : int -> string
 
 external int_of_string : string -> int = "caml_int_of_string"
 (** Convert the given string to an integer.
-   The string is read in decimal (by default), in hexadecimal (if it
-   begins with [0x] or [0X]), in octal (if it begins with [0o] or [0O]),
-   or in binary (if it begins with [0b] or [0B]).
+   The string is read in decimal (by default, or if the string 
+   begins with [0u]), in hexadecimal (if it begins with [0x] or
+   [0X]), in octal (if it begins with [0o] or [0O]), or in binary
+   (if it begins with [0b] or [0B]).
+
+   The [0u] prefix reads the input as an unsigned integer in the range
+   [[0, 2*max_int+1]].  If the input exceeds {!max_int}
+   it is converted to the signed integer
+   [min_int + input - max_int - 1].
+
    The [_] (underscore) character can appear anywhere in the string
    and is ignored.
    Raise [Failure "int_of_string"] if the given string is not
@@ -594,7 +641,7 @@ external int_of_string : string -> int = "caml_int_of_string"
 
 
 val int_of_string_opt: string -> int option
-(** Same as [int_of_string], but returs [None] instead of raising.
+(** Same as [int_of_string], but returns [None] instead of raising.
     @since 4.05
 *)
 
@@ -623,7 +670,7 @@ val float_of_string_opt: string -> float option
     @since 4.05
 *)
 
-(** {6 Pair operations} *)
+(** {1 Pair operations} *)
 
 external fst : 'a * 'b -> 'a = "%field0"
 (** Return the first component of a pair. *)
@@ -632,16 +679,17 @@ external snd : 'a * 'b -> 'b = "%field1"
 (** Return the second component of a pair. *)
 
 
-(** {6 List operations}
+(** {1 List operations}
 
    More list operations are provided in module {!List}.
 *)
 
 val ( @ ) : 'a list -> 'a list -> 'a list
-(** List concatenation.  Not tail-recursive (length of the first argument). *)
+(** List concatenation.  Not tail-recursive (length of the first argument).
+    Right-associative operator at precedence level 5/11. *)
 
 
-(** {6 Input/output}
+(** {1 Input/output}
     Note: all input/output functions can raise [Sys_error] when the system
     calls they invoke fail. *)
 
@@ -661,7 +709,7 @@ val stderr : out_channel
 (** The standard error output for the process. *)
 
 
-(** {7 Output functions on standard output} *)
+(** {2 Output functions on standard output} *)
 
 val print_char : char -> unit
 (** Print a character on standard output. *)
@@ -689,7 +737,7 @@ val print_newline : unit -> unit
    buffering of standard output. *)
 
 
-(** {7 Output functions on standard error} *)
+(** {2 Output functions on standard error} *)
 
 val prerr_char : char -> unit
 (** Print a character on standard error. *)
@@ -716,7 +764,7 @@ val prerr_newline : unit -> unit
    standard error. *)
 
 
-(** {7 Input functions on standard input} *)
+(** {2 Input functions on standard input} *)
 
 val read_line : unit -> string
 (** Flush standard output, then read characters from standard input
@@ -729,7 +777,7 @@ val read_int : unit -> int
    if the line read is not a valid representation of an integer. *)
 
 val read_int_opt: unit -> int option
-(** Same as [read_int_opt], but returs [None] instead of raising.
+(** Same as [read_int_opt], but returns [None] instead of raising.
     @since 4.05
 *)
 
@@ -747,7 +795,7 @@ val read_float_opt: unit -> float option
     @since 4.05.0 *)
 
 
-(** {7 General output functions} *)
+(** {2 General output functions} *)
 
 type open_flag =
     Open_rdonly      (** open for reading. *)
@@ -871,7 +919,7 @@ val set_binary_mode_out : out_channel -> bool -> unit
    do not distinguish between text mode and binary mode. *)
 
 
-(** {7 General input functions} *)
+(** {2 General input functions} *)
 
 val open_in : string -> in_channel
 (** Open the named file for reading, and return a new input channel
@@ -987,7 +1035,7 @@ val set_binary_mode_in : in_channel -> bool -> unit
    do not distinguish between text mode and binary mode. *)
 
 
-(** {7 Operations on large files} *)
+(** {2 Operations on large files} *)
 
 module LargeFile :
   sig
@@ -1006,7 +1054,7 @@ module LargeFile :
   operating on files whose sizes are greater than [max_int]. *)
 
 
-(** {6 References} *)
+(** {1 References} *)
 
 type 'a ref = { mutable contents : 'a }
 (** The type of references (mutable indirection cells) containing
@@ -1017,11 +1065,13 @@ external ref : 'a -> 'a ref = "%makemutable"
 
 external ( ! ) : 'a ref -> 'a = "%field0"
 (** [!r] returns the current contents of reference [r].
-   Equivalent to [fun r -> r.contents]. *)
+   Equivalent to [fun r -> r.contents].
+   Unary operator at precedence level 11/11.*)
 
 external ( := ) : 'a ref -> 'a -> unit = "%setfield0"
 (** [r := a] stores the value of [a] in reference [r].
-   Equivalent to [fun r v -> r.contents <- v]. *)
+   Equivalent to [fun r v -> r.contents <- v].
+   Right-associative operator at precedence level 1/11. *)
 
 external incr : int ref -> unit = "%incr"
 (** Increment the integer contained in the given reference.
@@ -1031,12 +1081,12 @@ external decr : int ref -> unit = "%decr"
 (** Decrement the integer contained in the given reference.
    Equivalent to [fun r -> r := pred !r]. *)
 
-(** {6 Result type} *)
+(** {1 Result type} *)
 
 (** @since 4.03.0 *)
 type ('a,'b) result = Ok of 'a | Error of 'b
 
-(** {6 Operations on format strings} *)
+(** {1 Operations on format strings} *)
 
 (** Format strings are character strings with special lexical conventions
   that defines the functionality of formatted input/output functions. Format
@@ -1135,10 +1185,10 @@ val ( ^^ ) :
   [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].
-*)
+  Right-associative operator at precedence level 5/11. *)
 
 
-(** {6 Program termination} *)
+(** {1 Program termination} *)
 
 val exit : int -> 'a
 (** Terminate the process, returning the given status code
@@ -1150,12 +1200,15 @@ val exit : int -> 'a
    terminates early because of an uncaught exception. *)
 
 val at_exit : (unit -> unit) -> unit
-(** Register the given function to be called at program
-   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 function most recently added with [at_exit] is called first. *)
+(** Register the given function to be called at program termination
+   time. The functions registered with [at_exit] will be called when
+   the program does any of the following:
+   - executes {!Pervasives.exit}
+   - terminates, either normally or because of an uncaught
+     exception
+   - executes the C function [caml_shutdown].
+   The functions are called in 'last in, first out' order: the
+   function most recently added with [at_exit] is called first. *)
 
 (**/**)
 

diff --git a/stdlib/printexc.mli b/stdlib/printexc.mli
index cc865085ca8581bcbc11a0a170280cdc001257e4..873e385f67c231f326e58d8f81ebe86d8a30ab8a 100644 (file)
--- a/stdlib/printexc.mli
+++ b/stdlib/printexc.mli
@@ -92,7 +92,7 @@ val register_printer: (exn -> string option) -> unit
     @since 3.11.2
 *)
 
-(** {6 Raw backtraces} *)
+(** {1 Raw backtraces} *)
 
 type raw_backtrace
 (** The abstract type [raw_backtrace] stores a backtrace in
@@ -140,7 +140,7 @@ external raise_with_backtrace: exn -> raw_backtrace -> 'a
     @since 4.05.0
 *)
 
-(** {6 Current call stack} *)
+(** {1 Current call stack} *)
 
 val get_callstack: int -> raw_backtrace
 (** [Printexc.get_callstack n] returns a description of the top of the
@@ -151,7 +151,7 @@ val get_callstack: int -> raw_backtrace
     @since 4.01.0
 *)
 
-(** {6 Uncaught exceptions} *)
+(** {1 Uncaught exceptions} *)
 
 val set_uncaught_exception_handler: (exn -> raw_backtrace -> unit) -> unit
 (** [Printexc.set_uncaught_exception_handler fn] registers [fn] as the handler
@@ -172,7 +172,7 @@ val set_uncaught_exception_handler: (exn -> raw_backtrace -> unit) -> unit
 *)
 
 
-(** {6 Manipulation of backtrace information}
+(** {1 Manipulation of backtrace information}
 
     These functions are used to traverse the slots of a raw backtrace
     and extract information from them in a programmer-friendly format.
@@ -261,7 +261,7 @@ module Slot : sig
 end
 
 
-(** {6 Raw backtrace slots} *)
+(** {1 Raw backtrace slots} *)
 
 type raw_backtrace_slot
 (** This type allows direct access to raw backtrace slots, without any
@@ -324,7 +324,7 @@ val get_raw_backtrace_next_slot :
     @since 4.04.0
 *)
 
-(** {6 Exception slots} *)
+(** {1 Exception slots} *)
 
 val exn_slot_id: exn -> int
 (** [Printexc.exn_slot_id] returns an integer which uniquely identifies

diff --git a/stdlib/printf.mli b/stdlib/printf.mli
index 92a3b16eaa66da37847d3a50d8800b69c5abc35c..39f7d4f3fc5abb12971b2c69132fe3b838f970d7 100644 (file)
--- a/stdlib/printf.mli
+++ b/stdlib/printf.mli
@@ -56,7 +56,10 @@ val fprintf : out_channel -> ('a, out_channel, unit) format -> 'a
    - [e] or [E]: convert a floating-point argument to decimal notation,
      in the style [d.ddd e+-dd] (mantissa and exponent).
    - [g] or [G]: convert a floating-point argument to decimal notation,
-     in style [f] or [e], [E] (whichever is more compact).
+     in style [f] or [e], [E] (whichever is more compact). Moreover,
+     any trailing zeros are removed from the fractional part of the result
+     and the decimal-point character is removed if there is no fractional
+     part remaining.
    - [h] or [H]: convert a floating-point argument to hexadecimal notation,
      in the style [0xh.hhhh e+-dd] (hexadecimal mantissa, exponent in
      decimal and denotes a power of 2).

diff --git a/stdlib/random.mli b/stdlib/random.mli
index 0cbaace3e936865ec281b3e7b9c22c6b2e1169dd..f8eae5fac90ddc2da127006f97acdd15282f4113 100644 (file)
--- a/stdlib/random.mli
+++ b/stdlib/random.mli
@@ -15,7 +15,7 @@
 
 (** Pseudo-random number generators (PRNG). *)
 
-(** {6 Basic functions} *)
+(** {1 Basic functions} *)
 
 val init : int -> unit
 (** Initialize the generator, using the argument as a seed.
@@ -64,7 +64,7 @@ val bool : unit -> bool
 (** [Random.bool ()] returns [true] or [false] with probability 0.5 each. *)
 
 
-(** {6 Advanced functions} *)
+(** {1 Advanced functions} *)
 
 (** The functions from module {!State} manipulate the current state
     of the random generator explicitly.

diff --git a/stdlib/scanf.ml b/stdlib/scanf.ml
index 7be353a1f307e35805da0eaa8caed64601b5797b..7f12d9a4a443e1137f2a173b773d24f5658e2eeb 100644 (file)
--- a/stdlib/scanf.ml
+++ b/stdlib/scanf.ml
@@ -410,7 +410,7 @@ module Scanning : SCANNING = struct
      More precisely, given [ic], all successive calls [fscanf ic] must read
      from the same scanning buffer.
      This obliged this library to allocated scanning buffers that were
-     not properly garbbage collectable, hence leading to memory leaks.
+     not properly garbage collectable, hence leading to memory leaks.
      If you need to read from a [Pervasives.in_channel] input channel
      [ic], simply define a [Scanning.in_channel] formatted input channel as in
      [let ib = Scanning.from_channel ic], then use [Scanf.bscanf ib] as usual.
@@ -655,7 +655,7 @@ let scan_digit_star digitp width ib =
 
 let scan_digit_plus basis digitp width ib =
   (* Ensure we have got enough width left,
-     and read at list one digit. *)
+     and read at least one digit. *)
   if width = 0 then bad_token_length "digits" else
   let c = Scanning.checked_peek_char ib in
   if digitp c then
@@ -1188,7 +1188,7 @@ let stopper_of_formatting_lit fmting =
 
 
 (******************************************************************************)
-                           (* Readers managment *)
+                           (* Reader management *)
 
 (* A call to take_format_readers on a format is evaluated into functions
    taking readers as arguments and aggregate them into an heterogeneous list *)
@@ -1211,7 +1211,7 @@ fun k fmt -> match fmt with
   | Nativeint (_, _, _, rest)        -> take_format_readers k rest
   | Int64 (_, _, _, rest)            -> take_format_readers k rest
   | Float (_, _, _, rest)            -> take_format_readers k rest
-  | Bool rest                        -> take_format_readers k rest
+  | Bool (_, rest)                   -> take_format_readers k rest
   | Alpha rest                       -> take_format_readers k rest
   | Theta rest                       -> take_format_readers k rest
   | Flush rest                       -> take_format_readers k rest
@@ -1284,7 +1284,7 @@ fun k ign fmt -> match ign with
   | Ignored_nativeint (_, _)        -> take_format_readers k fmt
   | Ignored_int64 (_, _)            -> take_format_readers k fmt
   | Ignored_float (_, _)            -> take_format_readers k fmt
-  | Ignored_bool                    -> take_format_readers k fmt
+  | Ignored_bool _                  -> take_format_readers k fmt
   | Ignored_format_arg _            -> take_format_readers k fmt
   | Ignored_format_subst (_, fmtty) -> take_fmtty_format_readers k fmtty fmt
   | Ignored_scan_char_set _         -> take_format_readers k fmt
@@ -1296,7 +1296,7 @@ fun k ign fmt -> match ign with
 
 (* Make a generic scanning function. *)
 (* Scan a stream according to a format and readers obtained by
-   take_format_readers, and aggegate scanned values into an
+   take_format_readers, and aggregate scanned values into an
    heterogeneous list. *)
 (* Return the heterogeneous list of scanned values. *)
 let rec make_scanf : type a c d e f.
@@ -1357,10 +1357,9 @@ fun ib fmt readers -> match fmt with
   | Float ((Float_h | Float_ph | Float_sh | Float_H | Float_pH | Float_sH),
            pad, prec, rest) ->
     pad_prec_scanf ib rest readers pad prec scan_hex_float token_float
-  | Bool rest ->
-    let _ = scan_bool ib in
-    let b = token_bool ib in
-    Cons (b, make_scanf ib rest readers)
+  | Bool (pad, rest) ->
+    let scan _ _ ib = scan_bool ib in
+    pad_prec_scanf ib rest readers pad No_precision scan token_bool
   | Alpha _ ->
     invalid_arg "scanf: bad conversion \"%a\""
   | Theta _ ->
@@ -1372,7 +1371,7 @@ fun ib fmt readers -> match fmt with
     | Cons (reader, readers_rest) ->
         let x = reader ib in
         Cons (x, make_scanf ib fmt_rest readers_rest)
-    | Nil -> 
+    | Nil ->
         invalid_arg "scanf: missing reader"
     end
   | Flush rest ->

diff --git a/stdlib/scanf.mli b/stdlib/scanf.mli
index ea0d4ce7528ad76eb262a0b5a598d4c5006f0258..c3d2a6a8aaa5402ddd347ac2a64ae1931c9558be 100644 (file)
--- a/stdlib/scanf.mli
+++ b/stdlib/scanf.mli
@@ -15,9 +15,9 @@
 
 (** Formatted input functions. *)
 
-(** {6 Introduction} *)
+(** {1 Introduction} *)
 
-(** {7 Functional input with format strings} *)
+(** {2 Functional input with format strings} *)
 
 (** The module {!Scanf} provides formatted input functions or {e scanners}.
 
@@ -48,7 +48,7 @@
     read in the input according to [fmt].
 *)
 
-(** {7 A simple example} *)
+(** {2 A simple example} *)
 
 (** As suggested above, the expression [bscanf ic "%d" f] reads a decimal
     integer [n] from the source of characters [ic] and returns [f n].
@@ -66,7 +66,7 @@
     keyboard, the result we get is [42].
 *)
 
-(** {7 Formatted input as a functional feature} *)
+(** {2 Formatted input as a functional feature} *)
 
 (** The OCaml scanning facility is reminiscent of the corresponding C feature.
     However, it is also largely different, simpler, and yet more powerful:
@@ -81,7 +81,7 @@
     facility is fully type-checked at compile time.
 *)
 
-(** {6 Formatted input channel} *)
+(** {1 Formatted input channel} *)
 
 module Scanning : sig
 
@@ -203,7 +203,7 @@ val stdib : in_channel
 
 end
 
-(** {6 Type of formatted input functions} *)
+(** {1 Type of formatted input functions} *)
 
 type ('a, 'b, 'c, 'd) scanner =
      ('a, Scanning.in_channel, 'b, 'c, 'a -> 'd, 'd) format6 -> 'c
@@ -218,7 +218,7 @@ type ('a, 'b, 'c, 'd) scanner =
     For instance, the {!Scanf.scanf} function below has type
     [('a, 'b, 'c, 'd) scanner], since it is a formatted input function that
     reads from {!Scanning.stdin}: [scanf fmt f] applies [f] to the arguments
-    specified by [fmt], reading those arguments from [!Pervasives.stdin] as
+    specified by [fmt], reading those arguments from {!Pervasives.stdin} as
     expected.
 
     If the format [fmt] has some [%r] indications, the corresponding
@@ -235,7 +235,7 @@ exception Scan_failure of string
     [Scan_failure].
 *)
 
-(** {6 The general formatted input function} *)
+(** {1 The general formatted input function} *)
 
 val bscanf : Scanning.in_channel -> ('a, 'b, 'c, 'd) scanner
 
@@ -253,7 +253,7 @@ val bscanf : Scanning.in_channel -> ('a, 'b, 'c, 'd) scanner
     string.
 *)
 
-(** {6 Format string description} *)
+(** {1 Format string description} *)
 
 (** The format string is a character string which contains three types of
     objects:
@@ -265,7 +265,7 @@ val bscanf : Scanning.in_channel -> ('a, 'b, 'c, 'd) scanner
       (see scanning {!Scanf.indication}).
 *)
 
-(** {7:space The space character in format strings} *)
+(** {2:space The space character in format strings} *)
 
 (** As mentioned above, a plain character in the format string is just
     matched with the next character of the input; however, two characters are
@@ -285,7 +285,7 @@ val bscanf : Scanning.in_channel -> ('a, 'b, 'c, 'd) scanner
     [Price  =  1    $], or even [Price=1$].
 *)
 
-(** {7:conversion Conversion specifications in format strings} *)
+(** {2:conversion Conversion specifications in format strings} *)
 
 (** Conversion specifications consist in the [%] character, followed by
     an optional flag, an optional field width, and followed by one or
@@ -414,7 +414,7 @@ val bscanf : Scanning.in_channel -> ('a, 'b, 'c, 'd) scanner
     [ocamlyacc]-generated parsers.
 *)
 
-(** {7:indication Scanning indications in format strings} *)
+(** {2:indication Scanning indications in format strings} *)
 
 (** Scanning indications appear just after the string conversions [%s]
     and [%[ range ]] to delimit the end of the token. A scanning
@@ -443,7 +443,7 @@ val bscanf : Scanning.in_channel -> ('a, 'b, 'c, 'd) scanner
     characters).
 *)
 
-(** {7 Exceptions during scanning} *)
+(** {2 Exceptions during scanning} *)
 
 (** Scanners may raise the following exceptions when the input cannot be read
     according to the format string:
@@ -464,7 +464,7 @@ val bscanf : Scanning.in_channel -> ('a, 'b, 'c, 'd) scanner
     simply returns the characters read so far, or [""] if none were ever read.
 *)
 
-(** {6 Specialised formatted input functions} *)
+(** {1 Specialised formatted input functions} *)
 
 val sscanf : string -> ('a, 'b, 'c, 'd) scanner
 (** Same as {!Scanf.bscanf}, but reads from the given string. *)
@@ -490,7 +490,7 @@ val ksscanf :
 (** Same as {!Scanf.kscanf} but reads from the given string.
     @since 4.02.0 *)
 
-(** {6 Reading format strings from input} *)
+(** {1 Reading format strings from input} *)
 
 val bscanf_format :
   Scanning.in_channel -> ('a, 'b, 'c, 'd, 'e, 'f) format6 ->
@@ -535,7 +535,7 @@ val unescaped : string -> string
     @since 4.00.0
 *)
 
-(** {6 Deprecated} *)
+(** {1 Deprecated} *)
 
 val fscanf : Pervasives.in_channel -> ('a, 'b, 'c, 'd) scanner
   [@@ocaml.deprecated "Use Scanning.from_channel then Scanf.bscanf."]

diff --git a/stdlib/set.ml b/stdlib/set.ml
index abfa41edbdba5520344bba68a47b64636647d7f8..b3cbda47d20edd732c23e89f8cee8da7d0b9d66d 100644 (file)
--- a/stdlib/set.ml
+++ b/stdlib/set.ml
@@ -65,14 +65,14 @@ module type S =
 module Make(Ord: OrderedType) =
   struct
     type elt = Ord.t
-    type t = Empty | Node of t * elt * t * int
+    type t = Empty | Node of {l:t; v:elt; r:t; h:int}
 
     (* Sets are represented by balanced binary trees (the heights of the
        children differ by at most 2 *)
 
     let height = function
         Empty -> 0
-      | Node(_, _, _, h) -> h
+      | Node {h} -> h
 
     (* Creates a new node with left son l, value v and right son r.
        We must have all elements of l < v < all elements of r.
@@ -80,9 +80,9 @@ module Make(Ord: OrderedType) =
        Inline expansion of height for better speed. *)
 
     let create l v r =
-      let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h in
-      let hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in
-      Node(l, v, r, (if hl >= hr then hl + 1 else hr + 1))
+      let hl = match l with Empty -> 0 | Node {h} -> h in
+      let hr = match r with Empty -> 0 | Node {h} -> h in
+      Node{l; v; r; h=(if hl >= hr then hl + 1 else hr + 1)}
 
     (* Same as create, but performs one step of rebalancing if necessary.
        Assumes l and r balanced and | height l - height r | <= 3.
@@ -90,40 +90,40 @@ module Make(Ord: OrderedType) =
        where no rebalancing is required. *)
 
     let bal l v r =
-      let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h in
-      let hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in
+      let hl = match l with Empty -> 0 | Node {h} -> h in
+      let hr = match r with Empty -> 0 | Node {h} -> h in
       if hl > hr + 2 then begin
         match l with
           Empty -> invalid_arg "Set.bal"
-        | Node(ll, lv, lr, _) ->
+        | Node{l=ll; v=lv; r=lr} ->
             if height ll >= height lr then
               create ll lv (create lr v r)
             else begin
               match lr with
                 Empty -> invalid_arg "Set.bal"
-              | Node(lrl, lrv, lrr, _)->
+              | Node{l=lrl; v=lrv; r=lrr}->
                   create (create ll lv lrl) lrv (create lrr v r)
             end
       end else if hr > hl + 2 then begin
         match r with
           Empty -> invalid_arg "Set.bal"
-        | Node(rl, rv, rr, _) ->
+        | Node{l=rl; v=rv; r=rr} ->
             if height rr >= height rl then
               create (create l v rl) rv rr
             else begin
               match rl with
                 Empty -> invalid_arg "Set.bal"
-              | Node(rll, rlv, rlr, _) ->
+              | Node{l=rll; v=rlv; r=rlr} ->
                   create (create l v rll) rlv (create rlr rv rr)
             end
       end else
-        Node(l, v, r, (if hl >= hr then hl + 1 else hr + 1))
+        Node{l; v; r; h=(if hl >= hr then hl + 1 else hr + 1)}
 
     (* Insertion of one element *)
 
     let rec add x = function
-        Empty -> Node(Empty, x, Empty, 1)
-      | Node(l, v, r, _) as t ->
+        Empty -> Node{l=Empty; v=x; r=Empty; h=1}
+      | Node{l; v; r} as t ->
           let c = Ord.compare x v in
           if c = 0 then t else
           if c < 0 then
@@ -133,7 +133,7 @@ module Make(Ord: OrderedType) =
             let rr = add x r in
             if r == rr then t else bal l v rr
 
-    let singleton x = Node(Empty, x, Empty, 1)
+    let singleton x = Node{l=Empty; v=x; r=Empty; h=1}
 
     (* Beware: those two functions assume that the added v is *strictly*
        smaller (or bigger) than all the present elements in the tree; it
@@ -142,15 +142,15 @@ module Make(Ord: OrderedType) =
        respects this precondition.
     *)
 
-    let rec add_min_element v = function
-      | Empty -> singleton v
-      | Node (l, x, r, _h) ->
-        bal (add_min_element v l) x r
+    let rec add_min_element x = function
+      | Empty -> singleton x
+      | Node {l; v; r} ->
+        bal (add_min_element x l) v r
 
-    let rec add_max_element v = function
-      | Empty -> singleton v
-      | Node (l, x, r, _h) ->
-        bal l x (add_max_element v r)
+    let rec add_max_element x = function
+      | Empty -> singleton x
+      | Node {l; v; r} ->
+        bal l v (add_max_element x r)
 
     (* Same as create and bal, but no assumptions are made on the
        relative heights of l and r. *)
@@ -159,7 +159,7 @@ module Make(Ord: OrderedType) =
       match (l, r) with
         (Empty, _) -> add_min_element v r
       | (_, Empty) -> add_max_element v l
-      | (Node(ll, lv, lr, lh), Node(rl, rv, rr, rh)) ->
+      | (Node{l=ll; v=lv; r=lr; h=lh}, Node{l=rl; v=rv; r=rr; h=rh}) ->
           if lh > rh + 2 then bal ll lv (join lr v r) else
           if rh > lh + 2 then bal (join l v rl) rv rr else
           create l v r
@@ -168,30 +168,30 @@ module Make(Ord: OrderedType) =
 
     let rec min_elt = function
         Empty -> raise Not_found
-      | Node(Empty, v, _, _) -> v
-      | Node(l, _, _, _) -> min_elt l
+      | Node{l=Empty; v} -> v
+      | Node{l} -> min_elt l
 
     let rec min_elt_opt = function
         Empty -> None
-      | Node(Empty, v, _, _) -> Some v
-      | Node(l, _, _, _) -> min_elt_opt l
+      | Node{l=Empty; v} -> Some v
+      | Node{l} -> min_elt_opt l
 
     let rec max_elt = function
         Empty -> raise Not_found
-      | Node(_, v, Empty, _) -> v
-      | Node(_, _, r, _) -> max_elt r
+      | Node{v; r=Empty} -> v
+      | Node{r} -> max_elt r
 
     let rec max_elt_opt = function
         Empty -> None
-      | Node(_, v, Empty, _) -> Some v
-      | Node(_, _, r, _) -> max_elt_opt r
+      | Node{v; r=Empty} -> Some v
+      | Node{r} -> max_elt_opt r
 
     (* Remove the smallest element of the given set *)
 
     let rec remove_min_elt = function
         Empty -> invalid_arg "Set.remove_min_elt"
-      | Node(Empty, _, r, _) -> r
-      | Node(l, v, r, _) -> bal (remove_min_elt l) v r
+      | Node{l=Empty; r} -> r
+      | Node{l; v; r} -> bal (remove_min_elt l) v r
 
     (* Merge two trees l and r into one.
        All elements of l must precede the elements of r.
@@ -222,7 +222,7 @@ module Make(Ord: OrderedType) =
     let rec split x = function
         Empty ->
           (Empty, false, Empty)
-      | Node(l, v, r, _) ->
+      | Node{l; v; r} ->
           let c = Ord.compare x v in
           if c = 0 then (l, true, r)
           else if c < 0 then
@@ -238,13 +238,13 @@ module Make(Ord: OrderedType) =
 
     let rec mem x = function
         Empty -> false
-      | Node(l, v, r, _) ->
+      | Node{l; v; r} ->
           let c = Ord.compare x v in
           c = 0 || mem x (if c < 0 then l else r)
 
     let rec remove x = function
         Empty -> Empty
-      | (Node(l, v, r, _) as t) ->
+      | (Node{l; v; r} as t) ->
           let c = Ord.compare x v in
           if c = 0 then merge l r
           else
@@ -261,7 +261,7 @@ module Make(Ord: OrderedType) =
       match (s1, s2) with
         (Empty, t2) -> t2
       | (t1, Empty) -> t1
-      | (Node(l1, v1, r1, h1), Node(l2, v2, r2, h2)) ->
+      | (Node{l=l1; v=v1; r=r1; h=h1}, Node{l=l2; v=v2; r=r2; h=h2}) ->
           if h1 >= h2 then
             if h2 = 1 then add v2 s1 else begin
               let (l2, _, r2) = split v1 s2 in
@@ -277,7 +277,7 @@ module Make(Ord: OrderedType) =
       match (s1, s2) with
         (Empty, _) -> Empty
       | (_, Empty) -> Empty
-      | (Node(l1, v1, r1, _), t2) ->
+      | (Node{l=l1; v=v1; r=r1}, t2) ->
           match split v1 t2 with
             (l2, false, r2) ->
               concat (inter l1 l2) (inter r1 r2)
@@ -288,7 +288,7 @@ module Make(Ord: OrderedType) =
       match (s1, s2) with
         (Empty, _) -> Empty
       | (t1, Empty) -> t1
-      | (Node(l1, v1, r1, _), t2) ->
+      | (Node{l=l1; v=v1; r=r1}, t2) ->
           match split v1 t2 with
             (l2, false, r2) ->
               join (diff l1 l2) v1 (diff r1 r2)
@@ -300,7 +300,7 @@ module Make(Ord: OrderedType) =
     let rec cons_enum s e =
       match s with
         Empty -> e
-      | Node(l, v, r, _) -> cons_enum l (More(v, r, e))
+      | Node{l; v; r} -> cons_enum l (More(v, r, e))
 
     let rec compare_aux e1 e2 =
         match (e1, e2) with
@@ -325,35 +325,35 @@ module Make(Ord: OrderedType) =
           true
       | _, Empty ->
           false
-      | Node (l1, v1, r1, _), (Node (l2, v2, r2, _) as t2) ->
+      | Node {l=l1; v=v1; r=r1}, (Node {l=l2; v=v2; r=r2} as t2) ->
           let c = Ord.compare v1 v2 in
           if c = 0 then
             subset l1 l2 && subset r1 r2
           else if c < 0 then
-            subset (Node (l1, v1, Empty, 0)) l2 && subset r1 t2
+            subset (Node {l=l1; v=v1; r=Empty; h=0}) l2 && subset r1 t2
           else
-            subset (Node (Empty, v1, r1, 0)) r2 && subset l1 t2
+            subset (Node {l=Empty; v=v1; r=r1; h=0}) r2 && subset l1 t2
 
     let rec iter f = function
         Empty -> ()
-      | Node(l, v, r, _) -> iter f l; f v; iter f r
+      | Node{l; v; r} -> iter f l; f v; iter f r
 
     let rec fold f s accu =
       match s with
         Empty -> accu
-      | Node(l, v, r, _) -> fold f r (f v (fold f l accu))
+      | Node{l; v; r} -> fold f r (f v (fold f l accu))
 
     let rec for_all p = function
         Empty -> true
-      | Node(l, v, r, _) -> p v && for_all p l && for_all p r
+      | Node{l; v; r} -> p v && for_all p l && for_all p r
 
     let rec exists p = function
         Empty -> false
-      | Node(l, v, r, _) -> p v || exists p l || exists p r
+      | Node{l; v; r} -> p v || exists p l || exists p r
 
     let rec filter p = function
         Empty -> Empty
-      | (Node(l, v, r, _)) as t ->
+      | (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
@@ -364,7 +364,7 @@ module Make(Ord: OrderedType) =
 
     let rec partition p = function
         Empty -> (Empty, Empty)
-      | Node(l, v, r, _) ->
+      | Node{l; v; r} ->
           (* call [p] in the expected left-to-right order *)
           let (lt, lf) = partition p l in
           let pv = p v in
@@ -375,11 +375,11 @@ module Make(Ord: OrderedType) =
 
     let rec cardinal = function
         Empty -> 0
-      | Node(l, _, r, _) -> cardinal l + 1 + cardinal r
+      | Node{l; r} -> cardinal l + 1 + cardinal r
 
     let rec elements_aux accu = function
         Empty -> accu
-      | Node(l, v, r, _) -> elements_aux (v :: elements_aux accu r) l
+      | Node{l; v; r} -> elements_aux (v :: elements_aux accu r) l
 
     let elements s =
       elements_aux [] s
@@ -390,7 +390,7 @@ module Make(Ord: OrderedType) =
 
     let rec find x = function
         Empty -> raise Not_found
-      | Node(l, v, r, _) ->
+      | Node{l; v; r} ->
           let c = Ord.compare x v in
           if c = 0 then v
           else find x (if c < 0 then l else r)
@@ -398,7 +398,7 @@ module Make(Ord: OrderedType) =
     let rec find_first_aux v0 f = function
         Empty ->
           v0
-      | Node(l, v, r, _) ->
+      | Node{l; v; r} ->
           if f v then
             find_first_aux v f l
           else
@@ -407,7 +407,7 @@ module Make(Ord: OrderedType) =
     let rec find_first f = function
         Empty ->
           raise Not_found
-      | Node(l, v, r, _) ->
+      | Node{l; v; r} ->
           if f v then
             find_first_aux v f l
           else
@@ -416,7 +416,7 @@ module Make(Ord: OrderedType) =
     let rec find_first_opt_aux v0 f = function
         Empty ->
           Some v0
-      | Node(l, v, r, _) ->
+      | Node{l; v; r} ->
           if f v then
             find_first_opt_aux v f l
           else
@@ -425,7 +425,7 @@ module Make(Ord: OrderedType) =
     let rec find_first_opt f = function
         Empty ->
           None
-      | Node(l, v, r, _) ->
+      | Node{l; v; r} ->
           if f v then
             find_first_opt_aux v f l
           else
@@ -434,7 +434,7 @@ module Make(Ord: OrderedType) =
     let rec find_last_aux v0 f = function
         Empty ->
           v0
-      | Node(l, v, r, _) ->
+      | Node{l; v; r} ->
           if f v then
             find_last_aux v f r
           else
@@ -443,7 +443,7 @@ module Make(Ord: OrderedType) =
     let rec find_last f = function
         Empty ->
           raise Not_found
-      | Node(l, v, r, _) ->
+      | Node{l; v; r} ->
           if f v then
             find_last_aux v f r
           else
@@ -452,7 +452,7 @@ module Make(Ord: OrderedType) =
     let rec find_last_opt_aux v0 f = function
         Empty ->
           Some v0
-      | Node(l, v, r, _) ->
+      | Node{l; v; r} ->
           if f v then
             find_last_opt_aux v f r
           else
@@ -461,7 +461,7 @@ module Make(Ord: OrderedType) =
     let rec find_last_opt f = function
         Empty ->
           None
-      | Node(l, v, r, _) ->
+      | Node{l; v; r} ->
           if f v then
             find_last_opt_aux v f r
           else
@@ -469,7 +469,7 @@ module Make(Ord: OrderedType) =
 
     let rec find_opt x = function
         Empty -> None
-      | Node(l, v, r, _) ->
+      | Node{l; v; r} ->
           let c = Ord.compare x v in
           if c = 0 then Some v
           else find_opt x (if c < 0 then l else r)
@@ -485,7 +485,7 @@ module Make(Ord: OrderedType) =
 
     let rec map f = function
       | Empty -> Empty
-      | Node (l, v, r, _) as t ->
+      | Node{l; v; r} as t ->
          (* enforce left-to-right evaluation order *)
          let l' = map f l in
          let v' = f v in
@@ -497,10 +497,12 @@ module Make(Ord: OrderedType) =
       let rec sub n l =
         match n, l with
         | 0, l -> Empty, l
-        | 1, x0 :: l -> Node (Empty, x0, Empty, 1), l
-        | 2, x0 :: x1 :: l -> Node (Node(Empty, x0, Empty, 1), x1, Empty, 2), l
+        | 1, x0 :: l -> Node {l=Empty; v=x0; r=Empty; h=1}, l
+        | 2, x0 :: x1 :: l ->
+            Node{l=Node{l=Empty; v=x0; r=Empty; h=1}; v=x1; r=Empty; h=2}, l
         | 3, x0 :: x1 :: x2 :: l ->
-            Node (Node(Empty, x0, Empty, 1), x1, Node(Empty, x2, Empty, 1), 2),l
+            Node{l=Node{l=Empty; v=x0; r=Empty; h=1}; v=x1;
+                 r=Node{l=Empty; v=x2; r=Empty; h=1}; h=2}, l
         | n, l ->
           let nl = n / 2 in
           let left, l = sub nl l in

diff --git a/stdlib/spacetime.mli b/stdlib/spacetime.mli
index d0bbac8be199f4f1a9218be1d44882a807fda9b2..1f770905d761211882440a8c1a6293917fa1a4f8 100644 (file)
--- a/stdlib/spacetime.mli
+++ b/stdlib/spacetime.mli
@@ -71,7 +71,7 @@ module Series : sig
   val save_event : ?time:float -> t -> event_name:string -> unit
 
   (** [save_and_close series] writes information into [series] required for
-      interpeting the snapshots that [series] contains and then closes the
+      interpreting the snapshots that [series] contains and then closes the
       [series] file. This function must be called to produce a valid series
       file.
       The optional [time] parameter is as for {!Snapshot.take}.

diff --git a/stdlib/stream.mli b/stdlib/stream.mli
index 03b34a04b8980e9c02b06da78f7b73cabb2a7a25..e52bab89615c129cf90e1fe85f4117167ecd32eb 100644 (file)
--- a/stdlib/stream.mli
+++ b/stdlib/stream.mli
@@ -27,7 +27,7 @@ exception Error of string
    accepted, but one of the following components is rejected. *)
 
 
-(** {6 Stream builders} *)
+(** {1 Stream builders} *)
 
 val from : (int -> 'a option) -> 'a t
 (** [Stream.from f] returns a stream built from the function [f].
@@ -56,14 +56,14 @@ val of_channel : in_channel -> char t
 (** Return the stream of the characters read from the input channel. *)
 
 
-(** {6 Stream iterator} *)
+(** {1 Stream iterator} *)
 
 val iter : ('a -> unit) -> 'a t -> unit
 (** [Stream.iter f s] scans the whole stream s, applying function [f]
    in turn to each stream element encountered. *)
 
 
-(** {6 Predefined parsers} *)
+(** {1 Predefined parsers} *)
 
 val next : 'a t -> 'a
 (** Return the first element of the stream and remove it from the
@@ -73,7 +73,7 @@ val empty : 'a t -> unit
 (** Return [()] if the stream is empty, else raise {!Stream.Failure}. *)
 
 
-(** {6 Useful functions} *)
+(** {1 Useful functions} *)
 
 val peek : 'a t -> 'a option
 (** Return [Some] of "the first element" of the stream, or [None] if

diff --git a/stdlib/stringLabels.mli b/stdlib/stringLabels.mli
index 41c5951d759143e213d4432a8cb3bff2afccedc8..f249d4397fb3ea8ad214f3ae94a9c2a4af20d43b 100644 (file)
--- a/stdlib/stringLabels.mli
+++ b/stdlib/stringLabels.mli
@@ -56,7 +56,7 @@ val init : int -> f:(int -> char) -> string
    Raise [Invalid_argument] if [n < 0] or [n > ]{!Sys.max_string_length}.
    @since 4.02.0 *)
 
-val copy : string -> string
+val copy : string -> string  [@@ocaml.deprecated]
 (** Return a copy of the given string. *)
 
 val sub : string -> pos:int -> len:int -> string

diff --git a/stdlib/sys.mli b/stdlib/sys.mli
index 2359d41b8567328c04908aabf7d5a451512a08d8..3c86a14473b58b6c803aca358cd58db9ecf6a856 100644 (file)
--- a/stdlib/sys.mli
+++ b/stdlib/sys.mli
@@ -43,10 +43,14 @@ external remove : string -> unit = "caml_sys_remove"
 (** Remove the given file name from the file system. *)
 
 external rename : string -> string -> unit = "caml_sys_rename"
-(** Rename a file. The first argument is the old name and the
-   second is the new name. If there is already another file
-   under the new name, [rename] may replace it, or raise an
-   exception, depending on your operating system. *)
+(** Rename a file.  [rename oldpath newpath] renames the file
+    called [oldpath], giving it [newpath] as its new name,
+    moving it between directories if needed.  If [newpath] already
+    exists, its contents will be replaced with those of [oldpath].
+    Depending on the operating system, the metadata (permissions,
+    owner, etc) of [newpath] can either be preserved or be replaced by
+    those of [oldpath].
+   @since 4.06 concerning the "replace existing file" behavior *)
 
 external getenv : string -> string = "caml_sys_getenv"
 (** Return the value associated to a variable in the process
@@ -155,7 +159,7 @@ external runtime_parameters : unit -> string = "caml_runtime_parameters"
     @since 4.03.0 *)
 
 
-(** {6 Signal handling} *)
+(** {1 Signal handling} *)
 
 
 type signal_behavior =
@@ -181,7 +185,7 @@ val set_signal : int -> signal_behavior -> unit
 (** Same as {!Sys.signal} but return value is ignored. *)
 
 
-(** {7 Signal numbers for the standard POSIX signals.} *)
+(** {2 Signal numbers for the standard POSIX signals.} *)
 
 val sigabrt : int
 (** Abnormal termination *)
@@ -309,7 +313,7 @@ val runtime_warnings_enabled: unit -> bool
 
     @since 4.03.0 *)
 
-(** {6 Optimization} *)
+(** {1 Optimization} *)
 
 external opaque_identity : 'a -> 'a = "%opaque"
 (** For the purposes of optimization, [opaque_identity] behaves like an

diff --git a/stdlib/uchar.ml b/stdlib/uchar.ml
index a2b7fe3adb65413b07dd44c19243c5bd35853e67..e4a40f65b2b201364160187c8a71edd5c2be1658 100644 (file)
--- a/stdlib/uchar.ml
+++ b/stdlib/uchar.ml
@@ -27,6 +27,9 @@ let max = 0x10FFFF
 let lo_bound = 0xD7FF
 let hi_bound = 0xE000
 
+let bom = 0xFEFF
+let rep = 0xFFFD
+
 let succ u =
   if u = lo_bound then hi_bound else
   if u = max then invalid_arg err_no_succ else

diff --git a/stdlib/uchar.mli b/stdlib/uchar.mli
index 5ea47c9d439721970e4b24490b34561313f98e80..c8b63bdbd501231a83dfe86e47665b324e081847 100644 (file)
--- a/stdlib/uchar.mli
+++ b/stdlib/uchar.mli
@@ -31,6 +31,20 @@ val min : t
 val max : t
 (** [max] is U+10FFFF. *)
 
+val bom : t
+(** [bom] is U+FEFF, the
+    {{:http://unicode.org/glossary/#byte_order_mark}byte order mark} (BOM)
+    character.
+
+    @since 4.06.0 *)
+
+val rep : t
+(** [rep] is U+FFFD, the
+    {{:http://unicode.org/glossary/#replacement_character}replacement}
+    character.
+
+    @since 4.06.0 *)
+
 val succ : t -> t
 (** [succ u] is the scalar value after [u] in the set of Unicode scalar
     values.

diff --git a/stdlib/weak.mli b/stdlib/weak.mli
index 951cd9c04ea9ffd6903804e1f71f50456fd65000..842520aa10db53bf002c55a0837fa1df6f4dc4f1 100644 (file)
--- a/stdlib/weak.mli
+++ b/stdlib/weak.mli
@@ -16,7 +16,7 @@
 (** Arrays of weak pointers and hash sets of weak pointers. *)
 
 
-(** {6 Low-level functions} *)
+(** {1 Low-level functions} *)
 
 type 'a t
 (** The type of arrays of weak pointers (weak arrays).  A weak
@@ -92,7 +92,7 @@ val blit : 'a t -> int -> 'a t -> int -> int -> unit
    do not designate a valid subarray of [ar2].*)
 
 
-(** {6 Weak hash sets} *)
+(** {1 Weak hash sets} *)
 
 (** A weak hash set is a hashed set of values.  Each value may
     magically disappear from the set when it is not used by the

diff --git a/testsuite/HACKING.adoc b/testsuite/HACKING.adoc
index 71259057b32d8a5f917729704c7f605796461a0d..f634cda705571cd17bd996fa0fa23115acb5472c 100644 (file)
--- a/testsuite/HACKING.adoc
+++ b/testsuite/HACKING.adoc
@@ -8,4 +8,6 @@
 
 `make all-foo`, `make parallel-foo`:: runs only the tests in the directories whose name starts with `foo`: `parallel-typing`, `all-lib`, etc.
 
-`make one DIR=tests/foo`:: runs only the tests in the directory `tests/foo`. This is often equivalent to `cd tests/foo && make`, but sometimes the latter breaks the test makefile if it contains fragile relative filesystem paths. Such errors should be fixed if you find them, but `make one DIR=...` is the more reliable option as it runs exactly as `make all` which is heavily tested.
\ No newline at end of file
+`make one DIR=tests/foo`:: runs only the tests in the directory `tests/foo`. This is often equivalent to `cd tests/foo && make`, but sometimes the latter breaks the test makefile if it contains fragile relative filesystem paths. Such errors should be fixed if you find them, but `make one DIR=...` is the more reliable option as it runs exactly as `make all` which is heavily tested.
+
+`make promote DIR=tests/foo`:: most test run a program and compare the result of the program, store in a file `foo.result`, with a reference output stored in `foo.reference` -- the test fails if the two output differ. Sometimes a change in result is innocuous, it comes from an intended change in output instead of a regression. `make promote` copies the new result file into the reference file, making the test pass again. Whenever you use this rule please check carefully, using `git diff`, that the change really corresponds to an intended output difference, and not to a regression. You then need to commit the change to reference file, and your commit message should explain why the output changed.

diff --git a/testsuite/Makefile b/testsuite/Makefile
index 828272b2a44005321b04db4a8d1f5229e718dd69..0a7325bcf33187fe95b561ef30bb1dd751f2f2d2 100644 (file)
--- a/testsuite/Makefile
+++ b/testsuite/Makefile
@@ -20,10 +20,41 @@ NO_PRINT=`$(MAKE) empty --no-print-directory >/dev/null 2>&1 \
 FIND=find
 include ../config/Makefile
 
+ifeq "$(UNIX_OR_WIN32)" "unix"
+  ifeq "$(SYSTEM)" "cygwin"
+    find := /usr/bin/find
+  else # Non-cygwin Unix
+    find := find
+  endif
+else # Windows
+  find := /usr/bin/find
+  FLEXDLL_SUBMODULE_PRESENT := $(wildcard ../flexdll/Makefile)
+  ifeq "$(FLEXDLL_SUBMODULE_PRESENT)" ""
+    FLEXLINK_PREFIX=
+  else
+    ROOT:=$(shell cd .. && pwd| cygpath -m -f -)
+    EMPTY=
+    FLEXLINK_PREFIX:=OCAML_FLEXLINK="$(ROOT)/boot/ocamlrun \
+                                     $(ROOT)/flexdll/flexlink.exe" $(EMPTY)
+  endif
+endif
+
+failstamp := failure.stamp
+
+ocamltest_directory := ../ocamltest
+
+ocamltest_program := $(or \
+  $(wildcard $(ocamltest_directory)/ocamltest.opt$(EXE)),\
+  $(wildcard $(ocamltest_directory)/ocamltest$(EXE)))
+
+ocamltest := $(FLEXLINK_PREFIX) $(ocamltest_program)
+
 .PHONY: default
 default:
        @echo "Available targets:"
        @echo "  all             launch all tests"
+       @echo "  legacy          launch legacy tests"
+       @echo "  new             launch new (ocamltest based) tests"
        @echo "  all-foo         launch all tests beginning with foo"
        @echo "  parallel        launch all tests using GNU parallel"
        @echo "  parallel-foo    launch all tests beginning with foo using \
@@ -41,12 +72,44 @@ default:
        @echo "(default value = $(MAX_TESTSUITE_DIR_RETRIES))"
 
 .PHONY: all
-all: lib tools
+all:
+       @rm -f _log
+       @$(MAKE) $(NO_PRINT) legacy-without-report
+       @$(MAKE) $(NO_PRINT) new-without-report
+       @$(MAKE) $(NO_PRINT) report
+
+.PHONY: legacy
+legacy:
+       @rm -f _log
+       @$(MAKE) $(NO_PRINT) legacy-without-report
+       @$(MAKE) $(NO_PRINT) report
+
+.PHONY: legacy-without-report
+legacy-without-report: lib tools
        @for dir in tests/*; do \
          $(MAKE) $(NO_PRINT) exec-one DIR=$$dir; \
-       done 2>&1 | tee _log
+       done 2>&1 | tee -a _log
        @$(MAKE) $(NO_PRINT) retries
-       @$(MAKE) report
+
+.PHONY: new
+new:
+       @rm -f _log
+       @$(MAKE) $(NO_PRINT) new-without-report
+       @$(MAKE) $(NO_PRINT) report
+
+.PHONY: new-without-report
+new-without-report: lib tools
+       @rm -f $(failstamp)
+       @(for file in `$(find) tests -name ocamltests`; do \
+         dir=`dirname $$file`; \
+         echo Running tests from \'$$dir\' ... ; \
+         (IFS=$$(printf "\r\n"); while read testfile; do \
+           TERM=dumb OCAMLRUNPARAM= \
+             $(ocamltest) $$dir/$$testfile || \
+             touch $(failstamp); \
+         done < $$file) || touch $(failstamp); \
+       done || touch $(failstamp)) 2>&1 | tee -a _log
+       @if [ -f $(failstamp) ]; then rm $(failstamp); exit 1; fi
 
 .PHONY: all-%
 all-%: lib tools
@@ -126,13 +189,13 @@ one: lib tools
 
 .PHONY: exec-one
 exec-one:
-       @if [ ! -f $(DIR)/Makefile ]; then \
+       @if [ ! -f $(DIR)/Makefile -a ! -f $(DIR)/ocamltests ]; then \
          for dir in $(DIR)/*; do \
            if [ -d $$dir ]; then \
              $(MAKE) exec-one DIR=$$dir; \
            fi; \
          done; \
-       else \
+       elif [ -f $(DIR)/Makefile ]; then \
          echo "Running tests from '$$DIR' ..."; \
          cd $(DIR) && \
          $(MAKE) TERM=dumb BASEDIR=$(BASEDIR) || echo '=> unexpected error'; \
@@ -177,12 +240,15 @@ clean:
        @for file in `$(FIND) interactive tests -name Makefile`; do \
          (cd `dirname $$file` && $(MAKE) BASEDIR=$(BASEDIR) clean); \
        done
+       $(FIND) . -name '*_ocamltest*' | xargs rm -rf
+       rm -f $(failstamp)
 
 .PHONY: report
 report:
        @if [ ! -f _log ]; then echo "No '_log' file."; exit 1; fi
        @awk -f makefiles/summarize.awk <_log
 
+.PHONY: retry-list
 retry-list:
        @while read LINE; do \
          if [ -n "$$LINE" ] ; then \
@@ -193,6 +259,7 @@ retry-list:
        done <_retries;
        @$(MAKE) $(NO_PRINT) retries
 
+.PHONY: retries
 retries:
        @awk -v retries=1 -v max_retries=$(MAX_TESTSUITE_DIR_RETRIES) \
             -f makefiles/summarize.awk <_log >_retries

diff --git a/testsuite/lib/Makefile b/testsuite/lib/Makefile
index be620ffad851889faed4fa7ed691d4579a360c53..7efde5c2642efa029df5e3ed380da2159637143b 100644 (file)
--- a/testsuite/lib/Makefile
+++ b/testsuite/lib/Makefile
@@ -25,7 +25,13 @@ clean: defaultclean
 include ../makefiles/Makefile.common
 
 .PHONY: compile-targets
-compile-targets: testing.cmi testing.cmo
+compile-targets: testing.cmi testing.cma
        @if $(BYTECODE_ONLY); then : ; else \
-         $(MAKE) testing.cmx; \
+         $(MAKE) testing.cmxa; \
        fi
+
+testing.cma: testing.cmo
+       $(OCAMLC) -a -linkall $(ADD_COMPFLAGS) -o $@ $<
+
+testing.cmxa: testing.cmx
+       $(OCAMLOPT) -a -linkall $(ADD_COMPFLAGS) -o $@ $<

diff --git a/testsuite/makefiles/Makefile.common b/testsuite/makefiles/Makefile.common
index 0a85f959695bb7b97e14bff5244f75b814331fa8..76063f7cacb34ae3d75f35fd3652918937e4c0a7 100644 (file)
--- a/testsuite/makefiles/Makefile.common
+++ b/testsuite/makefiles/Makefile.common
@@ -16,11 +16,13 @@
 TOPDIR=$(BASEDIR)/..
 include $(TOPDIR)/Makefile.tools
 
+.PHONY: defaultpromote
 defaultpromote:
        @for file in *.reference; do \
          cp `basename $$file reference`result $$file; \
        done
 
+.PHONY: defaultclean
 defaultclean:
        @rm -f *.cmo *.cmi *.cmx *.cma *.cmxa *.cmxs *.$(O) *.$(SO) *.$(A) *.exe
        @rm -f *.exe.manifest
@@ -76,7 +78,7 @@ defaultclean:
        @$(ASPP) $(ASPPFLAGS) -DSYS_$(SYSTEM) -o $*.o $*.s
 
 .c.o:
-       @$(CC) -c -I$(CTOPDIR)/byterun $*.c -o $*.$(O)
+       @$(CC) $(CFLAGS) -c -I$(CTOPDIR)/byterun $*.c -o $*.$(O)
 
 .f.o:
        @$(FORTRAN_COMPILER) -c -I$(CTOPDIR)/byterun $*.f -o $*.$(O)

diff --git a/testsuite/makefiles/Makefile.dlambda b/testsuite/makefiles/Makefile.dlambda
index d9e887447cc2c34dce12d71038ca18bfa51875c9..eebd2436d291acc2fdd02fa7b8cee5f0ff634acd 100644 (file)
--- a/testsuite/makefiles/Makefile.dlambda
+++ b/testsuite/makefiles/Makefile.dlambda
@@ -17,6 +17,7 @@
 # changes, we strip -dlambda-produced identifiers of their unique
 # identifier: "x/1234" becomes simply "x".
 
+.PHONY: default
 default:
        @for file in *.ml; do \
          $(OCAMLC) -dlambda -c $$file 2>&1 | \
@@ -29,7 +30,9 @@ default:
           && echo " => passed" || echo " => failed"; \
        done
 
+.PHONY: promote
 promote: defaultpromote
 
+.PHONY: clean
 clean: defaultclean
        @rm -f *.result

diff --git a/testsuite/makefiles/Makefile.dparsetree b/testsuite/makefiles/Makefile.dparsetree
index 711e440adbb5e8f1fda03ac070920813eabbe071..7d1fcd0eaa6ab148b22d50cb174ae6fa00e65a40 100644 (file)
--- a/testsuite/makefiles/Makefile.dparsetree
+++ b/testsuite/makefiles/Makefile.dparsetree
@@ -14,6 +14,7 @@
 #*                                                                        *
 #**************************************************************************
 
+.PHONY: default
 default:
        @for file in *.ml; do \
          $(OCAMLC) -dparsetree -c $$file 2>$$file.result >/dev/null || true; \
@@ -24,7 +25,9 @@ default:
           && echo " => passed" || echo " => failed"; \
        done
 
+.PHONY: promote
 promote: defaultpromote
 
+.PHONY: clean
 clean: defaultclean
        @rm -f *.result

diff --git a/testsuite/makefiles/Makefile.expect b/testsuite/makefiles/Makefile.expect
index 0b219ee893ac0d84a1bf0ccbdcfc35688b2358a7..d1395a487290c34fcaa766476283e2ba533cadb6 100644 (file)
--- a/testsuite/makefiles/Makefile.expect
+++ b/testsuite/makefiles/Makefile.expect
@@ -12,6 +12,7 @@
 #*                                                                        *
 #**************************************************************************
 
+.PHONY: default
 default:
        @for file in *.ml; do \
          printf " ... testing '$$file':"; \
@@ -23,10 +24,12 @@ default:
          echo " => passed" || echo " => failed"; \
        done
 
+.PHONY: promote
 promote:
        @for file in *.corrected; do \
          cp $$file `basename $$file .corrected`; \
        done
 
+.PHONY: clean
 clean: defaultclean
        @rm -f *.corrected

diff --git a/testsuite/makefiles/Makefile.several b/testsuite/makefiles/Makefile.several
index e29378c77780aff968a6b828e1b85ec1c2f44871..18604b248f2020fe1486bd06a8ddbc1fee54d1ad 100644 (file)
--- a/testsuite/makefiles/Makefile.several
+++ b/testsuite/makefiles/Makefile.several
@@ -13,13 +13,12 @@
 #*                                                                        *
 #**************************************************************************
 
-CC=$(NATIVECC) $(NATIVECCCOMPOPTS)
 FC=$(FORTAN_COMPILER)
 CMO_FILES=$(MODULES:=.cmo)
 CMX_FILES=$(MODULES:=.cmx)
 CMA_FILES=$(LIBRARIES:=.cma)
 CMXA_FILES=$(LIBRARIES:=.cmxa)
-O_FILES=$(F_FILES:=.o) $(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)
@@ -61,26 +60,28 @@ run-all:
              continue; \
            fi; \
          fi; \
-         $(MAKE) run-file DESC=ocamlc COMP='$(OCAMLC)' \
-                 RUNTIME='$(MYRUNTIME)' \
-                 COMPFLAGS='-w a $(ADD_COMPFLAGS) $(ADD_CFLAGS) $(O_FILES) \
-                            $(CMA_FILES) -I $(OTOPDIR)/testsuite/lib \
-                            $(CMO_FILES)' \
-                 FILE=$$file PROGRAM_ARGS=$(PROGRAM_ARGS) \
+         if $(NATIVECODE_ONLY); then : ; else \
+           $(MAKE) run-file DESC=ocamlc COMP='$(OCAMLC)' \
+                   RUNTIME='$(MYRUNTIME)' \
+                   COMPFLAGS='$(ADD_COMPFLAGS) $(ADD_CFLAGS) $(O_FILES) \
+                              $(CMA_FILES) -I $(OTOPDIR)/testsuite/lib \
+                              $(CMO_FILES)' \
+                   FILE=$$file PROGRAM_ARGS='$(PROGRAM_ARGS)'; \
+         fi \
          && \
          if $(BYTECODE_ONLY); then : ; else \
            $(MAKE) run-file DESC=ocamlopt COMP='$(OCAMLOPT)' \
                    RUNTIME= \
-                   COMPFLAGS='-w a $(ADD_COMPFLAGS) $(ADD_OPTFLAGS) \
+                   COMPFLAGS='$(ADD_COMPFLAGS) $(ADD_OPTFLAGS) \
                               $(O_FILES) $(CMXA_FILES) \
                               -I $(OTOPDIR)/testsuite/lib $(CMX_FILES)' \
-                   FILE=$$file PROGRAM_ARGS=$(PROGRAM_ARGS); \
+                   FILE=$$file PROGRAM_ARGS='$(PROGRAM_ARGS)'; \
          fi \
          && \
          if [ -n "$(UNSAFE)" ]; then \
            $(MAKE) run-file DESC=ocamlc-unsafe COMP='$(OCAMLC)' \
                    RUNTIME='$(MYRUNTIME)' \
-                   COMPFLAGS='-w a -unsafe $(ADD_COMPFLAGS) $(ADD_CFLAGS) \
+                   COMPFLAGS='-unsafe $(ADD_COMPFLAGS) $(ADD_CFLAGS) \
                               $(O_FILES) $(CMA_FILES) \
                               -I $(OTOPDIR)/testsuite/lib $(CMO_FILES)' \
                    FILE=$$file \
@@ -88,7 +89,7 @@ run-all:
            if $(BYTECODE_ONLY); then : ; else \
              $(MAKE) run-file DESC=ocamlopt-unsafe COMP='$(OCAMLOPT)' \
                      RUNTIME= \
-                     COMPFLAGS='-w a -unsafe $(ADD_COMPFLAGS) $(ADD_OPTFLAGS)\
+                     COMPFLAGS='-unsafe $(ADD_COMPFLAGS) $(ADD_OPTFLAGS)\
                                 $(O_FILES) $(CMXA_FILES) \
                                 -I $(OTOPDIR)/testsuite/lib $(CMX_FILES)' \
                      FILE=$$file; \
@@ -114,7 +115,18 @@ run-file:
          rm -f "$$T"; \
        } || true
        @rm -f program program$(EXE)
-       @$(COMP) $(COMPFLAGS) $(FILE) -o program$(EXE)
+       @if [ -f "$(FILE).silent-compilation" ]; then \
+          temp="$$(mktemp "$${TMPDIR:-/tmp}/ocaml-test-XXXXXXXX")"; \
+          $(COMP) $(COMPFLAGS) $(FILE) -o program$(EXE) >$$temp 2>&1 ; \
+          if [ -s "$$temp" ]; then \
+            rm -f $$temp; \
+            printf "  Error: compilation wrote to stdout/stderr!\n"; \
+            exit 1; \
+          fi; \
+          rm -f $$temp; \
+        else \
+          $(COMP) $(COMPFLAGS) $(FILE) -o program$(EXE); \
+        fi
        @F="`basename $(FILE) .ml`"; \
        if [ -f $$F.runner ]; then \
          RUNTIME="$(RUNTIME)" sh $$F.runner; \

diff --git a/testsuite/makefiles/Makefile.toplevel b/testsuite/makefiles/Makefile.toplevel
index e4d29fae41541d2a69b39f9864abb7db4079b6e2..ad5a4b370624106b6f4a52a36eb2a9b96280bc61 100644 (file)
--- a/testsuite/makefiles/Makefile.toplevel
+++ b/testsuite/makefiles/Makefile.toplevel
@@ -13,6 +13,7 @@
 #*                                                                        *
 #**************************************************************************
 
+.PHONY: default
 default:
        @for file in *.ml; do \
          TERM=dumb $(OCAML) $(TOPFLAGS) <$$file 2>&1 \
@@ -28,7 +29,9 @@ default:
           && echo " => passed" || echo " => failed"; \
        done
 
+.PHONY: promote
 promote: defaultpromote
 
+.PHONY: clean
 clean: defaultclean
        @rm -f *.result

diff --git a/testsuite/tests/afl-instrumentation/Makefile b/testsuite/tests/afl-instrumentation/Makefile
new file mode 100644 (file)
index 0000000..c32365e
--- /dev/null
+++ b/testsuite/tests/afl-instrumentation/Makefile
@@ -0,0 +1,17 @@
+BASEDIR=../..
+
+default:
+       @printf " ... testing 'afl_instrumentation':"
+       @if ! which afl-showmap > /dev/null; then \
+         echo " => skipped (afl-showmap unavailable)"; \
+       else \
+         if OCAMLOPT='$(OCAMLOPT)' ./test.sh > /dev/null; then \
+           echo " => passed"; \
+         else \
+           echo " => failed"; \
+         fi \
+       fi
+
+include $(BASEDIR)/makefiles/Makefile.common
+
+clean: defaultclean

diff --git a/testsuite/tests/afl-instrumentation/harness.ml b/testsuite/tests/afl-instrumentation/harness.ml
new file mode 100644 (file)
index 0000000..dbcbebf
--- /dev/null
+++ b/testsuite/tests/afl-instrumentation/harness.ml
@@ -0,0 +1,22 @@
+external reset_instrumentation : bool -> unit = "caml_reset_afl_instrumentation"
+external sys_exit : int -> 'a = "caml_sys_exit"
+
+let name n =
+  fst (Test.tests.(int_of_string n - 1))
+let run n =
+  snd (Test.tests.(int_of_string n - 1)) ()
+
+let orig_random = Random.get_state ()
+
+let () =
+  (* Random.set_state orig_random; *)
+  reset_instrumentation true;
+  begin
+    match Sys.argv with
+    | [| _; "len" |] -> print_int (Array.length Test.tests); print_newline (); flush stdout
+    | [| _; "name"; n |] -> print_string (name n); flush stdout
+    | [| _; "1"; n |] -> run n
+    | [| _; "2"; n |] -> run n; (* Random.set_state orig_random;  *)reset_instrumentation false; run n
+    | _ -> failwith "error"
+  end;
+  sys_exit 0

diff --git a/testsuite/tests/afl-instrumentation/test.ml b/testsuite/tests/afl-instrumentation/test.ml
new file mode 100644 (file)
index 0000000..83c1fc0
--- /dev/null
+++ b/testsuite/tests/afl-instrumentation/test.ml
@@ -0,0 +1,73 @@
+let opaque = Sys.opaque_identity
+
+let lists n =
+  let l = opaque [n; n; n] in
+  match List.rev l with
+  | [a; b; c] when a = n && b = n && c = n -> ()
+  | _ -> assert false
+
+let fresh_exception x =
+  opaque @@
+    let module M = struct
+        exception E of int
+        let throw () = raise (E x)
+      end in
+    try
+      M.throw ()
+    with
+      M.E n -> assert (n = x)
+
+let obj_with_closure x =
+  opaque (object method foo = x end)
+
+let r = ref 42
+let state () =
+  incr r;
+  if !r > 43 then print_string "woo" else ()
+
+let classes (x : int) =
+  opaque @@
+    let module M = struct
+        class a = object
+          method foo = x
+        end
+        class c = object
+          inherit a
+        end
+      end in
+    let o = new M.c in
+    assert (o#foo = x)
+
+
+class c_global = object
+  method foo = 42
+end
+let obj_ordering () = opaque @@
+  (* Object IDs change, but should be in the same relative order *)
+  let a = new c_global in
+  let b = new c_global in
+  if a < b then print_string "a" else print_string "b"
+
+let random () = opaque @@
+  (* as long as there's no self_init, this should be deterministic *)
+  if Random.int 100 < 50 then print_string "a" else print_string "b";
+  if Random.int 100 < 50 then print_string "a" else print_string "b";
+  if Random.int 100 < 50 then print_string "a" else print_string "b";
+  if Random.int 100 < 50 then print_string "a" else print_string "b";
+  if Random.int 100 < 50 then print_string "a" else print_string "b";
+  if Random.int 100 < 50 then print_string "a" else print_string "b";
+  if Random.int 100 < 50 then print_string "a" else print_string "b";
+  if Random.int 100 < 50 then print_string "a" else print_string "b";
+  if Random.int 100 < 50 then print_string "a" else print_string "b"
+
+let tests =
+  [| ("lists", fun () -> lists 42);
+     ("manylists", fun () -> for i = 1 to 10 do lists 42 done);
+     ("exceptions", fun () -> fresh_exception 100);
+     ("objects", fun () -> ignore (obj_with_closure 42));
+     (* ("state", state); *) (* this one should fail *)
+     ("classes", fun () -> classes 42);
+     ("obj_ordering", obj_ordering);
+     (* ("random", random); *)
+  |]
+  

diff --git a/testsuite/tests/afl-instrumentation/test.sh b/testsuite/tests/afl-instrumentation/test.sh
new file mode 100755 (executable)
index 0000000..804db5f
--- /dev/null
+++ b/testsuite/tests/afl-instrumentation/test.sh
@@ -0,0 +1,33 @@
+#!/bin/bash
+
+set -e
+
+$OCAMLOPT -c -afl-instrument test.ml
+$OCAMLOPT -afl-inst-ratio 0 test.cmx harness.ml -o test
+
+NTESTS=`./test len`
+failures=''
+echo "running $NTESTS tests..."
+for t in `seq 1 $NTESTS`; do
+  printf "%14s: " `./test name $t`
+  # when run twice, the instrumentation output should double
+  afl-showmap -q -o output-1 -- ./test 1 $t
+  afl-showmap -q -o output-2 -- ./test 2 $t
+  # see afl-showmap.c for what the numbers mean
+  cat output-1 | sed '
+    s/:6/:7/; s/:5/:6/;
+    s/:4/:5/; s/:3/:4/;
+    s/:2/:4/; s/:1/:2/;
+  ' > output-2-predicted
+  if cmp -s output-2-predicted output-2; then
+    echo "passed."
+  else
+    echo "failed:"
+    paste output-2 output-1
+    failures=1
+  fi
+done
+
+if [ -z "$failures" ]; then echo "all tests passed"; else exit 1; fi
+
+rm -f {test,harness}.{cmi,cmx,o} test output-{1,2,2-predicted}

diff --git a/testsuite/tests/array-functions/Makefile b/testsuite/tests/array-functions/Makefile
deleted file mode 100644 (file)
index c11a415..0000000
--- a/testsuite/tests/array-functions/Makefile
+++ /dev/null
@@ -1,18 +0,0 @@
-#**************************************************************************
-#*                                                                        *
-#*                                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 GNU Lesser General Public License version 2.1, with the          *
-#*   special exception on linking described in the file LICENSE.          *
-#*                                                                        *
-#**************************************************************************
-
-BASEDIR=../..
-include $(BASEDIR)/makefiles/Makefile.several
-include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/array-functions/ocamltests b/testsuite/tests/array-functions/ocamltests
new file mode 100644 (file)
index 0000000..31c13b4
--- /dev/null
+++ b/testsuite/tests/array-functions/ocamltests
@@ -0,0 +1 @@
+test.ml

diff --git a/testsuite/tests/array-functions/test.ml b/testsuite/tests/array-functions/test.ml
index e325724cce2bf17491fca91d4bfcc297b489b624..c7f101ed08fb9e237a13b7a2f500bd8d6d8f7228 100644 (file)
--- a/testsuite/tests/array-functions/test.ml
+++ b/testsuite/tests/array-functions/test.ml
@@ -1,3 +1,5 @@
+(* TEST *)
+
 let () =
   let a = [|0;1;2;3;4;5;6;7;8;9|] in
   assert (Array.exists (fun a -> a < 10) a);
@@ -176,7 +178,9 @@ let () =
   assert (not (Array.memq (ref 1) (Array.make 100 (ref 1))));
   let f = Array.create_float 10 in
   Array.fill f 0 10 1.0;
-  assert (not (Array.memq 1.0 f));
+  (* FIXME
+  if Config.flat_float_array then assert (not (Array.memq 1.0 f));
+  *)
 ;;
 
 let () = print_endline "OK"

diff --git a/testsuite/tests/asmcomp/Makefile b/testsuite/tests/asmcomp/Makefile
index 5ef5a2e3289aa66229a3521e65eee346f42a35db..08921d12f083ba37098bddb3eb8dfc69e3851d75 100644 (file)
--- a/testsuite/tests/asmcomp/Makefile
+++ b/testsuite/tests/asmcomp/Makefile
@@ -15,6 +15,8 @@
 
 BASEDIR=../..
 
+include $(BASEDIR)/../config/Makefile
+
 INCLUDES=\
   -I $(OTOPDIR)/parsing \
   -I $(OTOPDIR)/utils \
@@ -55,8 +57,9 @@ MLCASES=optargs staticalloc bind_tuples is_static register_typing \
   register_typing_switch
 ARGS_optargs=-g
 ARGS_is_static=-I $(OTOPDIR)/byterun is_in_static_data.c
-MLCASES_FLAMBDA=is_static_flambda unrolling_flambda unrolling_flambda2 \
-  static_float_array_flambda static_float_array_flambda_opaque
+MLCASES_FLAMBDA=is_static_flambda unrolling_flambda unrolling_flambda2
+MLCASES_FLAMBDA_FLOAT=static_float_array_flambda \
+                      static_float_array_flambda_opaque
 ARGS_is_static_flambda=\
   -I $(OTOPDIR)/byterun is_in_static_data.c is_static_flambda_dep.ml
 ARGS_static_float_array_flambda=\
@@ -87,7 +90,8 @@ ARGS_even-odd-spill=-DINT_INT -DFUN=is_even main.c
 ARGS_pgcd=-DINT_INT -DFUN=pgcd_30030 main.c
 
 skips:
-       @for c in $(CASES) $(MLCASES) $(MLCASES_FLAMBDA); do \
+       @for c in $(CASES) $(MLCASES) $(MLCASES_FLAMBDA) \
+                  $(MLCASES_FLAMBDA_FLOAT); do \
          echo " ... testing '$$c': => skipped"; \
        done
 
@@ -95,8 +99,8 @@ one_ml:
        @$(OCAMLOPT) $(ARGS_$(NAME)) -o $(NAME).exe $(NAME).ml && \
        ./$(NAME).exe && echo " => passed" || echo " => failed"
 
-one_ml_flambda:
-       @if $(FLAMBDA); then \
+one_ml_cond:
+       @if $(COND); then \
           $(OCAMLOPT) $(ARGS_$(NAME)) -o $(NAME).exe $(NAME).ml && \
           ./$(NAME).exe && echo " => passed" || echo " => failed"; \
         else \
@@ -104,7 +108,7 @@ one_ml_flambda:
         fi
 
 one:
-       @$(call CC,$(NAME).out $(ARGS_$(NAME)) $(NAME).$(O) $(ARCH).$(O)) \
+       @$(call CCOMP,$(NAME).out $(ARGS_$(NAME)) $(NAME).$(O) $(ARCH).$(O)) \
        && echo " => passed" || echo " => failed"
 
 clean: defaultclean
@@ -127,11 +131,9 @@ SKIP=true
 endif
 
 ifeq ($(CCOMPTYPE),msvc)
-CC=set -o pipefail ; $(NATIVECC) $(CFLAGS) /Fe$(1) | tail -n +2
-CFLAGS=$(NATIVECCCOMPOPTS)
+CCOMP=set -o pipefail ; $(CC) $(CFLAGS) /Fe$(1) | tail -n +2
 else
-CC=$(NATIVECC) $(CFLAGS) -o $(1)
-CFLAGS=$(NATIVECCCOMPOPTS) -g
+CCOMP=$(CC) $(CFLAGS) -o $(1)
 endif
 tests: $(CASES:=.$(O))
        @for c in $(CASES); do \
@@ -144,7 +146,12 @@ tests: $(CASES:=.$(O))
         done
        @for c in $(MLCASES_FLAMBDA); do \
          printf " ... testing '$$c':"; \
-          $(MAKE) one_ml_flambda NAME=$$c; \
+          $(MAKE) one_ml_cond NAME=$$c COND=$(FLAMBDA); \
+        done
+       @for c in $(MLCASES_FLAMBDA_FLOAT); do \
+         printf " ... testing '$$c':"; \
+         $(MAKE) one_ml_cond NAME=$$c \
+                  COND='$(FLAMBDA) && $(FLAT_FLOAT_ARRAY)'; \
         done
 
 promote:

diff --git a/testsuite/tests/asmcomp/is_static_flambda.ml b/testsuite/tests/asmcomp/is_static_flambda.ml
index d4cf27566e3536d7158553dee8358b57403b3d86..94e0519b2b780c645fcd150263721b33f8cb7a17 100644 (file)
--- a/testsuite/tests/asmcomp/is_static_flambda.ml
+++ b/testsuite/tests/asmcomp/is_static_flambda.ml
@@ -113,3 +113,88 @@ let f x =
 let () =
   f true;
   f false
+
+(* Verify that physical equality/inequality is correctly propagated *)
+
+(* In these tests, tuple can be statically allocated only if it is a
+   known constant since the function is never inlined (hence this
+   code is never at toplevel) *)
+
+let () =
+  let f () =
+    let v = (1, 2) in
+    (* eq is supposed to be considered always true since v is a
+       constant, hence aliased to a symbol.
+       It is not yet optimized away if it is not constant *)
+    let eq = v == v in
+    let n = if eq then 1 else 2 in
+    let tuple = (n,n) in
+    assert(is_in_static_data tuple)
+  in
+  (f [@inlined never]) ()
+
+let () =
+  let f () =
+    let v = (1, 2) in
+    (* same with inequality *)
+    let eq = v != v in
+    let n = if eq then 1 else 2 in
+    let tuple = (n,n) in
+    assert(is_in_static_data tuple)
+  in
+  (f [@inlined never]) ()
+
+let () =
+  let f x =
+    let v1 = Some x in
+    let v2 = None in
+    let eq = v1 == v2 in
+    (* The values are structurally different, so must be physically
+       different *)
+    let n = if eq then 1 else 2 in
+    let tuple = (n,n) in
+    assert(is_in_static_data tuple)
+  in
+  (f [@inlined never]) ()
+
+let () =
+  let f x =
+    let v1 = Some x in
+    let v2 = None in
+    let eq = v1 != v2 in
+    (* same with inequality *)
+    let n = if eq then 1 else 2 in
+    let tuple = (n,n) in
+    assert(is_in_static_data tuple)
+  in
+  (f [@inlined never]) ()
+
+let () =
+  let f x =
+    let v1 = (1, 2) in
+    let v2 = (3, 2) in
+    let eq = v1 == v2 in
+    (* difference is deeper *)
+    let n = if eq then 1 else 2 in
+    let tuple = (n,n) in
+    assert(is_in_static_data tuple)
+  in
+  (f [@inlined never]) ()
+
+module Int = struct
+  type t = int
+  let compare (a:int) b = compare a b
+end
+module IntMap = (Map.Make [@inlined])(Int)
+
+let () =
+  let f () =
+    let a = IntMap.empty in
+    let b = (IntMap.add [@inlined]) 1 (Some 1) a in
+    assert(is_in_static_data b);
+    let c = (IntMap.add [@inlined]) 1 (Some 2) b in
+    assert(is_in_static_data c);
+    let d = (IntMap.add [@inlined]) 1 (Some 2) c in
+    assert(is_in_static_data d);
+  in
+  (f [@inlined never]) ()

diff --git a/testsuite/tests/asmcomp/main.ml b/testsuite/tests/asmcomp/main.ml
index 284f7fbc960abc35ea6588aa3c06e05e5c30fa1a..6970f99a93b0c1bba476afbf703db5cc1656dfd9 100644 (file)
--- a/testsuite/tests/asmcomp/main.ml
+++ b/testsuite/tests/asmcomp/main.ml
@@ -6,8 +6,7 @@ let compile_file filename =
     let out_name = Filename.chop_extension filename ^ ".s" in
     Emitaux.output_channel := open_out out_name
   end; (* otherwise, stdout *)
-  Clflags.dlcode := false;
-  Compilenv.reset ~source_provenance:(Timings.File filename) "test";
+  Compilenv.reset "test";
   Emit.begin_assembly();
   let ic = open_in filename in
   let lb = Lexing.from_channel ic in
@@ -58,9 +57,10 @@ let main() =
      "-dreload", Arg.Set dump_reload, "";
      "-dscheduling", Arg.Set dump_scheduling, "";
      "-dlinear", Arg.Set dump_linear, "";
-     "-dtimings", Arg.Set print_timings, "";
+     "-dtimings", Arg.Unit (fun () -> profile_columns := [ `Time ]), "";
     ] compile_file usage
 
-let _ = (*Printexc.catch*) Timings.(time All) main ();
-  if !Clflags.print_timings then Timings.print Format.std_formatter;
+let () =
+  main ();
+  Profile.print Format.std_formatter !Clflags.profile_columns;
   exit 0

diff --git a/testsuite/tests/backtrace/pr6920_why_swallow.byte.reference b/testsuite/tests/backtrace/pr6920_why_swallow.byte.reference
index ad66532f311b546bc83a1c80c1d2a9986aec8e4f..f7e3ca349e2209ba217c4421b8bf1430a9b6719d 100644 (file)
--- a/testsuite/tests/backtrace/pr6920_why_swallow.byte.reference
+++ b/testsuite/tests/backtrace/pr6920_why_swallow.byte.reference
@@ -1,4 +1,4 @@
 Fatal error: exception Pervasives.Exit
 Raised at file "pr6920_why_swallow.ml", line 1, characters 41-45
-Called from file "pr6920_why_swallow.ml", line 4, characters 4-14
+Called from file "pr6920_why_swallow.ml", line 4, characters 4-13
 Called from file "pr6920_why_swallow.ml", line 11, characters 2-6

diff --git a/testsuite/tests/backtrace/pr6920_why_swallow.native.reference b/testsuite/tests/backtrace/pr6920_why_swallow.native.reference
index facb06dd33685ba16829d1ec1c678fc10296c7c7..1e28144bc1ba80a066752ec673a781e9754f68db 100644 (file)
--- a/testsuite/tests/backtrace/pr6920_why_swallow.native.reference
+++ b/testsuite/tests/backtrace/pr6920_why_swallow.native.reference
@@ -1,4 +1,4 @@
 Fatal error: exception Pervasives.Exit
 Raised at file "pr6920_why_swallow.ml", line 1, characters 35-45
-Called from file "pr6920_why_swallow.ml", line 4, characters 4-14
+Called from file "pr6920_why_swallow.ml", line 4, characters 4-13
 Called from file "pr6920_why_swallow.ml", line 11, characters 2-6

diff --git a/testsuite/tests/basic-float/tfloat_record.ml b/testsuite/tests/basic-float/tfloat_record.ml
index 38cf230baf9b607f1c6a73f21ef89338fa831458..8df1a00588339f27e99aaf95cd5bb590ba721f77 100644 (file)
--- a/testsuite/tests/basic-float/tfloat_record.ml
+++ b/testsuite/tests/basic-float/tfloat_record.ml
@@ -32,7 +32,7 @@ print_float (Float_record.from s.Float_record.f);;
 print_newline ();;
 
 
-let b = (Float_array.small_float_array [@inlined]) 12
+let b = Float_array.small_float_array 12
 let c = (Float_array.longer_float_array [@inlined]) 34
 
 let print_array a =

diff --git a/testsuite/tests/basic-io-2/Makefile b/testsuite/tests/basic-io-2/Makefile
deleted file mode 100644 (file)
index a84f031..0000000
--- a/testsuite/tests/basic-io-2/Makefile
+++ /dev/null
@@ -1,22 +0,0 @@
-#**************************************************************************
-#*                                                                        *
-#*                                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 GNU Lesser General Public License version 2.1, with the          *
-#*   special exception on linking described in the file LICENSE.          *
-#*                                                                        *
-#**************************************************************************
-
-BASEDIR=../..
-#MODULES=
-MAIN_MODULE=io
-EXEC_ARGS=io.ml
-
-include $(BASEDIR)/makefiles/Makefile.one
-include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/basic-io-2/io.ml b/testsuite/tests/basic-io-2/io.ml
index 3c088d3f5d198f32d9e3d9790e3a1f8d5c535f2f..c6d3e535e75c92e223e05b5a53400a491fe4d0fe 100644 (file)
--- a/testsuite/tests/basic-io-2/io.ml
+++ b/testsuite/tests/basic-io-2/io.ml
@@ -1,3 +1,8 @@
+(* TEST
+  arguments = "io.ml"
+  files = "test-file-short-lines"
+*)
+
 (* Test a file copy function *)
 
 let test msg funct f1 f2 =

diff --git a/testsuite/tests/basic-io-2/ocamltests b/testsuite/tests/basic-io-2/ocamltests
new file mode 100644 (file)
index 0000000..9ab7106
--- /dev/null
+++ b/testsuite/tests/basic-io-2/ocamltests
@@ -0,0 +1 @@
+io.ml

diff --git a/testsuite/tests/basic-io/Makefile b/testsuite/tests/basic-io/Makefile
deleted file mode 100644 (file)
index 6e63bd8..0000000
--- a/testsuite/tests/basic-io/Makefile
+++ /dev/null
@@ -1,22 +0,0 @@
-#**************************************************************************
-#*                                                                        *
-#*                                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 GNU Lesser General Public License version 2.1, with the          *
-#*   special exception on linking described in the file LICENSE.          *
-#*                                                                        *
-#**************************************************************************
-
-BASEDIR=../..
-#MODULES=
-MAIN_MODULE=wc
-EXEC_ARGS=wc.ml
-
-include $(BASEDIR)/makefiles/Makefile.one
-include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/basic-io/ocamltests b/testsuite/tests/basic-io/ocamltests
new file mode 100644 (file)
index 0000000..1a75b9a
--- /dev/null
+++ b/testsuite/tests/basic-io/ocamltests
@@ -0,0 +1 @@
+wc.ml

diff --git a/testsuite/tests/basic-io/wc.ml b/testsuite/tests/basic-io/wc.ml
index adec8b5310b8018ef10a81c8be5378e9ef487b39..33e7911597bb69c1482a1f47ab31c4f4d2e362ce 100644 (file)
--- a/testsuite/tests/basic-io/wc.ml
+++ b/testsuite/tests/basic-io/wc.ml
@@ -1,3 +1,6 @@
+(* TEST
+  arguments = "wc.ml"
+*)
 
 (* Counts characters, lines and words in one or several files. *)
 

diff --git a/testsuite/tests/basic-io/wc.reference b/testsuite/tests/basic-io/wc.reference
index b242e31af8e5e6ab1881d5c894c95099f2b406c6..3c812841cffc4133f84db48d17d6d95706f405f9 100644 (file)
--- a/testsuite/tests/basic-io/wc.reference
+++ b/testsuite/tests/basic-io/wc.reference
@@ -1 +1 @@
-1199 characters, 178 words, 55 lines
+1232 characters, 184 words, 58 lines

diff --git a/testsuite/tests/basic-modules/Makefile b/testsuite/tests/basic-modules/Makefile
deleted file mode 100644 (file)
index 1feb55a..0000000
--- a/testsuite/tests/basic-modules/Makefile
+++ /dev/null
@@ -1,22 +0,0 @@
-#**************************************************************************
-#*                                                                        *
-#*                                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 GNU Lesser General Public License version 2.1, with the          *
-#*   special exception on linking described in the file LICENSE.          *
-#*                                                                        *
-#**************************************************************************
-
-BASEDIR=../..
-
-MODULES=offset pr6726 pr7427
-MAIN_MODULE=main
-
-include $(BASEDIR)/makefiles/Makefile.one
-include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/basic-modules/main.ml b/testsuite/tests/basic-modules/main.ml
index b9a7df8de12cf692b89d9e98bb0f0ebab0fe0efc..dae92a6eb09152d88930d1a397ffdde0339303d8 100644 (file)
--- a/testsuite/tests/basic-modules/main.ml
+++ b/testsuite/tests/basic-modules/main.ml
@@ -1,3 +1,7 @@
+(* TEST
+  modules = "offset.ml pr6726.ml pr7427.ml"
+*)
+
 (* PR#6435 *)
 
 module F (M : sig

diff --git a/testsuite/tests/basic-modules/ocamltests b/testsuite/tests/basic-modules/ocamltests
new file mode 100644 (file)
index 0000000..d389d15
--- /dev/null
+++ b/testsuite/tests/basic-modules/ocamltests
@@ -0,0 +1 @@
+main.ml

diff --git a/testsuite/tests/basic-more/morematch.ml b/testsuite/tests/basic-more/morematch.ml
index 86b638821ac8599b9cadd34a766db522b9fe7a6b..349c27e16c85a12875670388bad884cd4e0c49d7 100644 (file)
--- a/testsuite/tests/basic-more/morematch.ml
+++ b/testsuite/tests/basic-more/morematch.ml
@@ -74,7 +74,7 @@ let g x= match  x with
 | 4|5|7 -> 100
 | 7 | 8 -> 6
 | 9 -> 7
-| _ -> 8;;
+| _ -> 8 [@@ocaml.warning "-12"];;
 test "quatre" g 4 4 ;
 test "quatre" g 7 100 ; ()
 ;;
@@ -229,6 +229,7 @@ test "foo1" f (1,2) (-1)
 
 
 let f = function (([]|[_]) as x)|(_::([] as x))|(_::_::x)  -> x
+  [@@ocaml.warning "-12"]
 ;;
 
 test "zob" f [] [] ;
@@ -397,7 +398,7 @@ let yaya = function
 | A,_,_ -> 1
 | _,A,_ -> 2
 | B,B,_ -> 3
-| A,_,(100|103) -> 5
+| A,_,(100|103) -> 5 [@@ocaml.warning "-11"]
 ;;
 
 test "yaya" yaya (A,A,0) 1 ;
@@ -444,7 +445,7 @@ let rec autre = function
 | (J,J,((C|D) as x |E x|F (_,x))) | (J,_,((C|J) as x)) -> autre (x,x,x)
 | (J, J, (I|H _|K _)) -> 9
 | I,_,_ -> 6
-| E _,_,_ -> 7
+| E _,_,_ -> 7 [@@ocaml.warning "-12"]
 ;;
 (*
 File "morematch.ml", line 437, characters 43-44:
@@ -467,7 +468,7 @@ let xyz = function
 | YB,YB,_ -> 3
 | ((YB|YC), (YB|YC), (X|Y|Z|V _|T _)) -> 6
 | _,_,(X|U _) -> 8
-| _,_,Y -> 5
+| _,_,Y -> 5 [@@ocaml.warning "-11-12"]
 ;;
 (*
 File "morematch.ml", line 459, characters 7-8:
@@ -1075,7 +1076,7 @@ type ('a, 'b) t_j = A of 'a | B of 'b * 'a | C
 let f = function
   | A (`A|`C) -> 0
   | B (`B,`D) -> 1
-  | C -> 2
+  | C -> 2 [@@ocaml.warning "-8"]
 
 let g x = try f x with Match_failure _ -> 3
 
@@ -1109,7 +1110,7 @@ let f = function
   |  _, _, _, _, _, A, _, _, _, _, B, _, _, _, _, _ -> "11"
   |  B, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _ -> "12"
   |  _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _ -> "13"
-
+[@@ocaml.warning "-11"]
 (*
 File "morematch.ml", line 1094, characters 5-51:
 Warning: this match case is unused.

diff --git a/testsuite/tests/basic-more/pr1271.ml b/testsuite/tests/basic-more/pr1271.ml
new file mode 100644 (file)
index 0000000..3890d0f
--- /dev/null
+++ b/testsuite/tests/basic-more/pr1271.ml
@@ -0,0 +1,288 @@
+(* GPR#1271 *)
+
+module F (X : sig val x : int end) = struct
+  let rec f1 y = f270 (X.x + y)
+  and f2 y = (f1 [@inlined never]) y
+  and f3 y = (f2 [@inlined never]) y
+  and f4 y = (f3 [@inlined never]) y
+  and f5 y = (f4 [@inlined never]) y
+  and f6 y = (f5 [@inlined never]) y
+  and f7 y = (f6 [@inlined never]) y
+  and f8 y = (f7 [@inlined never]) y
+  and f9 y = (f8 [@inlined never]) y
+  and f10 y = (f9 [@inlined never]) y
+  and f11 y = (f10 [@inlined never]) y
+  and f12 y = (f11 [@inlined never]) y
+  and f13 y = (f12 [@inlined never]) y
+  and f14 y = (f13 [@inlined never]) y
+  and f15 y = (f14 [@inlined never]) y
+  and f16 y = (f15 [@inlined never]) y
+  and f17 y = (f16 [@inlined never]) y
+  and f18 y = (f17 [@inlined never]) y
+  and f19 y = (f18 [@inlined never]) y
+  and f20 y = (f19 [@inlined never]) y
+  and f21 y = (f20 [@inlined never]) y
+  and f22 y = (f21 [@inlined never]) y
+  and f23 y = (f22 [@inlined never]) y
+  and f24 y = (f23 [@inlined never]) y
+  and f25 y = (f24 [@inlined never]) y
+  and f26 y = (f25 [@inlined never]) y
+  and f27 y = (f26 [@inlined never]) y
+  and f28 y = (f27 [@inlined never]) y
+  and f29 y = (f28 [@inlined never]) y
+  and f30 y = (f29 [@inlined never]) y
+  and f31 y = (f30 [@inlined never]) y
+  and f32 y = (f31 [@inlined never]) y
+  and f33 y = (f32 [@inlined never]) y
+  and f34 y = (f33 [@inlined never]) y
+  and f35 y = (f34 [@inlined never]) y
+  and f36 y = (f35 [@inlined never]) y
+  and f37 y = (f36 [@inlined never]) y
+  and f38 y = (f37 [@inlined never]) y
+  and f39 y = (f38 [@inlined never]) y
+  and f40 y = (f39 [@inlined never]) y
+  and f41 y = (f40 [@inlined never]) y
+  and f42 y = (f41 [@inlined never]) y
+  and f43 y = (f42 [@inlined never]) y
+  and f44 y = (f43 [@inlined never]) y
+  and f45 y = (f44 [@inlined never]) y
+  and f46 y = (f45 [@inlined never]) y
+  and f47 y = (f46 [@inlined never]) y
+  and f48 y = (f47 [@inlined never]) y
+  and f49 y = (f48 [@inlined never]) y
+  and f50 y = (f49 [@inlined never]) y
+  and f51 y = (f50 [@inlined never]) y
+  and f52 y = (f51 [@inlined never]) y
+  and f53 y = (f52 [@inlined never]) y
+  and f54 y = (f53 [@inlined never]) y
+  and f55 y = (f54 [@inlined never]) y
+  and f56 y = (f55 [@inlined never]) y
+  and f57 y = (f56 [@inlined never]) y
+  and f58 y = (f57 [@inlined never]) y
+  and f59 y = (f58 [@inlined never]) y
+  and f60 y = (f59 [@inlined never]) y
+  and f61 y = (f60 [@inlined never]) y
+  and f62 y = (f61 [@inlined never]) y
+  and f63 y = (f62 [@inlined never]) y
+  and f64 y = (f63 [@inlined never]) y
+  and f65 y = (f64 [@inlined never]) y
+  and f66 y = (f65 [@inlined never]) y
+  and f67 y = (f66 [@inlined never]) y
+  and f68 y = (f67 [@inlined never]) y
+  and f69 y = (f68 [@inlined never]) y
+  and f70 y = (f69 [@inlined never]) y
+  and f71 y = (f70 [@inlined never]) y
+  and f72 y = (f71 [@inlined never]) y
+  and f73 y = (f72 [@inlined never]) y
+  and f74 y = (f73 [@inlined never]) y
+  and f75 y = (f74 [@inlined never]) y
+  and f76 y = (f75 [@inlined never]) y
+  and f77 y = (f76 [@inlined never]) y
+  and f78 y = (f77 [@inlined never]) y
+  and f79 y = (f78 [@inlined never]) y
+  and f80 y = (f79 [@inlined never]) y
+  and f81 y = (f80 [@inlined never]) y
+  and f82 y = (f81 [@inlined never]) y
+  and f83 y = (f82 [@inlined never]) y
+  and f84 y = (f83 [@inlined never]) y
+  and f85 y = (f84 [@inlined never]) y
+  and f86 y = (f85 [@inlined never]) y
+  and f87 y = (f86 [@inlined never]) y
+  and f88 y = (f87 [@inlined never]) y
+  and f89 y = (f88 [@inlined never]) y
+  and f90 y = (f89 [@inlined never]) y
+  and f91 y = (f90 [@inlined never]) y
+  and f92 y = (f91 [@inlined never]) y
+  and f93 y = (f92 [@inlined never]) y
+  and f94 y = (f93 [@inlined never]) y
+  and f95 y = (f94 [@inlined never]) y
+  and f96 y = (f95 [@inlined never]) y
+  and f97 y = (f96 [@inlined never]) y
+  and f98 y = (f97 [@inlined never]) y
+  and f99 y = (f98 [@inlined never]) y
+  and f100 y = (f99 [@inlined never]) y
+  and f101 y = (f100 [@inlined never]) y
+  and f102 y = (f101 [@inlined never]) y
+  and f103 y = (f102 [@inlined never]) y
+  and f104 y = (f103 [@inlined never]) y
+  and f105 y = (f104 [@inlined never]) y
+  and f106 y = (f105 [@inlined never]) y
+  and f107 y = (f106 [@inlined never]) y
+  and f108 y = (f107 [@inlined never]) y
+  and f109 y = (f108 [@inlined never]) y
+  and f110 y = (f109 [@inlined never]) y
+  and f111 y = (f110 [@inlined never]) y
+  and f112 y = (f111 [@inlined never]) y
+  and f113 y = (f112 [@inlined never]) y
+  and f114 y = (f113 [@inlined never]) y
+  and f115 y = (f114 [@inlined never]) y
+  and f116 y = (f115 [@inlined never]) y
+  and f117 y = (f116 [@inlined never]) y
+  and f118 y = (f117 [@inlined never]) y
+  and f119 y = (f118 [@inlined never]) y
+  and f120 y = (f119 [@inlined never]) y
+  and f121 y = (f120 [@inlined never]) y
+  and f122 y = (f121 [@inlined never]) y
+  and f123 y = (f122 [@inlined never]) y
+  and f124 y = (f123 [@inlined never]) y
+  and f125 y = (f124 [@inlined never]) y
+  and f126 y = (f125 [@inlined never]) y
+  and f127 y = (f126 [@inlined never]) y
+  and f128 y = (f127 [@inlined never]) y
+  and f129 y = (f128 [@inlined never]) y
+  and f130 y = (f129 [@inlined never]) y
+  and f131 y = (f130 [@inlined never]) y
+  and f132 y = (f131 [@inlined never]) y
+  and f133 y = (f132 [@inlined never]) y
+  and f134 y = (f133 [@inlined never]) y
+  and f135 y = (f134 [@inlined never]) y
+  and f136 y = (f135 [@inlined never]) y
+  and f137 y = (f136 [@inlined never]) y
+  and f138 y = (f137 [@inlined never]) y
+  and f139 y = (f138 [@inlined never]) y
+  and f140 y = (f139 [@inlined never]) y
+  and f141 y = (f140 [@inlined never]) y
+  and f142 y = (f141 [@inlined never]) y
+  and f143 y = (f142 [@inlined never]) y
+  and f144 y = (f143 [@inlined never]) y
+  and f145 y = (f144 [@inlined never]) y
+  and f146 y = (f145 [@inlined never]) y
+  and f147 y = (f146 [@inlined never]) y
+  and f148 y = (f147 [@inlined never]) y
+  and f149 y = (f148 [@inlined never]) y
+  and f150 y = (f149 [@inlined never]) y
+  and f151 y = (f150 [@inlined never]) y
+  and f152 y = (f151 [@inlined never]) y
+  and f153 y = (f152 [@inlined never]) y
+  and f154 y = (f153 [@inlined never]) y
+  and f155 y = (f154 [@inlined never]) y
+  and f156 y = (f155 [@inlined never]) y
+  and f157 y = (f156 [@inlined never]) y
+  and f158 y = (f157 [@inlined never]) y
+  and f159 y = (f158 [@inlined never]) y
+  and f160 y = (f159 [@inlined never]) y
+  and f161 y = (f160 [@inlined never]) y
+  and f162 y = (f161 [@inlined never]) y
+  and f163 y = (f162 [@inlined never]) y
+  and f164 y = (f163 [@inlined never]) y
+  and f165 y = (f164 [@inlined never]) y
+  and f166 y = (f165 [@inlined never]) y
+  and f167 y = (f166 [@inlined never]) y
+  and f168 y = (f167 [@inlined never]) y
+  and f169 y = (f168 [@inlined never]) y
+  and f170 y = (f169 [@inlined never]) y
+  and f171 y = (f170 [@inlined never]) y
+  and f172 y = (f171 [@inlined never]) y
+  and f173 y = (f172 [@inlined never]) y
+  and f174 y = (f173 [@inlined never]) y
+  and f175 y = (f174 [@inlined never]) y
+  and f176 y = (f175 [@inlined never]) y
+  and f177 y = (f176 [@inlined never]) y
+  and f178 y = (f177 [@inlined never]) y
+  and f179 y = (f178 [@inlined never]) y
+  and f180 y = (f179 [@inlined never]) y
+  and f181 y = (f180 [@inlined never]) y
+  and f182 y = (f181 [@inlined never]) y
+  and f183 y = (f182 [@inlined never]) y
+  and f184 y = (f183 [@inlined never]) y
+  and f185 y = (f184 [@inlined never]) y
+  and f186 y = (f185 [@inlined never]) y
+  and f187 y = (f186 [@inlined never]) y
+  and f188 y = (f187 [@inlined never]) y
+  and f189 y = (f188 [@inlined never]) y
+  and f190 y = (f189 [@inlined never]) y
+  and f191 y = (f190 [@inlined never]) y
+  and f192 y = (f191 [@inlined never]) y
+  and f193 y = (f192 [@inlined never]) y
+  and f194 y = (f193 [@inlined never]) y
+  and f195 y = (f194 [@inlined never]) y
+  and f196 y = (f195 [@inlined never]) y
+  and f197 y = (f196 [@inlined never]) y
+  and f198 y = (f197 [@inlined never]) y
+  and f199 y = (f198 [@inlined never]) y
+  and f200 y = (f199 [@inlined never]) y
+  and f201 y = (f200 [@inlined never]) y
+  and f202 y = (f201 [@inlined never]) y
+  and f203 y = (f202 [@inlined never]) y
+  and f204 y = (f203 [@inlined never]) y
+  and f205 y = (f204 [@inlined never]) y
+  and f206 y = (f205 [@inlined never]) y
+  and f207 y = (f206 [@inlined never]) y
+  and f208 y = (f207 [@inlined never]) y
+  and f209 y = (f208 [@inlined never]) y
+  and f210 y = (f209 [@inlined never]) y
+  and f211 y = (f210 [@inlined never]) y
+  and f212 y = (f211 [@inlined never]) y
+  and f213 y = (f212 [@inlined never]) y
+  and f214 y = (f213 [@inlined never]) y
+  and f215 y = (f214 [@inlined never]) y
+  and f216 y = (f215 [@inlined never]) y
+  and f217 y = (f216 [@inlined never]) y
+  and f218 y = (f217 [@inlined never]) y
+  and f219 y = (f218 [@inlined never]) y
+  and f220 y = (f219 [@inlined never]) y
+  and f221 y = (f220 [@inlined never]) y
+  and f222 y = (f221 [@inlined never]) y
+  and f223 y = (f222 [@inlined never]) y
+  and f224 y = (f223 [@inlined never]) y
+  and f225 y = (f224 [@inlined never]) y
+  and f226 y = (f225 [@inlined never]) y
+  and f227 y = (f226 [@inlined never]) y
+  and f228 y = (f227 [@inlined never]) y
+  and f229 y = (f228 [@inlined never]) y
+  and f230 y = (f229 [@inlined never]) y
+  and f231 y = (f230 [@inlined never]) y
+  and f232 y = (f231 [@inlined never]) y
+  and f233 y = (f232 [@inlined never]) y
+  and f234 y = (f233 [@inlined never]) y
+  and f235 y = (f234 [@inlined never]) y
+  and f236 y = (f235 [@inlined never]) y
+  and f237 y = (f236 [@inlined never]) y
+  and f238 y = (f237 [@inlined never]) y
+  and f239 y = (f238 [@inlined never]) y
+  and f240 y = (f239 [@inlined never]) y
+  and f241 y = (f240 [@inlined never]) y
+  and f242 y = (f241 [@inlined never]) y
+  and f243 y = (f242 [@inlined never]) y
+  and f244 y = (f243 [@inlined never]) y
+  and f245 y = (f244 [@inlined never]) y
+  and f246 y = (f245 [@inlined never]) y
+  and f247 y = (f246 [@inlined never]) y
+  and f248 y = (f247 [@inlined never]) y
+  and f249 y = (f248 [@inlined never]) y
+  and f250 y = (f249 [@inlined never]) y
+  and f251 y = (f250 [@inlined never]) y
+  and f252 y = (f251 [@inlined never]) y
+  and f253 y = (f252 [@inlined never]) y
+  and f254 y = (f253 [@inlined never]) y
+  and f255 y = (f254 [@inlined never]) y
+  and f256 y = (f255 [@inlined never]) y
+  and f257 y = (f256 [@inlined never]) y
+  and f258 y = (f257 [@inlined never]) y
+  and f259 y = (f258 [@inlined never]) y
+  and f260 y = (f259 [@inlined never]) y
+  and f261 y = (f260 [@inlined never]) y
+  and f262 y = (f261 [@inlined never]) y
+  and f263 y = (f262 [@inlined never]) y
+  and f264 y = (f263 [@inlined never]) y
+  and f265 y = (f264 [@inlined never]) y
+  and f266 y = (f265 [@inlined never]) y
+  and f267 y = (f266 [@inlined never]) y
+  and f268 y = (f267 [@inlined never]) y
+  and f269 y = (f268 [@inlined never]) y
+  and f270 y = (f269 [@inlined never]) y
+end
+
+let words0 = Gc.minor_words ()
+let words1 = Gc.minor_words ()
+module X = F (struct let x = 42 end)
+let words2 = Gc.minor_words ()
+
+let expected = words1 -. words0
+
+let () =
+  match Sys.backend_type with
+  | Sys.Native ->
+    Printf.printf "%.0f" ((words2 -. words1) -. expected)
+  | Sys.Bytecode | Sys.Other _ ->
+    print_string "0"

diff --git a/testsuite/tests/basic-more/pr1271.reference b/testsuite/tests/basic-more/pr1271.reference
new file mode 100644 (file)
index 0000000..6e374c1
--- /dev/null
+++ b/testsuite/tests/basic-more/pr1271.reference
@@ -0,0 +1,2 @@
+0
+All tests succeeded.

diff --git a/testsuite/tests/basic-more/pr2719.ml b/testsuite/tests/basic-more/pr2719.ml
index f0a9d6a4f90f38bec195cae15edc3b76978bd483..d0357ea5e355429bd38a343c5244cbe7a9588646 100644 (file)
--- a/testsuite/tests/basic-more/pr2719.ml
+++ b/testsuite/tests/basic-more/pr2719.ml
@@ -3,12 +3,12 @@ open Printf
 let bug () =
   let mat = [| [|false|] |]
   and test = ref false in
-    printf "Value of test at the beginning : %b\n" !test; flush stdout;
+    printf "Value of test at the beginning : %B\n" !test; flush stdout;
     (try let _ = mat.(0).(-1) in
        (test := true;
         printf "Am I going through this block of instructions ?\n";
         flush stdout)
-     with Invalid_argument _ -> printf "Value of test now : %b\n" !test
+     with Invalid_argument _ -> printf "Value of test now : %B\n" !test
     );
     (try if mat.(0).(-1) then ()
      with Invalid_argument _ -> ()

diff --git a/testsuite/tests/basic-more/sequential_and_or.ml b/testsuite/tests/basic-more/sequential_and_or.ml
index 6492ea279e4314ba9032aa20820076c7a8c74ce3..b8aabae0f54df1f38e1acd053bbab8d5c52544ca 100644 (file)
--- a/testsuite/tests/basic-more/sequential_and_or.ml
+++ b/testsuite/tests/basic-more/sequential_and_or.ml
@@ -18,7 +18,7 @@ let test i f =
 let s = Bytes.of_string "\000"
 let () =
   (* ensure that the string is not constant *)
-  s.[0] <- '\001'
+  Bytes.set s 0 '\001'
 
 let unknown_true =
   Bytes.get s 0 = '\001'

diff --git a/testsuite/tests/basic-more/tformat.ml b/testsuite/tests/basic-more/tformat.ml
deleted file mode 100644 (file)
index 7a628ed..0000000
--- a/testsuite/tests/basic-more/tformat.ml
+++ /dev/null
@@ -1,21 +0,0 @@
-(*
-
-A testbed file for the module Format.
-
-*)
-
-open Testing;;
-
-open Format;;
-
-(* BR#4769 *)
-let test0 () =
-  let b = Buffer.create 10 in
-  let msg = "Hello world!" in
-  Format.bprintf b "%s" msg;
-  let s = Buffer.contents b in
-  s = msg
-;;
-
-test (test0 ())
-;;

diff --git a/testsuite/tests/basic-more/tformat.reference b/testsuite/tests/basic-more/tformat.reference
deleted file mode 100644 (file)
index 819c5ba..0000000
--- a/testsuite/tests/basic-more/tformat.reference
+++ /dev/null
@@ -1,2 +0,0 @@
- 0
-All tests succeeded.

diff --git a/testsuite/tests/basic-multdef/Makefile b/testsuite/tests/basic-multdef/Makefile
deleted file mode 100644 (file)
index 17dc2a5..0000000
--- a/testsuite/tests/basic-multdef/Makefile
+++ /dev/null
@@ -1,21 +0,0 @@
-#**************************************************************************
-#*                                                                        *
-#*                                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 GNU Lesser General Public License version 2.1, with the          *
-#*   special exception on linking described in the file LICENSE.          *
-#*                                                                        *
-#**************************************************************************
-
-BASEDIR=../..
-MODULES=multdef
-MAIN_MODULE=usemultdef
-
-include $(BASEDIR)/makefiles/Makefile.one
-include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/basic-multdef/ocamltests b/testsuite/tests/basic-multdef/ocamltests
new file mode 100644 (file)
index 0000000..0b7c97d
--- /dev/null
+++ b/testsuite/tests/basic-multdef/ocamltests
@@ -0,0 +1 @@
+usemultdef.ml

diff --git a/testsuite/tests/basic-multdef/usemultdef.ml b/testsuite/tests/basic-multdef/usemultdef.ml
index 2bccabb693e279ef6c7261f96112c523294d9b9d..477cf4ced5d48f2a0aeef5a4f72eeb4abba372bf 100644 (file)
--- a/testsuite/tests/basic-multdef/usemultdef.ml
+++ b/testsuite/tests/basic-multdef/usemultdef.ml
@@ -1 +1,5 @@
+(* TEST
+  modules = "multdef.ml"
+*)
+
 let _ = print_int(Multdef.f 1); print_newline(); exit 0

diff --git a/testsuite/tests/basic-private/Makefile b/testsuite/tests/basic-private/Makefile
deleted file mode 100644 (file)
index 1deeb9c..0000000
--- a/testsuite/tests/basic-private/Makefile
+++ /dev/null
@@ -1,22 +0,0 @@
-#**************************************************************************
-#*                                                                        *
-#*                                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 GNU Lesser General Public License version 2.1, with the          *
-#*   special exception on linking described in the file LICENSE.          *
-#*                                                                        *
-#**************************************************************************
-
-BASEDIR=../..
-
-MODULES=length
-MAIN_MODULE=tlength
-
-include $(BASEDIR)/makefiles/Makefile.one
-include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/basic-private/ocamltests b/testsuite/tests/basic-private/ocamltests
new file mode 100644 (file)
index 0000000..dd926c3
--- /dev/null
+++ b/testsuite/tests/basic-private/ocamltests
@@ -0,0 +1 @@
+tlength.ml

diff --git a/testsuite/tests/basic-private/tlength.ml b/testsuite/tests/basic-private/tlength.ml
index 73f0bf9548963c81410bc7ac3e3cc17758ca4045..00ce4cc843f1fe8cb98d61a226b891ae33567ee7 100644 (file)
--- a/testsuite/tests/basic-private/tlength.ml
+++ b/testsuite/tests/basic-private/tlength.ml
@@ -1,3 +1,7 @@
+(* TEST
+  modules = "length.ml"
+*)
+
 (*
 
 A testbed file for private type abbreviation definitions.

diff --git a/testsuite/tests/basic/Makefile b/testsuite/tests/basic/Makefile
index 446664a9d8d9b1dc0566cdb37f2a130fd3fa9234..26cdeadf21e9788a6f2609f4c0e7c20e10f6201f 100644 (file)
--- a/testsuite/tests/basic/Makefile
+++ b/testsuite/tests/basic/Makefile
@@ -1,33 +1,10 @@
-#**************************************************************************
-#*                                                                        *
-#*                                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 GNU Lesser General Public License version 2.1, with the          *
-#*   special exception on linking described in the file LICENSE.          *
-#*                                                                        *
-#**************************************************************************
-
-all: pr6322.ml check
-
 BASEDIR=../..
 include $(BASEDIR)/makefiles/Makefile.several
 include $(BASEDIR)/makefiles/Makefile.common
 
-GENERATED_SOURCES=pr6322.ml *.safe-string
-
-pr6322.ml: $(SAFE_STRING).safe-string
-ifeq ($(SAFE_STRING),false)
-       @cat pr6322.ml.in > $@
-else
-       @echo "Printf.printf \"PR#6322=Ok\\n%!\"" > $@
-endif
-
-%.safe-string:
-       @rm -f pr6322.ml
-       @touch $@
+# The trigraph.ml test always fails under OpenBSD 6 / i386
+# because of an unrelated warning emitted by the linker called by ocamlopt
+# (see commit log for details).
+# As a temporary workaround, we skip this test.
+SKIP=test $$file = trigraph.ml \
+     && test `uname -m` = i386 && test `uname -s` = OpenBSD

diff --git a/testsuite/tests/basic/eval_order_6.ml b/testsuite/tests/basic/eval_order_6.ml
new file mode 100644 (file)
index 0000000..14526e3
--- /dev/null
+++ b/testsuite/tests/basic/eval_order_6.ml
@@ -0,0 +1,17 @@
+type t =
+  { mutable x : int;
+    y : int }
+
+let f { x = c } =
+    fun () -> c;;
+
+let r = { x = 10; y = 20 };;
+
+let h = f r;;
+
+print_endline (string_of_int (h ()));;
+
+r.x <- 20;;
+
+print_endline (string_of_int (h ()));;
+

diff --git a/testsuite/tests/basic/eval_order_6.reference b/testsuite/tests/basic/eval_order_6.reference
new file mode 100644 (file)
index 0000000..b2f7f08
--- /dev/null
+++ b/testsuite/tests/basic/eval_order_6.reference
@@ -0,0 +1,2 @@
+10
+10

diff --git a/testsuite/tests/basic/maps.ml b/testsuite/tests/basic/maps.ml
index 2ed02dec2083dd8c653e41711557aca00da7e9b2..cc95eb638363dcf46689876a7e3a566be0f3721f 100644 (file)
--- a/testsuite/tests/basic/maps.ml
+++ b/testsuite/tests/basic/maps.ml
@@ -27,5 +27,45 @@ let () =
   print_endline "Union+concat (with Map.union)";
   let f3 _ l r = if l = r then None else Some (l ^ r) in
   show (IntMap.union f3 m1 m2);
-
   ()
+
+let show m = IntMap.iter (fun k v -> Printf.printf "%d -> %d\n" k v) m
+
+let update x f m =
+  let yp = IntMap.find_opt x m in
+  let y = f yp in
+  match yp, y with
+  | _, None -> IntMap.remove x m
+  | None, Some z -> IntMap.add x z m
+  | Some zp, Some z -> if zp == z then m else IntMap.add x z m
+
+let () =
+  print_endline "Update";
+  let rec init m  = function
+    | -1 -> m
+    | n -> init (IntMap.add n n m) (n - 1)
+  in
+  let n = 9 in
+  let m = init IntMap.empty n in
+  for i = 0 to n + 1 do
+    for j = 0 to n + 1 do
+      List.iter (function (k, f) ->
+          let m1 = update i f m in
+          let m2 = IntMap.update i f m in
+          if not (IntMap.equal ( = ) m1 m2 && ((m1 == m) = (m2 == m))) then begin
+            Printf.printf "ERROR: %s: %d -> %d\n" k i j;
+            print_endline "expected result:";
+            show m1;
+            print_endline "result:";
+            show m2;
+          end
+        )
+      [
+        "replace",                          (function None -> None   | Some _ -> Some j);
+        "delete if exists, bind otherwise", (function None -> Some j | Some _ -> None);
+        "delete",                           (function None -> None   | Some _ -> None);
+        "insert",                           (function None -> Some j | Some _ -> Some j);
+      ]
+    done;
+  done;
+;;

diff --git a/testsuite/tests/basic/maps.reference b/testsuite/tests/basic/maps.reference
index 7416150480ecfb4832d736198bf923bd4c6f22c5..b406eedb498a01d72d4b6c041b7ff555b6aebdab 100644 (file)
--- a/testsuite/tests/basic/maps.reference
+++ b/testsuite/tests/basic/maps.reference
@@ -8,3 +8,4 @@ Union+concat (with Map.union)
 0 AB
 3 X1
 5 X2
+Update

diff --git a/testsuite/tests/basic/pr6322.ml.in b/testsuite/tests/basic/pr6322.ml.in
deleted file mode 100644 (file)
index 460f0a3..0000000
--- a/testsuite/tests/basic/pr6322.ml.in
+++ /dev/null
@@ -1,11 +0,0 @@
-(* No string sharing PR#6322. This test is not applicable when OCaml is compiled with -safe-string. *)
-
-let test x = match x with
-  | true -> "a"
-  | false -> "a"
-
-let () =
-  let s1 = test true in
-  let s2 = test false in
-  s1.[0] <- 'p';
-  if s1 <> s2 then Printf.printf "PR#6322=Ok\n%!"

diff --git a/testsuite/tests/basic/pr6322.reference b/testsuite/tests/basic/pr6322.reference
deleted file mode 100644 (file)
index e07c25c..0000000
--- a/testsuite/tests/basic/pr6322.reference
+++ /dev/null
@@ -1 +0,0 @@
-PR#6322=Ok

diff --git a/testsuite/tests/basic/pr7657.ml b/testsuite/tests/basic/pr7657.ml
new file mode 100755 (executable)
index 0000000..8803cf3
--- /dev/null
+++ b/testsuite/tests/basic/pr7657.ml
@@ -0,0 +1,13 @@
+[@@@ocaml.warning "-21-5"]
+
+let foo g () = g 1; ()
+let f1 ?x y = print_endline "f1"
+let f2 ?x y = print_endline "f2"
+
+let () =
+  try foo (raise Exit; f1); print_endline "FAIL"
+  with Exit -> print_endline "OK"
+
+let r : (?x:unit -> int -> unit) ref = ref f1
+let h = foo r.contents
+let () = h (); r := f2; h ()

diff --git a/testsuite/tests/basic/pr7657.reference b/testsuite/tests/basic/pr7657.reference
new file mode 100644 (file)
index 0000000..2268fbe
--- /dev/null
+++ b/testsuite/tests/basic/pr7657.reference
@@ -0,0 +1,3 @@
+OK
+f1
+f1

diff --git a/testsuite/tests/basic/trigraph.ml b/testsuite/tests/basic/trigraph.ml
new file mode 100644 (file)
index 0000000..3b4914c
--- /dev/null
+++ b/testsuite/tests/basic/trigraph.ml
@@ -0,0 +1,3 @@
+(* PR#6373 *)
+
+let () = print_string "??'"

diff --git a/testsuite/tests/basic/trigraph.ml.silent-compilation b/testsuite/tests/basic/trigraph.ml.silent-compilation
new file mode 100644 (file)
index 0000000..e69de29

diff --git a/testsuite/tests/basic/trigraph.reference b/testsuite/tests/basic/trigraph.reference
new file mode 100644 (file)
index 0000000..988082b
--- /dev/null
+++ b/testsuite/tests/basic/trigraph.reference
@@ -0,0 +1 @@
+??'
\ No newline at end of file

diff --git a/testsuite/tests/callback/Makefile b/testsuite/tests/callback/Makefile
index d6615a1c49cc9233c9bcb7a519679274fdae1d68..27b36e583c0b44f24f82aca7683685dcb1d6565d 100644 (file)
--- a/testsuite/tests/callback/Makefile
+++ b/testsuite/tests/callback/Makefile
@@ -15,7 +15,6 @@
 
 BASEDIR=../..
 
-CC=$(NATIVECC) -I $(CTOPDIR)/byterun
 COMPFLAGS=-I $(OTOPDIR)/otherlibs/unix
 LD_PATH=$(TOPDIR)/otherlibs/unix
 
@@ -29,7 +28,7 @@ default:
 
 .PHONY: common
 common:
-       @$(CC) -c callbackprim.c
+       @$(CC) -c $(CFLAGS) $(CPPFLAGS)  -I$(CTOPDIR)/byterun callbackprim.c
 
 .PHONY: skip
 skip:

diff --git a/testsuite/tests/callback/callbackprim.c b/testsuite/tests/callback/callbackprim.c
index b1ab24653244671495e1dae151abaa4da7bb4168..45879a01917c3f1c1eae622494e6625b330fd1a8 100644 (file)
--- a/testsuite/tests/callback/callbackprim.c
+++ b/testsuite/tests/callback/callbackprim.c
@@ -20,21 +20,21 @@
 value mycallback1(value fun, value arg)
 {
   value res;
-  res = callback(fun, arg);
+  res = caml_callback(fun, arg);
   return res;
 }
 
 value mycallback2(value fun, value arg1, value arg2)
 {
   value res;
-  res = callback2(fun, arg1, arg2);
+  res = caml_callback2(fun, arg1, arg2);
   return res;
 }
 
 value mycallback3(value fun, value arg1, value arg2, value arg3)
 {
   value res;
-  res = callback3(fun, arg1, arg2, arg3);
+  res = caml_callback3(fun, arg1, arg2, arg3);
   return res;
 }
 
@@ -46,14 +46,14 @@ value mycallback4(value fun, value arg1, value arg2, value arg3, value arg4)
   args[1] = arg2;
   args[2] = arg3;
   args[3] = arg4;
-  res = callbackN(fun, 4, args);
+  res = caml_callbackN(fun, 4, args);
   return res;
 }
 
 value mypushroot(value v, value fun, value arg)
 {
   Begin_root(v)
-    callback(fun, arg);
+    caml_callback(fun, arg);
   End_roots();
   return v;
 }
@@ -63,7 +63,7 @@ value mycamlparam (value v, value fun, value arg)
   CAMLparam3 (v, fun, arg);
   CAMLlocal2 (x, y);
   x = v;
-  y = callback (fun, arg);
+  y = caml_callback (fun, arg);
   v = x;
   CAMLreturn (v);
 }

diff --git a/testsuite/tests/embedded/cmmain.c b/testsuite/tests/embedded/cmmain.c
index 04ed07286a32299451266331fd44119603793661..2fe048c10cd82b844a98af8787d873214ea0a056 100644 (file)
--- a/testsuite/tests/embedded/cmmain.c
+++ b/testsuite/tests/embedded/cmmain.c
@@ -20,16 +20,30 @@
 extern int fib(int n);
 extern char * format_result(int n);
 
+#ifdef _WIN32
+int wmain(int argc, wchar_t ** argv)
+#else
 int main(int argc, char ** argv)
+#endif
 {
   printf("Initializing OCaml code...\n");
+
+  /* Initializing the runtime twice, to check that it's possible to
+     make nested calls to caml_startup/caml_shutdown. */
 #ifdef NO_BYTECODE_FILE
   caml_startup(argv);
+  caml_startup(argv);
 #else
   caml_main(argv);
+  caml_main(argv);
 #endif
+
   printf("Back in C code...\n");
   printf("Computing fib(20)...\n");
   printf("%s\n", format_result(fib(20)));
+
+  caml_shutdown();
+  caml_shutdown();
+
   return 0;
 }

diff --git a/testsuite/tests/functors/Makefile b/testsuite/tests/functors/Makefile
new file mode 100644 (file)
index 0000000..c4223d4
--- /dev/null
+++ b/testsuite/tests/functors/Makefile
@@ -0,0 +1,4 @@
+BASEDIR=../..
+TOPFLAGS+=-dlambda
+include $(BASEDIR)/makefiles/Makefile.dlambda
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/functors/functors.ml b/testsuite/tests/functors/functors.ml
new file mode 100644 (file)
index 0000000..3254169
--- /dev/null
+++ b/testsuite/tests/functors/functors.ml
@@ -0,0 +1,41 @@
+module type S = sig
+  val foo : int -> int
+end
+
+module O (X : S) = struct
+  let cow x = X.foo x
+  let sheep x = 1 + cow x
+end [@@inline always]
+
+module F (X : S) (Y : S) = struct
+  let cow x = Y.foo (X.foo x)
+  let sheep x = 1 + cow x
+end [@@inline always]
+
+module type S1 = sig
+  val bar : int -> int
+  val foo : int -> int
+end
+
+module type T = sig
+  val sheep : int -> int
+end
+
+module F1 (X : S) (Y : S) : T = struct
+  let cow x = Y.foo (X.foo x)
+  let sheep x = 1 + cow x
+end [@@inline always]
+
+module F2 : S1 -> S1 -> T = functor (X : S) -> functor (Y : S) -> struct
+  let cow x = Y.foo (X.foo x)
+  let sheep x = 1 + cow x
+end [@@inline always]
+
+module M : sig
+  module F (X : S1) (Y : S1) : T
+end = struct
+  module F (X : S) (Y : S) = struct
+    let cow x = Y.foo (X.foo x)
+    let sheep x = 1 + cow x
+  end [@@inline always]
+end

diff --git a/testsuite/tests/functors/functors.ml.reference b/testsuite/tests/functors/functors.ml.reference
new file mode 100644 (file)
index 0000000..8037fe5
--- /dev/null
+++ b/testsuite/tests/functors/functors.ml.reference
@@ -0,0 +1,60 @@
+(setglobal Functors!
+  (let
+    (O =
+       (module-defn(O) functors.ml(5):48-143
+         (function X is_a_functor always_inline
+           (let
+             (cow = (function x (apply (field 0 X) x))
+              sheep = (function x (+ 1 (apply cow x))))
+             (makeblock 0 cow sheep))))
+     F =
+       (module-defn(F) functors.ml(10):145-256
+         (function X Y is_a_functor always_inline
+           (let
+             (cow =
+                (function x
+                  (apply (field 0 Y) (apply (field 0 X) x)))
+              sheep = (function x (+ 1 (apply cow x))))
+             (makeblock 0 cow sheep))))
+     F1/1022 =
+       (module-defn(F1/1022) functors.ml(24):380-496
+         (function X Y is_a_functor always_inline
+           (let
+             (cow =
+                (function x
+                  (apply (field 0 Y) (apply (field 0 X) x)))
+              sheep = (function x (+ 1 (apply cow x))))
+             (makeblock 0 sheep))))
+     F2/1029 =
+       (module-defn(F2/1029) functors.ml(29):498-648
+         (function X Y is_a_functor always_inline
+           (let
+             (X =a (makeblock 0 (field 1 X))
+              Y =a (makeblock 0 (field 1 Y))
+              cow =
+                (function x
+                  (apply (field 0 Y) (apply (field 0 X) x)))
+              sheep = (function x (+ 1 (apply cow x))))
+             (makeblock 0 sheep))))
+     M =
+       (module-defn(M) functors.ml(34):650-834
+         (let
+           (F =
+              (module-defn(F) functors.ml(37):713-830
+                (function X Y is_a_functor always_inline
+                  (let
+                    (cow =
+                       (function x
+                         (apply (field 0 Y)
+                           (apply (field 0 X) x)))
+                     sheep =
+                       (function x (+ 1 (apply cow x))))
+                    (makeblock 0 cow sheep)))))
+           (makeblock 0
+             (function funarg funarg is_a_functor stub
+               (let
+                 (let =
+                    (apply F (makeblock 0 (field 1 funarg))
+                      (makeblock 0 (field 1 funarg))))
+                 (makeblock 0 (field 1 let))))))))
+    (makeblock 0 O F F1/1022 F2/1029 M)))

diff --git a/testsuite/tests/letrec-disallowed/Makefile b/testsuite/tests/letrec-disallowed/Makefile
new file mode 100644 (file)
index 0000000..7fc0066
--- /dev/null
+++ b/testsuite/tests/letrec-disallowed/Makefile
@@ -0,0 +1,18 @@
+#**************************************************************************
+#*                                                                        *
+#*                                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 GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.toplevel
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/letrec-disallowed/disallowed.ml b/testsuite/tests/letrec-disallowed/disallowed.ml
new file mode 100644 (file)
index 0000000..ded2be9
--- /dev/null
+++ b/testsuite/tests/letrec-disallowed/disallowed.ml
@@ -0,0 +1,112 @@
+let rec x = let y = () in x;;
+
+let rec x = let module M = struct let f = x let g = x () end in fun () -> ();;
+
+let rec x = let module M = struct let f = x () let g = x end in fun () -> ();;
+
+let rec x = (let module M = struct let f = y 0 let g = () end in fun () -> ())
+    and y = succ;;
+
+let rec x = let module M = struct module N = struct let y = x end end in M.N.y;;
+
+let rec x = let module M = struct let f = x () and g = x end in fun () -> ();;
+
+class c _ = object end;;
+let rec x = new c x;;
+
+let rec x = ignore x;;
+
+let rec x = y 0 and y _ = ();;
+
+let rec c = { c with Complex.re = 1.0 };;
+
+let rec b = if b then true else false;;
+
+let r = ref ()
+let rec x = r := x;;
+
+let rec x =
+  for i = 0 to 1 do
+    let z = y in ignore z
+  done
+and y = x; ();;
+
+let rec x =
+  for i = 0 to y do
+    ()
+  done
+and y = 10;;
+
+let rec x =
+  for i = y to 10 do
+    ()
+  done
+and y = 0;;
+
+let rec x =
+  while false do
+    let y = x in ignore y
+  done
+and y = x; ();;
+
+let rec x =
+  while y do
+    ()
+  done
+and y = false;;
+
+let rec x =
+  while y do
+    let y = x in ignore y
+  done
+and y = false;;
+
+let rec x = y#m and y = object method m = () end;;
+
+let rec x = (object method m _ = () end)#m x;;
+
+let rec x = y.contents and y = { contents = 3 };;
+
+let rec x = object val mutable v = 0 method m = v <- y end and y = 1;;
+
+let rec x = assert y and y = true;;
+
+let rec x = object method m = x end;;
+
+let rec x = object method m = ignore x end;;
+
+(* The builtin Pervasives.ref is currently treated as a constructor.
+   Other functions of the same name should not be so treated. *)
+let _ =
+  let module Pervasives =
+  struct
+    let ref _ = assert false
+  end in
+  let rec x = Pervasives.ref y
+  and y = fun () -> ignore x
+  in (x, y)
+;;
+
+(* An example, from Leo White, of let rec bindings that allocate
+   values of unknown size *)
+let foo p x =
+  let rec f =
+    if p then (fun y -> x + g y) else (fun y -> g y)
+  and g =
+    if not p then (fun y -> x - f y) else (fun y -> f y)
+  in
+  (f, g)
+;;
+
+module type T = sig end
+let rec x = (module (val y : T) : T)
+and y = let module M = struct let x = x end in (module M : T)
+;;
+
+let rec x =
+  match let _ = y in raise Not_found with
+    _ -> "x"
+  | exception Not_found -> "z" 
+and y = match x with
+  z -> ("y", z);;
+

diff --git a/testsuite/tests/letrec-disallowed/disallowed.ml.reference b/testsuite/tests/letrec-disallowed/disallowed.ml.reference
new file mode 100644 (file)
index 0000000..c053974
--- /dev/null
+++ b/testsuite/tests/letrec-disallowed/disallowed.ml.reference
@@ -0,0 +1,126 @@
+
+# Characters 12-27:
+  let rec x = let y = () in x;;
+              ^^^^^^^^^^^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+#   Characters 13-77:
+  let rec x = let module M = struct let f = x let g = x () end in fun () -> ();;
+              ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+#   Characters 13-77:
+  let rec x = let module M = struct let f = x () let g = x end in fun () -> ();;
+              ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+#     Characters 13-79:
+  let rec x = (let module M = struct let f = y 0 let g = () end in fun () -> ())
+              ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+#   Characters 13-79:
+  let rec x = let module M = struct module N = struct let y = x end end in M.N.y;;
+              ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+#   Characters 13-77:
+  let rec x = let module M = struct let f = x () and g = x end in fun () -> ();;
+              ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+#   class c : 'a -> object  end
+# Characters 12-19:
+  let rec x = new c x;;
+              ^^^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+#   Characters 13-21:
+  let rec x = ignore x;;
+              ^^^^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+#   Characters 13-16:
+  let rec x = y 0 and y _ = ();;
+              ^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+#   Characters 13-40:
+  let rec c = { c with Complex.re = 1.0 };;
+              ^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+#   Characters 13-38:
+  let rec b = if b then true else false;;
+              ^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+#     Characters 28-34:
+  let rec x = r := x;;
+              ^^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+#           Characters 15-65:
+  ..for i = 0 to 1 do
+      let z = y in ignore z
+    done
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+#           Characters 15-46:
+  ..for i = 0 to y do
+      ()
+    done
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+#           Characters 15-47:
+  ..for i = y to 10 do
+      ()
+    done
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+#           Characters 15-62:
+  ..while false do
+      let y = x in ignore y
+    done
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+#           Characters 15-39:
+  ..while y do
+      ()
+    done
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+#           Characters 15-58:
+  ..while y do
+      let y = x in ignore y
+    done
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+#   Characters 13-16:
+  let rec x = y#m and y = object method m = () end;;
+              ^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+#   Characters 13-45:
+  let rec x = (object method m _ = () end)#m x;;
+              ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+#   Characters 13-23:
+  let rec x = y.contents and y = { contents = 3 };;
+              ^^^^^^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+#   Characters 13-59:
+  let rec x = object val mutable v = 0 method m = v <- y end and y = 1;;
+              ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+#   Characters 13-21:
+  let rec x = assert y and y = true;;
+              ^^^^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+#   Characters 13-36:
+  let rec x = object method m = x end;;
+              ^^^^^^^^^^^^^^^^^^^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+#   Characters 13-43:
+  let rec x = object method m = ignore x end;;
+              ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+#   *                   Characters 230-246:
+    let rec x = Pervasives.ref y
+                ^^^^^^^^^^^^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+#   *                 Characters 127-175:
+      if p then (fun y -> x + g y) else (fun y -> g y)
+      ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+#         Characters 37-61:
+  let rec x = (module (val y : T) : T)
+              ^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+#             Characters 15-98:
+  ..match let _ = y in raise Not_found with
+      _ -> "x"
+    | exception Not_found -> "z".
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+#   

diff --git a/testsuite/tests/letrec-disallowed/extension_constructor.ml b/testsuite/tests/letrec-disallowed/extension_constructor.ml
new file mode 100644 (file)
index 0000000..eb013ea
--- /dev/null
+++ b/testsuite/tests/letrec-disallowed/extension_constructor.ml
@@ -0,0 +1,12 @@
+(* Example from Stephen Dolan.
+   Accessing an extension constructor involves accessing the module
+   in which it's defined.
+ *)
+module type T =
+  sig exception A of int end;;
+
+let rec x =
+  let module M = (val m) in
+  M.A 42
+and (m : (module T)) =
+  (module (struct exception A of int end));;

diff --git a/testsuite/tests/letrec-disallowed/extension_constructor.ml.reference b/testsuite/tests/letrec-disallowed/extension_constructor.ml.reference
new file mode 100644 (file)
index 0000000..f680d73
--- /dev/null
+++ b/testsuite/tests/letrec-disallowed/extension_constructor.ml.reference
@@ -0,0 +1,7 @@
+
+# * * *     module type T = sig exception A of int end
+#           Characters 15-49:
+  ..let module M = (val m) in
+    M.A 42
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+# 

diff --git a/testsuite/tests/letrec-disallowed/float_block.ml b/testsuite/tests/letrec-disallowed/float_block.ml
new file mode 100644 (file)
index 0000000..4f8fc9d
--- /dev/null
+++ b/testsuite/tests/letrec-disallowed/float_block.ml
@@ -0,0 +1,6 @@
+let test =
+  let rec x = [| y; y |] and y = 1. in
+  assert (x = [| 1.; 1. |]);
+  assert (y = 1.);
+  ()
+;;

diff --git a/testsuite/tests/letrec-disallowed/float_block.ml.reference b/testsuite/tests/letrec-disallowed/float_block.ml.reference
new file mode 100644 (file)
index 0000000..58b1e32
--- /dev/null
+++ b/testsuite/tests/letrec-disallowed/float_block.ml.reference
@@ -0,0 +1,6 @@
+
+#           Characters 25-35:
+    let rec x = [| y; y |] and y = 1. in
+                ^^^^^^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+# 

diff --git a/testsuite/tests/letrec-disallowed/generic_arrays.ml b/testsuite/tests/letrec-disallowed/generic_arrays.ml
new file mode 100644 (file)
index 0000000..46d9342
--- /dev/null
+++ b/testsuite/tests/letrec-disallowed/generic_arrays.ml
@@ -0,0 +1,3 @@
+(* This is not allowed because constructing the generic array 'x' involves
+   inspecting 'y', which is bound in the same recursive group *)
+let f z = let rec x = [| y; z |] and y = z in x;;

diff --git a/testsuite/tests/letrec-disallowed/generic_arrays.ml.reference b/testsuite/tests/letrec-disallowed/generic_arrays.ml.reference
new file mode 100644 (file)
index 0000000..449d1a0
--- /dev/null
+++ b/testsuite/tests/letrec-disallowed/generic_arrays.ml.reference
@@ -0,0 +1,6 @@
+
+# *   Characters 162-172:
+  let f z = let rec x = [| y; z |] and y = z in x;;
+                        ^^^^^^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+# 

diff --git a/testsuite/tests/letrec-disallowed/lazy_.ml b/testsuite/tests/letrec-disallowed/lazy_.ml
new file mode 100644 (file)
index 0000000..e958ef1
--- /dev/null
+++ b/testsuite/tests/letrec-disallowed/lazy_.ml
@@ -0,0 +1,3 @@
+let rec a = lazy b and b = 3;;
+
+let rec e = lazy (fun _ -> f) and f = ();;

diff --git a/testsuite/tests/letrec-disallowed/lazy_.ml.reference b/testsuite/tests/letrec-disallowed/lazy_.ml.reference
new file mode 100644 (file)
index 0000000..538bf00
--- /dev/null
+++ b/testsuite/tests/letrec-disallowed/lazy_.ml.reference
@@ -0,0 +1,8 @@
+
+# Characters 12-18:
+  let rec a = lazy b and b = 3;;
+              ^^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+#   val e : ('a -> unit) lazy_t = lazy <fun>
+val f : unit = ()
+# 

diff --git a/testsuite/tests/letrec-disallowed/module_constraints.ml b/testsuite/tests/letrec-disallowed/module_constraints.ml
new file mode 100644 (file)
index 0000000..faf81f2
--- /dev/null
+++ b/testsuite/tests/letrec-disallowed/module_constraints.ml
@@ -0,0 +1,6 @@
+module type S = sig               val y : float end;;
+module type T = sig val x : float val y : float end;;
+type t = T : (module S) -> t;;
+
+let rec x = let module M = (val m) in T (module M)
+and (m : (module T)) = (module (struct let x = 10.0 and y = 20.0 end));;

diff --git a/testsuite/tests/letrec-disallowed/module_constraints.ml.reference b/testsuite/tests/letrec-disallowed/module_constraints.ml.reference
new file mode 100644 (file)
index 0000000..b1aec6f
--- /dev/null
+++ b/testsuite/tests/letrec-disallowed/module_constraints.ml.reference
@@ -0,0 +1,9 @@
+
+# module type S = sig val y : float end
+# module type T = sig val x : float val y : float end
+# type t = T : (module S) -> t
+#     Characters 13-51:
+  let rec x = let module M = (val m) in T (module M)
+              ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+# 

diff --git a/testsuite/tests/letrec-disallowed/pr7215.ml b/testsuite/tests/letrec-disallowed/pr7215.ml
new file mode 100644 (file)
index 0000000..223434d
--- /dev/null
+++ b/testsuite/tests/letrec-disallowed/pr7215.ml
@@ -0,0 +1,9 @@
+(* From Stephen Dolan *)
+type (_,_) eq = Refl : ('a, 'a) eq;;
+let cast (type a) (type b) (Refl : (a, b) eq) (x : a) = (x : b);;
+
+let is_int (type a) =
+  let rec (p : (int, a) eq) = match p with Refl -> Refl in
+  p
+
+let bang = print_string (cast (is_int : (int, string) eq) 42);;

diff --git a/testsuite/tests/letrec-disallowed/pr7215.ml.reference b/testsuite/tests/letrec-disallowed/pr7215.ml.reference
new file mode 100644 (file)
index 0000000..19735e4
--- /dev/null
+++ b/testsuite/tests/letrec-disallowed/pr7215.ml.reference
@@ -0,0 +1,8 @@
+
+#   type (_, _) eq = Refl : ('a, 'a) eq
+# val cast : ('a, 'b) eq -> 'a -> 'b = <fun>
+#           Characters 53-78:
+    let rec (p : (int, a) eq) = match p with Refl -> Refl in
+                                ^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+# 

diff --git a/testsuite/tests/letrec-disallowed/pr7231.ml b/testsuite/tests/letrec-disallowed/pr7231.ml
new file mode 100644 (file)
index 0000000..5f8282d
--- /dev/null
+++ b/testsuite/tests/letrec-disallowed/pr7231.ml
@@ -0,0 +1 @@
+let rec r = let rec x () = r and y () = x () in y () in r "oops";; 

diff --git a/testsuite/tests/letrec-disallowed/pr7231.ml.reference b/testsuite/tests/letrec-disallowed/pr7231.ml.reference
new file mode 100644 (file)
index 0000000..a764815
--- /dev/null
+++ b/testsuite/tests/letrec-disallowed/pr7231.ml.reference
@@ -0,0 +1,10 @@
+
+# Characters 58-64:
+  let rec r = let rec x () = r and y () = x () in y () in r "oops";; 
+                                                            ^^^^^^
+Warning 20: this argument will not be used by the function.
+Characters 12-52:
+  let rec r = let rec x () = r and y () = x () in y () in r "oops";; 
+              ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+# 

diff --git a/testsuite/tests/letrec-disallowed/unboxed.ml b/testsuite/tests/letrec-disallowed/unboxed.ml
new file mode 100644 (file)
index 0000000..c19fefa
--- /dev/null
+++ b/testsuite/tests/letrec-disallowed/unboxed.ml
@@ -0,0 +1,6 @@
+type t = {x: int64} [@@unboxed];;
+let rec x = {x = y} and y = 3L;;
+
+type r = A of r [@@unboxed];;
+let rec y = A y;;
+              

diff --git a/testsuite/tests/letrec-disallowed/unboxed.ml.reference b/testsuite/tests/letrec-disallowed/unboxed.ml.reference
new file mode 100644 (file)
index 0000000..b824227
--- /dev/null
+++ b/testsuite/tests/letrec-disallowed/unboxed.ml.reference
@@ -0,0 +1,12 @@
+
+# type t = { x : int64; } [@@unboxed]
+# Characters 12-19:
+  let rec x = {x = y} and y = 3L;;
+              ^^^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+#   type r = A of r [@@unboxed]
+# Characters 12-15:
+  let rec y = A y;;
+              ^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+#   

diff --git a/testsuite/tests/letrec/allowed.ml b/testsuite/tests/letrec/allowed.ml
new file mode 100644 (file)
index 0000000..f8e8956
--- /dev/null
+++ b/testsuite/tests/letrec/allowed.ml
@@ -0,0 +1,78 @@
+let rec x = (x; ());;
+
+let rec x = let x = () in x;;
+
+let rec x = [y]
+and y = let x = () in x;;
+
+let rec x = [y]
+and y = let rec x = () in x;;
+
+let rec x =
+  let a = x in
+  fun () -> a ()
+and y =
+  [x];;
+
+let rec x = let module M = struct let f = x end in ();;
+
+module type T = sig val y: int end
+
+let rec x = let module M =
+            struct
+              module N =
+              struct
+                let y = x
+              end
+            end
+  in fun () -> ignore (M.N.y ());;
+
+let rec x = "x";;
+
+class c = object end
+let rec x = fun () -> new c;;
+
+let rec x = (y, y)
+and y = fun () -> ignore x;;
+
+let rec x = Some y
+and y = fun () -> ignore x
+;;
+
+let rec x = `A y
+and y = fun () -> ignore x
+;;
+
+let rec x = { contents = y }
+and y = fun () -> ignore x;;
+               
+let r = ref (fun () -> ())
+let rec x = fun () -> r := x;;
+
+let rec x = fun () -> y.contents and y = { contents = 3 };;
+
+let rec x = function
+    Some _ -> ignore (y [])
+  | None -> ignore (y [])
+and y = function
+    [] -> ignore (x None)
+  | _ :: _ -> ignore (x None)
+    ;;
+
+let rec x = lazy (Lazy.force x + Lazy.force x)
+  ;;
+
+let rec x = { x with contents = 3 }  [@ocaml.warning "-23"];;
+
+let rec x = let y = (x; ()) in y;;
+
+let rec x = [|y|] and y = 0;;
+
+(* Recursively constructing arrays of known non-float type is permitted *)
+let rec deep_cycle : [`Tuple of [`Shared of 'a] array] as 'a
+  = `Tuple [| `Shared deep_cycle |];;
+
+(* Constructing float arrays was disallowed altogether at one point
+   by an overzealous check.  Constructing float arrays in recursive 
+   bindings is fine when they don't partake in the recursion. *)
+let rec _x = let _ = [| 1.0 |] in 1. in ();;

diff --git a/testsuite/tests/letrec/allowed.reference b/testsuite/tests/letrec/allowed.reference
new file mode 100644 (file)
index 0000000..e69de29

diff --git a/testsuite/tests/letrec/disallowed.reference b/testsuite/tests/letrec/disallowed.reference
new file mode 100644 (file)
index 0000000..1c75897
--- /dev/null
+++ b/testsuite/tests/letrec/disallowed.reference
@@ -0,0 +1,149 @@
+
+# Characters 12-27:
+  let rec x = let y = () in x;;
+              ^^^^^^^^^^^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+#   Characters 13-77:
+  let rec x = let module M = struct let f = x let g = x () end in fun () -> ();;
+              ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+#   Characters 13-77:
+  let rec x = let module M = struct let f = x () let g = x end in fun () -> ();;
+              ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+#     Characters 13-79:
+  let rec x = (let module M = struct let f = y 0 let g = () end in fun () -> ())
+              ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+#   Characters 13-79:
+  let rec x = let module M = struct module N = struct let y = x end end in M.N.y;;
+              ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+#   Characters 13-77:
+  let rec x = let module M = struct let f = x () and g = x end in fun () -> ();;
+              ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+#   class c : 'a -> object  end
+# Characters 12-19:
+  let rec x = new c x;;
+              ^^^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+#   Characters 13-21:
+  let rec x = ignore x;;
+              ^^^^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+#   Characters 13-16:
+  let rec x = y 0 and y _ = ();;
+              ^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+#     Characters 13-18:
+  let rec x = [|y|]
+              ^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+#   Characters 13-40:
+  let rec c = { c with Complex.re = 1.0 };;
+              ^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+#   Characters 13-36:
+  let rec x = { x with contents = 3 };;
+              ^^^^^^^^^^^^^^^^^^^^^^^
+Warning 23: all the fields are explicitly listed in this record:
+the 'with' clause is useless.
+Characters 13-36:
+  let rec x = { x with contents = 3 };;
+              ^^^^^^^^^^^^^^^^^^^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+#   Characters 13-38:
+  let rec b = if b then true else false;;
+              ^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+#     Characters 28-34:
+  let rec x = r := x;;
+              ^^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+#           Characters 15-65:
+  ..for i = 0 to 1 do
+      let z = y in ignore z
+    done
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+#           Characters 15-46:
+  ..for i = 0 to y do
+      ()
+    done
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+#           Characters 15-47:
+  ..for i = y to 10 do
+      ()
+    done
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+#           Characters 15-62:
+  ..while false do
+      let y = x in ignore y
+    done
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+#           Characters 15-39:
+  ..while y do
+      ()
+    done
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+#               Characters 15-58:
+  ..while y do
+      let y = x in ignore y
+    done
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+#   Characters 13-45:
+  let rec x = (object method m _ = () end)#m x;;
+              ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+#   Characters 13-23:
+  let rec x = y.contents and y = { contents = 3 };;
+              ^^^^^^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+#   Characters 13-59:
+  let rec x = object val mutable v = 0 method m = v <- y end and y = 1;;
+              ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+#   Characters 13-21:
+  let rec x = assert y and y = true;;
+              ^^^^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+#   Characters 13-36:
+  let rec x = object method m = x end;;
+              ^^^^^^^^^^^^^^^^^^^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+#   Characters 13-43:
+  let rec x = object method m = ignore x end;;
+              ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+#   *                   Characters 230-246:
+    let rec x = Pervasives.ref y
+                ^^^^^^^^^^^^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+#   *                 Characters 127-175:
+      if p then (fun y -> x + g y) else (fun y -> g y)
+      ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+#   Characters 13-33:
+  let rec x = let y = (x; ()) in y;;
+              ^^^^^^^^^^^^^^^^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+#           Characters 15-58:
+  ..for i = 0 to 1 do
+      let z = y in z
+    done
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+#         Characters 37-61:
+  let rec x = (module (val y : T) : T)
+              ^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+#           Characters 15-55:
+  ..while false do
+      let y = x in y
+    done
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+#             Characters 15-98:
+  ..match let _ = y in raise Not_found with
+      _ -> "x"
+    | exception Not_found -> "z".
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+#   

diff --git a/testsuite/tests/letrec/float_block_2.ml b/testsuite/tests/letrec/float_block_2.ml
deleted file mode 100644 (file)
index 968cba4..0000000
--- a/testsuite/tests/letrec/float_block_2.ml
+++ /dev/null
@@ -1,7 +0,0 @@
-(* a bug in cmmgen.ml provokes a segfault in certain natively compiled
-   letrec-bindings involving float arrays *)
-let test =
-  let rec x = [| y; y |] and y = 1. in
-  assert (x = [| 1.; 1. |]);
-  assert (y = 1.);
-  ()

diff --git a/testsuite/tests/letrec/generic_array.ml b/testsuite/tests/letrec/generic_array.ml
new file mode 100644 (file)
index 0000000..f71eb34
--- /dev/null
+++ b/testsuite/tests/letrec/generic_array.ml
@@ -0,0 +1,3 @@
+let rec x = let _y = [| |] in ();;
+
+let rec x = let y = [| |] in y :: x;;

diff --git a/testsuite/tests/letrec/generic_array.reference b/testsuite/tests/letrec/generic_array.reference
new file mode 100644 (file)
index 0000000..e69de29

diff --git a/testsuite/tests/letrec/lazy_.ml b/testsuite/tests/letrec/lazy_.ml
new file mode 100644 (file)
index 0000000..08c022f
--- /dev/null
+++ b/testsuite/tests/letrec/lazy_.ml
@@ -0,0 +1,3 @@
+let rec c = lazy (0 + d) and d = 3;;
+
+let () = Printf.printf "%d\n" (Lazy.force c)

diff --git a/testsuite/tests/letrec/lazy_.reference b/testsuite/tests/letrec/lazy_.reference
new file mode 100644 (file)
index 0000000..00750ed
--- /dev/null
+++ b/testsuite/tests/letrec/lazy_.reference
@@ -0,0 +1 @@
+3

diff --git a/testsuite/tests/letrec/nested.ml b/testsuite/tests/letrec/nested.ml
new file mode 100644 (file)
index 0000000..d87a958
--- /dev/null
+++ b/testsuite/tests/letrec/nested.ml
@@ -0,0 +1,7 @@
+(* Mantis PR7447 *)
+
+let rec r = (let rec x = `A r and y = fun () -> x in y)
+
+let (`A x) = r () 
+
+let _ = x ()

diff --git a/testsuite/tests/letrec/nested.reference b/testsuite/tests/letrec/nested.reference
new file mode 100644 (file)
index 0000000..e69de29

diff --git a/testsuite/tests/letrec/pr4989.ml b/testsuite/tests/letrec/pr4989.ml
new file mode 100644 (file)
index 0000000..d608b3c
--- /dev/null
+++ b/testsuite/tests/letrec/pr4989.ml
@@ -0,0 +1 @@
+let rec f = let g = f in fun x -> g x;;

diff --git a/testsuite/tests/letrec/pr4989.reference b/testsuite/tests/letrec/pr4989.reference
new file mode 100644 (file)
index 0000000..e69de29

diff --git a/testsuite/tests/letrec/ref.ml b/testsuite/tests/letrec/ref.ml
new file mode 100644 (file)
index 0000000..483cdcb
--- /dev/null
+++ b/testsuite/tests/letrec/ref.ml
@@ -0,0 +1,12 @@
+(* Test construction of cyclic values where the cycles pass through references *)
+
+type t = { mutable next : t; mutable inst : n ref }
+and n = T of t
+
+let rec d = { next = d; inst = ref (T d) }
+
+let f t1 t2 =
+  let rec self = ref init
+  and init () = t1 (function () -> self := t2; t2 ())
+  in fun () -> !self ()
+;;

diff --git a/testsuite/tests/letrec/ref.reference b/testsuite/tests/letrec/ref.reference
new file mode 100644 (file)
index 0000000..e69de29

diff --git a/testsuite/tests/lexing/Makefile b/testsuite/tests/lexing/Makefile
new file mode 100644 (file)
index 0000000..9625a3f
--- /dev/null
+++ b/testsuite/tests/lexing/Makefile
@@ -0,0 +1,3 @@
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.toplevel
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/lexing/uchar_esc.ml b/testsuite/tests/lexing/uchar_esc.ml
new file mode 100644 (file)
index 0000000..b288ac2
--- /dev/null
+++ b/testsuite/tests/lexing/uchar_esc.ml
@@ -0,0 +1,34 @@
+
+(* Correct escapes and their encoding *)
+
+let () =
+  assert ("\xF0\x9F\x90\xAB" = "\u{1F42B}");
+  assert ("\xF0\x9F\x90\xAB" = "\u{01F42B}");
+  assert ("\x00" = "\u{0}");
+  assert ("\x00" = "\u{00}");
+  assert ("\x00" = "\u{000}");
+  assert ("\x00" = "\u{0000}");
+  assert ("\x00" = "\u{00000}");
+  assert ("\x00" = "\u{000000}");
+  assert ("\xC3\xA9" = "\u{E9}");
+  assert ("\xC3\xA9" = "\u{0E9}");
+  assert ("\xC3\xA9" = "\u{00E9}");
+  assert ("\xC3\xA9" = "\u{000E9}");
+  assert ("\xC3\xA9" = "\u{0000E9}");
+  assert ("\xC3\xA9" = "\u{0000E9}");
+  assert ("\xF4\x8F\xBF\xBF" = "\u{10FFFF}");
+  ()
+;;
+
+
+(* Errors *)
+
+let invalid_sv = "\u{0D800}" ;;
+let invalid_sv = "\u{D800}" ;;
+let invalid_sv = "\u{D900}" ;;
+let invalid_sv = "\u{DFFF}" ;;
+let invalid_sv = "\u{110000} ;;
+
+let too_many_digits = "\u{01234567}" ;;
+let no_hex_digits = "\u{}" ;;
+let illegal_hex_digit = "\u{u}" ;;

diff --git a/testsuite/tests/lexing/uchar_esc.ml.reference b/testsuite/tests/lexing/uchar_esc.ml.reference
new file mode 100644 (file)
index 0000000..8730059
--- /dev/null
+++ b/testsuite/tests/lexing/uchar_esc.ml.reference
@@ -0,0 +1,36 @@
+
+#                                         #         Characters 34-43:
+  let invalid_sv = "\u{0D800}" ;;
+                    ^^^^^^^^^
+Error: Illegal backslash escape in string or character (\u{0D800}, D800 is not a Unicode scalar value)
+# Characters 18-26:
+  let invalid_sv = "\u{D800}" ;;
+                    ^^^^^^^^
+Error: Illegal backslash escape in string or character (\u{D800}, D800 is not a Unicode scalar value)
+# Characters 18-26:
+  let invalid_sv = "\u{D900}" ;;
+                    ^^^^^^^^
+Error: Illegal backslash escape in string or character (\u{D900}, D900 is not a Unicode scalar value)
+# Characters 18-26:
+  let invalid_sv = "\u{DFFF}" ;;
+                    ^^^^^^^^
+Error: Illegal backslash escape in string or character (\u{DFFF}, DFFF is not a Unicode scalar value)
+# Characters 18-28:
+  let invalid_sv = "\u{110000} ;;
+                    ^^^^^^^^^^
+Error: Illegal backslash escape in string or character (\u{110000}, 110000 is not a Unicode scalar value)
+#   Characters 24-36:
+  let too_many_digits = "\u{01234567}" ;;
+                         ^^^^^^^^^^^^
+Error: Illegal backslash escape in string or character (\u{01234567}, too many digits, expected 1 to 6 hexadecimal digits)
+# Characters 21-23:
+  let no_hex_digits = "\u{}" ;;
+                       ^^
+Warning 14: illegal backslash escape in string.
+val no_hex_digits : string = "\\u{}"
+# Characters 25-27:
+  let illegal_hex_digit = "\u{u}" ;;
+                           ^^
+Warning 14: illegal backslash escape in string.
+val illegal_hex_digit : string = "\\u{u}"
+# 

diff --git a/testsuite/tests/lib-arg/testarg.ml b/testsuite/tests/lib-arg/testarg.ml
index 380f420cd80b1a7a8b30034cf0dbce57f5a30bc7..77573812f40959ce6b0456e0a9abd4ed1919f422 100644 (file)
--- a/testsuite/tests/lib-arg/testarg.ml
+++ b/testsuite/tests/lib-arg/testarg.ml
@@ -7,7 +7,7 @@ let record fmt (* args *) =
 ;;
 
 let f_unit () = record "unit()";;
-let f_bool b = record "bool(%b)" b;;
+let f_bool b = record "bool(%B)" b;;
 let r_set = ref false;;
 let r_clear = ref true;;
 let f_string s = record "string(%s)" s;;
@@ -187,3 +187,18 @@ let test_expand spec argv reference =
 
 test_expand (expand1@spec) args1 expected1;;
 test_expand (expand2@spec) args2 expected2;;
+
+let test_align () =
+  let spec =
+    [
+      "-foo", Arg.String ignore, "FOO Do foo with FOO";
+      "-bar", Arg.Tuple [Arg.String ignore; Arg.String ignore], "FOO BAR\tDo bar with FOO and BAR";
+      "-cha", Arg.Unit ignore, " Another option";
+      "-sym", Arg.Symbol (["a"; "b"], ignore), "\ty\tfoo";
+      "-sym2", Arg.Symbol (["a"; "b"], ignore), "x bar";
+    ]
+  in
+  print_endline (Arg.usage_string (Arg.align spec) "")
+;;
+
+test_align ();;

diff --git a/testsuite/tests/lib-arg/testarg.reference b/testsuite/tests/lib-arg/testarg.reference
index e69de29bb2d1d6434b8b29ae775ad8c2e48c5391..6049276299fccc579ae1c00379c552136ef87e86 100644 (file)
--- a/testsuite/tests/lib-arg/testarg.reference
+++ b/testsuite/tests/lib-arg/testarg.reference
@@ -0,0 +1,11 @@
+
+  -foo FOO     Do foo with FOO
+  -bar FOO BAR Do bar with FOO and BAR
+  -cha         Another option
+  -sym {a|b}
+               y       foo
+  -sym2 {a|b}
+             x bar
+  -help        Display this list of options
+  --help       Display this list of options
+

diff --git a/testsuite/tests/lib-bigarray-file/mapfile.ml b/testsuite/tests/lib-bigarray-file/mapfile.ml
index c69ca45928735b23c8c3a397ffb49e4c72efdc68..aeed7258f9d0a79067a8726820d61630bf46966e 100644 (file)
--- a/testsuite/tests/lib-bigarray-file/mapfile.ml
+++ b/testsuite/tests/lib-bigarray-file/mapfile.ml
@@ -26,21 +26,21 @@ let test test_number answer correct_answer =
 (* Tests *)
 
 let tests () =
-  testing_function "map_file";
   let mapped_file = Filename.temp_file "bigarray" ".data" in
   begin
+    testing_function "map_file";
     let fd =
      Unix.openfile mapped_file
                    [Unix.O_RDWR; Unix.O_TRUNC; Unix.O_CREAT] 0o666 in
     let a =
-      array1_of_genarray (Genarray.map_file fd float64 c_layout true [|10000|])
+      array1_of_genarray (Unix.map_file fd float64 c_layout true [|10000|])
     in
     Unix.close fd;
     for i = 0 to 9999 do a.{i} <- float i done;
     let fd = Unix.openfile mapped_file [Unix.O_RDONLY] 0 in
     let b =
       array2_of_genarray
-        (Genarray.map_file fd float64 fortran_layout false [|100; -1|])
+        (Unix.map_file fd float64 fortran_layout false [|100; -1|])
     in
     Unix.close fd;
     let ok = ref true in
@@ -53,7 +53,7 @@ let tests () =
     b.{50,50} <- (-1.0);
     let fd = Unix.openfile mapped_file [Unix.O_RDONLY] 0 in
     let c =
-      array2_of_genarray (Genarray.map_file fd float64 c_layout false [|-1; 100|])
+      array2_of_genarray (Unix.map_file fd float64 c_layout false [|-1; 100|])
     in
     Unix.close fd;
     let ok = ref true in
@@ -66,7 +66,7 @@ let tests () =
     let fd = Unix.openfile mapped_file [Unix.O_RDONLY] 0 in
     let c =
       array2_of_genarray
-        (Genarray.map_file fd ~pos:800L float64 c_layout false [|-1; 100|])
+        (Unix.map_file fd ~pos:800L float64 c_layout false [|-1; 100|])
     in
     Unix.close fd;
     let ok = ref true in
@@ -79,14 +79,39 @@ let tests () =
     let fd = Unix.openfile mapped_file [Unix.O_RDONLY] 0 in
     let c =
       array2_of_genarray
-        (Genarray.map_file fd ~pos:79200L float64 c_layout false [|-1; 100|])
+        (Unix.map_file fd ~pos:79200L float64 c_layout false [|-1; 100|])
     in
     Unix.close fd;
     let ok = ref true in
     for j = 0 to 99 do
       if c.{0,j} <> float (100 * 99 + j) then ok := false
     done;
-    test 4 !ok true
+    test 4 !ok true;
+
+    testing_function "map_file errors";
+    (* Insufficient permissions *)
+    let fd = Unix.openfile mapped_file [Unix.O_RDONLY] 0 in
+    test 1 true
+      begin try
+        ignore (Unix.map_file fd float64 c_layout true [|-1; 100|]); false
+      with
+      | Unix.Unix_error((Unix.EACCES | Unix.EPERM), _, _) -> true
+      | Unix.Unix_error(err, _, _) ->
+          Printf.eprintf "Unexpected error %s\n%!" (Unix.error_message err);
+          false
+      end;
+    Unix.close fd;
+    (* Invalid handle *)
+    test 2 true
+      begin try
+        ignore (Unix.map_file fd float64 c_layout true [|-1; 100|]); false
+      with
+      | Unix.Unix_error((Unix.EBADF|Unix.EINVAL), _, _) -> true
+      | Unix.Unix_error(err, _, _) ->
+          Printf.eprintf "Unexpected error %s\n%!" (Unix.error_message err);
+          false
+      end
+
   end;
   (* Force garbage collection of the mapped bigarrays above, otherwise
      Win32 doesn't let us erase the file.  Notice the begin...end above
@@ -97,7 +122,6 @@ let tests () =
   ()
   [@@inline never]
 
-
 (********* End of test *********)
 
 let _ =

diff --git a/testsuite/tests/lib-bigarray-file/mapfile.reference b/testsuite/tests/lib-bigarray-file/mapfile.reference
index 4b66315ca7d558876d3d174a84bd33ec119aeaba..1f9cef4bf085991dc2d02e0f8fbeb57495133823 100644 (file)
--- a/testsuite/tests/lib-bigarray-file/mapfile.reference
+++ b/testsuite/tests/lib-bigarray-file/mapfile.reference
@@ -1,3 +1,5 @@
 
 map_file
  1... 2... 3... 4...
+map_file errors
+ 1... 2...

diff --git a/testsuite/tests/lib-bigarray/bigarrays.ml b/testsuite/tests/lib-bigarray/bigarrays.ml
index d229ae09c699659f4f04cf272b88319fcc575014..31a90bca8d447494f4e9987e83c0fb68e8f7f927 100644 (file)
--- a/testsuite/tests/lib-bigarray/bigarrays.ml
+++ b/testsuite/tests/lib-bigarray/bigarrays.ml
@@ -976,61 +976,6 @@ let tests () =
   test_structured_io 14 (make_array3 complex64 fortran_layout 1 10 20 30
                                      makecomplex);
 
-  testing_function "map_file";
-  let mapped_file = Filename.temp_file "bigarray" ".data" in
-  begin
-    let fd =
-     Unix.openfile mapped_file
-                   [Unix.O_RDWR; Unix.O_TRUNC; Unix.O_CREAT] 0o666 in
-    let a = Array1.map_file fd float64 c_layout true 10000 in
-    Unix.close fd;
-    for i = 0 to 9999 do a.{i} <- float i done;
-    let fd = Unix.openfile mapped_file [Unix.O_RDONLY] 0 in
-    let b = Array2.map_file fd float64 fortran_layout false 100 (-1) in
-    Unix.close fd;
-    let ok = ref true in
-    for i = 0 to 99 do
-      for j = 0 to 99 do
-        if b.{j+1,i+1} <> float (100 * i + j) then ok := false
-      done
-    done;
-    test 1 !ok true;
-    b.{50,50} <- (-1.0);
-    let fd = Unix.openfile mapped_file [Unix.O_RDONLY] 0 in
-    let c = Array2.map_file fd float64 c_layout false (-1) 100 in
-    Unix.close fd;
-    let ok = ref true in
-    for i = 0 to 99 do
-      for j = 0 to 99 do
-        if c.{i,j} <> float (100 * i + j) then ok := false
-      done
-    done;
-    test 2 !ok true;
-    let fd = Unix.openfile mapped_file [Unix.O_RDONLY] 0 in
-    let c = Array2.map_file fd ~pos:800L float64 c_layout false (-1) 100 in
-    Unix.close fd;
-    let ok = ref true in
-    for i = 1 to 99 do
-      for j = 0 to 99 do
-        if c.{i-1,j} <> float (100 * i + j) then ok := false
-      done
-    done;
-    test 3 !ok true;
-    let fd = Unix.openfile mapped_file [Unix.O_RDONLY] 0 in
-    let c = Array2.map_file fd ~pos:79200L float64 c_layout false (-1) 100 in
-    Unix.close fd;
-    let ok = ref true in
-    for j = 0 to 99 do
-      if c.{0,j} <> float (100 * 99 + j) then ok := false
-    done;
-    test 4 !ok true
-  end;
-  (* Force garbage collection of the mapped bigarrays above, otherwise
-     Win32 doesn't let us erase the file.  Notice the begin...end above
-     so that the VM doesn't keep stack references to the mapped bigarrays. *)
-  Gc.full_major();
-  Sys.remove mapped_file;
-
   ()
   [@@inline never]
 

diff --git a/testsuite/tests/lib-bigarray/bigarrays.reference b/testsuite/tests/lib-bigarray/bigarrays.reference
index e96d0114ca28b5ad547181f02cf49f89252fb68e..1c80e50e2859d64684ab8a97b751ba5501d995a9 100644 (file)
--- a/testsuite/tests/lib-bigarray/bigarrays.reference
+++ b/testsuite/tests/lib-bigarray/bigarrays.reference
@@ -75,5 +75,3 @@ reshape
 
 output_value/input_value
  1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... 13... 14...
-map_file
- 1... 2... 3... 4...

diff --git a/testsuite/tests/lib-bigarray/change_layout.ml b/testsuite/tests/lib-bigarray/change_layout.ml
new file mode 100644 (file)
index 0000000..4f0c37c
--- /dev/null
+++ b/testsuite/tests/lib-bigarray/change_layout.ml
@@ -0,0 +1,142 @@
+(** Test the various change_layout for Genarray and the various Array[n] *)
+
+open Bigarray
+
+let pp_sep ppf () = Format.fprintf ppf ";@ "
+ let print_array pp ppf a =
+ Format.fprintf ppf "@[<hov>[|%a|]@]"
+    Format.(pp_print_list ~pp_sep pp) (Array.to_list a)
+
+let print_index = print_array Format.pp_print_int
+
+let do_test n test =
+  let rec aux l n =
+    if n = 0 then l
+    else
+      aux
+        begin match test (n-1) with
+        | Some error -> error :: l
+        | None -> l
+        end
+        (n-1) in
+  aux [] n
+
+let kind = float64
+
+let c = c_layout
+let fortran = fortran_layout
+
+let rank = 5
+let dims = Array.init rank (fun n -> n+2)
+let size = Array.fold_left ( * ) 1 dims
+
+let report s test =
+  let errors = do_test size test in
+  if errors = [] then
+    Format.printf"@[%s: Ok@]@." s
+  else
+    Format.printf "@[%s:@;Failed at indices @[<hov>%a@]@]@." s
+      (Format.pp_print_list ~pp_sep print_index)
+      errors
+
+let array =
+  let a = Array1.create kind c size in
+  for i = 0 to size - 1 do a.{i} <- float i done;
+  a
+
+(** Test for generic biggarray *)
+let gen = reshape (genarray_of_array1 array) dims
+
+let sizes =
+  let a = Array.make rank 1 in
+  let _ = Array.fold_left (fun (i,s) x -> a.(i)<- s; (i+1, s * x)) (0,1) dims in
+  a
+
+let multi_index n =
+  Array.init rank ( fun i ->  (n / sizes.(i)) mod dims.(i)  )
+
+let testG n =
+  let pos = multi_index n in
+  let initial = Genarray.get gen pos in
+  Genarray.set gen pos (-1.);
+  let different = Genarray.get gen pos <> initial in
+  let gen' = Genarray.change_layout gen fortran in
+  Genarray.set gen' ( Array.init rank @@ fun n -> 1 + pos.( rank - 1 - n ) ) initial;
+  if not (different && initial = Genarray.get gen pos) then Some pos
+  else None
+
+;;
+report "Generic rank test" testG
+;;
+
+(* Scalar *)
+let scalar =
+  let a = Array0.create kind c in
+  Array0.set a 0.; a
+;;
+let test  =
+  let a' = Array0.change_layout scalar fortran in
+  Array0.set a' 1.;
+  Array0.get scalar = 1.
+
+;;
+Format.printf "Scalar test: %s@." (if test then "Ok" else "Failed")
+;;
+
+(* Vector *)
+let vec = array1_of_genarray @@ reshape gen [|size|]
+let test1 i =
+  let initial = vec.{i}  in
+  vec.{i} <- -1.;
+  let different = vec.{i} <> initial in
+  let vec' = Array1.change_layout vec fortran in
+  vec'.{ i + 1 } <- initial;
+  if different && initial = vec.{i} then None
+    else Some [|i|]
+
+;;
+report "Rank-1 array test" test1
+;;
+
+(* Matrix *)
+let mat = array2_of_genarray @@ reshape gen [|dims.(0); size / dims.(0) |]
+let bi_index n = n mod dims.(0), n / dims.(0)
+
+let test2 n =
+  let i, j = bi_index n in
+  let initial = mat.{i,j}  in
+  mat.{i,j} <- -1.;
+  let different = mat.{i,j} <> initial in
+  let mat' = Array2.change_layout mat fortran in
+  mat'.{ j + 1, i + 1 } <- initial;
+  if different && initial = mat.{i, j} then None
+    else Some [|i; j|]
+
+
+;;
+report "Rank-2 array test" test2
+;;
+
+(* Rank 3 *)
+let t3 = array3_of_genarray @@
+  reshape gen [|dims.(0); dims.(1); size / (dims.(0) * dims.(1)) |]
+
+let tri_index n =
+  n mod dims.(0),
+  (n/ dims.(0)) mod  dims.(1),
+  n / (dims.(0) * dims.(1))
+
+let test3 n =
+  let i, j, k = tri_index n in
+  let initial = t3.{i,j,k}  in
+  t3.{i,j,k} <- -1.;
+  let different = t3.{i,j,k} <> initial in
+  let t3' = Array3.change_layout t3 fortran in
+  t3'.{ k + 1, j + 1, i + 1 } <- initial;
+  if different && initial = t3.{i, j, k} then None
+    else Some [|i;j;k|]
+
+
+;;
+report "Rank-3 array test" test3
+;;

diff --git a/testsuite/tests/lib-bigarray/change_layout.reference b/testsuite/tests/lib-bigarray/change_layout.reference
new file mode 100644 (file)
index 0000000..bab576e
--- /dev/null
+++ b/testsuite/tests/lib-bigarray/change_layout.reference
@@ -0,0 +1,5 @@
+Generic rank test: Ok
+Scalar test: Ok
+Rank-1 array test: Ok
+Rank-2 array test: Ok
+Rank-3 array test: Ok

diff --git a/testsuite/tests/lib-bigarray/pr5115.ml b/testsuite/tests/lib-bigarray/pr5115.ml
index e75215cf75c26a3f8ba88d9452edd8e693067755..fd16662eb0879f4b43bc277eac798de610a7972b 100644 (file)
--- a/testsuite/tests/lib-bigarray/pr5115.ml
+++ b/testsuite/tests/lib-bigarray/pr5115.ml
@@ -8,5 +8,5 @@ let f y0 =
 
 let _ =
   let y = Array1.of_array float64 fortran_layout [| 1. |] in
-  (f y).{1};
+  ignore ((f y).{1});
   (f y).{1} <- 3.14

diff --git a/testsuite/tests/lib-buffer/test.ml b/testsuite/tests/lib-buffer/test.ml
index 0fd32a6c5d1ed7feb25e40ec48fb45f15de0e062..83adcf830a730a61400b713291f5af5ea5726faf 100644 (file)
--- a/testsuite/tests/lib-buffer/test.ml
+++ b/testsuite/tests/lib-buffer/test.ml
@@ -29,6 +29,17 @@ let passed = output "passed"
 let failed = output "failed"
 ;;
 
+let buffer_truncate = "Buffer.truncate"
+
+let unexpected str =
+  Printf.sprintf "The Invalid_argument exception has been raised with an \
+    invalid value as argument \"%s\". Expecting \"%s\"."
+    str buffer_truncate
+
+let validate f str msg =
+  if str=buffer_truncate then f msg
+  else failed (unexpected str)
+
 (* Tests *)
 let () = print_string "Standard Library: Module Buffer\n"
 ;;
@@ -39,8 +50,7 @@ let truncate_neg : unit =
     Buffer.truncate buf (-1);
     failed msg
   with
-    Invalid_argument "Buffer.truncate" ->
-      passed msg
+    Invalid_argument str -> validate passed str msg
 ;;
 
 let truncate_large : unit =
@@ -49,8 +59,7 @@ let truncate_large : unit =
     Buffer.truncate buf (n+1);
     failed msg
   with
-    Invalid_argument "Buffer.truncate" ->
-      passed msg
+    Invalid_argument str -> validate passed str msg
 ;;
 
 let truncate_correct : unit =
@@ -63,8 +72,7 @@ let truncate_correct : unit =
     else
       failed msg
   with
-    Invalid_argument "Buffer.truncate" ->
-      failed msg
+    Invalid_argument str -> validate failed str msg
 ;;
 
 let reset_non_zero : unit =
@@ -84,3 +92,103 @@ let reset_zero : unit =
   else
     failed msg
 ;;
+
+let utf_8_spec =
+  (* UTF-8 byte sequences, cf. table 3.7 Unicode 9. *)
+  [(0x0000,0x007F),     [|(0x00,0x7F)|];
+   (0x0080,0x07FF),     [|(0xC2,0xDF); (0x80,0xBF)|];
+   (0x0800,0x0FFF),     [|(0xE0,0xE0); (0xA0,0xBF); (0x80,0xBF)|];
+   (0x1000,0xCFFF),     [|(0xE1,0xEC); (0x80,0xBF); (0x80,0xBF)|];
+   (0xD000,0xD7FF),     [|(0xED,0xED); (0x80,0x9F); (0x80,0xBF)|];
+   (0xE000,0xFFFF),     [|(0xEE,0xEF); (0x80,0xBF); (0x80,0xBF)|];
+   (0x10000,0x3FFFF),   [|(0xF0,0xF0); (0x90,0xBF); (0x80,0xBF); (0x80,0xBF)|];
+   (0x40000,0xFFFFF),   [|(0xF1,0xF3); (0x80,0xBF); (0x80,0xBF); (0x80,0xBF)|];
+   (0x100000,0x10FFFF), [|(0xF4,0xF4); (0x80,0x8F); (0x80,0xBF); (0x80,0xBF)|]]
+;;
+
+let utf_16be_spec =
+  (* UTF-16BE byte sequences, derived from table 3.5 Unicode 9. *)
+  [(0x0000,0xD7FF), [|(0x00,0xD7); (0x00,0xFF)|];
+   (0xE000,0xFFFF), [|(0xE0,0xFF); (0x00,0xFF)|];
+   (0x10000,0x10FFFF), [|(0xD8,0xDB); (0x00,0xFF); (0xDC,0xDF); (0x00,0xFF)|]]
+;;
+
+let uchar_map_of_spec spec =
+  (* array mapping Uchar.t as ints to byte sequences according to [spec]. *)
+  let map = Array.make ((Uchar.to_int Uchar.max) + 1) "" in
+  let add_range ((umin, umax), bytes) =
+    let len = Array.length bytes in
+    let bmin i = if i < len then fst bytes.(i) else max_int in
+    let bmax i = if i < len then snd bytes.(i) else min_int in
+    let uchar = ref umin in
+    let buf = Bytes.create len in
+    let add len' =
+      if len <> len' then () else
+      begin
+        let bytes = Bytes.to_string buf in
+        map.(!uchar) <- bytes;
+        incr uchar;
+      end
+    in
+    for b0 = bmin 0 to bmax 0 do
+      Bytes.unsafe_set buf 0 (Char.chr b0);
+      for b1 = bmin 1 to bmax 1 do
+        Bytes.unsafe_set buf 1 (Char.chr b1);
+        for b2 = bmin 2 to bmax 2 do
+          Bytes.unsafe_set buf 2 (Char.chr b2);
+          for b3 = bmin 3 to bmax 3 do
+            Bytes.unsafe_set buf 3 (Char.chr b3);
+            add 4;
+          done;
+          add 3;
+        done;
+        add 2;
+      done;
+      add 1;
+    done;
+    assert (!uchar - 1 = umax)
+  in
+  List.iter add_range spec;
+  map
+;;
+
+let test_spec_map msg utf_x_map buffer_add_utf_x_uchar =
+  let b = Buffer.create 4 in
+  let rec loop u =
+    Buffer.clear b; buffer_add_utf_x_uchar b u;
+    match Buffer.contents b = utf_x_map.(Uchar.to_int u) with
+    | false -> failed (sprintf "%s of U+%04X" msg (Uchar.to_int u))
+    | true ->
+        if Uchar.equal u Uchar.max then passed msg else loop (Uchar.succ u)
+  in
+  loop Uchar.min
+;;
+
+let add_utf_8_uchar : unit =
+  let map = uchar_map_of_spec utf_8_spec in
+  test_spec_map
+    "add_utf_8_uchar: test against spec" map Buffer.add_utf_8_uchar
+;;
+
+let add_utf_16be_uchar : unit =
+  let map = uchar_map_of_spec utf_16be_spec in
+  test_spec_map
+    "add_utf_16be_uchar: test against spec" map Buffer.add_utf_16be_uchar
+;;
+
+let add_utf_16le_uchar : unit =
+  (* The uchar_map_of_spec generation function doesn't work on a LE spec since
+     uchars and byte seqs have to increase and map together; simply swap
+     the map obtained with utf_16be_spec. *)
+  let map =
+    let swap bytes =
+      let swap i = match i with
+      | 0 -> 1 | 1 -> 0 | 2 -> 3 | 3 -> 2 | _ -> assert false
+      in
+      String.init (String.length bytes) (fun i -> bytes.[swap i])
+    in
+    Array.map swap (uchar_map_of_spec utf_16be_spec)
+  in
+  test_spec_map
+    "add_utf_16le_uchar: test against spec" map Buffer.add_utf_16le_uchar
+;;

diff --git a/testsuite/tests/lib-buffer/test.reference b/testsuite/tests/lib-buffer/test.reference
index 3e63c335117500342a91c66b05d1e928d93ddb5f..bc990bf2d5dbd9fcad0fa26526e4867f8f0f0e59 100644 (file)
--- a/testsuite/tests/lib-buffer/test.reference
+++ b/testsuite/tests/lib-buffer/test.reference
@@ -4,3 +4,6 @@ Buffer truncate: large passed
 Buffer truncate: in-range passed
 Buffer reset: non-zero passed
 Buffer reset: zero passed
+Buffer add_utf_8_uchar: test against spec passed
+Buffer add_utf_16be_uchar: test against spec passed
+Buffer add_utf_16le_uchar: test against spec passed

diff --git a/testsuite/tests/lib-digest/md5.ml b/testsuite/tests/lib-digest/md5.ml
index 1b61d15262bcc2334da166bb5888a8077c159d9d..0fb11defec7c0ff29ad2508e9cb8f96f9cf35549 100644 (file)
--- a/testsuite/tests/lib-digest/md5.ml
+++ b/testsuite/tests/lib-digest/md5.ml
@@ -120,10 +120,12 @@ let string_to_data s =
   for i = 0 to 15 do
     let j = i lsl 2 in
     data.(i) <-
-      Int32.logor (Int32.shift_left (Int32.of_int (Bytes.get s (j+3) |> Char.code)) 24)
-        (Int32.logor (Int32.shift_left (Int32.of_int (Bytes.get s (j+2) |> Char.code)) 16)
-          (Int32.logor (Int32.shift_left (Int32.of_int (Bytes.get s (j+1) |> Char.code)) 8)
-                       (Int32.of_int (Bytes.get s j |> Char.code))))
+      let byte n = Bytes.get s (j+n) |> Char.code |> Int32.of_int in
+      let open Int32 in
+      byte 0
+      |> logor (shift_left (byte 1) 8)
+      |> logor (shift_left (byte 2) 16)
+      |> logor (shift_left (byte 3) 24)
   done;
   data
 

diff --git a/testsuite/tests/lib-dynlink-csharp/Makefile b/testsuite/tests/lib-dynlink-csharp/Makefile
index ae98ca0bb5bb19af7c1b18cdb1dfb2d2b4c66963..a385d1caf1bd5cf22d85fffb637b2b7d590a8c81 100644 (file)
--- a/testsuite/tests/lib-dynlink-csharp/Makefile
+++ b/testsuite/tests/lib-dynlink-csharp/Makefile
@@ -20,7 +20,7 @@ CSC=$(CSC_COMMAND) $(CSC_FLAGS)
 
 COMPFLAGS=-I $(OTOPDIR)/otherlibs/bigarray -I $(OTOPDIR)/otherlibs/dynlink \
           -I $(OTOPDIR)/byterun
-LD_PATH=$(TOPDIR)/otherlibs/bigarray:$(TOPDIR)/otherlibs/dynlink
+LD_PATH=$(TOPDIR)/otherlibs/win32unix:$(TOPDIR)/otherlibs/bigarray:$(TOPDIR)/otherlibs/dynlink
 
 default:
        @$(SET_LD_PATH) $(MAKE) all

diff --git a/testsuite/tests/lib-dynlink-csharp/bytecode.reference b/testsuite/tests/lib-dynlink-csharp/bytecode.reference
index 8be606c4bd517bdb7aa660f2b780b80583616b90..1c61c156e718120a9703f1dc031a6cdfba7e5b77 100644 (file)
--- a/testsuite/tests/lib-dynlink-csharp/bytecode.reference
+++ b/testsuite/tests/lib-dynlink-csharp/bytecode.reference
@@ -1,5 +1,6 @@
 Now starting the OCaml engine.
 Main is running.
+Loading ../../../otherlibs/win32unix/unix.cma
 Loading ../../../otherlibs/bigarray/bigarray.cma
 Loading plugin.cmo
 I'm the plugin.

diff --git a/testsuite/tests/lib-dynlink-csharp/entry.c b/testsuite/tests/lib-dynlink-csharp/entry.c
index 6116b6d4082a1d28a90ea7256529c994c748ddaf..12e39a5b7583306bda2ce0c881fbfc201ff1cbfd 100755 (executable)
--- a/testsuite/tests/lib-dynlink-csharp/entry.c
+++ b/testsuite/tests/lib-dynlink-csharp/entry.c
@@ -37,8 +37,8 @@
 #endif /* WIN32 && !CYGWIN */
 
 _DLLAPI void _CALLPROC start_caml_engine() {
-  char * argv[2];
-  argv[0] = "--";
+  wchar_t * argv[2];
+  argv[0] = L"--";
   argv[1] = NULL;
   caml_startup(argv);
 }

diff --git a/testsuite/tests/lib-dynlink-csharp/main.ml b/testsuite/tests/lib-dynlink-csharp/main.ml
index d30c150e1d8c15890fa44cce9b5c1374d0c7587f..7c8030a18baa6f62b2f6d2d743ce6b536c6ed458 100755 (executable)
--- a/testsuite/tests/lib-dynlink-csharp/main.ml
+++ b/testsuite/tests/lib-dynlink-csharp/main.ml
@@ -5,19 +5,21 @@ let load s =
   with Dynlink.Error e ->
     print_endline (Dynlink.error_message e)
 
+(* Callback must be linked to load Unix dynamically *)
+let _ = Callback.register
+module CamlinternalBigarray = CamlinternalBigarray
+
 let () =
   ignore (Hashtbl.hash 42.0);
   print_endline "Main is running.";
   Dynlink.init ();
   Dynlink.allow_unsafe_modules true;
-  let s1,s2 =
-    if Dynlink.is_native then
-      "../../../otherlibs/bigarray/bigarray.cmxs",
-      "plugin.cmxs"
-    else
-      "../../../otherlibs/bigarray/bigarray.cma",
-      "plugin.cmo"
+  let s1,s2,s3 =
+    Dynlink.adapt_filename "../../../otherlibs/win32unix/unix.cma",
+    Dynlink.adapt_filename "../../../otherlibs/bigarray/bigarray.cma",
+    Dynlink.adapt_filename "plugin.cmo"
   in
   load s1;
   load s2;
+  load s3;
   print_endline "OK."

diff --git a/testsuite/tests/lib-dynlink-csharp/native.reference b/testsuite/tests/lib-dynlink-csharp/native.reference
index ff18be96c35ba75ae608344669ea95b3e2b6341b..cfb612da6d1a53cfdfa234778aa9775149e24f38 100644 (file)
--- a/testsuite/tests/lib-dynlink-csharp/native.reference
+++ b/testsuite/tests/lib-dynlink-csharp/native.reference
@@ -1,5 +1,6 @@
 Now starting the OCaml engine.
 Main is running.
+Loading ../../../otherlibs/win32unix/unix.cmxs
 Loading ../../../otherlibs/bigarray/bigarray.cmxs
 Loading plugin.cmxs
 I'm the plugin.

diff --git a/testsuite/tests/lib-dynlink-native/Makefile b/testsuite/tests/lib-dynlink-native/Makefile
index 13e1a4a944777e1a096de016169a641241ad87cd..c2e21950af2470ccc353f348e9f4d80b51ee9148 100644 (file)
--- a/testsuite/tests/lib-dynlink-native/Makefile
+++ b/testsuite/tests/lib-dynlink-native/Makefile
@@ -23,7 +23,7 @@ LD_PATH = $(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix:$(TOPDIR)/otherlibs/systhreads\
 
 .PHONY: default
 default:
-       @if ! $(SUPPORTS_SHARED_LIBRARIES) || $(BYTECODE_ONLY) ; then \
+       @if ! $(NATDYNLINK) || $(BYTECODE_ONLY) ; then \
          echo " ... testing 'main' => skipped"; \
        else \
           $(SET_LD_PATH) $(MAKE) all; \

diff --git a/testsuite/tests/lib-list/Makefile b/testsuite/tests/lib-list/Makefile
new file mode 100644 (file)
index 0000000..4ba0bff
--- /dev/null
+++ b/testsuite/tests/lib-list/Makefile
@@ -0,0 +1,3 @@
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/lib-list/test.ml b/testsuite/tests/lib-list/test.ml
new file mode 100644 (file)
index 0000000..4898c3d
--- /dev/null
+++ b/testsuite/tests/lib-list/test.ml
@@ -0,0 +1,64 @@
+(* Standard test case *)
+let () =
+  let l = List.init 10 (fun x -> x) in
+  assert (List.exists (fun a -> a < 10) l);
+  assert (List.exists (fun a -> a > 0) l);
+  assert (List.exists (fun a -> a = 0) l);
+  assert (List.exists (fun a -> a = 1) l);
+  assert (List.exists (fun a -> a = 2) l);
+  assert (List.exists (fun a -> a = 3) l);
+  assert (List.exists (fun a -> a = 4) l);
+  assert (List.exists (fun a -> a = 5) l);
+  assert (List.exists (fun a -> a = 6) l);
+  assert (List.exists (fun a -> a = 7) l);
+  assert (List.exists (fun a -> a = 8) l);
+  assert (List.exists (fun a -> a = 9) l);
+  assert (not (List.exists (fun a -> a < 0) l));
+  assert (not (List.exists (fun a -> a > 9) l));
+  assert (List.exists (fun _ -> true) l);
+
+  assert (List.compare_lengths [] [] = 0);
+  assert (List.compare_lengths [1;2] ['a';'b'] = 0);
+  assert (List.compare_lengths [] [1;2] < 0);
+  assert (List.compare_lengths ['a'] [1;2] < 0);
+  assert (List.compare_lengths [1;2] [] > 0);
+  assert (List.compare_lengths [1;2] ['a'] > 0);
+
+  assert (List.compare_length_with [] 0 = 0);
+  assert (List.compare_length_with [] 1 < 0);
+  assert (List.compare_length_with [] (-1) > 0);
+  assert (List.compare_length_with [] max_int < 0);
+  assert (List.compare_length_with [] min_int > 0);
+  assert (List.compare_length_with [1] 0 > 0);
+  assert (List.compare_length_with ['1'] 1 = 0);
+  assert (List.compare_length_with ['1'] 2 < 0);
+  ()
+;;
+
+(* Empty test case *)
+let () =
+  assert ((List.init 0 (fun x -> x)) = []);
+;;
+
+(* Erroneous test case *)
+
+let () =
+  let result = try
+      let _ = List.init (-1) (fun x -> x) in false
+  with Invalid_argument e -> true (* Exception caught *)
+  in assert result;
+;;
+
+(* Evaluation order *)
+let () =
+  let test n =
+    let result = ref false in
+    let _ = List.init n (fun x -> result := (x = n - 1)) in
+    assert !result
+  in
+  let threshold = 10_000 in (* Threshold must equal the value in stdlib/list.ml *)
+  test threshold; (* Non tail-recursive case *)
+  test (threshold + 1) (* Tail-recursive case *)
+;;
+
+let () = print_endline "OK";;

diff --git a/testsuite/tests/lib-list/test.reference b/testsuite/tests/lib-list/test.reference
new file mode 100644 (file)
index 0000000..d86bac9
--- /dev/null
+++ b/testsuite/tests/lib-list/test.reference
@@ -0,0 +1 @@
+OK

diff --git a/testsuite/tests/lib-num-2/Makefile b/testsuite/tests/lib-num-2/Makefile
deleted file mode 100644 (file)
index 78930ae..0000000
--- a/testsuite/tests/lib-num-2/Makefile
+++ /dev/null
@@ -1,23 +0,0 @@
-#**************************************************************************
-#*                                                                        *
-#*                                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 GNU Lesser General Public License version 2.1, with the          *
-#*   special exception on linking described in the file LICENSE.          *
-#*                                                                        *
-#**************************************************************************
-
-BASEDIR=../..
-LIBRARIES=nums
-ADD_COMPFLAGS=-I $(OTOPDIR)/otherlibs/num
-LD_PATH=$(TOPDIR)/otherlibs/num
-PROGRAM_ARGS=1000
-
-include $(BASEDIR)/makefiles/Makefile.several
-include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/lib-num-2/pi_big_int.ml b/testsuite/tests/lib-num-2/pi_big_int.ml
deleted file mode 100644 (file)
index 22872ba..0000000
--- a/testsuite/tests/lib-num-2/pi_big_int.ml
+++ /dev/null
@@ -1,78 +0,0 @@
-(* Pi digits computed with the sreaming algorithm given on pages 4, 6
-   & 7 of "Unbounded Spigot Algorithms for the Digits of Pi", Jeremy
-   Gibbons, August 2004. *)
-
-open Printf;;
-open Big_int;;
-
-let ( !$ ) = Big_int.big_int_of_int
-and ( +$ ) = Big_int.add_big_int
-and ( *$ ) = Big_int.mult_big_int
-and ( =$ ) = Big_int.eq_big_int
-;;
-
-let zero = Big_int.zero_big_int
-and one = Big_int.unit_big_int
-and three = !$ 3
-and four = !$ 4
-and ten = !$ 10
-and neg_ten = !$(-10)
-;;
-
-(* Linear Fractional (aka M=F6bius) Transformations *)
-module LFT = struct
-
-  let floor_ev (q, r, s, t) x = div_big_int (q *$ x +$ r) (s *$ x +$ t);;
-
-  let unit = (one, zero, zero, one);;
-
-  let comp (q, r, s, t) (q', r', s', t') =
-    (q *$ q' +$ r *$ s', q *$ r' +$ r *$ t',
-     s *$ q' +$ t *$ s', s *$ r' +$ t *$ t')
-;;
-
-end
-;;
-
-let next z = LFT.floor_ev z three
-and safe z n = (n =$ LFT.floor_ev z four)
-and prod z n = LFT.comp (ten, neg_ten *$ n, zero, one) z
-and cons z k =
-  let den = 2 * k + 1 in
-  LFT.comp z (!$ k, !$(2 * den), zero, !$ den)
-;;
-
-let rec digit k z n row col =
-  if n > 0 then
-    let y = next z in
-    if safe z y then
-      if col = 10 then (
-        let row = row + 10 in
-        printf "\t:%i\n%s" row (string_of_big_int y);
-        digit k (prod z y) (n - 1) row 1
-      )
-      else (
-        print_string(string_of_big_int y);
-        digit k (prod z y) (n - 1) row (col + 1)
-      )
-    else digit (k + 1) (cons z k) n row col
-  else
-    printf "%*s\t:%i\n" (10 - col) "" (row + col)
-;;
-
-let digits n = digit 1 LFT.unit n 0 0
-;;
-
-let usage () =
-  prerr_endline "Usage: pi_big_int <number of digits to compute for pi>";
-  exit 2
-;;
-
-let main () =
-  let args = Sys.argv in
-  if Array.length args <> 2 then usage () else
-  digits (int_of_string Sys.argv.(1))
-;;
-
-main ()
-;;

diff --git a/testsuite/tests/lib-num-2/pi_big_int.reference b/testsuite/tests/lib-num-2/pi_big_int.reference
deleted file mode 100644 (file)
index ad4dc99..0000000
--- a/testsuite/tests/lib-num-2/pi_big_int.reference
+++ /dev/null
@@ -1,100 +0,0 @@
-3141592653     :10
-5897932384     :20
-6264338327     :30
-9502884197     :40
-1693993751     :50
-0582097494     :60
-4592307816     :70
-4062862089     :80
-9862803482     :90
-5342117067     :100
-9821480865     :110
-1328230664     :120
-7093844609     :130
-5505822317     :140
-2535940812     :150
-8481117450     :160
-2841027019     :170
-3852110555     :180
-9644622948     :190
-9549303819     :200
-6442881097     :210
-5665933446     :220
-1284756482     :230
-3378678316     :240
-5271201909     :250
-1456485669     :260
-2346034861     :270
-0454326648     :280
-2133936072     :290
-6024914127     :300
-3724587006     :310
-6063155881     :320
-7488152092     :330
-0962829254     :340
-0917153643     :350
-6789259036     :360
-0011330530     :370
-5488204665     :380
-2138414695     :390
-1941511609     :400
-4330572703     :410
-6575959195     :420
-3092186117     :430
-3819326117     :440
-9310511854     :450
-8074462379     :460
-9627495673     :470
-5188575272     :480
-4891227938     :490
-1830119491     :500
-2983367336     :510
-2440656643     :520
-0860213949     :530
-4639522473     :540
-7190702179     :550
-8609437027     :560
-7053921717     :570
-6293176752     :580
-3846748184     :590
-6766940513     :600
-2000568127     :610
-1452635608     :620
-2778577134     :630
-2757789609     :640
-1736371787     :650
-2146844090     :660
-1224953430     :670
-1465495853     :680
-7105079227     :690
-9689258923     :700
-5420199561     :710
-1212902196     :720
-0864034418     :730
-1598136297     :740
-7477130996     :750
-0518707211     :760
-3499999983     :770
-7297804995     :780
-1059731732     :790
-8160963185     :800
-9502445945     :810
-5346908302     :820
-6425223082     :830
-5334468503     :840
-5261931188     :850
-1710100031     :860
-3783875288     :870
-6587533208     :880
-3814206171     :890
-7766914730     :900
-3598253490     :910
-4287554687     :920
-3115956286     :930
-3882353787     :940
-5937519577     :950
-8185778053     :960
-2171226806     :970
-6130019278     :980
-7661119590     :990
-9216420198     :1000

diff --git a/testsuite/tests/lib-num-2/pi_num.ml b/testsuite/tests/lib-num-2/pi_num.ml
deleted file mode 100644 (file)
index e2580c1..0000000
--- a/testsuite/tests/lib-num-2/pi_num.ml
+++ /dev/null
@@ -1,72 +0,0 @@
-(* Pi digits computed with the sreaming algorithm given on pages 4, 6
-   & 7 of "Unbounded Spigot Algorithms for the Digits of Pi", Jeremy
-   Gibbons, August 2004. *)
-
-open Printf;;
-open Num;;
-
-let zero = num_of_int 0
-and one = num_of_int 1
-and three = num_of_int 3
-and four = num_of_int 4
-and ten = num_of_int 10
-and neg_ten = num_of_int(-10)
-;;
-
-(* Linear Fractional Transformation *)
-module LFT = struct
-
-  let floor_ev (q, r, s, t) x = quo_num (q */ x +/ r) (s */ x +/ t);;
-
-  let unit = (one, zero, zero, one);;
-
-  let comp (q, r, s, t) (q', r', s', t') =
-    (q */ q' +/ r */ s', q */ r' +/ r */ t',
-     s */ q' +/ t */ s', s */ r' +/ t */ t')
-;;
-
-end
-;;
-
-let next z = LFT.floor_ev z three
-and safe z n = (n =/ LFT.floor_ev z four)
-and prod z n = LFT.comp (ten, neg_ten */ n, zero, one) z
-and cons z k =
-  let den = 2 * k + 1 in
-  LFT.comp z (num_of_int k, num_of_int(2 * den), zero, num_of_int den)
-;;
-
-let rec digit k z n row col =
-  if n > 0 then
-    let y = next z in
-    if safe z y then
-      if col = 10 then (
-    let row = row + 10 in
-    printf "\t:%i\n%s" row (string_of_num y);
-    digit k (prod z y) (n-1) row 1
-      )
-      else (
-    print_string(string_of_num y);
-    digit k (prod z y) (n-1) row (col + 1)
-      )
-    else digit (k + 1) (cons z k) n row col
-  else
-    printf "%*s\t:%i\n" (10 - col) "" (row + col)
-;;
-
-let digits n = digit 1 LFT.unit n 0 0
-;;
-
-let usage () =
-  prerr_endline "Usage: pi_num <number of digits to compute for pi>";
-  exit 2
-;;
-
-let main () =
-  let args = Sys.argv in
-  if Array.length args <> 2 then usage () else
-  digits (int_of_string Sys.argv.(1))
-;;
-
-main ()
-;;

diff --git a/testsuite/tests/lib-num-2/pi_num.reference b/testsuite/tests/lib-num-2/pi_num.reference
deleted file mode 100644 (file)
index ad4dc99..0000000
--- a/testsuite/tests/lib-num-2/pi_num.reference
+++ /dev/null
@@ -1,100 +0,0 @@
-3141592653     :10
-5897932384     :20
-6264338327     :30
-9502884197     :40
-1693993751     :50
-0582097494     :60
-4592307816     :70
-4062862089     :80
-9862803482     :90
-5342117067     :100
-9821480865     :110
-1328230664     :120
-7093844609     :130
-5505822317     :140
-2535940812     :150
-8481117450     :160
-2841027019     :170
-3852110555     :180
-9644622948     :190
-9549303819     :200
-6442881097     :210
-5665933446     :220
-1284756482     :230
-3378678316     :240
-5271201909     :250
-1456485669     :260
-2346034861     :270
-0454326648     :280
-2133936072     :290
-6024914127     :300
-3724587006     :310
-6063155881     :320
-7488152092     :330
-0962829254     :340
-0917153643     :350
-6789259036     :360
-0011330530     :370
-5488204665     :380
-2138414695     :390
-1941511609     :400
-4330572703     :410
-6575959195     :420
-3092186117     :430
-3819326117     :440
-9310511854     :450
-8074462379     :460
-9627495673     :470
-5188575272     :480
-4891227938     :490
-1830119491     :500
-2983367336     :510
-2440656643     :520
-0860213949     :530
-4639522473     :540
-7190702179     :550
-8609437027     :560
-7053921717     :570
-6293176752     :580
-3846748184     :590
-6766940513     :600
-2000568127     :610
-1452635608     :620
-2778577134     :630
-2757789609     :640
-1736371787     :650
-2146844090     :660
-1224953430     :670
-1465495853     :680
-7105079227     :690
-9689258923     :700
-5420199561     :710
-1212902196     :720
-0864034418     :730
-1598136297     :740
-7477130996     :750
-0518707211     :760
-3499999983     :770
-7297804995     :780
-1059731732     :790
-8160963185     :800
-9502445945     :810
-5346908302     :820
-6425223082     :830
-5334468503     :840
-5261931188     :850
-1710100031     :860
-3783875288     :870
-6587533208     :880
-3814206171     :890
-7766914730     :900
-3598253490     :910
-4287554687     :920
-3115956286     :930
-3882353787     :940
-5937519577     :950
-8185778053     :960
-2171226806     :970
-6130019278     :980
-7661119590     :990
-9216420198     :1000

diff --git a/testsuite/tests/lib-num/Makefile b/testsuite/tests/lib-num/Makefile
deleted file mode 100644 (file)
index 14f0d2c..0000000
--- a/testsuite/tests/lib-num/Makefile
+++ /dev/null
@@ -1,24 +0,0 @@
-#**************************************************************************
-#*                                                                        *
-#*                                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 GNU Lesser General Public License version 2.1, with the          *
-#*   special exception on linking described in the file LICENSE.          *
-#*                                                                        *
-#**************************************************************************
-
-BASEDIR=../..
-MODULES=test test_nats test_big_ints test_ratios test_nums test_io
-MAIN_MODULE=end_test
-LIBRARIES=nums
-ADD_COMPFLAGS=-w a -I $(OTOPDIR)/otherlibs/num
-LD_PATH=$(TOPDIR)/otherlibs/num
-
-include $(BASEDIR)/makefiles/Makefile.one
-include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/lib-num/end_test.ml b/testsuite/tests/lib-num/end_test.ml
deleted file mode 100644 (file)
index 57e099e..0000000
--- a/testsuite/tests/lib-num/end_test.ml
+++ /dev/null
@@ -1 +0,0 @@
-Test.end_tests ();;

diff --git a/testsuite/tests/lib-num/end_test.reference b/testsuite/tests/lib-num/end_test.reference
deleted file mode 100644 (file)
index ab99ae0..0000000
--- a/testsuite/tests/lib-num/end_test.reference
+++ /dev/null
@@ -1,170 +0,0 @@
-
-num_digits_nat
- -1... 0... 1...
-length_nat
- 1...
-equal_nat
- 1... 2... 3... 4...
-incr_nat
- 1... 2... 3... 4...
-decr_nat
- 1... 2... 3... 4...
-is_zero_nat
- 1... 2... 3... 4...
-string_of_nat
- 1... 2...
-string_of_nat && nat_of_string
- 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... 13... 14... 15... 16... 17... 18... 19... 20... 21... 22...
-gcd_nat
- 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... 13... 14... 15... 16... 17... 18... 19... 20...
-sqrt_nat
- 1... 2... 3... 4... 5...
-compare_big_int
- 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... 13...
-pred_big_int
- 1... 2... 3...
-succ_big_int
- 1... 2... 3...
-add_big_int
- 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... 13... 14... 15... 16... 17...
-sub_big_int
- 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... 13... 14... 15... 16... 17...
-mult_int_big_int
- 1... 2... 3... 4...
-mult_big_int
- 1... 2... 3... 4... 5...
-quomod_big_int
- 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... 13... 14... 15... 16... 17... 18... 19... 20... 21... 22... 23... 24... 25...
-gcd_big_int
- 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... 13... 14... 15... 16... 17... 18... 19... 20... 21... 22... 23... 24... 25... 26... 27... 28...
-int_of_big_int
- 1... 2... 3... 4... 5... 6... 7... 8...
-is_int_big_int
- 1... 2... 3... 4... 5... 6... 7... 8... 9... 10...
-sys_string_of_big_int
- 1...
-big_int_of_string
- 1... 2... 4... 5... 6... 7... 9... 10... 18... 19... 20... 21...
-power_base_int
- 1... 2... 3...
-base_power_big_int
- 1... 2... 3...
-power_int_positive_big_int
- 1... 2... 3... 4... 5... 6... 7...
-power_big_int_positive_int
- 1... 2... 3... 4... 5...
-power_big_int_positive_big_int
- 1... 2... 3... 4... 5... 6... 7... 8... 9...
-square_big_int
- 1... 2... 3... 4...
-big_int_of_nativeint
- 1... 2... 3...
-nativeint_of_big_int
- 1... 2... 2...
-big_int_of_int32
- 1... 2... 3...
-int32_of_big_int
- 1... 2... 3... 4... 5... 6... 7... 8...
-big_int_of_int64
- 1... 2... 3... 4... 5... 6... 7... 8...
-int64_of_big_int
- 1... 2... 3... 4... 5... 6... 7... 8...
-and_big_int
- 1... 2... 3... 4... 5... 6...
-or_big_int
- 1... 2... 3... 4... 5... 6...
-xor_big_int
- 1... 2... 3... 4... 5... 6...
-shift_left_big_int
- 1... 2... 2... 3... 4... 5... 6...
-shift_right_big_int
- 1... 2... 3... 4... 5... 6...
-shift_right_towards_zero_big_int
- 1... 2...
-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
- 1... 2... 3... 4... 5... 6... 7... 8... 9... 10...
-null_denominator
- 1... 2...
-sign_ratio
- 1... 2... 3...
-normalize_ratio
- 1... 2... 3... 4...
-report_sign_ratio
- 1... 2...
-is_integer_ratio
- 1... 2...
-add_ratio
- 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... 1... 2... 3... 4...
-sub_ratio
- 1... 2... 3... 4... 5... 6... 7... 8...
-mult_ratio
- 1... 2... 3... 4... 5... 6... 7... 8...
-div_ratio
- 1... 2... 3... 4... 5... 6... 7... 8...
-integer_ratio
- 1... 2... 3... 4... 5...
-floor_ratio
- 1... 2... 3... 4... 5...
-round_ratio
- 1... 2... 3... 4... 5...
-ceiling_ratio
- 1... 2... 3... 4... 5... 6...
-eq_ratio
- 1... 2... 3... 4... 5...
-compare_ratio
- 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... 13... 14... 15... 16... 17... 18... 19... 20... 21... 22... 23... 24... 25... 26... 27... 28... 29... 30... 31... 32... 33... 34... 35... 36...
-eq_big_int_ratio
- 1... 2... 3... 4... 5...
-compare_big_int_ratio
- 1... 2... 3... 4... 5... 6... 7... 8... 9...
-int_of_ratio
- 1... 2... 3... 4... 5...
-ratio_of_int
- 1... 2...
-nat_of_ratio
- 1... 2... 3... 4...
-ratio_of_big_int
- 1...
-big_int_of_ratio
- 1... 2... 3...
-string_of_ratio
- 1... 2... 3... 4...
-ratio_of_string
- 1... 6... 7... 8...
-round_futur_last_digit
- 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... 13... 14... 15... 16... 17... 18... 19... 20... 21... 22... 23... 24...
-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
- 1... 2... 3... 4... 5... 7... 8... 9... 10...
-mult_num
- 1... 2... 3... 4... 5... 6... 7... 8... 9...
-div_num
- 1... 2... 3... 4... 5... 6... 7... 8... 9...
-is_integer_num
- 1... 2... 3... 4...
-num_of_ratio
- 1... 2... 3...
-num_of_string
- 1... 7... 8... 11... 12... 13... 14... 15...
-output_value/input_value on nats
- 1... 2... 3... 4... 5... 6... 7...
-output_value/input_value on big ints
- 1... 2... 3... 4... 5...
-output_value/input_value on nums
- 1... 2... 3... 4... 5... 6... 7... 8...
-************* TESTS COMPLETED SUCCESSFULLY ****************

diff --git a/testsuite/tests/lib-num/test.ml b/testsuite/tests/lib-num/test.ml
deleted file mode 100644 (file)
index b45d05d..0000000
--- a/testsuite/tests/lib-num/test.ml
+++ /dev/null
@@ -1,103 +0,0 @@
-open Printf;;
-
-let flush_all () = flush stdout; flush stderr;;
-
-let message s = print_string s; print_newline ();;
-
-let error_occurred = ref false;;
-let immediate_failure = ref true;;
-
-let error () =
- if !immediate_failure then exit 2 else begin
-   error_occurred := true;
-   flush_all ();
-   false
- end;;
-
-let success () = flush_all (); true;;
-
-let function_tested = ref "";;
-
-let testing_function s =
-    flush_all ();
-    function_tested := s;
-    print_newline();
-    message s;;
-
-let test test_number eq_fun (answer, correct_answer) =
- flush_all ();
- if not (eq_fun answer correct_answer) then begin
-   fprintf stderr ">>> Bad result (%s, test %d)\n" !function_tested test_number;
-   error ()
- end else begin
-   printf " %d..." test_number;
-   success ()
- end;;
-
-let failure_test test_number fun_to_test arg =
- flush_all ();
- try
-   fun_to_test arg;
-   fprintf stderr ">>> Failure expected (%s, test %d)\n"
-                  !function_tested test_number;
-   error ()
-  with _ ->
-   printf " %d..." test_number;
-   success ();;
-
-let failwith_test test_number fun_to_test arg correct_failure =
- flush_all ();
- try
-   fun_to_test arg;
-   fprintf stderr ">>> Failure expected (%s, test %d)\n"
-                  !function_tested test_number;
-   error ()
-  with x ->
-   if x = correct_failure then begin
-     printf " %d..." test_number;
-     success ()
-   end else begin
-     fprintf stderr ">>> Bad failure (%s, test %d)\n"
-                    !function_tested test_number;
-     error ()
-   end;;
-
-let end_tests () =
- flush_all ();
- print_newline ();
- if !error_occurred then begin
-   print_endline "************* TESTS FAILED ****************"; exit 2
- end else begin
-   print_endline "************* TESTS COMPLETED SUCCESSFULLY ****************";
-   exit 0
- end;;
-
-let eq = (==);;
-let eq_int (i: int) (j: int) = (i = j);;
-let eq_string (i: string) (j: string) = (i = j);;
-let eq_bytes (i: bytes) (j: bytes) = (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;;
-
-let rec gcd_int i1 i2 =
-  if i2 = 0 then abs i1 else gcd_int i2 (i1 mod i2);;
-
-let rec num_bits_int_aux n =
-  if n = 0 then 0 else succ(num_bits_int_aux (n lsr 1));;
-
-let num_bits_int n = num_bits_int_aux (abs n);;
-
-let sign_int i = if i = 0 then 0 else if i > 0 then 1 else -1;;
-
-let length_of_int = Sys.word_size - 2;;
-
-let monster_int = 1 lsl length_of_int;;
-let biggest_int = monster_int - 1;;
-let least_int = - biggest_int;;
-
-let compare_int n1 n2 =
-  if n1 == n2 then 0 else if n1 > n2 then 1 else -1;;

diff --git a/testsuite/tests/lib-num/test_big_ints.ml b/testsuite/tests/lib-num/test_big_ints.ml
deleted file mode 100644 (file)
index 61e4a9f..0000000
--- a/testsuite/tests/lib-num/test_big_ints.ml
+++ /dev/null
@@ -1,1030 +0,0 @@
-open Test;;
-open Nat;;
-open Big_int;;
-open List;;
-
-testing_function "compare_big_int";;
-
-test 1
-eq_int (compare_big_int zero_big_int zero_big_int, 0);;
-test 2
-eq_int (compare_big_int zero_big_int (big_int_of_int 1), (-1));;
-test 3
-eq_int (compare_big_int zero_big_int (big_int_of_int (-1)), 1);;
-test 4
-eq_int (compare_big_int (big_int_of_int 1) zero_big_int, 1);;
-test 5
-eq_int (compare_big_int (big_int_of_int (-1)) zero_big_int, (-1));;
-test 6
-eq_int (compare_big_int (big_int_of_int 1) (big_int_of_int 1), 0);;
-test 7
-eq_int (compare_big_int (big_int_of_int (-1)) (big_int_of_int (-1)), 0);;
-test 8
-eq_int (compare_big_int (big_int_of_int 1) (big_int_of_int (-1)), 1);;
-test 9
-eq_int (compare_big_int (big_int_of_int (-1)) (big_int_of_int 1), (-1));;
-test 10
-eq_int (compare_big_int (big_int_of_int 1) (big_int_of_int 2), (-1));;
-test 11
-eq_int (compare_big_int (big_int_of_int 2) (big_int_of_int 1), 1);;
-test 12
-eq_int (compare_big_int (big_int_of_int (-1)) (big_int_of_int (-2)), 1);;
-test 13
-eq_int (compare_big_int (big_int_of_int (-2)) (big_int_of_int (-1)), (-1));;
-
-
-testing_function "pred_big_int";;
-
-test 1
-eq_big_int (pred_big_int zero_big_int, big_int_of_int (-1));;
-test 2
-eq_big_int (pred_big_int unit_big_int, zero_big_int);;
-test 3
-eq_big_int (pred_big_int (big_int_of_int (-1)), big_int_of_int (-2));;
-
-testing_function "succ_big_int";;
-
-test 1
-eq_big_int (succ_big_int zero_big_int, unit_big_int);;
-test 2
-eq_big_int (succ_big_int unit_big_int, big_int_of_int 2);;
-test 3
-eq_big_int (succ_big_int (big_int_of_int (-1)), zero_big_int);;
-
-testing_function "add_big_int";;
-
-test 1
-eq_big_int (add_big_int zero_big_int zero_big_int, zero_big_int);;
-test 2
-eq_big_int (add_big_int zero_big_int (big_int_of_int 1),
-            big_int_of_int 1);;
-test 3
-eq_big_int (add_big_int (big_int_of_int 1) zero_big_int,
-            big_int_of_int 1);;
-test 4
-eq_big_int (add_big_int zero_big_int (big_int_of_int (-1)),
-            big_int_of_int (-1));;
-test 5
-eq_big_int (add_big_int (big_int_of_int (-1)) zero_big_int,
-            big_int_of_int (-1));;
-test 6
-eq_big_int (add_big_int (big_int_of_int 1) (big_int_of_int 1),
-            big_int_of_int 2);;
-test 7
-eq_big_int (add_big_int (big_int_of_int 1) (big_int_of_int 2),
-            big_int_of_int 3);;
-test 8
-eq_big_int (add_big_int (big_int_of_int 2) (big_int_of_int 1),
-            big_int_of_int 3);;
-test 9
-eq_big_int (add_big_int (big_int_of_int (-1)) (big_int_of_int (-1)),
-            big_int_of_int (-2));;
-test 10
-eq_big_int (add_big_int (big_int_of_int (-1)) (big_int_of_int (-2)),
-            big_int_of_int (-3));;
-test 11
-eq_big_int (add_big_int (big_int_of_int (-2)) (big_int_of_int (-1)),
-            big_int_of_int (-3));;
-test 12
-eq_big_int (add_big_int (big_int_of_int 1) (big_int_of_int (-1)),
-            zero_big_int);;
-test 13
-eq_big_int (add_big_int (big_int_of_int (-1)) (big_int_of_int 1),
-            zero_big_int);;
-test 14
-eq_big_int (add_big_int (big_int_of_int 1) (big_int_of_int (-2)),
-            big_int_of_int (-1));;
-test 15
-eq_big_int (add_big_int (big_int_of_int (-2)) (big_int_of_int 1),
-            big_int_of_int (-1));;
-test 16
-eq_big_int (add_big_int (big_int_of_int (-1)) (big_int_of_int 2),
-            big_int_of_int 1);;
-test 17
-eq_big_int (add_big_int (big_int_of_int 2) (big_int_of_int (-1)),
-            big_int_of_int 1);;
-
-
-testing_function "sub_big_int";;
-
-test 1
-eq_big_int (sub_big_int zero_big_int zero_big_int, zero_big_int);;
-test 2
-eq_big_int (sub_big_int zero_big_int (big_int_of_int 1),
-            big_int_of_int (-1));;
-test 3
-eq_big_int (sub_big_int (big_int_of_int 1) zero_big_int,
-            big_int_of_int 1);;
-test 4
-eq_big_int (sub_big_int zero_big_int (big_int_of_int (-1)),
-            big_int_of_int 1);;
-test 5
-eq_big_int (sub_big_int (big_int_of_int (-1)) zero_big_int,
-            big_int_of_int (-1));;
-test 6
-eq_big_int (sub_big_int (big_int_of_int 1) (big_int_of_int 1),
-            zero_big_int);;
-test 7
-eq_big_int (sub_big_int (big_int_of_int 1) (big_int_of_int 2),
-            big_int_of_int (-1));;
-test 8
-eq_big_int (sub_big_int (big_int_of_int 2) (big_int_of_int 1),
-            big_int_of_int 1);;
-test 9
-eq_big_int (sub_big_int (big_int_of_int (-1)) (big_int_of_int (-1)),
-            zero_big_int);;
-test 10
-eq_big_int (sub_big_int (big_int_of_int (-1)) (big_int_of_int (-2)),
-            big_int_of_int 1);;
-test 11
-eq_big_int (sub_big_int (big_int_of_int (-2)) (big_int_of_int (-1)),
-            big_int_of_int (-1));;
-test 12
-eq_big_int (sub_big_int (big_int_of_int 1) (big_int_of_int (-1)),
-            big_int_of_int 2);;
-test 13
-eq_big_int (sub_big_int (big_int_of_int (-1)) (big_int_of_int 1),
-            big_int_of_int (-2));;
-test 14
-eq_big_int (sub_big_int (big_int_of_int 1) (big_int_of_int (-2)),
-            big_int_of_int 3);;
-test 15
-eq_big_int (sub_big_int (big_int_of_int (-2)) (big_int_of_int 1),
-            big_int_of_int (-3));;
-test 16
-eq_big_int (sub_big_int (big_int_of_int (-1)) (big_int_of_int 2),
-            big_int_of_int (-3));;
-test 17
-eq_big_int (sub_big_int (big_int_of_int 2) (big_int_of_int (-1)),
-            big_int_of_int 3);;
-
-testing_function "mult_int_big_int";;
-
-test 1
-eq_big_int (mult_int_big_int 0 (big_int_of_int 3), zero_big_int);;
-test 2
-eq_big_int (mult_int_big_int 1 (big_int_of_int 3), big_int_of_int 3);;
-test 3
-eq_big_int (mult_int_big_int 1 zero_big_int, zero_big_int);;
-test 4
-eq_big_int (mult_int_big_int 2 (big_int_of_int 3), big_int_of_int 6);;
-
-testing_function "mult_big_int";;
-
-test 1
-eq_big_int (mult_big_int zero_big_int zero_big_int,
-            zero_big_int);;
-test 2
-eq_big_int (mult_big_int (big_int_of_int 2) (big_int_of_int 3),
-            big_int_of_int 6);;
-test 3
-eq_big_int (mult_big_int (big_int_of_int 2) (big_int_of_int (-3)),
-            big_int_of_int (-6));;
-test 4
-eq_big_int (mult_big_int (big_int_of_string "12724951")
-                         (big_int_of_string "81749606400"),
-            big_int_of_string "1040259735709286400");;
-test 5
-eq_big_int (mult_big_int (big_int_of_string "26542080")
-                          (big_int_of_string "81749606400"),
-            big_int_of_string "2169804593037312000");;
-
-testing_function "quomod_big_int";;
-
-let (quotient, modulo) =
-      quomod_big_int (big_int_of_int 1) (big_int_of_int 1) in
- test 1 eq_big_int (quotient, big_int_of_int 1) &&
- test 2 eq_big_int (modulo, zero_big_int);;
-
-let (quotient, modulo) =
-      quomod_big_int (big_int_of_int 1) (big_int_of_int (-1)) in
- test 3 eq_big_int (quotient, big_int_of_int (-1)) &&
- test 4 eq_big_int (modulo, zero_big_int);;
-
-let (quotient, modulo) =
-      quomod_big_int (big_int_of_int (-1)) (big_int_of_int 1) in
- test 5 eq_big_int (quotient, big_int_of_int (-1)) &&
- test 6 eq_big_int (modulo, zero_big_int);;
-
-let (quotient, modulo) =
-      quomod_big_int (big_int_of_int 3) (big_int_of_int 2) in
- test 7 eq_big_int (quotient, big_int_of_int 1) &&
- test 8 eq_big_int (modulo, big_int_of_int 1);;
-
-let (quotient, modulo) =
-      quomod_big_int (big_int_of_int 5) (big_int_of_int 3) in
- test 9 eq_big_int (quotient, big_int_of_int 1) &&
- test 10 eq_big_int (modulo, big_int_of_int 2);;
-
-let (quotient, modulo) =
-      quomod_big_int (big_int_of_int (-5)) (big_int_of_int 3) in
- test 11 eq_big_int (quotient, big_int_of_int (-2)) &&
- test 12 eq_big_int (modulo, big_int_of_int 1);;
-
-let (quotient, modulo) =
-      quomod_big_int (big_int_of_int 1) (big_int_of_int 2) in
- test 13 eq_big_int (quotient, zero_big_int) &&
- test 14 eq_big_int (modulo, big_int_of_int 1);;
-
-let (quotient, modulo) =
-      quomod_big_int (big_int_of_int (-1)) (big_int_of_int 3) in
- test 15 eq_big_int (quotient, minus_big_int unit_big_int) &&
- test 16 eq_big_int (modulo, big_int_of_int 2);;
-
-failwith_test 17
-(quomod_big_int (big_int_of_int 1)) zero_big_int
-Division_by_zero
-;;
-
-let (quotient, modulo) =
-      quomod_big_int (big_int_of_int 10) (big_int_of_int 20) in
- test 18 eq_big_int (quotient, big_int_of_int 0) &&
- test 19 eq_big_int (modulo, big_int_of_int 10);;
-
-let (quotient, modulo) =
-      quomod_big_int (big_int_of_int (-10)) (big_int_of_int 20) in
- test 20 eq_big_int (quotient, big_int_of_int (-1)) &&
- test 21 eq_big_int (modulo, big_int_of_int 10);;
-
-let (quotient, modulo) =
-      quomod_big_int (big_int_of_int 10) (big_int_of_int (-20)) in
- test 22 eq_big_int (quotient, big_int_of_int 0) &&
- test 23 eq_big_int (modulo, big_int_of_int 10);;
-
-let (quotient, modulo) =
-      quomod_big_int (big_int_of_int (-10)) (big_int_of_int (-20)) in
- test 24 eq_big_int (quotient, big_int_of_int 1) &&
- test 25 eq_big_int (modulo, big_int_of_int 10);;
-
-
-testing_function "gcd_big_int";;
-
-test 1
-eq_big_int (gcd_big_int zero_big_int zero_big_int,
-            zero_big_int);;
-test 2
-eq_big_int (gcd_big_int zero_big_int (big_int_of_int 1),
-            big_int_of_int 1);;
-test 3
-eq_big_int (gcd_big_int (big_int_of_int 1) zero_big_int,
-            big_int_of_int 1);;
-test 4
-eq_big_int (gcd_big_int (big_int_of_int 1) (big_int_of_int 2),
-            big_int_of_int 1);;
-test 5
-eq_big_int (gcd_big_int (big_int_of_int 2) (big_int_of_int 1),
-            big_int_of_int 1);;
-test 6
-eq_big_int (gcd_big_int (big_int_of_int 1) (big_int_of_int 1),
-            big_int_of_int 1);;
-test 7
-eq_big_int (gcd_big_int (big_int_of_int 9) (big_int_of_int 16),
-            big_int_of_int 1);;
-test 8
-eq_big_int (gcd_big_int (big_int_of_int 12) (big_int_of_int 16),
-            big_int_of_int 4);;
-
-for i = 9 to 28 do
-  let n1 = Random.int 1000000000
-  and n2 = Random.int 100000 in
-  let _ =
-    test i eq
-      (int_of_big_int (gcd_big_int (big_int_of_int n1) (big_int_of_int n2)),
-       gcd_int n1 n2) in
-  ()
-done;;
-
-testing_function "int_of_big_int";;
-
-test 1
-eq_int (int_of_big_int (big_int_of_int 1), 1);;
-test 2
-eq_int (int_of_big_int (big_int_of_int(-1)), -1);;
-test 3
-eq_int (int_of_big_int zero_big_int, 0);;
-test 4
-eq_int (int_of_big_int (big_int_of_int max_int), max_int);;
-test 5
-eq_int (int_of_big_int (big_int_of_int min_int), min_int);;
-failwith_test 6
-  (fun () -> int_of_big_int (succ_big_int (big_int_of_int max_int)))
-  () (Failure "int_of_big_int");;
-failwith_test 7
-  (fun () -> int_of_big_int (pred_big_int (big_int_of_int min_int)))
-  () (Failure "int_of_big_int");;
-failwith_test 8
-  (fun () -> int_of_big_int (mult_big_int (big_int_of_int min_int)
-                                          (big_int_of_int 2)))
-  () (Failure "int_of_big_int");;
-
-
-testing_function "is_int_big_int";;
-
-test 1
-eq (is_int_big_int (big_int_of_int 1), true);;
-test 2
-eq (is_int_big_int (big_int_of_int (-1)), true);;
-test 3
-eq (is_int_big_int (succ_big_int (big_int_of_int biggest_int)), false);;
-test 4
-eq (int_of_big_int (big_int_of_int monster_int), monster_int);;
-(* Should be true *)
-test 5
-eq (is_int_big_int (big_int_of_string (string_of_int biggest_int)), true);;
-test 6
-eq (is_int_big_int (big_int_of_string (string_of_int least_int)), true);;
-test 7
-eq (is_int_big_int (big_int_of_string (string_of_int monster_int)), true);;
-
-(* Should be false *)
-(* Successor of biggest_int is not an int *)
-test 8
-eq (is_int_big_int (succ_big_int (big_int_of_int (biggest_int))), false);;
-test 9
-eq (is_int_big_int
-     (succ_big_int (succ_big_int (big_int_of_int (biggest_int)))), false);;
-(* Negation of monster_int (as a big_int) is not an int *)
-test 10
-eq (is_int_big_int
-     (minus_big_int (big_int_of_string (string_of_int monster_int))), false);;
-
-
-testing_function "sys_string_of_big_int";;
-
-test 1
-eq_string (string_of_big_int (big_int_of_int 1), "1");;
-
-
-testing_function "big_int_of_string";;
-
-test 1
-eq_big_int (big_int_of_string "1", big_int_of_int 1);;
-test 2
-eq_big_int (big_int_of_string "-1", big_int_of_int (-1));;
-test 4
-eq_big_int (big_int_of_string "0", zero_big_int);;
-
-failwith_test 5 big_int_of_string "sdjdkfighdgf"
-  (Failure "invalid digit");;
-
-test 6
-eq_big_int (big_int_of_string "123", big_int_of_int 123);;
-test 7
-eq_big_int (big_int_of_string "+3456", big_int_of_int 3456);;
-
-test 9
-eq_big_int (big_int_of_string "-3456", big_int_of_int (-3456));;
-
-
-let implode = List.fold_left (^) "";; (* To hell with efficiency *)
-
-let l = rev [
-"174679877494298468451661416292903906557638850173895426081611831060970135303";
-"044177587617233125776581034213405720474892937404345377707655788096850784519";
-"539374048533324740018513057210881137248587265169064879918339714405948322501";
-"445922724181830422326068913963858377101914542266807281471620827145038901025";
-"322784396182858865537924078131032036927586614781817695777639491934361211399";
-"888524140253852859555118862284235219972858420374290985423899099648066366558";
-"238523612660414395240146528009203942793935957539186742012316630755300111472";
-"852707974927265572257203394961525316215198438466177260614187266288417996647";
-"132974072337956513457924431633191471716899014677585762010115338540738783163";
-"739223806648361958204720897858193606022290696766988489073354139289154127309";
-"916985231051926209439373780384293513938376175026016587144157313996556653811";
-"793187841050456120649717382553450099049321059330947779485538381272648295449";
-"847188233356805715432460040567660999184007627415398722991790542115164516290";
-"619821378529926683447345857832940144982437162642295073360087284113248737998";
-"046564369129742074737760485635495880623324782103052289938185453627547195245";
-"688272436219215066430533447287305048225780425168823659431607654712261368560";
-"702129351210471250717394128044019490336608558608922841794819375031757643448";
-"32"
-] in
-
-let bi1 = big_int_of_string (implode (rev l)) in
-
-let bi2 = big_int_of_string (implode (rev ("3" :: tl l))) in
-
-test 10
-eq_big_int (bi1, (add_big_int (mult_big_int bi2 (big_int_of_string "10"))
-                              (big_int_of_string "2")))
-(* test 11
- &&
-eq_big_int (bi1, (add_big_int (mult_big_int bi2 (big_int_of_string "10e0"))
-                              (big_int_of_string "20e-1"))) &&
-test 12
-eq_big_int (minus_big_int bi1,
-            (add_big_int (mult_big_int bi2 (big_int_of_string "-10e0"))
-                         (big_int_of_string "-20e-1"))) &&
-test 13
-eq_big_int (bi1, (add_big_int (mult_big_int bi2 (big_int_of_string "+10e0"))
-                              (big_int_of_string "+20e-1"))) &&
-test 14
-eq_big_int (minus_big_int bi1,
-            (add_big_int (mult_big_int bi2 (big_int_of_string "-10e+0"))
-                         (big_int_of_string "-20e-1"))) &&
-test 15
-eq_big_int (minus_big_int bi1,
-            (add_big_int (mult_big_int bi2 (big_int_of_string "-1e+1"))
-                         (big_int_of_string "-2e-0"))) &&
-test 16
-eq_big_int (minus_big_int bi1,
-            (add_big_int (mult_big_int bi2 (big_int_of_string "-0.1e+2"))
-                         (big_int_of_string "-2.0e-0"))) &&
-test 17
-eq_big_int (minus_big_int bi1,
-            (add_big_int (mult_big_int bi2 (big_int_of_string "-1.000e+1"))
-                         (big_int_of_string "-0.02e2")))*)
-;;
-
-test 18
-eq_big_int (big_int_of_string "0xAbC", big_int_of_int 0xABC);;
-
-test 19
-eq_big_int (big_int_of_string "-0o452", big_int_of_int (-0o452));;
-
-test 20
-eq_big_int (big_int_of_string "0B110101", big_int_of_int 53);;
-
-test 21
-eq_big_int (big_int_of_string "0b11_01_01", big_int_of_int 53);;
-
-testing_function "power_base_int";;
-
-test 1
-eq_big_int (big_int_of_nat (power_base_int 10 0), unit_big_int)
-;;
-test 2
-eq_big_int (big_int_of_nat (power_base_int 10 8), big_int_of_int 100000000)
-;;
-test 3
-eq_big_int (big_int_of_nat (power_base_int 2 (length_of_int + 2)),
-            big_int_of_nat (let nat = make_nat 2 in
-                              set_digit_nat nat 1 1;
-                              nat))
-;;
-
-testing_function "base_power_big_int";;
-
-test 1
-eq_big_int (base_power_big_int 10 0 (big_int_of_int 2), big_int_of_int 2);;
-test 2
-eq_big_int (base_power_big_int 10 2 (big_int_of_int 2), big_int_of_int 200);;
-test 3
-eq_big_int (base_power_big_int 10 1 (big_int_of_int 123), big_int_of_int 1230)
-;;
-
-testing_function "power_int_positive_big_int";;
-
-test 1
-eq_big_int (power_int_positive_big_int 2 (big_int_of_int 10),
-            big_int_of_int 1024);;
-test 2
-eq_big_int
- (power_int_positive_big_int 2 (big_int_of_int 65),
-  big_int_of_string "36893488147419103232");;
-
-test 3
-eq_big_int
- (power_int_positive_big_int 3 (big_int_of_string "47"),
-  big_int_of_string "26588814358957503287787");;
-
-test 4
-eq_big_int
- (power_int_positive_big_int 1 (big_int_of_string "1000000000000000000000"),
-  big_int_of_int 1);;
-
-test 5
-eq_big_int
- (power_int_positive_big_int (-1) (big_int_of_string "1000000000000000000000"),
-  big_int_of_int 1);;
-
-test 6
-eq_big_int
- (power_int_positive_big_int (-1) (big_int_of_string "1000000000000000000001"),
-  big_int_of_int (-1));;
-
-test 7
-eq_big_int
- (power_int_positive_big_int 0 (big_int_of_string "1000000000000000000000"),
-  big_int_of_int 0);;
-
-testing_function "power_big_int_positive_int";;
-
-test 1
-eq_big_int (power_big_int_positive_int (big_int_of_int 2) 10,
-            big_int_of_int 1024);;
-test 2
-eq_big_int
- (power_big_int_positive_int (big_int_of_int 100) 20,
-  big_int_of_string "10000000000000000000000000000000000000000");;
-
-test 3
-eq_big_int
- (power_big_int_positive_int (big_int_of_string "3") 47,
-  big_int_of_string "26588814358957503287787");;
-
-test 4
-eq_big_int
- (power_big_int_positive_int (big_int_of_string "200000000000000") 34,
-  big_int_of_string
-"17179869184000000000000000000000000000000000000000000000000000000000\
-00000000000000000000000000000000000000000000000000000000000000000000\
-00000000000000000000000000000000000000000000000000000000000000000000\
-00000000000000000000000000000000000000000000000000000000000000000000\
-00000000000000000000000000000000000000000000000000000000000000000000\
-00000000000000000000000000000000000000000000000000000000000000000000\
-00000000000000000000000000000000000000000000000000000000000000000000\
-00000000000");;
-
-test 5
-eq_big_int
- (power_big_int_positive_int (big_int_of_string "2197609328765") 243,
-  big_int_of_string
-"12415638672345366257764851943822299490113545698929764576040102857365\
-27920436565335427676982530274588056944387957287793378051852205028658\
-73008292720317554332284838709453634119919368441951233982592586680844\
-20765201140575612595182857026804842796931784944918059630667794516774\
-58498235838834599150657873894983300999081942159304585449505963892008\
-97855706440206825609657816209327492197604711437269361628626691080334\
-38432768885637928268354258860147333786379766583179851226375449161073\
-10396958979998161989562418169797611757651190037273397850239552735199\
-63719988832594486235837899145390948533078339399890545062510060406048\
-61331200657727576638170520036143007285549092686618686739320973444703\
-33342725604091818763255601206325426337211467746377586080108631634250\
-11232258578207762608797108802386708549785680783113606089879687396654\
-54004281165259352412815385041917713969718327109245777066079665194617\
-29230093411050053217775067781725651590160086483960457766025246936489\
-92234225900994076609973190516835778346886551506344097474301175288686\
-25662752919718480402972207084177612056491949911377568680526080633587\
-33230060757162252611388973328501680433819585006035301408574879645573\
-47126018243568976860515247053858204554293343161581801846081341003624\
-22906934772131205632200433218165757307182816260714026614324014553342\
-77303133877636489457498062819003614421295692889321460150481573909330\
-77301946991278225819671075907191359721824291923283322225480199446258\
-03302645587072103949599624444368321734975586414930425964782010567575\
-43333331963876294983400462908871215572514487548352925949663431718284\
-14589547315559936497408670231851521193150991888789948397029796279240\
-53117024758684807981605608837291399377902947471927467827290844733264\
-70881963357258978768427852958888430774360783419404195056122644913454\
-24537375432013012467418602205343636983874410969339344956536142566292\
-67710105053213729008973121773436382170956191942409859915563249876601\
-97309463059908818473774872128141896864070835259683384180928526600888\
-17480854811931632353621014638284918544379784608050029606475137979896\
-79160729736625134310450643341951675749112836007180865039256361941093\
-99844921135320096085772541537129637055451495234892640418746420370197\
-76655592198723057553855194566534999101921182723711243608938705766658\
-35660299983828999383637476407321955462859142012030390036241831962713\
-40429407146441598507165243069127531565881439971034178400174881243483\
-00001434950666035560134867554719667076133414445044258086968145695386\
-00575860256380332451841441394317283433596457253185221717167880159573\
-60478649571700878049257386910142909926740023800166057094445463624601\
-79490246367497489548435683835329410376623483996271147060314994344869\
-89606855219181727424853876740423210027967733989284801813769926906846\
-45570461348452758744643550541290031199432061998646306091218518879810\
-17848488755494879341886158379140088252013009193050706458824793551984\
-39285914868159111542391208521561221610797141925061986437418522494485\
-59871215531081904861310222368465288125816137210222223075106739997863\
-76953125");;
-
-testing_function "power_big_int_positive_big_int";;
-
-test 1
-eq_big_int
- (power_big_int_positive_big_int (big_int_of_int 2) (big_int_of_int 10),
-  big_int_of_int 1024);;
-
-test 2
-eq_big_int
- (power_big_int_positive_big_int (big_int_of_int 2) (big_int_of_int 65),
-  big_int_of_string "36893488147419103232");;
-
-test 3
-eq_big_int
- (power_big_int_positive_big_int
-   (big_int_of_string "3") (big_int_of_string "47"),
-  big_int_of_string "26588814358957503287787");;
-
-test 4
-eq_big_int
- (power_big_int_positive_big_int
-     (big_int_of_string "200000000000000") (big_int_of_int 34),
-  big_int_of_string
-"17179869184000000000000000000000000000000000000000000000000000000000\
-00000000000000000000000000000000000000000000000000000000000000000000\
-00000000000000000000000000000000000000000000000000000000000000000000\
-00000000000000000000000000000000000000000000000000000000000000000000\
-00000000000000000000000000000000000000000000000000000000000000000000\
-00000000000000000000000000000000000000000000000000000000000000000000\
-00000000000000000000000000000000000000000000000000000000000000000000\
-00000000000");;
-
-test 5
-eq_big_int
- (power_big_int_positive_big_int (big_int_of_string "2197609328765")
-                                 (big_int_of_string "243"),
-  big_int_of_string
-"12415638672345366257764851943822299490113545698929764576040102857365\
-27920436565335427676982530274588056944387957287793378051852205028658\
-73008292720317554332284838709453634119919368441951233982592586680844\
-20765201140575612595182857026804842796931784944918059630667794516774\
-58498235838834599150657873894983300999081942159304585449505963892008\
-97855706440206825609657816209327492197604711437269361628626691080334\
-38432768885637928268354258860147333786379766583179851226375449161073\
-10396958979998161989562418169797611757651190037273397850239552735199\
-63719988832594486235837899145390948533078339399890545062510060406048\
-61331200657727576638170520036143007285549092686618686739320973444703\
-33342725604091818763255601206325426337211467746377586080108631634250\
-11232258578207762608797108802386708549785680783113606089879687396654\
-54004281165259352412815385041917713969718327109245777066079665194617\
-29230093411050053217775067781725651590160086483960457766025246936489\
-92234225900994076609973190516835778346886551506344097474301175288686\
-25662752919718480402972207084177612056491949911377568680526080633587\
-33230060757162252611388973328501680433819585006035301408574879645573\
-47126018243568976860515247053858204554293343161581801846081341003624\
-22906934772131205632200433218165757307182816260714026614324014553342\
-77303133877636489457498062819003614421295692889321460150481573909330\
-77301946991278225819671075907191359721824291923283322225480199446258\
-03302645587072103949599624444368321734975586414930425964782010567575\
-43333331963876294983400462908871215572514487548352925949663431718284\
-14589547315559936497408670231851521193150991888789948397029796279240\
-53117024758684807981605608837291399377902947471927467827290844733264\
-70881963357258978768427852958888430774360783419404195056122644913454\
-24537375432013012467418602205343636983874410969339344956536142566292\
-67710105053213729008973121773436382170956191942409859915563249876601\
-97309463059908818473774872128141896864070835259683384180928526600888\
-17480854811931632353621014638284918544379784608050029606475137979896\
-79160729736625134310450643341951675749112836007180865039256361941093\
-99844921135320096085772541537129637055451495234892640418746420370197\
-76655592198723057553855194566534999101921182723711243608938705766658\
-35660299983828999383637476407321955462859142012030390036241831962713\
-40429407146441598507165243069127531565881439971034178400174881243483\
-00001434950666035560134867554719667076133414445044258086968145695386\
-00575860256380332451841441394317283433596457253185221717167880159573\
-60478649571700878049257386910142909926740023800166057094445463624601\
-79490246367497489548435683835329410376623483996271147060314994344869\
-89606855219181727424853876740423210027967733989284801813769926906846\
-45570461348452758744643550541290031199432061998646306091218518879810\
-17848488755494879341886158379140088252013009193050706458824793551984\
-39285914868159111542391208521561221610797141925061986437418522494485\
-59871215531081904861310222368465288125816137210222223075106739997863\
-76953125");;
-
-test 6
-eq_big_int
- (power_big_int_positive_big_int (big_int_of_int 1)
-                                 (big_int_of_string "1000000000000000000000"),
-  big_int_of_int 1);;
-
-test 7
-eq_big_int
- (power_big_int_positive_big_int (big_int_of_int (-1))
-                                 (big_int_of_string "1000000000000000000000"),
-  big_int_of_int 1);;
-
-test 8
-eq_big_int
- (power_big_int_positive_big_int (big_int_of_int (-1))
-                                 (big_int_of_string "1000000000000000000001"),
-  big_int_of_int (-1));;
-
-test 9
-eq_big_int
- (power_big_int_positive_big_int (big_int_of_int 0)
-                                 (big_int_of_string "1000000000000000000000"),
-  big_int_of_int 0);;
-
-testing_function "square_big_int";;
-
-test 1 eq_big_int
- (square_big_int (big_int_of_string "0"), big_int_of_string "0");;
-test 2 eq_big_int
- (square_big_int (big_int_of_string "1"), big_int_of_string "1");;
-test 3 eq_big_int
- (square_big_int (big_int_of_string "-1"), big_int_of_string "1");;
-test 4 eq_big_int
- (square_big_int (big_int_of_string "-7"), big_int_of_string "49");;
-
-
-testing_function "big_int_of_nativeint";;
-
-test 1 eq_big_int
-  (big_int_of_nativeint 0n, zero_big_int);;
-test 2 eq_big_int
-  (big_int_of_nativeint 1234n, big_int_of_string "1234");;
-test 3 eq_big_int
-  (big_int_of_nativeint (-1234n), big_int_of_string "-1234");;
-
-testing_function "nativeint_of_big_int";;
-
-test 1 eq_nativeint
-  (nativeint_of_big_int zero_big_int, 0n);;
-test 2 eq_nativeint
-  (nativeint_of_big_int (big_int_of_string "1234"), 1234n);;
-test 2 eq_nativeint
-  (nativeint_of_big_int (big_int_of_string "-1234"), -1234n);;
-
-testing_function "big_int_of_int32";;
-
-test 1 eq_big_int
-  (big_int_of_int32 0l, zero_big_int);;
-test 2 eq_big_int
-  (big_int_of_int32 2147483647l, big_int_of_string "2147483647");;
-test 3 eq_big_int
-  (big_int_of_int32 (-2147483648l), big_int_of_string "-2147483648");;
-
-testing_function "int32_of_big_int";;
-
-test 1 eq_int32
-  (int32_of_big_int zero_big_int, 0l);;
-test 2 eq_int32
-  (int32_of_big_int (big_int_of_string "2147483647"), 2147483647l);;
-test 3 eq_int32
-  (int32_of_big_int (big_int_of_string "-2147483648"), -2147483648l);;
-test 4 eq_int32
-  (int32_of_big_int (big_int_of_string "-2147"), -2147l);;
-let should_fail s =
-  try ignore (int32_of_big_int (big_int_of_string s)); 0
-  with Failure _ -> 1;;
-test 5 eq_int
-  (should_fail "2147483648", 1);;
-test 6 eq_int
-  (should_fail "-2147483649", 1);;
-test 7 eq_int
-  (should_fail "4294967296", 1);;
-test 8 eq_int
-  (should_fail "18446744073709551616", 1);;
-
-testing_function "big_int_of_int64";;
-
-test 1 eq_big_int
-  (big_int_of_int64 0L, zero_big_int);;
-test 2 eq_big_int
-  (big_int_of_int64 9223372036854775807L,
-   big_int_of_string "9223372036854775807");;
-test 3 eq_big_int
-  (big_int_of_int64 (-9223372036854775808L),
-   big_int_of_string "-9223372036854775808");;
-test 4 eq_big_int (*PR#4792*)
-  (big_int_of_int64 (Int64.of_int32 Int32.min_int),
-   big_int_of_string "-2147483648");;
-test 5 eq_big_int
-  (big_int_of_int64 1234L, big_int_of_string "1234");;
-test 6 eq_big_int
-  (big_int_of_int64 0x1234567890ABCDEFL,
-   big_int_of_string "1311768467294899695");;
-test 7 eq_big_int
-  (big_int_of_int64 (-1234L), big_int_of_string "-1234");;
-test 8 eq_big_int
-  (big_int_of_int64 (-0x1234567890ABCDEFL),
-   big_int_of_string "-1311768467294899695");;
-
-testing_function "int64_of_big_int";;
-
-test 1 eq_int64
-  (int64_of_big_int zero_big_int, 0L);;
-test 2 eq_int64
-  (int64_of_big_int (big_int_of_string "9223372036854775807"),
-   9223372036854775807L);;
-test 3 eq_int64
-  (int64_of_big_int (big_int_of_string "-9223372036854775808"),
-   -9223372036854775808L);;
-test 4 eq_int64
-  (int64_of_big_int (big_int_of_string "-9223372036854775"),
-   -9223372036854775L);;
-test 5 eq_int64 (* PR#4804 *)
-  (int64_of_big_int (big_int_of_string "2147483648"), 2147483648L);;
-let should_fail s =
-  try ignore (int64_of_big_int (big_int_of_string s)); 0
-  with Failure _ -> 1;;
-test 6 eq_int
-  (should_fail "9223372036854775808", 1);;
-test 7 eq_int
-  (should_fail "-9223372036854775809", 1);;
-test 8 eq_int
-  (should_fail "18446744073709551616", 1);;
-
-(* build a 128-bit big int from two int64 *)
-
-let big_int_128 hi lo =
-  add_big_int (mult_big_int (big_int_of_int64 hi)
-                            (big_int_of_string "18446744073709551616"))
-              (big_int_of_int64 lo);;
-let h1 = 0x7fd05b7ee46a29f8L
-and h2 = 0x64b28b8ee70b6e6dL
-and h3 = 0x58546e563f5b44f0L
-and h4 = 0x1db72f6377ff3ec6L
-and h5 = 0x4f9bb0a19c543cb1L;;
-
-testing_function "and_big_int";;
-
-test 1 eq_big_int
-  (and_big_int unit_big_int zero_big_int, zero_big_int);;
-test 2 eq_big_int
-  (and_big_int zero_big_int unit_big_int, zero_big_int);;
-test 3 eq_big_int
-  (and_big_int unit_big_int unit_big_int, unit_big_int);;
-test 4 eq_big_int
-  (and_big_int (big_int_128 h1 h2) (big_int_128 h3 h4),
-   big_int_128 (Int64.logand h1 h3) (Int64.logand h2 h4));;
-test 5 eq_big_int
-  (and_big_int (big_int_128 h1 h2) (big_int_of_int64 h5),
-   big_int_of_int64 (Int64.logand h2 h5));;
-test 6 eq_big_int
-  (and_big_int (big_int_of_int64 h5) (big_int_128 h3 h4) ,
-   big_int_of_int64 (Int64.logand h5 h4));;
-
-testing_function "or_big_int";;
-
-test 1 eq_big_int
-  (or_big_int unit_big_int zero_big_int, unit_big_int);;
-test 2 eq_big_int
-  (or_big_int zero_big_int unit_big_int, unit_big_int);;
-test 3 eq_big_int
-  (or_big_int unit_big_int unit_big_int, unit_big_int);;
-test 4 eq_big_int
-  (or_big_int (big_int_128 h1 h2) (big_int_128 h3 h4),
-   big_int_128 (Int64.logor h1 h3) (Int64.logor h2 h4));;
-test 5 eq_big_int
-  (or_big_int (big_int_128 h1 h2) (big_int_of_int64 h5),
-   big_int_128 h1 (Int64.logor h2 h5));;
-test 6 eq_big_int
-  (or_big_int (big_int_of_int64 h5) (big_int_128 h3 h4) ,
-   big_int_128 h3 (Int64.logor h5 h4));;
-
-testing_function "xor_big_int";;
-
-test 1 eq_big_int
-  (xor_big_int unit_big_int zero_big_int, unit_big_int);;
-test 2 eq_big_int
-  (xor_big_int zero_big_int unit_big_int, unit_big_int);;
-test 3 eq_big_int
-  (xor_big_int unit_big_int unit_big_int, zero_big_int);;
-test 4 eq_big_int
-  (xor_big_int (big_int_128 h1 h2) (big_int_128 h3 h4),
-   big_int_128 (Int64.logxor h1 h3) (Int64.logxor h2 h4));;
-test 5 eq_big_int
-  (xor_big_int (big_int_128 h1 h2) (big_int_of_int64 h5),
-   big_int_128 h1 (Int64.logxor h2 h5));;
-test 6 eq_big_int
-  (xor_big_int (big_int_of_int64 h5) (big_int_128 h3 h4) ,
-   big_int_128 h3 (Int64.logxor h5 h4));;
-
-testing_function "shift_left_big_int";;
-
-test 1 eq_big_int
-  (shift_left_big_int unit_big_int 0,
-   unit_big_int);;
-test 2 eq_big_int
-  (shift_left_big_int unit_big_int 1,
-   big_int_of_int 2);;
-test 2 eq_big_int
-  (shift_left_big_int unit_big_int 31,
-   big_int_of_string "2147483648");;
-test 3 eq_big_int
-  (shift_left_big_int unit_big_int 64,
-   big_int_of_string "18446744073709551616");;
-test 4 eq_big_int
-  (shift_left_big_int unit_big_int 95,
-   big_int_of_string "39614081257132168796771975168");;
-test 5 eq_big_int
-  (shift_left_big_int (big_int_of_string "39614081257132168796771975168") 67,
-   big_int_of_string "5846006549323611672814739330865132078623730171904");;
-test 6 eq_big_int
-  (shift_left_big_int (big_int_of_string "-39614081257132168796771975168") 67,
-   big_int_of_string "-5846006549323611672814739330865132078623730171904");;
-
-testing_function "shift_right_big_int";;
-
-test 1 eq_big_int
-  (shift_right_big_int unit_big_int 0,
-   unit_big_int);;
-test 2 eq_big_int
-  (shift_right_big_int (big_int_of_int 12345678) 3,
-   big_int_of_int 1543209);;
-test 3 eq_big_int
-  (shift_right_big_int (big_int_of_string "5299989648942") 32,
-   big_int_of_int 1234);;
-test 4 eq_big_int
-  (shift_right_big_int (big_int_of_string
-                          "5846006549323611672814739330865132078623730171904")
-                       67,
-   big_int_of_string "39614081257132168796771975168");;
-test 5 eq_big_int
-  (shift_right_big_int (big_int_of_string "-5299989648942") 32,
-   big_int_of_int (-1235));;
-test 6 eq_big_int
-  (shift_right_big_int (big_int_of_string "-16570089876543209725755392") 27,
-   big_int_of_string "-123456790123456789");;
-
-testing_function "shift_right_towards_zero_big_int";;
-
-test 1 eq_big_int
-  (shift_right_towards_zero_big_int (big_int_of_string "-5299989648942") 32,
-   big_int_of_int (-1234));;
-test 2 eq_big_int
-  (shift_right_towards_zero_big_int (big_int_of_string
-                                       "-16570089876543209725755392")
-                                    27,
-   big_int_of_string "-123456790123456789");;
-
-testing_function "extract_big_int";;
-
-test 1 eq_big_int
-  (extract_big_int (big_int_of_int64 0x123456789ABCDEFL) 3 13,
-   big_int_of_int 6589);;
-test 2 eq_big_int
-  (extract_big_int (big_int_128 h1 h2) 67 12,
-   big_int_of_int 1343);;
-test 3 eq_big_int
-  (extract_big_int (big_int_of_string "-1844674407370955178") 37 9,
-   big_int_of_int 307);;
-test 4 eq_big_int
-  (extract_big_int unit_big_int 2048 254,
-   zero_big_int);;
-test 5 eq_big_int
-  (extract_big_int (big_int_of_int64 0x123456789ABCDEFL) 0 32,
-   big_int_of_int64 2309737967L);;
-test 6 eq_big_int
-  (extract_big_int (big_int_of_int (-1)) 0 16,
-   big_int_of_int 0xFFFF);;
-test 7 eq_big_int
-  (extract_big_int (big_int_of_int (-1)) 1027 12,
-   big_int_of_int 0xFFF);;
-test 8 eq_big_int
-  (extract_big_int (big_int_of_int (-1234567)) 0 16,
-   big_int_of_int 10617);;
-test 9 eq_big_int
-  (extract_big_int (minus_big_int (power_int_positive_int 2 64)) 64 20,
-   big_int_of_int 0xFFFFF);;
-test 10 eq_big_int
-  (extract_big_int (pred_big_int (minus_big_int (power_int_positive_int 2 64)))
-                   64 20,
-   big_int_of_int 0xFFFFE);;
-
-testing_function "hashing of big integers";;
-
-test 1 eq_int (Hashtbl.hash zero_big_int,
-               955772237);;
-test 2 eq_int (Hashtbl.hash unit_big_int,
-               992063522);;
-test 3 eq_int (Hashtbl.hash (minus_big_int unit_big_int),
-               161678167);;
-test 4 eq_int (Hashtbl.hash (big_int_of_string "123456789123456789"),
-               755417385);;
-test 5 eq_int (Hashtbl.hash (sub_big_int
-                               (big_int_of_string "123456789123456789")
-                               (big_int_of_string "123456789123456789")),
-               955772237);;
-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;
-  let n = Int64.neg n 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_io.ml b/testsuite/tests/lib-num/test_io.ml
deleted file mode 100644 (file)
index 1df11a5..0000000
--- a/testsuite/tests/lib-num/test_io.ml
+++ /dev/null
@@ -1,64 +0,0 @@
-open Test
-open Nat
-open Big_int
-open Num
-
-let intern_extern obj =
-  let f = Filename.temp_file "testnum" ".data" in
-  let oc = open_out_bin f in
-  output_value oc obj;
-  close_out oc;
-  let ic = open_in_bin f in
-  let res = input_value ic in
-  close_in ic;
-  Sys.remove f;
-  res
-;;
-
-testing_function "output_value/input_value on nats";;
-
-let equal_nat n1 n2 =
-  eq_nat n1 0 (length_nat n1) n2 0 (length_nat n2)
-;;
-
-List.iter
-  (fun (i, s) ->
-    let n = nat_of_string s in
-    ignore(test i equal_nat (n, intern_extern n)))
-  [1, "0";
-   2, "1234";
-   3, "8589934592";
-   4, "340282366920938463463374607431768211455";
-   5, String.make 100 '3';
-   6, String.make 1000 '9';
-   7, String.make 20000 '8']
-;;
-
-testing_function "output_value/input_value on big ints";;
-
-List.iter
-  (fun (i, s) ->
-    let b = big_int_of_string s in
-    ignore(test i eq_big_int (b, intern_extern b)))
-  [1, "0";
-   2, "1234";
-   3, "-1234";
-   4, "1040259735709286400";
-   5, "-" ^ String.make 20000 '7']
-;;
-
-testing_function "output_value/input_value on nums";;
-
-List.iter
-  (fun (i, s) ->
-    let n = num_of_string s in
-    ignore(test i eq_num (n, intern_extern n)))
-  [1, "0";
-   2, "1234";
-   3, "-1234";
-   4, "159873568791325097646845892426782";
-   5, "1/4";
-   6, "-15/2";
-   7, "159873568791325097646845892426782/24098772507410987265987";
-   8, String.make 10000 '3' ^ "/" ^ String.make 5000 '7']
-;;

diff --git a/testsuite/tests/lib-num/test_nats.ml b/testsuite/tests/lib-num/test_nats.ml
deleted file mode 100644 (file)
index 74ce5ec..0000000
--- a/testsuite/tests/lib-num/test_nats.ml
+++ /dev/null
@@ -1,148 +0,0 @@
-open Test;;
-open Nat;;
-
-(* Can compare nats less than 2**32 *)
-let equal_nat n1 n2 =
- eq_nat n1 0 (num_digits_nat n1 0 1)
-        n2 0 (num_digits_nat n2 0 1);;
-
-testing_function "num_digits_nat";;
-
-test (-1) eq (false,not true);;
-test 0 eq (true,not false);;
-
-test 1
-eq_int
-(let r = make_nat 2 in
-  set_digit_nat r 1 1;
-  num_digits_nat r 0 1,1);;
-
-testing_function "length_nat";;
-
-test 1
-eq_int
-(let r = make_nat 2 in
-  set_digit_nat r 0 1;
-  length_nat r,2);;
-
-testing_function "equal_nat";;
-
-let zero_nat = make_nat 1 in
-
-test 1
-equal_nat (zero_nat,zero_nat);;
-test 2
-equal_nat (nat_of_int 1,nat_of_int 1);;
-
-test 3
-equal_nat (nat_of_string "2",nat_of_string "2");;
-test 4
-eq (equal_nat (nat_of_string "2")(nat_of_string "3"),false);;
-
-testing_function "incr_nat";;
-
-let zero = nat_of_int 0 in
-let res = incr_nat zero 0 1 1 in
- test 1
-  equal_nat (zero, nat_of_int 1) &&
- test 2
-  eq (res,0);;
-
-let n = nat_of_int 1 in
-let res = incr_nat n 0 1 1 in
- test 3
-  equal_nat (n, nat_of_int 2) &&
- test 4
-  eq (res,0);;
-
-
-testing_function "decr_nat";;
-
-let n = nat_of_int 1 in
-let res = decr_nat n 0 1 0 in
- test 1
-  equal_nat (n, nat_of_int 0) &&
- test 2
-  eq (res,1);;
-
-let n = nat_of_int 2 in
-let res = decr_nat n 0 1 0 in
- test 3
-  equal_nat (n, nat_of_int 1) &&
- test 4
-  eq (res,1);;
-
-testing_function "is_zero_nat";;
-
-let n = nat_of_int 1 in
-test 1 eq (is_zero_nat n 0 1,false) &&
-test 2 eq (is_zero_nat (make_nat 1) 0 1, true) &&
-test 3 eq (is_zero_nat (make_nat 2) 0 2, true) &&
-(let r = make_nat 2 in
-  set_digit_nat r 1 1;
-  test 4 eq (is_zero_nat r 0 1, true))
-;;
-
-testing_function "string_of_nat";;
-
-let n = make_nat 4;;
-
-test 1 eq_string (string_of_nat n, "0");;
-
-complement_nat n 0 (if sixtyfour then 2 else 4);;
-
-test 2 eq_string (string_of_nat n, "340282366920938463463374607431768211455");;
-
-testing_function "string_of_nat && nat_of_string";;
-
-for i = 1 to 20 do
-  let s = String.init i (function 0 -> '1' | _ -> '0') in
-  ignore (test i eq_string (string_of_nat (nat_of_string s), s))
-done;;
-
-let set_mult_digit_nat n1 d1 l1 n2 d2 l2 n3 d3 =
-  ignore (mult_digit_nat n1 d1 l1 n2 d2 l2 n3 d3)
-;;
-
-let s =
-  "33333333333333333333333333333333333333333333333333333333333333333333\
-   33333333333333333333333333333333333333333333333333333333333333333333"
-in
-test 21 equal_nat (
-nat_of_string s,
-(let nat = make_nat 15 in
-  set_digit_nat nat 0 3;
-  set_mult_digit_nat nat 0 15
-                 (nat_of_string (String.sub s 0 135)) 0 14
-                 (nat_of_int 10) 0;
-  nat))
-;;
-
-test 22 eq_string (string_of_nat(nat_of_string "1073741824"), "1073741824");;
-
-testing_function "gcd_nat";;
-
-for i = 1 to 20 do
-  let n1 = Random.int 1000000000
-  and n2 = Random.int 100000 in
-  let nat1 = nat_of_int n1
-  and nat2 = nat_of_int n2 in
-  ignore (gcd_nat nat1 0 1 nat2 0 1);
-  ignore (test i eq (int_of_nat nat1, gcd_int n1 n2))
-done
-;;
-
-testing_function "sqrt_nat";;
-
-test 1 equal_nat (sqrt_nat (nat_of_int 1) 0 1, nat_of_int 1);;
-test 2 equal_nat (let n = nat_of_string "8589934592" in
-                  sqrt_nat n 0 (length_nat n),
-                  nat_of_string "92681");;
-test 3 equal_nat (let n = nat_of_string "4294967295" in
-                  sqrt_nat n 0 (length_nat n),
-                  nat_of_string "65535");;
-test 4 equal_nat (let n = nat_of_string "18446744065119617025" in
-                  sqrt_nat n 0 (length_nat n),
-                  nat_of_string "4294967295");;
-test 5 equal_nat (sqrt_nat (nat_of_int 15) 0 1,
-                  nat_of_int 3);;

diff --git a/testsuite/tests/lib-num/test_nums.ml b/testsuite/tests/lib-num/test_nums.ml
deleted file mode 100644 (file)
index e6cd5c9..0000000
--- a/testsuite/tests/lib-num/test_nums.ml
+++ /dev/null
@@ -1,234 +0,0 @@
-open Test;;
-open Nat;;
-open Big_int;;
-open Ratio;;
-open Num;;
-open Arith_status;;
-
-testing_function "add_num";;
-
-test 1
-eq_num (add_num (Int 1) (Int 3), Int 4);;
-test 2
-eq_num (add_num (Int 1) (Big_int (big_int_of_int 3)), Int 4);;
-test 3
-eq_num (add_num (Int 1) (Ratio (ratio_of_string "3/4")),
-        Ratio (ratio_of_string "7/4"));;
-test 4
-eq_num (add_num (Big_int (big_int_of_int 1)) (Ratio (ratio_of_string "3/4")),
-        Ratio (ratio_of_string "7/4"));;
-test 5
-eq_num (add_num (Big_int (big_int_of_int 1)) (Big_int (big_int_of_int 3)),
-        Int 4);;
-test 6
-eq_num (add_num (Big_int (big_int_of_int 1)) (Ratio (ratio_of_string "3/4")),
-        Ratio (ratio_of_string "7/4"));;
-test 7
-eq_num (add_num (Ratio (ratio_of_string "2/3")) (Ratio (ratio_of_string "3/4")),
-        Ratio (ratio_of_string "17/12"));;
-test 8
-eq_num (add_num (Int least_int) (Int 1),
-        Int (- (pred biggest_int)));;
-test 9
-eq_num (add_num (Int biggest_int) (Int 1),
-        Big_int (minus_big_int (pred_big_int (big_int_of_int least_int))));;
-
-testing_function "sub_num";;
-
-test 1
-eq_num (sub_num (Int 1) (Int 3), Int (-2));;
-test 2
-eq_num (sub_num (Int 1) (Big_int (big_int_of_int 3)), Int (-2));;
-test 3
-eq_num (sub_num (Int 1) (Ratio (ratio_of_string "3/4")),
-        Ratio (ratio_of_string "1/4"));;
-test 4
-eq_num (sub_num (Big_int (big_int_of_int 1)) (Ratio (ratio_of_string "3/4")),
-        Ratio (ratio_of_string "1/4"));;
-test 5
-eq_num (sub_num (Big_int (big_int_of_int 1)) (Big_int (big_int_of_int 3)),
-        Int (-2));;
-test 7
-eq_num (sub_num (Big_int (big_int_of_int 1)) (Ratio (ratio_of_string "3/4")),
-        Ratio (ratio_of_string "1/4"));;
-test 8
-eq_num (sub_num (Ratio (ratio_of_string "2/3")) (Ratio (ratio_of_string "3/4")),
-        Ratio (ratio_of_string "-1/12"));;
-test 9
-eq_num (sub_num (Int least_int) (Int (-1)),
-        Int (- (pred biggest_int)));;
-test 10
-eq_num (sub_num (Int (-1)) (Int biggest_int), pred_num (Int least_int));;
-
-testing_function "mult_num";;
-
-test 1
-eq_num (mult_num (Int 2) (Int 3), Int 6);;
-test 2
-eq_num (mult_num (Int 127) (Int (int_of_string "257")),
-                  Int (int_of_string "32639"));;
-test 3
-eq_num (mult_num (Int 257) (Int (int_of_string "260")),
-        Big_int (big_int_of_string "66820"));;
-test 4
-eq_num (mult_num (Int 2) (Big_int (big_int_of_int 3)), Int 6);;
-test 5
-eq_num (mult_num (Int 10) (Ratio (ratio_of_string "3/4")),
-        Ratio (ratio_of_string "15/2"));;
-test 6
-eq_num (mult_num (Big_int (big_int_of_int 10)) (Ratio (ratio_of_string "3/4")),
-        Ratio (ratio_of_string "15/2"));;
-test 7
-eq_num (mult_num (Big_int (big_int_of_int 2)) (Big_int (big_int_of_int 3)),
-        Int 6);;
-test 8
-eq_num (mult_num (Big_int (big_int_of_int 10)) (Ratio (ratio_of_string "3/4")),
-        Ratio (ratio_of_string "15/2"));;
-test 9
-eq_num (mult_num (Ratio (ratio_of_string "2/3")) (Ratio (ratio_of_string "3/4"))
-               , Ratio (ratio_of_string "1/2"));;
-
-testing_function "div_num";;
-
-test 1
-eq_num (div_num (Int 6) (Int 3), Int 2);;
-test 2
-eq_num (div_num (Int (int_of_string "32639"))
-                 (Int (int_of_string "257")), Int 127);;
-test 3
-eq_num (div_num (Big_int (big_int_of_string "66820"))
-                 (Int (int_of_string "257")),
-        Int 260);;
-test 4
-eq_num (div_num (Int 6) (Big_int (big_int_of_int 3)), Int 2);;
-test 5
-eq_num (div_num (Ratio (ratio_of_string "15/2"))
-                 (Int 10),
-        Ratio (ratio_of_string "3/4"));;
-test 6
-eq_num (div_num (Big_int (big_int_of_int 6)) (Big_int (big_int_of_int 3)),
-        Int 2);;
-test 7
-eq_num (div_num (Ratio (ratio_of_string "15/2"))
-                 (Big_int (big_int_of_int 10)),
-        Ratio (ratio_of_string "3/4"));;
-test 8
-eq_num (div_num (Ratio (ratio_of_string "15/2"))
-                 (Ratio (ratio_of_string "3/4")),
-        Big_int (big_int_of_int 10));;
-test 9
-eq_num (div_num (Ratio (ratio_of_string "1/2"))
-                 (Ratio (ratio_of_string "3/4")),
-        Ratio (ratio_of_string "2/3"));;
-
-testing_function "is_integer_num";;
-
-test 1
-eq (is_integer_num (Int 3),true);;
-test 2
-eq (is_integer_num (Big_int (big_int_of_string "1234567890")),true);;
-test 3
-eq (not (is_integer_num (Ratio (ratio_of_string "1/2"))),true);;
-test 4
-eq (is_integer_num (Ratio (ratio_of_string "1073774590/32770")),true);;
-
-testing_function "num_of_ratio";;
-
-test 1
-eq_num (num_of_ratio (ratio_of_string "4/2"), Int 2);;
-test 2
-eq_num (num_of_ratio (ratio_of_string "11811160075/11"),
-        Big_int (big_int_of_string "1073741825"));;
-test 3
-eq_num (num_of_ratio (ratio_of_string "123456789012/1234"),
-        Ratio (ratio_of_string "61728394506/617"));;
-
-testing_function "num_of_string";;
-
-test 1
-eq_num (num_of_string "123/3456", Ratio (ratio_of_string "123/3456"));;
-(*********
-test 2
-eq_num (num_of_string "12.3/34.56", Ratio (ratio_of_string "1230/3456"));;
-test 3
-eq_num (num_of_string "1.23/325.6", Ratio (ratio_of_string "123/32560"));;
-test 4
-eq_num (num_of_string "12.3/345.6", Ratio (ratio_of_string "123/3456"));;
-set_error_when_null_denominator false;;
-test 5
-eq_num (num_of_string "12.3/0.0", Ratio (ratio_of_string "123/0"));;
-test 6
-eq_num (num_of_string "0/0", Ratio (ratio_of_string "0/0"));;
-set_error_when_null_denominator true;;
-*********)
-test 7
-eq_num (num_of_string "1234567890",
-        Big_int (big_int_of_string "1234567890"));;
-test 8
-eq_num (num_of_string "12345", Int (int_of_string "12345"));;
-(*********
-test 9
-eq_num (num_of_string "0.23", Ratio (ratio_of_string "23/100"));;
-test 10
-eq_num (num_of_string "0.23", Ratio (ratio_of_string "0.23/1"));;
-********)
-
-failwith_test 11
-num_of_string ("frlshjkurty") (Failure "num_of_string");;
-
-test 12
-eq_num (num_of_string "0xAbCdEf",
-        Big_int (big_int_of_int 0xabcdef));;
-
-test 13
-eq_num (num_of_string "0b1101/0O1765",
-        Ratio (ratio_of_string "0b1101/0o1765"));;
-
-test 14
-eq_num (num_of_string "-12_34_56",
-        Big_int (big_int_of_int (-123456)));;
-
-test 15
-eq_num (num_of_string "0B101010", Big_int (big_int_of_int 42));;
-
-(*******
-
-testing_function "immediate numbers";;
-
-standard arith false;;
-
-let x = (1/2) in
-test 0 eq_string (string_of_num x, "1/2");;
-
-let y = 12345678901 in
-test 1 eq_string (string_of_num y, "12345678901");;
-testing_function "immediate numbers";;
-
-let x = (1/2) in
-test 0 eq_string (string_of_num x, "1/2");;
-
-let y = 12345678901 in
-test 1 eq_string (string_of_num y, "12345678901");;
-
-testing_function "pattern_matching on nums";;
-
-let f1 = function 0 -> true | _  -> false;;
-
-test 1 eq (f1 0, true);;
-
-test 2 eq (f1 1, false);;
-
-test 3 eq (f1 (0/1), true);;
-
-test 4 eq (f1 (let n = num_of_string "2000000000000000000000000" in n-n) ,
-            true);;
-
-test 5 eq (f1 (let n = num_of_string "2000000000000000000000000" in n/n-1) ,
-            true);;
-
-test 6 eq (f1 (let n = num_of_string "2000000000000000000000000" in n+1) ,
-            false);;
-
-test 7 eq (f1 (1/2), false);;
-
-**************)

diff --git a/testsuite/tests/lib-num/test_ratios.ml b/testsuite/tests/lib-num/test_ratios.ml
deleted file mode 100644 (file)
index a5d8fe5..0000000
--- a/testsuite/tests/lib-num/test_ratios.ml
+++ /dev/null
@@ -1,1195 +0,0 @@
-open Test;;
-open Nat;;
-open Big_int;;
-open Ratio;;
-open Arith_status;;
-
-set_error_when_null_denominator false
-;;
-
-let infinite_failure = "infinite or undefined rational number";;
-
-testing_function "create_ratio"
-;;
-
-let r = create_ratio (big_int_of_int 1) (big_int_of_int (-2)) in
-test 1 eq_big_int (numerator_ratio r, big_int_of_int (-1)) &&
-test 2 eq_big_int (denominator_ratio r, big_int_of_int 2)
-;;
-
-let r = create_ratio (big_int_of_int 2) (big_int_of_int 3) in
-test 3 eq_big_int (numerator_ratio r, big_int_of_int 2) &&
-test 4 eq_big_int (denominator_ratio r, big_int_of_int 3)
-;;
-
-set_normalize_ratio true
-;;
-
-let r = create_ratio (big_int_of_int 12) (big_int_of_int (-16)) in
-test 5 eq_big_int (numerator_ratio r, big_int_of_int (-3)) &&
-test 6 eq_big_int (denominator_ratio r, big_int_of_int 4)
-;;
-
-set_normalize_ratio false
-;;
-
-let r = create_ratio (big_int_of_int 0) (big_int_of_int 0) in
-test 7 eq_big_int (numerator_ratio r, big_int_of_int 0) &&
-test 8 eq_big_int (denominator_ratio r, big_int_of_int 0)
-;;
-
-testing_function "create_normalized_ratio"
-;;
-
-let r = create_normalized_ratio (big_int_of_int 1) (big_int_of_int (-2)) in
-test 1 eq_big_int (numerator_ratio r, big_int_of_int (-1)) &&
-test 2 eq_big_int (denominator_ratio r, big_int_of_int 2)
-;;
-
-let r = create_normalized_ratio (big_int_of_int 2) (big_int_of_int 3) in
-test 3 eq_big_int (numerator_ratio r, big_int_of_int 2) &&
-test 4 eq_big_int (denominator_ratio r, big_int_of_int 3)
-;;
-
-set_normalize_ratio true
-;;
-
-let r = create_normalized_ratio (big_int_of_int 12) (big_int_of_int (-16)) in
-test 5 eq_big_int (numerator_ratio r, big_int_of_int (-12)) &&
-test 6 eq_big_int (denominator_ratio r, big_int_of_int 16)
-;;
-
-set_normalize_ratio false
-;;
-
-let r = create_normalized_ratio (big_int_of_int 1) (big_int_of_int 0) in
-test 7 eq_big_int (numerator_ratio r, big_int_of_int 1) &&
-test 8 eq_big_int (denominator_ratio r, big_int_of_int 0)
-;;
-
-let r = create_normalized_ratio (big_int_of_int 0) (big_int_of_int 0) in
-test 9 eq_big_int (numerator_ratio r, big_int_of_int 0) &&
-test 10 eq_big_int (denominator_ratio r, big_int_of_int 0)
-;;
-
-testing_function "null_denominator"
-;;
-
-test 1
- eq (null_denominator (create_ratio (big_int_of_int 1) (big_int_of_int (-2))),
-     false)
-;;
-test 2 eq
- (null_denominator (create_ratio (big_int_of_int 1) zero_big_int),true)
-;;
-
-(*****
-testing_function "verify_null_denominator"
-;;
-
-test 1
- eq (verify_null_denominator (ratio_of_string "0/1"), false)
-;;
-test 2
- eq (verify_null_denominator (ratio_of_string "0/0"), true)
-;;
-*****)
-
-testing_function "sign_ratio"
-;;
-
-test 1
-eq_int (sign_ratio (create_ratio (big_int_of_int (-2)) (big_int_of_int (-3))),
-        1)
-;;
-test 2
-eq_int (sign_ratio (create_ratio (big_int_of_int 2) (big_int_of_int (-3))),
-        (-1))
-;;
-test 3
-eq_int (sign_ratio (create_ratio zero_big_int (big_int_of_int (-3))), 0)
-;;
-
-testing_function "normalize_ratio"
-;;
-
-let r = create_ratio (big_int_of_int 12) (big_int_of_int (-16)) in
-ignore (normalize_ratio r);
-test 1 eq_big_int (numerator_ratio r, big_int_of_int (-3)) &&
-test 2 eq_big_int (denominator_ratio r, big_int_of_int 4)
-;;
-
-let r = create_ratio (big_int_of_int (-1)) zero_big_int in
-ignore (normalize_ratio r);
-test 3 eq_big_int (numerator_ratio r, big_int_of_int (-1)) &&
-test 4 eq_big_int (denominator_ratio r, zero_big_int)
-;;
-
-testing_function "report_sign_ratio"
-;;
-
-test 1
-eq_big_int (report_sign_ratio
-            (create_ratio (big_int_of_int 2) (big_int_of_int (-3)))
-            (big_int_of_int 1),
-            big_int_of_int (-1))
-;;
-test 2
-eq_big_int (report_sign_ratio
-            (create_ratio (big_int_of_int 2) (big_int_of_int 3))
-             (big_int_of_int 1),
-            big_int_of_int 1)
-;;
-
-testing_function "is_integer_ratio"
-;;
-
-test 1 eq
- (is_integer_ratio (create_ratio (big_int_of_int 2) (big_int_of_int (-1))),
-  true)
-;;
-test 2 eq
- (is_integer_ratio (create_ratio (big_int_of_int 2) (big_int_of_int 3)),
-  false)
-;;
-
-testing_function "add_ratio"
-;;
-
-let r = add_ratio (create_ratio (big_int_of_int 1) (big_int_of_int 2))
-                   (create_ratio (big_int_of_int 2) (big_int_of_int 3)) in
-test 1 eq_big_int (numerator_ratio r, big_int_of_int 7) &&
-test 2 eq_big_int (denominator_ratio r, big_int_of_int 6)
-;;
-
-let r = add_ratio (create_ratio (big_int_of_int 2) (big_int_of_int 3))
-                   (create_ratio (big_int_of_int 1) (big_int_of_int (-2))) in
-test 3 eq_big_int (numerator_ratio r, big_int_of_int 1) &&
-test 4 eq_big_int (denominator_ratio r, big_int_of_int 6)
-;;
-
-let r = add_ratio (create_ratio (big_int_of_int 2) zero_big_int)
-                   (create_ratio (big_int_of_int 1) (big_int_of_int (-2))) in
-test 5 eq_big_int (numerator_ratio r, big_int_of_int 4) &&
-test 6 eq_big_int (denominator_ratio r, zero_big_int)
-;;
-
-let r = add_ratio (create_ratio (big_int_of_int 2) (big_int_of_int 3))
-                   (create_ratio (big_int_of_int 1) zero_big_int) in
-test 7 eq_big_int (numerator_ratio r, big_int_of_int 3) &&
-test 8 eq_big_int (denominator_ratio r, zero_big_int)
-;;
-
-let r = add_ratio (create_ratio (big_int_of_int 2) zero_big_int)
-                   (create_ratio (big_int_of_int 1) zero_big_int) in
-test 9 eq_big_int (numerator_ratio r, zero_big_int) &&
-test 10 eq_big_int (denominator_ratio r, zero_big_int)
-;;
-
-let r = add_ratio (create_ratio (big_int_of_string "12724951")
-                                 (big_int_of_string "26542080"))
-                   (create_ratio (big_int_of_string "-1")
-                                 (big_int_of_string "81749606400")) in
-test 11 eq_big_int (numerator_ratio r,
-                     big_int_of_string "1040259735682744320") &&
-test 12 eq_big_int (denominator_ratio r,
-                     big_int_of_string "2169804593037312000")
-;;
-
-let r1,r2 =
- (create_ratio (big_int_of_string "12724951")
-                                 (big_int_of_string "26542080"),
-                   create_ratio (big_int_of_string "-1")
-                                 (big_int_of_string "81749606400")) in
-
-let bi1 = mult_big_int (numerator_ratio r1) (denominator_ratio r2)
-and  bi2 = mult_big_int (numerator_ratio r2) (denominator_ratio r1)
-in
-test 1
-eq_big_int (bi1,
-            big_int_of_string "1040259735709286400")
-&&
-test 2
-eq_big_int (bi2,
-            big_int_of_string "-26542080")
-&& test 3
-eq_big_int (mult_big_int (denominator_ratio r1) (denominator_ratio r2),
-            big_int_of_string "2169804593037312000")
-&& test 4
-eq_big_int (add_big_int bi1 bi2,
-            big_int_of_string "1040259735682744320")
-;;
-
-testing_function "sub_ratio"
-;;
-
-let r = sub_ratio (create_ratio (big_int_of_int 2) (big_int_of_int 3))
-                   (create_ratio (big_int_of_int 1) (big_int_of_int 2)) in
-test 1  eq_big_int (numerator_ratio r, big_int_of_int 1) &&
-test 2 eq_big_int (denominator_ratio r, big_int_of_int 6)
-;;
-
-let r = sub_ratio (create_ratio (big_int_of_int 2) zero_big_int)
-                   (create_ratio (big_int_of_int 1) (big_int_of_int (-2))) in
-test 3 eq_big_int (numerator_ratio r, big_int_of_int 4) &&
-test 4 eq_big_int (denominator_ratio r, zero_big_int)
-;;
-
-let r = sub_ratio (create_ratio (big_int_of_int 2) (big_int_of_int 3))
-                   (create_ratio (big_int_of_int 1) zero_big_int) in
-test 5 eq_big_int (numerator_ratio r, big_int_of_int (-3)) &&
-test 6 eq_big_int (denominator_ratio r, zero_big_int)
-;;
-
-let r = sub_ratio (create_ratio (big_int_of_int 2) zero_big_int)
-                   (create_ratio (big_int_of_int 1) zero_big_int) in
-test 7 eq_big_int (numerator_ratio r, zero_big_int) &&
-test 8 eq_big_int (denominator_ratio r, zero_big_int)
-;;
-
-testing_function "mult_ratio"
-;;
-
-let r = mult_ratio (create_ratio (big_int_of_int 2) (big_int_of_int 3))
-                    (create_ratio (big_int_of_int 7) (big_int_of_int 5)) in
-test 1 eq_big_int (numerator_ratio r, big_int_of_int 14) &&
-test 2 eq_big_int (denominator_ratio r, big_int_of_int 15)
-;;
-
-let r = mult_ratio (create_ratio (big_int_of_int 2) zero_big_int)
-                    (create_ratio (big_int_of_int 1) (big_int_of_int (-2))) in
-test 3 eq_big_int (numerator_ratio r, big_int_of_int (-2)) &&
-test 4 eq_big_int (denominator_ratio r, zero_big_int)
-;;
-
-let r = mult_ratio (create_ratio (big_int_of_int 2) (big_int_of_int 3))
-                   (create_ratio (big_int_of_int 1) zero_big_int) in
-test 5 eq_big_int (numerator_ratio r, big_int_of_int 2) &&
-test 6 eq_big_int (denominator_ratio r, zero_big_int)
-;;
-
-let r = mult_ratio (create_ratio (big_int_of_int 2) zero_big_int)
-                   (create_ratio (big_int_of_int 1) zero_big_int) in
-test 7 eq_big_int (numerator_ratio r, big_int_of_int 2) &&
-test 8 eq_big_int (denominator_ratio r, zero_big_int)
-;;
-
-testing_function "div_ratio"
-;;
-
-let r = div_ratio (create_ratio (big_int_of_int 2) (big_int_of_int 3))
-                   (create_ratio (big_int_of_int 5) (big_int_of_int 7)) in
-test 1 eq_big_int (numerator_ratio r, big_int_of_int 14) &&
-test 2 eq_big_int (denominator_ratio r, big_int_of_int 15)
-;;
-
-let r = div_ratio (create_ratio (big_int_of_int 2) zero_big_int)
-                   (create_ratio (big_int_of_int 1) (big_int_of_int (-2))) in
-test 3 eq_big_int (numerator_ratio r, big_int_of_int (-4)) &&
-test 4 eq_big_int (denominator_ratio r, zero_big_int)
-;;
-
-let r = div_ratio (create_ratio (big_int_of_int 2) (big_int_of_int 3))
-                   (create_ratio (big_int_of_int 1) zero_big_int) in
-test 5 eq_big_int (numerator_ratio r, zero_big_int) &&
-test 6 eq_big_int (denominator_ratio r, big_int_of_int 3)
-;;
-
-let r = div_ratio (create_ratio (big_int_of_int 2) zero_big_int)
-                   (create_ratio (big_int_of_int 1) zero_big_int) in
-test 7 eq_big_int (numerator_ratio r, zero_big_int) &&
-test 8 eq_big_int (denominator_ratio r, zero_big_int)
-;;
-
-testing_function "integer_ratio"
-;;
-
-test 1
-eq_big_int (integer_ratio
-            (create_ratio (big_int_of_int 5) (big_int_of_int 3)),
-            big_int_of_int 1)
-;;
-test 2
-eq_big_int (integer_ratio
-            (create_ratio (big_int_of_int 5) (big_int_of_int (-3))),
-            big_int_of_int (-1))
-;;
-test 3
-eq_big_int (integer_ratio
-            (create_ratio (big_int_of_int 3) (big_int_of_int 2)),
-            big_int_of_int 1)
-;;
-test 4
-eq_big_int (integer_ratio
-            (create_ratio (big_int_of_int 3) (big_int_of_int (-2))),
-            big_int_of_int (-1))
-;;
-
-failwith_test 5
-integer_ratio (create_ratio (big_int_of_int 3) zero_big_int)
-(Failure("integer_ratio "^infinite_failure))
-;;
-
-testing_function "floor_ratio"
-;;
-
-test 1
-eq_big_int (floor_ratio
-            (create_ratio (big_int_of_int 5) (big_int_of_int 3)),
-            big_int_of_int 1)
-;;
-test 2
-eq_big_int (floor_ratio
-            (create_ratio (big_int_of_int 5) (big_int_of_int (-3))),
-            big_int_of_int (-2))
-;;
-test 3
-eq_big_int (floor_ratio
-            (create_ratio (big_int_of_int 3) (big_int_of_int 2)),
-            big_int_of_int 1)
-;;
-test 4
-eq_big_int (floor_ratio
-            (create_ratio (big_int_of_int 3) (big_int_of_int (-2))),
-            big_int_of_int (-2))
-;;
-
-failwith_test 5 floor_ratio (create_ratio (big_int_of_int 3) zero_big_int)
-Division_by_zero
-;;
-
-
-testing_function "round_ratio"
-;;
-
-test 1
-eq_big_int (round_ratio
-            (create_ratio (big_int_of_int 5) (big_int_of_int 3)),
-            big_int_of_int 2)
-;;
-test 2
-eq_big_int (round_ratio
-            (create_ratio (big_int_of_int 5) (big_int_of_int (-3))),
-            big_int_of_int (-2))
-;;
-test 3
-eq_big_int (round_ratio
-            (create_ratio (big_int_of_int 3) (big_int_of_int 2)),
-            big_int_of_int 2)
-;;
-test 4
-eq_big_int (round_ratio
-            (create_ratio (big_int_of_int 3) (big_int_of_int (-2))),
-            big_int_of_int (-2))
-;;
-
-failwith_test 5
-round_ratio (create_ratio (big_int_of_int 3) zero_big_int)
-Division_by_zero
-;;
-
-
-testing_function "ceiling_ratio"
-;;
-
-test 1
-eq_big_int (ceiling_ratio
-            (create_ratio (big_int_of_int 5) (big_int_of_int 3)),
-            big_int_of_int 2)
-;;
-test 2
-eq_big_int (ceiling_ratio
-            (create_ratio (big_int_of_int 5) (big_int_of_int (-3))),
-            big_int_of_int (-1))
-;;
-test 3
-eq_big_int (ceiling_ratio
-            (create_ratio (big_int_of_int 3) (big_int_of_int 2)),
-            big_int_of_int 2)
-;;
-test 4
-eq_big_int (ceiling_ratio
-            (create_ratio (big_int_of_int 3) (big_int_of_int (-2))),
-            big_int_of_int (-1))
-;;
-test 5
-eq_big_int (ceiling_ratio
-            (create_ratio (big_int_of_int 4) (big_int_of_int 2)),
-            big_int_of_int 2)
-;;
-failwith_test 6
-ceiling_ratio (create_ratio (big_int_of_int 3) zero_big_int)
-Division_by_zero
-;;
-
-testing_function "eq_ratio"
-;;
-
-test 1
-eq_ratio (create_ratio (big_int_of_int 5) (big_int_of_int 3),
-          create_ratio (big_int_of_int (-20)) (big_int_of_int (-12)))
-;;
-test 2
-eq_ratio (create_ratio (big_int_of_int 1) zero_big_int,
-          create_ratio (big_int_of_int 2) zero_big_int)
-;;
-
-let neq_ratio x y = not (eq_ratio x y);;
-
-test 3
-neq_ratio (create_ratio (big_int_of_int 1) zero_big_int,
-           create_ratio (big_int_of_int (-1)) zero_big_int)
-;;
-test 4
-neq_ratio (create_ratio (big_int_of_int 1) zero_big_int,
-           create_ratio zero_big_int zero_big_int)
-;;
-test 5
-eq_ratio (create_ratio zero_big_int zero_big_int,
-          create_ratio zero_big_int zero_big_int)
-;;
-
-testing_function "compare_ratio"
-;;
-
-test 1
-eq_int (compare_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 0))
-                       (create_ratio (big_int_of_int 0) (big_int_of_int 0)),
-        0)
-;;
-test 2
-eq_int (compare_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 0))
-                       (create_ratio (big_int_of_int 1) (big_int_of_int 0)),
-        0)
-;;
-test 3
-eq_int (compare_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 0))
-                       (create_ratio (big_int_of_int (-1)) (big_int_of_int 0)),
-        0)
-;;
-test 4
-eq_int (compare_ratio (create_ratio (big_int_of_int 1) (big_int_of_int 0))
-                       (create_ratio (big_int_of_int 0) (big_int_of_int 0)),
-        0)
-;;
-test 5
-eq_int (compare_ratio (create_ratio (big_int_of_int (-1)) (big_int_of_int 0))
-                       (create_ratio (big_int_of_int 0) (big_int_of_int 0)),
-        0)
-;;
-test 6
-eq_int (compare_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 0))
-                       (create_ratio (big_int_of_int 5) (big_int_of_int 3)),
-        0)
-;;
-test 7
-eq_int (compare_ratio (create_ratio (big_int_of_int 5) (big_int_of_int 3))
-                       (create_ratio (big_int_of_int 0) (big_int_of_int 0)),
-        0)
-;;
-test 8
-eq_int (compare_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 0))
-                       (create_ratio (big_int_of_int (-5)) (big_int_of_int 3)),
-        0)
-;;
-test 9
-eq_int (compare_ratio (create_ratio (big_int_of_int (-5)) (big_int_of_int 3))
-                       (create_ratio (big_int_of_int 0) (big_int_of_int 0)),
-        0)
-;;
-test 10
-eq_int (compare_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 0))
-                       (create_ratio (big_int_of_int 0) (big_int_of_int 1)),
-        0)
-;;
-test 11
-eq_int (compare_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 1))
-                       (create_ratio (big_int_of_int 0) (big_int_of_int 0)),
-        0)
-;;
-test 12
-eq_int (compare_ratio (create_ratio (big_int_of_int 1) (big_int_of_int 0))
-                       (create_ratio (big_int_of_int 1) (big_int_of_int 0)),
-        0)
-;;
-test 13
-eq_int (compare_ratio (create_ratio (big_int_of_int 1) (big_int_of_int 0))
-                       (create_ratio (big_int_of_int 2) (big_int_of_int 0)),
-        0)
-;;
-test 14
-eq_int (compare_ratio (create_ratio (big_int_of_int 1) (big_int_of_int 0))
-                       (create_ratio (big_int_of_int (-1)) (big_int_of_int 0)),
-        1)
-;;
-test 15
-eq_int (compare_ratio (create_ratio (big_int_of_int (-1)) (big_int_of_int 0))
-                       (create_ratio (big_int_of_int 1) (big_int_of_int 0)),
-        (-1))
-;;
-test 16
-eq_int (compare_ratio (create_ratio (big_int_of_int 5) (big_int_of_int 3))
-                       (create_ratio (big_int_of_int 1) (big_int_of_int 0)),
-        (-1))
-;;
-test 17
-eq_int (compare_ratio (create_ratio (big_int_of_int 1) (big_int_of_int 0))
-                       (create_ratio (big_int_of_int 5) (big_int_of_int 3)),
-        1)
-;;
-test 18
-eq_int (compare_ratio (create_ratio (big_int_of_int (-5)) (big_int_of_int 3))
-                       (create_ratio (big_int_of_int 1) (big_int_of_int 0)),
-        (-1))
-;;
-test 19
-eq_int (compare_ratio (create_ratio (big_int_of_int 1) (big_int_of_int 0))
-                       (create_ratio (big_int_of_int (-5)) (big_int_of_int 3)),
-        1)
-;;
-test 20
-eq_int (compare_ratio (create_ratio (big_int_of_int 1) (big_int_of_int 0))
-                       (create_ratio (big_int_of_int 0) (big_int_of_int 3)),
-        1)
-;;
-test 21
-eq_int (compare_ratio (create_ratio (big_int_of_int (-1)) (big_int_of_int 0))
-                       (create_ratio (big_int_of_int (-1)) (big_int_of_int 0)),
-        0)
-;;
-test 22
-eq_int (compare_ratio (create_ratio (big_int_of_int (-1)) (big_int_of_int 0))
-                       (create_ratio (big_int_of_int (-2)) (big_int_of_int 0)),
-        0)
-;;
-test 23
-eq_int (compare_ratio (create_ratio (big_int_of_int 5) (big_int_of_int 3))
-                       (create_ratio (big_int_of_int (-1)) (big_int_of_int 0)),
-        1)
-;;
-test 24
-eq_int (compare_ratio (create_ratio (big_int_of_int (-1)) (big_int_of_int 0))
-                       (create_ratio (big_int_of_int 5) (big_int_of_int 3)),
-        (-1))
-;;
-test 25
-eq_int (compare_ratio (create_ratio (big_int_of_int (-5)) (big_int_of_int 3))
-                       (create_ratio (big_int_of_int (-1)) (big_int_of_int 0)),
-        1)
-;;
-test 26
-eq_int (compare_ratio (create_ratio (big_int_of_int (-1)) (big_int_of_int 0))
-                       (create_ratio (big_int_of_int (-5)) (big_int_of_int 3)),
-        (-1))
-;;
-test 27
-eq_int (compare_ratio (create_ratio (big_int_of_int (-1)) (big_int_of_int 0))
-                       (create_ratio (big_int_of_int 0) (big_int_of_int 3)),
-        (-1))
-;;
-test 28
-eq_int (compare_ratio (create_ratio (big_int_of_int 5) (big_int_of_int 3))
-                       (create_ratio (big_int_of_int 3) (big_int_of_int 2)),
-        1)
-;;
-test 29
-eq_int (compare_ratio (create_ratio (big_int_of_int 3) (big_int_of_int 2))
-                       (create_ratio (big_int_of_int 5) (big_int_of_int 3)),
-        (-1))
-;;
-test 30
-eq_int (compare_ratio (create_ratio (big_int_of_int 5) (big_int_of_int 3))
-                       (create_ratio (big_int_of_int (-3)) (big_int_of_int 2)),
-        1)
-;;
-test 31
-eq_int (compare_ratio (create_ratio (big_int_of_int (-3)) (big_int_of_int 2))
-                       (create_ratio (big_int_of_int 5) (big_int_of_int 3)),
-        (-1))
-;;
-test 32
-eq_int (compare_ratio (create_ratio (big_int_of_int 3) (big_int_of_int 2))
-                       (create_ratio (big_int_of_int 0) (big_int_of_int 3)),
-        1)
-;;
-test 33
-eq_int (compare_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 2))
-                       (create_ratio (big_int_of_int 5) (big_int_of_int 3)),
-        (-1))
-;;
-test 34
-eq_int (compare_ratio (create_ratio (big_int_of_int (-3)) (big_int_of_int 2))
-                       (create_ratio (big_int_of_int 0) (big_int_of_int 3)),
-        (-1))
-;;
-test 35
-eq_int (compare_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 2))
-                       (create_ratio (big_int_of_int (-5)) (big_int_of_int 3)),
-        1)
-;;
-test 36
-eq_int (compare_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 2))
-                       (create_ratio (big_int_of_int 0) (big_int_of_int 3)),
-        0)
-;;
-
-testing_function "eq_big_int_ratio"
-;;
-
-test 1
-eq_big_int_ratio (big_int_of_int 3,
-                  (create_ratio (big_int_of_int 3) (big_int_of_int 1)))
-;;
-test 2
-eq
-(not (eq_big_int_ratio (big_int_of_int 1)
-                       (create_ratio (big_int_of_int 3) (big_int_of_int 1))),
-true)
-;;
-
-test 3
-eq
-(not (eq_big_int_ratio (big_int_of_int 1)
-                       (create_ratio (big_int_of_int 3) (big_int_of_int 2))),
- true)
-;;
-
-test 4
-eq
-(not (eq_big_int_ratio (big_int_of_int 1)
-                       (create_ratio (big_int_of_int 3) (big_int_of_int 0))),
- true)
-;;
-
-test 5
-eq
-(not (eq_big_int_ratio (big_int_of_int 1)
-                       (create_ratio (big_int_of_int (-3)) (big_int_of_int 2))),
- true)
-;;
-
-testing_function "compare_big_int_ratio"
-;;
-
-test 1
-eq_int (compare_big_int_ratio
-           (big_int_of_int 1)
-            (create_ratio (big_int_of_int 3) (big_int_of_int 0)), (-1))
-;;
-test 2
-eq_int (compare_big_int_ratio
-           (big_int_of_int 1)
-            (create_ratio (big_int_of_int 0) (big_int_of_int 0)), 0)
-;;
-test 3
-eq_int (compare_big_int_ratio
-           (big_int_of_int 1)
-            (create_ratio (big_int_of_int (-3)) (big_int_of_int 0)), 1)
-;;
-test 4
-eq_int (compare_big_int_ratio
-           (big_int_of_int (-1))
-            (create_ratio (big_int_of_int 3) (big_int_of_int 0)), (-1))
-;;
-test 5
-eq_int (compare_big_int_ratio
-           (big_int_of_int (-1))
-            (create_ratio (big_int_of_int 0) (big_int_of_int 0)), 0)
-;;
-test 6
-eq_int (compare_big_int_ratio
-           (big_int_of_int (-1))
-            (create_ratio (big_int_of_int (-3)) (big_int_of_int 0)), 1)
-;;
-test 7
-eq_int (compare_big_int_ratio
-           (big_int_of_int 1)
-            (create_ratio (big_int_of_int 1) (big_int_of_int 1)), 0)
-;;
-test 8
-eq_int (compare_big_int_ratio
-           (big_int_of_int 1)
-            (create_ratio (big_int_of_int 3) (big_int_of_int 2)), (-1))
-;;
-test 9
-eq_int (compare_big_int_ratio
-           (big_int_of_int 1)
-            (create_ratio (big_int_of_int 2) (big_int_of_int 3)), 1)
-;;
-
-
-
-testing_function "int_of_ratio"
-;;
-
-test 1
-eq_int (int_of_ratio (create_ratio (big_int_of_int 4) (big_int_of_int 2)),
-        2)
-;;
-
-test 2
-eq_int (int_of_ratio
-        (create_ratio (big_int_of_int biggest_int) (big_int_of_int 1)),
-        biggest_int)
-;;
-
-failwith_test 3
-int_of_ratio (create_ratio (big_int_of_int 4) (big_int_of_int 0))
-(Failure "integer argument required")
-;;
-
-failwith_test 4
-int_of_ratio (create_ratio (succ_big_int (big_int_of_int biggest_int))
-                             (big_int_of_int 1))
-(Failure "integer argument required")
-;;
-
-failwith_test 5
-int_of_ratio (create_ratio (big_int_of_int 4) (big_int_of_int 3))
-(Failure "integer argument required")
-;;
-
-testing_function "ratio_of_int"
-;;
-
-test 1
-eq_ratio (ratio_of_int 3,
-          create_ratio (big_int_of_int 3) (big_int_of_int 1))
-;;
-
-test 2
-eq_ratio (ratio_of_nat (nat_of_int 2),
-          create_ratio (big_int_of_int 2) (big_int_of_int 1))
-;;
-
-testing_function "nat_of_ratio"
-;;
-
-let nat1 = nat_of_ratio (create_ratio (big_int_of_int 3) (big_int_of_int 1))
-and nat2 = nat_of_int 3 in
-test 1
-eq (eq_nat nat1 0 (length_nat nat1) nat2 0 (length_nat nat2), true)
-;;
-
-failwith_test 2
-nat_of_ratio (create_ratio (big_int_of_int 3) (big_int_of_int 0))
-(Failure "nat_of_ratio")
-;;
-
-failwith_test 3
-nat_of_ratio (create_ratio (big_int_of_int (-3)) (big_int_of_int 1))
-(Failure "nat_of_ratio")
-;;
-
-failwith_test 4
-nat_of_ratio (create_ratio (big_int_of_int 3) (big_int_of_int 2))
-(Failure "nat_of_ratio")
-;;
-
-testing_function "ratio_of_big_int"
-;;
-
-test 1
-eq_ratio (ratio_of_big_int (big_int_of_int 3),
-          create_ratio (big_int_of_int 3) (big_int_of_int 1))
-;;
-
-testing_function "big_int_of_ratio"
-;;
-
-test 1
-eq_big_int (big_int_of_ratio
-                (create_ratio (big_int_of_int 3) (big_int_of_int 1)),
-            big_int_of_int 3)
-;;
-test 2
-eq_big_int (big_int_of_ratio
-                (create_ratio (big_int_of_int (-3)) (big_int_of_int 1)),
-            big_int_of_int (-3))
-;;
-
-failwith_test 3
-big_int_of_ratio (create_ratio (big_int_of_int 3) (big_int_of_int 0))
-(Failure "big_int_of_ratio")
-;;
-
-testing_function "string_of_ratio"
-;;
-
-test 1
-eq_string (string_of_ratio
-              (create_ratio (big_int_of_int 43) (big_int_of_int 35)),
-           "43/35")
-;;
-test 2
-eq_string (string_of_ratio
-              (create_ratio (big_int_of_int 42) (big_int_of_int 0)),
-           "1/0")
-;;
-
-set_normalize_ratio_when_printing false
-;;
-
-test 3
-eq_string (string_of_ratio
-              (create_ratio (big_int_of_int 42) (big_int_of_int 35)),
-           "42/35")
-;;
-
-set_normalize_ratio_when_printing true
-;;
-
-test 4
-eq_string (string_of_ratio
-              (create_ratio (big_int_of_int 42) (big_int_of_int 35)),
-           "6/5")
-;;
-
-testing_function "ratio_of_string"
-;;
-
-test 1
-eq_ratio (ratio_of_string ("123/3456"),
-          create_ratio (big_int_of_int 123) (big_int_of_int 3456))
-;;
-
-(***********
-test 2
-eq_ratio (ratio_of_string ("12.3/34.56"),
-          create_ratio (big_int_of_int 1230) (big_int_of_int 3456))
-;;
-test 3
-eq_ratio (ratio_of_string ("1.23/325.6"),
-          create_ratio (big_int_of_int 123) (big_int_of_int 32560))
-;;
-test 4
-eq_ratio (ratio_of_string ("12.3/345.6"),
-          create_ratio (big_int_of_int 123) (big_int_of_int 3456))
-;;
-test 5
-eq_ratio (ratio_of_string ("12.3/0.0"),
-          create_ratio (big_int_of_int 123) (big_int_of_int 0))
-;;
-***********)
-test 6
-eq_ratio (ratio_of_string ("0/0"),
-          create_ratio (big_int_of_int 0) (big_int_of_int 0))
-;;
-
-test 7
-eq_ratio (ratio_of_string "1234567890",
-          create_ratio (big_int_of_string "1234567890") unit_big_int)
-;;
-failwith_test 8
-ratio_of_string "frlshjkurty" (Failure "invalid digit");;
-
-(***********
-testing_function "msd_ratio"
-;;
-
-test 1
-eq_int (msd_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 1)),
-        0)
-;;
-test 2
-eq_int (msd_ratio (create_ratio (big_int_of_int 1) (big_int_of_int 12)),
-        (-2))
-;;
-test 3
-eq_int (msd_ratio (create_ratio (big_int_of_int 12) (big_int_of_int 1)),
-        1)
-;;
-test 4
-eq_int (msd_ratio (create_ratio (big_int_of_int 1) (big_int_of_int 2)),
-        (-1))
-;;
-test 5
-eq_int (msd_ratio (create_ratio (big_int_of_int 2) (big_int_of_int 1)),
-        0)
-;;
-test 6
-eq_int (msd_ratio (create_ratio (big_int_of_int 25) (big_int_of_int 21)),
-        0)
-;;
-test 7
-eq_int (msd_ratio (create_ratio (big_int_of_int 35) (big_int_of_int 21)),
-        0)
-;;
-test 8
-eq_int (msd_ratio (create_ratio (big_int_of_int 215) (big_int_of_int 31)),
-        0)
-;;
-test 9
-eq_int (msd_ratio (create_ratio (big_int_of_int 2) (big_int_of_int 30)),
-        (-2))
-;;
-test 10
-eq_int (msd_ratio (create_ratio (big_int_of_int 2345)
-                                     (big_int_of_int 23456)),
-        (-2))
-;;
-test 11
-eq_int (msd_ratio (create_ratio (big_int_of_int 2345)
-                                     (big_int_of_int 2346)),
-        (-1))
-;;
-test 12
-eq_int (msd_ratio (create_ratio (big_int_of_int 2345)
-                                     (big_int_of_int 2344)),
-        0)
-;;
-test 13
-eq_int (msd_ratio (create_ratio (big_int_of_int 23456)
-                                     (big_int_of_int 2345)),
-        1)
-;;
-test 14
-eq_int (msd_ratio (create_ratio (big_int_of_int 23467)
-                                     (big_int_of_int 2345)),
-        1)
-;;
-failwith_test 15
-msd_ratio (create_ratio (big_int_of_int 1) (big_int_of_int 0))
-("msd_ratio "^infinite_failure)
-;;
-failwith_test 16
-msd_ratio (create_ratio (big_int_of_int (-1)) (big_int_of_int 0))
-("msd_ratio "^infinite_failure)
-;;
-failwith_test 17
-msd_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 0))
-("msd_ratio "^infinite_failure)
-;;
-*************************)
-
-testing_function "round_futur_last_digit"
-;;
-
-let s = Bytes.of_string "+123456" in
-test 1 eq (round_futur_last_digit s 1 (pred (Bytes.length s)),
-            false) &&
-test 2 eq_bytes (s, Bytes.of_string "+123466")
-;;
-
-let s = Bytes.of_string "123456" in
-test 3 eq (round_futur_last_digit s 0 (Bytes.length s), false) &&
-test 4 eq_bytes (s, Bytes.of_string "123466")
-;;
-
-let s = Bytes.of_string "-123456" in
-test 5 eq (round_futur_last_digit s 1 (pred (Bytes.length s)),
-            false) &&
-test 6 eq_bytes (s, Bytes.of_string "-123466")
-;;
-
-let s = Bytes.of_string "+123496" in
-test 7 eq (round_futur_last_digit s 1 (pred (Bytes.length s)),
-            false) &&
-test 8 eq_bytes (s, Bytes.of_string "+123506")
-;;
-
-let s = Bytes.of_string "123496" in
-test 9 eq (round_futur_last_digit s 0 (Bytes.length s), false) &&
-test 10 eq_bytes (s, Bytes.of_string "123506")
-;;
-
-let s = Bytes.of_string "-123496" in
-test 11 eq (round_futur_last_digit s 1 (pred (Bytes.length s)),
-            false) &&
-test 12 eq_bytes (s, Bytes.of_string "-123506")
-;;
-
-let s = Bytes.of_string "+996" in
-test 13 eq (round_futur_last_digit s 1 (pred (Bytes.length s)),
-            true) &&
-test 14 eq_bytes (s, Bytes.of_string "+006")
-;;
-
-let s = Bytes.of_string "996" in
-test 15 eq (round_futur_last_digit s 0 (Bytes.length s), true) &&
-test 16 eq_bytes (s, Bytes.of_string "006")
-;;
-
-let s = Bytes.of_string "-996" in
-test 17 eq (round_futur_last_digit s 1 (pred (Bytes.length s)),
-             true) &&
-test 18 eq_bytes (s, Bytes.of_string "-006")
-;;
-
-let s = Bytes.of_string "+6666666" in
-test 19 eq (round_futur_last_digit s 1 (pred (Bytes.length s)),
-             false) &&
-test 20 eq_bytes (s, Bytes.of_string "+6666676")
-;;
-
-let s = Bytes.of_string "6666666" in
-test 21 eq (round_futur_last_digit s 0 (Bytes.length s), false) &&
-test 22 eq_bytes (s, Bytes.of_string "6666676")
-;;
-
-let s = Bytes.of_string "-6666666" in
-test 23 eq (round_futur_last_digit s 1 (pred (Bytes.length s)),
-             false) &&
-test 24 eq_bytes (s, Bytes.of_string "-6666676")
-;;
-
-testing_function "approx_ratio_fix"
-;;
-
-let s = approx_ratio_fix 5
-                          (create_ratio (big_int_of_int 2)
-                                        (big_int_of_int 3)) in
-test 1
-eq_string (s, "+0.66667")
-;;
-
-test 2
-eq_string (approx_ratio_fix 5
-                             (create_ratio (big_int_of_int 20)
-                                           (big_int_of_int 3)),
-           "+6.66667")
-;;
-test 3
-eq_string (approx_ratio_fix 5
-                             (create_ratio (big_int_of_int 2)
-                                           (big_int_of_int 30)),
-           "+0.06667")
-;;
-test 4
-eq_string (approx_ratio_fix 5
-                             (create_ratio (big_int_of_string "999996")
-                                           (big_int_of_string "1000000")),
-           "+1.00000")
-;;
-test 5
-eq_string (approx_ratio_fix 5
-                             (create_ratio (big_int_of_string "299996")
-                                           (big_int_of_string "100000")),
-           "+2.99996")
-;;
-test 6
-eq_string (approx_ratio_fix 5
-                             (create_ratio (big_int_of_string "2999996")
-                                           (big_int_of_string "1000000")),
-           "+3.00000")
-;;
-test 7
-eq_string (approx_ratio_fix 4
-                             (create_ratio (big_int_of_string "299996")
-                                           (big_int_of_string "100000")),
-           "+3.0000")
-;;
-test 8
-eq_string (approx_ratio_fix 5
-                             (create_ratio (big_int_of_int 29996)
-                                           (big_int_of_string "100000")),
-           "+0.29996")
-;;
-test 9
-eq_string (approx_ratio_fix 5
-                             (create_ratio (big_int_of_int 0)
-                                           (big_int_of_int 1)),
-           "+0")
-;;
-failwith_test 10
-(approx_ratio_fix 5) (create_ratio (big_int_of_int 1) (big_int_of_int 0))
-(Failure "approx_ratio_fix infinite or undefined rational number")
-;;
-failwith_test 11
-(approx_ratio_fix 5) (create_ratio (big_int_of_int 0) (big_int_of_int 0))
-(Failure "approx_ratio_fix infinite or undefined rational number")
-;;
-
-(* PR#4566 *)
-test 12
-eq_string (approx_ratio_fix 8
-                            (create_ratio (big_int_of_int 9603)
-                                          (big_int_of_string "100000000000")),
-
-          "+0.00000010")
-;;
-test 13
-eq_string (approx_ratio_fix 1
-                            (create_ratio (big_int_of_int 94)
-                                          (big_int_of_int 1000)),
-          "+0.1")
-;;
-test 14
-eq_string (approx_ratio_fix 1
-                            (create_ratio (big_int_of_int 49)
-                                          (big_int_of_int 1000)),
-          "+0.0")
-;;
-
-testing_function "approx_ratio_exp"
-;;
-
-test 1
-eq_string (approx_ratio_exp 5
-                             (create_ratio (big_int_of_int 2)
-                                           (big_int_of_int 3)),
-           "+0.66667e0")
-;;
-test 2
-eq_string (approx_ratio_exp 5
-                             (create_ratio (big_int_of_int 20)
-                                           (big_int_of_int 3)),
-           "+0.66667e1")
-;;
-test 3
-eq_string (approx_ratio_exp 5
-                             (create_ratio (big_int_of_int 2)
-                                           (big_int_of_int 30)),
-           "+0.66667e-1")
-;;
-test 4
-eq_string (approx_ratio_exp 5
-                             (create_ratio (big_int_of_string "999996")
-                                           (big_int_of_string "1000000")),
-           "+1.00000e0")
-;;
-test 5
-eq_string (approx_ratio_exp 5
-                             (create_ratio (big_int_of_string "299996")
-                                           (big_int_of_string "100000")),
-           "+0.30000e1")
-;;
-test 6
-eq_string (approx_ratio_exp 5
-                             (create_ratio (big_int_of_int 29996)
-                                           (big_int_of_string "100000")),
-           "+0.29996e0")
-;;
-test 7
-eq_string (approx_ratio_exp 5
-                             (create_ratio (big_int_of_int 0)
-                                           (big_int_of_int 1)),
-           "+0.00000e0")
-;;
-failwith_test 8
-(approx_ratio_exp 5) (create_ratio (big_int_of_int 1) (big_int_of_int 0))
-(Failure "approx_ratio_exp infinite or undefined rational number")
-;;
-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/tprintf.ml b/testsuite/tests/lib-printf/tprintf.ml
index 4ab57230736b9281d22d1d99a8b0880b00efb6e5..16e65479d767c90d8556e80a7cedf53704c3bd9a 100644 (file)
--- a/testsuite/tests/lib-printf/tprintf.ml
+++ b/testsuite/tests/lib-printf/tprintf.ml
@@ -372,7 +372,9 @@ try
 
   printf "\nB\n%!";
   test (sprintf "%B" true = "true");
+  test (sprintf "%8B" true = "    true");
   test (sprintf "%B" false = "false");
+  test (sprintf "%-8B" false = "false   ");
 
   printf "\nld/li positive\n%!";
   test (sprintf "%ld/%li" 42l 43l = "42/43");

diff --git a/testsuite/tests/lib-printf/tprintf.reference b/testsuite/tests/lib-printf/tprintf.reference
index de3dc1dbddd0351a80fc53097da5a66f93c63ad7..9098a48dbe397032d762143895fb6612ed5aa14e 100644 (file)
--- a/testsuite/tests/lib-printf/tprintf.reference
+++ b/testsuite/tests/lib-printf/tprintf.reference
@@ -39,57 +39,57 @@ e
 E
  132 133 134 135 136 137 138 139 140 141 142 143 144 145
 B
- 146 147
+ 146 147 148 149
 ld/li positive
- 148 149 150 151 152 153 154
+ 150 151 152 153 154 155 156
 ld/li negative
- 155 156 157 158 159 160 161
+ 157 158 159 160 161 162 163
 lu positive
- 162 163 164 165 166
+ 164 165 166 167 168
 lu negative
- 167
+ 169
 lx positive
- 168 169 170 171 172 173
+ 170 171 172 173 174 175
 lx negative
- 174
+ 176
 lX positive
- 175 176 177 178 179 180
+ 177 178 179 180 181 182
 lx negative
- 181
+ 183
 lo positive
- 182 183 184 185 186 187
+ 184 185 186 187 188 189
 lo negative
- 188
+ 190
 Ld/Li positive
- 189 190 191 192 193
+ 191 192 193 194 195
 Ld/Li negative
- 194 195 196 197 198
+ 196 197 198 199 200
 Lu positive
- 199 200 201 202 203
+ 201 202 203 204 205
 Lu negative
- 204
+ 206
 Lx positive
- 205 206 207 208 209 210
+ 207 208 209 210 211 212
 Lx negative
- 211
+ 213
 LX positive
- 212 213 214 215 216 217
+ 214 215 216 217 218 219
 Lx negative
- 218
+ 220
 Lo positive
- 219 220 221 222 223 224
+ 221 222 223 224 225 226
 Lo negative
- 225
+ 227
 a
- 226
+ 228
 t
- 227
+ 229
 {...%}
- 228
+ 230
 (...%)
- 229
+ 231
 ! % @ , and constants
- 230 231 232 233 234 235 236
+ 232 233 234 235 236 237 238
 end of tests
 
 All tests succeeded.

diff --git a/testsuite/tests/lib-set/testmap.ml b/testsuite/tests/lib-set/testmap.ml
index 307c7f8d04f8820011835e06e6ea3b88c2bdf975..5d28cd1ea40176d56c5c412d763421e3b572c37d 100644 (file)
--- a/testsuite/tests/lib-set/testmap.ml
+++ b/testsuite/tests/lib-set/testmap.ml
@@ -117,15 +117,18 @@ let test x v s1 s2 =
 
   checkbool "find_first_opt"
     (let (l, p, r) = M.split x s1 in
+    let find_first_opt_result = M.find_first_opt (fun k -> k >= x) s1 in
     if p = None && M.is_empty r then
-      match M.find_first_opt (fun k -> k >= x) s1 with
+      match find_first_opt_result with
         None -> true
       | _ -> false
     else
-      let Some (k, v) = M.find_first_opt (fun k -> k >= x) s1 in
-      match p with
-        None -> (k, v) = M.min_binding r
-      | Some v1 -> (k, v) = (x, v1));
+      match find_first_opt_result with
+        | None -> false
+        | Some (k, v) ->
+          (match p with
+          | None -> (k, v) = M.min_binding r
+          | Some v1 -> (k, v) = (x, v1)));
 
   checkbool "find_last"
     (let (l, p, r) = M.split x s1 in
@@ -143,15 +146,18 @@ let test x v s1 s2 =
 
   checkbool "find_last_opt"
     (let (l, p, r) = M.split x s1 in
+    let find_last_opt_result = M.find_last_opt (fun k -> k <= x) s1 in
     if p = None && M.is_empty l then
-      match M.find_last_opt (fun k -> k <= x) s1 with
+      match find_last_opt_result with
         None -> true
       | _ -> false
     else
-      let Some (k, v) = M.find_last_opt (fun k -> k <= x) s1 in
-      match p with
-        None -> (k, v) = M.max_binding l
-      | Some v1 -> (k, v) = (x, v1));
+      (match find_last_opt_result with
+      | None -> false
+      | Some (k, v) ->
+        (match p with
+        | None -> (k, v) = M.max_binding l
+        | Some v1 -> (k, v) = (x, v1))));
 
   check "split"
     (let (l, p, r) = M.split x s1 in

diff --git a/testsuite/tests/lib-set/testset.ml b/testsuite/tests/lib-set/testset.ml
index 35878ea044611ba16e45cd5bc457177dd69d993a..8e9d6d544426f504a2cb3a93c24d7716e35994e4 100644 (file)
--- a/testsuite/tests/lib-set/testset.ml
+++ b/testsuite/tests/lib-set/testset.ml
@@ -129,16 +129,15 @@ let test x s1 s2 =
 
   checkbool "find_first_opt"
     (let (l, p, r) = S.split x s1 in
+    let find_first_opt_result = S.find_first_opt (fun k -> k >= x) s1 in
     if not p && S.is_empty r then
-      match S.find_first_opt (fun k -> k >= x) s1 with
+      match find_first_opt_result with
         None -> true
       | _ -> false
     else
-      let Some e = S.find_first_opt (fun k -> k >= x) s1 in
-      if p then
-        e = x
-      else
-        e = S.min_elt r);
+      (match find_first_opt_result with
+      | None -> false
+      | Some e -> if p then e = x else e = S.min_elt r));
 
   checkbool "find_last"
     (let (l, p, r) = S.split x s1 in
@@ -157,16 +156,15 @@ let test x s1 s2 =
 
   checkbool "find_last_opt"
     (let (l, p, r) = S.split x s1 in
+    let find_last_opt_result = S.find_last_opt (fun k -> k <= x) s1 in
     if not p && S.is_empty l then
-      match S.find_last_opt (fun k -> k <= x) s1 with
+      match find_last_opt_result with
         None -> true
       | _ -> false
     else
-      let Some e = S.find_last_opt (fun k -> k <= x) s1 in
-      if p then
-        e = x
-      else
-        e = S.max_elt l);
+      (match find_last_opt_result with
+      | None -> false
+      | Some e -> if p then e = x else e = S.max_elt l));
 
   check "split"
     (let (l, p, r) = S.split x s1 in

diff --git a/testsuite/tests/lib-stack/test.ml b/testsuite/tests/lib-stack/test.ml
index e0105c5032c483766ff00c540bdf3bbe67b2ffe4..7ca64bed05cf01ed94a44819033879dc33ca16e9 100644 (file)
--- a/testsuite/tests/lib-stack/test.ml
+++ b/testsuite/tests/lib-stack/test.ml
@@ -107,7 +107,7 @@ let () =
 ;;
 
 let () =
-  let s1 = S.create () and s2 = S.create () in
+  let s1 = S.create () in
   for i = 1 to 4 do S.push i s1 done;
   assert (S.length s1 = 4); assert (S.to_list s1 = [1; 2; 3; 4]);
   let s2 = S.copy s1 in

diff --git a/testsuite/tests/lib-str/t01.ml b/testsuite/tests/lib-str/t01.ml
index 1e1b270592e728aaed4572231814699287d16a05..eb75e1cbf64f96476b509f6ecdbb7d10fb9c26e2 100644 (file)
--- a/testsuite/tests/lib-str/t01.ml
+++ b/testsuite/tests/lib-str/t01.ml
@@ -1065,8 +1065,8 @@ let manual_test regexp text =
         with Not_found ->
           ()
       done
-    with Invalid_argument "Str.matched_group" -> (*yuck*)
-      ()
+    with Invalid_argument str as exn ->
+      if str="Str.matched_group" then () else raise exn
     end;
     print_newline()
   with Not_found ->

diff --git a/testsuite/tests/lib-sys/Makefile b/testsuite/tests/lib-sys/Makefile
new file mode 100644 (file)
index 0000000..07ea06e
--- /dev/null
+++ b/testsuite/tests/lib-sys/Makefile
@@ -0,0 +1,21 @@
+#**************************************************************************
+#*                                                                        *
+#*                                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 GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common
+
+# Not really generated sources but temp files that need cleaning
+GENERATED_SOURCES=file1.dat file2.dat

diff --git a/testsuite/tests/lib-sys/rename.ml b/testsuite/tests/lib-sys/rename.ml
new file mode 100644 (file)
index 0000000..63c29ec
--- /dev/null
+++ b/testsuite/tests/lib-sys/rename.ml
@@ -0,0 +1,52 @@
+(* Test the Sys.rename function *)
+
+let writefile filename contents =
+  let oc = open_out_bin filename in
+  output_string oc contents;
+  close_out oc
+
+let readfile filename =
+  let ic = open_in_bin filename in
+  let sz = in_channel_length ic in
+  let contents = really_input_string ic sz in
+  close_in ic;
+  contents
+
+let safe_remove filename =
+  try Sys.remove filename with Sys_error _ -> ()
+
+let testrename f1 f2 contents =
+  try
+    Sys.rename f1 f2;
+    if readfile f2 <> contents then print_string "wrong contents!"
+    else if Sys.file_exists f1 then print_string "initial file still exists!"
+    else print_string "passed"
+  with Sys_error msg ->
+    print_string "Sys_error exception: "; print_string msg
+
+let testfailure f1 f2 =
+  try
+    Sys.rename f1 f2; print_string "should fail but doesn't!"
+  with Sys_error _ ->
+    print_string "fails as expected"
+
+let _ =
+  let f1 = "file1.dat" and f2 = "file2.dat" in
+  safe_remove f1; safe_remove f2;
+  print_string "Rename to nonexisting file: ";
+  writefile f1 "abc";
+  testrename f1 f2 "abc";
+  print_newline();
+  print_string "Rename to existing file: ";
+  writefile f1 "def";
+  writefile f2 "xyz";
+  testrename f1 f2 "def";
+  print_newline();
+  print_string "Renaming a nonexisting file: ";
+  testfailure f1 f2;
+  print_newline();
+  print_string "Renaming to a nonexisting directory: ";
+  writefile f1 "abc";
+  testfailure f1 (Filename.concat "nosuchdir" f2);
+  print_newline();
+  safe_remove f1; safe_remove f2

diff --git a/testsuite/tests/lib-sys/rename.reference b/testsuite/tests/lib-sys/rename.reference
new file mode 100644 (file)
index 0000000..d5ec88d
--- /dev/null
+++ b/testsuite/tests/lib-sys/rename.reference
@@ -0,0 +1,4 @@
+Rename to nonexisting file: passed
+Rename to existing file: passed
+Renaming a nonexisting file: fails as expected
+Renaming to a nonexisting directory: fails as expected

diff --git a/testsuite/tests/lib-threads/backtrace_threads.ml b/testsuite/tests/lib-threads/backtrace_threads.ml
index 348a5f7f2de386a4747b76a2366b31da740d1a82..79dc8c5b5ab10548ae5012e5e39d3db54fbc7d5b 100644 (file)
--- a/testsuite/tests/lib-threads/backtrace_threads.ml
+++ b/testsuite/tests/lib-threads/backtrace_threads.ml
@@ -4,7 +4,8 @@ let () = Printexc.record_backtrace true
 let () =
    let bt =
      try
-       Hashtbl.find (Hashtbl.create 1) 1;
+       let h = (Hashtbl.create 1 : (int, unit) Hashtbl.t) in
+       Hashtbl.find h 1;
        assert false
      with Not_found ->
        Printexc.get_raw_backtrace ()

diff --git a/testsuite/tests/lib-threads/close.ml b/testsuite/tests/lib-threads/close.ml
index 3af8ae313d9aad8d72445a2dfe2cbcde0026ae1f..bba0286cb85492345d0e4b4709c0df84c09c3c41 100644 (file)
--- a/testsuite/tests/lib-threads/close.ml
+++ b/testsuite/tests/lib-threads/close.ml
@@ -7,7 +7,7 @@ let main () =
       Unix.close wr;
     )
     () in
-  let buf = String.create 10 in
+  let buf = Bytes.create 10 in
   print_endline "reading...";
   begin try ignore (Unix.read rd buf 0 10) with Unix.Unix_error _ -> () end;
   print_endline "read returned";

diff --git a/testsuite/tests/lib-threads/fileio.ml b/testsuite/tests/lib-threads/fileio.ml
index f9d97c9436b6d8ae46d69f686bedee1ea0a50fed..5c02aebddc3cfca9e53662a81a776b820c51e2ab 100644 (file)
--- a/testsuite/tests/lib-threads/fileio.ml
+++ b/testsuite/tests/lib-threads/fileio.ml
@@ -19,7 +19,7 @@ let test msg producer consumer src dst =
 (* File copy with constant-sized chunks *)
 
 let copy_file sz (ic, oc) =
-  let buffer = String.create sz in
+  let buffer = Bytes.create sz in
   let rec copy () =
     let n = input ic buffer 0 sz in
     if n = 0 then () else begin
@@ -33,7 +33,7 @@ let copy_file sz (ic, oc) =
 (* File copy with random-sized chunks *)
 
 let copy_random sz (ic, oc) =
-  let buffer = String.create sz in
+  let buffer = Bytes.create sz in
   let rec copy () =
     let s = 1 + Random.int sz in
     let n = input ic buffer 0 s in

diff --git a/testsuite/tests/lib-threads/pr7638.ml b/testsuite/tests/lib-threads/pr7638.ml
new file mode 100644 (file)
index 0000000..9537111
--- /dev/null
+++ b/testsuite/tests/lib-threads/pr7638.ml
@@ -0,0 +1,10 @@
+(* MPR#7638 repro case *)
+
+let crashme v =
+  match Sys.getenv v with
+  | exception Not_found -> print_string "OK\n"
+  | s -> print_string "Surprising but OK\n"
+
+let _ =
+  let th = Thread.create crashme "no such variable" in
+  Thread.join th

diff --git a/testsuite/tests/lib-threads/pr7638.reference b/testsuite/tests/lib-threads/pr7638.reference
new file mode 100644 (file)
index 0000000..d86bac9
--- /dev/null
+++ b/testsuite/tests/lib-threads/pr7638.reference
@@ -0,0 +1 @@
+OK

diff --git a/testsuite/tests/lib-threads/signal.checker b/testsuite/tests/lib-threads/signal.checker
index 181d3c5afce9ac8e96d19adc2733b13022d2d8f2..8bb0d3da20560a3e760b8a1b2171228498172871 100644 (file)
--- a/testsuite/tests/lib-threads/signal.checker
+++ b/testsuite/tests/lib-threads/signal.checker
@@ -13,4 +13,4 @@
 #*                                                                        *
 #**************************************************************************
 
-sed -e 1q signal.result | grep -q '^[ab]*Got ctrl-C, exiting...$'
+sed -e 1q signal.result | grep -q '^[ab]*Got ctrl-C, exiting...[ab]\{0,2\}$'

diff --git a/testsuite/tests/lib-threads/signal2.checker b/testsuite/tests/lib-threads/signal2.checker
deleted file mode 100644 (file)
index 56fe7db..0000000
--- a/testsuite/tests/lib-threads/signal2.checker
+++ /dev/null
@@ -1,16 +0,0 @@
-#**************************************************************************
-#*                                                                        *
-#*                                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 GNU Lesser General Public License version 2.1, with the          *
-#*   special exception on linking described in the file LICENSE.          *
-#*                                                                        *
-#**************************************************************************
-
-sed -e 1q signal2.result | grep -q '^[ab]*'

diff --git a/testsuite/tests/lib-threads/signal2.ml b/testsuite/tests/lib-threads/signal2.ml
deleted file mode 100644 (file)
index b7cda56..0000000
--- a/testsuite/tests/lib-threads/signal2.ml
+++ /dev/null
@@ -1,11 +0,0 @@
-let print_message delay c =
-  while true do
-    print_char c; flush stdout; Thread.delay delay
-  done
-
-let _ =
-  ignore (Thread.sigmask Unix.SIG_BLOCK [Sys.sigint; Sys.sigterm]);
-  ignore (Thread.create (print_message 0.6666666666) 'a');
-  ignore (Thread.create (print_message 1.0) 'b');
-  let s = Thread.wait_signal [Sys.sigint; Sys.sigterm] in
-  Printf.printf "Got signal %d, exiting...\n" s

diff --git a/testsuite/tests/lib-threads/signal2.precheck b/testsuite/tests/lib-threads/signal2.precheck
deleted file mode 100644 (file)
index 72b0054..0000000
--- a/testsuite/tests/lib-threads/signal2.precheck
+++ /dev/null
@@ -1,16 +0,0 @@
-#**************************************************************************
-#*                                                                        *
-#*                                OCaml                                   *
-#*                                                                        *
-#*           Damien Doligez, projet Gallium, INRIA Rocquencourt           *
-#*                                                                        *
-#*   Copyright 2013 Institut National de Recherche en Informatique et     *
-#*     en Automatique.                                                    *
-#*                                                                        *
-#*   All rights reserved.  This file is distributed under the terms of    *
-#*   the GNU Lesser General Public License version 2.1, with the          *
-#*   special exception on linking described in the file LICENSE.          *
-#*                                                                        *
-#**************************************************************************
-
-test "$TOOLCHAIN" != "msvc" -a "$TOOLCHAIN" != "mingw"

diff --git a/testsuite/tests/lib-threads/signal2.runner b/testsuite/tests/lib-threads/signal2.runner
deleted file mode 100644 (file)
index 8369d63..0000000
--- a/testsuite/tests/lib-threads/signal2.runner
+++ /dev/null
@@ -1,21 +0,0 @@
-#**************************************************************************
-#*                                                                        *
-#*                                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 GNU Lesser General Public License version 2.1, with the          *
-#*   special exception on linking described in the file LICENSE.          *
-#*                                                                        *
-#**************************************************************************
-
-$RUNTIME ./program >signal2.result &
-pid=$!
-sleep 2
-kill -INT $pid
-sleep 1
-kill -9 $pid 2>&- || true

diff --git a/testsuite/tests/lib-uchar/test.ml b/testsuite/tests/lib-uchar/test.ml
index 3895c54544a4689b86456d0a39f079ee3c801b8e..4fdbf925064d16f797ab0c4a2f95c0dcf77b009e 100644 (file)
--- a/testsuite/tests/lib-uchar/test.ml
+++ b/testsuite/tests/lib-uchar/test.ml
@@ -4,6 +4,8 @@ let assert_raise_invalid_argument f v =
 let test_constants () =
   assert (Uchar.(to_int min) = 0x0000);
   assert (Uchar.(to_int max) = 0x10FFFF);
+  assert (Uchar.(to_int bom) = 0xFEFF);
+  assert (Uchar.(to_int rep) = 0xFFFD);
   ()
 
 let test_succ () =

diff --git a/testsuite/tests/lib-unix/Makefile b/testsuite/tests/lib-unix/Makefile
deleted file mode 100644 (file)
index 789c509..0000000
--- a/testsuite/tests/lib-unix/Makefile
+++ /dev/null
@@ -1,36 +0,0 @@
-#**************************************************************************
-#*                                                                        *
-#*                                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 GNU Lesser General Public License version 2.1, with the          *
-#*   special exception on linking described in the file LICENSE.          *
-#*                                                                        *
-#**************************************************************************
-
-BASEDIR=../..
-LIBRARIES=unix
-ADD_COMPFLAGS=-I $(OTOPDIR)/otherlibs/$(UNIXLIBVAR)unix
-LD_PATH=$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix
-
-ifeq ($(OS),Windows_NT)
-ADD_BYTERUN_FLAGS="-I $(OTOPDIR)/otherlibs/win32unix"
-endif
-
-default: reflector.exe fdstatus.exe cmdline_prog.exe
-       @$(MAKE) check
-
-include $(BASEDIR)/makefiles/Makefile.several
-include $(BASEDIR)/makefiles/Makefile.common
-
-%.exe: %.c
-ifeq ($(CCOMPTYPE),msvc)
-       @set -o pipefail ; $(BYTECC) /Fe$*.exe $*.c | tail -n +2
-else
-       @$(BYTECC) -o $*.exe $*.c
-endif

diff --git a/testsuite/tests/lib-unix/cloexec.ml b/testsuite/tests/lib-unix/cloexec.ml
deleted file mode 100644 (file)
index d7e1e29..0000000
--- a/testsuite/tests/lib-unix/cloexec.ml
+++ /dev/null
@@ -1,51 +0,0 @@
-(* This is a terrible hack that plays on the internal representation
-   of file descriptors.  The result is a number (as a string)
-   that the fdstatus.exe auxiliary program can use to check whether
-   the fd is open. *)
-
-let string_of_fd (fd: Unix.file_descr) : string =
-  match Sys.os_type with
-  | "Unix" | "Cygwin" ->  string_of_int (Obj.magic fd : int)
-  | "Win32" ->
-      if Sys.word_size = 32 then
-        Int32.to_string (Obj.magic fd : int32)
-      else
-        Int64.to_string (Obj.magic fd : int64)
-  | _ -> assert false
-
-let _ =
-  let f0 = Unix.(openfile "tmp.txt" [O_WRONLY; O_CREAT; O_TRUNC] 0o600) in
-  let f1 = Unix.(openfile "tmp.txt" [O_RDONLY; O_KEEPEXEC] 0) in
-  let f2 = Unix.(openfile "tmp.txt" [O_RDONLY; O_CLOEXEC] 0) in
-  let d0 = Unix.dup f0 in
-  let d1 = Unix.dup ~cloexec:false f1 in
-  let d2 = Unix.dup ~cloexec:true f2 in
-  let (p0, p0') = Unix.pipe () in
-  let (p1, p1') = Unix.pipe ~cloexec:false () in
-  let (p2, p2') = Unix.pipe ~cloexec:true () in
-  let s0 = Unix.(socket PF_INET SOCK_STREAM 0) in
-  let s1 = Unix.(socket ~cloexec:false PF_INET SOCK_STREAM 0) in
-  let s2 = Unix.(socket ~cloexec:true PF_INET SOCK_STREAM 0) in
-  let (x0, x0') =
-    try Unix.(socketpair PF_UNIX SOCK_STREAM 0)
-    with Invalid_argument _ -> (p0, p0') in
-    (* socketpair not available under Win32; keep the same output *)
-  let (x1, x1') =
-    try Unix.(socketpair ~cloexec:false PF_UNIX SOCK_STREAM 0)
-    with Invalid_argument _ -> (p1, p1') in
-  let (x2, x2') =
-    try Unix.(socketpair ~cloexec:true PF_UNIX SOCK_STREAM 0)
-    with Invalid_argument _ -> (p2, p2') in
-
-  let fds = [| f0;f1;f2; d0;d1;d2;
-               p0;p0';p1;p1';p2;p2';
-               s0;s1;s2;
-               x0;x0';x1;x1';x2;x2' |] in
-  let pid =
-    Unix.create_process
-      (Filename.concat Filename.current_dir_name "fdstatus.exe")
-      (Array.append [| "fdstatus" |] (Array.map string_of_fd fds))
-      Unix.stdin Unix.stdout Unix.stderr in
-  ignore (Unix.waitpid [] pid);
-  Array.iter (fun fd -> try Unix.close fd with Unix.Unix_error _ -> ()) fds;
-  Sys.remove "tmp.txt"

diff --git a/testsuite/tests/lib-unix/cloexec.reference b/testsuite/tests/lib-unix/cloexec.reference
deleted file mode 100644 (file)
index c627017..0000000
--- a/testsuite/tests/lib-unix/cloexec.reference
+++ /dev/null
@@ -1,21 +0,0 @@
-#1: open
-#2: open
-#3: closed
-#4: open
-#5: open
-#6: closed
-#7: open
-#8: open
-#9: open
-#10: open
-#11: closed
-#12: closed
-#13: open
-#14: open
-#15: closed
-#16: open
-#17: open
-#18: open
-#19: open
-#20: closed
-#21: closed

diff --git a/testsuite/tests/lib-unix/cmdline_prog.c b/testsuite/tests/lib-unix/cmdline_prog.c
deleted file mode 100644 (file)
index c67a756..0000000
--- a/testsuite/tests/lib-unix/cmdline_prog.c
+++ /dev/null
@@ -1,10 +0,0 @@
-#include <stdio.h>
-
-int main (int argc, char *argv[])
-{
-  int i;
-  for (i = 1; i < argc; i ++) {
-    printf ("%s\n", argv[i]);
-  }
-  return 0;
-}

diff --git a/testsuite/tests/lib-unix/common/Makefile b/testsuite/tests/lib-unix/common/Makefile
new file mode 100644 (file)
index 0000000..706137b
--- /dev/null
+++ b/testsuite/tests/lib-unix/common/Makefile
@@ -0,0 +1,37 @@
+#**************************************************************************
+#*                                                                        *
+#*                                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 GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../../..
+LIBRARIES=unix
+ADD_COMPFLAGS=-I $(OTOPDIR)/otherlibs/$(UNIXLIBVAR)unix
+LD_PATH=$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix
+
+ifeq ($(OS),Windows_NT)
+ADD_BYTERUN_FLAGS="-I $(OTOPDIR)/otherlibs/win32unix"
+endif
+
+default: reflector.exe fdstatus.exe cmdline_prog.exe
+       @$(MAKE) check
+
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common
+
+%.exe: %.c
+ifeq ($(CCOMPTYPE),msvc)
+       @set -o pipefail ; \
+       $(CC) $(CFLAGS) $(CPPFLAGS) /Fe$*.exe $*.c | tail -n +2
+else
+       @$(CC) $(CFLAGS) $(CPPFLAGS) -o $*.exe $*.c
+endif

diff --git a/testsuite/tests/lib-unix/common/cloexec.ml b/testsuite/tests/lib-unix/common/cloexec.ml
new file mode 100644 (file)
index 0000000..d7e1e29
--- /dev/null
+++ b/testsuite/tests/lib-unix/common/cloexec.ml
@@ -0,0 +1,51 @@
+(* This is a terrible hack that plays on the internal representation
+   of file descriptors.  The result is a number (as a string)
+   that the fdstatus.exe auxiliary program can use to check whether
+   the fd is open. *)
+
+let string_of_fd (fd: Unix.file_descr) : string =
+  match Sys.os_type with
+  | "Unix" | "Cygwin" ->  string_of_int (Obj.magic fd : int)
+  | "Win32" ->
+      if Sys.word_size = 32 then
+        Int32.to_string (Obj.magic fd : int32)
+      else
+        Int64.to_string (Obj.magic fd : int64)
+  | _ -> assert false
+
+let _ =
+  let f0 = Unix.(openfile "tmp.txt" [O_WRONLY; O_CREAT; O_TRUNC] 0o600) in
+  let f1 = Unix.(openfile "tmp.txt" [O_RDONLY; O_KEEPEXEC] 0) in
+  let f2 = Unix.(openfile "tmp.txt" [O_RDONLY; O_CLOEXEC] 0) in
+  let d0 = Unix.dup f0 in
+  let d1 = Unix.dup ~cloexec:false f1 in
+  let d2 = Unix.dup ~cloexec:true f2 in
+  let (p0, p0') = Unix.pipe () in
+  let (p1, p1') = Unix.pipe ~cloexec:false () in
+  let (p2, p2') = Unix.pipe ~cloexec:true () in
+  let s0 = Unix.(socket PF_INET SOCK_STREAM 0) in
+  let s1 = Unix.(socket ~cloexec:false PF_INET SOCK_STREAM 0) in
+  let s2 = Unix.(socket ~cloexec:true PF_INET SOCK_STREAM 0) in
+  let (x0, x0') =
+    try Unix.(socketpair PF_UNIX SOCK_STREAM 0)
+    with Invalid_argument _ -> (p0, p0') in
+    (* socketpair not available under Win32; keep the same output *)
+  let (x1, x1') =
+    try Unix.(socketpair ~cloexec:false PF_UNIX SOCK_STREAM 0)
+    with Invalid_argument _ -> (p1, p1') in
+  let (x2, x2') =
+    try Unix.(socketpair ~cloexec:true PF_UNIX SOCK_STREAM 0)
+    with Invalid_argument _ -> (p2, p2') in
+
+  let fds = [| f0;f1;f2; d0;d1;d2;
+               p0;p0';p1;p1';p2;p2';
+               s0;s1;s2;
+               x0;x0';x1;x1';x2;x2' |] in
+  let pid =
+    Unix.create_process
+      (Filename.concat Filename.current_dir_name "fdstatus.exe")
+      (Array.append [| "fdstatus" |] (Array.map string_of_fd fds))
+      Unix.stdin Unix.stdout Unix.stderr in
+  ignore (Unix.waitpid [] pid);
+  Array.iter (fun fd -> try Unix.close fd with Unix.Unix_error _ -> ()) fds;
+  Sys.remove "tmp.txt"

diff --git a/testsuite/tests/lib-unix/common/cloexec.reference b/testsuite/tests/lib-unix/common/cloexec.reference
new file mode 100644 (file)
index 0000000..c627017
--- /dev/null
+++ b/testsuite/tests/lib-unix/common/cloexec.reference
@@ -0,0 +1,21 @@
+#1: open
+#2: open
+#3: closed
+#4: open
+#5: open
+#6: closed
+#7: open
+#8: open
+#9: open
+#10: open
+#11: closed
+#12: closed
+#13: open
+#14: open
+#15: closed
+#16: open
+#17: open
+#18: open
+#19: open
+#20: closed
+#21: closed

diff --git a/testsuite/tests/lib-unix/common/cmdline_prog.c b/testsuite/tests/lib-unix/common/cmdline_prog.c
new file mode 100644 (file)
index 0000000..c67a756
--- /dev/null
+++ b/testsuite/tests/lib-unix/common/cmdline_prog.c
@@ -0,0 +1,10 @@
+#include <stdio.h>
+
+int main (int argc, char *argv[])
+{
+  int i;
+  for (i = 1; i < argc; i ++) {
+    printf ("%s\n", argv[i]);
+  }
+  return 0;
+}

diff --git a/testsuite/tests/lib-unix/common/dup.ml b/testsuite/tests/lib-unix/common/dup.ml
new file mode 100644 (file)
index 0000000..d296cb9
--- /dev/null
+++ b/testsuite/tests/lib-unix/common/dup.ml
@@ -0,0 +1,5 @@
+let _ =
+  let f = Unix.dup ~cloexec:true Unix.stdout in
+  let txt = "Some output\n" in
+  ignore (Unix.write_substring f txt 0 (String.length txt));
+  Unix.close f

diff --git a/testsuite/tests/lib-unix/common/dup.reference b/testsuite/tests/lib-unix/common/dup.reference
new file mode 100644 (file)
index 0000000..85cc16f
--- /dev/null
+++ b/testsuite/tests/lib-unix/common/dup.reference
@@ -0,0 +1 @@
+Some output

diff --git a/testsuite/tests/lib-unix/common/dup2.ml b/testsuite/tests/lib-unix/common/dup2.ml
new file mode 100644 (file)
index 0000000..055d7e5
--- /dev/null
+++ b/testsuite/tests/lib-unix/common/dup2.ml
@@ -0,0 +1,24 @@
+let cat file =
+  let fd = Unix.openfile file [Unix.O_RDONLY] 0 in
+  let buf = Bytes.create 1024 in
+  let rec cat () =
+    let n = Unix.read fd buf 0 (Bytes.length buf) in
+    if n > 0 then (ignore(Unix.write Unix.stdout buf 0 n); cat ())
+  in cat (); Unix.close fd
+
+let out fd txt =
+  ignore (Unix.write_substring fd txt 0 (String.length txt))
+
+let _ =
+  let fd =
+    Unix.(openfile "./tmp.txt"
+                   [O_WRONLY;O_TRUNC;O_CREAT;O_SHARE_DELETE]
+                  0o600) in
+  out fd "---\n";
+  Unix.dup2 ~cloexec:true fd Unix.stderr;
+  Unix.close fd;
+  out Unix.stderr "Some output\n";
+  cat "./tmp.txt";
+  Sys.remove "./tmp.txt"
+
+    

diff --git a/testsuite/tests/lib-unix/common/dup2.reference b/testsuite/tests/lib-unix/common/dup2.reference
new file mode 100644 (file)
index 0000000..2f5a485
--- /dev/null
+++ b/testsuite/tests/lib-unix/common/dup2.reference
@@ -0,0 +1,2 @@
+---
+Some output

diff --git a/testsuite/tests/lib-unix/common/fdstatus.c b/testsuite/tests/lib-unix/common/fdstatus.c
new file mode 100644 (file)
index 0000000..b877041
--- /dev/null
+++ b/testsuite/tests/lib-unix/common/fdstatus.c
@@ -0,0 +1,73 @@
+/* Check if file descriptors are open or not */
+
+#include <stdio.h>
+#include <stdlib.h>
+
+#ifdef _WIN32
+
+#define WIN32_LEAN_AND_MEAN
+#include <wtypes.h>
+#include <winbase.h>
+#include <winerror.h>
+
+void process_fd(char * s)
+{
+  int fd;
+  HANDLE h;
+  DWORD flags;
+
+#ifdef _WIN64
+  h = (HANDLE) _atoi64(s);
+#else
+  h = (HANDLE) atoi(s);
+#endif
+  if (GetHandleInformation(h, &flags)) {
+    printf("open\n");
+  } else if (GetLastError() == ERROR_INVALID_HANDLE) {
+    printf("closed\n");
+  } else {
+    printf("error %lu\n", (unsigned long)(GetLastError()));
+  }
+}
+
+#else
+
+#include <limits.h>
+#include <string.h>
+#include <errno.h>
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <unistd.h>
+
+void process_fd(char * s)
+{
+  long n;
+  int fd;
+  char * endp;
+  struct stat st;
+  n = strtol(s, &endp, 0);
+  if (*endp != 0 || n < 0 || n > (long) INT_MAX) {
+    printf("parsing error\n");
+    return;
+  }
+  fd = (int) n;
+  if (fstat(fd, &st) != -1) {
+    printf("open\n");
+  } else if (errno == EBADF) {
+    printf("closed\n");
+  } else {
+    printf("error %s\n", strerror(errno));
+  }
+}
+
+#endif
+
+int main(int argc, char ** argv)
+{
+  int i;
+  for (i = 1; i < argc; i++) {
+    printf("#%d: ", i);
+    process_fd(argv[i]);
+  }
+  return 0;
+}

diff --git a/testsuite/tests/lib-unix/common/pipe_eof.ml b/testsuite/tests/lib-unix/common/pipe_eof.ml
new file mode 100644 (file)
index 0000000..19f5258
--- /dev/null
+++ b/testsuite/tests/lib-unix/common/pipe_eof.ml
@@ -0,0 +1,34 @@
+let drain pipe =
+  let max = 2048 in
+  let buf = Buffer.create 2048 in
+  let tmp = Bytes.create max in
+  while begin
+    try
+      let len = Unix.read pipe tmp 0 max in
+      Buffer.add_subbytes buf tmp 0 len;
+      len > 0
+    with Unix.Unix_error (Unix.EPIPE, _, _) when false ->
+      false
+  end do () done;
+  Buffer.contents buf
+;;
+
+let run exe args =
+  let out_in, out_out = Unix.pipe () in
+  let err_in, err_out = Unix.pipe () in
+  let args = Array.append [| exe |] args in
+  let pid = Unix.create_process exe args Unix.stdin out_out err_out in
+  Unix.close out_out;
+  Unix.close err_out;
+  let output = drain out_in in
+  let error = drain err_in in
+  Unix.close out_in;
+  Unix.close err_in;
+  let _pid, status = Unix.waitpid [ ] pid in
+  status, output, error
+;;
+
+let _ =
+  ignore (run "cp" [||]);
+  print_endline "success"
+;;

diff --git a/testsuite/tests/lib-unix/common/pipe_eof.reference b/testsuite/tests/lib-unix/common/pipe_eof.reference
new file mode 100644 (file)
index 0000000..2e9ba47
--- /dev/null
+++ b/testsuite/tests/lib-unix/common/pipe_eof.reference
@@ -0,0 +1 @@
+success

diff --git a/testsuite/tests/lib-unix/common/redirections.ml b/testsuite/tests/lib-unix/common/redirections.ml
new file mode 100644 (file)
index 0000000..ed1712a
--- /dev/null
+++ b/testsuite/tests/lib-unix/common/redirections.ml
@@ -0,0 +1,113 @@
+let cat file =
+  let fd = Unix.openfile file [Unix.O_RDONLY] 0 in
+  let buf = Bytes.create 1024 in
+  let rec cat () =
+    let n = Unix.read fd buf 0 (Bytes.length buf) in
+    if n > 0 then (ignore(Unix.write Unix.stdout buf 0 n); cat ())
+  in cat (); Unix.close fd
+
+let out fd txt =
+  ignore (Unix.write_substring fd txt 0 (String.length txt))
+
+let refl =
+  Filename.concat Filename.current_dir_name "reflector.exe"
+
+let test_createprocess () =
+  let f_out =
+    Unix.(openfile "./tmpout.txt" [O_WRONLY;O_TRUNC;O_CREAT;O_CLOEXEC] 0o600) in
+  let f_err =
+    Unix.(openfile "./tmperr.txt" [O_WRONLY;O_TRUNC;O_CREAT;O_CLOEXEC] 0o600) in
+  let (p_exit, p_entrance) =
+    Unix.pipe ~cloexec:true () in
+  let pid =
+    Unix.create_process_env
+       refl
+       [| refl; "i2o"; "i2e"; "o"; "123"; "e"; "456"; "i2o"; "v"; "XVAR" |]
+       [| "XVAR=xvar" |]
+       p_exit f_out f_err in
+  out p_entrance "aaaa\n";
+  out p_entrance "bbbb\n";
+  Unix.close p_entrance;
+  let (_, status) = Unix.waitpid [] pid in
+  Unix.close p_exit; Unix.close f_out; Unix.close f_err;
+  if status <> Unix.WEXITED 0 then
+    out Unix.stdout "!!! reflector exited with an error\n";
+  out Unix.stdout "---- File tmpout.txt\n";
+  cat "./tmpout.txt";
+  out Unix.stdout "---- File tmperr.txt\n";
+  cat "./tmperr.txt";
+  Sys.remove "./tmpout.txt";
+  Sys.remove "./tmperr.txt"
+
+let test_2ampsup1 () =    (* 2>&1 redirection, cf. GPR#1105 *)
+  let pid =
+    Unix.create_process
+      refl
+      [| refl; "o"; "123"; "e"; "456"; "o"; "789" |]
+      Unix.stdin Unix.stdout Unix.stdout in
+  let (_, status) = Unix.waitpid [] pid in
+  if status <> Unix.WEXITED 0 then
+    out Unix.stdout "!!! reflector exited with an error\n"
+
+let test_swap12 () =    (* swapping stdout and stderr *)
+  (* The test harness doesn't let us check contents of stderr,
+     so just output on stdout (after redirection) *)
+  let pid =
+    Unix.create_process
+      refl
+      [| refl; "e"; "123" |]
+      Unix.stdin Unix.stderr Unix.stdout in
+  let (_, status) = Unix.waitpid [] pid in
+  if status <> Unix.WEXITED 0 then
+    out Unix.stdout "!!! reflector exited with an error\n"
+
+let test_open_process_in () =
+  let ic = Unix.open_process_in (refl ^ " o 123 o 456") in
+  out Unix.stdout (input_line ic ^ "\n");
+  out Unix.stdout (input_line ic ^ "\n");
+  let status = Unix.close_process_in ic in
+  if status <> Unix.WEXITED 0 then
+    out Unix.stdout "!!! reflector exited with an error\n"
+
+let test_open_process_out () =
+  let oc = Unix.open_process_out (refl ^ " i2o i2o i2o") in
+  output_string oc "aa\nbbbb\n"; close_out oc;
+  let status = Unix.close_process_out oc in
+  if status <> Unix.WEXITED 0 then
+    out Unix.stdout "!!! reflector exited with an error\n"
+
+let test_open_process_full () =
+  let ((o, i, e) as res) =
+    Unix.open_process_full
+      (refl ^ " o 123 i2o e 456 i2e v XVAR")
+      [|"XVAR=xvar"|] in
+  output_string i "aa\nbbbb\n"; close_out i;
+  for _i = 1 to 3 do 
+    out Unix.stdout (input_line o ^ "\n")
+  done;
+  for _i = 1 to 2 do
+    out Unix.stdout (input_line e ^ "\n")
+  done;
+  let status = Unix.close_process_full res in
+  if status <> Unix.WEXITED 0 then
+    out Unix.stdout "!!! reflector exited with an error\n"
+
+let _ =
+  (* The following 'close' makes things more difficult.
+     Under Unix it works fine, but under Win32 create_process 
+     gives an error if one of the standard handles is closed. *)
+  (* Unix.close Unix.stdin; *)
+  out Unix.stdout "** create_process\n";
+  test_createprocess();
+  out Unix.stdout "** create_process 2>&1 redirection\n";
+  test_2ampsup1();
+  out Unix.stdout "** create_process swap 1-2\n";
+  test_swap12();
+  out Unix.stdout "** open_process_in\n";
+  test_open_process_in();
+  out Unix.stdout "** open_process_out\n";
+  test_open_process_out();
+  out Unix.stdout "** open_process_full\n";
+  test_open_process_full()
+
+

diff --git a/testsuite/tests/lib-unix/common/redirections.reference b/testsuite/tests/lib-unix/common/redirections.reference
new file mode 100644 (file)
index 0000000..c0da174
--- /dev/null
+++ b/testsuite/tests/lib-unix/common/redirections.reference
@@ -0,0 +1,28 @@
+** create_process
+---- File tmpout.txt
+aaaa
+123
+<end of file>
+xvar
+---- File tmperr.txt
+bbbb
+456
+** create_process 2>&1 redirection
+123
+456
+789
+** create_process swap 1-2
+123
+** open_process_in
+123
+456
+** open_process_out
+aa
+bbbb
+<end of file>
+** open_process_full
+123
+aa
+xvar
+456
+bbbb

diff --git a/testsuite/tests/lib-unix/common/reflector.c b/testsuite/tests/lib-unix/common/reflector.c
new file mode 100644 (file)
index 0000000..f8bbbf3
--- /dev/null
+++ b/testsuite/tests/lib-unix/common/reflector.c
@@ -0,0 +1,74 @@
+#include <stdio.h>
+#include <string.h>
+#include <stdlib.h>
+#if defined(_WIN32)
+#include <fcntl.h>
+#include <io.h>
+#endif
+
+/* A tool to read data from standard input and send it to standard
+   output or standard error. */
+
+void copyline(FILE * in, FILE * out)
+{
+  int c;
+  do {
+    c = getc(in);
+    if (c == EOF) {
+      fputs("<end of file>\n", out);
+      break;
+    }
+    putc(c, out);
+  } while (c != '\n');
+  fflush(out);
+}
+
+/* Command language:
+     i2o       copy one line from stdin to stdout
+     i2e       copy one line from stdin to stderr
+     o <txt>   write <txt> plus newline to stdout
+     e <txt>   write <txt> plus newline to stderr
+     v <var>   write value of environment variable <env> to stdout
+*/
+
+int main(int argc, char ** argv)
+{
+  int i;
+  char * cmd;
+#if defined(_WIN32)
+  _setmode(_fileno(stdin), _O_BINARY);
+  _setmode(_fileno(stdout), _O_BINARY);
+  _setmode(_fileno(stderr), _O_BINARY);
+#endif
+  i = 1;
+  while (i < argc) {
+    cmd = argv[i];
+    if (strcmp(cmd, "i2o") == 0) {
+      copyline(stdin, stdout);
+      i++;
+    } else if (strcmp(cmd, "i2e") == 0) {
+      copyline(stdin, stderr);
+      i++;
+    } else if (strcmp(cmd, "o") == 0 && i + 1 < argc) {
+      fputs(argv[i + 1], stdout);
+      fputc('\n', stdout);
+      fflush(stdout);
+      i += 2;
+    } else if (strcmp(cmd, "e") == 0 && i + 1 < argc) {
+      fputs(argv[i + 1], stderr);
+      fputc('\n', stderr);
+      fflush(stderr);
+      i += 2;
+    } else if (strcmp(cmd, "v") == 0 && i + 1 < argc) {
+      char * v = getenv(argv[i + 1]);
+      fputs((v == NULL ? "<no such variable>" : v), stdout);
+      fputc('\n', stdout);
+      fflush(stdout);
+      i += 2;
+    } else {
+      fputs("<bad argument>\n", stderr);
+      return 2;
+    }
+  }
+  return 0;
+}

diff --git a/testsuite/tests/lib-unix/common/rename.ml b/testsuite/tests/lib-unix/common/rename.ml
new file mode 100644 (file)
index 0000000..713c6dd
--- /dev/null
+++ b/testsuite/tests/lib-unix/common/rename.ml
@@ -0,0 +1,52 @@
+(* Test the Unix.rename function *)
+
+let writefile filename contents =
+  let oc = open_out_bin filename in
+  output_string oc contents;
+  close_out oc
+
+let readfile filename =
+  let ic = open_in_bin filename in
+  let sz = in_channel_length ic in
+  let contents = really_input_string ic sz in
+  close_in ic;
+  contents
+
+let safe_remove filename =
+  try Sys.remove filename with Sys_error _ -> ()
+
+let testrename f1 f2 contents =
+  try
+    Unix.rename f1 f2;
+    if readfile f2 <> contents then print_string "wrong contents!"
+    else if Sys.file_exists f1 then print_string "initial file still exists!"
+    else print_string "passed"
+  with Unix.Unix_error(err, _, _) ->
+    print_string "Unix_error exception: "; print_string (Unix.error_message err)
+
+let testfailure f1 f2 =
+  try
+    Unix.rename f1 f2; print_string "should fail but doesn't!"
+  with Unix.Unix_error _ ->
+    print_string "fails as expected"
+
+let _ =
+  let f1 = "file1.dat" and f2 = "file2.dat" in
+  safe_remove f1; safe_remove f2;
+  print_string "Rename to nonexisting file: ";
+  writefile f1 "abc";
+  testrename f1 f2 "abc";
+  print_newline();
+  print_string "Rename to existing file: ";
+  writefile f1 "def";
+  writefile f2 "xyz";
+  testrename f1 f2 "def";
+  print_newline();
+  print_string "Renaming a nonexisting file: ";
+  testfailure f1 f2;
+  print_newline();
+  print_string "Renaming to a nonexisting directory: ";
+  writefile f1 "abc";
+  testfailure f1 (Filename.concat "nosuchdir" f2);
+  print_newline();
+  safe_remove f1; safe_remove f2

diff --git a/testsuite/tests/lib-unix/common/rename.reference b/testsuite/tests/lib-unix/common/rename.reference
new file mode 100644 (file)
index 0000000..d5ec88d
--- /dev/null
+++ b/testsuite/tests/lib-unix/common/rename.reference
@@ -0,0 +1,4 @@
+Rename to nonexisting file: passed
+Rename to existing file: passed
+Renaming a nonexisting file: fails as expected
+Renaming to a nonexisting directory: fails as expected

diff --git a/testsuite/tests/lib-unix/common/test_unix_cmdline.ml b/testsuite/tests/lib-unix/common/test_unix_cmdline.ml
new file mode 100644 (file)
index 0000000..f0f7679
--- /dev/null
+++ b/testsuite/tests/lib-unix/common/test_unix_cmdline.ml
@@ -0,0 +1,28 @@
+open Unix
+
+let prog_name = "cmdline_prog.exe"
+
+let run args =
+  let out, inp = pipe () in
+  let in_chan = in_channel_of_descr out in
+  set_binary_mode_in in_chan false;
+  let pid = create_process ("./" ^ prog_name) (Array.of_list (prog_name :: args)) Unix.stdin inp Unix.stderr in
+  List.iter (fun arg ->
+      let s = input_line in_chan in
+      Printf.printf "%S -> %S [%s]\n" arg s (if s = arg then "OK" else "FAIL")
+    ) args;
+  close_in in_chan;
+  let _, exit = waitpid [] pid in
+  assert (exit = WEXITED 0)
+
+let () =
+  List.iter run
+    [
+      [""; ""; "\t \011"];
+      ["a"; "b"; "c.txt@!"];
+      ["\""];
+      [" "; " a "; "  \" \\\" "];
+      [" \\ \\ \\\\\\"];
+      [" \"hola \""];
+      ["a\tb"];
+    ]

diff --git a/testsuite/tests/lib-unix/common/test_unix_cmdline.reference b/testsuite/tests/lib-unix/common/test_unix_cmdline.reference
new file mode 100644 (file)
index 0000000..7d2f2c2
--- /dev/null
+++ b/testsuite/tests/lib-unix/common/test_unix_cmdline.reference
@@ -0,0 +1,13 @@
+"" -> "" [OK]
+"" -> "" [OK]
+"\t \011" -> "\t \011" [OK]
+"a" -> "a" [OK]
+"b" -> "b" [OK]
+"c.txt@!" -> "c.txt@!" [OK]
+"\"" -> "\"" [OK]
+" " -> " " [OK]
+" a " -> " a " [OK]
+"  \" \\\" " -> "  \" \\\" " [OK]
+" \\ \\ \\\\\\" -> " \\ \\ \\\\\\" [OK]
+" \"hola \"" -> " \"hola \"" [OK]
+"a\tb" -> "a\tb" [OK]

diff --git a/testsuite/tests/lib-unix/common/wait_nohang.ml b/testsuite/tests/lib-unix/common/wait_nohang.ml
new file mode 100644 (file)
index 0000000..7af3838
--- /dev/null
+++ b/testsuite/tests/lib-unix/common/wait_nohang.ml
@@ -0,0 +1,12 @@
+let () =
+  let fd = Unix.openfile "plop" [O_CREAT; O_WRONLY] 0o666 in
+  let pid =
+    Unix.create_process "echo" [|"echo"; "toto"|] Unix.stdin fd Unix.stderr
+  in
+  Unix.close fd;
+  while fst (Unix.waitpid [WNOHANG] pid) = 0 do
+    Unix.sleepf 0.001
+  done;
+  match Sys.remove "plop" with
+  | () ->  print_endline "OK"
+  | exception (Sys_error _) -> print_endline "ERROR"

diff --git a/testsuite/tests/lib-unix/common/wait_nohang.reference b/testsuite/tests/lib-unix/common/wait_nohang.reference
new file mode 100644 (file)
index 0000000..d86bac9
--- /dev/null
+++ b/testsuite/tests/lib-unix/common/wait_nohang.reference
@@ -0,0 +1 @@
+OK

diff --git a/testsuite/tests/lib-unix/dup.ml b/testsuite/tests/lib-unix/dup.ml
deleted file mode 100644 (file)
index d296cb9..0000000
--- a/testsuite/tests/lib-unix/dup.ml
+++ /dev/null
@@ -1,5 +0,0 @@
-let _ =
-  let f = Unix.dup ~cloexec:true Unix.stdout in
-  let txt = "Some output\n" in
-  ignore (Unix.write_substring f txt 0 (String.length txt));
-  Unix.close f

diff --git a/testsuite/tests/lib-unix/dup.reference b/testsuite/tests/lib-unix/dup.reference
deleted file mode 100644 (file)
index 85cc16f..0000000
--- a/testsuite/tests/lib-unix/dup.reference
+++ /dev/null
@@ -1 +0,0 @@
-Some output

diff --git a/testsuite/tests/lib-unix/dup2.ml b/testsuite/tests/lib-unix/dup2.ml
deleted file mode 100644 (file)
index 055d7e5..0000000
--- a/testsuite/tests/lib-unix/dup2.ml
+++ /dev/null
@@ -1,24 +0,0 @@
-let cat file =
-  let fd = Unix.openfile file [Unix.O_RDONLY] 0 in
-  let buf = Bytes.create 1024 in
-  let rec cat () =
-    let n = Unix.read fd buf 0 (Bytes.length buf) in
-    if n > 0 then (ignore(Unix.write Unix.stdout buf 0 n); cat ())
-  in cat (); Unix.close fd
-
-let out fd txt =
-  ignore (Unix.write_substring fd txt 0 (String.length txt))
-
-let _ =
-  let fd =
-    Unix.(openfile "./tmp.txt"
-                   [O_WRONLY;O_TRUNC;O_CREAT;O_SHARE_DELETE]
-                  0o600) in
-  out fd "---\n";
-  Unix.dup2 ~cloexec:true fd Unix.stderr;
-  Unix.close fd;
-  out Unix.stderr "Some output\n";
-  cat "./tmp.txt";
-  Sys.remove "./tmp.txt"
-
-    

diff --git a/testsuite/tests/lib-unix/dup2.reference b/testsuite/tests/lib-unix/dup2.reference
deleted file mode 100644 (file)
index 2f5a485..0000000
--- a/testsuite/tests/lib-unix/dup2.reference
+++ /dev/null
@@ -1,2 +0,0 @@
----
-Some output

diff --git a/testsuite/tests/lib-unix/fdstatus.c b/testsuite/tests/lib-unix/fdstatus.c
deleted file mode 100644 (file)
index be8c6e5..0000000
--- a/testsuite/tests/lib-unix/fdstatus.c
+++ /dev/null
@@ -1,73 +0,0 @@
-/* Check if file descriptors are open or not */
-
-#include <stdio.h>
-#include <stdlib.h>
-
-#ifdef _WIN32
-
-#define WIN32_LEAN_AND_MEAN
-#include <wtypes.h>
-#include <winbase.h>
-#include <winerror.h>
-
-void process_fd(char * s)
-{
-  int fd;
-  HANDLE h;
-  DWORD flags;
-
-#ifdef _WIN64
-  h = (HANDLE) _atoi64(s);
-#else
-  h = (HANDLE) atoi(s);
-#endif
-  if (GetHandleInformation(h, &flags)) {
-    printf("open\n");
-  } else if (GetLastError() == ERROR_INVALID_HANDLE) {
-    printf("closed\n");
-  } else {
-    printf("error %d\n", GetLastError());
-  }
-}
-
-#else
-
-#include <limits.h>
-#include <string.h>
-#include <errno.h>
-#include <sys/types.h>
-#include <sys/stat.h>
-#include <unistd.h>
-
-void process_fd(char * s)
-{
-  long n;
-  int fd;
-  char * endp;
-  struct stat st;
-  n = strtol(s, &endp, 0);
-  if (*endp != 0 || n < 0 || n > (long) INT_MAX) {
-    printf("parsing error\n");
-    return;
-  }
-  fd = (int) n;
-  if (fstat(fd, &st) != -1) {
-    printf("open\n");
-  } else if (errno == EBADF) {
-    printf("closed\n");
-  } else {
-    printf("error %s\n", strerror(errno));
-  }
-}
-
-#endif
-
-int main(int argc, char ** argv)
-{
-  int i;
-  for (i = 1; i < argc; i++) {
-    printf("#%d: ", i);
-    process_fd(argv[i]);
-  }
-  return 0;
-}

diff --git a/testsuite/tests/lib-unix/isatty/Makefile b/testsuite/tests/lib-unix/isatty/Makefile
new file mode 100644 (file)
index 0000000..ea6482f
--- /dev/null
+++ b/testsuite/tests/lib-unix/isatty/Makefile
@@ -0,0 +1,9 @@
+BASEDIR=../../..
+LIBRARIES=unix
+ADD_COMPFLAGS=-I $(OTOPDIR)/otherlibs/$(UNIXLIBVAR)unix
+LD_PATH=$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix
+MAIN_MODULE=isatty
+PROGRAM_ARGS=2>/dev/null </dev/null
+
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/lib-unix/isatty/isatty_std.ml b/testsuite/tests/lib-unix/isatty/isatty_std.ml
new file mode 100644 (file)
index 0000000..4ee99cf
--- /dev/null
+++ b/testsuite/tests/lib-unix/isatty/isatty_std.ml
@@ -0,0 +1,7 @@
+Printf.printf
+  "Unix.isatty Unix.stdin = %b\n\
+   Unix.isatty Unix.stdout = %b\n\
+   Unix.isatty Unix.stderr = %b\n"
+  (Unix.isatty Unix.stdin)
+  (Unix.isatty Unix.stdout)
+  (Unix.isatty Unix.stderr)

diff --git a/testsuite/tests/lib-unix/isatty/isatty_std.reference b/testsuite/tests/lib-unix/isatty/isatty_std.reference
new file mode 100644 (file)
index 0000000..9a32009
--- /dev/null
+++ b/testsuite/tests/lib-unix/isatty/isatty_std.reference
@@ -0,0 +1,3 @@
+Unix.isatty Unix.stdin = false
+Unix.isatty Unix.stdout = false
+Unix.isatty Unix.stderr = false

diff --git a/testsuite/tests/lib-unix/isatty/isatty_tty.ml b/testsuite/tests/lib-unix/isatty/isatty_tty.ml
new file mode 100644 (file)
index 0000000..d2589ef
--- /dev/null
+++ b/testsuite/tests/lib-unix/isatty/isatty_tty.ml
@@ -0,0 +1,7 @@
+let console =
+  try
+    Unix.(openfile "/dev/tty" [O_RDWR] 0)
+  with _ ->
+    Unix.(openfile "CONIN$" [O_RDWR] 0)
+in
+Printf.printf "/dev/tty = %b\n" (Unix.isatty console)

diff --git a/testsuite/tests/lib-unix/isatty/isatty_tty.precheck b/testsuite/tests/lib-unix/isatty/isatty_tty.precheck
new file mode 100644 (file)
index 0000000..3c64e1b
--- /dev/null
+++ b/testsuite/tests/lib-unix/isatty/isatty_tty.precheck
@@ -0,0 +1 @@
+test "$TOOLCHAIN" = "msvc" || test "$TOOLCHAIN" = "mingw"

diff --git a/testsuite/tests/lib-unix/isatty/isatty_tty.reference b/testsuite/tests/lib-unix/isatty/isatty_tty.reference
new file mode 100644 (file)
index 0000000..6ac4059
--- /dev/null
+++ b/testsuite/tests/lib-unix/isatty/isatty_tty.reference
@@ -0,0 +1 @@
+/dev/tty = true

diff --git a/testsuite/tests/lib-unix/pipe_eof.ml b/testsuite/tests/lib-unix/pipe_eof.ml
deleted file mode 100644 (file)
index 19f5258..0000000
--- a/testsuite/tests/lib-unix/pipe_eof.ml
+++ /dev/null
@@ -1,34 +0,0 @@
-let drain pipe =
-  let max = 2048 in
-  let buf = Buffer.create 2048 in
-  let tmp = Bytes.create max in
-  while begin
-    try
-      let len = Unix.read pipe tmp 0 max in
-      Buffer.add_subbytes buf tmp 0 len;
-      len > 0
-    with Unix.Unix_error (Unix.EPIPE, _, _) when false ->
-      false
-  end do () done;
-  Buffer.contents buf
-;;
-
-let run exe args =
-  let out_in, out_out = Unix.pipe () in
-  let err_in, err_out = Unix.pipe () in
-  let args = Array.append [| exe |] args in
-  let pid = Unix.create_process exe args Unix.stdin out_out err_out in
-  Unix.close out_out;
-  Unix.close err_out;
-  let output = drain out_in in
-  let error = drain err_in in
-  Unix.close out_in;
-  Unix.close err_in;
-  let _pid, status = Unix.waitpid [ ] pid in
-  status, output, error
-;;
-
-let _ =
-  ignore (run "cp" [||]);
-  print_endline "success"
-;;

diff --git a/testsuite/tests/lib-unix/pipe_eof.reference b/testsuite/tests/lib-unix/pipe_eof.reference
deleted file mode 100644 (file)
index 2e9ba47..0000000
--- a/testsuite/tests/lib-unix/pipe_eof.reference
+++ /dev/null
@@ -1 +0,0 @@
-success

diff --git a/testsuite/tests/lib-unix/redirections.ml b/testsuite/tests/lib-unix/redirections.ml
deleted file mode 100644 (file)
index ed1712a..0000000
--- a/testsuite/tests/lib-unix/redirections.ml
+++ /dev/null
@@ -1,113 +0,0 @@
-let cat file =
-  let fd = Unix.openfile file [Unix.O_RDONLY] 0 in
-  let buf = Bytes.create 1024 in
-  let rec cat () =
-    let n = Unix.read fd buf 0 (Bytes.length buf) in
-    if n > 0 then (ignore(Unix.write Unix.stdout buf 0 n); cat ())
-  in cat (); Unix.close fd
-
-let out fd txt =
-  ignore (Unix.write_substring fd txt 0 (String.length txt))
-
-let refl =
-  Filename.concat Filename.current_dir_name "reflector.exe"
-
-let test_createprocess () =
-  let f_out =
-    Unix.(openfile "./tmpout.txt" [O_WRONLY;O_TRUNC;O_CREAT;O_CLOEXEC] 0o600) in
-  let f_err =
-    Unix.(openfile "./tmperr.txt" [O_WRONLY;O_TRUNC;O_CREAT;O_CLOEXEC] 0o600) in
-  let (p_exit, p_entrance) =
-    Unix.pipe ~cloexec:true () in
-  let pid =
-    Unix.create_process_env
-       refl
-       [| refl; "i2o"; "i2e"; "o"; "123"; "e"; "456"; "i2o"; "v"; "XVAR" |]
-       [| "XVAR=xvar" |]
-       p_exit f_out f_err in
-  out p_entrance "aaaa\n";
-  out p_entrance "bbbb\n";
-  Unix.close p_entrance;
-  let (_, status) = Unix.waitpid [] pid in
-  Unix.close p_exit; Unix.close f_out; Unix.close f_err;
-  if status <> Unix.WEXITED 0 then
-    out Unix.stdout "!!! reflector exited with an error\n";
-  out Unix.stdout "---- File tmpout.txt\n";
-  cat "./tmpout.txt";
-  out Unix.stdout "---- File tmperr.txt\n";
-  cat "./tmperr.txt";
-  Sys.remove "./tmpout.txt";
-  Sys.remove "./tmperr.txt"
-
-let test_2ampsup1 () =    (* 2>&1 redirection, cf. GPR#1105 *)
-  let pid =
-    Unix.create_process
-      refl
-      [| refl; "o"; "123"; "e"; "456"; "o"; "789" |]
-      Unix.stdin Unix.stdout Unix.stdout in
-  let (_, status) = Unix.waitpid [] pid in
-  if status <> Unix.WEXITED 0 then
-    out Unix.stdout "!!! reflector exited with an error\n"
-
-let test_swap12 () =    (* swapping stdout and stderr *)
-  (* The test harness doesn't let us check contents of stderr,
-     so just output on stdout (after redirection) *)
-  let pid =
-    Unix.create_process
-      refl
-      [| refl; "e"; "123" |]
-      Unix.stdin Unix.stderr Unix.stdout in
-  let (_, status) = Unix.waitpid [] pid in
-  if status <> Unix.WEXITED 0 then
-    out Unix.stdout "!!! reflector exited with an error\n"
-
-let test_open_process_in () =
-  let ic = Unix.open_process_in (refl ^ " o 123 o 456") in
-  out Unix.stdout (input_line ic ^ "\n");
-  out Unix.stdout (input_line ic ^ "\n");
-  let status = Unix.close_process_in ic in
-  if status <> Unix.WEXITED 0 then
-    out Unix.stdout "!!! reflector exited with an error\n"
-
-let test_open_process_out () =
-  let oc = Unix.open_process_out (refl ^ " i2o i2o i2o") in
-  output_string oc "aa\nbbbb\n"; close_out oc;
-  let status = Unix.close_process_out oc in
-  if status <> Unix.WEXITED 0 then
-    out Unix.stdout "!!! reflector exited with an error\n"
-
-let test_open_process_full () =
-  let ((o, i, e) as res) =
-    Unix.open_process_full
-      (refl ^ " o 123 i2o e 456 i2e v XVAR")
-      [|"XVAR=xvar"|] in
-  output_string i "aa\nbbbb\n"; close_out i;
-  for _i = 1 to 3 do 
-    out Unix.stdout (input_line o ^ "\n")
-  done;
-  for _i = 1 to 2 do
-    out Unix.stdout (input_line e ^ "\n")
-  done;
-  let status = Unix.close_process_full res in
-  if status <> Unix.WEXITED 0 then
-    out Unix.stdout "!!! reflector exited with an error\n"
-
-let _ =
-  (* The following 'close' makes things more difficult.
-     Under Unix it works fine, but under Win32 create_process 
-     gives an error if one of the standard handles is closed. *)
-  (* Unix.close Unix.stdin; *)
-  out Unix.stdout "** create_process\n";
-  test_createprocess();
-  out Unix.stdout "** create_process 2>&1 redirection\n";
-  test_2ampsup1();
-  out Unix.stdout "** create_process swap 1-2\n";
-  test_swap12();
-  out Unix.stdout "** open_process_in\n";
-  test_open_process_in();
-  out Unix.stdout "** open_process_out\n";
-  test_open_process_out();
-  out Unix.stdout "** open_process_full\n";
-  test_open_process_full()
-
-

diff --git a/testsuite/tests/lib-unix/redirections.reference b/testsuite/tests/lib-unix/redirections.reference
deleted file mode 100644 (file)
index c0da174..0000000
--- a/testsuite/tests/lib-unix/redirections.reference
+++ /dev/null
@@ -1,28 +0,0 @@
-** create_process
----- File tmpout.txt
-aaaa
-123
-<end of file>
-xvar
----- File tmperr.txt
-bbbb
-456
-** create_process 2>&1 redirection
-123
-456
-789
-** create_process swap 1-2
-123
-** open_process_in
-123
-456
-** open_process_out
-aa
-bbbb
-<end of file>
-** open_process_full
-123
-aa
-xvar
-456
-bbbb

diff --git a/testsuite/tests/lib-unix/reflector.c b/testsuite/tests/lib-unix/reflector.c
deleted file mode 100644 (file)
index f8bbbf3..0000000
--- a/testsuite/tests/lib-unix/reflector.c
+++ /dev/null
@@ -1,74 +0,0 @@
-#include <stdio.h>
-#include <string.h>
-#include <stdlib.h>
-#if defined(_WIN32)
-#include <fcntl.h>
-#include <io.h>
-#endif
-
-/* A tool to read data from standard input and send it to standard
-   output or standard error. */
-
-void copyline(FILE * in, FILE * out)
-{
-  int c;
-  do {
-    c = getc(in);
-    if (c == EOF) {
-      fputs("<end of file>\n", out);
-      break;
-    }
-    putc(c, out);
-  } while (c != '\n');
-  fflush(out);
-}
-
-/* Command language:
-     i2o       copy one line from stdin to stdout
-     i2e       copy one line from stdin to stderr
-     o <txt>   write <txt> plus newline to stdout
-     e <txt>   write <txt> plus newline to stderr
-     v <var>   write value of environment variable <env> to stdout
-*/
-
-int main(int argc, char ** argv)
-{
-  int i;
-  char * cmd;
-#if defined(_WIN32)
-  _setmode(_fileno(stdin), _O_BINARY);
-  _setmode(_fileno(stdout), _O_BINARY);
-  _setmode(_fileno(stderr), _O_BINARY);
-#endif
-  i = 1;
-  while (i < argc) {
-    cmd = argv[i];
-    if (strcmp(cmd, "i2o") == 0) {
-      copyline(stdin, stdout);
-      i++;
-    } else if (strcmp(cmd, "i2e") == 0) {
-      copyline(stdin, stderr);
-      i++;
-    } else if (strcmp(cmd, "o") == 0 && i + 1 < argc) {
-      fputs(argv[i + 1], stdout);
-      fputc('\n', stdout);
-      fflush(stdout);
-      i += 2;
-    } else if (strcmp(cmd, "e") == 0 && i + 1 < argc) {
-      fputs(argv[i + 1], stderr);
-      fputc('\n', stderr);
-      fflush(stderr);
-      i += 2;
-    } else if (strcmp(cmd, "v") == 0 && i + 1 < argc) {
-      char * v = getenv(argv[i + 1]);
-      fputs((v == NULL ? "<no such variable>" : v), stdout);
-      fputc('\n', stdout);
-      fflush(stdout);
-      i += 2;
-    } else {
-      fputs("<bad argument>\n", stderr);
-      return 2;
-    }
-  }
-  return 0;
-}

diff --git a/testsuite/tests/lib-unix/test_unix_cmdline.ml b/testsuite/tests/lib-unix/test_unix_cmdline.ml
deleted file mode 100644 (file)
index f0f7679..0000000
--- a/testsuite/tests/lib-unix/test_unix_cmdline.ml
+++ /dev/null
@@ -1,28 +0,0 @@
-open Unix
-
-let prog_name = "cmdline_prog.exe"
-
-let run args =
-  let out, inp = pipe () in
-  let in_chan = in_channel_of_descr out in
-  set_binary_mode_in in_chan false;
-  let pid = create_process ("./" ^ prog_name) (Array.of_list (prog_name :: args)) Unix.stdin inp Unix.stderr in
-  List.iter (fun arg ->
-      let s = input_line in_chan in
-      Printf.printf "%S -> %S [%s]\n" arg s (if s = arg then "OK" else "FAIL")
-    ) args;
-  close_in in_chan;
-  let _, exit = waitpid [] pid in
-  assert (exit = WEXITED 0)
-
-let () =
-  List.iter run
-    [
-      [""; ""; "\t \011"];
-      ["a"; "b"; "c.txt@!"];
-      ["\""];
-      [" "; " a "; "  \" \\\" "];
-      [" \\ \\ \\\\\\"];
-      [" \"hola \""];
-      ["a\tb"];
-    ]

diff --git a/testsuite/tests/lib-unix/test_unix_cmdline.reference b/testsuite/tests/lib-unix/test_unix_cmdline.reference
deleted file mode 100644 (file)
index 7d2f2c2..0000000
--- a/testsuite/tests/lib-unix/test_unix_cmdline.reference
+++ /dev/null
@@ -1,13 +0,0 @@
-"" -> "" [OK]
-"" -> "" [OK]
-"\t \011" -> "\t \011" [OK]
-"a" -> "a" [OK]
-"b" -> "b" [OK]
-"c.txt@!" -> "c.txt@!" [OK]
-"\"" -> "\"" [OK]
-" " -> " " [OK]
-" a " -> " a " [OK]
-"  \" \\\" " -> "  \" \\\" " [OK]
-" \\ \\ \\\\\\" -> " \\ \\ \\\\\\" [OK]
-" \"hola \"" -> " \"hola \"" [OK]
-"a\tb" -> "a\tb" [OK]

diff --git a/testsuite/tests/lib-unix/unix-execvpe/Makefile b/testsuite/tests/lib-unix/unix-execvpe/Makefile
new file mode 100644 (file)
index 0000000..91fbaa8
--- /dev/null
+++ b/testsuite/tests/lib-unix/unix-execvpe/Makefile
@@ -0,0 +1,32 @@
+BASEDIR=../../..
+LIBRARIES=unix
+ADD_COMPFLAGS=-I $(OTOPDIR)/otherlibs/$(UNIXLIBVAR)unix
+LD_PATH=$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix
+MAIN_MODULE=exec
+
+test:
+       @if grep -q HAS_EXECVPE $(OTOPDIR)/byterun/caml/s.h; \
+        then echo " ... testing => skipped (using the system-provided execvpe())"; \
+        else $(MAKE) compile && $(SET_LD_PATH) $(MAKE) myrun; \
+        fi
+
+myrun:
+       @printf " ... testing with"
+       @if $(NATIVECODE_ONLY); then : ; else \
+          printf " ocamlc"; \
+          ./exec.run "$(MYRUNTIME) ./program.byte$(EXE)" $(EXEC_ARGS) \
+                       >$(MAIN_MODULE).result \
+          && $(DIFF) $(MAIN_MODULE).reference $(MAIN_MODULE).result \
+             >/dev/null; \
+        fi \
+       && if $(BYTECODE_ONLY); then : ; else \
+            printf " ocamlopt"; \
+            ./exec.run ./program.native$(EXE) $(EXEC_ARGS) \
+                                    > $(MAIN_MODULE).result \
+            && $(DIFF) $(MAIN_MODULE).reference $(MAIN_MODULE).result \
+                       >/dev/null; \
+          fi \
+       && echo " => passed" || echo " => failed"
+
+include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/lib-unix/unix-execvpe/exec.ml b/testsuite/tests/lib-unix/unix-execvpe/exec.ml
new file mode 100644 (file)
index 0000000..8eb6232
--- /dev/null
+++ b/testsuite/tests/lib-unix/unix-execvpe/exec.ml
@@ -0,0 +1,15 @@
+open Printf
+
+let _ =
+  let arg = Array.sub Sys.argv 1 (Array.length Sys.argv - 1) in
+  let env = Array.append [|"FOO=foo"|] (Unix.environment()) in
+  try
+    Unix.execvpe arg.(0) arg env
+  with
+  | Unix.Unix_error(Unix.ENOENT, _, arg) ->
+      eprintf "No such file %s\n" arg; exit 2
+  | Unix.Unix_error(Unix.EACCES, _, arg) ->
+      eprintf "Permission denied %s\n" arg; exit 2
+  | Unix.Unix_error(err, fn, arg) ->
+      eprintf "Other error %s - %s - %s\n" (Unix.error_message err) fn arg;
+      exit 4

diff --git a/testsuite/tests/lib-unix/unix-execvpe/exec.reference b/testsuite/tests/lib-unix/unix-execvpe/exec.reference
new file mode 100644 (file)
index 0000000..b8c8bb4
--- /dev/null
+++ b/testsuite/tests/lib-unix/unix-execvpe/exec.reference
@@ -0,0 +1,19 @@
+## Test 1: a binary program in the path
+## Test 2: a #! script in the path
+--- subdir/script1
+FOO is foo, BAR is bar, BUZ is 
+3 arguments:  2 3 4
+## Test 3: a script without #! in the path
+--- subdir/script2
+FOO is foo, BAR is bar, BUZ is 
+3 arguments:  5 6 7
+## Test 4: a script in the current directory
+--- ./script3
+FOO is foo, BAR is bar, BUZ is 
+2 arguments:  8 9
+## Test 5: a non-existent program
+No such file nosuchprogram
+## Test 6: a non-executable program
+Permission denied nonexec
+## Test 7: a script in the current directory
+No such file script3

diff --git a/testsuite/tests/lib-unix/unix-execvpe/exec.run b/testsuite/tests/lib-unix/unix-execvpe/exec.run
new file mode 100755 (executable)
index 0000000..86f8eb8
--- /dev/null
+++ b/testsuite/tests/lib-unix/unix-execvpe/exec.run
@@ -0,0 +1,27 @@
+#!/bin/sh
+
+program=$1
+if test -z "$program"; then echo "Usage: exec.run <program>" 1&>2; exit 2; fi
+
+exec 2>&1
+
+export PATH="/bin:/usr/bin:./subdir:"
+export BAR=bar
+
+echo "## Test 1: a binary program in the path"
+$program ls / > /dev/null || echo "ls failed"
+echo "## Test 2: a #! script in the path"
+$program script1 2 3 4 || echo "script1 failed"
+echo "## Test 3: a script without #! in the path"
+$program script2 5 6 7 || echo "script2 failed"
+echo "## Test 4: a script in the current directory"
+$program script3 8 9 || echo "script3 failed"
+echo "## Test 5: a non-existent program"
+$program nosuchprogram
+echo "## Test 6: a non-executable program"
+$program nonexec
+
+export PATH="/bin:/usr/bin:./subdir"
+echo "## Test 7: a script in the current directory"
+$program script3 9 && echo "script3 should have failed"
+exit 0

diff --git a/testsuite/tests/lib-unix/unix-execvpe/script3 b/testsuite/tests/lib-unix/unix-execvpe/script3
new file mode 100755 (executable)
index 0000000..931aac3
--- /dev/null
+++ b/testsuite/tests/lib-unix/unix-execvpe/script3
@@ -0,0 +1,5 @@
+#!/bin/sh
+echo "--- ./script3"
+echo "FOO is $FOO, BAR is $BAR, BUZ is $BUZ"
+echo "$# arguments:  $*"
+

diff --git a/testsuite/tests/lib-unix/unix-execvpe/subdir/nonexec b/testsuite/tests/lib-unix/unix-execvpe/subdir/nonexec
new file mode 100644 (file)
index 0000000..b76ada7
--- /dev/null
+++ b/testsuite/tests/lib-unix/unix-execvpe/subdir/nonexec
@@ -0,0 +1,2 @@
+echo "This script lacks the x bit and should not run!"
+

diff --git a/testsuite/tests/lib-unix/unix-execvpe/subdir/script1 b/testsuite/tests/lib-unix/unix-execvpe/subdir/script1
new file mode 100755 (executable)
index 0000000..e59ab0a
--- /dev/null
+++ b/testsuite/tests/lib-unix/unix-execvpe/subdir/script1
@@ -0,0 +1,4 @@
+#!/bin/sh
+echo "--- subdir/script1"
+echo "FOO is $FOO, BAR is $BAR, BUZ is $BUZ"
+echo "$# arguments:  $*"

diff --git a/testsuite/tests/lib-unix/unix-execvpe/subdir/script2 b/testsuite/tests/lib-unix/unix-execvpe/subdir/script2
new file mode 100755 (executable)
index 0000000..8345744
--- /dev/null
+++ b/testsuite/tests/lib-unix/unix-execvpe/subdir/script2
@@ -0,0 +1,3 @@
+echo "--- subdir/script2"
+echo "FOO is $FOO, BAR is $BAR, BUZ is $BUZ"
+echo "$# arguments:  $*"

diff --git a/testsuite/tests/lib-unix/win-env/Makefile b/testsuite/tests/lib-unix/win-env/Makefile
new file mode 100755 (executable)
index 0000000..9077597
--- /dev/null
+++ b/testsuite/tests/lib-unix/win-env/Makefile
@@ -0,0 +1,18 @@
+BASEDIR=../../..
+LIBRARIES=unix
+ADD_COMPFLAGS= \
+       -I $(OTOPDIR)/otherlibs/$(UNIXLIBVAR)unix \
+       -strict-sequence -safe-string -w A -warn-error A
+LD_PATH=$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix
+C_FILES=stubs
+
+.PHONY: test
+test:
+       @if echo 'let () = exit (if Sys.win32 then 0 else 1)' | $(OCAML) -stdin; then \
+         $(MAKE) check; \
+       else \
+         $(MAKE) SKIP=true C_FILES= run-all; \
+       fi
+
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/lib-unix/win-env/stubs.c b/testsuite/tests/lib-unix/win-env/stubs.c
new file mode 100644 (file)
index 0000000..607103a
--- /dev/null
+++ b/testsuite/tests/lib-unix/win-env/stubs.c
@@ -0,0 +1,20 @@
+#define CAML_INTERNALS
+
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include <caml/memory.h>
+#include <caml/fail.h>
+#include <caml/osdeps.h>
+
+#include <windows.h>
+
+CAMLprim value caml_SetEnvironmentVariable(value s1, value s2)
+{
+  WCHAR *w1, *w2;
+  w1 = caml_stat_strdup_to_utf16(String_val(s1));
+  w2 = caml_stat_strdup_to_utf16(String_val(s2));
+  SetEnvironmentVariableW(w1, w2);
+  caml_stat_free(w1);
+  caml_stat_free(w2);
+  return Val_unit;
+}

diff --git a/testsuite/tests/lib-unix/win-env/test_env.ml b/testsuite/tests/lib-unix/win-env/test_env.ml
new file mode 100755 (executable)
index 0000000..a13da93
--- /dev/null
+++ b/testsuite/tests/lib-unix/win-env/test_env.ml
@@ -0,0 +1,30 @@
+external set_environment_variable: string -> string -> unit = "caml_SetEnvironmentVariable"
+
+let find_env s =
+  let env = Unix.environment () in
+  let rec loop i =
+    if i >= Array.length env then
+      None
+    else begin
+      let e = env.(i) in
+      let pos = String.index e '=' in
+      if String.sub e 0 pos = s then
+        Some (String.sub e (pos+1) (String.length e - pos - 1))
+      else
+        loop (i+1)
+    end
+  in
+  loop 0
+
+let print title = function
+  | None ->
+      Printf.printf "%s -> None\n%!" title
+  | Some s ->
+      Printf.printf "%s -> Some %S\n%!" title s
+
+let foo = "FOO"
+
+let () =
+  set_environment_variable foo "BAR";
+  print "Sys.getenv FOO" (Sys.getenv_opt foo);
+  print "Unix.environment FOO" (find_env foo)

diff --git a/testsuite/tests/lib-unix/win-env/test_env.reference b/testsuite/tests/lib-unix/win-env/test_env.reference
new file mode 100644 (file)
index 0000000..63bdda3
--- /dev/null
+++ b/testsuite/tests/lib-unix/win-env/test_env.reference
@@ -0,0 +1,2 @@
+Sys.getenv FOO -> None
+Unix.environment FOO -> None

diff --git a/testsuite/tests/lib-unix/win-env/test_env2.ml b/testsuite/tests/lib-unix/win-env/test_env2.ml
new file mode 100755 (executable)
index 0000000..f2616ef
--- /dev/null
+++ b/testsuite/tests/lib-unix/win-env/test_env2.ml
@@ -0,0 +1,17 @@
+(* This test is disabled (see test_env2.precheck) as it fails due to MPR#4499:
+   the Windows POSIX environment does not get updated when using the native
+   Windows API SetEnvironmentVariable. *)
+
+external set_environment_variable: string -> string -> unit = "caml_SetEnvironmentVariable"
+
+let print title = function
+  | None ->
+      Printf.printf "%s -> None\n%!" title
+  | Some s ->
+      Printf.printf "%s -> Some %S\n%!" title s
+
+let foo = "FOO"
+
+let () =
+  set_environment_variable foo "BAR";
+  print "Sys.getenv FOO" (Sys.getenv_opt foo)

diff --git a/testsuite/tests/lib-unix/win-env/test_env2.precheck b/testsuite/tests/lib-unix/win-env/test_env2.precheck
new file mode 100755 (executable)
index 0000000..8a1936f
--- /dev/null
+++ b/testsuite/tests/lib-unix/win-env/test_env2.precheck
@@ -0,0 +1,4 @@
+# test_env2.ml disabled because it fails due to the fact that
+# Windows POSIX environment is not updated when using the native
+# API SetEnvironmentVariable (see MPR#4499)
+exit 1

diff --git a/testsuite/tests/lib-unix/win-env/test_env2.reference b/testsuite/tests/lib-unix/win-env/test_env2.reference
new file mode 100755 (executable)
index 0000000..19e10cb
--- /dev/null
+++ b/testsuite/tests/lib-unix/win-env/test_env2.reference
@@ -0,0 +1 @@
+Sys.getenv FOO -> Some "BAR"

diff --git a/testsuite/tests/lib-unix/win-stat/Makefile b/testsuite/tests/lib-unix/win-stat/Makefile
new file mode 100644 (file)
index 0000000..3018bdf
--- /dev/null
+++ b/testsuite/tests/lib-unix/win-stat/Makefile
@@ -0,0 +1,20 @@
+BASEDIR=../../..
+LIBRARIES=unix
+ADD_COMPFLAGS=-I $(OTOPDIR)/otherlibs/$(UNIXLIBVAR)unix
+LD_PATH=$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix
+C_FILES=fakeclock
+MAIN_MODULE=test
+TEST_TEMP_FILES=dst-file non-dst-file
+
+ifeq ($(OS),Windows_NT)
+test:
+       @TZ=utc touch -m -t 201707011200 dst-file
+       @TZ=utc touch -m -t 201702011200 non-dst-file
+       @$(MAKE) default
+else
+skip:
+       @echo " ... testing => skipped (not on Windows)"
+endif
+
+include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/lib-unix/win-stat/fakeclock.c b/testsuite/tests/lib-unix/win-stat/fakeclock.c
new file mode 100644 (file)
index 0000000..be30e6f
--- /dev/null
+++ b/testsuite/tests/lib-unix/win-stat/fakeclock.c
@@ -0,0 +1,179 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*                 David Allsopp, OCaml Labs, Cambridge.                  */
+/*                                                                        */
+/*   Copyright 2017 MetaStack Solutions Ltd.                              */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+#include <windows.h>
+
+typedef union ufiletime_int64
+{
+  unsigned __int64 scalar;
+  FILETIME ft;
+} filetime_int64;
+
+static filetime_int64 clk;
+static DWORD wall = 0;
+static unsigned __int64 bias = 0LL;
+
+BOOL WINAPI FakeConvert(const FILETIME* lpFileTime, LPFILETIME lpLocalFileTime)
+{
+  filetime_int64 result;
+  memcpy(&result.ft, lpFileTime, sizeof(FILETIME));
+  result.scalar += bias;
+  memcpy(lpLocalFileTime, &result.ft, sizeof(FILETIME));
+  return TRUE;
+}
+
+void WINAPI FakeClock(LPFILETIME result)
+{
+  DWORD now = GetTickCount();
+  /* Take a risk on this: GetTickCount64 is not available in Windows XP... */
+  /* GetTickCount is in ms, clk.scalar is in 100ns intervals */
+  clk.scalar += ((now - wall) * 10000);
+  wall = now;
+
+  memcpy(result, &clk.ft, sizeof(FILETIME));
+
+  return;
+}
+
+/* Assuming that nowhere transitions DST in February... */
+static short mon_days[13] = {0, 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31};
+
+void SetBias(void)
+{
+  TIME_ZONE_INFORMATION tzInfo;
+  filetime_int64 dst;
+  SYSTEMTIME dst_start;
+
+  switch (GetTimeZoneInformation(&tzInfo)) {
+    case TIME_ZONE_ID_INVALID:
+    case TIME_ZONE_ID_UNKNOWN:
+      /* Default to GMT */
+      tzInfo.DaylightDate.wYear = 0;
+      tzInfo.DaylightDate.wMonth = 3;
+      tzInfo.DaylightDate.wDay = 5;
+      tzInfo.DaylightDate.wDayOfWeek = 0;
+      tzInfo.DaylightDate.wHour = 1;
+      tzInfo.StandardBias = 0;
+      tzInfo.DaylightBias = -60;
+  }
+
+  /* If wYear is given, then DaylightDate is a date, otherwise the transition
+   * is the wDay'th wDayOfWeek of wMonth (where the 5th wDayOfWeek means last
+   * when there are only 4 wDayOfWeek's in wMonth)
+   */
+  if (!tzInfo.DaylightDate.wYear) {
+    int wday;
+    /* Get the clock date in order to determine wYear */
+    FileTimeToSystemTime(&clk.ft, &dst_start);
+    /* Back-up DST transition details */
+    dst_start.wDay = tzInfo.DaylightDate.wDay;
+    dst_start.wDayOfWeek = tzInfo.DaylightDate.wDayOfWeek;
+    /* Set tzInfo to be first day of month on DST change */
+    tzInfo.DaylightDate.wYear = dst_start.wYear;
+    tzInfo.DaylightDate.wDay = 1;
+    /* Normalise tzInfo.DaylightDate (need wDayOfWeek) */
+    SystemTimeToFileTime(&tzInfo.DaylightDate, &dst.ft);
+    FileTimeToSystemTime(&dst.ft, &tzInfo.DaylightDate);
+    /* First to first weekday of DST transition */
+    if ((wday = dst_start.wDayOfWeek - tzInfo.DaylightDate.wDayOfWeek) < 0)
+      tzInfo.DaylightDate.wDay += wday + 7;
+    else
+      tzInfo.DaylightDate.wDay += wday;
+    tzInfo.DaylightDate.wDayOfWeek =
+      (mon_days[tzInfo.DaylightDate.wMonth] - tzInfo.DaylightDate.wDay) / 7;
+    if (dst_start.wDay > tzInfo.DaylightDate.wDayOfWeek)
+      dst_start.wDay = tzInfo.DaylightDate.wDayOfWeek;
+    tzInfo.DaylightDate.wDay += 7 * dst_start.wDay;
+  }
+  SystemTimeToFileTime(&tzInfo.DaylightDate, &dst.ft);
+  bias = -(clk.scalar >= dst.scalar ? tzInfo.DaylightBias
+                                    : tzInfo.StandardBias) * 600000000LL;
+  return;
+}
+
+void ReplaceFunction(char* fn, char* module, void* pNew)
+{
+  HMODULE hModule = LoadLibrary(module);
+  void* pCode;
+  DWORD dwOldProtect = 0;
+#ifdef _M_X64
+  SIZE_T jmpSize = 13;
+  BYTE jump[13];
+#else
+  SIZE_T jmpSize = 5;
+  BYTE jump[5];
+#endif
+  SIZE_T bytesWritten;
+
+  /* Patching is permitted to fail (missing API, etc.) */
+  if (!hModule) return;
+  pCode = GetProcAddress(hModule, fn);
+  if (!pCode) return;
+
+  /* Overwrite the code with a jump to our function */
+  if (VirtualProtect(pCode, jmpSize, PAGE_EXECUTE_READWRITE, &dwOldProtect)) {
+#ifdef _M_X64
+    jump[0] = 0x49;             /* REX.WB prefix */
+    jump[1] = 0xBB;             /* MOV r11, ... */
+    memcpy(jump + 2, &pNew, 8); /* imm64 */
+    jump[10] = 0x41;            /* REX.B prefix */
+    jump[11] = 0xFF;            /* JMP */
+    jump[12] = 0xE3;            /* r11 */
+#else
+    /* JMP rel32 to FakeClock */
+    DWORD dwRelativeAddr = (DWORD)pNew - ((DWORD)pCode + 5);
+    jump[0] = 0xE9;
+    memcpy(jump + 1, &dwRelativeAddr, 4);
+#endif
+
+    if (WriteProcessMemory(GetCurrentProcess(), pCode, jump, jmpSize, NULL)) {
+      VirtualProtect(pCode, jmpSize, dwOldProtect, &dwOldProtect);
+    }
+  }
+
+  return;
+}
+
+#define CAML_NAME_SPACE
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+
+static int patched = 0;
+
+CAMLprim value set_fake_clock(value time)
+{
+  CAMLparam1(time);
+
+  clk.scalar = Int64_val(time);
+  wall = GetTickCount();
+  SetBias();
+
+  if (!patched) {
+    patched = 1;
+    /* Patch Windows 8 and later (UCRT) */
+    ReplaceFunction("GetSystemTimePreciseAsFileTime",
+                    "api-ms-win-core-sysinfo-l1-2-1.dll", &FakeClock);
+    ReplaceFunction("GetSystemTimeAsFileTime",
+                    "api-ms-win-core-sysinfo-l1-2-1.dll", &FakeClock);
+    /* Patch Windows 7 API Set */
+    ReplaceFunction("GetSystemTimeAsFileTime",
+                    "api-ms-win-core-sysinfo-l1-1-0.dll", &FakeClock);
+    /* Patch Windows 7 and previous (standard CRT) */
+    ReplaceFunction("GetSystemTimeAsFileTime",
+                    "kernel32.dll", &FakeClock);
+    ReplaceFunction("FileTimeToLocalFileTime", "kernel32.dll", &FakeConvert);
+  }
+
+  CAMLreturn(Val_unit);
+}

diff --git a/testsuite/tests/lib-unix/win-stat/test.ml b/testsuite/tests/lib-unix/win-stat/test.ml
new file mode 100644 (file)
index 0000000..1a6df64
--- /dev/null
+++ b/testsuite/tests/lib-unix/win-stat/test.ml
@@ -0,0 +1,31 @@
+open Unix
+
+external set_fake_clock : int64 -> unit = "set_fake_clock"
+
+let real_time tm = {tm with tm_year = tm.tm_year + 1900; tm_mon = tm.tm_mon + 1}
+
+let print_time () =
+  let time = Unix.time () |> Unix.gmtime |> real_time in
+  Printf.printf "System clock: %04d/%02d/%02d %02d:%02d\n" time.tm_year
+                                                           time.tm_mon
+                                                           time.tm_mday
+                                                           time.tm_hour
+                                                           time.tm_min
+
+let test_mtime file =
+  let time = (Unix.stat file).st_mtime |> Unix.gmtime |> real_time in
+  Printf.printf "Read mtime for %s = %04d/%02d/%02d %02d:%02d:%02d\n"
+    file
+    time.tm_year time.tm_mon time.tm_mday time.tm_hour time.tm_min time.tm_sec
+
+let _ =
+  (* 1-Jun-2017 20:33:10.42+0000 *)
+  set_fake_clock 0x1D2DB1648916FA0L;
+  print_time ();
+  test_mtime "dst-file";
+  test_mtime "non-dst-file";
+  (* 1-Feb-2017 20:33:10.42+0000 *)
+  set_fake_clock 0x1D27CCA66FF6FA0L;
+  print_time ();
+  test_mtime "dst-file";
+  test_mtime "non-dst-file"

diff --git a/testsuite/tests/lib-unix/win-stat/test.reference b/testsuite/tests/lib-unix/win-stat/test.reference
new file mode 100644 (file)
index 0000000..308e489
--- /dev/null
+++ b/testsuite/tests/lib-unix/win-stat/test.reference
@@ -0,0 +1,6 @@
+System clock: 2017/06/01 20:33
+Read mtime for dst-file = 2017/07/01 12:00:00
+Read mtime for non-dst-file = 2017/02/01 12:00:00
+System clock: 2017/02/01 20:33
+Read mtime for dst-file = 2017/07/01 12:00:00
+Read mtime for non-dst-file = 2017/02/01 12:00:00

diff --git a/testsuite/tests/lib-unix/win-symlink/Makefile b/testsuite/tests/lib-unix/win-symlink/Makefile
new file mode 100755 (executable)
index 0000000..c0c031a
--- /dev/null
+++ b/testsuite/tests/lib-unix/win-symlink/Makefile
@@ -0,0 +1,16 @@
+BASEDIR=../../..
+LIBRARIES=unix
+ADD_COMPFLAGS=-I $(OTOPDIR)/otherlibs/$(UNIXLIBVAR)unix
+LD_PATH=$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix
+MAIN_MODULE=test
+TEST_TEMP_FILES=link1 link2 test.txt
+
+test:
+       @if $(OCAML) $(ADD_COMPFLAGS) unix.cma precheck.ml; then \
+         $(MAKE) default; \
+       else \
+         echo " ... testing => skipped (not on Windows and/or symlinks not allowed)"; \
+       fi
+
+include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/lib-unix/win-symlink/precheck.ml b/testsuite/tests/lib-unix/win-symlink/precheck.ml
new file mode 100755 (executable)
index 0000000..85c9550
--- /dev/null
+++ b/testsuite/tests/lib-unix/win-symlink/precheck.ml
@@ -0,0 +1,2 @@
+let () =
+  exit (if Sys.win32 && Unix.has_symlink () then 0 else 1)

diff --git a/testsuite/tests/lib-unix/win-symlink/test.ml b/testsuite/tests/lib-unix/win-symlink/test.ml
new file mode 100755 (executable)
index 0000000..0c8556d
--- /dev/null
+++ b/testsuite/tests/lib-unix/win-symlink/test.ml
@@ -0,0 +1,19 @@
+let link1 = "link1"
+let link2 = "link2"
+
+let link_exists s =
+  try (Unix.lstat s).Unix.st_kind = Unix.S_LNK with _ -> false
+
+let main () =
+  close_out (open_out "test.txt");
+  if link_exists link1 then Sys.remove link1;
+  if link_exists link2 then Sys.remove link2;
+  Unix.symlink ~to_dir:false ".\\test.txt" link1;
+  assert ((Unix.stat link1).Unix.st_kind = Unix.S_REG);
+  print_endline "Unix.symlink works with backwards slashes";
+  Unix.symlink ~to_dir:false "./test.txt" link2;
+  assert ((Unix.stat link2).Unix.st_kind = Unix.S_REG);
+  print_endline "Unix.symlink works with forward slashes"
+
+let () =
+  Unix.handle_unix_error main ()

diff --git a/testsuite/tests/lib-unix/win-symlink/test.reference b/testsuite/tests/lib-unix/win-symlink/test.reference
new file mode 100644 (file)
index 0000000..871a3e0
--- /dev/null
+++ b/testsuite/tests/lib-unix/win-symlink/test.reference
@@ -0,0 +1,2 @@
+Unix.symlink works with backwards slashes
+Unix.symlink works with forward slashes

diff --git a/testsuite/tests/match-exception/match_failure.ml b/testsuite/tests/match-exception/match_failure.ml
index 40c60595f7912dc7f916d90d382368c02a3a60f3..7b2cd300ec5e77e499cdc97487dcbddef2dc7d84 100644 (file)
--- a/testsuite/tests/match-exception/match_failure.ml
+++ b/testsuite/tests/match-exception/match_failure.ml
@@ -11,7 +11,7 @@ let test_match_partial_match =
     | exception Failure _ -> "failure"
     | exception Invalid_argument _ -> "invalid argument"
     | None -> "None"
-    ) in
+    ) [@ocaml.warning "-8"] in
     assert false
   with
     Match_failure _ ->

diff --git a/testsuite/tests/messages/precise_locations.ml b/testsuite/tests/messages/precise_locations.ml
index 997cb86e88e314ba40bb484b4d93bab0c7a8d602..d370f8c5b6828e6c674e11e4e79aec4210f58905 100644 (file)
--- a/testsuite/tests/messages/precise_locations.ml
+++ b/testsuite/tests/messages/precise_locations.ml
@@ -40,18 +40,14 @@ Foo ();;
 [%%expect{|
 type t = Foo of unit | Bar
 Line _, characters 0-6:
-Warning 3: deprecated: Foo
-Line _:
-Error: Some fatal warnings were triggered (1 occurrences)
+Error (warning 3): deprecated: Foo
 |}];;
 function
 Foo _ -> () | Bar -> ();;
 (* "Foo _", the whole construct is deprecated *)
 [%%expect{|
 Line _, characters 0-5:
-Warning 3: deprecated: Foo
-Line _:
-Error: Some fatal warnings were triggered (1 occurrences)
+Error (warning 3): deprecated: Foo
 |}];;
 
 
@@ -70,9 +66,7 @@ end);;
    on "open List" as whole rather than "List" *)
 [%%expect{|
 Line _, characters 0-9:
-Warning 33: unused open List.
-Line _:
-Error: Some fatal warnings were triggered (1 occurrences)
+Error (warning 33): unused open List.
 |}];;
 
 type unknown += Foo;;

diff --git a/testsuite/tests/misc-unsafe/almabench.ml b/testsuite/tests/misc-unsafe/almabench.ml
index 54fc31087dd47a8e9772280425dee3256e69e0a4..05fe3bba549584f093299ef83fce27e3a936581a 100644 (file)
--- a/testsuite/tests/misc-unsafe/almabench.ml
+++ b/testsuite/tests/misc-unsafe/almabench.ml
@@ -236,7 +236,7 @@ let planetpv epoch np pv =
     let dae = ref ((am -. !ae +. de *. sin !ae) /. (1.0 -. de *. cos !ae)) in
       ae := !ae +. !dae;
       incr k;
-      while !k < 10 or abs_float !dae >= 1e-12 do
+      while !k < 10 || abs_float !dae >= 1e-12 do
         dae := (am -. !ae +. de *. sin !ae) /. (1.0 -. de *. cos !ae);
         ae := !ae +. !dae;
         incr k

diff --git a/testsuite/tests/misc-unsafe/soli.ml b/testsuite/tests/misc-unsafe/soli.ml
index ccab81e09681f68778e20e7697ba87156607fc74..65488ba5fea753b28b340a0f646055775bd62602 100644 (file)
--- a/testsuite/tests/misc-unsafe/soli.ml
+++ b/testsuite/tests/misc-unsafe/soli.ml
@@ -35,7 +35,7 @@ let dir = [| {dx = 0; dy = 1}; {dx = 1; dy = 0};
 
 type move = { x1: int; y1: int; x2: int; y2: int }
 
-let moves = Array.create 31 {x1=0;y1=0;x2=0;y2=0}
+let moves = Array.make 31 {x1=0;y1=0;x2=0;y2=0}
 
 let counter = ref 0
 

diff --git a/testsuite/tests/misc/ephetest2.ml b/testsuite/tests/misc/ephetest2.ml
index 61861df99601fc79b023fc5d71e0f957fc9c5b77..d8a8a41b465d1939200efc76a2065008f14d7eec 100644 (file)
--- a/testsuite/tests/misc/ephetest2.ml
+++ b/testsuite/tests/misc/ephetest2.ml
@@ -41,7 +41,7 @@ let print_short_bool fmt b =
 
 let rec pp_form fmt = function
   | Constant b ->
-      fprintf fmt "%b" b
+      fprintf fmt "%B" b
   | And a      ->
       fprintf fmt "And[@[%a@]]" (fun fmt -> Array.iter (pp_var fmt)) a
   | Or a       ->

diff --git a/testsuite/tests/misc/ephetest3.ml b/testsuite/tests/misc/ephetest3.ml
index 5eed2cf3b49e418bdf1b558b00d0573941685228..f0f52d2bdb604908fa423b4b7f513b81eea62d82 100644 (file)
--- a/testsuite/tests/misc/ephetest3.ml
+++ b/testsuite/tests/misc/ephetest3.ml
@@ -96,7 +96,7 @@ let print_stats () =
 
 let test_keep_last d d' =
   Printf.printf "## Keep last %i alive, check each %i ##\n%!" (n/d) (n/d');
-  let keep_alive = Array.create (n/d) Int64.zero in
+  let keep_alive = Array.make (n/d) Int64.zero in
   let next x =
     let x' = hashcons (Int64.of_int x) in
     Array.set keep_alive (x mod (n/d)) x';

diff --git a/testsuite/tests/misc/gcwords.ml b/testsuite/tests/misc/gcwords.ml
index 80ecd34e54fc5b70232a003d23b15adbea3e97f5..61cb84953752b74e280dea60e23e55aed7679545 100644 (file)
--- a/testsuite/tests/misc/gcwords.ml
+++ b/testsuite/tests/misc/gcwords.ml
@@ -1,6 +1,8 @@
 type t = Leaf of int | Branch of t * t
 
-let a = [| 0.0 |]
+type floatref = { mutable f : float }
+
+let a = { f = 0.0 }
 
 let rec allocate_lots m = function
   | 0 -> Leaf m
@@ -13,7 +15,7 @@ let measure f =
   c -. a
 
 let () =
-  let n = measure (fun () -> a.(0) <- Gc.minor_words ()) in
+  let n = measure (fun () -> a.f <- Gc.minor_words ()) in
   (* Gc.minor_words should not allocate, although bytecode
      generally boxes the floats *)
   assert (n < 10.);

diff --git a/testsuite/tests/misc/sorts.ml b/testsuite/tests/misc/sorts.ml
index 4c4d7126d6c042e3837ea20d96d161ab93b1cadd..43c53078c04ef4bc08eb561e666acd043aff4e41 100644 (file)
--- a/testsuite/tests/misc/sorts.ml
+++ b/testsuite/tests/misc/sorts.ml
@@ -128,9 +128,9 @@ type record = {
 
 let rand_string () =
   let len = Random.int 10 in
-  let s = String.create len in
+  let s = Bytes.create len in
   for i = 0 to len-1 do
-    s.[i] <- Char.chr (Random.int 256);
+    Bytes.set s i (Char.chr (Random.int 256));
   done;
   s
 ;;
@@ -4234,7 +4234,6 @@ let amerge_0 cmp a =    (* cutoff is not yet used *)
 (************************************************************************)
 
 let lold = [
-  "Sort.list", Sort.list, true;
   "lmerge_3", lmerge_3, false;
   "lmerge_4a", lmerge_4a, true;
 ];;
@@ -4370,7 +4369,7 @@ let main () =
   done;
   Printf.printf "\n";
 
-  ignore (String.create (1048576 * !mem));
+  ignore (Bytes.create (1048576 * !mem));
   Gc.full_major ();
 (*
   let a2l = Array.to_list in
@@ -4405,7 +4404,6 @@ let main () =
         let (_, f2, _) = List.nth lold i in
         testonly name stable f1 f2 ll ll;
       done;
-      testonly "Sort.array" false Sort.array Sort.array al al;
       for i = 0 to List.length lnew - 1 do
         let (name, f1, stable) = List.nth lnew i in
         let (_, f2, _) = List.nth lnew i in
@@ -4428,9 +4426,6 @@ let main () =
         let (name, f, stable) = List.nth lold i in bb name f ll;
         let (name, f, stable) = List.nth lold i in bc name f ll;
       done;
-      ba "Sort.array" Sort.array al;
-      bb "Sort.array" Sort.array al;
-      bc "Sort.array" Sort.array al;
       for i = 0 to List.length lnew - 1 do
         let (name, f, stable) = List.nth lnew i in ba name f lc;
         let (name, f, stable) = List.nth lnew i in bb name f lc;
@@ -4447,7 +4442,6 @@ let main () =
       for i = 0 to List.length lold - 1 do
         let (name, f, stable) = List.nth lold i in b name f ll;
       done;
-      b "Sort.array" Sort.array al;
       for i = 0 to List.length lnew - 1 do
         let (name, f, stable) = List.nth lnew i in b name f lc;
       done;

diff --git a/testsuite/tests/output_obj/Makefile.disabled b/testsuite/tests/output_obj/Makefile.disabled
new file mode 100644 (file)
index 0000000..17fb689
--- /dev/null
+++ b/testsuite/tests/output_obj/Makefile.disabled
@@ -0,0 +1,58 @@
+#**************************************************************************
+#*                                                                        *
+#*                                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 GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+SHOULD_FAIL=
+
+
+compile:
+       @for file in *.ml; do \
+         printf " ... testing '$$file' with native"; \
+          if $(BYTECODE_ONLY); then \
+           echo " => skipped"; \
+         else \
+           rm -f log $${file}.exe.$(O) $${file}_stub$(EXE); \
+           ( set -x; \
+             $(OCAMLOPT) -w a -output-complete-obj -o $${file}.exe.$(O) \
+                          $${file} && \
+             $(MKEXE) -I$(CTOPDIR)/byterun -o $${file}_stub$(EXE) \
+                       $${file}.exe.$(O) $(NATIVECCLIBS) $${file}_stub.c && \
+             ./$${file}_stub$(EXE) ) > log 2>&1 \
+            && echo " => passed" || (echo " => failed" && cat log); \
+         fi \
+       done
+       @for file in *.ml; do \
+         printf " ... testing '$$file' with byte"; \
+         if [ $(TOOLCHAIN) = msvc ]; then \
+           echo " => skipped"; \
+         else \
+            rm -f log $${file}.bc.$(O) $${file}_bc_stub$(EXE); \
+           ( set -x; \
+             $(OCAMLC) -ccopt "-I$(CTOPDIR)/byterun" -w a -output-complete-obj\
+                        -o $${file}.bc.$(O) $${file} && \
+             $(MKEXE) -I$(CTOPDIR)/byterun -o $${file}_bc_stub$(EXE) \
+                       $${file}.bc.$(O) $(BYTECCLIBS) $${file}_stub.c && \
+             ./$${file}_bc_stub$(EXE) ) > log 2>&1 \
+           && echo " => passed" || (echo " => failed" && cat log); \
+         fi; \
+       done
+       @rm -f log
+
+promote:
+
+clean: defaultclean
+       @rm -f ./a.out
+
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/output_obj/test.ml b/testsuite/tests/output_obj/test.ml
new file mode 100644 (file)
index 0000000..2cdc201
--- /dev/null
+++ b/testsuite/tests/output_obj/test.ml
@@ -0,0 +1 @@
+let () = Printf.printf "Test!!\n%!"

diff --git a/testsuite/tests/output_obj/test.ml_stub.c b/testsuite/tests/output_obj/test.ml_stub.c
new file mode 100644 (file)
index 0000000..c3e8d3f
--- /dev/null
+++ b/testsuite/tests/output_obj/test.ml_stub.c
@@ -0,0 +1,10 @@
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include <caml/callback.h>
+#include <caml/memory.h>
+
+int main(int argc, char ** argv){
+
+  caml_startup(argv);
+  return 0;
+}

diff --git a/testsuite/tests/parsetree/source.ml b/testsuite/tests/parsetree/source.ml
index 7742c5995e25f31e6a3eb9279e4928829c9a8a82..28fb4a40419dc3995e479863ad5ef36205d9c370 100644 (file)
--- a/testsuite/tests/parsetree/source.ml
+++ b/testsuite/tests/parsetree/source.ml
@@ -6585,10 +6585,10 @@ let () =
   let i = int_inj 3 in
   let s = string_inj "abc" in
 
-  Printf.printf "%b\n%!" (int_proj i = None);
-  Printf.printf "%b\n%!" (int_proj s = None);
-  Printf.printf "%b\n%!" (string_proj i = None);
-  Printf.printf "%b\n%!" (string_proj s = None)
+  Printf.printf "%B\n%!" (int_proj i = None);
+  Printf.printf "%B\n%!" (int_proj s = None);
+  Printf.printf "%B\n%!" (string_proj i = None);
+  Printf.printf "%B\n%!" (string_proj s = None)
 ;;
 
 let sort_uniq (type s) cmp l =
@@ -7274,3 +7274,69 @@ let g x =
 let ( ~$ ) x y = (x, y)
 let g x y =
   ~$ (x.contents) (y.contents)
+
+
+
+(* PR#7506: attributes on list tail *)
+
+let tail1 = ([1; 2])[@hello]
+let tail2 = 0::(([1; 2])[@hello])
+let tail3 = 0::(([])[@hello])
+
+let f ~l:(l[@foo]) = l;;
+let test x y = ((+)[@foo]) x y;;
+let test x = ((~-)[@foo]) x;;
+let test contents = { contents = contents[@foo] };;
+class type t = object(_[@foo]) end;;
+let test f x = f ~x:(x[@foo]);;
+let f = function ((`A|`B)[@bar]) | `C -> ();;
+let f = function _::(_::_ [@foo]) -> () | _ -> ();;
+function {contents=contents[@foo]} -> ();;
+fun contents -> {contents=contents[@foo]};;
+((); (((); ())[@foo]));;
+
+(* https://github.com/LexiFi/gen_js_api/issues/61 *)
+
+let () = foo##.bar := ();;
+
+(* "let open" in classes and class types *)
+
+class c =
+  let open M in
+  object
+    method f : t = x
+  end
+;;
+class type ct =
+  let open M in
+  object
+    method f : t
+  end
+;;
+
+(* M.(::) notation *)
+module Exotic_list = struct
+  module Inner = struct
+    type ('a,'b) t = [] | (::) of 'a * 'b *  ('a,'b) t
+  end
+
+  let Inner.(::)(x,y, Inner.[]) = Inner.(::)(1,"one",Inner.[])
+end
+
+(** Extended index operators *)
+module Indexop = struct
+  module Def = struct
+    let ( .%[] ) = Hashtbl.find
+    let ( .%[] <- ) = Hashtbl.add
+    let ( .%() ) = Hashtbl.find
+    let ( .%() <- ) = Hashtbl.add
+    let ( .%{} ) = Hashtbl.find
+    let ( .%{} <- ) = Hashtbl.add
+  end
+  ;;
+  let h = Hashtbl.create 17 in
+  h.Def.%["one"] <- 1;
+  h.Def.%("two") <- 2;
+  h.Def.%{"three"} <- 3
+  let x,y,z = Def.(h.%["one"], h.%("two"), h.%{"three"})
+end

diff --git a/testsuite/tests/parsetree/test.ml b/testsuite/tests/parsetree/test.ml
index 86ed3c8cc613d1731b9edc895772dca8c85aa140..9b96a3786c2e7e15a991ff5116132058463acec3 100644 (file)
--- a/testsuite/tests/parsetree/test.ml
+++ b/testsuite/tests/parsetree/test.ml
@@ -7,15 +7,7 @@ let diff =
   | _ -> "diff -u"
 
 let report_err exn =
-  match exn with
-    | Sys_error msg ->
-        Format.printf "@[I/O error:@ %s@]@." msg
-    | x ->
-        match Location.error_of_exn x with
-        | Some err ->
-            Format.printf "@[%a@]@."
-              Location.report_error err
-        | None -> raise x
+  Location.report_exception Format.std_formatter exn
 
 let remove_locs =
   let open Ast_mapper in

diff --git a/testsuite/tests/parsing/attributes.ml.reference b/testsuite/tests/parsing/attributes.ml.reference
index c6e8ad8d516645de741e592a3540d4d12334a254..5a39357fd9d4064592ffdc065634be098cad0a76 100644 (file)
--- a/testsuite/tests/parsing/attributes.ml.reference
+++ b/testsuite/tests/parsing/attributes.ml.reference
@@ -125,7 +125,7 @@
                     []
                   Pmod_ident "M" (attributes.ml[26,254+27]..[26,254+28])
               [
-                Pwith_typesubst
+                Pwith_typesubst "t" (attributes.ml[26,254+53]..[26,254+54])
                   type_declaration "t" (attributes.ml[26,254+53]..[26,254+54]) (attributes.ml[26,254+48]..[26,254+61])
                     ptype_params =
                       []

diff --git a/testsuite/tests/parsing/extended_indexoperators.ml b/testsuite/tests/parsing/extended_indexoperators.ml
new file mode 100644 (file)
index 0000000..ddbc84a
--- /dev/null
+++ b/testsuite/tests/parsing/extended_indexoperators.ml
@@ -0,0 +1,23 @@
+let (.?[]) = Hashtbl.find_opt
+let (.@[]) = Hashtbl.find
+let ( .@[]<- ) = Hashtbl.add
+let (.@{}) = Hashtbl.find
+let ( .@{}<- ) = Hashtbl.add
+let (.@()) = Hashtbl.find
+let ( .@()<- ) = Hashtbl.add
+
+let h = Hashtbl.create 17
+
+;;
+  h.@("One") <- 1
+; assert (h.@{"One"} = 1)
+; print_int h.@{"One"}
+; assert (h.?["Two"] = None)
+
+
+(* from GPR#1392 *)
+let ( #? ) x y = (x, y);;
+let ( .%() ) x y = x.(y);;
+let x = [| 0 |];;
+let _ = 1 #? x.(0);;
+let _ = 1 #? x.%(0);;

diff --git a/testsuite/tests/parsing/extended_indexoperators.ml.reference b/testsuite/tests/parsing/extended_indexoperators.ml.reference
new file mode 100644 (file)
index 0000000..fe60fc6
--- /dev/null
+++ b/testsuite/tests/parsing/extended_indexoperators.ml.reference
@@ -0,0 +1,327 @@
+[
+  structure_item (extended_indexoperators.ml[1,0+0]..[1,0+29])
+    Pstr_value Nonrec
+    [
+      <def>
+        pattern (extended_indexoperators.ml[1,0+4]..[1,0+10])
+          Ppat_var ".?[]" (extended_indexoperators.ml[1,0+4]..[1,0+10])
+        expression (extended_indexoperators.ml[1,0+13]..[1,0+29])
+          Pexp_ident "Hashtbl.find_opt" (extended_indexoperators.ml[1,0+13]..[1,0+29])
+    ]
+  structure_item (extended_indexoperators.ml[2,30+0]..[2,30+25])
+    Pstr_value Nonrec
+    [
+      <def>
+        pattern (extended_indexoperators.ml[2,30+4]..[2,30+10])
+          Ppat_var ".@[]" (extended_indexoperators.ml[2,30+4]..[2,30+10])
+        expression (extended_indexoperators.ml[2,30+13]..[2,30+25])
+          Pexp_ident "Hashtbl.find" (extended_indexoperators.ml[2,30+13]..[2,30+25])
+    ]
+  structure_item (extended_indexoperators.ml[3,56+0]..[3,56+28])
+    Pstr_value Nonrec
+    [
+      <def>
+        pattern (extended_indexoperators.ml[3,56+4]..[3,56+14])
+          Ppat_var ".@[]<-" (extended_indexoperators.ml[3,56+4]..[3,56+14])
+        expression (extended_indexoperators.ml[3,56+17]..[3,56+28])
+          Pexp_ident "Hashtbl.add" (extended_indexoperators.ml[3,56+17]..[3,56+28])
+    ]
+  structure_item (extended_indexoperators.ml[4,85+0]..[4,85+25])
+    Pstr_value Nonrec
+    [
+      <def>
+        pattern (extended_indexoperators.ml[4,85+4]..[4,85+10])
+          Ppat_var ".@{}" (extended_indexoperators.ml[4,85+4]..[4,85+10])
+        expression (extended_indexoperators.ml[4,85+13]..[4,85+25])
+          Pexp_ident "Hashtbl.find" (extended_indexoperators.ml[4,85+13]..[4,85+25])
+    ]
+  structure_item (extended_indexoperators.ml[5,111+0]..[5,111+28])
+    Pstr_value Nonrec
+    [
+      <def>
+        pattern (extended_indexoperators.ml[5,111+4]..[5,111+14])
+          Ppat_var ".@{}<-" (extended_indexoperators.ml[5,111+4]..[5,111+14])
+        expression (extended_indexoperators.ml[5,111+17]..[5,111+28])
+          Pexp_ident "Hashtbl.add" (extended_indexoperators.ml[5,111+17]..[5,111+28])
+    ]
+  structure_item (extended_indexoperators.ml[6,140+0]..[6,140+25])
+    Pstr_value Nonrec
+    [
+      <def>
+        pattern (extended_indexoperators.ml[6,140+4]..[6,140+10])
+          Ppat_var ".@()" (extended_indexoperators.ml[6,140+4]..[6,140+10])
+        expression (extended_indexoperators.ml[6,140+13]..[6,140+25])
+          Pexp_ident "Hashtbl.find" (extended_indexoperators.ml[6,140+13]..[6,140+25])
+    ]
+  structure_item (extended_indexoperators.ml[7,166+0]..[7,166+28])
+    Pstr_value Nonrec
+    [
+      <def>
+        pattern (extended_indexoperators.ml[7,166+4]..[7,166+14])
+          Ppat_var ".@()<-" (extended_indexoperators.ml[7,166+4]..[7,166+14])
+        expression (extended_indexoperators.ml[7,166+17]..[7,166+28])
+          Pexp_ident "Hashtbl.add" (extended_indexoperators.ml[7,166+17]..[7,166+28])
+    ]
+  structure_item (extended_indexoperators.ml[9,196+0]..[9,196+25])
+    Pstr_value Nonrec
+    [
+      <def>
+        pattern (extended_indexoperators.ml[9,196+4]..[9,196+5])
+          Ppat_var "h" (extended_indexoperators.ml[9,196+4]..[9,196+5])
+        expression (extended_indexoperators.ml[9,196+8]..[9,196+25])
+          Pexp_apply
+          expression (extended_indexoperators.ml[9,196+8]..[9,196+22])
+            Pexp_ident "Hashtbl.create" (extended_indexoperators.ml[9,196+8]..[9,196+22])
+          [
+            <arg>
+            Nolabel
+              expression (extended_indexoperators.ml[9,196+23]..[9,196+25])
+                Pexp_constant PConst_int (17,None)
+          ]
+    ]
+  structure_item (extended_indexoperators.ml[12,226+2]..[15,293+28])
+    Pstr_eval
+    expression (extended_indexoperators.ml[12,226+2]..[15,293+28])
+      Pexp_sequence
+      expression (extended_indexoperators.ml[12,226+2]..[12,226+17])
+        Pexp_apply
+        expression (extended_indexoperators.ml[12,226+2]..[12,226+17])
+          Pexp_ident ".@()<-" (extended_indexoperators.ml[12,226+2]..[12,226+17]) ghost
+        [
+          <arg>
+          Nolabel
+            expression (extended_indexoperators.ml[12,226+2]..[12,226+3])
+              Pexp_ident "h" (extended_indexoperators.ml[12,226+2]..[12,226+3])
+          <arg>
+          Nolabel
+            expression (extended_indexoperators.ml[12,226+6]..[12,226+11])
+              Pexp_constant PConst_string("One",None)
+          <arg>
+          Nolabel
+            expression (extended_indexoperators.ml[12,226+16]..[12,226+17])
+              Pexp_constant PConst_int (1,None)
+        ]
+      expression (extended_indexoperators.ml[13,244+2]..[15,293+28])
+        Pexp_sequence
+        expression (extended_indexoperators.ml[13,244+2]..[13,244+25])
+          Pexp_assert
+          expression (extended_indexoperators.ml[13,244+9]..[13,244+25])
+            Pexp_apply
+            expression (extended_indexoperators.ml[13,244+21]..[13,244+22])
+              Pexp_ident "=" (extended_indexoperators.ml[13,244+21]..[13,244+22])
+            [
+              <arg>
+              Nolabel
+                expression (extended_indexoperators.ml[13,244+10]..[13,244+20])
+                  Pexp_apply
+                  expression (extended_indexoperators.ml[13,244+10]..[13,244+20])
+                    Pexp_ident ".@{}" (extended_indexoperators.ml[13,244+10]..[13,244+20]) ghost
+                  [
+                    <arg>
+                    Nolabel
+                      expression (extended_indexoperators.ml[13,244+10]..[13,244+11])
+                        Pexp_ident "h" (extended_indexoperators.ml[13,244+10]..[13,244+11])
+                    <arg>
+                    Nolabel
+                      expression (extended_indexoperators.ml[13,244+14]..[13,244+19])
+                        Pexp_constant PConst_string("One",None)
+                  ]
+              <arg>
+              Nolabel
+                expression (extended_indexoperators.ml[13,244+23]..[13,244+24])
+                  Pexp_constant PConst_int (1,None)
+            ]
+        expression (extended_indexoperators.ml[14,270+2]..[15,293+28])
+          Pexp_sequence
+          expression (extended_indexoperators.ml[14,270+2]..[14,270+22])
+            Pexp_apply
+            expression (extended_indexoperators.ml[14,270+2]..[14,270+11])
+              Pexp_ident "print_int" (extended_indexoperators.ml[14,270+2]..[14,270+11])
+            [
+              <arg>
+              Nolabel
+                expression (extended_indexoperators.ml[14,270+12]..[14,270+22])
+                  Pexp_apply
+                  expression (extended_indexoperators.ml[14,270+12]..[14,270+22])
+                    Pexp_ident ".@{}" (extended_indexoperators.ml[14,270+12]..[14,270+22]) ghost
+                  [
+                    <arg>
+                    Nolabel
+                      expression (extended_indexoperators.ml[14,270+12]..[14,270+13])
+                        Pexp_ident "h" (extended_indexoperators.ml[14,270+12]..[14,270+13])
+                    <arg>
+                    Nolabel
+                      expression (extended_indexoperators.ml[14,270+16]..[14,270+21])
+                        Pexp_constant PConst_string("One",None)
+                  ]
+            ]
+          expression (extended_indexoperators.ml[15,293+2]..[15,293+28])
+            Pexp_assert
+            expression (extended_indexoperators.ml[15,293+9]..[15,293+28])
+              Pexp_apply
+              expression (extended_indexoperators.ml[15,293+21]..[15,293+22])
+                Pexp_ident "=" (extended_indexoperators.ml[15,293+21]..[15,293+22])
+              [
+                <arg>
+                Nolabel
+                  expression (extended_indexoperators.ml[15,293+10]..[15,293+20])
+                    Pexp_apply
+                    expression (extended_indexoperators.ml[15,293+10]..[15,293+20])
+                      Pexp_ident ".?[]" (extended_indexoperators.ml[15,293+10]..[15,293+20]) ghost
+                    [
+                      <arg>
+                      Nolabel
+                        expression (extended_indexoperators.ml[15,293+10]..[15,293+11])
+                          Pexp_ident "h" (extended_indexoperators.ml[15,293+10]..[15,293+11])
+                      <arg>
+                      Nolabel
+                        expression (extended_indexoperators.ml[15,293+14]..[15,293+19])
+                          Pexp_constant PConst_string("Two",None)
+                    ]
+                <arg>
+                Nolabel
+                  expression (extended_indexoperators.ml[15,293+23]..[15,293+27])
+                    Pexp_construct "None" (extended_indexoperators.ml[15,293+23]..[15,293+27])
+                    None
+              ]
+  structure_item (extended_indexoperators.ml[19,344+0]..[19,344+23])
+    Pstr_value Nonrec
+    [
+      <def>
+        pattern (extended_indexoperators.ml[19,344+4]..[19,344+10])
+          Ppat_var "#?" (extended_indexoperators.ml[19,344+4]..[19,344+10])
+        expression (extended_indexoperators.ml[19,344+11]..[19,344+23]) ghost
+          Pexp_fun
+          Nolabel
+          None
+          pattern (extended_indexoperators.ml[19,344+11]..[19,344+12])
+            Ppat_var "x" (extended_indexoperators.ml[19,344+11]..[19,344+12])
+          expression (extended_indexoperators.ml[19,344+13]..[19,344+23]) ghost
+            Pexp_fun
+            Nolabel
+            None
+            pattern (extended_indexoperators.ml[19,344+13]..[19,344+14])
+              Ppat_var "y" (extended_indexoperators.ml[19,344+13]..[19,344+14])
+            expression (extended_indexoperators.ml[19,344+17]..[19,344+23])
+              Pexp_tuple
+              [
+                expression (extended_indexoperators.ml[19,344+18]..[19,344+19])
+                  Pexp_ident "x" (extended_indexoperators.ml[19,344+18]..[19,344+19])
+                expression (extended_indexoperators.ml[19,344+21]..[19,344+22])
+                  Pexp_ident "y" (extended_indexoperators.ml[19,344+21]..[19,344+22])
+              ]
+    ]
+  structure_item (extended_indexoperators.ml[20,370+0]..[20,370+24])
+    Pstr_value Nonrec
+    [
+      <def>
+        pattern (extended_indexoperators.ml[20,370+4]..[20,370+12])
+          Ppat_var ".%()" (extended_indexoperators.ml[20,370+4]..[20,370+12])
+        expression (extended_indexoperators.ml[20,370+13]..[20,370+24]) ghost
+          Pexp_fun
+          Nolabel
+          None
+          pattern (extended_indexoperators.ml[20,370+13]..[20,370+14])
+            Ppat_var "x" (extended_indexoperators.ml[20,370+13]..[20,370+14])
+          expression (extended_indexoperators.ml[20,370+15]..[20,370+24]) ghost
+            Pexp_fun
+            Nolabel
+            None
+            pattern (extended_indexoperators.ml[20,370+15]..[20,370+16])
+              Ppat_var "y" (extended_indexoperators.ml[20,370+15]..[20,370+16])
+            expression (extended_indexoperators.ml[20,370+19]..[20,370+24])
+              Pexp_apply
+              expression (extended_indexoperators.ml[20,370+19]..[20,370+24]) ghost
+                Pexp_ident "Array.get" (extended_indexoperators.ml[20,370+19]..[20,370+24]) ghost
+              [
+                <arg>
+                Nolabel
+                  expression (extended_indexoperators.ml[20,370+19]..[20,370+20])
+                    Pexp_ident "x" (extended_indexoperators.ml[20,370+19]..[20,370+20])
+                <arg>
+                Nolabel
+                  expression (extended_indexoperators.ml[20,370+22]..[20,370+23])
+                    Pexp_ident "y" (extended_indexoperators.ml[20,370+22]..[20,370+23])
+              ]
+    ]
+  structure_item (extended_indexoperators.ml[21,397+0]..[21,397+15])
+    Pstr_value Nonrec
+    [
+      <def>
+        pattern (extended_indexoperators.ml[21,397+4]..[21,397+5])
+          Ppat_var "x" (extended_indexoperators.ml[21,397+4]..[21,397+5])
+        expression (extended_indexoperators.ml[21,397+8]..[21,397+15])
+          Pexp_array
+          [
+            expression (extended_indexoperators.ml[21,397+11]..[21,397+12])
+              Pexp_constant PConst_int (0,None)
+          ]
+    ]
+  structure_item (extended_indexoperators.ml[22,415+0]..[22,415+18])
+    Pstr_value Nonrec
+    [
+      <def>
+        pattern (extended_indexoperators.ml[22,415+4]..[22,415+5])
+          Ppat_any
+        expression (extended_indexoperators.ml[22,415+8]..[22,415+18])
+          Pexp_apply
+          expression (extended_indexoperators.ml[22,415+10]..[22,415+12])
+            Pexp_ident "#?" (extended_indexoperators.ml[22,415+10]..[22,415+12])
+          [
+            <arg>
+            Nolabel
+              expression (extended_indexoperators.ml[22,415+8]..[22,415+9])
+                Pexp_constant PConst_int (1,None)
+            <arg>
+            Nolabel
+              expression (extended_indexoperators.ml[22,415+13]..[22,415+18])
+                Pexp_apply
+                expression (extended_indexoperators.ml[22,415+13]..[22,415+18]) ghost
+                  Pexp_ident "Array.get" (extended_indexoperators.ml[22,415+13]..[22,415+18]) ghost
+                [
+                  <arg>
+                  Nolabel
+                    expression (extended_indexoperators.ml[22,415+13]..[22,415+14])
+                      Pexp_ident "x" (extended_indexoperators.ml[22,415+13]..[22,415+14])
+                  <arg>
+                  Nolabel
+                    expression (extended_indexoperators.ml[22,415+16]..[22,415+17])
+                      Pexp_constant PConst_int (0,None)
+                ]
+          ]
+    ]
+  structure_item (extended_indexoperators.ml[23,436+0]..[23,436+19])
+    Pstr_value Nonrec
+    [
+      <def>
+        pattern (extended_indexoperators.ml[23,436+4]..[23,436+5])
+          Ppat_any
+        expression (extended_indexoperators.ml[23,436+8]..[23,436+19])
+          Pexp_apply
+          expression (extended_indexoperators.ml[23,436+10]..[23,436+12])
+            Pexp_ident "#?" (extended_indexoperators.ml[23,436+10]..[23,436+12])
+          [
+            <arg>
+            Nolabel
+              expression (extended_indexoperators.ml[23,436+8]..[23,436+9])
+                Pexp_constant PConst_int (1,None)
+            <arg>
+            Nolabel
+              expression (extended_indexoperators.ml[23,436+13]..[23,436+19])
+                Pexp_apply
+                expression (extended_indexoperators.ml[23,436+13]..[23,436+19])
+                  Pexp_ident ".%()" (extended_indexoperators.ml[23,436+13]..[23,436+19]) ghost
+                [
+                  <arg>
+                  Nolabel
+                    expression (extended_indexoperators.ml[23,436+13]..[23,436+14])
+                      Pexp_ident "x" (extended_indexoperators.ml[23,436+13]..[23,436+14])
+                  <arg>
+                  Nolabel
+                    expression (extended_indexoperators.ml[23,436+17]..[23,436+18])
+                      Pexp_constant PConst_int (0,None)
+                ]
+          ]
+    ]
+]
+

diff --git a/testsuite/tests/ppx-contexts/Makefile b/testsuite/tests/ppx-contexts/Makefile
new file mode 100644 (file)
index 0000000..fe93607
--- /dev/null
+++ b/testsuite/tests/ppx-contexts/Makefile
@@ -0,0 +1,28 @@
+BASEDIR=../..
+
+INCLUDES=\
+  -I $(OTOPDIR)/parsing \
+  -I $(OTOPDIR)/utils \
+  -I $(OTOPDIR)/compilerlibs
+
+myppx=$(shell $(CYGPATH) '$(OCAMLRUN)') ./program$(EXE)
+
+.PHONY: run
+run: program$(EXE) test.reference
+       @echo " ... testing -thread and -vmthread are propagated to PPX:"
+       @( $(OCAMLC) -c -thread -ppx '$(myppx)' test.ml \
+          && $(OCAMLC) -c -vmthread -ppx '$(myppx)' test.ml ) 2> test.result
+       @$(DIFF) test.reference test.result >/dev/null \
+       && echo " => passed" || echo " => failed"
+
+program$(EXE): program.ml Makefile
+       @$(OCAMLC) -o program$(EXE) $(INCLUDES) ocamlcommon.cma ./program.ml
+
+.PHONY: promote
+promote: defaultpromote
+
+.PHONY: clean
+clean: defaultclean
+       @rm -f program$(EXE) test.result *.cm*
+
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/ppx-contexts/program.ml b/testsuite/tests/ppx-contexts/program.ml
new file mode 100644 (file)
index 0000000..738fd9a
--- /dev/null
+++ b/testsuite/tests/ppx-contexts/program.ml
@@ -0,0 +1,10 @@
+(* A simple PPX *)
+
+open Ast_mapper
+
+let () =
+  register "test" (fun _ ->
+      Printf.eprintf "use_threads=%b\n" !Clflags.use_threads;
+      Printf.eprintf "use_vmthreads=%b\n" !Clflags.use_vmthreads;
+      default_mapper);
+

diff --git a/testsuite/tests/ppx-contexts/test.ml b/testsuite/tests/ppx-contexts/test.ml
new file mode 100644 (file)
index 0000000..e790aeb
--- /dev/null
+++ b/testsuite/tests/ppx-contexts/test.ml
@@ -0,0 +1 @@
+(* empty *)

diff --git a/testsuite/tests/ppx-contexts/test.reference b/testsuite/tests/ppx-contexts/test.reference
new file mode 100644 (file)
index 0000000..ac117c7
--- /dev/null
+++ b/testsuite/tests/ppx-contexts/test.reference
@@ -0,0 +1,4 @@
+use_threads=true
+use_vmthreads=false
+use_threads=false
+use_vmthreads=true

diff --git a/testsuite/tests/prim-bigstring/bigstring_access.ml b/testsuite/tests/prim-bigstring/bigstring_access.ml
index 512181f088e91043ff3bcb165bc665f45b505242..392caecd6c34d81357f1f7fd434f8e6543b4dca6 100644 (file)
--- a/testsuite/tests/prim-bigstring/bigstring_access.ml
+++ b/testsuite/tests/prim-bigstring/bigstring_access.ml
@@ -31,14 +31,14 @@ let assert_bound_check2 f v1 v2 =
     ignore(f v1 v2);
     assert false
   with
-     | Invalid_argument("index out of bounds") -> ()
+     | Invalid_argument _ -> ()
 
 let assert_bound_check3 f v1 v2 v3 =
   try
     ignore(f v1 v2 v3);
     assert false
   with
-     | Invalid_argument("index out of bounds") -> ()
+     | Invalid_argument _ -> ()
 
 let () =
   assert_bound_check2 caml_bigstring_get_16 s (-1);

diff --git a/testsuite/tests/prim-bigstring/string_access.ml b/testsuite/tests/prim-bigstring/string_access.ml
index 48964c0b3372e19b7d14d995335e1d1c7a6648cb..3fbb9664e34746364a0588bbdb9169ba958b85ad 100644 (file)
--- a/testsuite/tests/prim-bigstring/string_access.ml
+++ b/testsuite/tests/prim-bigstring/string_access.ml
@@ -18,14 +18,14 @@ let assert_bound_check2 f v1 v2 =
     ignore(f v1 v2);
     assert false
   with
-     | Invalid_argument("index out of bounds") -> ()
+     | Invalid_argument _ -> ()
 
 let assert_bound_check3 f v1 v2 v3 =
   try
     ignore(f v1 v2 v3);
     assert false
   with
-     | Invalid_argument("index out of bounds") -> ()
+     | Invalid_argument _ -> ()
 
 let () =
   assert_bound_check2 caml_string_get_16 s (-1);

diff --git a/testsuite/tests/printing-types/Makefile b/testsuite/tests/printing-types/Makefile
new file mode 100644 (file)
index 0000000..9625a3f
--- /dev/null
+++ b/testsuite/tests/printing-types/Makefile
@@ -0,0 +1,3 @@
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.toplevel
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/printing-types/pr248.ml b/testsuite/tests/printing-types/pr248.ml
new file mode 100644 (file)
index 0000000..6f83e57
--- /dev/null
+++ b/testsuite/tests/printing-types/pr248.ml
@@ -0,0 +1,13 @@
+(** Test that weak variables keep their names long enough *)
+
+let f y = fun x -> x
+let blah = f 0
+let splash () = blah (failwith "coucou")
+let blurp = f 0;;
+
+blah 1;;
+
+let g = f ();;
+
+g (fun x -> x);;
+let h = g (f ());;

diff --git a/testsuite/tests/printing-types/pr248.ml.reference b/testsuite/tests/printing-types/pr248.ml.reference
new file mode 100644 (file)
index 0000000..44c9fad
--- /dev/null
+++ b/testsuite/tests/printing-types/pr248.ml.reference
@@ -0,0 +1,10 @@
+
+#           val f : 'a -> 'b -> 'b = <fun>
+val blah : '_weak1 -> '_weak1 = <fun>
+val splash : unit -> '_weak1 = <fun>
+val blurp : '_weak2 -> '_weak2 = <fun>
+#   - : int = 1
+#   val g : '_weak3 -> '_weak3 = <fun>
+#   - : '_weak4 -> '_weak4 = <fun>
+# val h : '_weak4 -> '_weak4 = <fun>
+# 

diff --git a/testsuite/tests/runtime-errors/Makefile b/testsuite/tests/runtime-errors/Makefile
index cee8ca8ca48d5dd89406f507dbada5cd7985e08a..b7f05895fbb2f279afb3091ccb824de92a8347b7 100644 (file)
--- a/testsuite/tests/runtime-errors/Makefile
+++ b/testsuite/tests/runtime-errors/Makefile
@@ -30,8 +30,9 @@ compile:
            $(OCAMLOPT) -w a -o $$F.native$(EXE) $$f; \
          fi; \
        done
-       @grep -q HAS_STACK_OVERFLOW_DETECTION $(TOPDIR)/config/s.h \
-         || rm -f stackoverflow.native$(EXE)
+       $(if $(findstring win32,$(UNIX_OR_WIN32)),:, \
+       @grep -q HAS_STACK_OVERFLOW_DETECTION $(TOPDIR)/byterun/caml/s.h \
+         || rm -f stackoverflow.native$(EXE))
 
 # Cygwin doesn't allow the stack limit to be changed - the 4096 is
 # intended to be larger than the its default stack size. The logic

diff --git a/testsuite/tests/runtime-errors/stackoverflow.bytecode.reference b/testsuite/tests/runtime-errors/stackoverflow.bytecode.reference
index a5bbdea33c8f82323cf17dd596ddc9f3672453c8..a62a27b545fd18c0d984166df31f9083f71f317a 100644 (file)
--- a/testsuite/tests/runtime-errors/stackoverflow.bytecode.reference
+++ b/testsuite/tests/runtime-errors/stackoverflow.bytecode.reference
@@ -2,3 +2,7 @@ x = 20000
 x = 10000
 x = 0
 Stack overflow caught
+x = 20000
+x = 10000
+x = 0
+second Stack overflow caught

diff --git a/testsuite/tests/runtime-errors/stackoverflow.ml b/testsuite/tests/runtime-errors/stackoverflow.ml
index ab53b8b068eac9122464a165f67a92568bbc2768..ad70d0cadb18c6c55feed2d0407a677733341957 100644 (file)
--- a/testsuite/tests/runtime-errors/stackoverflow.ml
+++ b/testsuite/tests/runtime-errors/stackoverflow.ml
@@ -9,7 +9,17 @@ let rec f x =
       raise Stack_overflow
 
 let _ =
+ begin
   try
     ignore(f 0)
   with Stack_overflow ->
     print_string "Stack overflow caught"; print_newline()
+ end ;
+ (* GPR#1289 *)
+ Printexc.record_backtrace true;
+ begin
+  try
+    ignore(f 0)
+  with Stack_overflow ->
+    print_string "second Stack overflow caught"; print_newline()
+ end

diff --git a/testsuite/tests/runtime-errors/stackoverflow.native.reference b/testsuite/tests/runtime-errors/stackoverflow.native.reference
index a5bbdea33c8f82323cf17dd596ddc9f3672453c8..a62a27b545fd18c0d984166df31f9083f71f317a 100644 (file)
--- a/testsuite/tests/runtime-errors/stackoverflow.native.reference
+++ b/testsuite/tests/runtime-errors/stackoverflow.native.reference
@@ -2,3 +2,7 @@ x = 20000
 x = 10000
 x = 0
 Stack overflow caught
+x = 20000
+x = 10000
+x = 0
+second Stack overflow caught

diff --git a/testsuite/tests/tool-lexyacc/grammar.mly b/testsuite/tests/tool-lexyacc/grammar.mly
index 02a7155e9f8ef4a3096d71c46f98372adb605b46..00821d51407571f5559b3165e3a42a3f4c022a89 100644 (file)
--- a/testsuite/tests/tool-lexyacc/grammar.mly
+++ b/testsuite/tests/tool-lexyacc/grammar.mly
@@ -29,7 +29,8 @@ lexer_definition:
 ;
 header:
     Taction
-        { $1 }
+        { $1 (* '"' test that ocamlyacc can
+                    handle comments correctly"*)" "(*" *) }
   |
         { Location(0,0) }
 ;

diff --git a/testsuite/tests/tool-ocamlc-compat32/Makefile b/testsuite/tests/tool-ocamlc-compat32/Makefile
new file mode 100644 (file)
index 0000000..938f025
--- /dev/null
+++ b/testsuite/tests/tool-ocamlc-compat32/Makefile
@@ -0,0 +1,25 @@
+BASEDIR=../..
+
+.PHONY: default
+default:
+       @printf " ... testing -compat-32"
+       @if ($(OCAMLC) -config | grep "word_size: *64") \
+       then $(MAKE) run; \
+       else echo ' => skipped (not compiled in 64bit)'; \
+       fi
+
+.PHONY: run
+run:
+       @$(OCAMLC) -compat-32 -c a.ml > test.result 2>&1 || true
+       @$(OCAMLC) -c a.ml
+       @$(OCAMLC) -compat-32 -a a.cmo -o a.cma >> test.result 2>&1 || true
+       @$(OCAMLC) -a a.cmo -o a.cma
+       @$(OCAMLC) -compat-32    a.cma -o a.byte -linkall >> test.result 2>&1 || true
+       @$(DIFF) test.reference test.result >/dev/null \
+       && echo " => passed" || echo " => failed"; \
+
+promote: defaultpromote
+
+clean: defaultclean
+
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/tool-ocamlc-compat32/a.ml b/testsuite/tests/tool-ocamlc-compat32/a.ml
new file mode 100644 (file)
index 0000000..81fdd45
--- /dev/null
+++ b/testsuite/tests/tool-ocamlc-compat32/a.ml
@@ -0,0 +1 @@
+let a = 0xffffffffffff

diff --git a/testsuite/tests/tool-ocamlc-compat32/test.reference b/testsuite/tests/tool-ocamlc-compat32/test.reference
new file mode 100644 (file)
index 0000000..8ef2562
--- /dev/null
+++ b/testsuite/tests/tool-ocamlc-compat32/test.reference
@@ -0,0 +1,6 @@
+File "a.ml", line 1:
+Error: Generated bytecode unit "a.cmo" cannot be used on a 32-bit platform
+File "_none_", line 1:
+Error: Generated bytecode library "a.cma" cannot be used on a 32-bit platform
+File "_none_", line 1:
+Error: Generated bytecode executable "a.byte" cannot be used on a 32-bit platform

diff --git a/testsuite/tests/tool-ocamldoc-2/Makefile b/testsuite/tests/tool-ocamldoc-2/Makefile
index 863c72c52cb7251b9924969ef663f6cc3a89189b..18ba07db7b62fb33e907f78a1e7d6289286c228c 100644 (file)
--- a/testsuite/tests/tool-ocamldoc-2/Makefile
+++ b/testsuite/tests/tool-ocamldoc-2/Makefile
@@ -17,6 +17,8 @@ BASEDIR=../..
 COMPFLAGS=-I $(OTOPDIR)/ocamldoc
 LD_PATH=$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix:$(TOPDIR)/otherlibs/str
 DOCFLAGS=-I $(OTOPDIR)/stdlib $(COMPFLAGS)\
+       -latextitle "1,subsection*" \
+       -latextitle "2,subsubsection*" \
        -latextitle "6,subsection*" \
        -latextitle "7,subsubsection*" \
        -latex-type-prefix "TYP" \

diff --git a/testsuite/tests/tool-ocamldoc-2/extensible_variant.ml b/testsuite/tests/tool-ocamldoc-2/extensible_variant.ml
index 01c67af44a0f1a494e3e7bd6b37ba6aefe34ee55..324a48d8809caff94643d410d1359933893b29da 100644 (file)
--- a/testsuite/tests/tool-ocamldoc-2/extensible_variant.ml
+++ b/testsuite/tests/tool-ocamldoc-2/extensible_variant.ml
@@ -1,8 +1,11 @@
-(** Testing display of extensible variant types.
+(** Testing display of extensible variant types and exceptions.
 
    @test_types_display
  *)
 
+(** Also check reference for {!M.A}, {!M.B}, {!M.C} and {!E} *)
+
+(** Extensible type *)
 type e = ..
 
 module M = struct
@@ -18,3 +21,5 @@ module type MT = sig
   | B (** B doc *)
   | C (** C doc *)
 end
+
+exception E

diff --git a/testsuite/tests/tool-ocamldoc-2/extensible_variant.reference b/testsuite/tests/tool-ocamldoc-2/extensible_variant.reference
index 859620027e91658ebb7424e1dfd305918204061d..a4b01455d29115a5f22fc033bb67488b34ce1246 100644 (file)
--- a/testsuite/tests/tool-ocamldoc-2/extensible_variant.reference
+++ b/testsuite/tests/tool-ocamldoc-2/extensible_variant.reference
@@ -7,7 +7,7 @@
 \usepackage{ocamldoc}
 \begin{document}
 \tableofcontents
-\section{Module {\tt{Extensible\_variant}} : Testing display of extensible variant types.}
+\section{Module {\tt{Extensible\_variant}} : Testing display of extensible variant types and exceptions.}
 \label{Extensible-underscorevariant}\index{Extensible-underscorevariant@\verb`Extensible_variant`}
 
 
@@ -17,10 +17,19 @@
 
 
 
+Also check reference for {\tt{Extensible\_variant.M.A}}[\ref{extension:Extensible-underscorevariant.M.A}], {\tt{Extensible\_variant.M.B}}[\ref{extension:Extensible-underscorevariant.M.B}], {\tt{Extensible\_variant.M.C}}[\ref{extension:Extensible-underscorevariant.M.C}] and {\tt{Extensible\_variant.E}}[\ref{exception:Extensible-underscorevariant.E}]
+
+
+
 \label{TYPExtensible-underscorevariant.e}\begin{ocamldoccode}
 type e = ..
 \end{ocamldoccode}
 \index{e@\verb`e`}
+\begin{ocamldocdescription}
+Extensible type
+
+
+\end{ocamldocdescription}
 
 
 
@@ -105,4 +114,12 @@ C doc
 
 
 
-\end{document}
\ No newline at end of file
+
+
+\label{exception:Extensible-underscorevariant.E}\begin{ocamldoccode}
+exception E
+\end{ocamldoccode}
+\index{E@\verb`E`}
+
+
+\end{document}

diff --git a/testsuite/tests/tool-ocamldoc-2/inline_records.reference b/testsuite/tests/tool-ocamldoc-2/inline_records.reference
index ff44400151e792fdc75704a580f5ea7e81c7c52e..506f253a8dc7e50ffd7842f2ee27bea3abef7a93 100644 (file)
--- a/testsuite/tests/tool-ocamldoc-2/inline_records.reference
+++ b/testsuite/tests/tool-ocamldoc-2/inline_records.reference
@@ -18,7 +18,7 @@
 
 
 
-\begin{ocamldoccode}
+\label{exception:Inline-underscorerecords.Simple}\begin{ocamldoccode}
 exception Simple
 \end{ocamldoccode}
 \index{Simple@\verb`Simple`}
@@ -31,7 +31,7 @@ A nice exception
 
 
 
-\begin{ocamldoccode}
+\label{exception:Inline-underscorerecords.Less}\begin{ocamldoccode}
 exception Less of int
 \end{ocamldoccode}
 \index{Less@\verb`Less`}
@@ -210,7 +210,7 @@ A gadt constructor
 
 
 
-\begin{ocamldoccode}
+\label{exception:Inline-underscorerecords.Error}\begin{ocamldoccode}
 exception Error of {\char123}  name : string ;
 \end{ocamldoccode}
 \begin{ocamldoccomment}
@@ -284,4 +284,4 @@ Two new constructors for ext
 \end{ocamldocdescription}
 
 
-\end{document}
\ No newline at end of file
+\end{document}

diff --git a/testsuite/tests/tool-ocamldoc-2/inline_records_bis.reference b/testsuite/tests/tool-ocamldoc-2/inline_records_bis.reference
index 091b0f0ea5fd5c2b9c4b73a99953e4c73cf01208..25986d097b7b354e47865ed49e11edc506958f48 100644 (file)
--- a/testsuite/tests/tool-ocamldoc-2/inline_records_bis.reference
+++ b/testsuite/tests/tool-ocamldoc-2/inline_records_bis.reference
@@ -18,7 +18,7 @@
 
 
 
-\begin{ocamldoccode}
+\label{exception:Inline-underscorerecords-underscorebis.Simple}\begin{ocamldoccode}
 exception Simple
 \end{ocamldoccode}
 \index{Simple@\verb`Simple`}
@@ -31,7 +31,7 @@ A nice exception
 
 
 
-\begin{ocamldoccode}
+\label{exception:Inline-underscorerecords-underscorebis.Less}\begin{ocamldoccode}
 exception Less of int
 \end{ocamldoccode}
 \index{Less@\verb`Less`}
@@ -210,7 +210,7 @@ A gadt constructor
 
 
 
-\begin{ocamldoccode}
+\label{exception:Inline-underscorerecords-underscorebis.Error}\begin{ocamldoccode}
 exception Error of {\char123}  name : string ;
 \end{ocamldoccode}
 \begin{ocamldoccomment}
@@ -283,4 +283,4 @@ Constructor G documentation
 
 Two new constructors for ext
 
-\end{document}
\ No newline at end of file
+\end{document}

diff --git a/testsuite/tests/tool-ocamldoc-2/level_0.mli b/testsuite/tests/tool-ocamldoc-2/level_0.mli
new file mode 100644 (file)
index 0000000..22c4665
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-2/level_0.mli
@@ -0,0 +1,15 @@
+(** Test for level 0 headings 
+ 
+  {1 Level 1} 
+   
+   Standard heading levels start at 1.
+
+  {0 Level 0}
+  A level 0 heading is guaranted to be at the same level that
+  the main heading of the module.
+
+  This setup allows users to start their standard heading at level 1 rather 
+  than 2, without losing the ability to add global level heading, 
+  when, if ever, such heading is warranted
+
+ *)

diff --git a/testsuite/tests/tool-ocamldoc-2/level_0.reference b/testsuite/tests/tool-ocamldoc-2/level_0.reference
new file mode 100644 (file)
index 0000000..331512f
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-2/level_0.reference
@@ -0,0 +1,36 @@
+\documentclass[11pt]{article} 
+\usepackage[latin1]{inputenc} 
+\usepackage[T1]{fontenc} 
+\usepackage{textcomp}
+\usepackage{fullpage} 
+\usepackage{url} 
+\usepackage{ocamldoc}
+\begin{document}
+\tableofcontents
+\section{Module {\tt{Level\_0}} : Test for level 0 headings }
+\label{Level-underscore0}\index{Level-underscore0@\verb`Level_0`}
+
+
+
+  \subsection*{Level 1}
+ 
+
+
+   Standard heading levels start at 1.
+
+
+  \section{Level 0}
+
+  A level 0 heading is guaranted to be at the same level that
+  the main heading of the module.
+
+
+  This setup allows users to start their standard heading at level 1 rather 
+  than 2, without losing the ability to add global level heading, 
+  when, if ever, such heading is warranted
+
+
+
+\ocamldocvspace{0.5cm}
+
+\end{document}

diff --git a/testsuite/tests/tool-ocamldoc-2/loop.reference b/testsuite/tests/tool-ocamldoc-2/loop.reference
index f9d6b43742fd843722b39ed6731e9f984d094978..8c386f300e891f4e173e995b40eef62e55bed0e2 100644 (file)
--- a/testsuite/tests/tool-ocamldoc-2/loop.reference
+++ b/testsuite/tests/tool-ocamldoc-2/loop.reference
@@ -33,4 +33,4 @@
 
 
 
-\end{document}
\ No newline at end of file
+\end{document}

diff --git a/testsuite/tests/tool-ocamldoc-2/short_description.reference b/testsuite/tests/tool-ocamldoc-2/short_description.reference
index 5ffb607536dbdb88caa9c00340de2917554b9a48..9cc843fc00a49d94b048ce03a10b4885c275e5ad 100644 (file)
--- a/testsuite/tests/tool-ocamldoc-2/short_description.reference
+++ b/testsuite/tests/tool-ocamldoc-2/short_description.reference
@@ -18,4 +18,4 @@ a short description in the global description of modules.
 
 
 
-\end{document}
\ No newline at end of file
+\end{document}

diff --git a/testsuite/tests/tool-ocamldoc-2/test.reference b/testsuite/tests/tool-ocamldoc-2/test.reference
index 55afe9770d48dbe6569eee19ef28651804e8c3ec..a9861f7ff9ca089a5689ed774755e9037e615114 100644 (file)
--- a/testsuite/tests/tool-ocamldoc-2/test.reference
+++ b/testsuite/tests/tool-ocamldoc-2/test.reference
@@ -71,4 +71,4 @@ Encore! Encore!
 
 
 
-\end{document}
\ No newline at end of file
+\end{document}

diff --git a/testsuite/tests/tool-ocamldoc-2/variants.reference b/testsuite/tests/tool-ocamldoc-2/variants.reference
index bb9e76018717ee093eda5b810a3f4a3bb01ea6ec..4d1753c72c25a34e954f0fe0793396877787d1cf 100644 (file)
--- a/testsuite/tests/tool-ocamldoc-2/variants.reference
+++ b/testsuite/tests/tool-ocamldoc-2/variants.reference
@@ -187,4 +187,4 @@ type no_documentation =
 \index{no-underscoredocumentation@\verb`no_documentation`}
 
 
-\end{document}
\ No newline at end of file
+\end{document}

diff --git a/testsuite/tests/tool-ocamldoc-html/Documentation_tags.mli b/testsuite/tests/tool-ocamldoc-html/Documentation_tags.mli
new file mode 100644 (file)
index 0000000..bac254a
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-html/Documentation_tags.mli
@@ -0,0 +1,19 @@
+(** Test the html rendering of ocamldoc documentation tags *)
+
+val heterological: unit
+(** 
+ @author yes
+ @param no No description
+ @param neither see no description  
+ @deprecated since the start of time
+ @return ()
+ @see "Documentation_tags.mli" Self reference
+ @since Now
+ @before Time not implemented
+*)
+
+val noop: unit
+(**
+ @raise Not_found Never
+ @raise Invalid_argument Never
+*)

diff --git a/testsuite/tests/tool-ocamldoc-html/Documentation_tags.reference b/testsuite/tests/tool-ocamldoc-html/Documentation_tags.reference
new file mode 100644 (file)
index 0000000..53f9d79
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-html/Documentation_tags.reference
@@ -0,0 +1,44 @@
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
+<html>
+<head>
+<link rel="stylesheet" href="style.css" type="text/css">
+<meta content="text/html; charset=iso-8859-1" http-equiv="Content-Type">
+<meta name="viewport" content="width=device-width, initial-scale=1">
+<link rel="Start" href="index.html">
+<link rel="Up" href="index.html">
+<link title="Index of values" rel=Appendix href="index_values.html">
+<link title="Index of modules" rel=Appendix href="index_modules.html">
+<link title="Documentation_tags" rel="Chapter" href="Documentation_tags.html"><title>Documentation_tags</title>
+</head>
+<body>
+<div class="navbar">&nbsp;<a class="up" href="index.html" title="Index">Up</a>
+&nbsp;</div>
+<h1>Module <a href="type_Documentation_tags.html">Documentation_tags</a></h1>
+
+<pre><span id="MODULEDocumentation_tags"><span class="keyword">module</span> Documentation_tags</span>: <code class="code"><span class="keyword">sig</span></code> <a href="Documentation_tags.html">..</a> <code class="code"><span class="keyword">end</span></code></pre><div class="info module top">
+<div class="info-desc">
+<p>Test the html rendering of ocamldoc documentation tags</p>
+</div>
+</div>
+<hr width="100%">
+
+<pre><span id="VALheterological"><span class="keyword">val</span> heterological</span> : <code class="type">unit</code></pre><div class="info ">
+<div class="info-deprecated">
+<span class="warning">Deprecated.</span>since the start of time</div>
+<ul class="info-attributes">
+<li><b>Author(s):</b> yes</li>
+<li><b>Before Time </b> not implemented</li>
+<li><b>Since</b> Now</li>
+<li><b>Returns</b> ()</li>
+<li><b>See also</b> <i>Documentation_tags.mli</i> Self reference</li>
+</ul>
+</div>
+
+<pre><span id="VALnoop"><span class="keyword">val</span> noop</span> : <code class="type">unit</code></pre><div class="info ">
+<ul class="info-attributes">
+<li><b>Raises</b><ul><li><code>Not_found</code> Never</li>
+<li><code>Invalid_argument</code> Never</li>
+</ul></li>
+</ul>
+</div>
+</body></html>
\ No newline at end of file

diff --git a/testsuite/tests/tool-ocamldoc-html/Inline_records.reference b/testsuite/tests/tool-ocamldoc-html/Inline_records.reference
index 856c902fcbe66edabab38c4892dd732fb52857e1..92d9e79d36ac7d0a1ffd101692fbe912e8610079 100644 (file)
--- a/testsuite/tests/tool-ocamldoc-html/Inline_records.reference
+++ b/testsuite/tests/tool-ocamldoc-html/Inline_records.reference
@@ -17,20 +17,26 @@
 &nbsp;</div>
 <h1>Module <a href="type_Inline_records.html">Inline_records</a></h1>
 
-<pre><span class="keyword">module</span> Inline_records: <code class="code"><span class="keyword">sig</span></code> <a href="Inline_records.html">..</a> <code class="code"><span class="keyword">end</span></code></pre><div class="info module top">
-This test focuses on the printing of documentation for inline record
-  within the latex generator.<br>
+<pre><span id="MODULEInline_records"><span class="keyword">module</span> Inline_records</span>: <code class="code"><span class="keyword">sig</span></code> <a href="Inline_records.html">..</a> <code class="code"><span class="keyword">end</span></code></pre><div class="info module top">
+<div class="info-desc">
+<p>This test focuses on the printing of documentation for inline record
+  within the latex generator.</p>
+</div>
 </div>
 <hr width="100%">
 
 <pre><span id="EXCEPTIONSimple"><span class="keyword">exception</span> Simple</span></pre>
 <div class="info ">
-A nice exception<br>
+<div class="info-desc">
+<p>A nice exception</p>
+</div>
 </div>
 
 <pre><span id="TYPEext"><span class="keyword">type</span> <code class="type"></code>ext</span> = ..</pre>
 <div class="info ">
-An open sum type<br>
+<div class="info-desc">
+<p>An open sum type</p>
+</div>
 </div>
 
 
@@ -41,7 +47,9 @@ An open sum type<br>
 <td align="left" valign="top" >
 <code><span id="TYPEELTr.lbl">lbl</span>&nbsp;: <code class="type">int</code>;</code></td>
 <td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
-Field documentation for non-inline, <code class="code">lbl&nbsp;:&nbsp;int</code><br>
+<div class="info-desc">
+<p>Field documentation for non-inline, <code class="code">lbl&nbsp;:&nbsp;int</code></p>
+</div>
 </div>
 </td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
 </tr>
@@ -51,14 +59,18 @@ Field documentation for non-inline, <code class="code">lbl&nbsp;:&nbsp;int</code
 <td align="left" valign="top" >
 <code><span id="TYPEELTr.more">more</span>&nbsp;: <code class="type">int list</code>;</code></td>
 <td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
-More documentation for r, <code class="code">more&nbsp;:&nbsp;int&nbsp;list</code><br>
+<div class="info-desc">
+<p>More documentation for r, <code class="code">more&nbsp;:&nbsp;int&nbsp;list</code></p>
+</div>
 </div>
 </td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
 </tr></table>
 }
 
 <div class="info ">
-A simple record type for reference<br>
+<div class="info-desc">
+<p>A simple record type for reference</p>
+</div>
 </div>
 
 
@@ -74,7 +86,9 @@ A simple record type for reference<br>
 <td align="left" valign="top" >
 <code><span id="TYPEELTInline_records.A.lbl">lbl</span>&nbsp;: <code class="type">int</code>;</code></td>
 <td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
-<code class="code"><span class="constructor">A</span></code> field documentation<br>
+<div class="info-desc">
+<p><code class="code"><span class="constructor">A</span></code> field documentation</p>
+</div>
 </div>
 </td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
 </tr>
@@ -84,20 +98,26 @@ A simple record type for reference<br>
 <td align="left" valign="top" >
 <code><span id="TYPEELTInline_records.A.more">more</span>&nbsp;: <code class="type">int list</code>;</code></td>
 <td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
-More <code class="code"><span class="constructor">A</span></code> field documentation<br>
+<div class="info-desc">
+<p>More <code class="code"><span class="constructor">A</span></code> field documentation</p>
+</div>
 </div>
 </td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
 </tr></table>
 }
 </code></td>
 <td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
-Constructor documentation<br>
+<div class="info-desc">
+<p>Constructor documentation</p>
+</div>
 </div>
 </td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
 </tr></table>
 
 <div class="info ">
-A sum type with one inline record<br>
+<div class="info-desc">
+<p>A sum type with one inline record</p>
+</div>
 </div>
 
 
@@ -113,7 +133,9 @@ A sum type with one inline record<br>
 <td align="left" valign="top" >
 <code><span id="TYPEELTInline_records.B.a_label_for_B">a_label_for_B</span>&nbsp;: <code class="type">int</code>;</code></td>
 <td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
-<code class="code"><span class="constructor">B</span></code> field documentation<br>
+<div class="info-desc">
+<p><code class="code"><span class="constructor">B</span></code> field documentation</p>
+</div>
 </div>
 </td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
 </tr>
@@ -123,14 +145,18 @@ A sum type with one inline record<br>
 <td align="left" valign="top" >
 <code><span id="TYPEELTInline_records.B.more_label_for_B">more_label_for_B</span>&nbsp;: <code class="type">int list</code>;</code></td>
 <td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
-More <code class="code"><span class="constructor">B</span></code> field documentation<br>
+<div class="info-desc">
+<p>More <code class="code"><span class="constructor">B</span></code> field documentation</p>
+</div>
 </div>
 </td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
 </tr></table>
 }
 </code></td>
 <td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
-Constructor B documentation<br>
+<div class="info-desc">
+<p>Constructor B documentation</p>
+</div>
 </div>
 </td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
 </tr>
@@ -145,7 +171,9 @@ Constructor B documentation<br>
 <td align="left" valign="top" >
 <code><span id="TYPEELTInline_records.C.c_has_label_too">c_has_label_too</span>&nbsp;: <code class="type">float</code>;</code></td>
 <td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
-<code class="code"><span class="constructor">C</span></code> field documentation<br>
+<div class="info-desc">
+<p><code class="code"><span class="constructor">C</span></code> field documentation</p>
+</div>
 </div>
 </td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
 </tr>
@@ -155,20 +183,26 @@ Constructor B documentation<br>
 <td align="left" valign="top" >
 <code><span id="TYPEELTInline_records.C.more_than_one">more_than_one</span>&nbsp;: <code class="type">unit</code>;</code></td>
 <td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
-... documentations<br>
+<div class="info-desc">
+<p>... documentations</p>
+</div>
 </div>
 </td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
 </tr></table>
 }
 </code></td>
 <td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
-Constructor C documentation<br>
+<div class="info-desc">
+<p>Constructor C documentation</p>
+</div>
 </div>
 </td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
 </tr></table>
 
 <div class="info ">
-A sum type with two inline records<br>
+<div class="info-desc">
+<p>A sum type with two inline records</p>
+</div>
 </div>
 
 
@@ -184,20 +218,26 @@ A sum type with two inline records<br>
 <td align="left" valign="top" >
 <code><span id="TYPEELTInline_records.D.any">any</span>&nbsp;: <code class="type">'a</code>;</code></td>
 <td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
-<code class="code"><span class="constructor">A</span></code> field <code class="code">any:<span class="keywordsign">'</span>a</code> for <code class="code"><span class="constructor">D</span></code> in <code class="code">any</code>.<br>
+<div class="info-desc">
+<p><code class="code"><span class="constructor">A</span></code> field <code class="code">any:<span class="keywordsign">'</span>a</code> for <code class="code"><span class="constructor">D</span></code> in <code class="code">any</code>.</p>
+</div>
 </div>
 </td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
 </tr></table>
 }
  <span class="keyword">-></span> <code class="type"><a href="Inline_records.html#TYPEany">any</a></code></code></td>
 <td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
-Constructor D documentation<br>
+<div class="info-desc">
+<p>Constructor D documentation</p>
+</div>
 </div>
 </td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
 </tr></table>
 
 <div class="info ">
-A gadt constructor<br>
+<div class="info-desc">
+<p>A gadt constructor</p>
+</div>
 </div>
 
 
@@ -208,7 +248,9 @@ A gadt constructor<br>
 <td align="left" valign="top" >
 <code><span id="TYPEELTInline_records.Error.name">name</span>&nbsp;: <code class="type">string</code>;</code></td>
 <td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
-Error field documentation <code class="code">name:string</code><br>
+<div class="info-desc">
+<p>Error field documentation <code class="code">name:string</code></p>
+</div>
 </div>
 </td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
 </tr></table>
@@ -226,14 +268,18 @@ Error field documentation <code class="code">name:string</code><br>
 <td align="left" valign="top" >
 <code><span id="TYPEELTInline_records.E.yet_another_field">yet_another_field</span>&nbsp;: <code class="type">unit</code>;</code></td>
 <td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
-Field documentation for <code class="code"><span class="constructor">E</span></code> in ext<br>
+<div class="info-desc">
+<p>Field documentation for <code class="code"><span class="constructor">E</span></code> in ext</p>
+</div>
 </div>
 </td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
 </tr></table>
 }
 </code></td>
 <td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
-Constructor E documentation<br>
+<div class="info-desc">
+<p>Constructor E documentation</p>
+</div>
 </div>
 </td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
 </tr>
@@ -248,14 +294,18 @@ Constructor E documentation<br>
 <td align="left" valign="top" >
 <code><span id="TYPEELTInline_records.F.even_more">even_more</span>&nbsp;: <code class="type">int -> int</code>;</code></td>
 <td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
-Some field documentations for <code class="code"><span class="constructor">F</span></code><br>
+<div class="info-desc">
+<p>Some field documentations for <code class="code"><span class="constructor">F</span></code></p>
+</div>
 </div>
 </td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
 </tr></table>
 }
 </code></td>
 <td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
-Constructor F documentation<br>
+<div class="info-desc">
+<p>Constructor F documentation</p>
+</div>
 </div>
 </td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
 </tr>
@@ -270,20 +320,26 @@ Constructor F documentation<br>
 <td align="left" valign="top" >
 <code><span id="TYPEELTInline_records.G.last">last</span>&nbsp;: <code class="type">int -> int</code>;</code></td>
 <td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
-The last and least field documentation<br>
+<div class="info-desc">
+<p>The last and least field documentation</p>
+</div>
 </div>
 </td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
 </tr></table>
 }
 </code></td>
 <td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
-Constructor G documentation<br>
+<div class="info-desc">
+<p>Constructor G documentation</p>
+</div>
 </div>
 </td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
 </tr></table>
 
 <div class="info ">
-Two new constructors for ext<br>
+<div class="info-desc">
+<p>Two new constructors for ext</p>
+</div>
 </div>
 
 </body></html>
\ No newline at end of file

diff --git a/testsuite/tests/tool-ocamldoc-html/Item_ids.mli b/testsuite/tests/tool-ocamldoc-html/Item_ids.mli
new file mode 100644 (file)
index 0000000..9001d3a
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-html/Item_ids.mli
@@ -0,0 +1,13 @@
+(** Check that all toplevel items are given a unique id. *)
+
+exception Ex
+type t
+val x: t
+type ext = ..
+type ext += A
+class c: object end
+class type ct= object end
+[@@@attribute]
+module M: sig end
+module type s = sig end
+

diff --git a/testsuite/tests/tool-ocamldoc-html/Item_ids.reference b/testsuite/tests/tool-ocamldoc-html/Item_ids.reference
new file mode 100644 (file)
index 0000000..94eddef
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-html/Item_ids.reference
@@ -0,0 +1,53 @@
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
+<html>
+<head>
+<link rel="stylesheet" href="style.css" type="text/css">
+<meta content="text/html; charset=iso-8859-1" http-equiv="Content-Type">
+<meta name="viewport" content="width=device-width, initial-scale=1">
+<link rel="Start" href="index.html">
+<link rel="Up" href="index.html">
+<link title="Index of types" rel=Appendix href="index_types.html">
+<link title="Index of extensions" rel=Appendix href="index_extensions.html">
+<link title="Index of exceptions" rel=Appendix href="index_exceptions.html">
+<link title="Index of values" rel=Appendix href="index_values.html">
+<link title="Index of classes" rel=Appendix href="index_classes.html">
+<link title="Index of class types" rel=Appendix href="index_class_types.html">
+<link title="Index of modules" rel=Appendix href="index_modules.html">
+<link title="Index of module types" rel=Appendix href="index_module_types.html">
+<link title="Item_ids" rel="Chapter" href="Item_ids.html"><title>Item_ids</title>
+</head>
+<body>
+<div class="navbar">&nbsp;<a class="up" href="index.html" title="Index">Up</a>
+&nbsp;</div>
+<h1>Module <a href="type_Item_ids.html">Item_ids</a></h1>
+
+<pre><span id="MODULEItem_ids"><span class="keyword">module</span> Item_ids</span>: <code class="code"><span class="keyword">sig</span></code> <a href="Item_ids.html">..</a> <code class="code"><span class="keyword">end</span></code></pre><div class="info module top">
+<div class="info-desc">
+<p>Check that all toplevel items are given a unique id.</p>
+</div>
+</div>
+<hr width="100%">
+
+<pre><span id="EXCEPTIONEx"><span class="keyword">exception</span> Ex</span></pre>
+
+<pre><span id="TYPEt"><span class="keyword">type</span> <code class="type"></code>t</span> </pre>
+
+
+<pre><span id="VALx"><span class="keyword">val</span> x</span> : <code class="type"><a href="Item_ids.html#TYPEt">t</a></code></pre>
+<pre><span id="TYPEext"><span class="keyword">type</span> <code class="type"></code>ext</span> = ..</pre>
+
+<pre><code><span class="keyword">type</span> <code class="type"></code><a href="Item_ids.html#TYPEext">ext</a> += </code></pre><table class="typetable">
+<tr>
+<td align="left" valign="top" >
+<code><span class="keyword">|</span></code></td>
+<td align="left" valign="top" >
+<code><span id="EXTENSIONA">A</span></code></td>
+
+</tr></table>
+
+
+
+<pre><span id="TYPEc"><span class="keyword">class</span> <a href="Item_ids.c-c.html">c</a></span> : <code class="type"></code><code class="code"><span class="keyword">object</span></code> <a href="Item_ids.c-c.html">..</a> <code class="code"><span class="keyword">end</span></code></pre>
+<pre><span id="TYPEct"><span class="keyword">class type</span> <a href="Item_ids.ct-c.html">ct</a></span> = <code class="code"><span class="keyword">object</span></code> <a href="Item_ids.ct-c.html">..</a> <code class="code"><span class="keyword">end</span></code></pre>
+<pre><span id="MODULEM"><span class="keyword">module</span> <a href="Item_ids.M.html">M</a></span>: <code class="code"><span class="keyword">sig</span></code> <a href="Item_ids.M.html">..</a> <code class="code"><span class="keyword">end</span></code></pre>
+<pre><span id="MODULETYPEs"><span class="keyword">module type</span> <a href="Item_ids.s-c.html">s</a></span> = <code class="code"><span class="keyword">sig</span></code> <a href="Item_ids.s-c.html">..</a> <code class="code"><span class="keyword">end</span></code></pre></body></html>
\ No newline at end of file

diff --git a/testsuite/tests/tool-ocamldoc-html/Linebreaks.mli b/testsuite/tests/tool-ocamldoc-html/Linebreaks.mli
index 764e7f4a5d09ef7118c1f089c162dfd4c5522f52..cca816f301be813af6e6df940653813a6421f184 100644 (file)
--- a/testsuite/tests/tool-ocamldoc-html/Linebreaks.mli
+++ b/testsuite/tests/tool-ocamldoc-html/Linebreaks.mli
@@ -16,8 +16,7 @@
    ]}
    See {{:http://caml.inria.fr/mantis/view.php?id=6341} MPR#6341} for more
    details or the file Linebreaks.html generated by ocamldoc from this file.
-
-   -Second, outside of a "pre"  tags, blank characters in embedded code
+   - Second, outside of a "pre"  tags, blank characters in embedded code
    should be escaped, in order to make them render in a "pre"-like fashion.
    A good example should be the files type_{i Modulename}.html generated by
    ocamldoc that should contains the signature of the module [Modulename] in

diff --git a/testsuite/tests/tool-ocamldoc-html/Linebreaks.reference b/testsuite/tests/tool-ocamldoc-html/Linebreaks.reference
index 71a020fbd17eaff240d52bbf8f939868a50863b5..8abb6dc9f06f3c6e4c68d0d1a244e6d0eda4fa51 100644 (file)
--- a/testsuite/tests/tool-ocamldoc-html/Linebreaks.reference
+++ b/testsuite/tests/tool-ocamldoc-html/Linebreaks.reference
@@ -20,13 +20,13 @@
 &nbsp;</div>
 <h1>Module <a href="type_Linebreaks.html">Linebreaks</a></h1>
 
-<pre><span class="keyword">module</span> Linebreaks: <code class="code"><span class="keyword">sig</span></code> <a href="Linebreaks.html">..</a> <code class="code"><span class="keyword">end</span></code></pre><div class="info module top">
-This file tests the encoding of linebreak inside OCaml code by the
-   ocamldoc html backend.
-<p>
+<pre><span id="MODULELinebreaks"><span class="keyword">module</span> Linebreaks</span>: <code class="code"><span class="keyword">sig</span></code> <a href="Linebreaks.html">..</a> <code class="code"><span class="keyword">end</span></code></pre><div class="info module top">
+<div class="info-desc">
+<p>This file tests the encoding of linebreak inside OCaml code by the
+   ocamldoc html backend.</p>
+
+<p>Two slightly different aspects are tested in this very file.</p>
 
-   Two slightly different aspects are tested in this very file.
-<p>
 <ul>
 <li>First, inside a "pre" tags, blanks character should not be escaped.
    For instance, the generated html code for this test fragment should not
@@ -39,14 +39,14 @@ This file tests the encoding of linebreak inside OCaml code by the
    </code></pre>
    See <a href="http://caml.inria.fr/mantis/view.php?id=6341"> MPR#6341</a> for more
    details or the file Linebreaks.html generated by ocamldoc from this file.</li>
-</ul>
-
-   -Second, outside of a "pre"  tags, blank characters in embedded code
+<li>Second, outside of a "pre"  tags, blank characters in embedded code
    should be escaped, in order to make them render in a "pre"-like fashion.
    A good example should be the files type_<i>Modulename</i>.html generated by
    ocamldoc that should contains the signature of the module <code class="code"><span class="constructor">Modulename</span></code> in
    a "code" tags.
-   For instance with the following type definitions,<br>
+   For instance with the following type definitions,</li>
+</ul>
+</div>
 </div>
 <hr width="100%">
 
@@ -98,8 +98,8 @@ This file tests the encoding of linebreak inside OCaml code by the
 
 
 <pre><span id="VALx"><span class="keyword">val</span> x</span> : <code class="type"><a href="Linebreaks.html#TYPEa">a</a></code></pre>
-<pre><span class="keyword">module</span> <a href="Linebreaks.S.html">S</a>: <code class="code"><span class="keyword">sig</span></code> <a href="Linebreaks.S.html">..</a> <code class="code"><span class="keyword">end</span></code></pre>
-<pre><span class="keyword">module type</span> <a href="Linebreaks.s-c.html">s</a> = <code class="code"><span class="keyword">sig</span></code> <a href="Linebreaks.s-c.html">..</a> <code class="code"><span class="keyword">end</span></code></pre>
+<pre><span id="MODULES"><span class="keyword">module</span> <a href="Linebreaks.S.html">S</a></span>: <code class="code"><span class="keyword">sig</span></code> <a href="Linebreaks.S.html">..</a> <code class="code"><span class="keyword">end</span></code></pre>
+<pre><span id="MODULETYPEs"><span class="keyword">module type</span> <a href="Linebreaks.s-c.html">s</a></span> = <code class="code"><span class="keyword">sig</span></code> <a href="Linebreaks.s-c.html">..</a> <code class="code"><span class="keyword">end</span></code></pre>
 <pre><span id="TYPEd"><span class="keyword">class type</span> <a href="Linebreaks.d-c.html">d</a></span> = <code class="code"><span class="keyword">object</span></code> <a href="Linebreaks.d-c.html">..</a> <code class="code"><span class="keyword">end</span></code></pre>
 <pre><span id="EXCEPTIONE"><span class="keyword">exception</span> E</span> <span class="keyword">of</span> <code>{</code><table class="typetable">
 <tr>
@@ -111,9 +111,7 @@ This file tests the encoding of linebreak inside OCaml code by the
 </tr></table>
 }
 </pre>
-<br>
-type_Linebreaks.html should contain
-<p>
+<p>type_Linebreaks.html should contain</p>
 
 <pre class="codepre"><code class="code"><span class="keyword">sig</span>
   <span class="keyword">type</span> a = <span class="constructor">A</span>
@@ -128,13 +126,10 @@ type_Linebreaks.html should contain
   <span class="keyword">exception</span> <span class="constructor">E</span> <span class="keyword">of</span> { inline : int; }
 <span class="keyword">end</span>
 </code></pre>
-<p>
-
-with &lt;br&gt; tags used for linebreaks.
+<p>with &lt;br&gt; tags used for linebreaks.
 Another example would be <code class="code">&nbsp;<span class="keyword">let</span>&nbsp;f&nbsp;x&nbsp;=<br>
-x</code> which is rendered with a &lt;br&gt; linebreak inside Linebreaks.html.
-<p>
+x</code> which is rendered with a &lt;br&gt; linebreak inside Linebreaks.html.</p>
 
-See <a href="http://caml.inria.fr/mantis/view.php?id=7272">MPR#7272</a> for more
-information.<br>
+<p>See <a href="http://caml.inria.fr/mantis/view.php?id=7272">MPR#7272</a> for more
+information.</p>
 </body></html>
\ No newline at end of file

diff --git a/testsuite/tests/tool-ocamldoc-html/Loop.reference b/testsuite/tests/tool-ocamldoc-html/Loop.reference
index 235b4775388fe6b640208e936c2c9eafa05dc796..2025479d06ccaa6e82bf52e189a056248ed853ff 100644 (file)
--- a/testsuite/tests/tool-ocamldoc-html/Loop.reference
+++ b/testsuite/tests/tool-ocamldoc-html/Loop.reference
@@ -14,7 +14,7 @@
 &nbsp;</div>
 <h1>Module <a href="type_Loop.html">Loop</a></h1>
 
-<pre><span class="keyword">module</span> Loop: <code class="code"><span class="keyword">sig</span></code> <a href="Loop.html">..</a> <code class="code"><span class="keyword">end</span></code></pre><hr width="100%">
+<pre><span id="MODULELoop"><span class="keyword">module</span> Loop</span>: <code class="code"><span class="keyword">sig</span></code> <a href="Loop.html">..</a> <code class="code"><span class="keyword">end</span></code></pre><hr width="100%">
 
-<pre><span class="keyword">module</span> <a href="Loop.A.html">A</a>: <code class="type"><a href="Loop.B.html">B</a></code></pre>
-<pre><span class="keyword">module</span> <a href="Loop.B.html">B</a>: <code class="type"><a href="Loop.A.html">A</a></code></pre></body></html>
\ No newline at end of file
+<pre><span id="MODULEA"><span class="keyword">module</span> <a href="Loop.A.html">A</a></span>: <code class="type"><a href="Loop.B.html">B</a></code></pre>
+<pre><span id="MODULEB"><span class="keyword">module</span> <a href="Loop.B.html">B</a></span>: <code class="type"><a href="Loop.A.html">A</a></code></pre></body></html>
\ No newline at end of file

diff --git a/testsuite/tests/tool-ocamldoc-html/Module_whitespace.reference b/testsuite/tests/tool-ocamldoc-html/Module_whitespace.reference
index 4691b2d435143f7e2bd5af1fec200c7f8eee91f5..fc98a0bb9d379d546e3851fa00acd9262f2f3a94 100644 (file)
--- a/testsuite/tests/tool-ocamldoc-html/Module_whitespace.reference
+++ b/testsuite/tests/tool-ocamldoc-html/Module_whitespace.reference
@@ -14,9 +14,9 @@
 &nbsp;</div>
 <h1>Module <a href="type_Module_whitespace.html">Module_whitespace</a></h1>
 
-<pre><span class="keyword">module</span> Module_whitespace: <code class="code"><span class="keyword">sig</span></code> <a href="Module_whitespace.html">..</a> <code class="code"><span class="keyword">end</span></code></pre><hr width="100%">
+<pre><span id="MODULEModule_whitespace"><span class="keyword">module</span> Module_whitespace</span>: <code class="code"><span class="keyword">sig</span></code> <a href="Module_whitespace.html">..</a> <code class="code"><span class="keyword">end</span></code></pre><hr width="100%">
 
-<pre><span class="keyword">module</span> <a href="Module_whitespace.M.html">M</a>: <code class="type">Set.Make</code><code class="code">(</code><code class="code"><span class="keyword">sig</span></code></pre><div class="sig_block">
+<pre><span id="MODULEM"><span class="keyword">module</span> <a href="Module_whitespace.M.html">M</a></span>: <code class="type">Set.Make</code><code class="code">(</code><code class="code"><span class="keyword">sig</span></code></pre><div class="sig_block">
 <pre><span id="TYPEt"><span class="keyword">type</span> <code class="type"></code>t</span> = <code class="type">int</code> </pre>
 
 

diff --git a/testsuite/tests/tool-ocamldoc-html/No_preamble.mli b/testsuite/tests/tool-ocamldoc-html/No_preamble.mli
new file mode 100644 (file)
index 0000000..2760e26
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-html/No_preamble.mli
@@ -0,0 +1,5 @@
+
+open String
+
+(** This is a documentation comment for [x], not a module preamble. *)
+val x: unit

diff --git a/testsuite/tests/tool-ocamldoc-html/No_preamble.reference b/testsuite/tests/tool-ocamldoc-html/No_preamble.reference
new file mode 100644 (file)
index 0000000..f34662e
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-html/No_preamble.reference
@@ -0,0 +1,25 @@
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
+<html>
+<head>
+<link rel="stylesheet" href="style.css" type="text/css">
+<meta content="text/html; charset=iso-8859-1" http-equiv="Content-Type">
+<meta name="viewport" content="width=device-width, initial-scale=1">
+<link rel="Start" href="index.html">
+<link rel="Up" href="index.html">
+<link title="Index of values" rel=Appendix href="index_values.html">
+<link title="Index of modules" rel=Appendix href="index_modules.html">
+<link title="No_preamble" rel="Chapter" href="No_preamble.html"><title>No_preamble</title>
+</head>
+<body>
+<div class="navbar">&nbsp;<a class="up" href="index.html" title="Index">Up</a>
+&nbsp;</div>
+<h1>Module <a href="type_No_preamble.html">No_preamble</a></h1>
+
+<pre><span id="MODULENo_preamble"><span class="keyword">module</span> No_preamble</span>: <code class="code"><span class="keyword">sig</span></code> <a href="No_preamble.html">..</a> <code class="code"><span class="keyword">end</span></code></pre><hr width="100%">
+
+<pre><span id="VALx"><span class="keyword">val</span> x</span> : <code class="type">unit</code></pre><div class="info ">
+<div class="info-desc">
+<p>This is a documentation comment for <code class="code">x</code>, not a module preamble.</p>
+</div>
+</div>
+</body></html>
\ No newline at end of file

diff --git a/testsuite/tests/tool-ocamldoc-html/Paragraph.mli b/testsuite/tests/tool-ocamldoc-html/Paragraph.mli
new file mode 100644 (file)
index 0000000..7081da1
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-html/Paragraph.mli
@@ -0,0 +1,50 @@
+(** This file tests the generation of paragraph within module comments.
+
+
+    At least three points should be exercised in this tests
+
+    - First, all text should be tagged
+    - Second, no paragraph should contain only spaces characters
+    - Third, the mixing of different text style should not create
+    invalid p tags
+
+
+    See also {{: http://caml.inria.fr/mantis/view.php?id=7352} MPR:7352},
+    {{: http://caml.inria.fr/mantis/view.php?id=7353} MPR:7353}
+
+    {2:here Testing non-text elements }
+
+    [code x ] {i should } be inside a p.
+
+
+    {e But} {b not}
+    {[
+      let complex_code = ()
+    ]}
+    here.
+
+    + An enumerated list first element
+    + second element
+
+    {L Alignement test: left}
+    {R Right}
+    {C Center}
+
+
+    Other complex text{_ in subscript }{^ and superscript}
+    {V Verbatim V}
+
+    There is also {%html: html specific %} elements.
+
+    @author: Florian Angeletti
+    @version: 1
+*)
+
+(** *)
+
+type t
+(**
+    And cross-reference {! t}.
+   {!modules: Paragraph}
+   {!indexlist}
+*)

diff --git a/testsuite/tests/tool-ocamldoc-html/Paragraph.reference b/testsuite/tests/tool-ocamldoc-html/Paragraph.reference
new file mode 100644 (file)
index 0000000..84dee74
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc-html/Paragraph.reference
@@ -0,0 +1,75 @@
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
+<html>
+<head>
+<link rel="stylesheet" href="style.css" type="text/css">
+<meta content="text/html; charset=iso-8859-1" http-equiv="Content-Type">
+<meta name="viewport" content="width=device-width, initial-scale=1">
+<link rel="Start" href="index.html">
+<link rel="Up" href="index.html">
+<link title="Index of types" rel=Appendix href="index_types.html">
+<link title="Index of modules" rel=Appendix href="index_modules.html">
+<link title="Paragraph" rel="Chapter" href="Paragraph.html"><title>Paragraph</title>
+</head>
+<body>
+<div class="navbar">&nbsp;<a class="up" href="index.html" title="Index">Up</a>
+&nbsp;</div>
+<h1>Module <a href="type_Paragraph.html">Paragraph</a></h1>
+
+<pre><span id="MODULEParagraph"><span class="keyword">module</span> Paragraph</span>: <code class="code"><span class="keyword">sig</span></code> <a href="Paragraph.html">..</a> <code class="code"><span class="keyword">end</span></code></pre><div class="info module top">
+<div class="info-desc">
+<p>This file tests the generation of paragraph within module comments.</p>
+
+<p>At least three points should be exercised in this tests</p>
+
+<ul>
+<li>First, all text should be tagged</li>
+<li>Second, no paragraph should contain only spaces characters</li>
+<li>Third, the mixing of different text style should not create
+    invalid p tags</li>
+</ul>
+<p>See also <a href=" http://caml.inria.fr/mantis/view.php?id=7352"> MPR:7352</a>,
+    <a href=" http://caml.inria.fr/mantis/view.php?id=7353"> MPR:7353</a></p>
+
+<h3 id="here">Testing non-text elements </h3>
+<p><code class="code">code&nbsp;x&nbsp;</code> <i>should </i> be inside a p.</p>
+
+<p><em>But</em> <b>not</b></p>
+<pre class="codepre"><code class="code">      <span class="keyword">let</span> complex_code = ()
+    </code></pre><p>here.</p>
+
+<OL>
+<li>An enumerated list first element</li>
+<li>second element</li>
+</OL>
+<div align=left>Alignement test: left</div><div align=right>Right</div><center>Center</center>
+<p>Other complex text<sub class="subscript">in subscript </sub><sup class="superscript">and superscript</sup></p>
+
+<p>There is also html specific  elements.</p>
+</div>
+<ul class="info-attributes">
+<li><b>Author(s):</b> : Florian Angeletti</li>
+<li><b>Version:</b> : 1</li>
+</ul>
+</div>
+<hr width="100%">
+
+<pre><span id="TYPEt"><span class="keyword">type</span> <code class="type"></code>t</span> </pre>
+<div class="info ">
+<div class="info-desc">
+<p>And cross-reference <a href="Paragraph.html#TYPEt"><code class="code"><span class="constructor">Paragraph</span>.t</code></a>.
+   
+<table class="indextable module-list">
+<tr><td class="module"><a href="Paragraph.html">Paragraph</a></td><td><div class="info">
+<p>This file tests the generation of paragraph within module comments.</p>
+
+</div>
+</td></tr>
+</table></p>
+<ul class="indexlist">
+<li><a href="index_types.html">Index of types</a></li>
+<li><a href="index_modules.html">Index of modules</a></li>
+</ul>
+</div>
+</div>
+
+</body></html>
\ No newline at end of file

diff --git a/testsuite/tests/tool-ocamldoc-html/Variants.mli b/testsuite/tests/tool-ocamldoc-html/Variants.mli
index 7562a0b8ffdd6e2606378600e6b3e05976470e07..f60c267e4d7ac5e9db2d569462a2e47f5638182f 100644 (file)
--- a/testsuite/tests/tool-ocamldoc-html/Variants.mli
+++ b/testsuite/tests/tool-ocamldoc-html/Variants.mli
@@ -4,7 +4,12 @@ type s = A | B (** only B is documented here *) | C
 
 type t =
   | A
-    (** doc for A *)
+    (** doc for A.
+        {[0]}
+        With three paragraphs.
+        {[1]}
+        To check styling
+    *)
   | B
   (** doc for B *)
 

diff --git a/testsuite/tests/tool-ocamldoc-html/Variants.reference b/testsuite/tests/tool-ocamldoc-html/Variants.reference
index 12bd44e792f66f3728871159d7e5729edddf7c0f..d5aa791dfa9d689c923fc176e09471642f0b3770 100644 (file)
--- a/testsuite/tests/tool-ocamldoc-html/Variants.reference
+++ b/testsuite/tests/tool-ocamldoc-html/Variants.reference
@@ -15,8 +15,10 @@
 &nbsp;</div>
 <h1>Module <a href="type_Variants.html">Variants</a></h1>
 
-<pre><span class="keyword">module</span> Variants: <code class="code"><span class="keyword">sig</span></code> <a href="Variants.html">..</a> <code class="code"><span class="keyword">end</span></code></pre><div class="info module top">
-This test is here to check the latex code generated for variants<br>
+<pre><span id="MODULEVariants"><span class="keyword">module</span> Variants</span>: <code class="code"><span class="keyword">sig</span></code> <a href="Variants.html">..</a> <code class="code"><span class="keyword">end</span></code></pre><div class="info module top">
+<div class="info-desc">
+<p>This test is here to check the latex code generated for variants</p>
+</div>
 </div>
 <hr width="100%">
 
@@ -34,7 +36,9 @@ This test is here to check the latex code generated for variants<br>
 <td align="left" valign="top" >
 <code><span id="TYPEELTs.B"><span class="constructor">B</span></span></code></td>
 <td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
-only B is documented here<br>
+<div class="info-desc">
+<p>only B is documented here</p>
+</div>
 </div>
 </td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
 </tr>
@@ -55,7 +59,11 @@ only B is documented here<br>
 <td align="left" valign="top" >
 <code><span id="TYPEELTt.A"><span class="constructor">A</span></span></code></td>
 <td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
-doc for A<br>
+<div class="info-desc">
+<p>doc for A.</p>
+<pre class="codepre"><code class="code">0</code></pre><p>With three paragraphs.</p>
+<pre class="codepre"><code class="code">1</code></pre><p>To check styling</p>
+</div>
 </div>
 </td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
 </tr>
@@ -65,7 +73,9 @@ doc for A<br>
 <td align="left" valign="top" >
 <code><span id="TYPEELTt.B"><span class="constructor">B</span></span></code></td>
 <td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
-doc for B<br>
+<div class="info-desc">
+<p>doc for B</p>
+</div>
 </div>
 </td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
 </tr></table>
@@ -79,7 +89,9 @@ doc for B<br>
 <td align="left" valign="top" >
 <code><span id="TYPEELTu.A"><span class="constructor">A</span></span></code></td>
 <td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
-doc for A<br>
+<div class="info-desc">
+<p>doc for A</p>
+</div>
 </div>
 </td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
 </tr>
@@ -89,13 +101,17 @@ doc for A<br>
 <td align="left" valign="top" >
 <code><span id="TYPEELTu.B"><span class="constructor">B</span></span> <span class="keyword">of</span> <code class="type">unit</code></code></td>
 <td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
-doc for B<br>
+<div class="info-desc">
+<p>doc for B</p>
+</div>
 </div>
 </td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
 </tr></table>
 
 <div class="info ">
-Some documentation for u<br>
+<div class="info-desc">
+<p>Some documentation for u</p>
+</div>
 </div>
 
 
@@ -115,7 +131,9 @@ Some documentation for u<br>
 }
 </code></td>
 <td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
-doc for A<br>
+<div class="info-desc">
+<p>doc for A</p>
+</div>
 </div>
 </td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
 </tr>
@@ -134,13 +152,17 @@ doc for A<br>
 }
 </code></td>
 <td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
-doc for B<br>
+<div class="info-desc">
+<p>doc for B</p>
+</div>
 </div>
 </td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
 </tr></table>
 
 <div class="info ">
-With records<br>
+<div class="info-desc">
+<p>With records</p>
+</div>
 </div>
 
 
@@ -151,7 +173,9 @@ With records<br>
 <td align="left" valign="top" >
 <code><span id="TYPEELTz.A"><span class="constructor">A</span></span> <span class="keyword">of</span> <code class="type">int</code></code></td>
 <td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
-doc for A<br>
+<div class="info-desc">
+<p>doc for A</p>
+</div>
 </div>
 </td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
 </tr>
@@ -161,13 +185,17 @@ doc for A<br>
 <td align="left" valign="top" >
 <code><span id="TYPEELTz.B"><span class="constructor">B</span></span> <span class="keyword">of</span> <code class="type">int</code></code></td>
 <td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
-doc for B<br>
+<div class="info-desc">
+<p>doc for B</p>
+</div>
 </div>
 </td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
 </tr></table>
 
 <div class="info ">
-With args<br>
+<div class="info-desc">
+<p>With args</p>
+</div>
 </div>
 
 
@@ -178,13 +206,17 @@ With args<br>
 <td align="left" valign="top" >
 <code><span id="TYPEELTa.A"><span class="constructor">A</span></span> <span class="keyword">:</span> <code class="type"><a href="Variants.html#TYPEa">a</a></code></code></td>
 <td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
-doc for A<br>
+<div class="info-desc">
+<p>doc for A</p>
+</div>
 </div>
 </td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
 </tr></table>
 
 <div class="info ">
-Gadt notation<br>
+<div class="info-desc">
+<p>Gadt notation</p>
+</div>
 </div>
 
 
@@ -195,13 +227,17 @@ Gadt notation<br>
 <td align="left" valign="top" >
 <code><span id="TYPEELTb.B"><span class="constructor">B</span></span></code></td>
 <td class="typefieldcomment" align="left" valign="top" ><code>(*</code></td><td class="typefieldcomment" align="left" valign="top" ><div class="info ">
-doc for B<br>
+<div class="info-desc">
+<p>doc for B</p>
+</div>
 </div>
 </td><td class="typefieldcomment" align="left" valign="bottom" ><code>*)</code></td>
 </tr></table>
 
 <div class="info ">
-Lonely constructor<br>
+<div class="info-desc">
+<p>Lonely constructor</p>
+</div>
 </div>
 
 

diff --git a/testsuite/tests/tool-ocamldoc-open/doc.reference b/testsuite/tests/tool-ocamldoc-open/doc.reference
index 19419f9b584c70462ed805c9b8a802922681535e..29c5eaf07b7a69fc61a5e1ce3d95bd1293b56643 100644 (file)
--- a/testsuite/tests/tool-ocamldoc-open/doc.reference
+++ b/testsuite/tests/tool-ocamldoc-open/doc.reference
@@ -67,4 +67,4 @@ Alias to type Inner.a
 \end{ocamldocdescription}
 
 
-\end{document}
\ No newline at end of file
+\end{document}

diff --git a/testsuite/tests/tool-ocamldoc/t01.ml b/testsuite/tests/tool-ocamldoc/t01.ml
index ee291b900b64f827884e23ca91d3b5bb290459e9..b1db38ea65ad744094de9d287f6454771d06dfc8 100644 (file)
--- a/testsuite/tests/tool-ocamldoc/t01.ml
+++ b/testsuite/tests/tool-ocamldoc/t01.ml
@@ -17,6 +17,11 @@ module type MT = sig
       (string * string * string) -> unit
   val y : int
 
+  type ob = < f : int >
+
   type obj_type =
-     < foo : int ; bar : float -> string ; gee : int -> (int * string) >
+     < foo : int ; bar : float -> string ; ob ; gee : int -> (int * string) >
+
+  type g = [`A]
+  type h = [`B of int | g | `C of string]
 end

diff --git a/testsuite/tests/tool-ocamldoc/t01.reference b/testsuite/tests/tool-ocamldoc/t01.reference
index d5159bdfc9b819380a9236a5ad17319b4b5966d7..0802c2731e265285c62058fa90a9b15ae8bc5b1e 100644 (file)
--- a/testsuite/tests/tool-ocamldoc/t01.reference
+++ b/testsuite/tests/tool-ocamldoc/t01.reference
@@ -23,8 +23,12 @@
       string * string * string ->
       string * string * string -> string * string * string -> unit
   val y : int
+  type ob = < f : int >
   type obj_type =
-      < bar : float -> string; foo : int; gee : int -> int * string >
+      < bar : float -> string; f : int; foo : int;
+        gee : int -> int * string >
+  type g = [ `A ]
+  type h = [ `A | `B of int | `C of string ]
 end]>
 # type T01.MT.t:
 # manifest (Odoc_info.string_of_type_expr):
@@ -33,6 +37,15 @@ end]>
   string ->
   string * string * string ->
   string * string * string -> string * string * string -> unit]>
+# type T01.MT.ob:
+# manifest (Odoc_info.string_of_type_expr):
+<[< f: int ; >]>
 # type T01.MT.obj_type:
 # manifest (Odoc_info.string_of_type_expr):
-<[< bar: float -> string ; foo: int ; gee: int -> int * string ; >]>
+<[< bar: float -> string ; f: int ; foo: int ; gee: int -> int * string ; >]>
+# type T01.MT.g:
+# manifest (Odoc_info.string_of_type_expr):
+<[[ `A ]]>
+# type T01.MT.h:
+# manifest (Odoc_info.string_of_type_expr):
+<[[ `A | `B of int | `C of string ]]>

diff --git a/testsuite/tests/tool-ocamlobjinfo/Makefile b/testsuite/tests/tool-ocamlobjinfo/Makefile
new file mode 100644 (file)
index 0000000..19a745c
--- /dev/null
+++ b/testsuite/tests/tool-ocamlobjinfo/Makefile
@@ -0,0 +1,38 @@
+BASEDIR=../..
+
+LD_PATH=
+
+# This test ensures that ocamlobjinfo is behaving as the configuration
+# expects and is a guard against the breakage fixed in 17fc532
+
+.PHONY: default
+default:
+       @printf " ... testing 'ocamlobjinfo'"
+       @if ! $(SUPPORTS_SHARED_LIBRARIES) || $(BYTECODE_ONLY) ; then \
+         echo ' => skipped (.cmxs not built)'; \
+       elif ! grep -q HAS_LIBBFD $(TOPDIR)/byterun/caml/s.h ; then \
+         echo ' => skipped (BFD library not available)'; \
+       else \
+    $(SET_LD_PATH) OCAMLLIB=$(TOPDIR)/tools $(MAKE) run; \
+       fi
+
+.PHONY: run
+run:
+       @rm -f $(MAIN_MODULE).result
+       @$(OCAMLOPT) -shared -o question.cmxs question.ml
+       @$(OCAMLRUN) `$(CYGPATH) $(TOPDIR)/tools/ocamlobjinfo` \
+                    question.cmxs \
+                    > test.raw.result 2>&1 \
+        && sed -e 's/\([^0-9a-z]\)[0-9a-z]\{32\}\([^0-9a-z]\|$$\)/\1<MD5>\2/' \
+                    test.raw.result > test.result \
+        && $(DIFF) test.reference test.result > /dev/null \
+        && echo " => passed" || echo " => failed"
+
+.PHONY: promote
+promote: defaultpromote
+
+.PHONY: clean
+clean: defaultclean
+       @rm -f *.result
+
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/tool-ocamlobjinfo/question.ml b/testsuite/tests/tool-ocamlobjinfo/question.ml
new file mode 100644 (file)
index 0000000..cd29842
--- /dev/null
+++ b/testsuite/tests/tool-ocamlobjinfo/question.ml
@@ -0,0 +1 @@
+let answer = 42

diff --git a/testsuite/tests/tool-ocamlobjinfo/test.reference b/testsuite/tests/tool-ocamlobjinfo/test.reference
new file mode 100644 (file)
index 0000000..dab40e8
--- /dev/null
+++ b/testsuite/tests/tool-ocamlobjinfo/test.reference
@@ -0,0 +1,10 @@
+File question.cmxs
+Name: Question
+CRC of implementation: <MD5>
+Globals defined:
+       Question
+Interfaces imported:
+       <MD5>   Question
+       <MD5>   Pervasives
+       <MD5>   CamlinternalFormatBasics
+Implementations imported:

diff --git a/testsuite/tests/tool-toplevel/exotic_lists.ml b/testsuite/tests/tool-toplevel/exotic_lists.ml
new file mode 100644 (file)
index 0000000..ae42ec8
--- /dev/null
+++ b/testsuite/tests/tool-toplevel/exotic_lists.ml
@@ -0,0 +1,15 @@
+module L = struct
+        type ('a,'b) t = [] | (::) of 'a * ('b,'a) t
+end;;
+L.[([1;2]:int list);"2";[3;4];"4";[5]];;
+open L;;
+[1;"2";3;"4";5];;
+
+module L = struct
+        type 'a t = 'a list = [] | (::) of 'a * 'a t
+end;;
+L.[[1];[2];[3];[4];[5]];;
+open L;;
+[1;2;3;4;5];;
+
+

diff --git a/testsuite/tests/tool-toplevel/exotic_lists.ml.reference b/testsuite/tests/tool-toplevel/exotic_lists.ml.reference
new file mode 100644 (file)
index 0000000..e064340
--- /dev/null
+++ b/testsuite/tests/tool-toplevel/exotic_lists.ml.reference
@@ -0,0 +1,15 @@
+
+#     module L : sig type ('a, 'b) t = [] | (::) of 'a * ('b, 'a) t end
+# - : (int list, string) L.t =
+L.(::) ([1; 2],
+ L.(::) ("2", L.(::) ([3; 4], L.(::) ("4", L.(::) ([5], L.[])))))
+# # - : (int, string) L.t =
+(::) (1, (::) ("2", (::) (3, (::) ("4", (::) (5, [])))))
+#       module L : sig type 'a t = 'a list = [] | (::) of 'a * 'a t end
+# - : int L.t L.t =
+L.(::) (L.(::) (1, L.[]),
+ L.(::) (L.(::) (2, L.[]),
+  L.(::) (L.(::) (3, L.[]),
+   L.(::) (L.(::) (4, L.[]), L.(::) (L.(::) (5, L.[]), L.[])))))
+# # - : int L.t = (::) (1, (::) (2, (::) (3, (::) (4, (::) (5, [])))))
+#     

diff --git a/testsuite/tests/tool-toplevel/strings.ml b/testsuite/tests/tool-toplevel/strings.ml
new file mode 100644 (file)
index 0000000..14a5d2e
--- /dev/null
+++ b/testsuite/tests/tool-toplevel/strings.ml
@@ -0,0 +1,14 @@
+(* Test the printing of strings in the terminal *)
+"\n\t\r\b";;
+
+{|"\'|};;
+
+" !#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[]^_`abcdefghijklmnopqrstuvwxyz{|}~";;
+
+"\x00\x01\x02\x03\x04\x05\x06\x07\x0B\x0C\x0E\x0F\
+ \x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1A\x1B\x1C\x1D\x1E\x1F\
+ \x7F";;
+
+"\"Ἀχιλλεύς\r\n天照\tब्रह्मन्\t𒄑 𒂆 𒈦 𒄑 𒂆  𒈦\\";;
+
+"ایدهآل";;

diff --git a/testsuite/tests/tool-toplevel/strings.ml.reference b/testsuite/tests/tool-toplevel/strings.ml.reference
new file mode 100644 (file)
index 0000000..10673d4
--- /dev/null
+++ b/testsuite/tests/tool-toplevel/strings.ml.reference
@@ -0,0 +1,11 @@
+
+#   - : string = "\n\t\r\b"
+#   - : string = "\"\\'"
+#   - : string =
+" !#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[]^_`abcdefghijklmnopqrstuvwxyz{|}~"
+#       - : string =
+"\000\001\002\003\004\005\006\007\011\012\014\015\016\017\018\019\020\021\022\023\024\025\026\027\028\029\030\031\127"
+#   - : string =
+"\"Ἀχιλλεύς\r\n天照\tब्रह्मन्\t𒄑 𒂆 𒈦 𒄑 𒂆  𒈦\\"
+#   - : string = "ایدهآل"
+# 

diff --git a/testsuite/tests/translprim/Makefile b/testsuite/tests/translprim/Makefile
index c4223d45227e3d06fbab904969dd64c0968629fc..cdfef9a21ca59f80b159c47fde5bf9597a173aba 100644 (file)
--- a/testsuite/tests/translprim/Makefile
+++ b/testsuite/tests/translprim/Makefile
@@ -1,4 +1,28 @@
+newdefault: array_spec.ml.reference module_coercion.ml.reference
+       $(MAKE) default
+
 BASEDIR=../..
 TOPFLAGS+=-dlambda
 include $(BASEDIR)/makefiles/Makefile.dlambda
 include $(BASEDIR)/makefiles/Makefile.common
+
+GENERATED_SOURCES = array_spec.ml.reference module_coercion.ml.reference \
+                    *.flat-float
+
+ifeq "$(FLAT_FLOAT_ARRAY)" "true"
+suffix = -flat
+else
+suffix = -noflat
+endif
+
+array_spec.ml.reference: array_spec.ml.reference$(suffix) \
+                         $(FLAT_FLOAT_ARRAY).flat-float
+       cp $< $@
+
+module_coercion.ml.reference: module_coercion.ml.reference$(suffix) \
+                              $(FLAT_FLOAT_ARRAY).flat-float
+       cp $< $@
+
+%.flat-float:
+       @rm -f $(GENERATED_SOURCES)
+       @touch $@

diff --git a/testsuite/tests/translprim/array_spec.ml.reference b/testsuite/tests/translprim/array_spec.ml.reference
deleted file mode 100644 (file)
index 83fe0c4..0000000
--- a/testsuite/tests/translprim/array_spec.ml.reference
+++ /dev/null
@@ -1,88 +0,0 @@
-(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 stub (array.length[gen] prim))
-         eta_gen_safe_get =
-           (function prim prim stub
-             (array.get[gen] prim prim))
-         eta_gen_unsafe_get =
-           (function prim prim stub
-             (array.unsafe_get[gen] prim prim))
-         eta_gen_safe_set =
-           (function prim prim prim stub
-             (array.set[gen] prim prim prim))
-         eta_gen_unsafe_set =
-           (function prim prim prim stub
-             (array.unsafe_set[gen] prim prim prim))
-         eta_int_len =
-           (function prim stub (array.length[int] prim))
-         eta_int_safe_get =
-           (function prim prim stub
-             (array.get[int] prim prim))
-         eta_int_unsafe_get =
-           (function prim prim stub
-             (array.unsafe_get[int] prim prim))
-         eta_int_safe_set =
-           (function prim prim prim stub
-             (array.set[int] prim prim prim))
-         eta_int_unsafe_set =
-           (function prim prim prim stub
-             (array.unsafe_set[int] prim prim prim))
-         eta_float_len =
-           (function prim stub (array.length[float] prim))
-         eta_float_safe_get =
-           (function prim prim stub
-             (array.get[float] prim prim))
-         eta_float_unsafe_get =
-           (function prim prim stub
-             (array.unsafe_get[float] prim prim))
-         eta_float_safe_set =
-           (function prim prim prim stub
-             (array.set[float] prim prim prim))
-         eta_float_unsafe_set =
-           (function prim prim prim stub
-             (array.unsafe_set[float] prim prim prim))
-         eta_addr_len =
-           (function prim stub (array.length[addr] prim))
-         eta_addr_safe_get =
-           (function prim prim stub
-             (array.get[addr] prim prim))
-         eta_addr_unsafe_get =
-           (function prim prim stub
-             (array.unsafe_get[addr] prim prim))
-         eta_addr_safe_set =
-           (function prim prim prim stub
-             (array.set[addr] prim prim prim))
-         eta_addr_unsafe_set =
-           (function prim prim prim stub
-             (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/array_spec.ml.reference-flat b/testsuite/tests/translprim/array_spec.ml.reference-flat
new file mode 100644 (file)
index 0000000..83fe0c4
--- /dev/null
+++ b/testsuite/tests/translprim/array_spec.ml.reference-flat
@@ -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 stub (array.length[gen] prim))
+         eta_gen_safe_get =
+           (function prim prim stub
+             (array.get[gen] prim prim))
+         eta_gen_unsafe_get =
+           (function prim prim stub
+             (array.unsafe_get[gen] prim prim))
+         eta_gen_safe_set =
+           (function prim prim prim stub
+             (array.set[gen] prim prim prim))
+         eta_gen_unsafe_set =
+           (function prim prim prim stub
+             (array.unsafe_set[gen] prim prim prim))
+         eta_int_len =
+           (function prim stub (array.length[int] prim))
+         eta_int_safe_get =
+           (function prim prim stub
+             (array.get[int] prim prim))
+         eta_int_unsafe_get =
+           (function prim prim stub
+             (array.unsafe_get[int] prim prim))
+         eta_int_safe_set =
+           (function prim prim prim stub
+             (array.set[int] prim prim prim))
+         eta_int_unsafe_set =
+           (function prim prim prim stub
+             (array.unsafe_set[int] prim prim prim))
+         eta_float_len =
+           (function prim stub (array.length[float] prim))
+         eta_float_safe_get =
+           (function prim prim stub
+             (array.get[float] prim prim))
+         eta_float_unsafe_get =
+           (function prim prim stub
+             (array.unsafe_get[float] prim prim))
+         eta_float_safe_set =
+           (function prim prim prim stub
+             (array.set[float] prim prim prim))
+         eta_float_unsafe_set =
+           (function prim prim prim stub
+             (array.unsafe_set[float] prim prim prim))
+         eta_addr_len =
+           (function prim stub (array.length[addr] prim))
+         eta_addr_safe_get =
+           (function prim prim stub
+             (array.get[addr] prim prim))
+         eta_addr_unsafe_get =
+           (function prim prim stub
+             (array.unsafe_get[addr] prim prim))
+         eta_addr_safe_set =
+           (function prim prim prim stub
+             (array.set[addr] prim prim prim))
+         eta_addr_unsafe_set =
+           (function prim prim prim stub
+             (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/array_spec.ml.reference-noflat b/testsuite/tests/translprim/array_spec.ml.reference-noflat
new file mode 100644 (file)
index 0000000..ba90062
--- /dev/null
+++ b/testsuite/tests/translprim/array_spec.ml.reference-noflat
@@ -0,0 +1,88 @@
+(setglobal Array_spec!
+  (let
+    (int_a = (makearray[int] 1 2 3)
+     float_a = (makearray[addr] 1. 2. 3.)
+     addr_a = (makearray[addr] "a" "b" "c"))
+    (seq (array.length[int] int_a) (array.length[addr] float_a)
+      (array.length[addr] addr_a)
+      (function a (array.length[addr] a))
+      (array.get[int] int_a 0) (array.get[addr] float_a 0)
+      (array.get[addr] addr_a 0)
+      (function a (array.get[addr] a 0))
+      (array.unsafe_get[int] int_a 0)
+      (array.unsafe_get[addr] float_a 0)
+      (array.unsafe_get[addr] addr_a 0)
+      (function a (array.unsafe_get[addr] a 0))
+      (array.set[int] int_a 0 1) (array.set[addr] float_a 0 1.)
+      (array.set[addr] addr_a 0 "a")
+      (function a x (array.set[addr] a 0 x))
+      (array.unsafe_set[int] int_a 0 1)
+      (array.unsafe_set[addr] float_a 0 1.)
+      (array.unsafe_set[addr] addr_a 0 "a")
+      (function a x (array.unsafe_set[addr] a 0 x))
+      (let
+        (eta_gen_len =
+           (function prim stub (array.length[addr] prim))
+         eta_gen_safe_get =
+           (function prim prim stub
+             (array.get[addr] prim prim))
+         eta_gen_unsafe_get =
+           (function prim prim stub
+             (array.unsafe_get[addr] prim prim))
+         eta_gen_safe_set =
+           (function prim prim prim stub
+             (array.set[addr] prim prim prim))
+         eta_gen_unsafe_set =
+           (function prim prim prim stub
+             (array.unsafe_set[addr] prim prim prim))
+         eta_int_len =
+           (function prim stub (array.length[int] prim))
+         eta_int_safe_get =
+           (function prim prim stub
+             (array.get[int] prim prim))
+         eta_int_unsafe_get =
+           (function prim prim stub
+             (array.unsafe_get[int] prim prim))
+         eta_int_safe_set =
+           (function prim prim prim stub
+             (array.set[int] prim prim prim))
+         eta_int_unsafe_set =
+           (function prim prim prim stub
+             (array.unsafe_set[int] prim prim prim))
+         eta_float_len =
+           (function prim stub (array.length[addr] prim))
+         eta_float_safe_get =
+           (function prim prim stub
+             (array.get[addr] prim prim))
+         eta_float_unsafe_get =
+           (function prim prim stub
+             (array.unsafe_get[addr] prim prim))
+         eta_float_safe_set =
+           (function prim prim prim stub
+             (array.set[addr] prim prim prim))
+         eta_float_unsafe_set =
+           (function prim prim prim stub
+             (array.unsafe_set[addr] prim prim prim))
+         eta_addr_len =
+           (function prim stub (array.length[addr] prim))
+         eta_addr_safe_get =
+           (function prim prim stub
+             (array.get[addr] prim prim))
+         eta_addr_unsafe_get =
+           (function prim prim stub
+             (array.unsafe_get[addr] prim prim))
+         eta_addr_safe_set =
+           (function prim prim prim stub
+             (array.set[addr] prim prim prim))
+         eta_addr_unsafe_set =
+           (function prim prim prim stub
+             (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.reference b/testsuite/tests/translprim/comparison_table.ml.reference
index e04016323ddb9301bf612277b80e3c8b92d6703e..635b05a2f65b905a6bcc337d8cd8202bbfee3e02 100644 (file)
--- a/testsuite/tests/translprim/comparison_table.ml.reference
+++ b/testsuite/tests/translprim/comparison_table.ml.reference
@@ -243,7 +243,7 @@
                 (apply f (field 0 param) (field 1 param)))
             map =
               (function f l
-                (apply (field 15 (global List!)) (apply uncurry f)
+                (apply (field 16 (global List!)) (apply uncurry f)
                   l)))
            (makeblock 0
              (makeblock 0 (apply map gen_cmp vec)
@@ -291,7 +291,7 @@
                     (apply f (field 0 param) (field 1 param)))
                 map =
                   (function f l
-                    (apply (field 15 (global List!))
+                    (apply (field 16 (global List!))
                       (apply uncurry f) l)))
                (makeblock 0
                  (makeblock 0 (apply map eta_gen_cmp vec)

diff --git a/testsuite/tests/translprim/module_coercion.ml.reference b/testsuite/tests/translprim/module_coercion.ml.reference
deleted file mode 100644 (file)
index ca77102..0000000
--- a/testsuite/tests/translprim/module_coercion.ml.reference
+++ /dev/null
@@ -1,115 +0,0 @@
-(setglobal Module_coercion!
-  (let (M = (makeblock 0))
-    (makeblock 0 M
-      (makeblock 0 (function prim stub (array.length[int] prim))
-        (function prim prim stub
-          (array.get[int] prim prim))
-        (function prim prim stub
-          (array.unsafe_get[int] prim prim))
-        (function prim prim prim stub
-          (array.set[int] prim prim prim))
-        (function prim prim prim stub
-          (array.unsafe_set[int] prim prim prim))
-        (function prim prim stub
-          (caml_int_compare prim prim))
-        (function prim prim stub (== prim prim))
-        (function prim prim stub (!= prim prim))
-        (function prim prim stub (< prim prim))
-        (function prim prim stub (> prim prim))
-        (function prim prim stub (<= prim prim))
-        (function prim prim stub (>= prim prim)))
-      (makeblock 0 (function prim stub (array.length[float] prim))
-        (function prim prim stub
-          (array.get[float] prim prim))
-        (function prim prim stub
-          (array.unsafe_get[float] prim prim))
-        (function prim prim prim stub
-          (array.set[float] prim prim prim))
-        (function prim prim prim stub
-          (array.unsafe_set[float] prim prim prim))
-        (function prim prim stub
-          (caml_float_compare prim prim))
-        (function prim prim stub (==. prim prim))
-        (function prim prim stub (!=. prim prim))
-        (function prim prim stub (<. prim prim))
-        (function prim prim stub (>. prim prim))
-        (function prim prim stub (<=. prim prim))
-        (function prim prim stub (>=. prim prim)))
-      (makeblock 0 (function prim stub (array.length[addr] prim))
-        (function prim prim stub
-          (array.get[addr] prim prim))
-        (function prim prim stub
-          (array.unsafe_get[addr] prim prim))
-        (function prim prim prim stub
-          (array.set[addr] prim prim prim))
-        (function prim prim prim stub
-          (array.unsafe_set[addr] prim prim prim))
-        (function prim prim stub
-          (caml_string_compare prim prim))
-        (function prim prim stub
-          (caml_string_equal prim prim))
-        (function prim prim stub
-          (caml_string_notequal prim prim))
-        (function prim prim stub
-          (caml_string_lessthan prim prim))
-        (function prim prim stub
-          (caml_string_greaterthan prim prim))
-        (function prim prim stub
-          (caml_string_lessequal prim prim))
-        (function prim prim stub
-          (caml_string_greaterequal prim prim)))
-      (makeblock 0 (function prim stub (array.length[addr] prim))
-        (function prim prim stub
-          (array.get[addr] prim prim))
-        (function prim prim stub
-          (array.unsafe_get[addr] prim prim))
-        (function prim prim prim stub
-          (array.set[addr] prim prim prim))
-        (function prim prim prim stub
-          (array.unsafe_set[addr] prim prim prim))
-        (function prim prim stub
-          (caml_int32_compare prim prim))
-        (function prim prim stub (Int32.== prim prim))
-        (function prim prim stub (Int32.!= prim prim))
-        (function prim prim stub (Int32.< prim prim))
-        (function prim prim stub (Int32.> prim prim))
-        (function prim prim stub (Int32.<= prim prim))
-        (function prim prim stub (Int32.>= prim prim)))
-      (makeblock 0 (function prim stub (array.length[addr] prim))
-        (function prim prim stub
-          (array.get[addr] prim prim))
-        (function prim prim stub
-          (array.unsafe_get[addr] prim prim))
-        (function prim prim prim stub
-          (array.set[addr] prim prim prim))
-        (function prim prim prim stub
-          (array.unsafe_set[addr] prim prim prim))
-        (function prim prim stub
-          (caml_int64_compare prim prim))
-        (function prim prim stub (Int64.== prim prim))
-        (function prim prim stub (Int64.!= prim prim))
-        (function prim prim stub (Int64.< prim prim))
-        (function prim prim stub (Int64.> prim prim))
-        (function prim prim stub (Int64.<= prim prim))
-        (function prim prim stub (Int64.>= prim prim)))
-      (makeblock 0 (function prim stub (array.length[addr] prim))
-        (function prim prim stub
-          (array.get[addr] prim prim))
-        (function prim prim stub
-          (array.unsafe_get[addr] prim prim))
-        (function prim prim prim stub
-          (array.set[addr] prim prim prim))
-        (function prim prim prim stub
-          (array.unsafe_set[addr] prim prim prim))
-        (function prim prim stub
-          (caml_nativeint_compare prim prim))
-        (function prim prim stub
-          (Nativeint.== prim prim))
-        (function prim prim stub
-          (Nativeint.!= prim prim))
-        (function prim prim stub (Nativeint.< prim prim))
-        (function prim prim stub (Nativeint.> prim prim))
-        (function prim prim stub
-          (Nativeint.<= prim prim))
-        (function prim prim stub
-          (Nativeint.>= prim prim))))))

diff --git a/testsuite/tests/translprim/module_coercion.ml.reference-flat b/testsuite/tests/translprim/module_coercion.ml.reference-flat
new file mode 100644 (file)
index 0000000..27cd3f7
--- /dev/null
+++ b/testsuite/tests/translprim/module_coercion.ml.reference-flat
@@ -0,0 +1,125 @@
+(setglobal Module_coercion!
+  (let
+    (M = (module-defn(M) module_coercion.ml(1):0-699 (makeblock 0)))
+    (makeblock 0 M
+      (module-defn(M_int) module_coercion.ml(32):1116-1155
+        (makeblock 0 (function prim stub (array.length[int] prim))
+          (function prim prim stub
+            (array.get[int] prim prim))
+          (function prim prim stub
+            (array.unsafe_get[int] prim prim))
+          (function prim prim prim stub
+            (array.set[int] prim prim prim))
+          (function prim prim prim stub
+            (array.unsafe_set[int] prim prim prim))
+          (function prim prim stub
+            (caml_int_compare prim prim))
+          (function prim prim stub (== prim prim))
+          (function prim prim stub (!= prim prim))
+          (function prim prim stub (< prim prim))
+          (function prim prim stub (> prim prim))
+          (function prim prim stub (<= prim prim))
+          (function prim prim stub (>= prim prim))))
+      (module-defn(M_float) module_coercion.ml(33):1158-1201
+        (makeblock 0
+          (function prim stub (array.length[float] prim))
+          (function prim prim stub
+            (array.get[float] prim prim))
+          (function prim prim stub
+            (array.unsafe_get[float] prim prim))
+          (function prim prim prim stub
+            (array.set[float] prim prim prim))
+          (function prim prim prim stub
+            (array.unsafe_set[float] prim prim prim))
+          (function prim prim stub
+            (caml_float_compare prim prim))
+          (function prim prim stub (==. prim prim))
+          (function prim prim stub (!=. prim prim))
+          (function prim prim stub (<. prim prim))
+          (function prim prim stub (>. prim prim))
+          (function prim prim stub (<=. prim prim))
+          (function prim prim stub (>=. prim prim))))
+      (module-defn(M_string) module_coercion.ml(34):1204-1249
+        (makeblock 0 (function prim stub (array.length[addr] prim))
+          (function prim prim stub
+            (array.get[addr] prim prim))
+          (function prim prim stub
+            (array.unsafe_get[addr] prim prim))
+          (function prim prim prim stub
+            (array.set[addr] prim prim prim))
+          (function prim prim prim stub
+            (array.unsafe_set[addr] prim prim prim))
+          (function prim prim stub
+            (caml_string_compare prim prim))
+          (function prim prim stub
+            (caml_string_equal prim prim))
+          (function prim prim stub
+            (caml_string_notequal prim prim))
+          (function prim prim stub
+            (caml_string_lessthan prim prim))
+          (function prim prim stub
+            (caml_string_greaterthan prim prim))
+          (function prim prim stub
+            (caml_string_lessequal prim prim))
+          (function prim prim stub
+            (caml_string_greaterequal prim prim))))
+      (module-defn(M_int32/1104) module_coercion.ml(35):1252-1295
+        (makeblock 0 (function prim stub (array.length[addr] prim))
+          (function prim prim stub
+            (array.get[addr] prim prim))
+          (function prim prim stub
+            (array.unsafe_get[addr] prim prim))
+          (function prim prim prim stub
+            (array.set[addr] prim prim prim))
+          (function prim prim prim stub
+            (array.unsafe_set[addr] prim prim prim))
+          (function prim prim stub
+            (caml_int32_compare prim prim))
+          (function prim prim stub (Int32.== prim prim))
+          (function prim prim stub (Int32.!= prim prim))
+          (function prim prim stub (Int32.< prim prim))
+          (function prim prim stub (Int32.> prim prim))
+          (function prim prim stub (Int32.<= prim prim))
+          (function prim prim stub (Int32.>= prim prim))))
+      (module-defn(M_int64/1129) module_coercion.ml(36):1298-1341
+        (makeblock 0 (function prim stub (array.length[addr] prim))
+          (function prim prim stub
+            (array.get[addr] prim prim))
+          (function prim prim stub
+            (array.unsafe_get[addr] prim prim))
+          (function prim prim prim stub
+            (array.set[addr] prim prim prim))
+          (function prim prim prim stub
+            (array.unsafe_set[addr] prim prim prim))
+          (function prim prim stub
+            (caml_int64_compare prim prim))
+          (function prim prim stub (Int64.== prim prim))
+          (function prim prim stub (Int64.!= prim prim))
+          (function prim prim stub (Int64.< prim prim))
+          (function prim prim stub (Int64.> prim prim))
+          (function prim prim stub (Int64.<= prim prim))
+          (function prim prim stub (Int64.>= prim prim))))
+      (module-defn(M_nativeint) module_coercion.ml(37):1344-1395
+        (makeblock 0 (function prim stub (array.length[addr] prim))
+          (function prim prim stub
+            (array.get[addr] prim prim))
+          (function prim prim stub
+            (array.unsafe_get[addr] prim prim))
+          (function prim prim prim stub
+            (array.set[addr] prim prim prim))
+          (function prim prim prim stub
+            (array.unsafe_set[addr] prim prim prim))
+          (function prim prim stub
+            (caml_nativeint_compare prim prim))
+          (function prim prim stub
+            (Nativeint.== prim prim))
+          (function prim prim stub
+            (Nativeint.!= prim prim))
+          (function prim prim stub
+            (Nativeint.< prim prim))
+          (function prim prim stub
+            (Nativeint.> prim prim))
+          (function prim prim stub
+            (Nativeint.<= prim prim))
+          (function prim prim stub
+            (Nativeint.>= prim prim)))))))

diff --git a/testsuite/tests/translprim/module_coercion.ml.reference-noflat b/testsuite/tests/translprim/module_coercion.ml.reference-noflat
new file mode 100644 (file)
index 0000000..b3cc51b
--- /dev/null
+++ b/testsuite/tests/translprim/module_coercion.ml.reference-noflat
@@ -0,0 +1,124 @@
+(setglobal Module_coercion!
+  (let
+    (M = (module-defn(M) module_coercion.ml(1):0-699 (makeblock 0)))
+    (makeblock 0 M
+      (module-defn(M_int) module_coercion.ml(32):1116-1155
+        (makeblock 0 (function prim stub (array.length[int] prim))
+          (function prim prim stub
+            (array.get[int] prim prim))
+          (function prim prim stub
+            (array.unsafe_get[int] prim prim))
+          (function prim prim prim stub
+            (array.set[int] prim prim prim))
+          (function prim prim prim stub
+            (array.unsafe_set[int] prim prim prim))
+          (function prim prim stub
+            (caml_int_compare prim prim))
+          (function prim prim stub (== prim prim))
+          (function prim prim stub (!= prim prim))
+          (function prim prim stub (< prim prim))
+          (function prim prim stub (> prim prim))
+          (function prim prim stub (<= prim prim))
+          (function prim prim stub (>= prim prim))))
+      (module-defn(M_float) module_coercion.ml(33):1158-1201
+        (makeblock 0 (function prim stub (array.length[addr] prim))
+          (function prim prim stub
+            (array.get[addr] prim prim))
+          (function prim prim stub
+            (array.unsafe_get[addr] prim prim))
+          (function prim prim prim stub
+            (array.set[addr] prim prim prim))
+          (function prim prim prim stub
+            (array.unsafe_set[addr] prim prim prim))
+          (function prim prim stub
+            (caml_float_compare prim prim))
+          (function prim prim stub (==. prim prim))
+          (function prim prim stub (!=. prim prim))
+          (function prim prim stub (<. prim prim))
+          (function prim prim stub (>. prim prim))
+          (function prim prim stub (<=. prim prim))
+          (function prim prim stub (>=. prim prim))))
+      (module-defn(M_string) module_coercion.ml(34):1204-1249
+        (makeblock 0 (function prim stub (array.length[addr] prim))
+          (function prim prim stub
+            (array.get[addr] prim prim))
+          (function prim prim stub
+            (array.unsafe_get[addr] prim prim))
+          (function prim prim prim stub
+            (array.set[addr] prim prim prim))
+          (function prim prim prim stub
+            (array.unsafe_set[addr] prim prim prim))
+          (function prim prim stub
+            (caml_string_compare prim prim))
+          (function prim prim stub
+            (caml_string_equal prim prim))
+          (function prim prim stub
+            (caml_string_notequal prim prim))
+          (function prim prim stub
+            (caml_string_lessthan prim prim))
+          (function prim prim stub
+            (caml_string_greaterthan prim prim))
+          (function prim prim stub
+            (caml_string_lessequal prim prim))
+          (function prim prim stub
+            (caml_string_greaterequal prim prim))))
+      (module-defn(M_int32/1104) module_coercion.ml(35):1252-1295
+        (makeblock 0 (function prim stub (array.length[addr] prim))
+          (function prim prim stub
+            (array.get[addr] prim prim))
+          (function prim prim stub
+            (array.unsafe_get[addr] prim prim))
+          (function prim prim prim stub
+            (array.set[addr] prim prim prim))
+          (function prim prim prim stub
+            (array.unsafe_set[addr] prim prim prim))
+          (function prim prim stub
+            (caml_int32_compare prim prim))
+          (function prim prim stub (Int32.== prim prim))
+          (function prim prim stub (Int32.!= prim prim))
+          (function prim prim stub (Int32.< prim prim))
+          (function prim prim stub (Int32.> prim prim))
+          (function prim prim stub (Int32.<= prim prim))
+          (function prim prim stub (Int32.>= prim prim))))
+      (module-defn(M_int64/1129) module_coercion.ml(36):1298-1341
+        (makeblock 0 (function prim stub (array.length[addr] prim))
+          (function prim prim stub
+            (array.get[addr] prim prim))
+          (function prim prim stub
+            (array.unsafe_get[addr] prim prim))
+          (function prim prim prim stub
+            (array.set[addr] prim prim prim))
+          (function prim prim prim stub
+            (array.unsafe_set[addr] prim prim prim))
+          (function prim prim stub
+            (caml_int64_compare prim prim))
+          (function prim prim stub (Int64.== prim prim))
+          (function prim prim stub (Int64.!= prim prim))
+          (function prim prim stub (Int64.< prim prim))
+          (function prim prim stub (Int64.> prim prim))
+          (function prim prim stub (Int64.<= prim prim))
+          (function prim prim stub (Int64.>= prim prim))))
+      (module-defn(M_nativeint) module_coercion.ml(37):1344-1395
+        (makeblock 0 (function prim stub (array.length[addr] prim))
+          (function prim prim stub
+            (array.get[addr] prim prim))
+          (function prim prim stub
+            (array.unsafe_get[addr] prim prim))
+          (function prim prim prim stub
+            (array.set[addr] prim prim prim))
+          (function prim prim prim stub
+            (array.unsafe_set[addr] prim prim prim))
+          (function prim prim stub
+            (caml_nativeint_compare prim prim))
+          (function prim prim stub
+            (Nativeint.== prim prim))
+          (function prim prim stub
+            (Nativeint.!= prim prim))
+          (function prim prim stub
+            (Nativeint.< prim prim))
+          (function prim prim stub
+            (Nativeint.> prim prim))
+          (function prim prim stub
+            (Nativeint.<= prim prim))
+          (function prim prim stub
+            (Nativeint.>= prim prim)))))))

diff --git a/testsuite/tests/typing-deprecated/Makefile b/testsuite/tests/typing-deprecated/Makefile
new file mode 100644 (file)
index 0000000..0b15e77
--- /dev/null
+++ b/testsuite/tests/typing-deprecated/Makefile
@@ -0,0 +1,18 @@
+#**************************************************************************
+#*                                                                        *
+#*                                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 GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.expect
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/typing-deprecated/deprecated.ml b/testsuite/tests/typing-deprecated/deprecated.ml
new file mode 100755 (executable)
index 0000000..da51555
--- /dev/null
+++ b/testsuite/tests/typing-deprecated/deprecated.ml
@@ -0,0 +1,497 @@
+[@@@ocaml.warning "+3"];;
+
+module X: sig
+  type t [@@ocaml.deprecated]
+  type s [@@ocaml.deprecated]
+  type u [@@ocaml.deprecated]
+  val x: t [@@ocaml.deprecated]
+end = struct
+  type t = int
+  type s
+  type u
+  let x = 0
+end;;
+[%%expect{|
+Line _, characters 9-10:
+Warning 3: deprecated: t
+module X : sig type t type s type u val x : t end
+|}]
+
+type t = X.t
+;;
+[%%expect{|
+Line _, characters 9-12:
+Warning 3: deprecated: X.t
+type t = X.t
+|}]
+
+let x = X.x
+;;
+[%%expect{|
+Line _, characters 8-11:
+Warning 3: deprecated: X.x
+val x : X.t = <abstr>
+|}]
+
+(* Type declarations *)
+
+type t = X.t * X.s
+;;
+[%%expect{|
+Line _, characters 9-12:
+Warning 3: deprecated: X.t
+Line _, characters 15-18:
+Warning 3: deprecated: X.s
+type t = X.t * X.s
+|}]
+
+type t = X.t * X.s [@@ocaml.warning "-3"]
+;;
+[%%expect{|
+type t = X.t * X.s
+|}]
+
+type t1 = X.t [@@ocaml.warning "-3"]
+and t2 = X.s
+;;
+[%%expect{|
+Line _, characters 9-12:
+Warning 3: deprecated: X.s
+type t1 = X.t
+and t2 = X.s
+|}]
+
+type t = A of t [@@ocaml.deprecated]
+;;
+[%%expect{|
+Line _, characters 14-15:
+Warning 3: deprecated: t
+type t = A of t
+|}]
+
+type t = A of t
+  [@@ocaml.deprecated]
+  [@@ocaml.warning "-3"]
+;;
+[%%expect{|
+type t = A of t
+|}]
+
+(* Type expressions *)
+
+type t = (X.t * X.s) [@ocaml.warning "-3"]
+;;
+[%%expect{|
+type t = X.t * X.s
+|}]
+
+type t = (X.t [@ocaml.warning "-3"]) * X.s
+;;
+[%%expect{|
+Line _, characters 39-42:
+Warning 3: deprecated: X.s
+type t = X.t * X.s
+|}]
+
+
+type t = A of (t [@ocaml.warning "-3"])
+  [@@ocaml.deprecated]
+;;
+[%%expect{|
+type t = A of t
+|}]
+
+(* Pattern expressions *)
+
+let _ = function (_ : X.t) -> ()
+;;
+[%%expect{|
+Line _, characters 22-25:
+Warning 3: deprecated: X.t
+- : X.t -> unit = <fun>
+|}]
+
+let _ = function (_ : X.t)[@ocaml.warning "-3"] -> ()
+;;
+[%%expect{|
+- : X.t -> unit = <fun>
+|}]
+
+
+(* Module expressions and module declarations *)
+
+module M = struct let x = X.x end
+;;
+[%%expect{|
+Line _, characters 26-29:
+Warning 3: deprecated: X.x
+module M : sig val x : X.t end
+|}]
+
+module M = (struct let x = X.x end)[@ocaml.warning "-3"]
+;;
+[%%expect{|
+module M : sig val x : X.t end
+|}]
+
+module M = struct let x = X.x end [@@ocaml.warning "-3"]
+;;
+[%%expect{|
+module M : sig val x : X.t end
+|}]
+
+
+module rec M : sig val x: X.t end = struct let x = X.x end
+[%%expect{|
+Line _, characters 26-29:
+Warning 3: deprecated: X.t
+Line _, characters 51-54:
+Warning 3: deprecated: X.x
+module rec M : sig val x : X.t end
+|}]
+
+module rec M : sig val x: X.t end = struct let x = X.x end [@@ocaml.warning "-3"]
+[%%expect{|
+module rec M : sig val x : X.t end
+|}]
+
+module rec M :
+  (sig val x: X.t end)[@ocaml.warning "-3"] =
+  (struct let x = X.x end)[@ocaml.warning "-3"]
+[%%expect{|
+module rec M : sig val x : X.t end
+|}]
+
+module rec M :
+  (sig val x: X.t end)[@ocaml.warning "-3"] =
+  struct let x = X.x end
+[%%expect{|
+Line _, characters 17-20:
+Warning 3: deprecated: X.x
+module rec M : sig val x : X.t end
+|}]
+
+(* Module type expressions and module type declarations *)
+
+module type S = sig type t = X.t end
+;;
+[%%expect{|
+Line _, characters 29-32:
+Warning 3: deprecated: X.t
+module type S = sig type t = X.t end
+|}]
+
+module type S = (sig type t = X.t end)[@ocaml.warning "-3"]
+;;
+[%%expect{|
+module type S = sig type t = X.t end
+|}]
+
+module type S = sig type t = X.t end[@@ocaml.warning "-3"]
+;;
+[%%expect{|
+module type S = sig type t = X.t end
+|}]
+
+
+(* Class expressions, class declarations and class fields *)
+
+class c = object method x = X.x end
+;;
+[%%expect{|
+Line _, characters 28-31:
+Warning 3: deprecated: X.x
+class c : object method x : X.t end
+|}]
+
+class c = object method x = X.x end[@@ocaml.warning "-3"]
+;;
+[%%expect{|
+class c : object method x : X.t end
+|}]
+
+class c = (object method x = X.x end)[@ocaml.warning "-3"]
+;;
+[%%expect{|
+class c : object method x : X.t end
+|}]
+
+class c = object method x = X.x [@@ocaml.warning "-3"] end
+;;
+[%%expect{|
+class c : object method x : X.t end
+|}]
+
+(* Class type expressions, class type declarations
+   and class type fields *)
+
+class type c = object method x : X.t end
+;;
+[%%expect{|
+Line _, characters 33-36:
+Warning 3: deprecated: X.t
+class type c = object method x : X.t end
+|}]
+
+class type c = object method x : X.t end[@@ocaml.warning "-3"]
+;;
+[%%expect{|
+class type c = object method x : X.t end
+|}]
+
+class type c = object method x : X.t end[@ocaml.warning "-3"]
+;;
+[%%expect{|
+class type c = object method x : X.t end
+|}]
+
+class type c = object method x : X.t [@@ocaml.warning "-3"] end
+;;
+[%%expect{|
+class type c = object method x : X.t end
+|}]
+
+
+
+(* External declarations *)
+
+external foo: unit -> X.t = "foo"
+;;
+[%%expect{|
+Line _, characters 22-25:
+Warning 3: deprecated: X.t
+external foo : unit -> X.t = "foo"
+|}]
+
+external foo: unit -> X.t = "foo"[@@ocaml.warning "-3"]
+;;
+[%%expect{|
+external foo : unit -> X.t = "foo"
+|}]
+
+
+(* Eval *)
+;;
+X.x
+;;
+[%%expect{|
+Line _, characters 0-3:
+Warning 3: deprecated: X.x
+- : X.t = <abstr>
+|}]
+
+;;
+X.x [@@ocaml.warning "-3"]
+;;
+[%%expect{|
+- : X.t = <abstr>
+|}]
+
+(* Open / include *)
+
+module D = struct end[@@ocaml.deprecated]
+
+open D
+;;
+[%%expect{|
+module D : sig  end
+Line _, characters 5-6:
+Warning 3: deprecated: module D
+|}]
+
+open D [@@ocaml.warning "-3"]
+;;
+[%%expect{|
+|}]
+
+include D
+;;
+[%%expect{|
+Line _, characters 8-9:
+Warning 3: deprecated: module D
+|}]
+
+include D [@@ocaml.warning "-3"]
+;;
+[%%expect{|
+|}]
+
+
+(* Type extensions *)
+
+type ext = ..
+;;
+[%%expect{|
+type ext = ..
+|}]
+
+type ext +=
+  | A of X.t
+  | B of (X.s [@ocaml.warning "-3"])
+  | C of X.u [@ocaml.warning "-3"]
+;;
+[%%expect{|
+Line _, characters 9-12:
+Warning 3: deprecated: X.t
+type ext += A of X.t | B of X.s | C of X.u
+|}]
+
+type ext +=
+  | C of X.t
+  [@@ocaml.warning "-3"]
+;;
+[%%expect{|
+type ext += C of X.t
+|}]
+
+
+exception Foo of X.t
+;;
+[%%expect{|
+Line _, characters 17-20:
+Warning 3: deprecated: X.t
+exception Foo of X.t
+|}]
+
+exception Foo of X.t [@ocaml.warning "-3"]
+;;
+[%%expect{|
+exception Foo of X.t
+|}]
+
+
+(* Labels/constructors/fields *)
+
+type t =
+  | A of X.t
+  | B of X.s [@ocaml.warning "-3"]
+  | C of (X.u [@ocaml.warning "-3"])
+;;
+[%%expect{|
+Line _, characters 9-12:
+Warning 3: deprecated: X.t
+type t = A of X.t | B of X.s | C of X.u
+|}]
+
+type t =
+  {
+    a: X.t;
+    b: X.s [@ocaml.warning "-3"];
+    c: (X.u [@ocaml.warning "-3"]);
+  }
+;;
+[%%expect{|
+Line _, characters 7-10:
+Warning 3: deprecated: X.t
+type t = { a : X.t; b : X.s; c : X.u; }
+|}]
+
+
+type t =
+  <
+    a: X.t;
+    b: X.s [@ocaml.warning "-3"];
+    c: (X.u [@ocaml.warning "-3"]);
+  >
+;;
+[%%expect{|
+Line _, characters 7-10:
+Warning 3: deprecated: X.t
+type t = < a : X.t; b : X.s; c : X.u >
+|}]
+
+
+type t =
+  [
+  | `A of X.t
+  | `B of X.s [@ocaml.warning "-3"]
+  | `C of (X.u [@ocaml.warning "-3"])
+  ]
+;;
+[%%expect{|
+Line _, characters 10-13:
+Warning 3: deprecated: X.t
+type t = [ `A of X.t | `B of X.s | `C of X.u ]
+|}]
+
+
+(* Test for ocaml.ppwarning, and its interactions with ocaml.warning *)
+
+
+[@@@ocaml.ppwarning "Pp warning!"]
+;;
+[%%expect{|
+Line _, characters 20-33:
+Warning 22: Pp warning!
+|}]
+
+
+let x = () [@ocaml.ppwarning "Pp warning 1!"]
+    [@@ocaml.ppwarning  "Pp warning 2!"]
+;;
+[%%expect{|
+Line _, characters 24-39:
+Warning 22: Pp warning 2!
+Line _, characters 29-44:
+Warning 22: Pp warning 1!
+val x : unit = ()
+|}]
+
+type t = unit
+    [@ocaml.ppwarning "Pp warning!"]
+;;
+[%%expect{|
+Line _, characters 22-35:
+Warning 22: Pp warning!
+type t = unit
+|}]
+
+module X = struct
+  [@@@ocaml.warning "-22"]
+
+  [@@@ocaml.ppwarning "Pp warning1!"]
+
+  [@@@ocaml.warning "+22"]
+
+  [@@@ocaml.ppwarning "Pp warning2!"]
+end
+;;
+[%%expect{|
+Line _, characters 22-36:
+Warning 22: Pp warning2!
+module X : sig  end
+|}]
+
+let x = ((() [@ocaml.ppwarning "Pp warning 1!"]) [@ocaml.warning "-22"])  [@ocaml.ppwarning  "Pp warning 2!"]
+;;
+[%%expect{|
+Line _, characters 93-108:
+Warning 22: Pp warning 2!
+val x : unit = ()
+|}]
+
+type t = ((unit [@ocaml.ppwarning "Pp warning 1!"]) [@ocaml.warning "-22"])  [@ocaml.ppwarning  "Pp warning 2!"]
+  [@@ocaml.ppwarning "Pp warning 3!"]
+;;
+[%%expect{|
+Line _, characters 21-36:
+Warning 22: Pp warning 3!
+Line _, characters 96-111:
+Warning 22: Pp warning 2!
+type t = unit
+|}]
+
+let ([][@ocaml.ppwarning "XX"]) = []
+;;
+[%%expect{|
+Line _, characters 25-29:
+Warning 22: XX
+Line _, characters 4-31:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+_::_
+|}]
+let[@ocaml.warning "-8-22"] ([][@ocaml.ppwarning "XX"]) = []
+;;
+[%%expect{|
+|}]

diff --git a/testsuite/tests/typing-extensions/extensions.ml b/testsuite/tests/typing-extensions/extensions.ml
index f6d6c9005b4a459a6a3d9515b0b1685848112c3d..c921ecf24c00df4a6203925ee8b2de70f77727be 100644 (file)
--- a/testsuite/tests/typing-extensions/extensions.ml
+++ b/testsuite/tests/typing-extensions/extensions.ml
@@ -23,6 +23,14 @@ type foo
 type foo += A of int (* Error type is not open *)
 ;;
 
+(* The type must be public to create extension *)
+
+type foo = private ..
+;;
+
+type foo += A of int (* Error type is private *)
+;;
+
 (* The type parameters must match *)
 
 type 'a foo = ..
@@ -31,11 +39,11 @@ type 'a foo = ..
 type ('a, 'b) foo += A of int (* Error: type parameter mismatch *)
 ;;
 
-(* In a signature the type does not have to be open *)
+(* In a signature the type can be private *)
 
 module type S =
 sig
-  type foo
+  type foo = private ..
   type foo += A of float
 end
 ;;
@@ -44,8 +52,8 @@ end
 
 module type S =
 sig
-  type foo = A of int
-  type foo += B of float (* Error foo does not have an extensible type *)
+  type foo
+  type foo += B of float (* Error: foo does not have an extensible type *)
 end
 ;;
 
@@ -164,9 +172,9 @@ type foo += B3 = M.B1  (* Error: rebind private extension *)
 type foo += C = Unknown  (* Error: unbound extension *)
 ;;
 
-(* Extensions can be rebound even if type is closed *)
+(* Extensions can be rebound even if type is private *)
 
-module M : sig type foo type foo += A1 of int end
+module M : sig type foo = private .. type foo += A1 of int end
   = struct type foo = .. type foo += A1 of int end
 
 type M.foo += A2 = M.A1

diff --git a/testsuite/tests/typing-extensions/extensions.ml.reference b/testsuite/tests/typing-extensions/extensions.ml.reference
index ea2cfb8cd222dfb9cff56aee2663ce6d155c6d40..a71a8187d29f379ebd4275428aa9f015b6199829 100644 (file)
--- a/testsuite/tests/typing-extensions/extensions.ml.reference
+++ b/testsuite/tests/typing-extensions/extensions.ml.reference
@@ -4,21 +4,26 @@
 #         type foo += A | B of int
 #           val is_a : foo -> bool = <fun>
 #         type foo
-#     Characters 13-21:
+#     Characters 1-21:
   type foo += A of int (* Error type is not open *)
+  ^^^^^^^^^^^^^^^^^^^^
+Error: Type definition foo is not extensible
+#         type foo = private ..
+#     Characters 13-21:
+  type foo += A of int (* Error type is private *)
               ^^^^^^^^
-Error: Cannot extend type definition foo
+Error: Cannot extend private type definition foo
 #         type 'a foo = ..
 #     Characters 1-30:
   type ('a, 'b) foo += A of int (* Error: type parameter mismatch *)
   ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
 Error: This extension does not match the definition of type foo
        They have different arities.
-#                 module type S = sig type foo type foo += A of float end
-#                 Characters 84-106:
-    type foo += B of float (* Error foo does not have an extensible type *)
+#                 module type S = sig type foo = private .. type foo += A of float end
+#                 Characters 73-95:
+    type foo += B of float (* Error: foo does not have an extensible type *)
     ^^^^^^^^^^^^^^^^^^^^^^
-Error: Type foo is not extensible
+Error: Type definition foo is not extensible
 #         type foo = ..
 #                     module M :
   sig
@@ -75,7 +80,7 @@ Error: The constructor M.B1 is private
   type foo += C = Unknown  (* Error: unbound extension *)
                   ^^^^^^^
 Error: Unbound constructor Unknown
-#                       module M : sig type foo type foo += A1 of int end
+#                       module M : sig type foo = private .. type foo += A1 of int end
 type M.foo += A2 of int
 type 'a foo = ..
 #     type 'a foo1 = 'a foo = ..

diff --git a/testsuite/tests/typing-extensions/msg.ml b/testsuite/tests/typing-extensions/msg.ml
index ef1c12fb4cdcaa5db35455971f6d9f6df0ac57ab..c845335149d0d356bb0646025a263310d2d5cb7c 100644 (file)
--- a/testsuite/tests/typing-extensions/msg.ml
+++ b/testsuite/tests/typing-extensions/msg.ml
@@ -2,7 +2,7 @@
 
 module Msg : sig
 
-  type 'a tag
+  type 'a tag = private ..
 
   type result = Result : 'a tag * 'a -> result
 

diff --git a/testsuite/tests/typing-extensions/msg.ml.reference b/testsuite/tests/typing-extensions/msg.ml.reference
index e7f1a8f248d55c58403041ef73417c80b37e7c8a..27f15ea77727b11c790545b5b2b0dec8b289dc9a 100644 (file)
--- a/testsuite/tests/typing-extensions/msg.ml.reference
+++ b/testsuite/tests/typing-extensions/msg.ml.reference
@@ -1,7 +1,7 @@
 
 #                                                                                                                                                                                                                             module Msg :
   sig
-    type 'a tag
+    type 'a tag = private ..
     type result = Result : 'a tag * 'a -> result
     val write : 'a tag -> 'a -> unit
     val read : unit -> result

diff --git a/testsuite/tests/typing-extensions/open_types.ml b/testsuite/tests/typing-extensions/open_types.ml
index c439f38ae660d182b87836c4b7f0d2cb5ba8e894..0f9038d1c925d2401cb4c255923d96583f12e796 100644 (file)
--- a/testsuite/tests/typing-extensions/open_types.ml
+++ b/testsuite/tests/typing-extensions/open_types.ml
@@ -52,31 +52,48 @@ type ('a, 'b) foo = ..
 type ('a, 'b) bar = ('a, 'a) foo = .. (* Error: constraints do not match *)
 ;;
 
-(* Private abstract types cannot be open *)
+(* Check that signatures can hide exstensibility *)
 
-type foo = ..
+module M = struct type foo = .. end
+;;
+
+module type S = sig type foo end
+;;
+
+module M_S = (M : S)
 ;;
 
-type bar = private foo = .. (* ERROR: Private abstract types cannot be open *)
+type M_S.foo += Foo (* ERROR: Cannot extend a type that isn't "open" *)
 ;;
 
-(* Check that signatures can hide open-ness *)
+(* Check that signatures cannot add extensibility *)
+
+module M = struct type foo end
+;;
+
+module type S = sig type foo = .. end
+;;
+
+module M_S = (M : S) (* ERROR: Signatures are not compatible *)
+;;
+
+(* Check that signatures can make exstensibility private *)
 
 module M = struct type foo = .. end
 ;;
 
-module type S = sig type foo end
+module type S = sig type foo = private .. end
 ;;
 
 module M_S = (M : S)
 ;;
 
-type M_S.foo += Foo (* ERROR: Cannot extend a type that isn't "open" *)
+type M_S.foo += Foo (* ERROR: Cannot extend a private extensible type *)
 ;;
 
-(* Check that signatures cannot add open-ness *)
+(* Check that signatures cannot make private extensibility public *)
 
-module M = struct type foo end
+module M = struct type foo = private .. end
 ;;
 
 module type S = sig type foo = .. end
@@ -85,6 +102,7 @@ module type S = sig type foo = .. end
 module M_S = (M : S) (* ERROR: Signatures are not compatible *)
 ;;
 
+
 (* Check that signatures maintain variances *)
 
 module M = struct type +'a foo = .. type 'a bar = 'a foo = .. end

diff --git a/testsuite/tests/typing-extensions/open_types.ml.reference b/testsuite/tests/typing-extensions/open_types.ml.reference
index a339ac7ff39b83b14763a686cef34c38b08f66fc..4b9e8f6fc1f35f419ea37149cf340464d3eb779d 100644 (file)
--- a/testsuite/tests/typing-extensions/open_types.ml.reference
+++ b/testsuite/tests/typing-extensions/open_types.ml.reference
@@ -9,10 +9,10 @@
 #     module M_S : S
 #         type foo = ..
 #     type bar = foo
-#     Characters 13-23:
+#     Characters 1-23:
   type bar += Bar of int (* Error: type is not open *)
-              ^^^^^^^^^^
-Error: Cannot extend type definition bar
+  ^^^^^^^^^^^^^^^^^^^^^^
+Error: Type definition bar is not extensible
 #     Characters 1-20:
   type baz = bar = .. (* Error: type kinds don't match *)
   ^^^^^^^^^^^^^^^^^^^
@@ -31,18 +31,13 @@ Error: This variant or record definition does not match that of type 'a foo
 Error: This variant or record definition does not match that of type
          ('a, 'a) foo
        Their constraints differ.
-#         type foo = ..
-#     Characters 24-25:
-  type bar = private foo = .. (* ERROR: Private abstract types cannot be open *)
-                         ^
-Error: Syntax error
 #         module M : sig type foo = .. end
 #     module type S = sig type foo end
 #     module M_S : S
-#     Characters 17-20:
+#     Characters 1-20:
   type M_S.foo += Foo (* ERROR: Cannot extend a type that isn't "open" *)
-                  ^^^
-Error: Cannot extend type definition M_S.foo
+  ^^^^^^^^^^^^^^^^^^^
+Error: Type definition M_S.foo is not extensible
 #         module M : sig type foo end
 #     module type S = sig type foo = .. end
 #     Characters 15-16:
@@ -55,7 +50,29 @@ Error: Signature mismatch:
        is not included in
          type foo = ..
        Their kinds differ.
-#         module M : sig type +'a foo = .. type 'a bar = 'a foo = .. end
+#         module M : sig type foo = .. end
+#     module type S = sig type foo = private .. end
+#     module M_S : S
+#     Characters 17-20:
+  type M_S.foo += Foo (* ERROR: Cannot extend a private extensible type *)
+                  ^^^
+Error: Cannot extend private type definition M_S.foo
+#         module M : sig type foo = private .. end
+#     module type S = sig type foo = .. end
+#     Characters 15-16:
+  module M_S = (M : S) (* ERROR: Signatures are not compatible *)
+                ^
+Error: Signature mismatch:
+       Modules do not match:
+         sig type foo = M.foo = private .. end
+       is not included in
+         S
+       Type declarations do not match:
+         type foo = M.foo = private ..
+       is not included in
+         type foo = ..
+       A private type would be revealed.
+#           module M : sig type +'a foo = .. type 'a bar = 'a foo = .. end
 #     module type S = sig type 'a foo = .. type 'a bar = 'a foo = .. end
 #     Characters 15-16:
   module M_S = (M : S) (* ERROR: Signatures are not compatible *)

diff --git a/testsuite/tests/typing-gadts/omega07.ml b/testsuite/tests/typing-gadts/omega07.ml
index 6c729abe8df8e7bde85b61d67a92662ee4f378c3..5fd175c3e413be6bacbbef9959d84032ef495183 100644 (file)
--- a/testsuite/tests/typing-gadts/omega07.ml
+++ b/testsuite/tests/typing-gadts/omega07.ml
@@ -898,11 +898,11 @@ val _0 : ((zero, int, 'a) rcons, int) lam = Var Zero
 val suc :
   (('a, 'b, (suc, int -> int, 'c) rcons) rcons, int) lam ->
   (('a, 'b, (suc, int -> int, 'c) rcons) rcons, int) lam = <fun>
-val _1 : ((zero, int, (suc, int -> int, '_a) rcons) rcons, int) lam =
+val _1 : ((zero, int, (suc, int -> int, '_weak1) rcons) rcons, int) lam =
   App (Shift (Var Suc), Var Zero)
-val _2 : ((zero, int, (suc, int -> int, '_a) rcons) rcons, int) lam =
+val _2 : ((zero, int, (suc, int -> int, '_weak2) rcons) rcons, int) lam =
   App (Shift (Var Suc), App (Shift (Var Suc), Var Zero))
-val _3 : ((zero, int, (suc, int -> int, '_a) rcons) rcons, int) lam =
+val _3 : ((zero, int, (suc, int -> int, '_weak3) rcons) rcons, int) lam =
   App (Shift (Var Suc),
    App (Shift (Var Suc), App (Shift (Var Suc), Var Zero)))
 val add :
@@ -916,7 +916,8 @@ val double :
   Abs (<poly>,
    App (App (Shift (Shift (Shift (Var Add))), Var <poly>), Var <poly>))
 val ex3 :
-  ((zero, int, (suc, int -> int, (add, int -> int -> int, '_a) rcons) rcons)
+  ((zero, int,
+    (suc, int -> int, (add, int -> int -> int, '_weak4) rcons) rcons)
    rcons, int)
   lam =
   App

diff --git a/testsuite/tests/typing-gadts/pr6934.ml b/testsuite/tests/typing-gadts/pr6934.ml
new file mode 100644 (file)
index 0000000..37170d2
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr6934.ml
@@ -0,0 +1,6 @@
+type nonrec t = A : t;;
+[%%expect{|
+Line _, characters 16-21:
+Error: GADT case syntax cannot be used in a 'nonrec' block.
+|}]
+

diff --git a/testsuite/tests/typing-gadts/pr7518.ml b/testsuite/tests/typing-gadts/pr7518.ml
new file mode 100644 (file)
index 0000000..7adaaa4
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr7518.ml
@@ -0,0 +1,50 @@
+type _ t = I : int t;;
+let f (type a) (x : a t) (y : int) =
+  match x, y with
+  | I, (_:a) -> ()
+;;
+[%%expect{|
+type _ t = I : int t
+val f : 'a t -> int -> unit = <fun>
+|}]
+
+type ('a, 'b) eq = Refl : ('a, 'a) eq;;
+let ok (type a b) (x : (a, b) eq) =
+  match x, [] with
+  | Refl, [(_ : a) | (_ : b)] -> []
+;;
+[%%expect{|
+type ('a, 'b) eq = Refl : ('a, 'a) eq
+Line _, characters 2-54:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+(Refl, _::_::_)
+Line _, characters 22-23:
+Warning 12: this sub-pattern is unused.
+val ok : ('a, 'b) eq -> 'c list = <fun>
+|}]
+let fails (type a b) (x : (a, b) eq) =
+  match x, [] with
+  | Refl, [(_ : a) | (_ : b)] -> []
+  | Refl, [(_ : b) | (_ : a)] -> []
+;;
+[%%expect{|
+Line _, characters 2-90:
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+(Refl, _::_::_)
+Line _, characters 22-23:
+Warning 12: this sub-pattern is unused.
+Line _, characters 4-29:
+Warning 11: this match case is unused.
+val fails : ('a, 'b) eq -> 'c list = <fun>
+|}]
+
+(* branches must be unified! *)
+let x = match [] with ["1"] -> 1 | [1.0] -> 2 | [1] -> 3 | _ -> 4;;
+[%%expect{|
+Line _, characters 35-40:
+Error: This pattern matches values of type float list
+       but a pattern was expected which matches values of type string list
+       Type float is not compatible with type string
+|}]

diff --git a/testsuite/tests/typing-gadts/unify_mb.ml b/testsuite/tests/typing-gadts/unify_mb.ml
index f11f92cc1f37c9a5a4ea829860eb8de77d58a0c9..567046a02dd018bc4558278de8cd1c189c0413a1 100644 (file)
--- a/testsuite/tests/typing-gadts/unify_mb.ml
+++ b/testsuite/tests/typing-gadts/unify_mb.ml
@@ -232,10 +232,10 @@ let t' = subst' d t
 [%%expect{|
 val s : 'a succ succ succ term = Fork (Var FZ, Fork (Var (FS (FS FZ)), Leaf))
 val t : 'a succ succ term = Fork (Var (FS FZ), Var (FS FZ))
-val d : '_a succ succ succ ealist =
+val d : '_weak1 succ succ succ ealist =
   EAlist (Asnoc (Asnoc (Anil, Fork (Var FZ, Leaf), FZ), Var FZ, FZ))
-val s' : '_a succ succ succ term =
+val s' : '_weak1 succ succ succ term =
   Fork (Fork (Var FZ, Leaf), Fork (Var FZ, Leaf))
-val t' : '_a succ succ succ term =
+val t' : '_weak1 succ succ succ term =
   Fork (Fork (Var FZ, Leaf), Fork (Var FZ, Leaf))
 |}];;

diff --git a/testsuite/tests/typing-implicit_unpack/implicit_unpack.ml.reference b/testsuite/tests/typing-implicit_unpack/implicit_unpack.ml.reference
index 50e54a07feadf049624c801964205d187827c326..5d2f4133762467a1f6784a7c83dd5dccbfa5d1a2 100644 (file)
--- a/testsuite/tests/typing-implicit_unpack/implicit_unpack.ml.reference
+++ b/testsuite/tests/typing-implicit_unpack/implicit_unpack.ml.reference
@@ -82,6 +82,7 @@ module type MapT =
     val is_empty : 'a t -> bool
     val mem : key -> 'a t -> bool
     val add : key -> 'a -> 'a t -> 'a t
+    val update : key -> ('a option -> 'a option) -> 'a t -> 'a t
     val singleton : key -> 'a -> 'a t
     val remove : key -> 'a t -> 'a t
     val merge :
@@ -128,6 +129,7 @@ module SSMap :
     val is_empty : 'a t -> bool
     val mem : key -> 'a t -> bool
     val add : key -> 'a -> 'a t -> 'a t
+    val update : key -> ('a option -> 'a option) -> 'a t -> 'a t
     val singleton : key -> 'a -> 'a t
     val remove : key -> 'a t -> 'a t
     val merge :

diff --git a/testsuite/tests/typing-misc/Makefile b/testsuite/tests/typing-misc/Makefile
index 0b15e777de9b37e51d0594072c80e3eef907fd3e..4184695d3803d25fc2177a16c137e54ebc30d23e 100644 (file)
--- a/testsuite/tests/typing-misc/Makefile
+++ b/testsuite/tests/typing-misc/Makefile
@@ -13,6 +13,24 @@
 #*                                                                        *
 #**************************************************************************
 
+all: pr6939.ml
+       $(MAKE) default
+
 BASEDIR=../..
 include $(BASEDIR)/makefiles/Makefile.expect
 include $(BASEDIR)/makefiles/Makefile.common
+
+GENERATED_SOURCES = pr6939.ml *.flat-float
+
+ifeq "$(FLAT_FLOAT_ARRAY)" "true"
+suffix = -flat
+else
+suffix = -noflat
+endif
+
+pr6939.ml: pr6939.ml$(suffix) $(FLAT_FLOAT_ARRAY).flat-float
+       cp $< $@
+
+%.flat-float:
+       @rm -f $(GENERATED_SOURCES)
+       @touch $@

diff --git a/testsuite/tests/typing-misc/polyvars.ml b/testsuite/tests/typing-misc/polyvars.ml
index a37eeb7bb6b2eefd2a671d6959c33cdd3d947091..4cdbd80422172f35cd75a52d3ccdcaf386cfbdce 100644 (file)
--- a/testsuite/tests/typing-misc/polyvars.ml
+++ b/testsuite/tests/typing-misc/polyvars.ml
@@ -57,3 +57,18 @@ let f x (g : [< `Foo]) =
 val revapply : 'a -> ('a -> 'b) -> 'b = <fun>
 val f : 'a -> [< `Foo ] -> 'a = <fun>
 |}];;
+
+(* PR#6124 *)
+let f : ([`A | `B ] as 'a) -> [> 'a] -> unit = fun x (y : [> 'a]) -> ();;
+let f (x : [`A | `B] as 'a) (y : [> 'a]) = ();;
+[%%expect{|
+Line _, characters 61-63:
+Error: The type 'a does not expand to a polymorphic variant type
+Hint: Did you mean `a?
+|}]
+
+(* PR#5927 *)
+type 'a foo = 'a constraint 'a = [< `Tag of & int];;
+[%%expect{|
+type 'a foo = 'a constraint 'a = [< `Tag of & int ]
+|}]

diff --git a/testsuite/tests/typing-misc/pr6939.ml b/testsuite/tests/typing-misc/pr6939.ml
deleted file mode 100755 (executable)
index 2acdd12..0000000
--- a/testsuite/tests/typing-misc/pr6939.ml
+++ /dev/null
@@ -1,15 +0,0 @@
-let rec x = [| x |]; 1.;;
-[%%expect{|
-Line _, characters 12-19:
-Warning 10: this expression should have type unit.
-Line _, characters 12-23:
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-|}];;
-
-let rec x = let u = [|y|] in 10. and y = 1.;;
-[%%expect{|
-Line _, characters 16-17:
-Warning 26: unused variable u.
-Line _, characters 12-32:
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-|}];;

diff --git a/testsuite/tests/typing-misc/pr6939.ml-flat b/testsuite/tests/typing-misc/pr6939.ml-flat
new file mode 100644 (file)
index 0000000..61298de
--- /dev/null
+++ b/testsuite/tests/typing-misc/pr6939.ml-flat
@@ -0,0 +1,13 @@
+let rec x = [| x |]; 1.;;
+[%%expect{|
+Line _, characters 12-19:
+Warning 10: this expression should have type unit.
+Line _, characters 12-23:
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+|}];;
+
+let rec x = let u = [|y|] in 10. and y = 1.;;
+[%%expect{|
+Line _, characters 12-32:
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+|}];;

diff --git a/testsuite/tests/typing-misc/pr6939.ml-noflat b/testsuite/tests/typing-misc/pr6939.ml-noflat
new file mode 100644 (file)
index 0000000..86f2ffd
--- /dev/null
+++ b/testsuite/tests/typing-misc/pr6939.ml-noflat
@@ -0,0 +1,14 @@
+let rec x = [| x |]; 1.;;
+[%%expect{|
+Line _, characters 12-19:
+Warning 10: this expression should have type unit.
+val x : float = 1.
+|}];;
+
+let rec x = let u = [|y|] in 10. and y = 1.;;
+[%%expect{|
+Line _, characters 16-17:
+Warning 26: unused variable u.
+val x : float = 10.
+val y : float = 1.
+|}];;

diff --git a/testsuite/tests/typing-misc/printing.ml b/testsuite/tests/typing-misc/printing.ml
index 277c386425cebb6e6d4d6a0263d0fe30beb803cc..e1fe44a4aad4d44ce92c0afc4a20c970609445e7 100644 (file)
--- a/testsuite/tests/typing-misc/printing.ml
+++ b/testsuite/tests/typing-misc/printing.ml
@@ -3,7 +3,7 @@
 type t = [ 'A_name | `Hi ];;
 [%%expect{|
 Line _, characters 11-18:
-Error: The type 'A_name is not a polymorphic variant type
+Error: The type 'A_name does not expand to a polymorphic variant type
 Hint: Did you mean `A_name?
 |}];;
 
@@ -16,3 +16,24 @@ let f (x:'Id_arg) = x;;
 [%%expect{|
 val f : 'Id_arg -> 'Id_arg = <fun>
 |}];;
+
+(* GPR#1204, GPR#1329 *)
+type 'a id = 'a
+let f (x : [< [`Foo] id]) = ();;
+[%%expect{|
+type 'a id = 'a
+val f : [< [ `Foo ] id ] -> unit = <fun>
+|}];;
+
+module M = struct module N = struct type t = [`A] end end;;
+let f x = (x :> M.N.t);;
+[%%expect{|
+module M : sig module N : sig type t = [ `A ] end end
+val f : [< M.N.t ] -> M.N.t = <fun>
+|}]
+module G = M.N;;
+let f x = (x :> G.t);;
+[%%expect{|
+module G = M.N
+val f : [< G.t ] -> G.t = <fun>
+|}]

diff --git a/testsuite/tests/typing-modules-bugs/pr6485_ok.ml b/testsuite/tests/typing-modules-bugs/pr6485_ok.ml
new file mode 100644 (file)
index 0000000..28821ca
--- /dev/null
+++ b/testsuite/tests/typing-modules-bugs/pr6485_ok.ml
@@ -0,0 +1,47 @@
+(** Check that rebinding module preserves private type aliases *)
+
+module String_id : sig
+  module type S = sig
+    type t = private string
+    val of_string : string -> t
+  end
+
+  include S
+
+  module Make (M : sig val module_name : string end) : S
+end = struct
+  module type S = sig
+    type t = private string
+    val of_string : string -> t
+  end
+
+  module String = struct
+    type t = string
+  end
+
+  module Make (M : sig val module_name : string end) = struct
+    include String
+
+    let of_string s =
+      Printf.printf "converting %s\n" M.module_name;
+      s
+  end
+
+  include Make (struct let module_name = "String_id" end)
+end
+
+let () =
+  let foo = String_id.of_string "foo" in
+  Printf.printf "foo = %s\n" (foo :> string)
+
+let () =
+  let module Bar = String_id.Make(struct let module_name="Bar" end) in
+  let bar = Bar.of_string "bar" in
+  Printf.printf "bar = %s\n" (bar :> string)
+
+let () =
+  let module String_id2 = String_id in
+  let module Baz = String_id2.Make(struct let module_name="Baz" end) in
+  let baz = Baz.of_string "baz" in
+  Printf.printf "baz = %s\n" (baz :> string)
+

diff --git a/testsuite/tests/typing-modules-bugs/pr7321_ok.ml b/testsuite/tests/typing-modules-bugs/pr7321_ok.ml
new file mode 100644 (file)
index 0000000..930031c
--- /dev/null
+++ b/testsuite/tests/typing-modules-bugs/pr7321_ok.ml
@@ -0,0 +1,8 @@
+module type S = sig type 'a t end
+module type Sp = sig type 'a t = private 'a array end
+
+module Id (S : S) = S
+
+module M : Sp = struct
+  include Id (struct type 'a t = 'a array end)
+end

diff --git a/testsuite/tests/typing-modules-bugs/pr7519_ok.ml b/testsuite/tests/typing-modules-bugs/pr7519_ok.ml
new file mode 100644 (file)
index 0000000..b01da15
--- /dev/null
+++ b/testsuite/tests/typing-modules-bugs/pr7519_ok.ml
@@ -0,0 +1,18 @@
+module Gen_spec = struct type 't extra = unit end
+
+module type S = sig
+  module Spec : sig type 't extra = unit end
+
+  type t
+  val make : unit -> t Spec.extra
+end (* S *)
+
+module Make () : S with module Spec := Gen_spec = struct
+  type t = int
+  let make () = ()
+end (* Make *)
+
+let () =
+  let module M = Make () in
+  M.make ()
+  (* (M.make () : unit) *)

diff --git a/testsuite/tests/typing-modules-bugs/pr7601_ok.ml b/testsuite/tests/typing-modules-bugs/pr7601_ok.ml
new file mode 100644 (file)
index 0000000..7dd1db7
--- /dev/null
+++ b/testsuite/tests/typing-modules-bugs/pr7601_ok.ml
@@ -0,0 +1,22 @@
+(**************************************************************************)
+(*                                                                        *)
+(*  Crude slicer for preprocessing reachability verification tasks        *)
+(*                                                                        *)
+(*  Copyright (C) 2016-2017 Mikhail Mandrykin, ISP RAS                    *)
+(*                                                                        *)
+(**************************************************************************)
+
+module type Analysis = sig
+  type t
+  type 'a maybe_region =
+    [< `Location of t
+    |  `Value of t
+    |  `None ] as 'a
+  val of_var : ?f:string -> string -> [ `Location of _ | `Value of _  | `None ] maybe_region
+end
+
+module Make (Analysis : Analysis) = struct
+  include Analysis
+  let of_var  = of_var ~f:""
+end
+

diff --git a/testsuite/tests/typing-modules-bugs/pr7601a_ok.ml b/testsuite/tests/typing-modules-bugs/pr7601a_ok.ml
new file mode 100644 (file)
index 0000000..58e0eed
--- /dev/null
+++ b/testsuite/tests/typing-modules-bugs/pr7601a_ok.ml
@@ -0,0 +1,21 @@
+module type Param1 = sig
+  type 'a r = [< `A of int ] as 'a
+  val f : ?a:string -> string -> [ `A of _ ] r
+end
+
+module Make1 (M : Param1) = struct
+  include M
+  let f = f ~a:""
+end
+
+module type Param2 = sig
+  type t
+  type 'a r = [< `A of t ] as 'a
+  val f : ?a:string -> string -> [ `A of _ ] r
+end
+
+module Make2 (M : Param2) = struct
+  include M
+  let f = f ~a:""
+end
+

diff --git a/testsuite/tests/typing-multifile/Makefile b/testsuite/tests/typing-multifile/Makefile
index a9653bd9e88addf1937e02569b69feadc53485d1..efcadaf29cc20c9b5d158a9ea796ed8e32f824ae 100644 (file)
--- a/testsuite/tests/typing-multifile/Makefile
+++ b/testsuite/tests/typing-multifile/Makefile
@@ -14,18 +14,35 @@
 #**************************************************************************
 
 BASEDIR=../..
-GENERATED= a.ml b.ml c.ml
+GENERATED= a.ml b.ml c.ml d.mli e.ml f.ml g.ml test
 
-default: pr7325
+default: pr7325 pr6372 pr7563
 
 pr7325:
-       @printf " ... testing pr7325:"
+       @printf " ... testing 'pr7325':"
        @echo "type _ t = T" > a.ml
        @echo "type 'a t = 'a A.t" > b.ml
        @echo 'external f : unit -> unit B.t = "%identity"' > c.ml
        @$(OCAMLC) -c a.ml b.ml && rm a.cmi && $(OCAMLC) -c c.ml \
          && echo " => passed" || echo " => failed"
 
+pr6372:
+       @printf " ... testing 'pr6372':"
+       @echo "type _ t =  C: { f: ('a -> [<\`X]) t } -> [<\`X] t" > d.mli
+       @echo "open D;; let f (C {f}) = ()" > e.ml
+       @$(OCAMLC) -c d.mli e.ml \
+         && echo " => passed" || echo " => failed"
+
+pr7563:
+       @printf " ... testing 'pr7563':"
+       @echo "module A = struct end" > f.ml
+       @echo "module Alias = A" >> f.ml
+       @echo "exception Alias" >> f.ml
+       @echo "let alias = Alias" >> f.ml
+       @echo "exit (if F.Alias = F.alias then 0 else 1)" > g.ml
+       @$(OCAMLC) f.ml g.ml -o test && $(OCAMLRUN) ./test \
+         && echo " => passed" || echo " => failed"
+
 clean: defaultclean
        @rm -f $(GENERATED)
 

diff --git a/testsuite/tests/typing-objects/Tests.ml.principal.reference b/testsuite/tests/typing-objects/Tests.ml.principal.reference
index 7b1164e680646f3b7a6d2d183a66266e76269cea..ba027f1de83be991ea0fef3fe287bee556606304 100644 (file)
--- a/testsuite/tests/typing-objects/Tests.ml.principal.reference
+++ b/testsuite/tests/typing-objects/Tests.ml.principal.reference
@@ -50,14 +50,14 @@ Error: The abbreviation c is used with parameters bool c
     constraint 'b = 'a * < x : 'b > * 'c * 'd
     method f : 'a -> 'b -> unit
   end
-#     val x : '_a list ref = {contents = []}
+#     val x : '_weak1 list ref = {contents = []}
 #     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,
+         unit -> object constraint 'a = '_weak1 list ref method f : 'a end,
        contains type variables that cannot be generalized
 #       Characters 21-53:
   type 'a c = <f : 'a c; g : 'a d>
@@ -265,7 +265,7 @@ Error: Type int -> bool is not a subtype of int -> int
        Type bool is not a subtype of int 
 # - : <  > -> <  > = <fun>
 # - : < .. > -> <  > = <fun>
-#   val x : '_a list ref = {contents = []}
+#   val x : '_weak2 list ref = {contents = []}
 #   module F : functor (X : sig  end) -> sig type t = int end
 # - : < m : int > list ref = {contents = []}
 #   type 'a t

diff --git a/testsuite/tests/typing-objects/Tests.ml.reference b/testsuite/tests/typing-objects/Tests.ml.reference
index 7b1164e680646f3b7a6d2d183a66266e76269cea..ba027f1de83be991ea0fef3fe287bee556606304 100644 (file)
--- a/testsuite/tests/typing-objects/Tests.ml.reference
+++ b/testsuite/tests/typing-objects/Tests.ml.reference
@@ -50,14 +50,14 @@ Error: The abbreviation c is used with parameters bool c
     constraint 'b = 'a * < x : 'b > * 'c * 'd
     method f : 'a -> 'b -> unit
   end
-#     val x : '_a list ref = {contents = []}
+#     val x : '_weak1 list ref = {contents = []}
 #     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,
+         unit -> object constraint 'a = '_weak1 list ref method f : 'a end,
        contains type variables that cannot be generalized
 #       Characters 21-53:
   type 'a c = <f : 'a c; g : 'a d>
@@ -265,7 +265,7 @@ Error: Type int -> bool is not a subtype of int -> int
        Type bool is not a subtype of int 
 # - : <  > -> <  > = <fun>
 # - : < .. > -> <  > = <fun>
-#   val x : '_a list ref = {contents = []}
+#   val x : '_weak2 list ref = {contents = []}
 #   module F : functor (X : sig  end) -> sig type t = int end
 # - : < m : int > list ref = {contents = []}
 #   type 'a t

diff --git a/testsuite/tests/typing-objects/open_in_classes.ml b/testsuite/tests/typing-objects/open_in_classes.ml
new file mode 100755 (executable)
index 0000000..24c0b34
--- /dev/null
+++ b/testsuite/tests/typing-objects/open_in_classes.ml
@@ -0,0 +1,17 @@
+module M = struct
+  type t = int
+  let x = 42
+end
+;;
+class c =
+  let open M in
+  object
+    method f : t = x
+  end
+;;
+class type ct =
+  let open M in
+  object
+    method f : t
+  end
+;;

diff --git a/testsuite/tests/typing-objects/open_in_classes.ml.reference b/testsuite/tests/typing-objects/open_in_classes.ml.reference
new file mode 100644 (file)
index 0000000..eaafa30
--- /dev/null
+++ b/testsuite/tests/typing-objects/open_in_classes.ml.reference
@@ -0,0 +1,5 @@
+
+#         module M : sig type t = int val x : int end
+#           class c : object method f : M.t end
+#           class type ct = object method f : M.t end
+# 

diff --git a/testsuite/tests/typing-ocamlc-i/Makefile b/testsuite/tests/typing-ocamlc-i/Makefile
new file mode 100644 (file)
index 0000000..8131fe6
--- /dev/null
+++ b/testsuite/tests/typing-ocamlc-i/Makefile
@@ -0,0 +1,15 @@
+# Check ocamlc -i
+
+SOURCES = pr7620_bad.ml
+
+all: 
+       @printf " ... testing '$(SOURCES)'"
+       @$(OCAMLC) -i $(SOURCES) 2> /dev/null \
+        && echo " => failed" || echo " => passed"
+
+clean: defaultclean
+       @rm -f *~
+
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.common
+

diff --git a/testsuite/tests/typing-ocamlc-i/pr7620_bad.ml b/testsuite/tests/typing-ocamlc-i/pr7620_bad.ml
new file mode 100644 (file)
index 0000000..ad03d56
--- /dev/null
+++ b/testsuite/tests/typing-ocamlc-i/pr7620_bad.ml
@@ -0,0 +1,3 @@
+let t = 
+  (function `A | `B -> () : 'a) (`A : [`A]);
+  (failwith "dummy" : 'a) (* to know how 'a is unified *)

diff --git a/testsuite/tests/typing-poly/poly.ml b/testsuite/tests/typing-poly/poly.ml
index 0073f0ecfc5e598a1d3120ccf8ebcbf72c99da11..6e21e0f406311f520267ccd20869dc0fe0155035 100644 (file)
--- a/testsuite/tests/typing-poly/poly.ml
+++ b/testsuite/tests/typing-poly/poly.ml
@@ -1448,7 +1448,7 @@ type ('c, 't) pvariant = [ `V of 'c * 't t ]
 class ['c] clss : object method mthod : 'c -> 't t -> ('c, 't) pvariant end
 val f2 : 'a -> 'b -> 'c t -> 'c t = <fun>
 val f1 :
-  < mthod : 't. 'a -> 't t -> [< ('a, 't) pvariant ]; .. > ->
+  < mthod : 't. 'a -> 't t -> [< `V of 'a * 't t ]; .. > ->
   'a -> 'b t -> 'b t = <fun>
 |}]
 
@@ -1459,7 +1459,18 @@ let x = f 3;;
 [%%expect{|
 type (+'a, -'b) foo = private int
 val f : int -> ('a, 'a) foo = <fun>
-val x : ('_a, '_a) foo = 3
+val x : ('_weak1, '_weak1) foo = 3
+|}]
+
+
+(* PR#7344*)
+let rec f : unit -> < m: 'a. 'a -> 'a> = fun () ->
+  let x = f () in
+  ignore (x#m 1);
+  ignore (x#m "hello");
+  assert false;;
+[%%expect{|
+val f : unit -> < m : 'a. 'a -> 'a > = <fun>
 |}]
 
 (* PR#7395 *)
@@ -1474,3 +1485,124 @@ type u
 type 'a t = u
 val c : (u -> u) -> < apply : 'a. 'a t -> 'a t > = <fun>
 |}]
+
+(* PR#7496 *)
+let f (x : < m: 'a. ([< `Foo of int & float] as 'a) -> unit>)
+         : < m: 'a. ([< `Foo of int & float] as 'a) -> unit> = x;;
+
+type t = { x : 'a. ([< `Foo of int & float ] as 'a) -> unit };;
+let f t = { x = t.x };;
+[%%expect{|
+val f :
+  < m : 'a. ([< `Foo of int & float ] as 'a) -> unit > ->
+  < m : 'b. ([< `Foo of int & float ] as 'b) -> unit > = <fun>
+type t = { x : 'a. ([< `Foo of int & float ] as 'a) -> unit; }
+val f : t -> t = <fun>
+|}]
+
+type t = <m:int>
+type g = <n:string; t>
+type h = <x:string; y:int; g>
+[%%expect{|
+type t = < m : int >
+type g = < m : int; n : string >
+type h = < m : int; n : string; x : string; y : int >
+|}]
+
+type t = <g>
+and g = <a:t>
+[%%expect{|
+Line _, characters 10-11:
+Error: The type constructor g
+is not yet completely defined
+|}]
+
+type t = int
+type g = <t>
+[%%expect{|
+type t = int
+Line _, characters 10-11:
+Error: The type int is not an object type
+|}]
+
+type t = <a:int>
+type g = <t; t; t;>
+[%%expect{|
+type t = < a : int >
+type g = < a : int >
+|}]
+
+type c = <a:int; d:string>
+let s:c = object method a=1; method d="123" end
+[%%expect{|
+type c = < a : int; d : string >
+val s : c = <obj>
+|}]
+
+type 'a t = < m: 'a >
+type s = < int t >
+module M = struct type t = < m: int > end
+type u = < M.t >
+type r = < a : int; < b : int > >
+type e = < >
+type r1 = < a : int; e >
+type r2 = < a : int; < < < > > > >
+[%%expect{|
+type 'a t = < m : 'a >
+type s = < m : int >
+module M : sig type t = < m : int > end
+type u = < m : int >
+type r = < a : int; b : int >
+type e = <  >
+type r1 = < a : int >
+type r2 = < a : int >
+|}]
+
+type gg = <a:int->float; a:int>
+[%%expect{|
+Line _, characters 27-30:
+Error: Method 'a' has type int, which should be int -> float
+|}]
+
+type t = <a:int; b:string>
+type g = <b:float; t;>
+[%%expect{|
+type t = < a : int; b : string >
+Line _, characters 19-20:
+Error: Method 'b' has type string, which should be float
+|}]
+
+module A = struct
+  class type ['a] t1 = object method f : 'a end
+end
+type t = < int A.t1 >
+[%%expect{|
+module A : sig class type ['a] t1 = object method f : 'a end end
+type t = < f : int >
+|}]
+
+type t = < int #A.t1 >
+[%%expect{|
+Line _, characters 11-20:
+Error: Illegal open object type
+|}]
+
+let g = fun (y : ('a * 'b)) x -> (x : < <m: 'a> ; <m: 'b> >)
+[%%expect{|
+val g : 'a * 'a -> < m : 'a > -> < m : 'a > = <fun>
+|}]
+
+type 'a t = <m: 'a ; m: int>
+[%%expect{|
+type 'a t = < m : 'a > constraint 'a = int
+|}]
+
+(* GPR#1142 *)
+module M () = struct
+  let f : 'a -> 'a = assert false
+  let g : 'a -> 'a = raise Not_found
+end
+
+[%%expect{|
+module M : functor () -> sig val f : 'a -> 'a val g : 'a -> 'a end
+|}]

diff --git a/testsuite/tests/typing-safe-linking/Makefile b/testsuite/tests/typing-safe-linking/Makefile
index 4e3cf43a5e5348c925acf944e89a9a99a6f87dbd..9ecd47c2ce4aba6746c37c47c32c5aaf98b4f1cb 100644 (file)
--- a/testsuite/tests/typing-safe-linking/Makefile
+++ b/testsuite/tests/typing-safe-linking/Makefile
@@ -13,8 +13,3 @@ clean:
 
 BASEDIR=../..
 include $(BASEDIR)/makefiles/Makefile.common
-
-# The second test (`A.y`) is unnecessary, indeed cannot be compiled, under -safe-string
-ifeq ($(SAFE_STRING),true)
-ADD_COMPFLAGS=-pp "sed -e '\$$d'"
-endif

diff --git a/testsuite/tests/typing-safe-linking/a.ml b/testsuite/tests/typing-safe-linking/a.ml
index 12e0cb123b248ab7f94d274ad9eb819a43dc350d..5556e495248d9a1733ae0379b87c90f230156adb 100644 (file)
--- a/testsuite/tests/typing-safe-linking/a.ml
+++ b/testsuite/tests/typing-safe-linking/a.ml
@@ -1,6 +1,3 @@
  type _ t =
      X of string
    | Y : bytes t
-
-(* It is important that the line below is the last line of the file (see Makefile) *)
-let y : string t = Y

diff --git a/testsuite/tests/typing-short-paths/Makefile b/testsuite/tests/typing-short-paths/Makefile
index 3e5a5df04037928cd50c6aabe7d158779494d2a0..10856782bd00acf4887cfcc815399b0327508f6f 100644 (file)
--- a/testsuite/tests/typing-short-paths/Makefile
+++ b/testsuite/tests/typing-short-paths/Makefile
@@ -17,3 +17,7 @@ BASEDIR=../..
 include $(BASEDIR)/makefiles/Makefile.toplevel
 include $(BASEDIR)/makefiles/Makefile.common
 TOPFLAGS = -short-paths
+
+default: gpr1223_foo.cmi gpr1223_bar.cmi
+
+gpr1223_bar.cmi: gpr1223_foo.cmi

diff --git a/testsuite/tests/typing-short-paths/gpr1223.ml b/testsuite/tests/typing-short-paths/gpr1223.ml
new file mode 100644 (file)
index 0000000..0c481db
--- /dev/null
+++ b/testsuite/tests/typing-short-paths/gpr1223.ml
@@ -0,0 +1,4 @@
+
+let y = Gpr1223_bar.N.O.T;;
+
+let x = Gpr1223_bar.M.T;;

diff --git a/testsuite/tests/typing-short-paths/gpr1223.ml.reference b/testsuite/tests/typing-short-paths/gpr1223.ml.reference
new file mode 100644 (file)
index 0000000..cf578cd
--- /dev/null
+++ b/testsuite/tests/typing-short-paths/gpr1223.ml.reference
@@ -0,0 +1,4 @@
+
+#   val y : Gpr1223_bar.N.O.t = Gpr1223_bar.N.O.T
+#   val x : Gpr1223_bar.M.t = Gpr1223_bar.M.T
+# 

diff --git a/testsuite/tests/typing-short-paths/gpr1223_bar.mli b/testsuite/tests/typing-short-paths/gpr1223_bar.mli
new file mode 100644 (file)
index 0000000..f3f51e0
--- /dev/null
+++ b/testsuite/tests/typing-short-paths/gpr1223_bar.mli
@@ -0,0 +1,12 @@
+
+module M : Gpr1223_foo.S
+
+module N : sig
+
+  module O : sig
+
+    type t = T
+
+  end
+
+end

diff --git a/testsuite/tests/typing-short-paths/gpr1223_foo.mli b/testsuite/tests/typing-short-paths/gpr1223_foo.mli
new file mode 100644 (file)
index 0000000..b46079d
--- /dev/null
+++ b/testsuite/tests/typing-short-paths/gpr1223_foo.mli
@@ -0,0 +1,6 @@
+
+module type S = sig
+
+  type t = T
+
+end

diff --git a/testsuite/tests/typing-short-paths/pr7543.ml b/testsuite/tests/typing-short-paths/pr7543.ml
new file mode 100644 (file)
index 0000000..9c89061
--- /dev/null
+++ b/testsuite/tests/typing-short-paths/pr7543.ml
@@ -0,0 +1,9 @@
+(** Test that short-path printtyp does not fail on packed module.
+
+  Packed modules does not respect the arity of type constructor, which can break
+  the path normalization within the short-path code path.
+*)
+module type S = sig type t end;;
+module N = struct type 'a t = 'a end;;
+let f (module M:S with type t = unit) = ();;
+let () = f (module N);;

diff --git a/testsuite/tests/typing-short-paths/pr7543.ml.reference b/testsuite/tests/typing-short-paths/pr7543.ml.reference
new file mode 100644 (file)
index 0000000..74fe45c
--- /dev/null
+++ b/testsuite/tests/typing-short-paths/pr7543.ml.reference
@@ -0,0 +1,18 @@
+
+# * * * *   module type S = sig type t end
+# module N : sig type 'a t = 'a end
+# val f : (module S with type t = unit) -> unit = <fun>
+# Characters 19-20:
+  let () = f (module N);;
+                     ^
+Error: Signature mismatch:
+       Modules do not match:
+         sig type 'a t = 'a end
+       is not included in
+         sig type t = N.t end
+       Type declarations do not match:
+         type 'a t = 'a
+       is not included in
+         type t = N.t
+       They have different arities.
+# 

diff --git a/testsuite/tests/typing-short-paths/short-paths.ml.reference b/testsuite/tests/typing-short-paths/short-paths.ml.reference
index 64651566cde14e2e2abfa37db16fc90d6d122be3..22babba59a208acbc8ebdfc4d32b76dc2224cbc9 100644 (file)
--- a/testsuite/tests/typing-short-paths/short-paths.ml.reference
+++ b/testsuite/tests/typing-short-paths/short-paths.ml.reference
@@ -20,6 +20,7 @@
             val is_empty : 'a t -> bool
             val mem : key -> 'a t -> bool
             val add : key -> 'a -> 'a t -> 'a t
+            val update : key -> ('a option -> 'a option) -> 'a t -> 'a t
             val singleton : key -> 'a -> 'a t
             val remove : key -> 'a t -> 'a t
             val merge :

diff --git a/testsuite/tests/typing-sigsubst/Makefile b/testsuite/tests/typing-sigsubst/Makefile
index 7fc00661cbe83513fbab37e2fe27d89365c35054..0b15e777de9b37e51d0594072c80e3eef907fd3e 100644 (file)
--- a/testsuite/tests/typing-sigsubst/Makefile
+++ b/testsuite/tests/typing-sigsubst/Makefile
@@ -14,5 +14,5 @@
 #**************************************************************************
 
 BASEDIR=../..
-include $(BASEDIR)/makefiles/Makefile.toplevel
+include $(BASEDIR)/makefiles/Makefile.expect
 include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/typing-sigsubst/sigsubst.ml b/testsuite/tests/typing-sigsubst/sigsubst.ml
index 6759f63ab282155b8040911d8a68c0414e3e4f67..96aea57302619b13146a8fb5213457879805c021 100644 (file)
--- a/testsuite/tests/typing-sigsubst/sigsubst.ml
+++ b/testsuite/tests/typing-sigsubst/sigsubst.ml
@@ -1,40 +1,330 @@
 module type Printable = sig
   type t
   val print : Format.formatter -> t -> unit
-end;;
+end
+[%%expect {|
+module type Printable =
+  sig type t val print : Format.formatter -> t -> unit end
+|}]
 module type Comparable = sig
   type t
   val compare : t -> t -> int
-end;;
+end
+[%%expect {|
+module type Comparable = sig type t val compare : t -> t -> int end
+|}]
 module type PrintableComparable = sig
   include Printable
   include Comparable with type t = t
-end;; (* Fails *)
+end
+[%%expect {|
+Line _, characters 2-36:
+Error: Multiple definition of the type name t.
+       Names must be unique in a given structure or signature.
+|}]
+
+module type Sunderscore = sig
+  type (_, _) t
+end with type (_, 'a) t = int * 'a
+[%%expect {|
+module type Sunderscore = sig type (_, 'a) t = int * 'a end
+|}]
+
+
+(* Valid substitutions in a recursive module may fail due to the ordering of
+   the modules. *)
+
+module type S0 = sig
+  module rec M : sig type t = M2.t end
+  and M2 : sig type t = int end
+end with type M.t = int
+[%%expect {|
+Line _, characters 17-115:
+Error: In this `with' constraint, the new definition of M.t
+       does not match its original definition in the constrained signature:
+       Type declarations do not match:
+         type t = int
+       is not included in
+         type t = M2.t
+|}]
+
+
 module type PrintableComparable = sig
   type t
   include Printable with type t := t
   include Comparable with type t := t
-end;;
+end
+[%%expect {|
+module type PrintableComparable =
+  sig
+    type t
+    val print : Format.formatter -> t -> unit
+    val compare : t -> t -> int
+  end
+|}]
 module type PrintableComparable = sig
   include Printable
   include Comparable with type t := t
-end;;
-module type ComparableInt = Comparable with type t := int;;
-module type S = sig type t val f : t -> t end;;
-module type S' = S with type t := int;;
+end
+[%%expect {|
+module type PrintableComparable =
+  sig
+    type t
+    val print : Format.formatter -> t -> unit
+    val compare : t -> t -> int
+  end
+|}]
+module type ComparableInt = Comparable with type t := int
+[%%expect {|
+module type ComparableInt = sig val compare : int -> int -> int end
+|}]
+module type S = sig type t val f : t -> t end
+[%%expect {|
+module type S = sig type t val f : t -> t end
+|}]
+module type S' = S with type t := int
+[%%expect {|
+module type S' = sig val f : int -> int end
+|}]
+
+module type S = sig type 'a t val map : ('a -> 'b) -> 'a t -> 'b t end
+module type S1 = S with type 'a t := 'a list
+[%%expect {|
+module type S = sig type 'a t val map : ('a -> 'b) -> 'a t -> 'b t end
+module type S1 = sig val map : ('a -> 'b) -> 'a list -> 'b list end
+|}]
+module type S2 = S with type 'a t := (string * 'a) list
+[%%expect {|
+module type S2 =
+  sig val map : ('a -> 'b) -> (string * 'a) list -> (string * 'b) list end
+|}]
+module type S3 = S with type _ t := int
+[%%expect {|
+module type S3 = sig val map : ('a -> 'b) -> int -> int end
+|}]
+
 
-module type S = sig type 'a t val map : ('a -> 'b) -> 'a t -> 'b t end;;
-module type S1 = S with type 'a t := 'a list;;
-module type S2 = sig
-  type 'a dict = (string * 'a) list
-  include S with type 'a t := 'a dict
-end;;
+module type S =
+  sig module T : sig type exp type arg end val f : T.exp -> T.arg end
+module M = struct type exp = string type arg = int end
+module type S' = S with module T := M
+[%%expect {|
+module type S =
+  sig module T : sig type exp type arg end val f : T.exp -> T.arg end
+module M : sig type exp = string type arg = int end
+module type S' = sig val f : M.exp -> M.arg end
+|}]
+
+
+module type S = sig type 'a t end with type 'a t := unit
+[%%expect {|
+module type S = sig  end
+|}]
 
+module type S = sig
+  type t = [ `Foo ]
+  type s = private [< t ]
+end with type t := [ `Foo ]
+[%%expect {|
+module type S = sig type s = private [< `Foo ] end
+|}]
 
+module type S = sig
+  type t = ..
+  type t += A
+end with type t := exn
+[%%expect {|
+module type S = sig type exn += A end
+|}]
+
+(* We allow type constraints when replacing a path by a path. *)
+type 'a t constraint 'a = 'b list
+module type S = sig
+  type 'a t2 constraint 'a = 'b list
+  type 'a mylist = 'a list
+  val x : int mylist t2
+end with type 'a t2 := 'a t
+[%%expect {|
+type 'a t constraint 'a = 'b list
+module type S = sig type 'a mylist = 'a list val x : int mylist t end
+|}]
+
+(* but not when replacing a path by a type expression *)
+type 'a t constraint 'a = 'b list
+module type S = sig
+  type 'a t2 constraint 'a = 'b list
+  type 'a mylist = 'a list
+  val x : int mylist t2
+end with type 'a t2 := 'a t * bool
+[%%expect {|
+type 'a t constraint 'a = 'b list
+Line _, characters 16-142:
+Error: Destructive substitutions are not supported for constrained
+       types (other than when replacing a type constructor with
+       a type constructor with the same arguments).
+|}]
+
+(* Issue where the typer expands an alias, which breaks the typing of the rest
+   of the signature, but no error is given to the user. *)
+module type S = sig
+  module M1 : sig type t = int end
+  module M2 = M1
+  module M3 : sig module M = M2 end
+  module F(X : sig module M = M1 end) : sig type t end
+  type t = F(M3).t
+end with type M2.t = int
+[%%expect {|
 module type S =
-  sig module T : sig type exp type arg end val f : T.exp -> T.arg end;;
-module M = struct type exp = string type arg = int end;;
-module type S' = S with module T := M;;
+  sig
+    module M1 : sig type t = int end
+    module M2 : sig type t = int end
+    module M3 : sig module M = M2 end
+    module F : functor (X : sig module M = M1 end) -> sig type t end
+    type t = F(M3).t
+  end
+|}]
+
+(* Checking that the uses of M.t are rewritten regardless of how they
+   are named, but we don't rewrite other types by the same name. *)
+module type S = sig
+  module M : sig type t val x : t end
+  val y : M.t
+  module A : sig module M : sig type t val z : t -> M.t end end
+end with type M.t := float
+[%%expect {|
+module type S =
+  sig
+    module M : sig val x : float end
+    val y : float
+    module A : sig module M : sig type t val z : t -> float end end
+  end
+|}]
+
+(* Regression test: at some point, expanding S1 twice in the same
+   "with type" would result in a signature with duplicate ids, which
+   would confuse the rewriting (we would end with (M2.x : int)) and
+   only then get refreshened. *)
+module type S = sig
+  module type S1 = sig type t type a val x : t end
+  module M1 : S1
+  type a = M1.t
+  module M2 : S1
+  type b = M2.t
+end with type M1.a = int and type M2.a = int and type M1.t := int;;
+[%%expect {|
+module type S =
+  sig
+    module type S1 = sig type t type a val x : t end
+    module M1 : sig type a = int val x : int end
+    type a = int
+    module M2 : sig type t type a = int val x : t end
+    type b = M2.t
+  end
+|}]
+
+(* And now some corner cases with aliases: *)
+
+module type S = sig
+  module M : sig type t end
+  module A = M
+end with type M.t := float
+[%%expect {|
+Line _, characters 16-89:
+Error: This `with' constraint on M.t changes M, which is aliased
+       in the constrained signature (as A).
+|}]
+
+(* And more corner cases with applicative functors: *)
+
+module type S = sig
+  module M : sig type t type u end
+  module F(X : sig type t end) : sig type t end
+  type t = F(M).t
+end
+[%%expect {|
+module type S =
+  sig
+    module M : sig type t type u end
+    module F : functor (X : sig type t end) -> sig type t end
+    type t = F(M).t
+  end
+|}]
+
+(* This particular substitution cannot be made to work *)
+module type S2 = S with type M.t := float
+[%%expect {|
+Line _, characters 17-41:
+Error: This `with' constraint on M.t makes the applicative functor
+       type F(M).t ill-typed in the constrained signature:
+       Modules do not match:
+         sig type u = M.u end
+       is not included in
+         sig type t end
+       The type `t' is required but not provided
+|}]
+
+(* However if the applicative functor doesn't care about the type
+   we're removing, the typer accepts the removal. *)
+module type S2 = S with type M.u := float
+[%%expect {|
+module type S2 =
+  sig
+    module M : sig type t end
+    module F : functor (X : sig type t end) -> sig type t end
+    type t = F(M).t
+  end
+|}]
+
+(* In the presence of recursive modules, the use of a module can come before its
+   definition (in the typed tree). *)
+
+module Id(X : sig type t end) = struct type t = X.t end
+module type S3 = sig
+  module rec M : sig type t = A of Id(M2).t end
+  and M2 : sig type t end
+end with type M2.t := int
+[%%expect {|
+module Id : functor (X : sig type t end) -> sig type t = X.t end
+Line _, characters 17-120:
+Error: This `with' constraint on M2.t makes the applicative functor
+       type Id(M2).t ill-typed in the constrained signature:
+       Modules do not match: sig  end is not included in sig type t end
+       The type `t' is required but not provided
+|}]
+
+
+(* Deep destructive module substitution: *)
+
+module A = struct module P = struct type t let x = 1 end end
+module type S = sig
+  module M : sig
+    module N : sig
+      module P : sig
+        type t
+      end
+    end
+  end
+  type t = M.N.P.t
+end with module M.N := A
+[%%expect {|
+module A : sig module P : sig type t val x : int end end
+module type S = sig module M : sig  end type t = A.P.t end
+|}]
 
+(* Same as for types, not all substitutions are accepted *)
 
-module type S = sig type 'a t end with type 'a t := unit;; (* Fails *)
+module type S = sig
+  module M : sig
+    module N : sig
+      module P : sig
+        type t
+      end
+    end
+  end
+  module Alias = M
+end with module M.N := A
+[%%expect {|
+Line _, characters 16-159:
+Error: This `with' constraint on M.N changes M, which is aliased
+       in the constrained signature (as Alias).
+|}]

diff --git a/testsuite/tests/typing-sigsubst/sigsubst.ml.reference b/testsuite/tests/typing-sigsubst/sigsubst.ml.reference
deleted file mode 100644 (file)
index 5a16034..0000000
--- a/testsuite/tests/typing-sigsubst/sigsubst.ml.reference
+++ /dev/null
@@ -1,40 +0,0 @@
-
-#       module type Printable =
-  sig type t val print : Format.formatter -> t -> unit end
-#       module type Comparable = sig type t val compare : t -> t -> int end
-#       Characters 60-94:
-    include Comparable with type t = t
-    ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: Multiple definition of the type name t.
-       Names must be unique in a given structure or signature.
-#         module type PrintableComparable =
-  sig
-    type t
-    val print : Format.formatter -> t -> unit
-    val compare : t -> t -> int
-  end
-#       module type PrintableComparable =
-  sig
-    type t
-    val print : Format.formatter -> t -> unit
-    val compare : t -> t -> int
-  end
-# module type ComparableInt = sig val compare : int -> int -> int end
-# module type S = sig type t val f : t -> t end
-# module type S' = sig val f : int -> int end
-#   module type S = sig type 'a t val map : ('a -> 'b) -> 'a t -> 'b t end
-# module type S1 = sig val map : ('a -> 'b) -> 'a list -> 'b list end
-#       module type S2 =
-  sig
-    type 'a dict = (string * 'a) list
-    val map : ('a -> 'b) -> 'a dict -> 'b dict
-  end
-#       module type S =
-  sig module T : sig type exp type arg end val f : T.exp -> T.arg end
-# module M : sig type exp = string type arg = int end
-# module type S' = sig val f : M.exp -> M.arg end
-#     Characters 41-58:
-  module type S = sig type 'a t end with type 'a t := unit;; (* Fails *)
-                                         ^^^^^^^^^^^^^^^^^
-Error: Only type constructors with identical parameters can be substituted.
-# 

diff --git a/testsuite/tests/typing-typeparam/newtype.ml b/testsuite/tests/typing-typeparam/newtype.ml
index abe587634c20ad9748d1a9c79a24fc4834729be3..d32f4c91d299ba84efd105d5b59107cac1e8c37e 100644 (file)
--- a/testsuite/tests/typing-typeparam/newtype.ml
+++ b/testsuite/tests/typing-typeparam/newtype.ml
@@ -10,10 +10,10 @@ let () =
   let i = int_inj 3 in
   let s = string_inj "abc" in
 
-  Printf.printf "%b\n%!" (int_proj i = None);
-  Printf.printf "%b\n%!" (int_proj s = None);
-  Printf.printf "%b\n%!" (string_proj i = None);
-  Printf.printf "%b\n%!" (string_proj s = None)
+  Printf.printf "%B\n%!" (int_proj i = None);
+  Printf.printf "%B\n%!" (int_proj s = None);
+  Printf.printf "%B\n%!" (string_proj i = None);
+  Printf.printf "%B\n%!" (string_proj s = None)
 ;;
 
 let sort_uniq (type s) cmp l =

diff --git a/testsuite/tests/typing-unboxed-types/Makefile b/testsuite/tests/typing-unboxed-types/Makefile
index 9625a3fbc38a582e10a311e67ac2b4bd7114c232..e0a77e8430b0b0a00b22d7e4eabe0dcf80c4391e 100644 (file)
--- a/testsuite/tests/typing-unboxed-types/Makefile
+++ b/testsuite/tests/typing-unboxed-types/Makefile
@@ -1,3 +1,21 @@
+newdefault: test.ml.reference
+       @$(MAKE) default
+
 BASEDIR=../..
 include $(BASEDIR)/makefiles/Makefile.toplevel
 include $(BASEDIR)/makefiles/Makefile.common
+
+GENERATED_SOURCES = test.ml.reference *.flat-float
+
+ifeq "$(FLAT_FLOAT_ARRAY)" "true"
+suffix = -flat
+else
+suffix = -noflat
+endif
+
+test.ml.reference: test.ml.reference$(suffix) $(FLAT_FLOAT_ARRAY).flat-float
+       @cp $< $@
+
+%.flat-float:
+       @rm -f $(GENERATED_SOURCES)
+       @touch $@

diff --git a/testsuite/tests/typing-unboxed-types/test.ml b/testsuite/tests/typing-unboxed-types/test.ml
index 8e0b337bc8a9979920f62cd89510f20ede942cb0..4391fcbbaa96831af00392ff4866427a9bc52524 100644 (file)
--- a/testsuite/tests/typing-unboxed-types/test.ml
+++ b/testsuite/tests/typing-unboxed-types/test.ml
@@ -154,3 +154,10 @@ type 'a t = T : 'a s -> 'a t [@@unboxed];;
 type _ s = S : 'a t -> _ s  [@@unboxed]
  and _ t = T : 'a -> 'a s t
 ;;
+
+
+(* Another corner case *)
+type 'a s
+type ('a, 'p) t = private 'a s
+type 'a packed = T : ('a, _) t -> 'a packed [@@unboxed]
+;;

diff --git a/testsuite/tests/typing-unboxed-types/test.ml.reference b/testsuite/tests/typing-unboxed-types/test.ml.reference
deleted file mode 100644 (file)
index 10a118d..0000000
--- a/testsuite/tests/typing-unboxed-types/test.ml.reference
+++ /dev/null
@@ -1,203 +0,0 @@
-
-#       type t1 = A of string [@@unboxed]
-#       - : bool = true
-#     type t2 = { f : string; } [@@unboxed]
-#       - : bool = true
-#     type t3 = B of { g : string; } [@@unboxed]
-#       - : bool = true
-#     Characters 29-58:
-  type t4 = C [@@ocaml.unboxed];;  (* no argument *)
-  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This type cannot be unboxed because its constructor has no argument.
-# Characters 0-45:
-  type t5 = D of int * string [@@ocaml.unboxed];; (* more than one argument *)
-  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This type cannot be unboxed because
-       its constructor has more than one argument.
-# Characters 0-33:
-  type t5 = E | F [@@ocaml.unboxed];;          (* more than one constructor *)
-  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This type cannot be unboxed because it has more than one constructor.
-# Characters 0-40:
-  type t6 = G of int | H [@@ocaml.unboxed];;
-  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This type cannot be unboxed because it has more than one constructor.
-# Characters 0-51:
-  type t7 = I of string | J of bool [@@ocaml.unboxed];;
-  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This type cannot be unboxed because it has more than one constructor.
-#   Characters 1-50:
-  type t8 = { h : bool; i : int } [@@ocaml.unboxed];;  (* more than one field *)
-  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This type cannot be unboxed because it has more than one field.
-# Characters 0-56:
-  type t9 = K of { j : string; l : int } [@@ocaml.unboxed];;
-  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This type cannot be unboxed because
-       its constructor has more than one argument.
-#     type t10 = A of t10 [@@unboxed]
-# Characters 12-15:
-  let rec x = A x;;
-              ^^^
-Error: This kind of expression is not allowed as right-hand side of `let rec'
-#             Characters 121-172:
-  ......struct
-    type t = A of string [@@ocaml.unboxed]
-  end..
-Error: Signature mismatch:
-       Modules do not match:
-         sig type t = A of string [@@unboxed] end
-       is not included in
-         sig type t = A of string end
-       Type declarations do not match:
-         type t = A of string [@@unboxed]
-       is not included in
-         type t = A of string
-       Their internal representations differ:
-       the first declaration uses unboxed representation.
-#           Characters 63-96:
-  ......struct
-    type t = A of string
-  end..
-Error: Signature mismatch:
-       Modules do not match:
-         sig type t = A of string end
-       is not included in
-         sig type t = A of string [@@unboxed] end
-       Type declarations do not match:
-         type t = A of string
-       is not included in
-         type t = A of string [@@unboxed]
-       Their internal representations differ:
-       the second declaration uses unboxed representation.
-#           Characters 48-102:
-  ......struct
-    type t = { f : string } [@@ocaml.unboxed]
-  end..
-Error: Signature mismatch:
-       Modules do not match:
-         sig type t = { f : string; } [@@unboxed] end
-       is not included in
-         sig type t = { f : string; } end
-       Type declarations do not match:
-         type t = { f : string; } [@@unboxed]
-       is not included in
-         type t = { f : string; }
-       Their internal representations differ:
-       the first declaration uses unboxed representation.
-#           Characters 66-102:
-  ......struct
-    type t = { f : string }
-  end..
-Error: Signature mismatch:
-       Modules do not match:
-         sig type t = { f : string; } end
-       is not included in
-         sig type t = { f : string; } [@@unboxed] end
-       Type declarations do not match:
-         type t = { f : string; }
-       is not included in
-         type t = { f : string; } [@@unboxed]
-       Their internal representations differ:
-       the second declaration uses unboxed representation.
-#           Characters 53-112:
-  ......struct
-    type t = A of { f : string } [@@ocaml.unboxed]
-  end..
-Error: Signature mismatch:
-       Modules do not match:
-         sig type t = A of { f : string; } [@@unboxed] end
-       is not included in
-         sig type t = A of { f : string; } end
-       Type declarations do not match:
-         type t = A of { f : string; } [@@unboxed]
-       is not included in
-         type t = A of { f : string; }
-       Their internal representations differ:
-       the first declaration uses unboxed representation.
-#           Characters 71-112:
-  ......struct
-    type t = A of { f : string }
-  end..
-Error: Signature mismatch:
-       Modules do not match:
-         sig type t = A of { f : string; } end
-       is not included in
-         sig type t = A of { f : string; } [@@unboxed] end
-       Type declarations do not match:
-         type t = A of { f : string; }
-       is not included in
-         type t = A of { f : string; } [@@unboxed]
-       Their internal representations differ:
-       the second declaration uses unboxed representation.
-#       type t11 = L of float [@@unboxed]
-#     - : unit = ()
-#       type 'a t12 = M of 'a t12 [@@unboxed]
-# val f : int t12 array -> int t12 = <fun>
-#     type t13 = A : 'a t12 -> t13 [@@unboxed]
-#         type t14
-# type t15 = A of t14 [@@unboxed]
-#     type 'a abs
-# Characters 0-45:
-  type t16 = A : _ abs -> t16 [@@ocaml.unboxed];;
-  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This type cannot be unboxed because
-       it might contain both float and non-float values.
-       You should annotate it with [@@ocaml.boxed].
-#     Characters 19-69:
-  type t18 = A : _ list abs -> t18 [@@ocaml.unboxed];;
-  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This type cannot be unboxed because
-       it might contain both float and non-float values.
-       You should annotate it with [@@ocaml.boxed].
-#   *               Characters 176-256:
-  ......struct
-    type t = A of float [@@ocaml.unboxed]
-    type u = { f1 : t; f2 : t }
-  end..
-Error: Signature mismatch:
-       ...
-       Type declarations do not match:
-         type u = { f1 : t; f2 : t; }
-       is not included in
-         type u = { f1 : t; f2 : t; }
-       Their internal representations differ:
-       the first declaration uses unboxed float representation.
-#     * *           module T : sig type t [@@immediate] end
-#   *   type 'a s = S : 'a -> 'a s [@@unboxed]
-# Characters 0-33:
-  type t = T : _ s -> t [@@unboxed];;
-  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This type cannot be unboxed because
-       it might contain both float and non-float values.
-       You should annotate it with [@@ocaml.boxed].
-#     type 'a s = S : 'a -> 'a option s [@@unboxed]
-# Characters 0-33:
-  type t = T : _ s -> t [@@unboxed];;
-  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This type cannot be unboxed because
-       it might contain both float and non-float values.
-       You should annotate it with [@@ocaml.boxed].
-#                 module M :
-  sig type 'a r constraint 'a = unit -> 'b val inj : 'b -> (unit -> 'b) r end
-#     Characters 14-59:
-  type t = T : (unit -> _) M.r -> t [@@unboxed];;
-  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This type cannot be unboxed because
-       it might contain both float and non-float values.
-       You should annotate it with [@@ocaml.boxed].
-#   type 'a s = S : (unit -> 'a) M.r -> 'a option s [@@unboxed]
-#     Characters 14-47:
-  type t = T : _ s -> t [@@unboxed];;
-  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This type cannot be unboxed because
-       it might contain both float and non-float values.
-       You should annotate it with [@@ocaml.boxed].
-#     type 'a t = T : 'a s -> 'a t [@@unboxed]
-#           Characters 42-81:
-  type _ s = S : 'a t -> _ s  [@@unboxed]
-  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This type cannot be unboxed because
-       it might contain both float and non-float values.
-       You should annotate it with [@@ocaml.boxed].
-# 

diff --git a/testsuite/tests/typing-unboxed-types/test.ml.reference-flat b/testsuite/tests/typing-unboxed-types/test.ml.reference-flat
new file mode 100644 (file)
index 0000000..f6d6aaa
--- /dev/null
+++ b/testsuite/tests/typing-unboxed-types/test.ml.reference-flat
@@ -0,0 +1,206 @@
+
+#       type t1 = A of string [@@unboxed]
+#       - : bool = true
+#     type t2 = { f : string; } [@@unboxed]
+#       - : bool = true
+#     type t3 = B of { g : string; } [@@unboxed]
+#       - : bool = true
+#     Characters 29-58:
+  type t4 = C [@@ocaml.unboxed];;  (* no argument *)
+  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This type cannot be unboxed because its constructor has no argument.
+# Characters 0-45:
+  type t5 = D of int * string [@@ocaml.unboxed];; (* more than one argument *)
+  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This type cannot be unboxed because
+       its constructor has more than one argument.
+# Characters 0-33:
+  type t5 = E | F [@@ocaml.unboxed];;          (* more than one constructor *)
+  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This type cannot be unboxed because it has more than one constructor.
+# Characters 0-40:
+  type t6 = G of int | H [@@ocaml.unboxed];;
+  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This type cannot be unboxed because it has more than one constructor.
+# Characters 0-51:
+  type t7 = I of string | J of bool [@@ocaml.unboxed];;
+  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This type cannot be unboxed because it has more than one constructor.
+#   Characters 1-50:
+  type t8 = { h : bool; i : int } [@@ocaml.unboxed];;  (* more than one field *)
+  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This type cannot be unboxed because it has more than one field.
+# Characters 0-56:
+  type t9 = K of { j : string; l : int } [@@ocaml.unboxed];;
+  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This type cannot be unboxed because
+       its constructor has more than one argument.
+#     type t10 = A of t10 [@@unboxed]
+# Characters 12-15:
+  let rec x = A x;;
+              ^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+#             Characters 121-172:
+  ......struct
+    type t = A of string [@@ocaml.unboxed]
+  end..
+Error: Signature mismatch:
+       Modules do not match:
+         sig type t = A of string [@@unboxed] end
+       is not included in
+         sig type t = A of string end
+       Type declarations do not match:
+         type t = A of string [@@unboxed]
+       is not included in
+         type t = A of string
+       Their internal representations differ:
+       the first declaration uses unboxed representation.
+#           Characters 63-96:
+  ......struct
+    type t = A of string
+  end..
+Error: Signature mismatch:
+       Modules do not match:
+         sig type t = A of string end
+       is not included in
+         sig type t = A of string [@@unboxed] end
+       Type declarations do not match:
+         type t = A of string
+       is not included in
+         type t = A of string [@@unboxed]
+       Their internal representations differ:
+       the second declaration uses unboxed representation.
+#           Characters 48-102:
+  ......struct
+    type t = { f : string } [@@ocaml.unboxed]
+  end..
+Error: Signature mismatch:
+       Modules do not match:
+         sig type t = { f : string; } [@@unboxed] end
+       is not included in
+         sig type t = { f : string; } end
+       Type declarations do not match:
+         type t = { f : string; } [@@unboxed]
+       is not included in
+         type t = { f : string; }
+       Their internal representations differ:
+       the first declaration uses unboxed representation.
+#           Characters 66-102:
+  ......struct
+    type t = { f : string }
+  end..
+Error: Signature mismatch:
+       Modules do not match:
+         sig type t = { f : string; } end
+       is not included in
+         sig type t = { f : string; } [@@unboxed] end
+       Type declarations do not match:
+         type t = { f : string; }
+       is not included in
+         type t = { f : string; } [@@unboxed]
+       Their internal representations differ:
+       the second declaration uses unboxed representation.
+#           Characters 53-112:
+  ......struct
+    type t = A of { f : string } [@@ocaml.unboxed]
+  end..
+Error: Signature mismatch:
+       Modules do not match:
+         sig type t = A of { f : string; } [@@unboxed] end
+       is not included in
+         sig type t = A of { f : string; } end
+       Type declarations do not match:
+         type t = A of { f : string; } [@@unboxed]
+       is not included in
+         type t = A of { f : string; }
+       Their internal representations differ:
+       the first declaration uses unboxed representation.
+#           Characters 71-112:
+  ......struct
+    type t = A of { f : string }
+  end..
+Error: Signature mismatch:
+       Modules do not match:
+         sig type t = A of { f : string; } end
+       is not included in
+         sig type t = A of { f : string; } [@@unboxed] end
+       Type declarations do not match:
+         type t = A of { f : string; }
+       is not included in
+         type t = A of { f : string; } [@@unboxed]
+       Their internal representations differ:
+       the second declaration uses unboxed representation.
+#       type t11 = L of float [@@unboxed]
+#     - : unit = ()
+#       type 'a t12 = M of 'a t12 [@@unboxed]
+# val f : int t12 array -> int t12 = <fun>
+#     type t13 = A : 'a t12 -> t13 [@@unboxed]
+#         type t14
+# type t15 = A of t14 [@@unboxed]
+#     type 'a abs
+# Characters 0-45:
+  type t16 = A : _ abs -> t16 [@@ocaml.unboxed];;
+  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This type cannot be unboxed because
+       it might contain both float and non-float values.
+       You should annotate it with [@@ocaml.boxed].
+#     Characters 19-69:
+  type t18 = A : _ list abs -> t18 [@@ocaml.unboxed];;
+  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This type cannot be unboxed because
+       it might contain both float and non-float values.
+       You should annotate it with [@@ocaml.boxed].
+#   *               Characters 176-256:
+  ......struct
+    type t = A of float [@@ocaml.unboxed]
+    type u = { f1 : t; f2 : t }
+  end..
+Error: Signature mismatch:
+       ...
+       Type declarations do not match:
+         type u = { f1 : t; f2 : t; }
+       is not included in
+         type u = { f1 : t; f2 : t; }
+       Their internal representations differ:
+       the first declaration uses unboxed float representation.
+#     * *           module T : sig type t [@@immediate] end
+#   *   type 'a s = S : 'a -> 'a s [@@unboxed]
+# Characters 0-33:
+  type t = T : _ s -> t [@@unboxed];;
+  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This type cannot be unboxed because
+       it might contain both float and non-float values.
+       You should annotate it with [@@ocaml.boxed].
+#     type 'a s = S : 'a -> 'a option s [@@unboxed]
+# Characters 0-33:
+  type t = T : _ s -> t [@@unboxed];;
+  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This type cannot be unboxed because
+       it might contain both float and non-float values.
+       You should annotate it with [@@ocaml.boxed].
+#                 module M :
+  sig type 'a r constraint 'a = unit -> 'b val inj : 'b -> (unit -> 'b) r end
+#     Characters 14-59:
+  type t = T : (unit -> _) M.r -> t [@@unboxed];;
+  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This type cannot be unboxed because
+       it might contain both float and non-float values.
+       You should annotate it with [@@ocaml.boxed].
+#   type 'a s = S : (unit -> 'a) M.r -> 'a option s [@@unboxed]
+#     Characters 14-47:
+  type t = T : _ s -> t [@@unboxed];;
+  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This type cannot be unboxed because
+       it might contain both float and non-float values.
+       You should annotate it with [@@ocaml.boxed].
+#     type 'a t = T : 'a s -> 'a t [@@unboxed]
+#           Characters 42-81:
+  type _ s = S : 'a t -> _ s  [@@unboxed]
+  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This type cannot be unboxed because
+       it might contain both float and non-float values.
+       You should annotate it with [@@ocaml.boxed].
+#             type 'a s
+type ('a, 'p) t = private 'a s
+type 'a packed = T : ('a, 'b) t -> 'a packed [@@unboxed]
+# 

diff --git a/testsuite/tests/typing-unboxed-types/test.ml.reference-noflat b/testsuite/tests/typing-unboxed-types/test.ml.reference-noflat
new file mode 100644 (file)
index 0000000..73c03fd
--- /dev/null
+++ b/testsuite/tests/typing-unboxed-types/test.ml.reference-noflat
@@ -0,0 +1,172 @@
+
+#       type t1 = A of string [@@unboxed]
+#       - : bool = true
+#     type t2 = { f : string; } [@@unboxed]
+#       - : bool = true
+#     type t3 = B of { g : string; } [@@unboxed]
+#       - : bool = true
+#     Characters 29-58:
+  type t4 = C [@@ocaml.unboxed];;  (* no argument *)
+  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This type cannot be unboxed because its constructor has no argument.
+# Characters 0-45:
+  type t5 = D of int * string [@@ocaml.unboxed];; (* more than one argument *)
+  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This type cannot be unboxed because
+       its constructor has more than one argument.
+# Characters 0-33:
+  type t5 = E | F [@@ocaml.unboxed];;          (* more than one constructor *)
+  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This type cannot be unboxed because it has more than one constructor.
+# Characters 0-40:
+  type t6 = G of int | H [@@ocaml.unboxed];;
+  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This type cannot be unboxed because it has more than one constructor.
+# Characters 0-51:
+  type t7 = I of string | J of bool [@@ocaml.unboxed];;
+  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This type cannot be unboxed because it has more than one constructor.
+#   Characters 1-50:
+  type t8 = { h : bool; i : int } [@@ocaml.unboxed];;  (* more than one field *)
+  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This type cannot be unboxed because it has more than one field.
+# Characters 0-56:
+  type t9 = K of { j : string; l : int } [@@ocaml.unboxed];;
+  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This type cannot be unboxed because
+       its constructor has more than one argument.
+#     type t10 = A of t10 [@@unboxed]
+# Characters 12-15:
+  let rec x = A x;;
+              ^^^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+#             Characters 121-172:
+  ......struct
+    type t = A of string [@@ocaml.unboxed]
+  end..
+Error: Signature mismatch:
+       Modules do not match:
+         sig type t = A of string [@@unboxed] end
+       is not included in
+         sig type t = A of string end
+       Type declarations do not match:
+         type t = A of string [@@unboxed]
+       is not included in
+         type t = A of string
+       Their internal representations differ:
+       the first declaration uses unboxed representation.
+#           Characters 63-96:
+  ......struct
+    type t = A of string
+  end..
+Error: Signature mismatch:
+       Modules do not match:
+         sig type t = A of string end
+       is not included in
+         sig type t = A of string [@@unboxed] end
+       Type declarations do not match:
+         type t = A of string
+       is not included in
+         type t = A of string [@@unboxed]
+       Their internal representations differ:
+       the second declaration uses unboxed representation.
+#           Characters 48-102:
+  ......struct
+    type t = { f : string } [@@ocaml.unboxed]
+  end..
+Error: Signature mismatch:
+       Modules do not match:
+         sig type t = { f : string; } [@@unboxed] end
+       is not included in
+         sig type t = { f : string; } end
+       Type declarations do not match:
+         type t = { f : string; } [@@unboxed]
+       is not included in
+         type t = { f : string; }
+       Their internal representations differ:
+       the first declaration uses unboxed representation.
+#           Characters 66-102:
+  ......struct
+    type t = { f : string }
+  end..
+Error: Signature mismatch:
+       Modules do not match:
+         sig type t = { f : string; } end
+       is not included in
+         sig type t = { f : string; } [@@unboxed] end
+       Type declarations do not match:
+         type t = { f : string; }
+       is not included in
+         type t = { f : string; } [@@unboxed]
+       Their internal representations differ:
+       the second declaration uses unboxed representation.
+#           Characters 53-112:
+  ......struct
+    type t = A of { f : string } [@@ocaml.unboxed]
+  end..
+Error: Signature mismatch:
+       Modules do not match:
+         sig type t = A of { f : string; } [@@unboxed] end
+       is not included in
+         sig type t = A of { f : string; } end
+       Type declarations do not match:
+         type t = A of { f : string; } [@@unboxed]
+       is not included in
+         type t = A of { f : string; }
+       Their internal representations differ:
+       the first declaration uses unboxed representation.
+#           Characters 71-112:
+  ......struct
+    type t = A of { f : string }
+  end..
+Error: Signature mismatch:
+       Modules do not match:
+         sig type t = A of { f : string; } end
+       is not included in
+         sig type t = A of { f : string; } [@@unboxed] end
+       Type declarations do not match:
+         type t = A of { f : string; }
+       is not included in
+         type t = A of { f : string; } [@@unboxed]
+       Their internal representations differ:
+       the second declaration uses unboxed representation.
+#       type t11 = L of float [@@unboxed]
+#     - : unit = ()
+#       type 'a t12 = M of 'a t12 [@@unboxed]
+# val f : int t12 array -> int t12 = <fun>
+#     type t13 = A : 'a t12 -> t13 [@@unboxed]
+#         type t14
+# type t15 = A of t14 [@@unboxed]
+#     type 'a abs
+# type t16 = A : 'a abs -> t16 [@@unboxed]
+#     type t18 = A : 'a list abs -> t18 [@@unboxed]
+#   *               Characters 176-256:
+  ......struct
+    type t = A of float [@@ocaml.unboxed]
+    type u = { f1 : t; f2 : t }
+  end..
+Error: Signature mismatch:
+       ...
+       Type declarations do not match:
+         type u = { f1 : t; f2 : t; }
+       is not included in
+         type u = { f1 : t; f2 : t; }
+       Their internal representations differ:
+       the first declaration uses unboxed float representation.
+#     * *           module T : sig type t [@@immediate] end
+#   *   type 'a s = S : 'a -> 'a s [@@unboxed]
+# type t = T : 'a s -> t [@@unboxed]
+#     type 'a s = S : 'a -> 'a option s [@@unboxed]
+# type t = T : 'a s -> t [@@unboxed]
+#                 module M :
+  sig type 'a r constraint 'a = unit -> 'b val inj : 'b -> (unit -> 'b) r end
+#     type t = T : (unit -> 'a) M.r -> t [@@unboxed]
+#   type 'a s = S : (unit -> 'a) M.r -> 'a option s [@@unboxed]
+#     type t = T : 'a s -> t [@@unboxed]
+#     type 'a t = T : 'a s -> 'a t [@@unboxed]
+#           type _ s = S : 'a t -> 'b s [@@unboxed]
+and _ t = T : 'a -> 'a s t
+#             type 'a s
+type ('a, 'p) t = private 'a s
+type 'a packed = T : ('a, 'b) t -> 'a packed [@@unboxed]
+# 

diff --git a/testsuite/tests/typing-warnings/pr6587.ml b/testsuite/tests/typing-warnings/pr6587.ml
new file mode 100644 (file)
index 0000000..ec51f69
--- /dev/null
+++ b/testsuite/tests/typing-warnings/pr6587.ml
@@ -0,0 +1,13 @@
+
+module A: sig val f: fpclass -> fpclass end =
+  struct
+    let f _ = FP_normal
+  end;;
+
+type fpclass = A ;;
+
+module B: sig val f: fpclass -> fpclass end =
+  struct
+    let f A = FP_normal
+  end
+    ;;

diff --git a/testsuite/tests/typing-warnings/pr6587.ml.reference b/testsuite/tests/typing-warnings/pr6587.ml.reference
new file mode 100644 (file)
index 0000000..81286b4
--- /dev/null
+++ b/testsuite/tests/typing-warnings/pr6587.ml.reference
@@ -0,0 +1,17 @@
+
+#         module A : sig val f : fpclass -> fpclass end
+#   type fpclass = A
+#           Characters 49-85:
+  ..struct
+      let f A = FP_normal
+    end
+Error: Signature mismatch:
+       Modules do not match:
+         sig val f : fpclass -> Pervasives.fpclass end
+       is not included in
+         sig val f : fpclass -> fpclass end
+       Values do not match:
+         val f : fpclass -> Pervasives.fpclass
+       is not included in
+         val f : fpclass -> fpclass
+# 

diff --git a/testsuite/tests/typing-warnings/pr7261.ml b/testsuite/tests/typing-warnings/pr7261.ml
new file mode 100644 (file)
index 0000000..aa2c5bd
--- /dev/null
+++ b/testsuite/tests/typing-warnings/pr7261.ml
@@ -0,0 +1,4 @@
+type foo =
+    Foo: [> `Bla ] as 'b ) * 'b -> foo;;
+type foo =
+    Foo: 'b * 'b -> foo constraint 'b = [> `Bla ];;

diff --git a/testsuite/tests/typing-warnings/pr7261.ml.reference b/testsuite/tests/typing-warnings/pr7261.ml.reference
new file mode 100644 (file)
index 0000000..cc66d88
--- /dev/null
+++ b/testsuite/tests/typing-warnings/pr7261.ml.reference
@@ -0,0 +1,11 @@
+
+#   Characters 30-32:
+      Foo: [> `Bla ] as 'b ) * 'b -> foo;;
+                     ^^
+Error: Syntax error
+#   Characters 46-60:
+      Foo: 'b * 'b -> foo constraint 'b = [> `Bla ];;
+                                     ^^^^^^^^^^^^^^
+Warning 62: Type constraints do not apply to GADT cases of variant types.
+type foo = Foo : 'b * 'b -> foo
+# 

diff --git a/testsuite/tests/typing-warnings/pr7553.ml b/testsuite/tests/typing-warnings/pr7553.ml
new file mode 100644 (file)
index 0000000..8e526d6
--- /dev/null
+++ b/testsuite/tests/typing-warnings/pr7553.ml
@@ -0,0 +1,20 @@
+module A = struct type foo end;;
+
+module rec B : sig
+  open A
+  type bar = Bar of foo
+end = B;;
+
+module rec C : sig
+  open A
+end = C;;
+
+module rec D : sig
+  module M : module type of struct
+    module X : sig end = struct
+      open A
+      let None = None
+    end
+  end
+end = D;;
+

diff --git a/testsuite/tests/typing-warnings/pr7553.ml.reference b/testsuite/tests/typing-warnings/pr7553.ml.reference
new file mode 100644 (file)
index 0000000..ead6b02
--- /dev/null
+++ b/testsuite/tests/typing-warnings/pr7553.ml.reference
@@ -0,0 +1,20 @@
+
+# module A : sig type foo end
+#         module rec B : sig type bar = Bar of A.foo end
+#       Characters 22-28:
+    open A
+    ^^^^^^
+Warning 33: unused open A.
+module rec C : sig  end
+#                 Characters 110-114:
+        let None = None
+            ^^^^
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+Some _
+Characters 93-99:
+        open A
+        ^^^^^^
+Warning 33: unused open A.
+module rec D : sig module M : sig module X : sig  end end end
+#   

diff --git a/testsuite/tests/unboxed-primitive-args/test_common.c b/testsuite/tests/unboxed-primitive-args/test_common.c
index 8fe2765f7c0c53752045c656079dc466a106359e..c6b873c514717f413b97ba7ed016b5644ee79eb4 100644 (file)
--- a/testsuite/tests/unboxed-primitive-args/test_common.c
+++ b/testsuite/tests/unboxed-primitive-args/test_common.c
@@ -14,7 +14,7 @@
 /**************************************************************************/
 
 #include <caml/mlvalues.h>
-#include <bigarray.h>
+#include <caml/bigarray.h>
 
 char *ocaml_buffer;
 char *c_buffer;

diff --git a/testsuite/tests/unwind/Makefile b/testsuite/tests/unwind/Makefile
index 614808b00240f1fb1c8239f49c4dfee59a231b64..ad88faf93616ba8f5a1ff404ca438253360d7668 100644 (file)
--- a/testsuite/tests/unwind/Makefile
+++ b/testsuite/tests/unwind/Makefile
@@ -31,7 +31,7 @@ unwind_test:
        @$(OCAMLOPT) -c -opaque mylib.mli
        @$(OCAMLOPT) -c driver.ml
        @$(OCAMLOPT) -c mylib.ml
-       @$(OCAMLOPT) -ccopt "-I$(CTOPDIR)/byterun" -c stack_walker.c
+       @$(OCAMLOPT) -ccopt -I -ccopt $(CTOPDIR)/byterun -c stack_walker.c
        @$(OCAMLOPT) -cclib -Wl,-keep_dwarf_unwind -o unwind_test mylib.cmx \
                     driver.cmx stack_walker.o
 

diff --git a/testsuite/tests/warnings/Makefile b/testsuite/tests/warnings/Makefile
index 7bf93ad261996619211ade3d52a7e02547e77f1b..794e658b750c7b7b5191df4078c5e34db8174c10 100644 (file)
--- a/testsuite/tests/warnings/Makefile
+++ b/testsuite/tests/warnings/Makefile
@@ -19,6 +19,7 @@ FLAGS=-w A
 run-all:
        @$(OCAMLC) $(FLAGS) -c deprecated_module.mli
        @$(OCAMLC) $(FLAGS) -c module_without_cmx.mli
+       @$(OCAMLC) $(FLAGS) -c w32.mli
        @$(OCAMLC) $(FLAGS) -c w60.mli
        @for file in *.ml; do \
          printf " ... testing '$$file':"; \

diff --git a/testsuite/tests/warnings/deprecated_module_assigment.ml b/testsuite/tests/warnings/deprecated_module_assigment.ml
new file mode 100755 (executable)
index 0000000..2595637
--- /dev/null
+++ b/testsuite/tests/warnings/deprecated_module_assigment.ml
@@ -0,0 +1,78 @@
+(* Values *)
+
+module X : sig
+  val x : int [@@deprecated "DEPRECATED"]
+end = struct
+  let x = 7
+end
+
+module Y : sig val x : int end = X
+
+module Z : sig val x : int [@@deprecated "..."] end = X
+
+module F(A : sig val x : int end) = struct end
+
+module B = F(X)
+
+
+
+module XX = struct let x = 7 end
+module YY : sig val x : int [@@deprecated "..."] end = XX
+
+
+(* Constructors *)
+
+module CSTR : sig type t = A | B end = struct type t = A [@deprecated] | B end
+
+module CSTR1 = struct
+  type t = A [@deprecated] | B
+  type s = t = A | B
+end
+
+
+(* Fields *)
+
+module FIELD :
+sig type t = {mutable x: int} end =
+struct type t = {mutable x: int [@deprecated_mutable]} end
+
+module FIELD1 = struct
+  type t = {mutable x: int [@deprecated_mutable]}
+  type s = t = {mutable x: int}
+end
+
+(* Types *)
+
+module TYPE : sig type t = int end = struct type t = int [@@deprecated] end
+
+(* Class, class types *)
+
+module CL :
+sig class c : object end end =
+struct class c = object end [@@deprecated "FOO"] end
+
+module CLT :
+sig class type c = object end end =
+struct class type c = object end [@@deprecated "FOO"] end
+
+
+(* Module types *)
+
+module MT :
+sig module type S = sig end end =
+struct module type S = sig end [@@deprecated "FOO"] end
+
+module MT_OK :
+sig module type S = sig end [@@deprecated] end =
+struct module type S = sig end [@@deprecated "FOO"] end
+
+
+(* Modules *)
+
+module MD :
+sig module M : sig end end =
+struct module M = struct end [@@deprecated "FOO"] end
+
+module MD_OK :
+sig module M : sig end [@@deprecated] end =
+struct module M = struct end [@@deprecated "FOO"] end

diff --git a/testsuite/tests/warnings/deprecated_module_assigment.reference b/testsuite/tests/warnings/deprecated_module_assigment.reference
new file mode 100644 (file)
index 0000000..5df8f12
--- /dev/null
+++ b/testsuite/tests/warnings/deprecated_module_assigment.reference
@@ -0,0 +1,72 @@
+File "deprecated_module_assigment.ml", line 9, characters 33-34:
+Warning 3: deprecated: x
+DEPRECATED
+  File "deprecated_module_assigment.ml", line 4, characters 2-41:
+  Definition
+  File "deprecated_module_assigment.ml", line 9, characters 15-26:
+  Expected signature
+File "deprecated_module_assigment.ml", line 15, characters 13-14:
+Warning 3: deprecated: x
+DEPRECATED
+  File "deprecated_module_assigment.ml", line 4, characters 2-41:
+  Definition
+  File "deprecated_module_assigment.ml", line 13, characters 17-28:
+  Expected signature
+File "deprecated_module_assigment.ml", line 25, characters 39-78:
+Warning 3: deprecated: A
+  File "deprecated_module_assigment.ml", line 25, characters 55-70:
+  Definition
+  File "deprecated_module_assigment.ml", line 25, characters 27-28:
+  Expected signature
+File "deprecated_module_assigment.ml", line 29, characters 2-20:
+Warning 3: deprecated: A
+  File "deprecated_module_assigment.ml", line 28, characters 11-26:
+  Definition
+  File "deprecated_module_assigment.ml", line 29, characters 15-16:
+  Expected signature
+File "deprecated_module_assigment.ml", line 37, characters 0-58:
+Warning 3: deprecated: mutating field x
+  File "deprecated_module_assigment.ml", line 37, characters 17-53:
+  Definition
+  File "deprecated_module_assigment.ml", line 36, characters 14-28:
+  Expected signature
+File "deprecated_module_assigment.ml", line 41, characters 2-31:
+Warning 3: deprecated: mutating field x
+  File "deprecated_module_assigment.ml", line 40, characters 12-48:
+  Definition
+  File "deprecated_module_assigment.ml", line 41, characters 16-30:
+  Expected signature
+File "deprecated_module_assigment.ml", line 46, characters 37-75:
+Warning 3: deprecated: t
+  File "deprecated_module_assigment.ml", line 46, characters 44-71:
+  Definition
+  File "deprecated_module_assigment.ml", line 46, characters 18-30:
+  Expected signature
+File "deprecated_module_assigment.ml", line 52, characters 0-52:
+Warning 3: deprecated: c
+FOO
+  File "deprecated_module_assigment.ml", line 52, characters 7-48:
+  Definition
+  File "deprecated_module_assigment.ml", line 51, characters 4-24:
+  Expected signature
+File "deprecated_module_assigment.ml", line 56, characters 0-57:
+Warning 3: deprecated: c
+FOO
+  File "deprecated_module_assigment.ml", line 56, characters 7-53:
+  Definition
+  File "deprecated_module_assigment.ml", line 55, characters 4-29:
+  Expected signature
+File "deprecated_module_assigment.ml", line 63, characters 0-55:
+Warning 3: deprecated: S
+FOO
+  File "deprecated_module_assigment.ml", line 63, characters 7-51:
+  Definition
+  File "deprecated_module_assigment.ml", line 62, characters 4-27:
+  Expected signature
+File "deprecated_module_assigment.ml", line 74, characters 0-53:
+Warning 3: deprecated: M
+FOO
+  File "deprecated_module_assigment.ml", line 74, characters 7-49:
+  Definition
+  File "deprecated_module_assigment.ml", line 73, characters 4-22:
+  Expected signature

diff --git a/testsuite/tests/warnings/w32.ml b/testsuite/tests/warnings/w32.ml
new file mode 100644 (file)
index 0000000..a3a17d3
--- /dev/null
+++ b/testsuite/tests/warnings/w32.ml
@@ -0,0 +1,47 @@
+(* from MPR#7624 *)
+
+let[@warning "-32"] f x = x
+
+let g x = x
+
+let h x = x
+
+
+(* multiple bindings *)
+
+let[@warning "-32"] i x = x
+and j x = x
+
+let k x = x
+and[@warning "-32"] l x = x
+
+let[@warning "-32"] m x = x
+and n x = x
+
+let o x = x
+and[@warning "-32"] p x = x
+
+
+(* recursive bindings *)
+
+let[@warning "-32"] rec q x = x
+and r x = x
+
+let[@warning "-32"] rec s x = x
+and[@warning "-39"] t x = x
+
+let[@warning "-39"] rec u x = x
+and v x = v x
+
+
+(* disabled then re-enabled warnings *)
+
+module M = struct
+  [@@@warning "-32"]
+  let f x = x
+  let[@warning "+32"] g x = x
+  let[@warning "+32"] h x = x
+  and i x = x
+  let j x = x
+  and[@warning "+32"] k x = x
+end

diff --git a/testsuite/tests/warnings/w32.mli b/testsuite/tests/warnings/w32.mli
new file mode 100644 (file)
index 0000000..199e350
--- /dev/null
+++ b/testsuite/tests/warnings/w32.mli
@@ -0,0 +1,9 @@
+(* from MPR#7624 *)
+
+val g : 'a -> 'a
+
+
+(* multiple bindings *)
+val n : 'a -> 'a
+
+val o : 'a -> 'a

diff --git a/testsuite/tests/warnings/w32.reference b/testsuite/tests/warnings/w32.reference
new file mode 100644 (file)
index 0000000..9040181
--- /dev/null
+++ b/testsuite/tests/warnings/w32.reference
@@ -0,0 +1,26 @@
+File "w32.ml", line 27, characters 24-25:
+Warning 39: unused rec flag.
+File "w32.ml", line 30, characters 24-25:
+Warning 39: unused rec flag.
+File "w32.ml", line 7, characters 4-5:
+Warning 32: unused value h.
+File "w32.ml", line 13, characters 4-5:
+Warning 32: unused value j.
+File "w32.ml", line 15, characters 4-5:
+Warning 32: unused value k.
+File "w32.ml", line 28, characters 4-5:
+Warning 32: unused value r.
+File "w32.ml", line 31, characters 20-21:
+Warning 32: unused value t.
+File "w32.ml", line 33, characters 24-25:
+Warning 32: unused value u.
+File "w32.ml", line 34, characters 4-5:
+Warning 32: unused value v.
+File "w32.ml", line 42, characters 22-23:
+Warning 32: unused value g.
+File "w32.ml", line 43, characters 22-23:
+Warning 32: unused value h.
+File "w32.ml", line 46, characters 22-23:
+Warning 32: unused value k.
+File "w32.ml", line 39, characters 0-174:
+Warning 60: unused module M.

diff --git a/testsuite/tests/warnings/w59.opt_backend.flambda.opt_reference b/testsuite/tests/warnings/w59.opt_backend.flambda.opt_reference
index a7e8b93c976392aa131a17c04bc9cff4ce5e7277..b757eafd158ad373b790eb1ccc9ca687286fc990 100644 (file)
--- a/testsuite/tests/warnings/w59.opt_backend.flambda.opt_reference
+++ b/testsuite/tests/warnings/w59.opt_backend.flambda.opt_reference
@@ -18,27 +18,3 @@ File "w59.opt_backend.ml", line 35, characters 2-7:
 Warning 59: A potential assignment to a non-mutable value was detected 
 in this source file.  Such assignments may generate incorrect code 
 when using Flambda.
-File "w59.opt_backend.ml", line 35, characters 2-7:
-Warning 59: A potential assignment to a non-mutable value was detected 
-in this source file.  Such assignments may generate incorrect code 
-when using Flambda.
-File "w59.opt_backend.ml", line 25, characters 2-43:
-Warning 59: A potential assignment to a non-mutable value was detected 
-in this source file.  Such assignments may generate incorrect code 
-when using Flambda.
-File "w59.opt_backend.ml", line 26, characters 2-43:
-Warning 59: A potential assignment to a non-mutable value was detected 
-in this source file.  Such assignments may generate incorrect code 
-when using Flambda.
-File "w59.opt_backend.ml", line 27, characters 2-43:
-Warning 59: A potential assignment to a non-mutable value was detected 
-in this source file.  Such assignments may generate incorrect code 
-when using Flambda.
-File "w59.opt_backend.ml", line 28, characters 2-43:
-Warning 59: A potential assignment to a non-mutable value was detected 
-in this source file.  Such assignments may generate incorrect code 
-when using Flambda.
-File "w59.opt_backend.ml", line 35, characters 2-7:
-Warning 59: A potential assignment to a non-mutable value was detected 
-in this source file.  Such assignments may generate incorrect code 
-when using Flambda.

diff --git a/testsuite/tests/win-unicode/Makefile b/testsuite/tests/win-unicode/Makefile
new file mode 100644 (file)
index 0000000..bc4adfa
--- /dev/null
+++ b/testsuite/tests/win-unicode/Makefile
@@ -0,0 +1,28 @@
+BASEDIR=../..
+LIBRARIES=unix
+ADD_COMPFLAGS= \
+       -I $(OTOPDIR)/otherlibs/$(UNIXLIBVAR)unix \
+       -strict-sequence -safe-string -w A -warn-error A
+LD_PATH=$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix
+C_FILES=mkfiles
+
+.PHONY: test
+test:
+       @if echo 'let () = exit (if Config.windows_unicode then 0 else 1)' | $(OCAML) -I $(OTOPDIR)/utils config.cmo -stdin; then \
+         $(MAKE) printargv.exe printenv.exe symlink_tests.precheck && \
+         $(MAKE) check; \
+       else \
+         $(MAKE) SKIP=true C_FILES= run-all; \
+       fi
+
+.PHONY: symlink_tests.precheck
+symlink_tests.precheck:
+       @echo 'echo "let () = exit (if Unix.has_symlink () then 0 else 1)" | $(OCAML) $(ADD_COMPFLAGS) unix.cma -stdin' > $@
+
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common
+
+GENERATED_SOURCES=symlink_tests.precheck
+
+%.exe: %.c
+       @$(CC) $(CFLAGS) $(CPPFLAGS) $(LDFLAGS) $(if $(filter msvc,$(CCOMPTYPE)),/Fe$*.exe,-o$*.exe) $*.c

diff --git a/testsuite/tests/win-unicode/exec_tests.ml b/testsuite/tests/win-unicode/exec_tests.ml
new file mode 100755 (executable)
index 0000000..b0aa293
--- /dev/null
+++ b/testsuite/tests/win-unicode/exec_tests.ml
@@ -0,0 +1,63 @@
+let values =
+  [
+    "\xD0\xB2\xD0\xB5\xD1\x80\xD0\xB1\xD0\xBB\xD1\x8E\xD0\xB4\xD1\x8B"; (* "верблюды" *)
+    "\xE9\xAA\x86\xE9\xA9\xBC"; (* "骆驼" *)
+    "\215\167\215\162\215\158\215\156"; (* "קעמל" *)
+    "\216\167\217\136\217\134\217\185"; (* "اونٹ" *)
+  ]
+
+let env0 =
+  List.sort compare (List.mapi (fun i v -> Printf.sprintf "OCAML_UTF8_VAR%d=%s" i v) values)
+
+let split sep s =
+  match String.index s sep with
+  | i ->
+      String.sub s 0 i, String.sub s (i + 1) (String.length s - i - 1)
+  | exception Not_found ->
+      s, ""
+
+let test_environment () =
+  print_endline "test_environment";
+  let vars = List.map (fun s -> fst (split '=' s)) env0 in
+  let f s = List.mem (fst (split '=' s)) vars in
+  let env = List.filter f (Array.to_list (Unix.environment ())) in
+  assert (List.length env0 = List.length env);
+  List.iter2 (fun s1 s2 -> assert (s1 = s2)) env0 env
+
+let test0 () =
+  print_endline "test0";
+  Unix.execve Sys.executable_name [|Sys.executable_name; "1"|] (Array.of_list env0)
+
+let test_argv () =
+  print_endline "test_argv";
+  let argv = match Array.to_list Sys.argv with _ :: _ :: argv -> argv | _ -> assert false in
+  List.iter2 (fun s1 s2 -> assert (s1 = s2)) argv values
+
+let test1 () =
+  print_endline "test1";
+  Unix.execv Sys.executable_name (Array.of_list (Sys.executable_name :: "2" :: values))
+
+let restart = function
+  | 0 -> test0 ()
+  | 1 -> test_environment (); test1 ()
+  | 2 -> test_argv ()
+  | _ -> assert false
+
+let main () =
+  match Array.length Sys.argv with
+  | 1 ->
+      let pid = Unix.create_process Sys.executable_name [|Sys.executable_name; "0"|] Unix.stdin Unix.stdout Unix.stderr in
+      begin match Unix.waitpid [] pid with
+      | _, Unix.WEXITED 0 -> ()
+      | _, (Unix.WEXITED _ | Unix.WSIGNALED _ | Unix.WSTOPPED _) -> failwith "Child process error"
+      end
+  | _ ->
+      restart (int_of_string Sys.argv.(1))
+
+let () =
+  match main () with
+  | () ->
+      Printf.printf "OK\n%!"
+  | exception e ->
+      Printf.printf "BAD: %s\n%!" (Printexc.to_string e);
+      exit 1

diff --git a/testsuite/tests/win-unicode/exec_tests.precheck b/testsuite/tests/win-unicode/exec_tests.precheck
new file mode 100644 (file)
index 0000000..6132b21
--- /dev/null
+++ b/testsuite/tests/win-unicode/exec_tests.precheck
@@ -0,0 +1,3 @@
+# exec_tests.ml disabled because it fails non-deterministically (at least under CI)
+# seems to be a problem redirecting handles
+exit 1

diff --git a/testsuite/tests/win-unicode/exec_tests.reference b/testsuite/tests/win-unicode/exec_tests.reference
new file mode 100644 (file)
index 0000000..5d6e024
--- /dev/null
+++ b/testsuite/tests/win-unicode/exec_tests.reference
@@ -0,0 +1,6 @@
+test0
+OK
+test_environment
+test1
+test_argv
+OK

diff --git a/testsuite/tests/win-unicode/mkfiles.c b/testsuite/tests/win-unicode/mkfiles.c
new file mode 100644 (file)
index 0000000..71eab6e
--- /dev/null
+++ b/testsuite/tests/win-unicode/mkfiles.c
@@ -0,0 +1,38 @@
+#include <assert.h>
+#include <stdlib.h>
+#include <stdio.h>
+#include <string.h>
+
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include <caml/memory.h>
+#include <caml/fail.h>
+
+#include <Windows.h>
+#include <io.h>
+
+/* Returns an OCaml string with the UTF-16 representation of [s], *including* the final (2-byte) NULL */
+CAMLprim value caml_to_utf16(value s)
+{
+  CAMLparam1(s);
+  CAMLlocal1(w);
+  int size;
+  size = MultiByteToWideChar(CP_UTF8, MB_ERR_INVALID_CHARS, String_val(s), caml_string_length(s), NULL, 0);
+  if (size == 0) caml_failwith("Invalid UTF-8");
+  w = caml_alloc_string((size + 1) * sizeof(wchar_t));
+  ((wchar_t *)String_val(w))[size] = 0;
+  size = MultiByteToWideChar(CP_UTF8, 0, String_val(s), caml_string_length(s), (wchar_t *)String_val(w), size);
+  assert(size != 0);
+  CAMLreturn(w);
+}
+
+CAMLprim value caml_create_file(value s, value contents)
+{
+  CAMLparam2(s, contents);
+  FILE * f;
+  f = _wfopen((wchar_t *)String_val(s), _T("w"));
+  if (f == NULL) caml_failwith("fopen failed");
+  fwrite(String_val(contents), 1, caml_string_length(contents), f);
+  fclose(f);
+  CAMLreturn(Val_unit);
+}

diff --git a/testsuite/tests/win-unicode/mltest.ml b/testsuite/tests/win-unicode/mltest.ml
new file mode 100644 (file)
index 0000000..c22f5a7
--- /dev/null
+++ b/testsuite/tests/win-unicode/mltest.ml
@@ -0,0 +1,416 @@
+let total = ref 0
+let failed = ref 0
+let num = ref 0
+
+external to_utf16 : string -> string = "caml_to_utf16"
+external create_file : string -> string -> unit = "caml_create_file"
+
+let foreign_names =
+  List.sort compare
+    [
+      "simple";
+      "\xE4\xBD\xA0\xE5\xA5\xBD"; (* "你好" *)
+      "\x73\xC5\x93\x75\x72"; (* "sœur" *)
+      "e\204\129te\204\129"; (* "été" *)
+    ]
+
+let test_files =
+  List.map (fun s -> s ^ ".txt") foreign_names
+
+let to_create_and_delete_files =
+  [
+    "\xD0\xB2\xD0\xB5\xD1\x80\xD0\xB1\xD0\xBB\xD1\x8E\xD0\xB4\xD1\x8B"; (* "верблюды" *)
+    "\xE9\xAA\x86\xE9\xA9\xBC"; (* "骆驼" *)
+    "\215\167\215\162\215\158\215\156"; (* "קעמל" *)
+    "\216\167\217\136\217\134\217\185"; (* "اونٹ" *)
+    "L\225\186\161c \196\145\195\160"; (* "Lạc đà" *)
+    "\224\176\146\224\176\130\224\176\159\224\177\134"; (* "ఒంటె" *)
+    "\224\174\146\224\174\159\224\175\141\224\174\159\224\174\149\224\
+     \174\174\224\175\141"; (* "ஒட்டகம்" *)
+    "\217\136\216\180\216\170\216\177"; (* "وشتر" *)
+    "\224\164\137\224\164\183\224\165\141\224\164\159\224\165\141\224\
+     \164\176\224\164\131"; (* "उष्ट्रः" *)
+    "\216\167\217\186"; (* "اٺ" *)
+  ]
+
+let rec take n l =
+  if n = 0 then []
+  else List.hd l :: take (n-1) (List.tl l)
+
+let foreign_names2 =
+  take (List.length foreign_names) to_create_and_delete_files
+
+let env0 =
+  List.sort compare (List.mapi (fun i v -> Printf.sprintf "OCAML_UTF8_VAR%d=%s" i v) foreign_names2)
+
+let read_all ic =
+  set_binary_mode_in ic false;
+  let rec loop acc =
+    match input_line ic with
+    | exception End_of_file ->
+        List.rev acc
+    | s ->
+        loop (s :: acc)
+  in
+  loop []
+
+let split sep s =
+  match String.index s sep with
+  | i ->
+      String.sub s 0 i, String.sub s (i+1) (String.length s - i - 1)
+  | exception Not_found ->
+      s, ""
+
+(** WRAPPERS *)
+
+let quote s = "\"" ^ s ^ "\""
+
+let ok _ = "OK"
+
+let unit _ = "()"
+
+let list f l = String.concat " " (List.map f l)
+
+let ell _ = "..."
+
+let file_kind = function
+  | Unix.S_REG -> "S_REG"
+  | Unix.S_DIR -> "S_DIR"
+  | Unix.S_CHR -> "S_CHR"
+  | Unix.S_BLK -> "S_BLK"
+  | Unix.S_LNK -> "S_LNK"
+  | Unix.S_FIFO -> "S_FIFO"
+  | Unix.S_SOCK -> "S_SOCK"
+
+let wrap s f quote_in x quote_out =
+  Printf.printf "%s %s ... " s (quote_in x);
+  match f x with
+  | x ->
+      Printf.printf "%s\n%!" (quote_out x);
+      x
+  | exception e ->
+      Printf.printf "FAILED: %s\n%!" (Printexc.to_string e);
+      raise e
+
+let wrap2 s f quote_in1 quote_in2 x y quote_out =
+  Printf.printf "%s %s %s ... " s (quote_in1 x) (quote_in2 y);
+  match f x y with
+  | x ->
+      Printf.printf "%s\n%!" (quote_out x);
+      x
+  | exception e ->
+      Printf.printf "FAILED: %s\n%!" (Printexc.to_string e);
+      raise e
+
+let getenv s =
+  wrap "Sys.getenv" Sys.getenv quote s quote
+
+let getenvironmentenv s =
+  let get s =
+    let env = Unix.environment () in
+    let rec loop i =
+      if i >= Array.length env then
+        ""
+      else begin
+        let e = env.(i) in
+        let pos = String.index e '=' in
+        if String.sub e 0 pos = s then
+          String.sub e (pos+1) (String.length e - pos - 1)
+        else
+          loop (i+1)
+      end
+    in
+    loop 0
+  in
+  wrap "Unix.environment" get quote s quote
+
+let putenv s x =
+  wrap2 "Unix.putenv" Unix.putenv quote quote s x ok
+
+let sys_rename s x =
+  wrap2 "Sys.rename" Sys.rename quote quote s x ok
+
+let unix_rename s x =
+  wrap2 "Unix.rename" Unix.rename quote quote s x ok
+
+let mkdir s mode =
+  wrap2 "Unix.mkdir" Unix.mkdir quote string_of_int s mode ok
+
+let file_exists s =
+  wrap "Sys.file_exists" Sys.file_exists quote s string_of_bool
+
+let is_directory s =
+  wrap "Sys.is_directory" Sys.is_directory quote s string_of_bool
+
+let unix_chdir s =
+  wrap "Unix.chdir" Unix.chdir quote s ok
+
+let sys_chdir s =
+  wrap "Sys.chdir" Sys.chdir quote s ok
+
+let unix_getcwd () =
+  wrap "Unix.getcwd" (fun s -> Filename.basename (Unix.getcwd s)) unit () quote
+
+let sys_getcwd () =
+  wrap "Sys.getcwd" (fun s -> Filename.basename (Sys.getcwd s)) unit () quote
+
+let rmdir s =
+  wrap "Unix.rmdir" Unix.rmdir quote s ok
+
+let remove s =
+  wrap "Sys.remove" Sys.remove quote s ok
+
+let unlink s =
+  wrap "Unix.unlink" Unix.unlink quote s ok
+
+let stat s =
+  let f s = (Unix.stat s).Unix.st_kind in
+  wrap "Unix.stat" f quote s file_kind
+
+let lstat s =
+  let f s = (Unix.lstat s).Unix.st_kind in
+  wrap "Unix.lstat" f quote s file_kind
+
+let large_stat s =
+  let f s = (Unix.LargeFile.stat s).Unix.LargeFile.st_kind in
+  wrap "Unix.LargeFile.stat" f quote s file_kind
+
+let large_lstat s =
+  let f s = (Unix.LargeFile.lstat s).Unix.LargeFile.st_kind in
+  wrap "Unix.LargeFile.lstat" f quote s file_kind
+
+let access s =
+  let f s = Unix.access s [Unix.F_OK] in
+  wrap "Unix.access" f quote s ok
+
+let unix_readdir f s =
+  let f s =
+    let h = Unix.opendir s in
+    let rec loop acc =
+      match Unix.readdir h with
+      | s ->
+          if f s then
+            loop (s :: acc)
+          else
+            loop acc
+      | exception End_of_file ->
+          Unix.closedir h;
+          List.sort compare acc
+    in
+    loop []
+  in
+  wrap "Unix.{opendir,readdir}" f quote s (list quote)
+
+let sys_readdir f s =
+  let f s =
+    let entries = Sys.readdir s in
+    List.sort compare (List.filter f (Array.to_list entries))
+  in
+  wrap "Sys.readdir" f quote s (list quote)
+
+let open_in s =
+  wrap "open_in" open_in quote s ok
+
+let open_out s =
+  wrap "open_out" open_out quote s ok
+
+let open_process_in cmdline =
+  let f cmdline =
+    let ic as proc = Unix.open_process_in cmdline in
+    let l = List.tl (read_all ic) in
+    ignore (Unix.close_process_in proc);
+    l
+  in
+  wrap "Unix.open_process_in" f ell cmdline (list quote)
+
+let open_process_full filter cmdline env =
+  let f cmdline env =
+    let (ic, _, _) as proc = Unix.open_process_full cmdline (Array.of_list env) in
+    let l = read_all ic in
+    ignore (Unix.close_process_full proc);
+    List.sort compare (List.filter filter l)
+  in
+  wrap2 "Unix.open_process_full" f ell (list quote) cmdline env (list quote)
+
+(** TESTS *)
+
+let title s =
+  let s = Printf.sprintf "Testing %s" s in
+  let u = String.make (String.length s) '=' in
+  Printf.printf "\n#%02d. %s\n%s\n\n%!" !num s u
+
+let expect_gen quote x b =
+  total := !total + 1;
+  if x <> b then begin
+    Printf.printf "** ERROR: EXPECTED RESULT = %s ACTUAL RESULT = %s\n%!" (quote x) (quote b);
+    failed := !failed + 1
+  end
+
+let expect_file_kind x b =
+  expect_gen file_kind x b
+
+let expect_string x s =
+  expect_gen quote x s
+
+let expect_bool x b =
+  expect_gen string_of_bool x b
+
+let expect_int x b =
+  expect_gen string_of_int x b
+
+let test_readdir readdir =
+  let filter s = List.mem s test_files in
+  let entries = readdir filter Filename.current_dir_name in
+  let entries = List.filter (fun s -> Filename.check_suffix s ".txt") entries in
+  expect_int (List.length entries) (List.length test_files);
+  List.iter2 expect_string entries test_files
+
+let test_open_in () =
+  let dump_file s =
+    let ic = open_in s in
+    let l = input_line ic in
+    close_in ic;
+    expect_string s l
+  in
+  let filter s = List.mem s test_files in
+  let files = sys_readdir filter Filename.current_dir_name in
+  List.iter dump_file files
+
+let test_getenv () =
+  let doit key s =
+    putenv key s;
+    expect_string (getenv key) s;
+    expect_string (getenvironmentenv key) s
+  in
+  List.iter2 doit foreign_names foreign_names2
+
+let test_mkdir () =
+  let doit s =
+    mkdir s 0o755;
+    expect_bool (file_exists s) true;
+    expect_bool (is_directory s) true
+  in
+  List.iter doit foreign_names
+
+let test_chdir chdir getcwd =
+  let doit s =
+    chdir s;
+    expect_string (getcwd ()) s;
+    chdir Filename.parent_dir_name
+  in
+  List.iter doit foreign_names
+
+let test_rmdir () =
+  let doit s =
+    rmdir s;
+    expect_bool (file_exists s) false
+  in
+  List.iter doit foreign_names
+
+let test_stat () =
+  let doit s =
+    expect_file_kind (stat s) Unix.S_REG;
+    expect_file_kind (lstat s) Unix.S_REG;
+    expect_file_kind (large_stat s) Unix.S_REG;
+    expect_file_kind (large_lstat s) Unix.S_REG
+  in
+  List.iter doit to_create_and_delete_files
+
+let test_access () =
+  List.iter access to_create_and_delete_files
+
+let test_rename rename =
+  let doit s =
+    let s' = s ^ "-1" in
+    rename s s';
+    expect_bool (file_exists s) false;
+    expect_bool (file_exists s') true;
+    rename s' s;
+    expect_bool (file_exists s) true;
+    expect_bool (file_exists s') false
+  in
+  List.iter doit to_create_and_delete_files
+
+let test_open_out () =
+  let doit s =
+    let oc = open_out s in
+    Printf.fprintf oc "Hello, %s\n" s;
+    close_out oc
+  in
+  List.iter doit to_create_and_delete_files
+
+let test_file_exists expected =
+  let doit s =
+    expect_bool (file_exists s) expected;
+  in
+  List.iter doit to_create_and_delete_files
+
+let test_remove remove =
+  let doit s =
+    remove s;
+    expect_bool (file_exists s) false
+  in
+  List.iter doit to_create_and_delete_files
+
+let test_open_process_in () =
+  let cmdline =
+    String.concat " " (Filename.concat Filename.current_dir_name "printargv.exe" :: List.map Filename.quote to_create_and_delete_files)
+  in
+  let l = open_process_in cmdline in
+  List.iter2 expect_string l to_create_and_delete_files
+
+let test_open_process_full () =
+  let vars = List.map (fun s -> fst (split '=' s)) env0 in
+  let filter s = List.mem (fst (split '=' s)) vars in
+  let l = open_process_full filter (Filename.concat Filename.current_dir_name "printenv.exe") env0 in
+  expect_int (List.length env0) (List.length l);
+  List.iter2 expect_string env0 l
+
+(* Order matters *)
+let tests =
+  [|
+    "test_readdir unix_readdir", (fun () -> test_readdir unix_readdir);
+    "test_readdir sys_readdir", (fun () -> test_readdir sys_readdir);
+    "test_open_in", test_open_in;
+    "test_open_out", test_open_out;
+    "test_file_exists", (fun () -> test_file_exists true);
+    "test_stat", test_stat;
+    "test_access", test_access;
+    "test_rename unix_rename", (fun () -> test_rename unix_rename);
+    "test_rename sys_rename", (fun () -> test_rename sys_rename);
+    "test_remove remove", (fun () -> test_remove remove);
+    "test_file_exists", (fun () -> test_file_exists false);
+    "test_mkdir", test_mkdir;
+    "test_chdir sys_chdir sys_getcwd", (fun () -> test_chdir sys_chdir sys_getcwd);
+    "test_chdir unix_chdir unix_getcwd", (fun () -> test_chdir unix_chdir unix_getcwd);
+    "test_rmdir", test_rmdir;
+    "test_getenv", test_getenv;
+    "test_open_process_in", test_open_process_in;
+    "test_open_process_full", test_open_process_full;
+  |]
+
+(** MAIN *)
+
+let prepare () =
+  List.iter (fun s -> create_file (to_utf16 s) s) test_files
+
+let cleanup () =
+  List.iter Sys.remove test_files
+
+let main () =
+  for i = 0 to Array.length tests - 1 do
+    num := !num + 1;
+    let s, f = tests.(i) in
+    title s;
+    f ()
+  done;
+  Printf.printf "\n\n*** ALL TESTS DONE (%d/%d OK) ***\n%!" (!total - !failed) !total
+
+let () =
+  try
+    prepare ();
+    main ();
+    cleanup ()
+  with e ->
+    Printf.printf "** ERROR: %s\n%!" (Printexc.to_string e);
+    exit 1

diff --git a/testsuite/tests/win-unicode/mltest.reference b/testsuite/tests/win-unicode/mltest.reference
new file mode 100644 (file)
index 0000000..3a70cf8
--- /dev/null
+++ b/testsuite/tests/win-unicode/mltest.reference
@@ -0,0 +1,360 @@
+
+#01. Testing test_readdir unix_readdir
+=================================
+
+Unix.{opendir,readdir} "." ... "été.txt" "simple.txt" "sœur.txt" "你好.txt"
+
+#02. Testing test_readdir sys_readdir
+================================
+
+Sys.readdir "." ... "été.txt" "simple.txt" "sœur.txt" "你好.txt"
+
+#03. Testing test_open_in
+====================
+
+Sys.readdir "." ... "été.txt" "simple.txt" "sœur.txt" "你好.txt"
+open_in "été.txt" ... OK
+open_in "simple.txt" ... OK
+open_in "sœur.txt" ... OK
+open_in "你好.txt" ... OK
+
+#04. Testing test_open_out
+=====================
+
+open_out "верблюды" ... OK
+open_out "骆驼" ... OK
+open_out "קעמל" ... OK
+open_out "اونٹ" ... OK
+open_out "Lạc đà" ... OK
+open_out "ఒంటె" ... OK
+open_out "ஒட்டகம்" ... OK
+open_out "وشتر" ... OK
+open_out "उष्ट्रः" ... OK
+open_out "اٺ" ... OK
+
+#05. Testing test_file_exists
+========================
+
+Sys.file_exists "верблюды" ... true
+Sys.file_exists "骆驼" ... true
+Sys.file_exists "קעמל" ... true
+Sys.file_exists "اونٹ" ... true
+Sys.file_exists "Lạc đà" ... true
+Sys.file_exists "ఒంటె" ... true
+Sys.file_exists "ஒட்டகம்" ... true
+Sys.file_exists "وشتر" ... true
+Sys.file_exists "उष्ट्रः" ... true
+Sys.file_exists "اٺ" ... true
+
+#06. Testing test_stat
+=================
+
+Unix.stat "верблюды" ... S_REG
+Unix.lstat "верблюды" ... S_REG
+Unix.LargeFile.stat "верблюды" ... S_REG
+Unix.LargeFile.lstat "верблюды" ... S_REG
+Unix.stat "骆驼" ... S_REG
+Unix.lstat "骆驼" ... S_REG
+Unix.LargeFile.stat "骆驼" ... S_REG
+Unix.LargeFile.lstat "骆驼" ... S_REG
+Unix.stat "קעמל" ... S_REG
+Unix.lstat "קעמל" ... S_REG
+Unix.LargeFile.stat "קעמל" ... S_REG
+Unix.LargeFile.lstat "קעמל" ... S_REG
+Unix.stat "اونٹ" ... S_REG
+Unix.lstat "اونٹ" ... S_REG
+Unix.LargeFile.stat "اونٹ" ... S_REG
+Unix.LargeFile.lstat "اونٹ" ... S_REG
+Unix.stat "Lạc đà" ... S_REG
+Unix.lstat "Lạc đà" ... S_REG
+Unix.LargeFile.stat "Lạc đà" ... S_REG
+Unix.LargeFile.lstat "Lạc đà" ... S_REG
+Unix.stat "ఒంటె" ... S_REG
+Unix.lstat "ఒంటె" ... S_REG
+Unix.LargeFile.stat "ఒంటె" ... S_REG
+Unix.LargeFile.lstat "ఒంటె" ... S_REG
+Unix.stat "ஒட்டகம்" ... S_REG
+Unix.lstat "ஒட்டகம்" ... S_REG
+Unix.LargeFile.stat "ஒட்டகம்" ... S_REG
+Unix.LargeFile.lstat "ஒட்டகம்" ... S_REG
+Unix.stat "وشتر" ... S_REG
+Unix.lstat "وشتر" ... S_REG
+Unix.LargeFile.stat "وشتر" ... S_REG
+Unix.LargeFile.lstat "وشتر" ... S_REG
+Unix.stat "उष्ट्रः" ... S_REG
+Unix.lstat "उष्ट्रः" ... S_REG
+Unix.LargeFile.stat "उष्ट्रः" ... S_REG
+Unix.LargeFile.lstat "उष्ट्रः" ... S_REG
+Unix.stat "اٺ" ... S_REG
+Unix.lstat "اٺ" ... S_REG
+Unix.LargeFile.stat "اٺ" ... S_REG
+Unix.LargeFile.lstat "اٺ" ... S_REG
+
+#07. Testing test_access
+===================
+
+Unix.access "верблюды" ... OK
+Unix.access "骆驼" ... OK
+Unix.access "קעמל" ... OK
+Unix.access "اونٹ" ... OK
+Unix.access "Lạc đà" ... OK
+Unix.access "ఒంటె" ... OK
+Unix.access "ஒட்டகம்" ... OK
+Unix.access "وشتر" ... OK
+Unix.access "उष्ट्रः" ... OK
+Unix.access "اٺ" ... OK
+
+#08. Testing test_rename unix_rename
+===============================
+
+Unix.rename "верблюды" "верблюды-1" ... OK
+Sys.file_exists "верблюды" ... false
+Sys.file_exists "верблюды-1" ... true
+Unix.rename "верблюды-1" "верблюды" ... OK
+Sys.file_exists "верблюды" ... true
+Sys.file_exists "верблюды-1" ... false
+Unix.rename "骆驼" "骆驼-1" ... OK
+Sys.file_exists "骆驼" ... false
+Sys.file_exists "骆驼-1" ... true
+Unix.rename "骆驼-1" "骆驼" ... OK
+Sys.file_exists "骆驼" ... true
+Sys.file_exists "骆驼-1" ... false
+Unix.rename "קעמל" "קעמל-1" ... OK
+Sys.file_exists "קעמל" ... false
+Sys.file_exists "קעמל-1" ... true
+Unix.rename "קעמל-1" "קעמל" ... OK
+Sys.file_exists "קעמל" ... true
+Sys.file_exists "קעמל-1" ... false
+Unix.rename "اونٹ" "اونٹ-1" ... OK
+Sys.file_exists "اونٹ" ... false
+Sys.file_exists "اونٹ-1" ... true
+Unix.rename "اونٹ-1" "اونٹ" ... OK
+Sys.file_exists "اونٹ" ... true
+Sys.file_exists "اونٹ-1" ... false
+Unix.rename "Lạc đà" "Lạc đà-1" ... OK
+Sys.file_exists "Lạc đà" ... false
+Sys.file_exists "Lạc đà-1" ... true
+Unix.rename "Lạc đà-1" "Lạc đà" ... OK
+Sys.file_exists "Lạc đà" ... true
+Sys.file_exists "Lạc đà-1" ... false
+Unix.rename "ఒంటె" "ఒంటె-1" ... OK
+Sys.file_exists "ఒంటె" ... false
+Sys.file_exists "ఒంటె-1" ... true
+Unix.rename "ఒంటె-1" "ఒంటె" ... OK
+Sys.file_exists "ఒంటె" ... true
+Sys.file_exists "ఒంటె-1" ... false
+Unix.rename "ஒட்டகம்" "ஒட்டகம்-1" ... OK
+Sys.file_exists "ஒட்டகம்" ... false
+Sys.file_exists "ஒட்டகம்-1" ... true
+Unix.rename "ஒட்டகம்-1" "ஒட்டகம்" ... OK
+Sys.file_exists "ஒட்டகம்" ... true
+Sys.file_exists "ஒட்டகம்-1" ... false
+Unix.rename "وشتر" "وشتر-1" ... OK
+Sys.file_exists "وشتر" ... false
+Sys.file_exists "وشتر-1" ... true
+Unix.rename "وشتر-1" "وشتر" ... OK
+Sys.file_exists "وشتر" ... true
+Sys.file_exists "وشتر-1" ... false
+Unix.rename "उष्ट्रः" "उष्ट्रः-1" ... OK
+Sys.file_exists "उष्ट्रः" ... false
+Sys.file_exists "उष्ट्रः-1" ... true
+Unix.rename "उष्ट्रः-1" "उष्ट्रः" ... OK
+Sys.file_exists "उष्ट्रः" ... true
+Sys.file_exists "उष्ट्रः-1" ... false
+Unix.rename "اٺ" "اٺ-1" ... OK
+Sys.file_exists "اٺ" ... false
+Sys.file_exists "اٺ-1" ... true
+Unix.rename "اٺ-1" "اٺ" ... OK
+Sys.file_exists "اٺ" ... true
+Sys.file_exists "اٺ-1" ... false
+
+#09. Testing test_rename sys_rename
+==============================
+
+Sys.rename "верблюды" "верблюды-1" ... OK
+Sys.file_exists "верблюды" ... false
+Sys.file_exists "верблюды-1" ... true
+Sys.rename "верблюды-1" "верблюды" ... OK
+Sys.file_exists "верблюды" ... true
+Sys.file_exists "верблюды-1" ... false
+Sys.rename "骆驼" "骆驼-1" ... OK
+Sys.file_exists "骆驼" ... false
+Sys.file_exists "骆驼-1" ... true
+Sys.rename "骆驼-1" "骆驼" ... OK
+Sys.file_exists "骆驼" ... true
+Sys.file_exists "骆驼-1" ... false
+Sys.rename "קעמל" "קעמל-1" ... OK
+Sys.file_exists "קעמל" ... false
+Sys.file_exists "קעמל-1" ... true
+Sys.rename "קעמל-1" "קעמל" ... OK
+Sys.file_exists "קעמל" ... true
+Sys.file_exists "קעמל-1" ... false
+Sys.rename "اونٹ" "اونٹ-1" ... OK
+Sys.file_exists "اونٹ" ... false
+Sys.file_exists "اونٹ-1" ... true
+Sys.rename "اونٹ-1" "اونٹ" ... OK
+Sys.file_exists "اونٹ" ... true
+Sys.file_exists "اونٹ-1" ... false
+Sys.rename "Lạc đà" "Lạc đà-1" ... OK
+Sys.file_exists "Lạc đà" ... false
+Sys.file_exists "Lạc đà-1" ... true
+Sys.rename "Lạc đà-1" "Lạc đà" ... OK
+Sys.file_exists "Lạc đà" ... true
+Sys.file_exists "Lạc đà-1" ... false
+Sys.rename "ఒంటె" "ఒంటె-1" ... OK
+Sys.file_exists "ఒంటె" ... false
+Sys.file_exists "ఒంటె-1" ... true
+Sys.rename "ఒంటె-1" "ఒంటె" ... OK
+Sys.file_exists "ఒంటె" ... true
+Sys.file_exists "ఒంటె-1" ... false
+Sys.rename "ஒட்டகம்" "ஒட்டகம்-1" ... OK
+Sys.file_exists "ஒட்டகம்" ... false
+Sys.file_exists "ஒட்டகம்-1" ... true
+Sys.rename "ஒட்டகம்-1" "ஒட்டகம்" ... OK
+Sys.file_exists "ஒட்டகம்" ... true
+Sys.file_exists "ஒட்டகம்-1" ... false
+Sys.rename "وشتر" "وشتر-1" ... OK
+Sys.file_exists "وشتر" ... false
+Sys.file_exists "وشتر-1" ... true
+Sys.rename "وشتر-1" "وشتر" ... OK
+Sys.file_exists "وشتر" ... true
+Sys.file_exists "وشتر-1" ... false
+Sys.rename "उष्ट्रः" "उष्ट्रः-1" ... OK
+Sys.file_exists "उष्ट्रः" ... false
+Sys.file_exists "उष्ट्रः-1" ... true
+Sys.rename "उष्ट्रः-1" "उष्ट्रः" ... OK
+Sys.file_exists "उष्ट्रः" ... true
+Sys.file_exists "उष्ट्रः-1" ... false
+Sys.rename "اٺ" "اٺ-1" ... OK
+Sys.file_exists "اٺ" ... false
+Sys.file_exists "اٺ-1" ... true
+Sys.rename "اٺ-1" "اٺ" ... OK
+Sys.file_exists "اٺ" ... true
+Sys.file_exists "اٺ-1" ... false
+
+#10. Testing test_remove remove
+==========================
+
+Sys.remove "верблюды" ... OK
+Sys.file_exists "верблюды" ... false
+Sys.remove "骆驼" ... OK
+Sys.file_exists "骆驼" ... false
+Sys.remove "קעמל" ... OK
+Sys.file_exists "קעמל" ... false
+Sys.remove "اونٹ" ... OK
+Sys.file_exists "اونٹ" ... false
+Sys.remove "Lạc đà" ... OK
+Sys.file_exists "Lạc đà" ... false
+Sys.remove "ఒంటె" ... OK
+Sys.file_exists "ఒంటె" ... false
+Sys.remove "ஒட்டகம்" ... OK
+Sys.file_exists "ஒட்டகம்" ... false
+Sys.remove "وشتر" ... OK
+Sys.file_exists "وشتر" ... false
+Sys.remove "उष्ट्रः" ... OK
+Sys.file_exists "उष्ट्रः" ... false
+Sys.remove "اٺ" ... OK
+Sys.file_exists "اٺ" ... false
+
+#11. Testing test_file_exists
+========================
+
+Sys.file_exists "верблюды" ... false
+Sys.file_exists "骆驼" ... false
+Sys.file_exists "קעמל" ... false
+Sys.file_exists "اونٹ" ... false
+Sys.file_exists "Lạc đà" ... false
+Sys.file_exists "ఒంటె" ... false
+Sys.file_exists "ஒட்டகம்" ... false
+Sys.file_exists "وشتر" ... false
+Sys.file_exists "उष्ट्रः" ... false
+Sys.file_exists "اٺ" ... false
+
+#12. Testing test_mkdir
+==================
+
+Unix.mkdir "été" 493 ... OK
+Sys.file_exists "été" ... true
+Sys.is_directory "été" ... true
+Unix.mkdir "simple" 493 ... OK
+Sys.file_exists "simple" ... true
+Sys.is_directory "simple" ... true
+Unix.mkdir "sœur" 493 ... OK
+Sys.file_exists "sœur" ... true
+Sys.is_directory "sœur" ... true
+Unix.mkdir "你好" 493 ... OK
+Sys.file_exists "你好" ... true
+Sys.is_directory "你好" ... true
+
+#13. Testing test_chdir sys_chdir sys_getcwd
+=======================================
+
+Sys.chdir "été" ... OK
+Sys.getcwd () ... "été"
+Sys.chdir ".." ... OK
+Sys.chdir "simple" ... OK
+Sys.getcwd () ... "simple"
+Sys.chdir ".." ... OK
+Sys.chdir "sœur" ... OK
+Sys.getcwd () ... "sœur"
+Sys.chdir ".." ... OK
+Sys.chdir "你好" ... OK
+Sys.getcwd () ... "你好"
+Sys.chdir ".." ... OK
+
+#14. Testing test_chdir unix_chdir unix_getcwd
+=========================================
+
+Unix.chdir "été" ... OK
+Unix.getcwd () ... "été"
+Unix.chdir ".." ... OK
+Unix.chdir "simple" ... OK
+Unix.getcwd () ... "simple"
+Unix.chdir ".." ... OK
+Unix.chdir "sœur" ... OK
+Unix.getcwd () ... "sœur"
+Unix.chdir ".." ... OK
+Unix.chdir "你好" ... OK
+Unix.getcwd () ... "你好"
+Unix.chdir ".." ... OK
+
+#15. Testing test_rmdir
+==================
+
+Unix.rmdir "été" ... OK
+Sys.file_exists "été" ... false
+Unix.rmdir "simple" ... OK
+Sys.file_exists "simple" ... false
+Unix.rmdir "sœur" ... OK
+Sys.file_exists "sœur" ... false
+Unix.rmdir "你好" ... OK
+Sys.file_exists "你好" ... false
+
+#16. Testing test_getenv
+===================
+
+Unix.putenv "été" "верблюды" ... OK
+Sys.getenv "été" ... "верблюды"
+Unix.environment "été" ... "верблюды"
+Unix.putenv "simple" "骆驼" ... OK
+Sys.getenv "simple" ... "骆驼"
+Unix.environment "simple" ... "骆驼"
+Unix.putenv "sœur" "קעמל" ... OK
+Sys.getenv "sœur" ... "קעמל"
+Unix.environment "sœur" ... "קעמל"
+Unix.putenv "你好" "اونٹ" ... OK
+Sys.getenv "你好" ... "اونٹ"
+Unix.environment "你好" ... "اونٹ"
+
+#17. Testing test_open_process_in
+============================
+
+Unix.open_process_in ... ... "верблюды" "骆驼" "קעמל" "اونٹ" "Lạc đà" "ఒంటె" "ஒட்டகம்" "وشتر" "उष्ट्रः" "اٺ"
+
+#18. Testing test_open_process_full
+==============================
+
+Unix.open_process_full ... "OCAML_UTF8_VAR0=верблюды" "OCAML_UTF8_VAR1=骆驼" "OCAML_UTF8_VAR2=קעמל" "OCAML_UTF8_VAR3=اونٹ" ... "OCAML_UTF8_VAR0=верблюды" "OCAML_UTF8_VAR1=骆驼" "OCAML_UTF8_VAR2=קעמל" "OCAML_UTF8_VAR3=اونٹ"
+
+
+*** ALL TESTS DONE (207/207 OK) ***

diff --git a/testsuite/tests/win-unicode/printargv.c b/testsuite/tests/win-unicode/printargv.c
new file mode 100755 (executable)
index 0000000..78bfbbd
--- /dev/null
+++ b/testsuite/tests/win-unicode/printargv.c
@@ -0,0 +1,25 @@
+#include <stdio.h>
+#include <locale.h>
+#include <assert.h>
+
+#include <Windows.h>
+
+int wmain(int argc, wchar_t ** argv)
+{
+  int len;
+  char * p;
+
+  int i;
+  for (i = 0; i < argc; i ++) {
+    /* printf("%S\n", argv[i]); */
+    len = WideCharToMultiByte(CP_UTF8, 0, argv[i], -1, NULL, 0, NULL, NULL);
+    assert(len != 0);
+    p = malloc(len);
+    len = WideCharToMultiByte(CP_UTF8, 0, argv[i], -1, p, len, NULL, NULL);
+    assert(len != 0);
+    printf("%s\n", p);
+    free(p);
+  }
+  fflush(stdout);
+  return 0;
+}

diff --git a/testsuite/tests/win-unicode/printenv.c b/testsuite/tests/win-unicode/printenv.c
new file mode 100755 (executable)
index 0000000..33dfb50
--- /dev/null
+++ b/testsuite/tests/win-unicode/printenv.c
@@ -0,0 +1,36 @@
+#include <stdio.h>
+#include <assert.h>
+
+#ifdef _WIN32
+
+#include <Windows.h>
+
+int wmain(int argc, char ** argv, wchar_t ** envp)
+{
+  wchar_t * p;
+  char * s;
+  int i = 0, len;
+  while (envp[i]) {
+    p = envp[i++];
+    len = WideCharToMultiByte(CP_UTF8, 0, p, -1, NULL, 0, NULL, NULL);
+    assert(len != 0);
+    s = malloc(len);
+    len = WideCharToMultiByte(CP_UTF8, 0, p, -1, s, len, NULL, NULL);
+    assert(len != 0);
+    printf("%s\n", s);
+    free(s);
+  }
+  return 0;
+}
+
+#else
+
+int main(int argc, char ** argv, char ** env)
+{
+  int i = 0;
+  while (env[i])
+    printf("%s\n", env[i++]);
+  return 0;
+}
+
+#endif

diff --git a/testsuite/tests/win-unicode/symlink_tests.ml b/testsuite/tests/win-unicode/symlink_tests.ml
new file mode 100755 (executable)
index 0000000..b51121c
--- /dev/null
+++ b/testsuite/tests/win-unicode/symlink_tests.ml
@@ -0,0 +1,27 @@
+external to_utf16 : string -> string = "caml_to_utf16"
+external create_file : string -> string -> unit = "caml_create_file"
+
+let foodir = "UNIQU\xE4\xBD\xA0\xE5\xA5\xBD" (* "UNIQU你好" *)
+let foofile = "UNIQU\xE4\xBD\xA0\xE5\xA5\xBD/\xE4\xBD\xA0\xE5\xA5\xBD.txt" (* "UNIQU你好/你好.txt" *)
+let foofile2 = "UNIQU\xE4\xBD\xA0\xE5\xA5\xBD\\\xE4\xBD\xA0\xE5\xA5\xBD.txt" (* "UNIQU你好\\你好.txt" *)
+let fileln = "\xE4\xBD\xA0\xE5\xA5\xBD-file-ln-s" (* "你好-file-ln-s" *)
+let dirln = "\xE4\xBD\xA0\xE5\xA5\xBD-dir-ln-s" (* "你好-dir-ln-s" *)
+
+open Unix
+
+let () =
+  mkdir foodir 0o777;
+  create_file (to_utf16 foofile) foofile;
+  symlink ~to_dir:true foodir dirln;
+  symlink ~to_dir:false (if Sys.win32 then foofile2 else foofile) fileln; (* workaround MPR#7564 *)
+  assert ((stat fileln).st_kind = S_REG);
+  assert ((stat dirln).st_kind = S_DIR);
+  assert ((lstat fileln).st_kind = S_LNK);
+  assert ((lstat dirln).st_kind = S_LNK);
+  Sys.remove foofile;
+  Sys.remove fileln;
+  rmdir dirln;
+  rmdir foodir
+
+let () =
+  print_endline "OK."

diff --git a/testsuite/tests/win-unicode/symlink_tests.reference b/testsuite/tests/win-unicode/symlink_tests.reference
new file mode 100644 (file)
index 0000000..d5c32f4
--- /dev/null
+++ b/testsuite/tests/win-unicode/symlink_tests.reference
@@ -0,0 +1 @@
+OK.

diff --git a/testsuite/tools/expect_test.ml b/testsuite/tools/expect_test.ml
index 6ddd44ba76d8d9f1562e87b56bbc9e51fbd24413..42c3027ac85ddced5b428bda0a041a81947bc520 100644 (file)
--- a/testsuite/tools/expect_test.ml
+++ b/testsuite/tools/expect_test.ml
@@ -136,30 +136,20 @@ module Compiler_messages = struct
     Format.fprintf ppf "Line _";
     if startchar >= 0 then
       Format.fprintf ppf ", characters %d-%d" startchar endchar;
-    Format.fprintf ppf ":@."
-
-  let rec error_reporter ppf ({loc; msg; sub; if_highlight=_} : Location.error)=
-    print_loc ppf loc;
-    Format.fprintf ppf "%a %s" Location.print_error_prefix () msg;
-    List.iter sub ~f:(fun err ->
-      Format.fprintf ppf "@\n@[<2>%a@]" error_reporter err)
-
-  let warning_printer loc ppf w =
-    if Warnings.is_active w then begin
-      print_loc ppf loc;
-      Format.fprintf ppf "Warning %a@." Warnings.print w
-    end
+    Format.fprintf ppf ":@,"
 
   let capture ppf ~f =
     Misc.protect_refs
-      [ R (Location.formatter_for_warnings , ppf            )
-      ; R (Location.warning_printer        , warning_printer)
-      ; R (Location.error_reporter         , error_reporter )
+      [ R (Location.formatter_for_warnings , ppf)
+      ; R (Location.printer                , print_loc)
       ]
       f
 end
 
 let collect_formatters buf pps ~f =
+  let ppb = Format.formatter_of_buffer buf in
+  let out_functions = Format.pp_get_formatter_out_functions ppb () in
+
   List.iter (fun pp -> Format.pp_print_flush pp ()) pps;
   let save =
     List.map (fun pp -> Format.pp_get_formatter_out_functions pp ()) pps
@@ -171,13 +161,6 @@ let collect_formatters buf pps ~f =
          Format.pp_set_formatter_out_functions pp out_functions)
       pps save
   in
-  let out_string str ofs len = Buffer.add_substring buf str ofs len
-  and out_flush = ignore
-  and out_newline () = Buffer.add_char buf '\n'
-  and out_spaces n = for i = 1 to n do Buffer.add_char buf ' ' done in
-  let out_functions =
-    { Format.out_string; out_flush; out_newline; out_spaces }
-  in
   List.iter
     (fun pp -> Format.pp_set_formatter_out_functions pp out_functions)
     pps;
@@ -357,6 +340,7 @@ let usage = "Usage: expect_test <options> [script-file [arguments]]\n\
              options are:"
 
 let () =
+  Clflags.error_size := 0;
   try
     Arg.parse args main usage;
     Printf.eprintf "expect_test: no input file\n";

diff --git a/tools/.depend b/tools/.depend
index 5dcb7ed8372f916c03bf20f7d3c45a1792a41950..add9b377312dde207053567afe6f94d8476be6bb 100644 (file)
--- a/tools/.depend
+++ b/tools/.depend
@@ -56,16 +56,8 @@ ocaml299to3.cmo :
 ocaml299to3.cmx :
 ocamlcp.cmo : ../driver/main_args.cmi
 ocamlcp.cmx : ../driver/main_args.cmx
-ocamldep.cmo : ../driver/pparse.cmi ../parsing/parsetree.cmi \
-    ../parsing/parser.cmi ../parsing/parse.cmi ../utils/misc.cmi \
-    ../parsing/longident.cmi ../parsing/location.cmi ../parsing/lexer.cmi \
-    ../parsing/depend.cmi ../utils/config.cmi ../driver/compplugin.cmi \
-    ../driver/compenv.cmi ../utils/clflags.cmi
-ocamldep.cmx : ../driver/pparse.cmx ../parsing/parsetree.cmi \
-    ../parsing/parser.cmx ../parsing/parse.cmx ../utils/misc.cmx \
-    ../parsing/longident.cmx ../parsing/location.cmx ../parsing/lexer.cmx \
-    ../parsing/depend.cmx ../utils/config.cmx ../driver/compplugin.cmx \
-    ../driver/compenv.cmx ../utils/clflags.cmx
+ocamldep.cmo : ../driver/makedepend.cmi
+ocamldep.cmx : ../driver/makedepend.cmx
 ocamlmklib.cmo : ocamlmklibconfig.cmo ../utils/misc.cmi ../utils/config.cmi
 ocamlmklib.cmx : ocamlmklibconfig.cmx ../utils/misc.cmx ../utils/config.cmx
 ocamlmklibconfig.cmo :
@@ -85,8 +77,10 @@ primreq.cmx : ../utils/config.cmx ../bytecomp/cmo_format.cmi
 profiling.cmo : profiling.cmi
 profiling.cmx : profiling.cmi
 profiling.cmi :
-read_cmt.cmo : ../typing/cmt_format.cmi cmt2annot.cmo ../utils/clflags.cmi
-read_cmt.cmx : ../typing/cmt_format.cmx cmt2annot.cmx ../utils/clflags.cmx
+read_cmt.cmo : ../parsing/location.cmi ../driver/compmisc.cmi \
+    ../typing/cmt_format.cmi cmt2annot.cmo ../utils/clflags.cmi
+read_cmt.cmx : ../parsing/location.cmx ../driver/compmisc.cmx \
+    ../typing/cmt_format.cmx cmt2annot.cmx ../utils/clflags.cmx
 scrapelabels.cmo :
 scrapelabels.cmx :
 stripdebug.cmo : ../utils/misc.cmi ../bytecomp/bytesections.cmi

diff --git a/tools/Makefile b/tools/Makefile
index 9a8cf652b4fce7c68822cbaded9872fee3ae6f17..92d9e99e783c63f2c57e72ecf15a4e4afc1dcb76 100644 (file)
--- a/tools/Makefile
+++ b/tools/Makefile
@@ -133,8 +133,8 @@ CSLPROF_IMPORTS=misc.cmo config.cmo identifiable.cmo numbers.cmo \
 
 $(call byte_and_opt,ocamlprof,$(CSLPROF_IMPORTS) profiling.cmo $(CSLPROF),)
 
-ocamlcp_cmos = misc.cmo warnings.cmo config.cmo identifiable.cmo numbers.cmo \
-              arg_helper.cmo clflags.cmo main_args.cmo
+ocamlcp_cmos = misc.cmo profile.cmo warnings.cmo config.cmo identifiable.cmo \
+               numbers.cmo arg_helper.cmo clflags.cmo main_args.cmo
 
 $(call byte_and_opt,ocamlcp,$(ocamlcp_cmos) ocamlcp.cmo,)
 $(call byte_and_opt,ocamloptp,$(ocamlcp_cmos) ocamloptp.cmo,)
@@ -156,8 +156,7 @@ $(call byte_and_opt,ocamlmklib,ocamlmklibconfig.cmo config.cmo misc.cmo \
 ocamlmklibconfig.ml: ../config/Makefile Makefile
        (echo 'let bindir = "$(BINDIR)"'; \
          echo 'let supports_shared_libraries = $(SUPPORTS_SHARED_LIBRARIES)';\
-         echo 'let byteccrpath = "$(BYTECCRPATH)"'; \
-         echo 'let nativeccrpath = "$(NATIVECCRPATH)"'; \
+         echo 'let default_rpath = "$(RPATH)"'; \
          echo 'let mksharedlibrpath = "$(MKSHAREDLIBRPATH)"'; \
          echo 'let toolpref = "$(TOOLPREF)"'; \
          sed -n -e 's/^#ml //p' ../config/Makefile) \
@@ -276,6 +275,13 @@ READ_CMT= \
 # Reading cmt files
 $(call byte_and_opt,read_cmt,$(READ_CMT),)
 
+install::
+       if test -f read_cmt.opt; then \
+               cp read_cmt.opt "$(INSTALL_BINDIR)/ocamlcmt$(EXE)"; \
+       else \
+               cp read_cmt "$(INSTALL_BINDIR)/ocamlcmt$(EXE)"; \
+       fi
+
 
 # The bytecode disassembler
 
@@ -307,16 +313,9 @@ 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) $(CCOUT)objinfo_helper$(EXE) $(BYTECCCOMPOPTS) \
-          $(DEF_SYMBOL_PREFIX) $(LIBBFD_INCLUDE) objinfo_helper.c $(LIBBFD_LINK)
+objinfo_helper$(EXE): objinfo_helper.c ../byterun/caml/s.h
+       $(CC) $(CFLAGS) $(CPPFLAGS) -I../byterun $(OUTPUTEXE)$@ \
+          $(DEF_SYMBOL_PREFIX) $(LIBBFD_INCLUDE) $< $(LIBBFD_LINK)
 
 OBJINFO=../compilerlibs/ocamlcommon.cma \
         ../compilerlibs/ocamlbytecomp.cma \

diff --git a/tools/check-symbol-names b/tools/check-symbol-names
new file mode 100755 (executable)
index 0000000..805215c
--- /dev/null
+++ b/tools/check-symbol-names
@@ -0,0 +1,33 @@
+#!/bin/bash
+
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*                 Stephen Dolan, University of Cambridge                 *
+#*                                                                        *
+#*   Copyright 2016 Stephen Dolan.                                        *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+set -o pipefail
+
+[ -z "$*" ] && { echo "Usage: $0 libfoo.a" 1>&2; exit 2; }
+
+nm -A -P "$@" | awk '
+# ignore caml_foo, camlFoo_bar, _caml_foo, _camlFoo_bar
+$2 ~ /^(_?caml[_A-Z])/ { next }
+# ignore local and undefined symbols
+$3 ~ /^[rbdtsU]$/ { next }
+# ignore "main", which should be externally linked
+$2 ~ /^_?main$/ { next }
+# print the rest
+{ found=1; print $1 " " $2 " " $3 }
+# fail if there were any results
+END { exit found ? 1 : 0 }
+'
+exit $?

diff --git a/tools/check-typo b/tools/check-typo
index 550ce2524ae353001e39aa4d901cd6947db13d73..90149526eb88ea4c4c8b78cc2f87054b5f70efbf 100755 (executable)
--- a/tools/check-typo
+++ b/tools/check-typo
@@ -162,10 +162,13 @@ IGNORE_DIRS="
     (cat "$f" | tr -d '\r'; echo) \
     | awk -v rules="$rules" -v svnrules="$svnrules" -v file="$f" \
       '
+        function is_err(name) {
+          return (("," rules svnrules ",") !~ ("[, ]" name "[, ]"));
+        }
+
         function err(name, msg) {
           ++ counts[name];
-          if (("," rules svnrules ",") !~ ("[, ]" name "[, ]") \
-              && counts[name] <= 10){
+          if (is_err(name) && counts[name] <= 10){
             printf ("%s:%d.%d:", file, NR, RSTART + RLENGTH);
             printf (" [%s] %s\n", name, msg);
             got_errors = 1;
@@ -204,8 +207,13 @@ IGNORE_DIRS="
           }
         }
 
-        match($0, /[\200-\377]/) {
+        match($0, /[\200-\377]/) \
+        && state != "authors" && state != "copyright" {
           err("non-ascii", "non-ASCII character(s)");
+          if (header_utf8 && !is_err("non-ascii")) {
+            err("non-ascii-utf8", \
+                "non-ASCII character(s) AND UTF-8 encountered");
+          }
         }
 
         match($0, /[^\t\200-\377 -~]/) {
@@ -221,9 +229,13 @@ IGNORE_DIRS="
         }
 
         $0 !~ /\t/ && length($0) > 80 {
-          RSTART = 81;
-          RLENGTH = 0;
-          err("long-line", "line is over 80 columns");
+          t = $0;
+          sub(/https?:[A-Za-z0-9._~:/?#\[\]@!$&\047()*+,;=%-]{73,}$/, "", t);
+          if (length(t) > 80) {
+            RSTART = 81;
+            RLENGTH = 0;
+            err("long-line", "line is over 80 columns");
+          }
         }
 
         $0 !~ /\t/ && length($0) > 132 {
@@ -232,7 +244,23 @@ IGNORE_DIRS="
           err("very-long-line", "line is over 132 columns");
         }
 
+        # Record that the header contained UTF-8 sequences
+        match($0, /[\300-\367][\200-\277]+/) \
+        && (state == "authors" || state == "copyright") {
+          header_utf8 = 1;
+          if (counts["non-ascii"] > 0 && is_err("non-ascii")) {
+            err("non-ascii-utf8", \
+                "non-ASCII character(s) AND UTF-8 encountered");
+          }
+        }
+
         # Header-recognition automaton. Read this from bottom to top.
+        # Valid UTF-8 chars are recognised in copyright and authors
+        # TODO: ensure all files are valid UTF-8 before awking them.
+        # Note that this code also assumes that combining characters are NOT
+        # used (i.e. that every Unicode code-point corresponds to exactly
+        # one displayed character, i.e. no Camels and no including
+        # weird-and-wonderful ways of encoded accented letters).
 
         state == "close" && $0 ~ /\*{74}/ { state = "OK"; }
         state == "close" { state = "(last line)"; }
@@ -242,11 +270,14 @@ IGNORE_DIRS="
                                                  { state = "blurb"; }
         state == "blurb1" { state = "(blurb line 1)"; }
         state == "copyright" && $0 ~ /\* {72}\*/ { state = "blurb1"; }
-        state == "copyright" && $0 !~ /\*   Copyright [0-9]{4}.{54} \*/ \
-                             && $0 !~ /\*     .{66} \*/ \
+        state == "copyright" \
+          && $0 !~ /\*   Copyright [0-9]{4}([\300-\367][\200-\277]+|.){54} \*/ \
+          && $0 !~ /\*     ([\300-\367][\200-\277]+|.){66} \*/ \
                       { state = "(copyright lines)"; }
         state == "authors" && $0 ~ /\* {72}\*/ { state = "copyright"; }
-        state == "authors" && $0 !~ /\* .{70} \*/ { state = "(authors)"; }
+        state == "authors" \
+          && $0 !~ /\* ([\300-\367][\200-\277]+|.){70} \*/ \
+                      { state = "(authors)"; }
         state == "blank2" && $0 ~ /\* {72}\*/ { state = "authors"; }
         state == "blank2" { state = "(blank line 2)"; }
         state == "title" && $0 ~ /\* {33}OCaml {34}\*/ { state = "blank2"; }

diff --git a/tools/ci-build b/tools/ci-build
index 46af368bcf5766a364e366591161e468440c87e7..a7489264367aeb1f588e8a9c1b8f8e8984402f48 100755 (executable)
--- a/tools/ci-build
+++ b/tools/ci-build
@@ -22,10 +22,15 @@
 # in Jenkins at the following address:
 # https://ci.inria.fr/ocaml/computer/NODE/configure
 
-# arguments:
+# Other environments variables that are honored:
+#   OCAML_CONFIGURE_OPTIONS   additional options for configure
+#   OCAML_JOBS                number of jobs to run in parallel (make -j)
+
+# Command-line arguments:
 # -conf configure-option  add configure-option to configure cmd line
 # -patch1 file-name       apply patch with -p1
 # -no-native              do not build "opt" and "opt.opt"
+# -jNN                    pass "-jNN" option to make for parallel builds
 
 error () {
   echo "$1" >&2
@@ -86,6 +91,11 @@ esac
 
 #########################################################################
 
+# be considerate towards other potential users of the test machine
+case "${OCAML_ARCH}" in
+  bsd|macos|linux) renice 10 $$ ;;
+esac
+
 # be verbose and stop on error
 set -ex
 
@@ -99,24 +109,33 @@ configure=unix
 confoptions="${OCAML_CONFIGURE_OPTIONS}"
 make_native=true
 cleanup=false
+check_make_alldepend=false
+dorebase=false
+jobs=''
 
 case "${OCAML_ARCH}" in
   bsd) make=gmake ;;
   macos) ;;
   linux)
     confoptions="${confoptions} -with-instrumented-runtime"
+    check_make_alldepend=true
   ;;
   cygwin)
-    cleanup=true;;
+    cleanup=true
+    check_make_alldepend=true
+    dorebase=true
+  ;;
   mingw)
     instdir='C:/ocamlmgw'
     configure=nt
     cleanup=true
+    check_make_alldepend=true
   ;;
   mingw64)
     instdir='C:/ocamlmgw64'
     configure=nt
     cleanup=true
+    check_make_alldepend=true
   ;;
   msvc)
     instdir='C:/ocamlms'
@@ -134,6 +153,10 @@ esac
 # Make sure two builds won't use the same install directory
 instdir="$instdir-$$"
 
+case "${OCAML_JOBS}" in
+  [1-9]|[1-9][0-9]) jobs="-j${OCAML_JOBS}" ;;
+esac
+
 #########################################################################
 # On Windows, cleanup processes that may remain from previous run
 
@@ -156,6 +179,7 @@ while [ $# -gt 0 ]; do
     -conf) confoptions="$confoptions `quote1 "$2"`"; shift;;
     -patch1) patch -f -p1 <"$2"; shift;;
     -no-native) make_native=false;;
+    -j[1-9]|-j[1-9][0-9]) jobs="$1";;
     *) error "unknown option $1";;
   esac
   shift
@@ -167,7 +191,7 @@ done
 # Tell gcc to use only ASCII in its diagnostic outputs.
 export LC_ALL=C
 
-$make distclean || :
+$make -s distclean || :
 
 # `make distclean` does not clean the files from previous versions that
 # are not produced by the current version, so use `git clean` in addition.
@@ -182,8 +206,8 @@ case $configure in
     eval "./configure -prefix '$instdir' $confoptions"
   ;;
   nt)
-    cp config/m-nt.h config/m.h
-    cp config/s-nt.h config/s.h
+    cp config/m-nt.h byterun/caml/m.h
+    cp config/s-nt.h byterun/caml/s.h
     cp config/Makefile.${OCAML_ARCH} config/Makefile
     sed -i "s%PREFIX=\(.\+\)%PREFIX=${instdir}%" config/Makefile
     sed -i 's%RUNTIMED=.\+%RUNTIMED=true%' config/Makefile
@@ -194,13 +218,19 @@ case $configure in
   *) error "internal error";;
 esac
 
-$make coldstart
-$make core
-$make coreboot
-$make world
+$make $jobs coldstart
+$make $jobs core
+$make $jobs coreboot
+$make $jobs world
 if $make_native; then
-  $make opt
-  $make opt.opt
+  $make $jobs opt
+  $make $jobs opt.opt
+  if $check_make_alldepend; then $make alldepend; fi
+fi
+if $dorebase; then
+    # temporary solution to the cygwin fork problem
+    rebase -b 0x7cd20000 otherlibs/unix/dllunix.so
+    rebase -b 0x7cdc0000 otherlibs/systhreads/dllthreads.so
 fi
 $make install
 

diff --git a/tools/ci-build-other-configs b/tools/ci-build-other-configs
new file mode 100755 (executable)
index 0000000..ac65581
--- /dev/null
+++ b/tools/ci-build-other-configs
@@ -0,0 +1,21 @@
+#!/bin/sh
+#**************************************************************************
+#*                                                                        *
+#*                                 OCaml                                  *
+#*                                                                        *
+#*            Sebastien Hinderer, projet Gallium, INRIA Paris             *
+#*                                                                        *
+#*   Copyright 2017 Institut National de Recherche en Informatique et     *
+#*     en Automatique.                                                    *
+#*                                                                        *
+#*   All rights reserved.  This file is distributed under the terms of    *
+#*   the GNU Lesser General Public License version 2.1, with the          *
+#*   special exception on linking described in the file LICENSE.          *
+#*                                                                        *
+#**************************************************************************
+
+# Commands to run for the 'other-configs' job on Inria's CI
+
+./tools/ci-build -conf -no-native-compiler -no-native
+./tools/ci-build -conf -no-naked-pointers
+./tools/ci-build -conf -flambda -conf -no-naked-pointers

diff --git a/tools/cleanup-header b/tools/cleanup-header
deleted file mode 100644 (file)
index 5945597..0000000
--- a/tools/cleanup-header
+++ /dev/null
@@ -1,29 +0,0 @@
-#!/bin/sed -f
-
-#**************************************************************************
-#*                                                                        *
-#*                                 OCaml                                  *
-#*                                                                        *
-#*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *
-#*                                                                        *
-#*   Copyright 2002 Institut National de Recherche en Informatique et     *
-#*     en Automatique.                                                    *
-#*                                                                        *
-#*   All rights reserved.  This file is distributed under the terms of    *
-#*   the GNU Lesser General Public License version 2.1, with the          *
-#*   special exception on linking described in the file LICENSE.          *
-#*                                                                        *
-#**************************************************************************
-
-# Remove private parts from runtime include files, before installation
-# in /usr/local/lib/ocaml/caml
-
-/\/\* <include \.\.\/config\/m\.h> \*\// {
-  r ../config/m.h
-  d
-}
-/\/\* <include \.\.\/config\/s\.h> \*\// {
-  r ../config/s.h
-  d
-}
-/\/\* <private> \*\//,/\/\* <\/private> \*\//d

diff --git a/tools/cmt2annot.ml b/tools/cmt2annot.ml
index 53299f98673548ae308247dec79a136ce9992e31..ef044bebe1a3bc4609ce320a3e6842ee46425eb4 100644 (file)
--- a/tools/cmt2annot.ml
+++ b/tools/cmt2annot.ml
@@ -29,7 +29,7 @@ let bind_variables scope =
                                         Annot.Idef scope))
     | _ -> ()
     end;
-    super.pat sub p;
+    super.pat sub p
   in
   {super with pat}
 
@@ -54,6 +54,12 @@ let bind_cases l =
     )
     l
 
+let record_module_binding scope mb =
+  Stypes.record (Stypes.An_ident
+                   (mb.mb_name.loc,
+                    mb.mb_name.txt,
+                    Annot.Idef scope))
+
 let rec iterator ~scope rebuild_env =
   let super = Tast_mapper.default in
   let class_expr sub node =
@@ -99,6 +105,9 @@ let rec iterator ~scope rebuild_env =
     | Texp_function { cases = f; }
     | Texp_try (_, f) ->
         bind_cases f
+    | Texp_letmodule (_, modname, _, body ) ->
+        Stypes.record (Stypes.An_ident
+                       (modname.loc,modname.txt,Annot.Idef body.exp_loc))
     | _ -> ()
     end;
     Stypes.record (Stypes.Ti_expr exp);
@@ -109,21 +118,28 @@ let rec iterator ~scope rebuild_env =
     super.pat sub p
   in
 
-  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 structure_item_rem sub str rem =
+    let open Location in
+    let loc = str.str_loc in
+    begin match str.str_desc with
+    | Tstr_value (rec_flag, bindings) ->
         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
+    | Tstr_module mb ->
+        record_module_binding
+          { scope with Location.loc_start = loc.loc_end } mb
+    | Tstr_recmodule mbs ->
+        List.iter (record_module_binding
+                   { scope with Location.loc_start = loc.loc_start }) mbs
     | _ ->
         ()
     end;
-    Stypes.record_phrase s.str_loc;
-    super.structure_item sub s
+    Stypes.record_phrase loc;
+    super.structure_item sub str
   in
   let structure_item sub s =
     (* This will be used for Partial_structure_item.
@@ -153,19 +169,45 @@ let binary_part iter 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; _} =
+(* Save cmt information as faked annotations, attached to
+   Location.none, on top of the .annot file. Only when -save-cmt-info is
+   provided to ocaml_cmt.
+*)
+let record_cmt_info cmt =
+  let location_none = {
+    Location.none with Location.loc_ghost = false }
+  in
+  let location_file file = {
+    Location.none with
+      Location.loc_start = {
+        Location.none.Location.loc_start with
+          Lexing.pos_fname = file }}
+  in
+  let record_info name value =
+    let ident = Printf.sprintf ".%s" name in
+    Stypes.record (Stypes.An_ident (location_none, ident,
+                                    Annot.Idef (location_file value)))
+  in
+  let open Cmt_format in
+  (* record in reverse order to get them in correct order... *)
+  List.iter (fun dir -> record_info "include" dir) (List.rev cmt.cmt_loadpath);
+  record_info "chdir" cmt.cmt_builddir;
+  (match cmt.cmt_sourcefile with
+    None -> () | Some file -> record_info "source" file)
+
+let gen_annot ?(save_cmt_info=false) target_filename filename cmt =
   let open Cmt_format in
   Envaux.reset_cache ();
-  Config.load_path := cmt_loadpath;
+  Config.load_path := cmt.cmt_loadpath @ !Config.load_path;
   let target_filename =
     match target_filename with
     | None -> Some (filename ^ ".annot")
     | Some "-" -> None
     | Some _ -> target_filename
   in
-  let iterator = iterator ~scope:Location.none cmt_use_summaries in
-  match cmt_annots with
+  if save_cmt_info then record_cmt_info cmt;
+  let iterator = iterator ~scope:Location.none cmt.cmt_use_summaries in
+  match cmt.cmt_annots with
   | Implementation typedtree ->
       ignore (iterator.structure iterator typedtree);
       Stypes.dump target_filename
@@ -175,26 +217,27 @@ let gen_annot target_filename filename
   | Partial_implementation parts ->
       Array.iter (binary_part iterator) parts;
       Stypes.dump target_filename
-  | _ ->
+  | Packed _ ->
+      Printf.fprintf stderr "Packed files not yet supported\n%!";
+      Stypes.dump target_filename
+  | Partial_interface _ ->
       Printf.fprintf stderr "File was generated with an error\n%!";
       exit 2
 
-
-
 let gen_ml target_filename filename cmt =
   let (printer, ext) =
     match cmt.Cmt_format.cmt_annots with
       | Cmt_format.Implementation typedtree ->
-        (fun ppf -> Pprintast.structure ppf
+          (fun ppf -> Pprintast.structure ppf
                                         (Untypeast.untype_structure typedtree)),
-        ".ml"
+          ".ml"
       | Cmt_format.Interface typedtree ->
-        (fun ppf -> Pprintast.signature ppf
+          (fun ppf -> Pprintast.signature ppf
                                         (Untypeast.untype_signature typedtree)),
-        ".mli"
+          ".mli"
       | _ ->
         Printf.fprintf stderr "File was generated with an error\n%!";
-        exit 2
+          exit 2
   in
   let target_filename = match target_filename with
       None -> Some (filename ^ ext)

diff --git a/tools/dumpobj.ml b/tools/dumpobj.ml
index c3d60bff0fd26a2ea76a574bc15caff0c0dec789..4945051183a20e9e3f61712d93a6decdf6125ca3 100644 (file)
--- a/tools/dumpobj.ml
+++ b/tools/dumpobj.ml
@@ -122,11 +122,11 @@ let rec print_obj x =
     else if tag = Obj.double_tag then
         printf "%.12g" (Obj.magic x : float)
     else if tag = Obj.double_array_tag then begin
-        let a = (Obj.magic x : float array) in
+        let a = (Obj.magic x : floatarray) in
         printf "[|";
-        for i = 0 to Array.length a - 1 do
+        for i = 0 to Array.Floatarray.length a - 1 do
           if i > 0 then printf ", ";
-          printf "%.12g" a.(i)
+          printf "%.12g" (Array.Floatarray.get a i)
         done;
         printf "|]"
     end else if tag = Obj.custom_tag && same_custom x 0l then

diff --git a/tools/lintapidiff.ml b/tools/lintapidiff.ml
index 87cf1d4b7694bbbebb3104a690abf0e55355ecbb..9422869d06eb3d7861235f6901c97f715275a1fd 100644 (file)
--- a/tools/lintapidiff.ml
+++ b/tools/lintapidiff.ml
@@ -2,6 +2,8 @@
 (*                                                                        *)
 (*                                 OCaml                                  *)
 (*                                                                        *)
+(*                              Edwin Török                               *)
+(*                                                                        *)
 (*   Copyright 2016--2017 Edwin Török                                     *)
 (*                                                                        *)
 (*   All rights reserved.  This file is distributed under the terms of    *)

diff --git a/tools/make_opcodes.mll b/tools/make_opcodes.mll
index 5c7cd854210c96879b750765971b26648a40ef14..67a09a29091258f7779281c3045c52cd42ede7a3 100644 (file)
--- a/tools/make_opcodes.mll
+++ b/tools/make_opcodes.mll
@@ -1,14 +1,17 @@
-(***********************************************************************)
-(*                                                                     *)
-(*                                OCaml                                *)
-(*                                                                     *)
-(*                      Nicolas Ojeda Bar, LexiFi                      *)
-(*                                                                     *)
-(*  Copyright 2016 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.               *)
-(*                                                                     *)
-(***********************************************************************)
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                      Nicolas Ojeda Bar, LexiFi                         *)
+(*                                                                        *)
+(*   Copyright 2016 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
 
 let ident = ['a'-'z''A'-'Z''_']['a'-'z''A'-'Z''0'-'9''_']*
 let space = [' ''\n''\r''\t']*

diff --git a/tools/objinfo_helper.c b/tools/objinfo_helper.c
index 7a36b388f039c100a2e080496600df47574d04a0..3d3ebc1c6d0580c95eedda647dda120fb1209573 100644 (file)
--- a/tools/objinfo_helper.c
+++ b/tools/objinfo_helper.c
@@ -12,7 +12,7 @@
 /*                                                                        */
 /**************************************************************************/
 
-#include "../config/s.h"
+#include "caml/s.h"
 #include <stdio.h>
 
 #ifdef HAS_LIBBFD

diff --git a/tools/ocamlcp.ml b/tools/ocamlcp.ml
index 278952f75ed22fa18fac66ca9bc9d104c34016c2..0aeaf2ce1bf6ce4aef7618ddd7a75c2c9ca2bbab 100644 (file)
--- a/tools/ocamlcp.ml
+++ b/tools/ocamlcp.ml
@@ -126,6 +126,7 @@ module Options = Main_args.Make_bytecomp_options (struct
   let _dflambda = option "-dflambda"
   let _dinstr = option "-dinstr"
   let _dtimings = option "-dtimings"
+  let _dprofile = option "-dprofile"
   let _args = Arg.read_arg
   let _args0 = Arg.read_arg0
   let anonymous = process_file

diff --git a/tools/ocamldep.ml b/tools/ocamldep.ml
index 215de187eabd57f33fc7638489c973835cefaa54..e1971fa894d6496be260563c2e2e4db27219733e 100644 (file)
--- a/tools/ocamldep.ml
+++ b/tools/ocamldep.ml
@@ -1,608 +1 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                 OCaml                                  *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 1999 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
-open Compenv
-open Parsetree
-module StringMap = Depend.StringMap
-
-let ppf = Format.err_formatter
-(* Print the dependencies *)
-
-type file_kind = ML | MLI;;
-
-let load_path = ref ([] : (string * string array) list)
-let ml_synonyms = ref [".ml"]
-let mli_synonyms = ref [".mli"]
-let native_only = ref false
-let bytecode_only = ref false
-let error_occurred = ref false
-let raw_dependencies = ref false
-let sort_files = ref false
-let all_dependencies = ref false
-let one_line = ref false
-let files = ref []
-let allow_approximation = ref false
-let map_files = ref []
-let module_map = ref StringMap.empty
-let debug = ref false
-
-(* Fix path to use '/' as directory separator instead of '\'.
-   Only under Windows. *)
-
-let fix_slash s =
-  if Sys.os_type = "Unix" then s else begin
-    String.map (function '\\' -> '/' | c -> c) s
-  end
-
-(* Since we reinitialize load_path after reading OCAMLCOMP,
-  we must use a cache instead of calling Sys.readdir too often. *)
-let dirs = ref StringMap.empty
-let readdir dir =
-  try
-    StringMap.find dir !dirs
-  with Not_found ->
-    let contents =
-      try
-        Sys.readdir dir
-      with Sys_error msg ->
-        Format.fprintf Format.err_formatter "@[Bad -I option: %s@]@." msg;
-        error_occurred := true;
-        [||]
-    in
-    dirs := StringMap.add dir contents !dirs;
-    contents
-
-let add_to_list li s =
-  li := s :: !li
-
-let add_to_load_path dir =
-  try
-    let dir = Misc.expand_directory Config.standard_library dir in
-    let contents = readdir dir in
-    add_to_list load_path (dir, contents)
-  with Sys_error msg ->
-    Format.fprintf Format.err_formatter "@[Bad -I option: %s@]@." msg;
-    error_occurred := true
-
-let add_to_synonym_list synonyms suffix =
-  if (String.length suffix) > 1 && suffix.[0] = '.' then
-    add_to_list synonyms suffix
-  else begin
-    Format.fprintf Format.err_formatter "@[Bad suffix: '%s'@]@." suffix;
-    error_occurred := true
-  end
-
-(* Find file 'name' (capitalized) in search path *)
-let find_file name =
-  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
-      if s = name || s = uname then Some s else find_in_array a (pos + 1)
-    end in
-  let rec find_in_path = function
-    [] -> raise Not_found
-  | (dir, contents) :: rem ->
-      match find_in_array contents 0 with
-        Some truename ->
-          if dir = "." then truename else Filename.concat dir truename
-      | None -> find_in_path rem in
-  find_in_path !load_path
-
-let rec find_file_in_list = function
-  [] -> raise Not_found
-| x :: rem -> try find_file x with Not_found -> find_file_in_list rem
-
-
-let find_dependency target_kind modname (byt_deps, opt_deps) =
-  try
-    let candidates = List.map ((^) modname) !mli_synonyms in
-    let filename = find_file_in_list candidates in
-    let basename = Filename.chop_extension filename in
-    let cmi_file = basename ^ ".cmi" in
-    let cmx_file = basename ^ ".cmx" in
-    let ml_exists =
-      List.exists (fun ext -> Sys.file_exists (basename ^ ext)) !ml_synonyms in
-    let new_opt_dep =
-      if !all_dependencies then
-        match target_kind with
-        | MLI -> [ cmi_file ]
-        | ML  ->
-          cmi_file :: (if ml_exists then [ cmx_file ] else [])
-      else
-        (* this is a make-specific hack that makes .cmx to be a 'proxy'
-           target that would force the dependency on .cmi via transitivity *)
-        if ml_exists
-        then [ cmx_file ]
-        else [ cmi_file ]
-    in
-    ( cmi_file :: byt_deps, new_opt_dep @ opt_deps)
-  with Not_found ->
-  try
-    (* "just .ml" case *)
-    let candidates = List.map ((^) modname) !ml_synonyms in
-    let filename = find_file_in_list candidates in
-    let basename = Filename.chop_extension filename in
-    let cmi_file = basename ^ ".cmi" in
-    let cmx_file = basename ^ ".cmx" in
-    let bytenames =
-      if !all_dependencies then
-        match target_kind with
-        | MLI -> [ cmi_file ]
-        | ML  -> [ cmi_file ]
-      else
-        (* again, make-specific hack *)
-        [basename ^ (if !native_only then ".cmx" else ".cmo")] in
-    let optnames =
-      if !all_dependencies
-      then match target_kind with
-        | MLI -> [ cmi_file ]
-        | ML  -> [ cmi_file; cmx_file ]
-      else [ cmx_file ]
-    in
-    (bytenames @ byt_deps, optnames @  opt_deps)
-  with Not_found ->
-    (byt_deps, opt_deps)
-
-let (depends_on, escaped_eol) = (":", " \\\n    ")
-
-let print_filename s =
-  let s = if !Clflags.force_slash then fix_slash s else s in
-  if not (String.contains s ' ') then begin
-    print_string s;
-  end else begin
-    let rec count n i =
-      if i >= String.length s then n
-      else if s.[i] = ' ' then count (n+1) (i+1)
-      else count n (i+1)
-    in
-    let spaces = count 0 0 in
-    let result = Bytes.create (String.length s + spaces) in
-    let rec loop i j =
-      if i >= String.length s then ()
-      else if s.[i] = ' ' then begin
-        Bytes.set result j '\\';
-        Bytes.set result (j+1) ' ';
-        loop (i+1) (j+2);
-      end else begin
-        Bytes.set result j s.[i];
-        loop (i+1) (j+1);
-      end
-    in
-    loop 0 0;
-    print_bytes result;
-  end
-;;
-
-let print_dependencies target_files deps =
-  let rec print_items pos = function
-    [] -> print_string "\n"
-  | dep :: rem ->
-    if !one_line || (pos + 1 + String.length dep <= 77) then begin
-        if pos <> 0 then print_string " "; print_filename dep;
-        print_items (pos + String.length dep + 1) rem
-      end else begin
-        print_string escaped_eol; print_filename dep;
-        print_items (String.length dep + 4) rem
-      end in
-  print_items 0 (target_files @ [depends_on] @ deps)
-
-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' | '\128'..'\255' -> true
-              | _ -> false) then
-        begin
-          print_char ' ';
-          print_string dep
-        end)
-    deps;
-  print_char '\n'
-
-
-(* Process one file *)
-
-let report_err exn =
-  error_occurred := true;
-  match exn with
-    | Sys_error msg ->
-        Format.fprintf Format.err_formatter "@[I/O error:@ %s@]@." msg
-    | x ->
-        match Location.error_of_exn x with
-        | Some err ->
-            Format.fprintf Format.err_formatter "@[%a@]@."
-              Location.report_error err
-        | None -> raise x
-
-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;
-  Depend.free_structure_names := Depend.StringSet.empty;
-  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 def ast_kind
-                           source_file =
-  Depend.free_structure_names := Depend.StringSet.empty;
-  try
-    let input_file = Pparse.preprocess source_file in
-    begin try
-      let ast =
-        Pparse.file ~tool_name Format.err_formatter
-                    input_file parse_function ast_kind
-      in
-      let bound_vars =
-        List.fold_left
-          (fun bv modname ->
-            Depend.open_module bv (Longident.parse modname))
-          !module_map ((* PR#7248 *) List.rev !Clflags.open_modules)
-      in
-      let r = extract_function bound_vars ast in
-      Pparse.remove_preprocessed input_file;
-      (!Depend.free_structure_names, r)
-    with x ->
-      Pparse.remove_preprocessed input_file;
-      raise x
-    end
-  with x -> begin
-    report_err x;
-    if not !allow_approximation
-    then (Depend.StringSet.empty, def)
-    else (read_and_approximate source_file, def)
-  end
-
-let print_ml_dependencies source_file extracted_deps =
-  let basename = Filename.chop_extension source_file in
-  let byte_targets = [ basename ^ ".cmo" ] in
-  let native_targets =
-    if !all_dependencies
-    then [ basename ^ ".cmx"; basename ^ ".o" ]
-    else [ basename ^ ".cmx" ] in
-  let init_deps = if !all_dependencies then [source_file] else [] in
-  let cmi_name = basename ^ ".cmi" in
-  let init_deps, extra_targets =
-    if List.exists (fun ext -> Sys.file_exists (basename ^ ext))
-        !mli_synonyms
-    then (cmi_name :: init_deps, cmi_name :: init_deps), []
-    else (init_deps, init_deps),
-         (if !all_dependencies then [cmi_name] else [])
-  in
-  let (byt_deps, native_deps) =
-    Depend.StringSet.fold (find_dependency ML)
-      extracted_deps init_deps in
-  if not !native_only then
-    print_dependencies (byte_targets @ extra_targets) byt_deps;
-  if not !bytecode_only then
-    print_dependencies (native_targets @ extra_targets) native_deps
-
-let print_mli_dependencies source_file extracted_deps =
-  let basename = Filename.chop_extension source_file in
-  let (byt_deps, _opt_deps) =
-    Depend.StringSet.fold (find_dependency MLI)
-      extracted_deps ([], []) in
-  print_dependencies [basename ^ ".cmi"] byt_deps
-
-let print_file_dependencies (source_file, kind, extracted_deps) =
-  if !raw_dependencies then begin
-    print_raw_dependencies source_file extracted_deps
-  end else
-    match kind with
-    | ML -> print_ml_dependencies source_file extracted_deps
-    | MLI -> print_mli_dependencies source_file extracted_deps
-
-
-let ml_file_dependencies source_file =
-  let parse_use_file_as_impl lexbuf =
-    let f x =
-      match x with
-      | Ptop_def s -> s
-      | Ptop_dir _ -> []
-    in
-    List.flatten (List.map f (Parse.use_file lexbuf))
-  in
-  let (extracted_deps, ()) =
-    read_parse_and_extract parse_use_file_as_impl Depend.add_implementation ()
-                           Pparse.Structure source_file
-  in
-  files := (source_file, ML, extracted_deps) :: !files
-
-let mli_file_dependencies source_file =
-  let (extracted_deps, ()) =
-    read_parse_and_extract Parse.interface Depend.add_signature ()
-                           Pparse.Signature source_file
-  in
-  files := (source_file, MLI, extracted_deps) :: !files
-
-let process_file_as process_fun def source_file =
-  Compenv.readenv ppf (Before_compile source_file);
-  load_path := [];
-  List.iter add_to_load_path (
-      (!Compenv.last_include_dirs @
-       !Clflags.include_dirs @
-       !Compenv.first_include_dirs
-      ));
-  Location.input_name := source_file;
-  try
-    if Sys.file_exists source_file then process_fun source_file else def
-  with x -> report_err x; def
-
-let process_file source_file ~ml_file ~mli_file ~def =
-  if List.exists (Filename.check_suffix source_file) !ml_synonyms then
-    process_file_as ml_file def source_file
-  else if List.exists (Filename.check_suffix source_file) !mli_synonyms then
-    process_file_as mli_file def source_file
-  else def
-
-let file_dependencies source_file =
-  process_file source_file ~def:()
-    ~ml_file:ml_file_dependencies
-    ~mli_file:mli_file_dependencies
-
-let file_dependencies_as kind =
-  match kind with
-  | ML -> process_file_as ml_file_dependencies ()
-  | MLI -> process_file_as mli_file_dependencies ()
-
-let sort_files_by_dependencies files =
-  let h = Hashtbl.create 31 in
-  let worklist = ref [] in
-
-(* Init Hashtbl with all defined modules *)
-  let files = List.map (fun (file, file_kind, deps) ->
-    let modname =
-      String.capitalize_ascii (Filename.chop_extension (Filename.basename file))
-    in
-    let key = (modname, file_kind) in
-    let new_deps = ref [] in
-    Hashtbl.add h key (file, new_deps);
-    worklist := key :: !worklist;
-    (modname, file_kind, deps, new_deps)
-  ) files in
-
-(* Keep only dependencies to defined modules *)
-  List.iter (fun (modname, file_kind, deps, new_deps) ->
-    let add_dep modname kind =
-      new_deps := (modname, kind) :: !new_deps;
-    in
-    Depend.StringSet.iter (fun modname ->
-      match file_kind with
-          ML -> (* ML depends both on ML and MLI *)
-            if Hashtbl.mem h (modname, MLI) then add_dep modname MLI;
-            if Hashtbl.mem h (modname, ML) then add_dep modname ML
-        | MLI -> (* MLI depends on MLI if exists, or ML otherwise *)
-          if Hashtbl.mem h (modname, MLI) then add_dep modname MLI
-          else if Hashtbl.mem h (modname, ML) then add_dep modname ML
-    ) deps;
-    if file_kind = ML then (* add dep from .ml to .mli *)
-      if Hashtbl.mem h (modname, MLI) then add_dep modname MLI
-  ) files;
-
-(* Print and remove all files with no remaining dependency. Iterate
-   until all files have been removed (worklist is empty) or
-   no file was removed during a turn (cycle). *)
-  let printed = ref true in
-  while !printed && !worklist <> [] do
-    let files = !worklist in
-    worklist := [];
-    printed := false;
-    List.iter (fun key ->
-      let (file, deps) = Hashtbl.find h key in
-      let set = !deps in
-      deps := [];
-      List.iter (fun key ->
-        if Hashtbl.mem h key then deps := key :: !deps
-      ) set;
-      if !deps = [] then begin
-        printed := true;
-        Printf.printf "%s " file;
-        Hashtbl.remove h key;
-      end else
-        worklist := key :: !worklist
-    ) files
-  done;
-
-  if !worklist <> [] then begin
-    Format.fprintf Format.err_formatter
-      "@[Warning: cycle in dependencies. End of list is not sorted.@]@.";
-    let sorted_deps =
-      let li = ref [] in
-      Hashtbl.iter (fun _ file_deps -> li := file_deps :: !li) h;
-      List.sort (fun (file1, _) (file2, _) -> String.compare file1 file2) !li
-    in
-    List.iter (fun (file, deps) ->
-      Format.fprintf Format.err_formatter "\t@[%s: " file;
-      List.iter (fun (modname, kind) ->
-        Format.fprintf Format.err_formatter "%s.%s " modname
-          (if kind=ML then "ml" else "mli");
-      ) !deps;
-      Format.fprintf Format.err_formatter "@]@.";
-      Printf.printf "%s " file) sorted_deps;
-  end;
-  Printf.printf "\n%!";
-  ()
-
-(* Map *)
-
-let rec dump_map s0 ppf m =
-  let open Depend in
-  StringMap.iter
-    (fun key (Node(s1,m')) ->
-      let s = StringSet.diff s1 s0 in
-      if StringSet.is_empty s then
-        Format.fprintf ppf "@ @[<hv2>module %s : sig%a@;<1 -2>end@]"
-          key (dump_map (StringSet.union s1 s0)) m'
-      else
-        Format.fprintf ppf "@ module %s = %s" key (StringSet.choose s))
-    m
-
-let process_ml_map =
-  read_parse_and_extract Parse.implementation Depend.add_implementation_binding
-                         StringMap.empty Pparse.Structure
-
-let process_mli_map =
-  read_parse_and_extract Parse.interface Depend.add_signature_binding
-                         StringMap.empty Pparse.Signature
-
-let parse_map fname =
-  map_files := fname :: !map_files ;
-  let old_transp = !Clflags.transparent_modules in
-  Clflags.transparent_modules := true;
-  let (deps, m) =
-    process_file fname ~def:(Depend.StringSet.empty, StringMap.empty)
-      ~ml_file:process_ml_map
-      ~mli_file:process_mli_map
-  in
-  Clflags.transparent_modules := old_transp;
-  let modname =
-    String.capitalize_ascii
-      (Filename.basename (Filename.chop_extension fname)) in
-  if StringMap.is_empty m then
-    report_err (Failure (fname ^ " : empty map file or parse error"));
-  let mm = Depend.make_node m in
-  if !debug then begin
-    Format.printf "@[<v>%s:%t%a@]@." fname
-      (fun ppf -> Depend.StringSet.iter (Format.fprintf ppf " %s") deps)
-      (dump_map deps) (StringMap.add modname mm StringMap.empty)
-  end;
-  let mm = Depend.(weaken_map (StringSet.singleton modname) mm) in
-  module_map := StringMap.add modname mm !module_map
-;;
-
-
-(* Entry point *)
-
-let usage = "Usage: ocamldep [options] <source files>\nOptions are:"
-
-let print_version () =
-  Format.printf "ocamldep, version %s@." Sys.ocaml_version;
-  exit 0;
-;;
-
-let print_version_num () =
-  Format.printf "%s@." Sys.ocaml_version;
-  exit 0;
-;;
-
-let _ =
-  Clflags.classic := false;
-  add_to_list first_include_dirs Filename.current_dir_name;
-  Compenv.readenv ppf Before_args;
-  Clflags.add_arguments __LOC__ [
-     "-absname", Arg.Set Location.absname,
-        " Show absolute filenames in error messages";
-     "-all", Arg.Set all_dependencies,
-        " Generate dependencies on all files";
-     "-allow-approx", Arg.Set allow_approximation,
-        " Fallback to a lexer-based approximation on unparseable files";
-     "-as-map", Arg.Set Clflags.transparent_modules,
-      " Omit delayed dependencies for module aliases (-no-alias-deps -w -49)";
-      (* "compiler uses -no-alias-deps, and no module is coerced"; *)
-     "-debug-map", Arg.Set debug,
-        " Dump the delayed dependency map for each map file";
-     "-I", Arg.String (add_to_list Clflags.include_dirs),
-        "<dir>  Add <dir> to the list of include directories";
-     "-impl", Arg.String (file_dependencies_as ML),
-        "<f>  Process <f> as a .ml file";
-     "-intf", Arg.String (file_dependencies_as MLI),
-        "<f>  Process <f> as a .mli file";
-     "-map", Arg.String parse_map,
-        "<f>  Read <f> and propagate delayed dependencies to following 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),
-        "<e>  Consider <e> as a synonym of the .mli extension";
-     "-modules", Arg.Set raw_dependencies,
-        " Print module dependencies in raw form (not suitable for make)";
-     "-native", Arg.Set native_only,
-        " Generate dependencies for native-code only (no .cmo files)";
-     "-bytecode", Arg.Set bytecode_only,
-        " Generate dependencies for bytecode-code only (no .cmx files)";
-     "-one-line", Arg.Set one_line,
-        " Output one line per file, regardless of the length";
-     "-open", Arg.String (add_to_list Clflags.open_modules),
-        "<module>  Opens the module <module> before typing";
-     "-plugin", Arg.String Compplugin.load,
-         "<plugin>  Load dynamic plugin <plugin>";
-     "-pp", Arg.String(fun s -> Clflags.preprocessor := Some s),
-         "<cmd>  Pipe sources through preprocessor <cmd>";
-     "-ppx", Arg.String (add_to_list first_ppx),
-         "<cmd>  Pipe abstract syntax trees through preprocessor <cmd>";
-     "-slash", Arg.Set Clflags.force_slash,
-         " (Windows) Use forward slash / instead of backslash \\ in file paths";
-     "-sort", Arg.Set sort_files,
-        " Sort files according to their dependencies";
-     "-version", Arg.Unit print_version,
-         " Print version and exit";
-     "-vnum", Arg.Unit print_version_num,
-         " Print version number and exit";
-     "-args", Arg.Expand Arg.read_arg,
-         "<file> Read additional newline separated command line arguments \n\
-         \      from <file>";
-     "-args0", Arg.Expand Arg.read_arg0,
-         "<file> Read additional NUL separated command line arguments from \n\
-         \      <file>"
-  ];
-  Clflags.parse_arguments file_dependencies usage;
-  Compenv.readenv ppf Before_link;
-  if !sort_files then sort_files_by_dependencies !files
-  else List.iter print_file_dependencies (List.sort compare !files);
-  exit (if !error_occurred then 2 else 0)
+let () = Makedepend.main ()

diff --git a/tools/ocamlmklib.ml b/tools/ocamlmklib.ml
index e5dda65e68bf09b92636389ccb9b3e290e427448..3d7fdd6d569f7dbe8476762a28dc75495034e679 100644 (file)
--- a/tools/ocamlmklib.ml
+++ b/tools/ocamlmklib.ml
@@ -101,6 +101,12 @@ let parse_arguments argv =
     else if s = "-linkall" then
       caml_opts := s :: !caml_opts
     else if starts_with s "-l" then
+      let s =
+        if Config.ccomp_type = "msvc" then
+          String.sub s 2 (String.length s - 2) ^ ".lib"
+        else
+          s
+      in
       c_libs := s :: !c_libs
     else if starts_with s "-L" then
      (c_Lopts := s :: !c_Lopts;
@@ -295,7 +301,7 @@ let build_libs () =
                   (Filename.basename !output_c)
                   (Filename.basename !output_c)
                   (String.concat " " (prefix_list "-ccopt " !c_opts))
-                  (make_rpath_ccopt byteccrpath)
+                  (make_rpath_ccopt default_rpath)
                   (String.concat " " (prefix_list "-cclib " !c_libs))
                   (String.concat " " !caml_libs));
   if !native_objs <> [] then
@@ -309,7 +315,7 @@ let build_libs () =
                   (String.concat " " !native_objs)
                   (Filename.basename !output_c)
                   (String.concat " " (prefix_list "-ccopt " !c_opts))
-                  (make_rpath_ccopt nativeccrpath)
+                  (make_rpath_ccopt default_rpath)
                   (String.concat " " (prefix_list "-cclib " !c_libs))
                   (String.concat " " !caml_libs))
 

diff --git a/tools/ocamloptp.ml b/tools/ocamloptp.ml
index 33147ea7430b3f68a26492a7281ca18de1dfeb3d..4683cc0348b8466a1fca5b513e2db8e29286036e 100644 (file)
--- a/tools/ocamloptp.ml
+++ b/tools/ocamloptp.ml
@@ -144,6 +144,7 @@ module Options = Main_args.Make_optcomp_options (struct
   let _color s = option_with_arg "-color" s
   let _where = option "-where"
 
+  let _linscan = option "-linscan"
   let _nopervasives = option "-nopervasives"
   let _dsource = option "-dsource"
   let _dparsetree = option "-dparsetree"
@@ -162,6 +163,8 @@ module Options = Main_args.Make_optcomp_options (struct
   let _dcombine = option "-dcombine"
   let _dcse = option "-dcse"
   let _dlive = option "-dlive"
+  let _davail = option "-davail"
+  let _drunavail = option "-drunavail"
   let _dspill = option "-dspill"
   let _dsplit = option "-dsplit"
   let _dinterf = option "-dinterf"
@@ -171,7 +174,9 @@ module Options = Main_args.Make_optcomp_options (struct
   let _dscheduling = option "-dscheduling"
   let _dlinear = option "-dlinear"
   let _dstartup = option "-dstartup"
+  let _dinterval = option "-dinterval"
   let _dtimings = option "-dtimings"
+  let _dprofile = option "-dprofile"
   let _opaque = option "-opaque"
 
   let _args = Arg.read_arg

diff --git a/tools/ocamlprof.ml b/tools/ocamlprof.ml
index fb08ffd5ea10c7acda72e0c999da54277037fcd5..2e72d52cf0e63dcad1857846bc9e380abae2a12a 100644 (file)
--- a/tools/ocamlprof.ml
+++ b/tools/ocamlprof.ml
@@ -367,6 +367,7 @@ and rewrite_class_expr iflag cexpr =
   | Pcl_let (_, spat_sexp_list, cexpr) ->
       rewrite_patexp_list iflag spat_sexp_list;
       rewrite_class_expr iflag cexpr
+  | Pcl_open (_, _, cexpr)
   | Pcl_constraint (cexpr, _) ->
       rewrite_class_expr iflag cexpr
   | Pcl_extension _ -> ()

diff --git a/tools/read_cmt.ml b/tools/read_cmt.ml
index ea8e3c05a459bb95ab6d919652befdb16eff9c25..1e221339f19028eaa70fbfc181220a2567aee1aa 100644 (file)
--- a/tools/read_cmt.ml
+++ b/tools/read_cmt.ml
@@ -17,20 +17,27 @@ let gen_annot = ref false
 let gen_ml = ref false
 let print_info_arg = ref false
 let target_filename = ref None
+let save_cmt_info = ref false
 
-let arg_list = [
+let arg_list = Arg.align [
   "-o", Arg.String (fun s -> target_filename := Some s),
-    " FILE (or -) : dump to file FILE (or stdout)";
-  "-annot", Arg.Set gen_annot, " : generate the corresponding .annot file";
+    "<file> Dump to file <file> (or stdout if -)";
+  "-annot", Arg.Set gen_annot,
+    " Generate the corresponding .annot file";
+  "-save-cmt-info", Arg.Set save_cmt_info,
+    " Encapsulate additional cmt information in annotations";
   "-src", Arg.Set gen_ml,
-    " : convert .cmt or .cmti back to source code (without comments)";
+    " Convert .cmt or .cmti back to source code (without comments)";
   "-info", Arg.Set print_info_arg, " : print information on the file";
   "-args", Arg.Expand Arg.read_arg,
-    " <file> Read additional newline separated command line arguments \n\
+    "<file> Read additional newline separated command line arguments \n\
     \      from <file>";
   "-args0", Arg.Expand Arg.read_arg0,
     "<file> Read additional NUL separated command line arguments from \n\
     \      <file>";
+  "-I", Arg.String (fun s ->
+    Clflags.include_dirs := s :: !Clflags.include_dirs),
+    "<dir> Add <dir> to the list of include directories";
   ]
 
 let arg_usage =
@@ -39,50 +46,58 @@ let arg_usage =
 let dummy_crc = String.make 32 '-'
 
 let print_info cmt =
+  let oc = match !target_filename with
+    | None -> stdout
+    | Some filename -> open_out filename
+  in
   let open Cmt_format in
-      Printf.printf "module name: %s\n" cmt.cmt_modname;
-      begin match cmt.cmt_annots with
-          Packed (_, list) ->
-            Printf.printf "pack: %s\n" (String.concat " " list)
-        | Implementation _ -> Printf.printf "kind: implementation\n"
-        | Interface _ -> Printf.printf "kind: interface\n"
-        | Partial_implementation _ ->
-            Printf.printf "kind: implementation with errors\n"
-        | Partial_interface _ -> Printf.printf "kind: interface with errors\n"
-      end;
-      Printf.printf "command: %s\n"
-                    (String.concat " " (Array.to_list cmt.cmt_args));
-      begin match cmt.cmt_sourcefile with
-          None -> ()
-        | Some name ->
-          Printf.printf "sourcefile: %s\n" name;
-      end;
-      Printf.printf "build directory: %s\n" cmt.cmt_builddir;
-      List.iter (Printf.printf "load path: %s\n%!") cmt.cmt_loadpath;
-      begin
-      match cmt.cmt_source_digest with
-          None -> ()
-        | Some digest ->
-            Printf.printf "source digest: %s\n" (Digest.to_hex digest);
-      end;
-      begin
-      match cmt.cmt_interface_digest with
-          None -> ()
-        | Some digest ->
-            Printf.printf "interface digest: %s\n" (Digest.to_hex digest);
-      end;
-      List.iter (fun (name, crco) ->
-        let crc =
-          match crco with
-            None -> dummy_crc
-          | Some crc -> Digest.to_hex crc
-        in
-          Printf.printf "import: %s %s\n" name crc;
-      ) (List.sort compare cmt.cmt_imports);
-      Printf.printf "%!";
-      ()
+  Printf.fprintf oc "module name: %s\n" cmt.cmt_modname;
+  begin match cmt.cmt_annots with
+    Packed (_, list) ->
+      Printf.fprintf oc "pack: %s\n" (String.concat " " list)
+  | Implementation _ -> Printf.fprintf oc "kind: implementation\n"
+  | Interface _ -> Printf.fprintf oc "kind: interface\n"
+  | Partial_implementation _ ->
+    Printf.fprintf oc "kind: implementation with errors\n"
+  | Partial_interface _ -> Printf.fprintf oc "kind: interface with errors\n"
+  end;
+  Printf.fprintf oc "command: %s\n"
+    (String.concat " " (Array.to_list cmt.cmt_args));
+  begin match cmt.cmt_sourcefile with
+    None -> ()
+  | Some name ->
+    Printf.fprintf oc "sourcefile: %s\n" name;
+  end;
+  Printf.fprintf oc "build directory: %s\n" cmt.cmt_builddir;
+  List.iter (Printf.fprintf oc "load path: %s\n%!") cmt.cmt_loadpath;
+  begin
+    match cmt.cmt_source_digest with
+      None -> ()
+    | Some digest ->
+      Printf.fprintf oc "source digest: %s\n" (Digest.to_hex digest);
+  end;
+  begin
+    match cmt.cmt_interface_digest with
+      None -> ()
+    | Some digest ->
+      Printf.fprintf oc "interface digest: %s\n" (Digest.to_hex digest);
+  end;
+  List.iter (fun (name, crco) ->
+    let crc =
+      match crco with
+        None -> dummy_crc
+      | Some crc -> Digest.to_hex crc
+    in
+    Printf.fprintf oc "import: %s %s\n" name crc;
+  ) (List.sort compare cmt.cmt_imports);
+  Printf.fprintf oc "%!";
+  begin match !target_filename with
+  | None -> ()
+  | Some _ -> close_out oc
+  end;
+  ()
 
-let _ =
+let main () =
   Clflags.annotations := true;
 
   Arg.parse_expand arg_list  (fun filename ->
@@ -90,9 +105,11 @@ let _ =
       Filename.check_suffix filename ".cmt" ||
         Filename.check_suffix filename ".cmti"
     then begin
-      (*      init_path(); *)
+      Compmisc.init_path false;
       let cmt = Cmt_format.read_cmt filename in
-      if !gen_annot then Cmt2annot.gen_annot !target_filename filename cmt;
+      if !gen_annot then
+        Cmt2annot.gen_annot ~save_cmt_info: !save_cmt_info
+          !target_filename filename cmt;
       if !gen_ml then Cmt2annot.gen_ml !target_filename filename cmt;
       if !print_info_arg || not (!gen_ml || !gen_annot) then print_info cmt;
     end else begin
@@ -101,3 +118,13 @@ let _ =
       Arg.usage arg_list arg_usage
     end
   ) arg_usage
+
+
+let () =
+  try
+    main ()
+  with x ->
+    Printf.eprintf "Exception in main ()\n%!";
+    Location.report_exception Format.err_formatter x;
+    Format.fprintf Format.err_formatter "@.";
+    exit 2

diff --git a/toplevel/genprintval.ml b/toplevel/genprintval.ml
index 8c7ce6602c0f7ffc39fa20db0a0bfefd08255ded..09b8fbeb5d82deef9bbe384ea6eb134d18c3d8e5 100644 (file)
--- a/toplevel/genprintval.ml
+++ b/toplevel/genprintval.ml
@@ -25,11 +25,14 @@ open Outcometree
 module type OBJ =
   sig
     type t
+    val repr : 'a -> t
     val obj : t -> 'a
     val is_block : t -> bool
     val tag : t -> int
     val size : t -> int
     val field : t -> int -> t
+    val double_array_tag : int
+    val double_field : t -> int -> float
   end
 
 module type EVALPATH =
@@ -95,7 +98,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
                (* Note: this could be a char or a constant constructor... *)
           else if O.tag arg = Obj.string_tag then
             list :=
-              Oval_string (String.escaped (O.obj arg : string)) :: !list
+              Oval_string ((O.obj arg : string), max_int, Ostr_string) :: !list
           else if O.tag arg = Obj.double_tag then
             list := Oval_float (O.obj arg : float) :: !list
           else
@@ -137,9 +140,6 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
       ( 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))) );
@@ -301,6 +301,16 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
                     Oval_array (List.rev (tree_of_items [] 0))
               else
                 Oval_array []
+
+          | Tconstr(path, [], _)
+              when Path.same path Predef.path_string ->
+            Oval_string ((O.obj obj : string), !printer_steps, Ostr_string)
+
+          | Tconstr (path, [], _)
+              when Path.same path Predef.path_bytes ->
+            let s = Bytes.to_string (O.obj obj : bytes) in
+            Oval_string (s, !printer_steps, Ostr_bytes)
+
           | Tconstr (path, [ty_arg], _)
             when Path.same path Predef.path_lazy_t ->
              let obj_tag = O.tag obj in
@@ -486,9 +496,17 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
                 if pos = 0 then tree_of_label env path name
                 else Oide_ident name
               and v =
-                if unboxed
-                then tree_of_val (depth - 1) obj ty_arg
-                else nest tree_of_val (depth - 1) (O.field obj pos) ty_arg
+                if unboxed then
+                  tree_of_val (depth - 1) obj ty_arg
+                else begin
+                  let fld =
+                    if O.tag obj = O.double_array_tag then
+                      O.repr (O.double_field obj pos)
+                    else
+                      O.field obj pos
+                  in
+                  nest tree_of_val (depth - 1) fld ty_arg
+                end
               in
               (lid, v) :: tree_of_fields (pos + 1) remainder
         in

diff --git a/toplevel/genprintval.mli b/toplevel/genprintval.mli
index 744aaaea9055d369acb6088646ae43242958611e..e45050e90228681a795190641f2072d9e27b29c0 100644 (file)
--- a/toplevel/genprintval.mli
+++ b/toplevel/genprintval.mli
@@ -21,11 +21,14 @@ open Format
 module type OBJ =
   sig
     type t
+    val repr : 'a -> t
     val obj : t -> 'a
     val is_block : t -> bool
     val tag : t -> int
     val size : t -> int
     val field : t -> int -> t
+    val double_array_tag : int
+    val double_field : t -> int -> float
   end
 
 module type EVALPATH =

diff --git a/toplevel/opttoploop.ml b/toplevel/opttoploop.ml
index 6ca12efa5fb1af100d1393600e2015682bebbc05..d5a45ee1181c4fe28ff5a36842a4f1c0c3a72ada 100644 (file)
--- a/toplevel/opttoploop.ml
+++ b/toplevel/opttoploop.ml
@@ -220,15 +220,14 @@ let load_lambda ppf ~module_ident ~required_globals lam size =
   in
   let fn = Filename.chop_extension dll in
   if not Config.flambda then
-    Asmgen.compile_implementation_clambda ~source_provenance:Timings.Toplevel
+    Asmgen.compile_implementation_clambda
       ~toplevel:need_symbol fn ppf
       { Lambda.code=slam ; main_module_block_size=size;
         module_ident; required_globals }
   else
-    Asmgen.compile_implementation_flambda ~source_provenance:Timings.Toplevel
+    Asmgen.compile_implementation_flambda
       ~required_globals ~backend ~toplevel:need_symbol fn ppf
-      (Middle_end.middle_end ppf
-         ~source_provenance:Timings.Toplevel ~prefixname:"" ~backend ~size
+      (Middle_end.middle_end ppf ~prefixname:"" ~backend ~size
          ~module_ident ~module_initializer:slam ~filename:"toplevel");
   Asmlink.call_linker_shared [fn ^ ext_obj] dll;
   Sys.remove (fn ^ ext_obj);
@@ -281,8 +280,7 @@ let execute_phrase print_outcome ppf phr =
       let oldenv = !toplevel_env in
       incr phrase_seqid;
       phrase_name := Printf.sprintf "TOP%i" !phrase_seqid;
-      Compilenv.reset ~source_provenance:Timings.Toplevel
-        ?packname:None !phrase_name;
+      Compilenv.reset ?packname:None !phrase_name;
       Typecore.reset_delayed_checks ();
       let sstr, rewritten =
         match sstr with

diff --git a/toplevel/opttopmain.ml b/toplevel/opttopmain.ml
index 96d22185df7611a8e35eeed84e7d8c9b59d0ae3a..f199d44d952f36eff0d751d19746388374873c96 100644 (file)
--- a/toplevel/opttopmain.ml
+++ b/toplevel/opttopmain.ml
@@ -178,6 +178,7 @@ module Options = Main_args.Make_opttop_options (struct
   let _labels = clear classic
   let _alias_deps = clear transparent_modules
   let _no_alias_deps = set transparent_modules
+  let _dlinscan = set use_linscan
   let _app_funct = set applicative_functors
   let _no_app_funct = clear applicative_functors
   let _noassert = set noassert
@@ -221,6 +222,8 @@ module Options = Main_args.Make_opttop_options (struct
   let _dcombine = set dump_combine
   let _dcse = set dump_cse
   let _dlive () = dump_live := true; Printmach.print_live := true
+  let _davail () = dump_avail := true
+  let _drunavail () = debug_runavail := true
   let _dspill = set dump_spill
   let _dsplit = set dump_split
   let _dinterf = set dump_interf
@@ -229,11 +232,11 @@ module Options = Main_args.Make_opttop_options (struct
   let _dreload = set dump_reload
   let _dscheduling = set dump_scheduling
   let _dlinear = set dump_linear
+  let _dinterval = set dump_interval
   let _dstartup = set keep_startup_file
   let _safe_string = clear unsafe_string
   let _unsafe_string = set unsafe_string
   let _open s = open_modules := s :: !open_modules
-  let _plugin p = Compplugin.load p
 
   let _args = wrap_expand Arg.read_arg
   let _args0 = wrap_expand Arg.read_arg0
@@ -252,4 +255,5 @@ let main () =
     | Arg.Help msg -> Format.fprintf Format.std_formatter "%s%!" msg; exit 0
   end;
   if not (prepare Format.err_formatter) then exit 2;
+  Compmisc.init_path true;
   Opttoploop.loop Format.std_formatter

diff --git a/toplevel/topdirs.ml b/toplevel/topdirs.ml
index a28ee990a6c8ad0ad2cd7ab502a63724417b7edd..c956513bece066c3803747118099e1c97e1236dc 100644 (file)
--- a/toplevel/topdirs.ml
+++ b/toplevel/topdirs.ml
@@ -621,7 +621,7 @@ let () =
     {
       section = section_env;
       doc = "Print the signatures of components \
-             from any of the above categories.";
+             from any of the categories below.";
     }
 
 let _ = add_directive "trace"

diff --git a/toplevel/topmain.ml b/toplevel/topmain.ml
index 1a8757b3318d387e031f169d1e02d37a8d723494..083b427eeeb02ccb9cbadc8aff672221e889081c 100644 (file)
--- a/toplevel/topmain.ml
+++ b/toplevel/topmain.ml
@@ -115,7 +115,6 @@ module Options = Main_args.Make_bytetop_options (struct
   let _nopromptcont = set nopromptcont
   let _nostdlib = set no_std_include
   let _open s = open_modules := s :: !open_modules
-  let _plugin p = Compplugin.load p
   let _ppx s = first_ppx := s :: !first_ppx
   let _principal = set principal
   let _no_principal = clear principal
@@ -144,7 +143,8 @@ module Options = Main_args.Make_bytetop_options (struct
   let _drawlambda = set dump_rawlambda
   let _dlambda = set dump_lambda
   let _dflambda = set dump_flambda
-  let _dtimings = set print_timings
+  let _dtimings () = profile_columns := [ `Time ]
+  let _dprofile () = profile_columns := Profile.all_columns
   let _dinstr = set dump_instr
 
   let _args = wrap_expand Arg.read_arg
@@ -167,4 +167,5 @@ let main () =
   end;
   Compenv.readenv ppf Before_link;
   if not (prepare ppf) then exit 2;
+  Compmisc.init_path false;
   Toploop.loop Format.std_formatter

diff --git a/typing/HACKING.adoc b/typing/HACKING.adoc
index 101bf8ed86e4ffa0a9b1ca80799cfe37f7046266..8633ef52ed6e6aa607c8bbb98069b333daf0e95c 100644 (file)
--- a/typing/HACKING.adoc
+++ b/typing/HACKING.adoc
@@ -3,7 +3,7 @@ will need a good understanding of the OCaml type system and type
 inference. Here is a reading list to ease your discovery of the
 typechecker:
 
-http://caml.inria.fr/pub/docs/u3-ocaml/index.html[Using, Understanding, and Unraveling the OCaml Language by Didier Rémy] ::
+http://caml.inria.fr/pub/docs/u3-ocaml/index.html[Using, Understanding, and Unraveling the OCaml Language by Didier Rémy] ::
 This book provides (among other things) a formal description of parts
 of the core OCaml language, starting with a simple Core ML.
 

diff --git a/typing/cmt_format.ml b/typing/cmt_format.ml
index 56cfba39034c9e3e08009897e0cdc26a753b78d1..fda1a4a56f1ea3a76d86af00540a70461a0300a1 100644 (file)
--- a/typing/cmt_format.ml
+++ b/typing/cmt_format.ml
@@ -166,30 +166,31 @@ let record_value_dependency vd1 vd2 =
 
 let save_cmt filename modname binary_annots sourcefile initial_env cmi =
   if !Clflags.binary_annotations && not !Clflags.print_types then begin
-    let oc = open_out_bin filename in
-    let this_crc =
-      match cmi with
-      | None -> None
-      | Some cmi -> Some (output_cmi filename oc cmi)
-    in
-    let source_digest = Misc.may_map Digest.file sourcefile in
-    let cmt = {
-      cmt_modname = modname;
-      cmt_annots = clear_env binary_annots;
-      cmt_value_dependencies = !value_deps;
-      cmt_comments = Lexer.comments ();
-      cmt_args = Sys.argv;
-      cmt_sourcefile = sourcefile;
-      cmt_builddir =  Sys.getcwd ();
-      cmt_loadpath = !Config.load_path;
-      cmt_source_digest = source_digest;
-      cmt_initial_env = if need_to_clear_env then
-          keep_only_summary initial_env else initial_env;
-      cmt_imports = List.sort compare (Env.imports ());
-      cmt_interface_digest = this_crc;
-      cmt_use_summaries = need_to_clear_env;
-    } in
-    output_cmt oc cmt;
-    close_out oc;
+    Misc.output_to_file_via_temporary
+       ~mode:[Open_binary] filename
+       (fun temp_file_name oc ->
+         let this_crc =
+           match cmi with
+           | None -> None
+           | Some cmi -> Some (output_cmi temp_file_name oc cmi)
+         in
+         let source_digest = Misc.may_map Digest.file sourcefile in
+         let cmt = {
+           cmt_modname = modname;
+           cmt_annots = clear_env binary_annots;
+           cmt_value_dependencies = !value_deps;
+           cmt_comments = Lexer.comments ();
+           cmt_args = Sys.argv;
+           cmt_sourcefile = sourcefile;
+           cmt_builddir =  Sys.getcwd ();
+           cmt_loadpath = !Config.load_path;
+           cmt_source_digest = source_digest;
+           cmt_initial_env = if need_to_clear_env then
+               keep_only_summary initial_env else initial_env;
+           cmt_imports = List.sort compare (Env.imports ());
+           cmt_interface_digest = this_crc;
+           cmt_use_summaries = need_to_clear_env;
+         } in
+         output_cmt oc cmt)
   end;
   clear ()

diff --git a/typing/ctype.ml b/typing/ctype.ml
index 3135e4a2949f001b00a32268b20bae1492d443e5..df46de1f6763bb3b85b0a99c0a7b27a9a56e0949 100644 (file)
--- a/typing/ctype.ml
+++ b/typing/ctype.ml
@@ -26,7 +26,7 @@ open Btype
    If one wants to manipulate a type after type inference (for
    instance, during code generation or in the debugger), one must
    first make sure that the type levels are correct, using the
-   function [correct_levels]. Then, this type can be correctely
+   function [correct_levels]. Then, this type can be correctly
    manipulated by [apply], [expand_head] and [moregeneral].
 *)
 
@@ -699,7 +699,7 @@ let rec normalize_package_path env p =
           normalize_package_path env (Path.Pdot (p1', s, n))
       | _ -> p
 
-let rec update_level env level ty =
+let rec update_level env level expand ty =
   let ty = repr ty in
   if ty.level > level then begin
     begin match Env.gadt_instance_level env ty with
@@ -712,22 +712,30 @@ let rec update_level env level ty =
         begin try
           (* if is_newtype env p then raise Cannot_expand; *)
           link_type ty (!forward_try_expand_once env ty);
-          update_level env level ty
+          update_level env level expand ty
         with Cannot_expand ->
           (* +++ Levels should be restored... *)
           (* Format.printf "update_level: %i < %i@." level (get_level env p); *)
           if level < get_level env p then raise (Unify [(ty, newvar2 level)]);
-          iter_type_expr (update_level env level) ty
+          iter_type_expr (update_level env level expand) ty
         end
+    | Tconstr(_, _ :: _, _) when expand ->
+        begin try
+          link_type ty (!forward_try_expand_once env ty);
+          update_level env level expand ty
+        with Cannot_expand ->
+          set_level ty level;
+          iter_type_expr (update_level env level expand) ty
+        end          
     | Tpackage (p, nl, tl) when level < Path.binding_time p ->
         let p' = normalize_package_path env p in
         if Path.same p p' then raise (Unify [(ty, newvar2 level)]);
         log_type ty; ty.desc <- Tpackage (p', nl, tl);
-        update_level env level ty
+        update_level env level expand ty
     | Tobject(_, ({contents=Some(p, _tl)} as nm))
       when level < get_level env p ->
         set_name nm None;
-        update_level env level ty
+        update_level env level expand ty
     | Tvariant row ->
         let row = row_repr row in
         begin match row.row_name with
@@ -737,14 +745,27 @@ let rec update_level env level ty =
         | _ -> ()
         end;
         set_level ty level;
-        iter_type_expr (update_level env level) ty
+        iter_type_expr (update_level env level expand) ty
     | Tfield(lab, _, ty1, _)
       when lab = dummy_method && (repr ty1).level > level ->
         raise (Unify [(ty1, newvar2 level)])
     | _ ->
         set_level ty level;
         (* XXX what about abbreviations in Tconstr ? *)
-        iter_type_expr (update_level env level) ty
+        iter_type_expr (update_level env level expand) ty
+  end
+
+(* First try without expanding, then expand everything,
+   to avoid combinatorial blow-up *)
+let update_level env level ty =
+  let ty = repr ty in
+  if ty.level > level then begin
+    let snap = snapshot () in
+    try
+      update_level env level false ty
+    with Unify _ ->
+      backtrack snap;
+      update_level env level true ty
   end
 
 (* Generalize and lower levels of contravariant branches simultaneously *)
@@ -1194,7 +1215,7 @@ let instance_class params cty =
   cleanup_types ();
   (params', cty')
 
-(**** Instanciation for types with free universal variables ****)
+(**** Instantiation for types with free universal variables ****)
 
 let rec diff_list l1 l2 =
   if l1 == l2 then [] else
@@ -1315,9 +1336,9 @@ let subst env level priv abbrev ty params args body =
     raise exn
 
 (*
-   Only the shape of the type matters, not whether is is generic or
+   Only the shape of the type matters, not whether it is generic or
    not. [generic_level] might be somewhat slower, but it ensures
-   invariants on types are enforced (decreasing levels.), and we don't
+   invariants on types are enforced (decreasing levels), and we don't
    care about efficiency here.
 *)
 let apply env params body args =
@@ -1326,16 +1347,17 @@ let apply env params body args =
   with
     Unify _ -> raise Cannot_apply
 
+let () = Subst.ctype_apply_env_empty := apply Env.empty
 
                               (****************************)
                               (*  Abbreviation expansion  *)
                               (****************************)
 
 (*
-   If the environnement has changed, memorized expansions might not
+   If the environment has changed, memorized expansions might not
    be correct anymore, and so we flush the cache. This is safe but
    quite pessimistic: it would be enough to flush the cache when a
-   type or module definition is overridden in the environnement.
+   type or module definition is overridden in the environment.
 *)
 let previous_env = ref Env.empty
 (*let string_of_kind = function Public -> "public" | Private -> "private"*)
@@ -1397,12 +1419,6 @@ let expand_abbrev_gen kind find_type_expansion env ty =
             (* prerr_endline
               ("add a "^string_of_kind kind^" expansion for "^Path.name path);*)
             let ty' = subst env level kind abbrev (Some ty) params args body in
-            (* Hack to name the variant type *)
-            begin match repr ty' with
-              {desc=Tvariant row} as ty when static_row row ->
-                ty.desc <- Tvariant { row with row_name = Some (path, args) }
-            | _ -> ()
-            end;
             (* For gadts, remember type as non exportable *)
             (* The ambiguous level registered for ty' should be the highest *)
             if !trace_gadt_instances then begin
@@ -1700,8 +1716,8 @@ let rec unify_univar t1 t2 = function
       end
   | [] -> raise (Unify [])
 
-(* Test the occurence of free univars in a type *)
-(* that's way too expansive. Must do some kind of cacheing *)
+(* Test the occurrence of free univars in a type *)
+(* that's way too expensive. Must do some kind of caching *)
 let occur_univar env ty =
   let visited = ref TypeMap.empty in
   let rec occur_rec bound ty =
@@ -1866,7 +1882,7 @@ let deep_occur t0 ty =
       types are kept distincts, but they are made to (temporally)
       expand to the same type.
    2. Abbreviations with at least one parameter are systematically
-      expanded. The overhead does not seem to high, and that way
+      expanded. The overhead does not seem too high, and that way
       abbreviations where some parameters does not appear in the
       expansion, such as ['a t = int], are correctly handled. In
       particular, for this example, unifying ['a t] with ['b t] keeps
@@ -2275,7 +2291,7 @@ let unify_package env unify_list lv1 p1 n1 tl1 lv2 p2 n2 tl2 =
   && !package_subtype env p2 n2 tl2 p1 n1 tl1 then () else raise Not_found
 
 
-(* force unification in Reither when one side has as non-conjunctive type *)
+(* force unification in Reither when one side has a non-conjunctive type *)
 let rigid_variants = ref false
 
 (* drop not force unification in Reither, even in fixed case
@@ -2669,7 +2685,7 @@ and unify_row env row1 row2 =
     end;
     (* The following test is not principal... should rather use Tnil *)
     let rm = row_more row in
-    if !trace_gadt_instances && rm.desc = Tnil then () else
+    (*if !trace_gadt_instances && rm.desc = Tnil then () else*)
     if !trace_gadt_instances then
       update_level !env rm.level (newgenty (Tvariant row));
     if row_fixed row then
@@ -2691,6 +2707,10 @@ and unify_row env row1 row2 =
           raise (Unify ((mkvariant [l,f1] true,
                          mkvariant [l,f2] true) :: trace)))
       pairs;
+    if static_row row1 then begin
+      let rm = row_more row1 in
+      if is_Tvar rm then link_type rm (newty2 rm.level Tnil)
+    end
   with exn ->
     log_type rm1; rm1.desc <- md1; log_type rm2; rm2.desc <- md2; raise exn
   end
@@ -2703,7 +2723,14 @@ and unify_row_field env fixed1 fixed2 more l f1 f2 =
   | Rpresent None, Rpresent None -> ()
   | Reither(c1, tl1, m1, e1), Reither(c2, tl2, m2, e2) ->
       if e1 == e2 then () else
-      let redo =
+      if (fixed1 || fixed2) && not (c1 || c2)
+      && List.length tl1 = List.length tl2 then begin
+        (* PR#7496 *)
+        let f = Reither (c1 || c2, [], m1 || m2, ref None) in
+        set_row_field e1 f; set_row_field e2 f;
+        List.iter2 (unify env) tl1 tl2
+      end
+      else let redo =
         not !passive_variants &&
         (m1 || m2 || fixed1 || fixed2 ||
          !rigid_variants && (List.length tl1 = 1 || List.length tl2 = 1)) &&
@@ -3097,10 +3124,10 @@ let moregen inst_nongen type_pairs env patt subj =
   moregen inst_nongen type_pairs env patt subj
 
 (*
-   Non-generic variable can be instanciated only if [inst_nongen] is
+   Non-generic variable can be instantiated only if [inst_nongen] is
    true. So, [inst_nongen] should be set to false if the subject might
    contain non-generic variables (and we do not want them to be
-   instanciated).
+   instantiated).
    Usually, the subject is given by the user, and the pattern
    is unimportant.  So, no need to propagate abbreviations.
 *)
@@ -3323,9 +3350,9 @@ and eqtype_row rename type_pairs subst env row1 row2 =
       match row_field_repr f1, row_field_repr f2 with
         Rpresent(Some t1), Rpresent(Some t2) ->
           eqtype rename type_pairs subst env t1 t2
-      | Reither(true, [], _, _), Reither(true, [], _, _) ->
+      | Reither(c1, [], _, _), Reither(c2, [], _, _) when c1 = c2 ->
           ()
-      | Reither(false, t1::tl1, _, _), Reither(false, t2::tl2, _, _) ->
+      | Reither(c1, t1::tl1, _, _), Reither(c2, t2::tl2, _, _) when c1 = c2 ->
           eqtype rename type_pairs subst env t1 t2;
           if List.length tl1 = List.length tl2 then
             (* if same length allow different types (meaning?) *)
@@ -3762,8 +3789,8 @@ let rec build_subtype env visited loops posi level t =
                 ty1, tl1
             | _ -> raise Not_found
           in
-          (* Fix PR4505: do not set ty to Tvar when it appears in tl1,
-             as this occurence might break the occur check.
+          (* Fix PR#4505: do not set ty to Tvar when it appears in tl1,
+             as this occurrence might break the occur check.
              XXX not clear whether this correct anyway... *)
           if List.exists (deep_occur ty) tl1 then raise Not_found;
           ty.desc <- Tvar None;
@@ -4031,7 +4058,7 @@ and subtype_fields env trace ty1 ty2 cstrs =
   in
   List.fold_left
     (fun cstrs (_, _k1, t1, _k2, t2) ->
-      (* Theses fields are always present *)
+      (* These fields are always present *)
       subtype_rec env ((t1, t2)::trace) t1 t2 cstrs)
     cstrs pairs
 
@@ -4492,7 +4519,7 @@ let nondep_cltype_declaration env id decl =
   clear_hash ();
   decl
 
-(* collapse conjonctive types in class parameters *)
+(* collapse conjunctive types in class parameters *)
 let rec collapse_conj env visited ty =
   let ty = repr ty in
   if List.memq ty visited then () else

diff --git a/typing/ctype.mli b/typing/ctype.mli
index f7a22e213e3feb5259f49ab691c416d5ea413e9d..00daacd53d8ee40cf48355e65f93bf91f1dc61b3 100644 (file)
--- a/typing/ctype.mli
+++ b/typing/ctype.mli
@@ -228,7 +228,7 @@ val enlarge_type: Env.t -> type_expr -> type_expr * bool
 val subtype: Env.t -> type_expr -> type_expr -> unit -> unit
         (* [subtype env t1 t2] checks that [t1] is a subtype of [t2].
            It accumulates the constraints the type variables must
-           enforce and returns a function that inforce this
+           enforce and returns a function that enforces this
            constraints. *)
 
 val nondep_type: Env.t -> Ident.t -> type_expr -> type_expr

diff --git a/typing/datarepr.ml b/typing/datarepr.ml
index 5c46ae156bb01b4153f9ab14103c6695451d941b..bce6ff212f15fb35f0988e4fbcd6eab34899e44b 100644 (file)
--- a/typing/datarepr.ml
+++ b/typing/datarepr.ml
@@ -235,3 +235,16 @@ let labels_of_type ty_path decl =
       label_descrs (newgenconstr ty_path decl.type_params)
         labels rep decl.type_private
   | Type_variant _ | Type_abstract | Type_open -> []
+
+(* Set row_name in Env, cf. GPR#1204/1329 *)
+let set_row_name decl path =
+  match decl.type_manifest with
+    None -> ()
+  | Some ty ->
+      let ty = repr ty in
+      match ty.desc with
+        Tvariant row when static_row row ->
+          let row = {(row_repr row) with
+                     row_name = Some (path, decl.type_params)} in
+          ty.desc <- Tvariant row
+      | _ -> ()

diff --git a/typing/datarepr.mli b/typing/datarepr.mli
index 8a85282add36d406531c0c256e2507df847d47c9..30dc1f1f6cf894163fd1eddb764d4e99c8dfc046 100644 (file)
--- a/typing/datarepr.mli
+++ b/typing/datarepr.mli
@@ -42,3 +42,7 @@ val constructor_existentials :
     - the types of the constructor's arguments
     - the existential variables introduced by the constructor
  *)
+
+
+(* Set the polymorphic variant row_name field *)
+val set_row_name : type_declaration -> Path.t -> unit

diff --git a/typing/env.ml b/typing/env.ml
index 224e2c8d05a7aaf57b2514350b3223b0d9370578..4d51aa9b6dc88d2a02f7bd8499951b3b9a5ee4d7 100644 (file)
--- a/typing/env.ml
+++ b/typing/env.ml
@@ -72,31 +72,46 @@ let error err = raise (Error err)
 module EnvLazy : sig
   type ('a,'b) t
 
+  type log
+
   val force : ('a -> 'b) -> ('a,'b) t -> 'b
   val create : 'a -> ('a,'b) t
   val get_arg : ('a,'b) t -> 'a option
 
+  (* [force_logged log f t] is equivalent to [force f t] but if [f] returns [None] then
+     [t] is recorded in [log]. [backtrack log] will then reset all the recorded [t]s back
+     to their original state. *)
+  val log : unit -> log
+  val force_logged : log -> ('a -> 'b option) -> ('a,'b option) t -> 'b option
+  val backtrack : log -> unit
+
 end  = struct
 
   type ('a,'b) t = ('a,'b) eval ref
 
   and ('a,'b) eval =
-      Done of 'b
+    | Done of 'b
     | Raise of exn
     | Thunk of 'a
 
+  type undo =
+    | Nil
+    | Cons : ('a, 'b) t * 'a * undo -> undo
+
+  type log = undo ref
+
   let force f x =
     match !x with
-        Done x -> x
-      | Raise e -> raise e
-      | Thunk e ->
-          try
-            let y = f e in
-            x := Done y;
-            y
-          with e ->
-            x := Raise e;
-            raise e
+    | Done x -> x
+    | Raise e -> raise e
+    | Thunk e ->
+        match f e with
+        | y ->
+          x := Done y;
+          y
+        | exception e ->
+          x := Raise e;
+          raise e
 
   let get_arg x =
     match !x with Thunk a -> Some a | _ -> None
@@ -104,6 +119,35 @@ end  = struct
   let create x =
     ref (Thunk x)
 
+  let log () =
+    ref Nil
+
+  let force_logged log f x =
+    match !x with
+    | Done x -> x
+    | Raise e -> raise e
+    | Thunk e ->
+      match f e with
+      | None ->
+          x := Done None;
+          log := Cons(x, e, !log);
+          None
+      | Some _ as y ->
+          x := Done y;
+          y
+      | exception e ->
+          x := Raise e;
+          raise e
+
+  let backtrack log =
+    let rec loop = function
+      | Nil -> ()
+      | Cons(x, e, rest) ->
+          x := Thunk e;
+          loop rest
+    in
+    loop !log
+
 end
 
 module PathMap = Map.Make(Path)
@@ -120,48 +164,274 @@ type summary =
   | Env_open of summary * Path.t
   | Env_functor_arg of summary * Ident.t
   | Env_constraints of summary * type_declaration PathMap.t
+  | Env_copy_types of summary * string list
 
-module EnvTbl =
+module TycompTbl =
   struct
-    (* A table indexed by identifier, with an extra slot to record usage. *)
-    type 'a t = ('a * (unit -> unit)) Ident.tbl
+    (** This module is used to store components of types (i.e. labels
+        and constructors).  We keep a representation of each nested
+        "open" and the set of local bindings between each of them. *)
 
-    let empty = Ident.empty
-    let nothing = fun () -> ()
+    type 'a t = {
+      current: 'a Ident.tbl;
+      (** Local bindings since the last open. *)
+
+      opened: 'a opened option;
+      (** Symbolic representation of the last (innermost) open, if any. *)
+    }
+
+    and 'a opened = {
+      components: (string, 'a list) Tbl.t;
+      (** Components from the opened module. We keep a list of
+          bindings for each name, as in comp_labels and
+          comp_constrs. *)
+
+      using: (string -> ('a * 'a) option -> unit) option;
+      (** A callback to be applied when a component is used from this
+          "open".  This is used to detect unused "opens".  The
+          arguments are used to detect shadowing. *)
+
+      next: 'a t;
+      (** The table before opening the module. *)
+    }
 
-    let already_defined wrap s tbl x =
-      wrap (try Some (fst (Ident.find_name s tbl), x) with Not_found -> None)
+    let empty = { current = Ident.empty; opened = None }
 
-    let add slot wrap id x tbl ref_tbl =
-      let slot =
+    let add id x tbl =
+      {tbl with current = Ident.add id x tbl.current}
+
+    let add_open slot wrap components next =
+      let using =
         match slot with
-        | None -> nothing
-        | Some f ->
+        | None -> None
+        | Some f -> Some (fun s x -> f s (wrap x))
+      in
+      {
+        current = Ident.empty;
+        opened = Some {using; components; next};
+      }
+
+    let rec find_same id tbl =
+      try Ident.find_same id tbl.current
+      with Not_found as exn ->
+        begin match tbl.opened with
+        | Some {next; _} -> find_same id next
+        | None -> raise exn
+        end
+
+    let nothing = fun () -> ()
+
+    let mk_callback rest name desc = function
+      | None -> nothing
+      | Some f ->
           (fun () ->
-             let s = Ident.name id in
-             f s (already_defined wrap s ref_tbl x)
+             match rest with
+             | [] -> f name None
+             | (hidden, _) :: _ -> f name (Some (desc, hidden))
           )
+
+    let rec find_all name tbl =
+      List.map (fun (_id, desc) -> desc, nothing)
+        (Ident.find_all name tbl.current) @
+      match tbl.opened with
+      | None -> []
+      | Some {using; next; components} ->
+          let rest = find_all name next in
+          match Tbl.find_str name components with
+          | exception Not_found -> rest
+          | opened ->
+              List.map
+                (fun desc -> desc, mk_callback rest name desc using)
+                opened
+              @ rest
+
+    let rec fold_name f tbl acc =
+      let acc = Ident.fold_name (fun _id d -> f d) tbl.current acc in
+      match tbl.opened with
+      | Some {using = _; next; components} ->
+          acc
+          |> Tbl.fold
+            (fun _name -> List.fold_right (fun desc -> f desc))
+            components
+          |> fold_name f next
+      | None ->
+          acc
+
+    let rec local_keys tbl acc =
+      let acc = Ident.fold_all (fun k _ accu -> k::accu) tbl.current acc in
+      match tbl.opened with
+      | Some o -> local_keys o.next acc
+      | None -> acc
+
+    let diff_keys is_local tbl1 tbl2 =
+      let keys2 = local_keys tbl2 [] in
+      List.filter
+        (fun id ->
+           is_local (find_same id tbl2) &&
+           try ignore (find_same id tbl1); false
+           with Not_found -> true)
+        keys2
+
+  end
+
+
+module IdTbl =
+  struct
+    (** This module is used to store all kinds of components except
+        (labels and constructors) in environments.  We keep a
+        representation of each nested "open" and the set of local
+        bindings between each of them. *)
+
+
+    type 'a t = {
+      current: 'a Ident.tbl;
+      (** Local bindings since the last open *)
+
+      opened: 'a opened option;
+      (** Symbolic representation of the last (innermost) open, if any. *)
+    }
+
+    and 'a opened = {
+      root: Path.t;
+      (** The path of the opened module, to be prefixed in front of
+          its local names to produce a valid path in the current
+          environment. *)
+
+      components: (string, 'a * int) Tbl.t;
+      (** Components from the opened module. *)
+
+      using: (string -> ('a * 'a) option -> unit) option;
+      (** A callback to be applied when a component is used from this
+          "open".  This is used to detect unused "opens".  The
+          arguments are used to detect shadowing. *)
+
+      next: 'a t;
+      (** The table before opening the module. *)
+    }
+
+    let empty = { current = Ident.empty; opened = None }
+
+    let add id x tbl =
+      {tbl with current = Ident.add id x tbl.current}
+
+    let add_open slot wrap root components next =
+      let using =
+        match slot with
+        | None -> None
+        | Some f -> Some (fun s x -> f s (wrap x))
       in
-      Ident.add id (x, slot) tbl
+      {
+        current = Ident.empty;
+        opened = Some {using; root; components; next};
+      }
+
+    let rec find_same id tbl =
+      try Ident.find_same id tbl.current
+      with Not_found as exn ->
+        begin match tbl.opened with
+        | Some {next; _} -> find_same id next
+        | None -> raise exn
+        end
+
+    let rec find_name mark name tbl =
+      try
+        let (id, desc) = Ident.find_name name tbl.current in
+        Pident id, desc
+      with Not_found as exn ->
+        begin match tbl.opened with
+        | Some {using; root; next; components} ->
+            begin try
+              let (descr, pos) = Tbl.find_str name components in
+              let res = Pdot (root, name, pos), descr in
+              if mark then begin match using with
+              | None -> ()
+              | Some f ->
+                  begin try f name (Some (snd (find_name false name next), snd res))
+                  with Not_found -> f name None
+                  end
+              end;
+              res
+            with Not_found ->
+              find_name mark name next
+            end
+        | None ->
+            raise exn
+        end
+
+    let find_name name tbl = find_name true name tbl
+
+    let rec update name f tbl =
+      try
+        let (id, desc) = Ident.find_name name tbl.current in
+        let new_desc = f desc in
+        {tbl with current = Ident.add id new_desc tbl.current}
+      with Not_found ->
+        begin match tbl.opened with
+        | Some {root; using; next; components} ->
+            begin try
+              let (desc, pos) = Tbl.find_str name components in
+              let new_desc = f desc in
+              let components = Tbl.add name (new_desc, pos) components in
+              {tbl with opened = Some {root; using; next; components}}
+            with Not_found ->
+              let next = update name f next in
+              {tbl with opened = Some {root; using; next; components}}
+            end
+        | None ->
+            tbl
+        end
+
+
 
-    let find_same_not_using id tbl =
-      fst (Ident.find_same id tbl)
+    let rec find_all name tbl =
+      List.map (fun (id, desc) -> Pident id, desc) (Ident.find_all name tbl.current) @
+      match tbl.opened with
+      | None -> []
+      | Some {root; using = _; next; components} ->
+          try
+            let (desc, pos) = Tbl.find_str name components in
+            (Pdot (root, name, pos), desc) :: find_all name next
+          with Not_found ->
+            find_all name next
+
+    let rec fold_name f tbl acc =
+      let acc = Ident.fold_name (fun id d -> f (Ident.name id) (Pident id, d)) tbl.current acc in
+      match tbl.opened with
+      | Some {root; using = _; next; components} ->
+          acc
+          |> Tbl.fold
+            (fun name (desc, pos) -> f name (Pdot (root, name, pos), desc))
+            components
+          |> fold_name f next
+      | None ->
+          acc
+
+    let rec local_keys tbl acc =
+      let acc = Ident.fold_all (fun k _ accu -> k::accu) tbl.current acc in
+      match tbl.opened with
+      | Some o -> local_keys o.next acc
+      | None -> acc
 
-    let find_same id tbl =
-      let (x, slot) = Ident.find_same id tbl in
-      slot ();
-      x
 
-    let find_name s tbl =
-      let (x, slot) = Ident.find_name s tbl in
-      slot ();
-      x
+    let rec iter f tbl =
+      Ident.iter (fun id desc -> f id (Pident id, desc)) tbl.current;
+      match tbl.opened with
+      | Some {root; using = _; next; components} ->
+          Tbl.iter
+            (fun s (x, pos) -> f (Ident.hide (Ident.create s) (* ??? *)) (Pdot (root, s, pos), x))
+            components;
+          iter f next
+      | None -> ()
+
+    let diff_keys tbl1 tbl2 =
+      let keys2 = local_keys tbl2 [] in
+      List.filter
+        (fun id ->
+           try ignore (find_same id tbl1); false
+           with Not_found -> true)
+        keys2
 
-    let find_all s tbl =
-      Ident.find_all s tbl
 
-    let fold_name f = Ident.fold_name (fun k (d,_) -> f k d)
-    let keys tbl = Ident.fold_all (fun k _ accu -> k::accu) tbl []
   end
 
 type type_descriptions =
@@ -171,15 +441,15 @@ let in_signature_flag = 0x01
 let implicit_coercion_flag = 0x02
 
 type t = {
-  values: (Path.t * value_description) EnvTbl.t;
-  constrs: constructor_description EnvTbl.t;
-  labels: label_description EnvTbl.t;
-  types: (Path.t * (type_declaration * type_descriptions)) EnvTbl.t;
-  modules: (Path.t * module_declaration) EnvTbl.t;
-  modtypes: (Path.t * modtype_declaration) EnvTbl.t;
-  components: (Path.t * module_components) EnvTbl.t;
-  classes: (Path.t * class_declaration) EnvTbl.t;
-  cltypes: (Path.t * class_type_declaration) EnvTbl.t;
+  values: value_description IdTbl.t;
+  constrs: constructor_description TycompTbl.t;
+  labels: label_description TycompTbl.t;
+  types: (type_declaration * type_descriptions) IdTbl.t;
+  modules: (Subst.t * module_declaration, module_declaration) EnvLazy.t IdTbl.t;
+  modtypes: modtype_declaration IdTbl.t;
+  components: module_components IdTbl.t;
+  classes: class_declaration IdTbl.t;
+  cltypes: class_type_declaration IdTbl.t;
   functor_args: unit Ident.tbl;
   summary: summary;
   local_constraints: type_declaration PathMap.t;
@@ -191,26 +461,28 @@ and module_components =
   {
     deprecated: string option;
     loc: Location.t;
-    comps: (t * Subst.t * Path.t * Types.module_type, module_components_repr)
-           EnvLazy.t;
+    comps:
+      (t * Subst.t * Path.t * Types.module_type, module_components_repr option)
+        EnvLazy.t;
   }
 
 and module_components_repr =
     Structure_comps of structure_components
   | Functor_comps of functor_components
 
+and 'a comp_tbl = (string, ('a * int)) Tbl.t
+
 and structure_components = {
-  mutable comp_values: (string, (value_description * int)) Tbl.t;
-  mutable comp_constrs: (string, (constructor_description * int) list) Tbl.t;
-  mutable comp_labels: (string, (label_description * int) list) Tbl.t;
-  mutable comp_types:
-   (string, ((type_declaration * type_descriptions) * int)) Tbl.t;
+  mutable comp_values: value_description comp_tbl;
+  mutable comp_constrs: (string, constructor_description list) Tbl.t;
+  mutable comp_labels: (string, label_description list) Tbl.t;
+  mutable comp_types: (type_declaration * type_descriptions) comp_tbl;
   mutable comp_modules:
-   (string, ((Subst.t * Types.module_type,module_type) EnvLazy.t * int)) Tbl.t;
-  mutable comp_modtypes: (string, (modtype_declaration * int)) Tbl.t;
-  mutable comp_components: (string, (module_components * int)) Tbl.t;
-  mutable comp_classes: (string, (class_declaration * int)) Tbl.t;
-  mutable comp_cltypes: (string, (class_type_declaration * int)) Tbl.t
+   (Subst.t * module_declaration, module_declaration) EnvLazy.t comp_tbl;
+  mutable comp_modtypes: modtype_declaration comp_tbl;
+  mutable comp_components: module_components comp_tbl;
+  mutable comp_classes: class_declaration comp_tbl;
+  mutable comp_cltypes: class_type_declaration comp_tbl;
 }
 
 and functor_components = {
@@ -254,14 +526,16 @@ let check_shadowing env = function
   | `Class None | `Class_type None | `Component None ->
       None
 
-let subst_modtype_maker (subst, mty) = Subst.modtype subst mty
+let subst_modtype_maker (subst, md) =
+  if subst == Subst.identity then md
+  else {md with md_type = Subst.modtype subst md.md_type}
 
 let empty = {
-  values = EnvTbl.empty; constrs = EnvTbl.empty;
-  labels = EnvTbl.empty; types = EnvTbl.empty;
-  modules = EnvTbl.empty; modtypes = EnvTbl.empty;
-  components = EnvTbl.empty; classes = EnvTbl.empty;
-  cltypes = EnvTbl.empty;
+  values = IdTbl.empty; constrs = TycompTbl.empty;
+  labels = TycompTbl.empty; types = IdTbl.empty;
+  modules = IdTbl.empty; modtypes = IdTbl.empty;
+  components = IdTbl.empty; classes = IdTbl.empty;
+  cltypes = IdTbl.empty;
   summary = Env_empty; local_constraints = PathMap.empty; gadt_instances = [];
   flags = 0;
   functor_args = Ident.empty;
@@ -280,30 +554,35 @@ let implicit_coercion env =
 let is_in_signature env = env.flags land in_signature_flag <> 0
 let is_implicit_coercion env = env.flags land implicit_coercion_flag <> 0
 
-let diff_keys is_local tbl1 tbl2 =
-  let keys2 = EnvTbl.keys tbl2 in
-  List.filter
-    (fun id ->
-      is_local (EnvTbl.find_same_not_using id tbl2) &&
-      try ignore (EnvTbl.find_same_not_using id tbl1); false
-      with Not_found -> true)
-    keys2
-
 let is_ident = function
     Pident _ -> true
   | Pdot _ | Papply _ -> false
 
-let is_local (p, _) = is_ident p
-
 let is_local_ext = function
   | {cstr_tag = Cstr_extension(p, _)} -> is_ident p
   | _ -> false
 
 let diff env1 env2 =
-  diff_keys is_local env1.values env2.values @
-  diff_keys is_local_ext env1.constrs env2.constrs @
-  diff_keys is_local env1.modules env2.modules @
-  diff_keys is_local env1.classes env2.classes
+  IdTbl.diff_keys env1.values env2.values @
+  TycompTbl.diff_keys is_local_ext env1.constrs env2.constrs @
+  IdTbl.diff_keys env1.modules env2.modules @
+  IdTbl.diff_keys env1.classes env2.classes
+
+type can_load_cmis =
+  | Can_load_cmis
+  | Cannot_load_cmis of EnvLazy.log
+
+let can_load_cmis = ref Can_load_cmis
+
+let without_cmis f x =
+  let log = EnvLazy.log () in
+  let res =
+    Misc.(protect_refs
+            [R (can_load_cmis, Cannot_load_cmis log)]
+            (fun () -> f x))
+  in
+  EnvLazy.backtrack log;
+  res
 
 (* Forward declarations *)
 
@@ -314,14 +593,14 @@ let components_of_module' =
        module_components)
 let components_of_module_maker' =
   ref ((fun (_env, _sub, _path, _mty) -> assert false) :
-          t * Subst.t * Path.t * module_type -> module_components_repr)
+          t * Subst.t * Path.t * module_type -> module_components_repr option)
 let components_of_functor_appl' =
   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) :
-          t -> module_type -> Path.t -> module_type -> unit)
+  ref ((fun ~loc:_ _env _mty1 _path1 _mty2 -> assert false) :
+          loc:Location.t -> t -> module_type -> Path.t -> module_type -> unit)
 let strengthen =
   (* to be filled with Mtype.strengthen *)
   ref ((fun ~aliasable:_ _env _mty _path -> assert false) :
@@ -330,9 +609,27 @@ let strengthen =
 let md md_type =
   {md_type; md_attributes=[]; md_loc=Location.none}
 
-let get_components c =
-  EnvLazy.force !components_of_module_maker' c.comps
+let get_components_opt c =
+  match !can_load_cmis with
+  | Can_load_cmis ->
+    EnvLazy.force !components_of_module_maker' c.comps
+  | Cannot_load_cmis log ->
+    EnvLazy.force_logged log !components_of_module_maker' c.comps
+
+let empty_structure =
+  Structure_comps {
+    comp_values = Tbl.empty;
+    comp_constrs = Tbl.empty;
+    comp_labels = Tbl.empty;
+    comp_types = Tbl.empty;
+    comp_modules = Tbl.empty; comp_modtypes = Tbl.empty;
+    comp_components = Tbl.empty; comp_classes = Tbl.empty;
+    comp_cltypes = Tbl.empty }
 
+let get_components c =
+  match get_components_opt c with
+  | None -> empty_structure
+  | Some c -> c
 
 (* The name of the compilation unit currently compiled.
    "" if outside a compilation unit. *)
@@ -460,25 +757,24 @@ let read_pers_struct check modname filename =
   acknowledge_pers_struct check modname
     { Persistent_signature.filename; cmi }
 
-let can_load_cmis = ref true
-let without_cmis f x =
-  Misc.(protect_refs [R (can_load_cmis, false)] (fun () -> f x))
-
 let find_pers_struct check name =
   if name = "*predef*" then raise Not_found;
   match Hashtbl.find persistent_structures name with
   | Some ps -> ps
   | None -> raise Not_found
-  | exception Not_found when !can_load_cmis ->
-      let ps =
-        match !Persistent_signature.load ~unit_name:name with
-        | Some ps -> ps
-        | None ->
-          Hashtbl.add persistent_structures name None;
-          raise Not_found
-      in
-      add_import name;
-      acknowledge_pers_struct check name ps
+  | exception Not_found ->
+    match !can_load_cmis with
+    | Cannot_load_cmis _ -> raise Not_found
+    | Can_load_cmis ->
+        let ps =
+          match !Persistent_signature.load ~unit_name:name with
+          | Some ps -> ps
+          | None ->
+            Hashtbl.add persistent_structures name None;
+            raise Not_found
+        in
+        add_import name;
+        acknowledge_pers_struct check name ps
 
 (* Emits a warning if there is no valid cmi for name *)
 let check_pers_struct name =
@@ -523,7 +819,7 @@ let find_pers_struct name =
 let check_pers_struct name =
   if not (Hashtbl.mem persistent_structures name) then begin
     (* PR#6843: record the weak dependency ([add_import]) regardless of
-       whether the check suceeds, to help make builds more
+       whether the check succeeds, to help make builds more
        deterministic. *)
     add_import name;
     if (Warnings.is_active (Warnings.No_cmi_file("", None))) then
@@ -568,8 +864,7 @@ let rec find_module_descr path env =
   match path with
     Pident id ->
       begin try
-        let (_p, desc) = EnvTbl.find_same id env.components
-        in desc
+        IdTbl.find_same id env.components
       with Not_found ->
         if Ident.persistent id && not (Ident.name id = !current_unit)
         then (find_pers_struct (Ident.name id)).ps_comps
@@ -578,7 +873,7 @@ let rec find_module_descr path env =
   | Pdot(p, s, _pos) ->
       begin match get_components (find_module_descr p env) with
         Structure_comps c ->
-          let (descr, _pos) = Tbl.find s c.comp_components in
+          let (descr, _pos) = Tbl.find_str s c.comp_components in
           descr
       | Functor_comps _ ->
          raise Not_found
@@ -594,12 +889,11 @@ let rec find_module_descr path env =
 let find proj1 proj2 path env =
   match path with
     Pident id ->
-      let (_p, data) = EnvTbl.find_same id (proj1 env)
-      in data
+      IdTbl.find_same id (proj1 env)
   | Pdot(p, s, _pos) ->
       begin match get_components (find_module_descr p env) with
         Structure_comps c ->
-          let (data, _pos) = Tbl.find s (proj2 c) in data
+          let (data, _pos) = Tbl.find_str s (proj2 c) in data
       | Functor_comps _ ->
           raise Not_found
       end
@@ -640,7 +934,7 @@ let find_type_full path env =
       type_of_cstr path cstr
   | LocalExt id ->
       let cstr =
-        try EnvTbl.find_same id env.constrs
+        try TycompTbl.find_same id env.constrs
         with Not_found -> assert false
       in
       type_of_cstr path cstr
@@ -656,12 +950,12 @@ let find_type_full path env =
       in
       let exts =
         List.filter
-          (function ({cstr_tag=Cstr_extension _}, _) -> true | _ -> false)
-          (try Tbl.find s comps.comp_constrs
+          (function {cstr_tag=Cstr_extension _} -> true | _ -> false)
+          (try Tbl.find_str s comps.comp_constrs
            with Not_found -> assert false)
       in
       match exts with
-      | [(cstr, _)] -> type_of_cstr path cstr
+      | [cstr] -> type_of_cstr path cstr
       | _ -> assert false
 
 let find_type p env =
@@ -673,8 +967,8 @@ let find_module ~alias path env =
   match path with
     Pident id ->
       begin try
-        let (_p, data) = EnvTbl.find_same id env.modules
-        in data
+        let data = IdTbl.find_same id env.modules in
+        EnvLazy.force subst_modtype_maker data
       with Not_found ->
         if Ident.persistent id && not (Ident.name id = !current_unit) then
           let ps = find_pers_struct (Ident.name id) in
@@ -684,8 +978,8 @@ let find_module ~alias path env =
   | Pdot(p, s, _pos) ->
       begin match get_components (find_module_descr p env) with
         Structure_comps c ->
-          let (data, _pos) = Tbl.find s c.comp_modules in
-          md (EnvLazy.force subst_modtype_maker data)
+          let (data, _pos) = Tbl.find_str s c.comp_modules in
+          EnvLazy.force subst_modtype_maker data
       | Functor_comps _ ->
           raise Not_found
       end
@@ -810,9 +1104,7 @@ let report_deprecated ?loc p deprecated =
   match loc, deprecated with
   | Some loc, Some txt ->
       let txt = if txt = "" then "" else "\n" ^ txt in
-      Location.prerr_warning loc
-        (Warnings.Deprecated (Printf.sprintf "module %s%s"
-                                (Path.name p) txt))
+      Location.deprecated loc (Printf.sprintf "module %s%s" (Path.name p) txt)
   | _ -> ()
 
 let mark_module_used env name loc =
@@ -824,7 +1116,7 @@ let rec lookup_module_descr_aux ?loc lid env =
   match lid with
     Lident s ->
       begin try
-        EnvTbl.find_name s env.components
+        IdTbl.find_name s env.components
       with Not_found ->
         if s = !current_unit then raise Not_found;
         let ps = find_pers_struct s in
@@ -834,7 +1126,7 @@ let rec lookup_module_descr_aux ?loc lid env =
       let (p, descr) = lookup_module_descr ?loc l env in
       begin match get_components descr with
         Structure_comps c ->
-          let (descr, pos) = Tbl.find s c.comp_components in
+          let (descr, pos) = Tbl.find_str s c.comp_components in
           (Pdot(p, s, pos), descr)
       | Functor_comps _ ->
           raise Not_found
@@ -845,7 +1137,8 @@ let rec lookup_module_descr_aux ?loc lid env =
       let {md_type=mty2} = find_module p2 env in
       begin match get_components desc1 with
         Functor_comps f ->
-          Misc.may (!check_modtype_inclusion env mty2 p2) f.fcomp_arg;
+          let loc = match loc with Some l -> l | None -> Location.none in
+          Misc.may (!check_modtype_inclusion ~loc env mty2 p2) f.fcomp_arg;
           (Papply(p1, p2), !components_of_functor_appl' f env p1 p2)
       | Structure_comps _ ->
           raise Not_found
@@ -865,8 +1158,9 @@ and lookup_module ~load ?loc lid env : Path.t =
   match lid with
     Lident s ->
       begin try
-        let (p, {md_type; md_attributes; md_loc}) =
-          EnvTbl.find_name s env.modules
+        let (p, data) = IdTbl.find_name s env.modules in
+        let {md_loc; md_attributes; md_type} =
+          EnvLazy.force subst_modtype_maker data
         in
         mark_module_used env s md_loc;
         begin match md_type with
@@ -892,8 +1186,8 @@ and lookup_module ~load ?loc lid env : Path.t =
       let (p, descr) = lookup_module_descr ?loc l env in
       begin match get_components descr with
         Structure_comps c ->
-          let (_data, pos) = Tbl.find s c.comp_modules in
-          let (comps, _) = Tbl.find s c.comp_components in
+          let (_data, pos) = Tbl.find_str s c.comp_modules in
+          let (comps, _) = Tbl.find_str s c.comp_components in
           mark_module_used env s comps.loc;
           let p = Pdot(p, s, pos) in
           report_deprecated ?loc p comps.deprecated;
@@ -908,7 +1202,8 @@ and lookup_module ~load ?loc lid env : Path.t =
       let p = Papply(p1, p2) in
       begin match get_components desc1 with
         Functor_comps f ->
-          Misc.may (!check_modtype_inclusion env mty2 p2) f.fcomp_arg;
+          let loc = match loc with Some l -> l | None -> Location.none in
+          Misc.may (!check_modtype_inclusion ~loc env mty2 p2) f.fcomp_arg;
           p
       | Structure_comps _ ->
           raise Not_found
@@ -917,12 +1212,12 @@ and lookup_module ~load ?loc lid env : Path.t =
 let lookup proj1 proj2 ?loc lid env =
   match lid with
     Lident s ->
-      EnvTbl.find_name s (proj1 env)
+      IdTbl.find_name s (proj1 env)
   | Ldot(l, s) ->
       let (p, desc) = lookup_module_descr ?loc l env in
       begin match get_components desc with
         Structure_comps c ->
-          let (data, pos) = Tbl.find s (proj2 c) in
+          let (data, pos) = Tbl.find_str s (proj2 c) in
           (Pdot(p, s, pos), data)
       | Functor_comps _ ->
           raise Not_found
@@ -933,7 +1228,7 @@ let lookup proj1 proj2 ?loc lid env =
 let lookup_all_simple proj1 proj2 shadow ?loc lid env =
   match lid with
     Lident s ->
-      let xl = EnvTbl.find_all s (proj1 env) in
+      let xl = TycompTbl.find_all s (proj1 env) in
       let rec do_shadow =
         function
         | [] -> []
@@ -947,10 +1242,10 @@ let lookup_all_simple proj1 proj2 shadow ?loc lid env =
       begin match get_components desc with
         Structure_comps c ->
           let comps =
-            try Tbl.find s (proj2 c) with Not_found -> []
+            try Tbl.find_str s (proj2 c) with Not_found -> []
           in
           List.map
-            (fun (data, _pos) -> (data, (fun () -> ())))
+            (fun data -> (data, (fun () -> ())))
             comps
       | Functor_comps _ ->
           raise Not_found
@@ -969,33 +1264,25 @@ let lbl_shadow _lbl1 _lbl2 = false
 
 let lookup_value =
   lookup (fun env -> env.values) (fun sc -> sc.comp_values)
-and lookup_all_constructors =
+let lookup_all_constructors =
   lookup_all_simple (fun env -> env.constrs) (fun sc -> sc.comp_constrs)
     cstr_shadow
-and lookup_all_labels =
+let lookup_all_labels =
   lookup_all_simple (fun env -> env.labels) (fun sc -> sc.comp_labels)
     lbl_shadow
-and lookup_type =
+let lookup_type =
   lookup (fun env -> env.types) (fun sc -> sc.comp_types)
-and lookup_modtype =
+let lookup_modtype =
   lookup (fun env -> env.modtypes) (fun sc -> sc.comp_modtypes)
-and lookup_class =
+let lookup_class =
   lookup (fun env -> env.classes) (fun sc -> sc.comp_classes)
-and lookup_cltype =
+let lookup_cltype =
   lookup (fun env -> env.cltypes) (fun sc -> sc.comp_cltypes)
 
-let update_value s f env =
-  try
-    let ((p, vd), slot) = Ident.find_name s env.values in
-    match p with
-    | Pident id ->
-        let vd2 = f vd in
-        {env with values = Ident.add id ((p, vd2), slot) env.values;
-                  summary = Env_value(env.summary, id, vd2)}
-    | _ ->
-        env
-  with Not_found ->
-    env
+let copy_types l env =
+  let f desc = {desc with val_type = Subst.type_expr Subst.identity desc.val_type} in
+  let values = List.fold_left (fun env s -> IdTbl.update s f env) env.values l in
+  {env with values; summary = Env_copy_types (env.summary, l)}
 
 let mark_value_used env name vd =
   if not (is_implicit_coercion env) then
@@ -1151,7 +1438,7 @@ let rec scrape_alias_for_visit env mty =
   | _ -> true
 
 let iter_env proj1 proj2 f env () =
-  Ident.iter (fun id (x,_) -> f (Pident id) x) (proj1 env);
+  IdTbl.iter (fun id x -> f (Pident id) x) (proj1 env);
   let rec iter_components path path' mcomps =
     let cont () =
       let visit =
@@ -1179,8 +1466,8 @@ let iter_env proj1 proj2 f env () =
           let id = Pident (Ident.create_persistent s) in
           iter_components id id ps.ps_comps)
     persistent_structures;
-  Ident.iter
-    (fun id ((path, comps), _) -> iter_components (Pident id) path comps)
+  IdTbl.iter
+    (fun id (path, comps) -> iter_components (Pident id) path comps)
     env.components
 
 let run_iter_cont l =
@@ -1205,13 +1492,13 @@ let find_all_comps proj s (p,mcomps) =
   match get_components mcomps with
     Functor_comps _ -> []
   | Structure_comps comps ->
-      try let (c,n) = Tbl.find s (proj comps) in [Pdot(p,s,n), c]
+      try let (c,n) = Tbl.find_str s (proj comps) in [Pdot(p,s,n), c]
       with Not_found -> []
 
 let rec find_shadowed_comps path env =
   match path with
     Pident id ->
-      List.map fst (Ident.find_all (Ident.name id) env.components)
+      IdTbl.find_all (Ident.name id) env.components
   | Pdot (p, s, _) ->
       let l = find_shadowed_comps p env in
       let l' =
@@ -1222,7 +1509,7 @@ let rec find_shadowed_comps path env =
 let find_shadowed proj1 proj2 path env =
   match path with
     Pident id ->
-      List.map fst (Ident.find_all (Ident.name id) (proj1 env))
+      IdTbl.find_all (Ident.name id) (proj1 env)
   | Pdot (p, s, _) ->
       let l = find_shadowed_comps p env in
       let l' = List.map (find_all_comps proj2 s) l in
@@ -1230,11 +1517,9 @@ let find_shadowed proj1 proj2 path env =
   | Papply _ -> []
 
 let find_shadowed_types path env =
-  let l =
-    find_shadowed
-      (fun env -> env.types) (fun comps -> comps.comp_types) path env
-  in
-  List.map fst l
+  List.map fst
+    (find_shadowed
+       (fun env -> env.types) (fun comps -> comps.comp_types) path env)
 
 
 (* GADT instance tracking *)
@@ -1350,33 +1635,7 @@ let rec prefix_idents root pos sub = function
         prefix_idents root pos (Subst.add_type id p sub) rem in
       (p::pl, final_sub)
 
-let subst_signature sub sg =
-  List.map
-    (fun item ->
-      match item with
-      | Sig_value(id, decl) ->
-          Sig_value (id, Subst.value_description sub decl)
-      | Sig_type(id, decl, x) ->
-          Sig_type(id, Subst.type_declaration sub decl, x)
-      | Sig_typext(id, ext, es) ->
-          Sig_typext (id, Subst.extension_constructor sub ext, es)
-      | Sig_module(id, mty, x) ->
-          Sig_module(id, Subst.module_declaration sub mty,x)
-      | Sig_modtype(id, decl) ->
-          Sig_modtype(id, Subst.modtype_declaration sub decl)
-      | Sig_class(id, decl, x) ->
-          Sig_class(id, Subst.class_declaration sub decl, x)
-      | Sig_class_type(id, decl, x) ->
-          Sig_class_type(id, Subst.cltype_declaration sub decl, x)
-    )
-    sg
-
-
-let prefix_idents_and_subst root sub sg =
-  let (pl, sub) = prefix_idents root 0 sub sg in
-  pl, sub, lazy (subst_signature sub sg)
-
-let prefix_idents_and_subst root sub sg =
+let prefix_idents root sub sg =
   if sub = Subst.identity then
     let sgs =
       try
@@ -1389,17 +1648,17 @@ let prefix_idents_and_subst root sub sg =
     try
       List.assq sg !sgs
     with Not_found ->
-      let r = prefix_idents_and_subst root sub sg in
+      let r = prefix_idents root 0 sub sg in
       sgs := (sg, r) :: !sgs;
       r
   else
-    prefix_idents_and_subst root sub sg
+    prefix_idents root 0 sub sg
 
 (* Compute structure descriptions *)
 
 let add_to_tbl id decl tbl =
   let decls =
-    try Tbl.find id tbl with Not_found -> [] in
+    try Tbl.find_str id tbl with Not_found -> [] in
   Tbl.add id (decl :: decls) tbl
 
 let rec components_of_module ~deprecated ~loc env sub path mty =
@@ -1410,7 +1669,7 @@ let rec components_of_module ~deprecated ~loc env sub path mty =
   }
 
 and components_of_module_maker (env, sub, path, mty) =
-  (match scrape_alias env mty with
+  match scrape_alias env mty with
     Mty_signature sg ->
       let c =
         { comp_values = Tbl.empty;
@@ -1419,7 +1678,7 @@ and components_of_module_maker (env, sub, path, mty) =
           comp_modules = Tbl.empty; comp_modtypes = Tbl.empty;
           comp_components = Tbl.empty; comp_classes = Tbl.empty;
           comp_cltypes = Tbl.empty } in
-      let pl, sub, _ = prefix_idents_and_subst path sub sg in
+      let pl, sub = prefix_idents path sub sg in
       let env = ref env in
       let pos = ref 0 in
       List.iter2 (fun item path ->
@@ -1433,6 +1692,7 @@ and components_of_module_maker (env, sub, path, mty) =
             end
         | Sig_type(id, decl, _) ->
             let decl' = Subst.type_declaration sub decl in
+            Datarepr.set_row_name decl' (Subst.type_path sub (Path.Pident id));
             let constructors =
               List.map snd (Datarepr.constructors_of_type path decl') in
             let labels =
@@ -1444,40 +1704,40 @@ and components_of_module_maker (env, sub, path, mty) =
             List.iter
               (fun descr ->
                 c.comp_constrs <-
-                  add_to_tbl descr.cstr_name (descr, nopos) c.comp_constrs)
+                  add_to_tbl descr.cstr_name descr c.comp_constrs)
               constructors;
             List.iter
               (fun descr ->
                 c.comp_labels <-
-                  add_to_tbl descr.lbl_name (descr, nopos) c.comp_labels)
+                  add_to_tbl descr.lbl_name descr c.comp_labels)
               labels;
-            env := store_type_infos None id (Pident id) decl !env !env
+            env := store_type_infos id decl !env
         | Sig_typext(id, ext, _) ->
             let ext' = Subst.extension_constructor sub ext in
             let descr = Datarepr.extension_descr path ext' in
             c.comp_constrs <-
-              add_to_tbl (Ident.name id) (descr, !pos) c.comp_constrs;
+              add_to_tbl (Ident.name id) descr c.comp_constrs;
             incr pos
         | Sig_module(id, md, _) ->
-            let mty = md.md_type in
-            let mty' = EnvLazy.create (sub, mty) in
+            let md' = EnvLazy.create (sub, md) in
             c.comp_modules <-
-              Tbl.add (Ident.name id) (mty', !pos) c.comp_modules;
+              Tbl.add (Ident.name id) (md', !pos) c.comp_modules;
             let deprecated =
               Builtin_attributes.deprecated_of_attrs md.md_attributes
             in
             let comps =
-              components_of_module ~deprecated ~loc:md.md_loc !env sub path mty
+              components_of_module ~deprecated ~loc:md.md_loc !env sub path
+                md.md_type
             in
             c.comp_components <-
               Tbl.add (Ident.name id) (comps, !pos) c.comp_components;
-            env := store_module ~check:false None id (Pident id) md !env !env;
+            env := store_module ~check:false id md !env;
             incr pos
         | Sig_modtype(id, decl) ->
             let decl' = Subst.modtype_declaration sub decl in
             c.comp_modtypes <-
               Tbl.add (Ident.name id) (decl', nopos) c.comp_modtypes;
-            env := store_modtype None id (Pident id) decl !env !env
+            env := store_modtype id decl !env
         | Sig_class(id, decl, _) ->
             let decl' = Subst.class_declaration sub decl in
             c.comp_classes <-
@@ -1488,26 +1748,18 @@ and components_of_module_maker (env, sub, path, mty) =
             c.comp_cltypes <-
               Tbl.add (Ident.name id) (decl', !pos) c.comp_cltypes)
         sg pl;
-        Structure_comps c
+        Some (Structure_comps c)
   | Mty_functor(param, ty_arg, ty_res) ->
-        Functor_comps {
+        Some (Functor_comps {
           fcomp_param = param;
           (* 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 = Subst.modtype sub ty_res;
           fcomp_cache = Hashtbl.create 17;
-          fcomp_subst_cache = Hashtbl.create 17 }
+          fcomp_subst_cache = Hashtbl.create 17 })
   | Mty_ident _
-  | Mty_alias _ ->
-        Structure_comps {
-          comp_values = Tbl.empty;
-          comp_constrs = Tbl.empty;
-          comp_labels = Tbl.empty;
-          comp_types = Tbl.empty;
-          comp_modules = Tbl.empty; comp_modtypes = Tbl.empty;
-          comp_components = Tbl.empty; comp_classes = Tbl.empty;
-          comp_cltypes = Tbl.empty })
+  | Mty_alias _ -> None
 
 (* Insertion of bindings by identifier + path *)
 
@@ -1536,19 +1788,19 @@ and check_value_name name loc =
     done
 
 
-and store_value ?check slot id path decl env renv =
+and store_value ?check id decl env =
   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 slot (fun x -> `Value x) id (path, decl)
-        env.values renv.values;
+    values = IdTbl.add id decl env.values;
     summary = Env_value(env.summary, id, decl) }
 
-and store_type ~check slot id path info env renv =
+and store_type ~check id info env =
   let loc = info.type_loc in
   if check then
     check_usage loc id (fun s -> Warnings.Unused_type_declaration s)
       type_declarations;
+  let path = Pident id in
   let constructors = Datarepr.constructors_of_type path info in
   let labels = Datarepr.labels_of_type path info in
   let descrs = (List.map snd constructors, List.map snd labels) in
@@ -1576,34 +1828,30 @@ and store_type ~check slot id path info env renv =
   { env with
     constrs =
       List.fold_right
-        (fun (id, descr) constrs ->
-           EnvTbl.add slot (fun x -> `Constructor x) id descr constrs
-             renv.constrs)
+        (fun (id, descr) constrs -> TycompTbl.add id descr constrs)
         constructors
         env.constrs;
     labels =
       List.fold_right
-        (fun (id, descr) labels ->
-           EnvTbl.add slot (fun x -> `Label x) id descr labels renv.labels)
+        (fun (id, descr) labels -> TycompTbl.add id descr labels)
         labels
         env.labels;
     types =
-      EnvTbl.add slot (fun x -> `Type x) id (path, (info, descrs)) env.types
-                       renv.types;
+      IdTbl.add id (info, descrs) env.types;
     summary = Env_type(env.summary, id, info) }
 
-and store_type_infos slot id path info env renv =
+and store_type_infos id info env =
   (* Simplified version of store_type that doesn't compute and store
      constructor and label infos, but simply record the arity and
      manifest-ness of the type.  Used in components_of_module to
      keep track of type abbreviations (e.g. type t = float) in the
      computation of label representations. *)
   { env with
-    types = EnvTbl.add slot (fun x -> `Type x) id (path, (info,([],[])))
-        env.types renv.types;
+    types = IdTbl.add id (info,([],[]))
+        env.types;
     summary = Env_type(env.summary, id, info) }
 
-and store_extension ~check slot id path ext env renv =
+and store_extension ~check id ext env =
   let loc = ext.ext_loc in
   if check && not loc.Location.loc_ghost &&
     Warnings.is_active (Warnings.Unused_extension ("", false, false, false))
@@ -1626,12 +1874,12 @@ and store_extension ~check slot id path ext env renv =
     end;
   end;
   { env with
-    constrs = EnvTbl.add slot (fun x -> `Constructor x) id
-                (Datarepr.extension_descr path ext)
-                env.constrs renv.constrs;
+    constrs = TycompTbl.add id
+                (Datarepr.extension_descr (Pident id) ext)
+                env.constrs;
     summary = Env_extension(env.summary, id, ext) }
 
-and store_module ~check slot id path md env renv =
+and store_module ~check id md env =
   let loc = md.md_loc in
   if check then
     check_usage loc id (fun s -> Warnings.Unused_module s)
@@ -1639,31 +1887,27 @@ and store_module ~check slot id path md env renv =
 
   let deprecated = Builtin_attributes.deprecated_of_attrs md.md_attributes in
   { env with
-    modules = EnvTbl.add slot (fun x -> `Module x) id (path, md)
-        env.modules renv.modules;
+    modules = IdTbl.add id (EnvLazy.create (Subst.identity, md)) env.modules;
     components =
-      EnvTbl.add slot (fun x -> `Component x) id
-        (path, components_of_module ~deprecated ~loc:md.md_loc
-           env Subst.identity path md.md_type)
-        env.components renv.components;
+      IdTbl.add id
+        (components_of_module ~deprecated ~loc:md.md_loc
+           env Subst.identity (Pident id) md.md_type)
+        env.components;
     summary = Env_module(env.summary, id, md) }
 
-and store_modtype slot id path info env renv =
+and store_modtype id info env =
   { env with
-    modtypes = EnvTbl.add slot (fun x -> `Module_type x) id (path, info)
-        env.modtypes renv.modtypes;
+    modtypes = IdTbl.add id info env.modtypes;
     summary = Env_modtype(env.summary, id, info) }
 
-and store_class slot id path desc env renv =
+and store_class id desc env =
   { env with
-    classes = EnvTbl.add slot (fun x -> `Class x) id (path, desc)
-        env.classes renv.classes;
+    classes = IdTbl.add id desc env.classes;
     summary = Env_class(env.summary, id, desc) }
 
-and store_cltype slot id path desc env renv =
+and store_cltype id desc env =
   { env with
-    cltypes = EnvTbl.add slot (fun x -> `Class_type x) id (path, desc)
-        env.cltypes renv.cltypes;
+    cltypes = IdTbl.add id desc env.cltypes;
     summary = Env_cltype(env.summary, id, desc) }
 
 (* Compute the components of a functor application in a path. *)
@@ -1696,31 +1940,26 @@ let add_functor_arg id env =
    summary = Env_functor_arg (env.summary, id)}
 
 let add_value ?check id desc env =
-  store_value None ?check id (Pident id) desc env env
+  store_value ?check id desc env
 
 let add_type ~check id info env =
-  store_type ~check None id (Pident id) info env env
+  store_type ~check id info env
 
 and add_extension ~check id ext env =
-  store_extension ~check None id (Pident id) ext env env
+  store_extension ~check id ext env
 
 and add_module_declaration ?(arg=false) ~check id md env =
-  let path =
-    (*match md.md_type with
-      Mty_alias path -> normalize_path env path
-    | _ ->*) Pident id
-  in
-  let env = store_module ~check None id path md env env in
+  let env = store_module ~check id md env in
   if arg then add_functor_arg id env else env
 
 and add_modtype id info env =
-  store_modtype None id (Pident id) info env env
+  store_modtype id info env
 
 and add_class id ty env =
-  store_class None id (Pident id) ty env env
+  store_class id ty env
 
 and add_cltype id ty env =
-  store_cltype None id (Pident id) ty env env
+  store_cltype id ty env
 
 let add_module ?arg id mty env =
   add_module_declaration ~check:false ?arg id (md mty) env
@@ -1741,7 +1980,7 @@ let add_local_constraint path info elv env =
 (* Insertion of bindings by name *)
 
 let enter store_fun name data env =
-  let id = Ident.create name in (id, store_fun None id (Pident id) data env env)
+  let id = Ident.create name in (id, store_fun id data env)
 
 let enter_value ?check = enter (store_value ?check)
 and enter_type = enter (store_type ~check:true)
@@ -1777,53 +2016,84 @@ let rec add_signature sg env =
 
 (* Open a signature path *)
 
-let open_signature slot root sg env0 =
-  (* First build the paths and substitution *)
-  let (pl, _sub, sg) = prefix_idents_and_subst root Subst.identity sg in
-  let sg = Lazy.force sg in
+let add_components slot root env0 comps =
+  let add_l w comps env0 =
+    TycompTbl.add_open slot w comps env0
+  in
 
-  (* Then enter the components in the environment after substitution *)
+  let add w comps env0 = IdTbl.add_open slot w root comps env0 in
+
+  let constrs =
+    add_l (fun x -> `Constructor x) comps.comp_constrs env0.constrs
+  in
+  let labels =
+    add_l (fun x -> `Label x) comps.comp_labels env0.labels
+  in
+
+  let values =
+    add (fun x -> `Value x) comps.comp_values env0.values
+  in
+  let types =
+    add (fun x -> `Type x) comps.comp_types env0.types
+  in
+  let modtypes =
+    add (fun x -> `Module_type x) comps.comp_modtypes env0.modtypes
+  in
+  let classes =
+    add (fun x -> `Class x) comps.comp_classes env0.classes
+  in
+  let cltypes =
+    add (fun x -> `Class_type x) comps.comp_cltypes env0.cltypes
+  in
+  let components =
+    add (fun x -> `Component x) comps.comp_components env0.components
+  in
+
+  let modules =
+    add (fun x -> `Module x) comps.comp_modules env0.modules
+  in
+
+  { env0 with
+    summary = Env_open(env0.summary, root);
+    constrs;
+    labels;
+    values;
+    types;
+    modtypes;
+    classes;
+    cltypes;
+    components;
+    modules;
+  }
+
+let open_signature slot root env0 =
+  match get_components (find_module_descr root env0) with
+  | Functor_comps _ -> None
+  | Structure_comps comps -> Some (add_components slot root env0 comps)
 
-  let newenv =
-    List.fold_left2
-      (fun env item p ->
-        match item with
-          Sig_value(id, decl) ->
-            store_value slot (Ident.hide id) p decl env env0
-        | Sig_type(id, decl, _) ->
-            store_type ~check:false slot (Ident.hide id) p decl env env0
-        | Sig_typext(id, ext, _) ->
-            store_extension ~check:false slot (Ident.hide id) p ext env env0
-        | Sig_module(id, mty, _) ->
-            store_module ~check:false slot (Ident.hide id) p mty env env0
-        | Sig_modtype(id, decl) ->
-            store_modtype slot (Ident.hide id) p decl env env0
-        | Sig_class(id, decl, _) ->
-            store_class slot (Ident.hide id) p decl env env0
-        | Sig_class_type(id, decl, _) ->
-            store_cltype slot (Ident.hide id) p decl env env0
-      )
-      env0 sg pl in
-  { newenv with summary = Env_open(env0.summary, root) }
 
 (* Open a signature from a file *)
 
 let open_pers_signature name env =
-  let ps = find_pers_struct name in
-  open_signature None (Pident(Ident.create_persistent name))
-    (Lazy.force ps.ps_sig) env
+  match open_signature None (Pident(Ident.create_persistent name)) env with
+  | Some env -> env
+  | None -> assert false (* a compilation unit cannot refer to a functor *)
 
-let open_signature ?(loc = Location.none) ?(toplevel = false) ovf root sg env =
+let open_signature
+    ?(used_slot = ref false)
+    ?(loc = Location.none) ?(toplevel = false) ovf root env =
   if not toplevel && ovf = Asttypes.Fresh && not loc.Location.loc_ghost
      && (Warnings.is_active (Warnings.Unused_open "")
          || Warnings.is_active (Warnings.Open_shadow_identifier ("", ""))
          || Warnings.is_active (Warnings.Open_shadow_label_constructor ("","")))
   then begin
-    let used = ref false in
+    let used = used_slot in
     !add_delayed_check_forward
       (fun () ->
-        if not !used then
-          Location.prerr_warning loc (Warnings.Unused_open (Path.name root))
+         if not !used then begin
+           used := true;
+           Location.prerr_warning loc (Warnings.Unused_open (Path.name root))
+         end
       );
     let shadowed = ref [] in
     let slot s b =
@@ -1841,9 +2111,9 @@ let open_signature ?(loc = Location.none) ?(toplevel = false) ovf root sg env =
       end;
       used := true
     in
-    open_signature (Some slot) root sg env
+    open_signature (Some slot) root env
   end
-  else open_signature None root sg env
+  else open_signature None root env
 
 (* Read a signature from a file *)
 
@@ -1890,7 +2160,6 @@ let save_signature_with_imports ~deprecated sg modname filename imports =
       (match deprecated with Some s -> [Deprecated s] | None -> []);
     ]
   in
-  let oc = open_out_bin filename in
   try
     let cmi = {
       cmi_name = modname;
@@ -1898,8 +2167,10 @@ let save_signature_with_imports ~deprecated sg modname filename imports =
       cmi_crcs = imports;
       cmi_flags = flags;
     } in
-    let crc = output_cmi filename oc cmi in
-    close_out oc;
+    let crc =
+      output_to_file_via_temporary (* see MPR#7472, MPR#4991 *)
+         ~mode: [Open_binary] filename
+         (fun temp_filename oc -> output_cmi temp_filename oc cmi) in
     (* Enter signature in persistent table so that imported_unit()
        will also return its crc *)
     let comps =
@@ -1917,7 +2188,6 @@ let save_signature_with_imports ~deprecated sg modname filename imports =
     save_pers_struct crc ps;
     cmi
   with exn ->
-    close_out oc;
     remove_file filename;
     raise exn
 
@@ -1929,8 +2199,8 @@ let save_signature ~deprecated sg modname filename =
 let find_all proj1 proj2 f lid env acc =
   match lid with
     | None ->
-      EnvTbl.fold_name
-        (fun id (p, data) acc -> f (Ident.name id) p data acc)
+      IdTbl.fold_name
+        (fun name (p, data) acc -> f name p data acc)
         (proj1 env) acc
     | Some l ->
       let p, desc = lookup_module_descr l env in
@@ -1946,8 +2216,8 @@ let find_all proj1 proj2 f lid env acc =
 let find_all_simple_list proj1 proj2 f lid env acc =
   match lid with
     | None ->
-      EnvTbl.fold_name
-        (fun _id data acc -> f data acc)
+      TycompTbl.fold_name
+        (fun data acc -> f data acc)
         (proj1 env) acc
     | Some l ->
       let (_p, desc) = lookup_module_descr l env in
@@ -1957,7 +2227,7 @@ let find_all_simple_list proj1 proj2 f lid env acc =
               (fun _s comps acc ->
                 match comps with
                   [] -> acc
-                | (data, _pos) :: _ ->
+                | data :: _ ->
                   f data acc)
               (proj2 c) acc
         | Functor_comps _ ->
@@ -1968,8 +2238,11 @@ let fold_modules f lid env acc =
   match lid with
     | None ->
       let acc =
-        EnvTbl.fold_name
-          (fun id (p, data) acc -> f (Ident.name id) p data acc)
+        IdTbl.fold_name
+          (fun name (p, data) acc ->
+             let data = EnvLazy.force subst_modtype_maker data in
+             f name p data acc
+          )
           env.modules
           acc
       in
@@ -1989,7 +2262,7 @@ let fold_modules f lid env acc =
             Tbl.fold
               (fun s (data, pos) acc ->
                 f s (Pdot (p, s, pos))
-                    (md (EnvLazy.force subst_modtype_maker data)) acc)
+                    (EnvLazy.force subst_modtype_maker data) acc)
               c.comp_modules
               acc
         | Functor_comps _ ->
@@ -2073,7 +2346,7 @@ let report_error ppf = function
       fprintf ppf
         "@[<hov>Unit %s imports from %s, compiled with -unsafe-string.@ %s@]"
         export import "This compiler has been configured in strict \
-                       -safe-string mode"
+                       safe-string mode (-force-safe-string)"
   | Missing_module(_, path1, path2) ->
       fprintf ppf "@[@[<hov>";
       if Path.same path1 path2 then

diff --git a/typing/env.mli b/typing/env.mli
index 1bf072c47c124a7d2ee9b80cf55c73ffcf0e539d..f96c76b7c1ee3d124628225a44f684b3d12fe2d0 100644 (file)
--- a/typing/env.mli
+++ b/typing/env.mli
@@ -32,6 +32,7 @@ type summary =
   | Env_open of summary * Path.t
   | Env_functor_arg of summary * Ident.t
   | Env_constraints of summary * type_declaration PathMap.t
+  | Env_copy_types of summary * string list
 
 type t
 
@@ -123,8 +124,7 @@ val lookup_class:
 val lookup_cltype:
   ?loc:Location.t -> Longident.t -> t -> Path.t * class_type_declaration
 
-val update_value:
-  string -> (value_description -> value_description) -> t -> t
+val copy_types: string list -> t -> t
   (* Used only in Typecore.duplicate_ident_types. *)
 
 exception Recmodule
@@ -153,11 +153,13 @@ val add_item: signature_item -> t -> t
 val add_signature: signature -> t -> t
 
 (* Insertion of all fields of a signature, relative to the given path.
-   Used to implement open. *)
-
+   Used to implement open. Returns None if the path refers to a functor,
+   not a structure. *)
 val open_signature:
+    ?used_slot:bool ref ->
     ?loc:Location.t -> ?toplevel:bool -> Asttypes.override_flag -> Path.t ->
-      signature -> t -> t
+      t -> t option
+
 val open_pers_signature: string -> t -> t
 
 (* Insertion by name *)
@@ -267,7 +269,7 @@ val set_type_used_callback:
 
 (* Forward declaration to break mutual recursion with Includemod. *)
 val check_modtype_inclusion:
-      (t -> module_type -> Path.t -> module_type -> unit) ref
+      (loc:Location.t -> t -> module_type -> Path.t -> module_type -> unit) ref
 (* Forward declaration to break mutual recursion with Typecore. *)
 val add_delayed_check_forward: ((unit -> unit) -> unit) ref
 (* Forward declaration to break mutual recursion with Mtype. *)

diff --git a/typing/envaux.ml b/typing/envaux.ml
index 53f4d8877b232fb3ba75f0d3bdd46f190ffc9c2e..c78f152b666e49c9936f3d0652587ae946fddedd 100644 (file)
--- a/typing/envaux.ml
+++ b/typing/envaux.ml
@@ -14,8 +14,6 @@
 (*                                                                        *)
 (**************************************************************************)
 
-open Misc
-open Types
 open Env
 
 type error =
@@ -30,11 +28,6 @@ let reset_cache () =
   Hashtbl.clear env_cache;
   Env.reset_cache()
 
-let extract_sig env mty =
-  match Env.scrape_alias env mty with
-    Mty_signature sg -> sg
-  | _ -> fatal_error "Envaux.extract_sig"
-
 let rec env_from_summary sum subst =
   try
     Hashtbl.find env_cache (sum, subst)
@@ -70,14 +63,10 @@ let rec env_from_summary sum subst =
       | Env_open(s, path) ->
           let env = env_from_summary s subst in
           let path' = Subst.module_path subst path in
-          let md =
-            try
-              Env.find_module path' env
-            with Not_found ->
-              raise (Error (Module_not_found path'))
-          in
-          Env.open_signature Asttypes.Override path'
-            (extract_sig env md.md_type) env
+          begin match Env.open_signature Asttypes.Override path' env with
+          | Some env -> env
+          | None -> assert false
+          end
       | Env_functor_arg(Env_module(s, id, desc), id') when Ident.same id id' ->
           Env.add_module_declaration ~check:false
             id (Subst.module_declaration subst desc)
@@ -89,6 +78,8 @@ let rec env_from_summary sum subst =
               Env.add_local_type (Subst.type_path subst path)
                 (Subst.type_declaration subst info))
             map (env_from_summary s subst)
+      | Env_copy_types (s, sl) ->
+          Env.copy_types sl (env_from_summary s subst)
     in
       Hashtbl.add env_cache (sum, subst) env;
       env

diff --git a/typing/ident.ml b/typing/ident.ml
index 951403fea7f5f86f8f67add128abfab931709d7b..c5556cb833fb588dfd87f2bee55187a3a3c00718 100644 (file)
--- a/typing/ident.ml
+++ b/typing/ident.ml
@@ -169,13 +169,13 @@ let rec find_name name = function
   | Node(l, k, r, _) ->
       let c = compare name k.ident.name in
       if c = 0 then
-        k.data
+        k.ident, k.data
       else
         find_name name (if c < 0 then l else r)
 
 let rec get_all = function
   | None -> []
-  | Some k -> k.data :: get_all k.previous
+  | Some k -> (k.ident, k.data) :: get_all k.previous
 
 let rec find_all name = function
     Empty ->
@@ -183,7 +183,7 @@ let rec find_all name = function
   | Node(l, k, r, _) ->
       let c = compare name k.ident.name in
       if c = 0 then
-        k.data :: get_all k.previous
+        (k.ident, k.data) :: get_all k.previous
       else
         find_all name (if c < 0 then l else r)
 

diff --git a/typing/ident.mli b/typing/ident.mli
index 52dd54ea5b2ba567a13ba86b6beeb74f8b537f4d..c2983edbed4c44674f4b54ea2325e4e81e635e0d 100644 (file)
--- a/typing/ident.mli
+++ b/typing/ident.mli
@@ -61,8 +61,8 @@ type 'a tbl
 val empty: 'a tbl
 val add: t -> 'a -> 'a tbl -> 'a tbl
 val find_same: t -> 'a tbl -> 'a
-val find_name: string -> 'a tbl -> 'a
-val find_all: string -> 'a tbl -> 'a list
+val find_name: string -> 'a tbl -> t * 'a
+val find_all: string -> 'a tbl -> (t * 'a) list
 val fold_name: (t -> 'a -> 'b -> 'b) -> 'a tbl -> 'b -> 'b
 val fold_all: (t -> 'a -> 'b -> 'b) -> 'a tbl -> 'b -> 'b
 val iter: (t -> 'a -> unit) -> 'a tbl -> unit

diff --git a/typing/includeclass.ml b/typing/includeclass.ml
index 10748bffd99991c7907d70449300e67fc8037e49..59e363ca3d7a4b14f001903081e3a0de1be93539 100644 (file)
--- a/typing/includeclass.ml
+++ b/typing/includeclass.ml
@@ -20,7 +20,13 @@ open Types
 let class_types env cty1 cty2 =
   Ctype.match_class_types env cty1 cty2
 
-let class_type_declarations env cty1 cty2 =
+let class_type_declarations ~loc env cty1 cty2 =
+  Builtin_attributes.check_deprecated_inclusion
+    ~def:cty1.clty_loc
+    ~use:cty2.clty_loc
+    loc
+    cty1.clty_attributes cty2.clty_attributes
+    (Path.last cty1.clty_path);
   Ctype.match_class_declarations env
     cty1.clty_params cty1.clty_type
     cty2.clty_params cty2.clty_type

diff --git a/typing/includeclass.mli b/typing/includeclass.mli
index 7483ee807b23fca1e1fd49dd0225c82d1d070a97..ebfa97897f7feb5a057a4eea7360f7d029d17963 100644 (file)
--- a/typing/includeclass.mli
+++ b/typing/includeclass.mli
@@ -22,10 +22,11 @@ open Format
 val class_types:
         Env.t -> class_type -> class_type -> class_match_failure list
 val class_type_declarations:
-        Env.t -> class_type_declaration -> class_type_declaration ->
-        class_match_failure list
+  loc:Location.t ->
+  Env.t -> class_type_declaration -> class_type_declaration ->
+  class_match_failure list
 val class_declarations:
-        Env.t -> class_declaration -> class_declaration ->
-        class_match_failure list
+  Env.t -> class_declaration -> class_declaration ->
+  class_match_failure list
 
 val report_error: formatter -> class_match_failure list -> unit

diff --git a/typing/includecore.ml b/typing/includecore.ml
index 382a33d6ca77e15ac6cea636ef94661eefa755de..4982a8a5c20523d4ed82101881f7944e521ddd14 100644 (file)
--- a/typing/includecore.ml
+++ b/typing/includecore.ml
@@ -24,7 +24,15 @@ open Typedtree
 
 exception Dont_match
 
-let value_descriptions env vd1 vd2 =
+let value_descriptions ~loc env name
+    (vd1 : Types.value_description)
+    (vd2 : Types.value_description) =
+  Builtin_attributes.check_deprecated_inclusion
+    ~def:vd1.val_loc
+    ~use:vd2.val_loc
+    loc
+    vd1.val_attributes vd2.val_attributes
+    name;
   if Ctype.moregeneral env true vd1.val_type vd2.val_type then begin
     match (vd1.val_kind, vd2.val_kind) with
         (Val_prim p1, Val_prim p2) ->
@@ -167,7 +175,7 @@ let report_type_mismatch first second decl ppf =
       if err = Manifest then () else
       Format.fprintf ppf "@ %a." (report_type_mismatch0 first second decl) err)
 
-let rec compare_constructor_arguments env cstr params1 params2 arg1 arg2 =
+let rec compare_constructor_arguments ~loc env cstr params1 params2 arg1 arg2 =
   match arg1, arg2 with
   | Types.Cstr_tuple arg1, Types.Cstr_tuple arg2 ->
       if List.length arg1 <> List.length arg2 then [Field_arity cstr]
@@ -176,52 +184,78 @@ let rec compare_constructor_arguments env cstr params1 params2 arg1 arg2 =
         Ctype.equal env true (params1 @ arg1) (params2 @ arg2)
       then [] else [Field_type cstr]
   | Types.Cstr_record l1, Types.Cstr_record l2 ->
-      compare_records env params1 params2 0 l1 l2
+      compare_records env ~loc params1 params2 0 l1 l2
   | _ -> [Field_type cstr]
 
-and compare_variants env params1 params2 n cstrs1 cstrs2 =
+and compare_variants ~loc env params1 params2 n
+    (cstrs1 : Types.constructor_declaration list)
+    (cstrs2 : Types.constructor_declaration list) =
   match cstrs1, cstrs2 with
     [], []           -> []
   | [], c::_ -> [Field_missing (true, c.Types.cd_id)]
   | c::_, [] -> [Field_missing (false, c.Types.cd_id)]
-  | {Types.cd_id=cstr1; cd_args=arg1; cd_res=ret1}::rem1,
-    {Types.cd_id=cstr2; cd_args=arg2; cd_res=ret2}::rem2 ->
-      if Ident.name cstr1 <> Ident.name cstr2 then
-        [Field_names (n, cstr1, cstr2)]
-      else
+  | cd1::rem1, cd2::rem2 ->
+      if Ident.name cd1.cd_id <> Ident.name cd2.cd_id then
+        [Field_names (n, cd1.cd_id, cd2.cd_id)]
+      else begin
+        Builtin_attributes.check_deprecated_inclusion
+          ~def:cd1.cd_loc
+          ~use:cd2.cd_loc
+          loc
+          cd1.cd_attributes cd2.cd_attributes
+          (Ident.name cd1.cd_id);
         let r =
-          match ret1, ret2 with
+          match cd1.cd_res, cd2.cd_res with
           | Some r1, Some r2 ->
               if Ctype.equal env true [r1] [r2] then
-                compare_constructor_arguments env cstr1 [r1] [r2] arg1 arg2
-              else [Field_type cstr1]
+                compare_constructor_arguments ~loc env cd1.cd_id [r1] [r2]
+                  cd1.cd_args cd2.cd_args
+              else [Field_type cd1.cd_id]
           | Some _, None | None, Some _ ->
-              [Field_type cstr1]
+              [Field_type cd1.cd_id]
           | _ ->
-              compare_constructor_arguments env cstr1
-                params1 params2 arg1 arg2
+              compare_constructor_arguments ~loc env cd1.cd_id
+                params1 params2 cd1.cd_args cd2.cd_args
         in
         if r <> [] then r
-        else compare_variants env params1 params2 (n+1) rem1 rem2
+        else compare_variants ~loc env params1 params2 (n+1) rem1 rem2
+      end
 
 
-and compare_records env params1 params2 n labels1 labels2 =
+and compare_records ~loc env params1 params2 n
+    (labels1 : Types.label_declaration list)
+    (labels2 : Types.label_declaration list) =
   match labels1, labels2 with
     [], []           -> []
   | [], l::_ -> [Field_missing (true, l.Types.ld_id)]
   | l::_, [] -> [Field_missing (false, l.Types.ld_id)]
-  | {Types.ld_id=lab1; ld_mutable=mut1; ld_type=arg1}::rem1,
-    {Types.ld_id=lab2; ld_mutable=mut2; ld_type=arg2}::rem2 ->
-      if Ident.name lab1 <> Ident.name lab2
-      then [Field_names (n, lab1, lab2)]
-      else if mut1 <> mut2 then [Field_mutable lab1] else
-      if Ctype.equal env true (arg1::params1)
-                              (arg2::params2)
-      then (* add arguments to the parameters, cf. PR#7378 *)
-        compare_records env (arg1::params1) (arg2::params2) (n+1) rem1 rem2
-      else [Field_type lab1]
+  | ld1::rem1, ld2::rem2 ->
+      if Ident.name ld1.ld_id <> Ident.name ld2.ld_id
+      then [Field_names (n, ld1.ld_id, ld2.ld_id)]
+      else if ld1.ld_mutable <> ld2.ld_mutable then [Field_mutable ld1.ld_id] else begin
+        Builtin_attributes.check_deprecated_mutable_inclusion
+          ~def:ld1.ld_loc
+          ~use:ld2.ld_loc
+          loc
+          ld1.ld_attributes ld2.ld_attributes
+          (Ident.name ld1.ld_id);
+        if Ctype.equal env true (ld1.ld_type::params1)(ld2.ld_type::params2)
+        then (* add arguments to the parameters, cf. PR#7378 *)
+          compare_records ~loc env
+            (ld1.ld_type::params1) (ld2.ld_type::params2)
+            (n+1)
+            rem1 rem2
+        else
+          [Field_type ld1.ld_id]
+      end
 
-let type_declarations ?(equality = false) env name decl1 id decl2 =
+let type_declarations ?(equality = false) ~loc env name decl1 id decl2 =
+  Builtin_attributes.check_deprecated_inclusion
+    ~def:decl1.type_loc
+    ~use:decl2.type_loc
+    loc
+    decl1.type_attributes decl2.type_attributes
+    name;
   if decl1.type_arity <> decl2.type_arity then [Arity] else
   if not (private_flags decl1 decl2) then [Privacy] else
   let err = match (decl1.type_manifest, decl2.type_manifest) with
@@ -267,9 +301,9 @@ let type_declarations ?(equality = false) env name decl1 id decl2 =
         in
         mark cstrs1 usage name decl1;
         if equality then mark cstrs2 Env.Positive (Ident.name id) decl2;
-        compare_variants env decl1.type_params decl2.type_params 1 cstrs1 cstrs2
+        compare_variants ~loc env decl1.type_params decl2.type_params 1 cstrs1 cstrs2
     | (Type_record(labels1,rep1), Type_record(labels2,rep2)) ->
-        let err = compare_records env decl1.type_params decl2.type_params
+        let err = compare_records ~loc env decl1.type_params decl2.type_params
             1 labels1 labels2 in
         if err <> [] || rep1 = rep2 then err else
         [Record_representation (rep2 = Record_float)]
@@ -288,6 +322,9 @@ let type_declarations ?(equality = false) env name decl1 id decl2 =
     else []
   in
   if err <> [] then err else
+  let need_variance =
+    abstr || decl1.type_private = Private || decl1.type_kind = Type_open in
+  if not need_variance then [] else
   let abstr = abstr || decl2.type_private = Private in
   let opn = decl2.type_kind = Type_open && decl2.type_manifest = None in
   let constrained ty = not (Btype.(is_Tvar (repr ty))) in
@@ -306,7 +343,7 @@ let type_declarations ?(equality = false) env name decl1 id decl2 =
 
 (* Inclusion between extension constructors *)
 
-let extension_constructors env id ext1 ext2 =
+let extension_constructors ~loc env id ext1 ext2 =
   let usage =
     if ext1.ext_private = Private || ext2.ext_private = Public
     then Env.Positive else Env.Privatize
@@ -322,7 +359,7 @@ let extension_constructors env id ext1 ext2 =
        (ty1 :: ext1.ext_type_params)
        (ty2 :: ext2.ext_type_params)
   then
-    if compare_constructor_arguments env (Ident.create "")
+    if compare_constructor_arguments ~loc env (Ident.create "")
         ext1.ext_type_params ext2.ext_type_params
         ext1.ext_args ext2.ext_args = [] then
       if match ext1.ext_ret_type, ext2.ext_ret_type with

diff --git a/typing/includecore.mli b/typing/includecore.mli
index 8ddd59cddcdac1c1173f4d81512f0e2ab6cf41d6..e3b8cac106724d0be6053b892f28e31a0344bf51 100644 (file)
--- a/typing/includecore.mli
+++ b/typing/includecore.mli
@@ -37,13 +37,19 @@ type type_mismatch =
   | Immediate
 
 val value_descriptions:
-    Env.t -> value_description -> value_description -> module_coercion
+  loc:Location.t -> Env.t -> string ->
+  value_description -> value_description -> module_coercion
+
 val type_declarations:
-    ?equality:bool ->
-      Env.t -> string ->
-        type_declaration -> Ident.t -> type_declaration -> type_mismatch list
+  ?equality:bool ->
+  loc:Location.t ->
+  Env.t -> string ->
+  type_declaration -> Ident.t -> type_declaration -> type_mismatch list
+
 val extension_constructors:
-    Env.t -> Ident.t -> extension_constructor -> extension_constructor -> bool
+  loc:Location.t ->
+  Env.t -> Ident.t ->
+  extension_constructor -> extension_constructor -> bool
 (*
 val class_types:
         Env.t -> class_type -> class_type -> bool

diff --git a/typing/includemod.ml b/typing/includemod.ml
index f3a3caf5afe585efedf22b0cb78dca941f72ad48..9b12e77855b3983861cfc24babf73f69059f7fec 100644 (file)
--- a/typing/includemod.ml
+++ b/typing/includemod.ml
@@ -53,37 +53,39 @@ exception Error of error list
 
 (* Inclusion between value descriptions *)
 
-let value_descriptions env cxt subst id vd1 vd2 =
+let value_descriptions ~loc env cxt subst id vd1 vd2 =
   Cmt_format.record_value_dependency vd1 vd2;
   Env.mark_value_used env (Ident.name id) vd1;
   let vd2 = Subst.value_description subst vd2 in
   try
-    Includecore.value_descriptions env vd1 vd2
+    Includecore.value_descriptions ~loc env (Ident.name id) vd1 vd2
   with Includecore.Dont_match ->
     raise(Error[cxt, env, Value_descriptions(id, vd1, vd2)])
 
 (* Inclusion between type declarations *)
 
-let type_declarations env ?(old_env=env) cxt subst id decl1 decl2 =
+let type_declarations ~loc env ?(old_env=env) cxt subst id decl1 decl2 =
   Env.mark_type_used env (Ident.name id) decl1;
   let decl2 = Subst.type_declaration subst decl2 in
-  let err = Includecore.type_declarations env (Ident.name id) decl1 id decl2 in
+  let err =
+    Includecore.type_declarations ~loc env (Ident.name id) decl1 id decl2
+  in
   if err <> [] then
     raise(Error[cxt, old_env, Type_declarations(id, decl1, decl2, err)])
 
 (* Inclusion between extension constructors *)
 
-let extension_constructors env cxt subst id ext1 ext2 =
+let extension_constructors ~loc env cxt subst id ext1 ext2 =
   let ext2 = Subst.extension_constructor subst ext2 in
-  if Includecore.extension_constructors env id ext1 ext2
+  if Includecore.extension_constructors ~loc env id ext1 ext2
   then ()
   else raise(Error[cxt, env, Extension_constructors(id, ext1, ext2)])
 
 (* Inclusion between class declarations *)
 
-let class_type_declarations ~old_env env cxt subst id decl1 decl2 =
+let class_type_declarations ~loc ~old_env env cxt subst id decl1 decl2 =
   let decl2 = Subst.cltype_declaration subst decl2 in
-  match Includeclass.class_type_declarations env decl1 decl2 with
+  match Includeclass.class_type_declarations ~loc env decl1 decl2 with
     []     -> ()
   | reason ->
       raise(Error[cxt, old_env,
@@ -211,9 +213,9 @@ let simplify_structure_coercion cc id_pos_list =
    Return the restriction that transforms a value of the smaller type
    into a value of the bigger type. *)
 
-let rec modtypes env cxt subst mty1 mty2 =
+let rec modtypes ~loc env cxt subst mty1 mty2 =
   try
-    try_modtypes env cxt subst mty1 mty2
+    try_modtypes ~loc env cxt subst mty1 mty2
   with
     Dont_match ->
       raise(Error[cxt, env, Module_types(mty1, Subst.modtype subst mty2)])
@@ -225,7 +227,7 @@ let rec modtypes env cxt subst mty1 mty2 =
           raise(Error((cxt, env, Module_types(mty1, Subst.modtype subst mty2))
                       :: reasons))
 
-and try_modtypes env cxt subst mty1 mty2 =
+and try_modtypes ~loc env cxt subst mty1 mty2 =
   match (mty1, mty2) with
   | (Mty_alias(pres1, p1), Mty_alias(pres2, p2)) -> begin
       if Env.is_functor_arg p2 env then
@@ -259,28 +261,28 @@ and try_modtypes env cxt subst mty1 mty2 =
         Mtype.strengthen ~aliasable:true env
           (expand_module_alias env cxt p1) p1
       in
-      let cc = modtypes env cxt subst mty1 mty2 in
+      let cc = modtypes ~loc env cxt subst mty1 mty2 in
       match pres1 with
       | Mta_present -> cc
       | Mta_absent -> Tcoerce_alias (p1, cc)
     end
   | (Mty_ident p1, _) when may_expand_module_path env p1 ->
-      try_modtypes env cxt subst (expand_module_path env cxt p1) mty2
+      try_modtypes ~loc env cxt subst (expand_module_path env cxt p1) mty2
   | (_, Mty_ident _) ->
-      try_modtypes2 env cxt mty1 (Subst.modtype subst mty2)
+      try_modtypes2 ~loc env cxt mty1 (Subst.modtype subst mty2)
   | (Mty_signature sig1, Mty_signature sig2) ->
-      signatures env cxt subst sig1 sig2
+      signatures ~loc env cxt subst sig1 sig2
   | (Mty_functor(param1, None, res1), Mty_functor(_param2, None, res2)) ->
-      begin match modtypes env (Body param1::cxt) subst res1 res2 with
+      begin match modtypes ~loc env (Body param1::cxt) subst res1 res2 with
         Tcoerce_none -> Tcoerce_none
       | cc -> Tcoerce_functor (Tcoerce_none, cc)
       end
   | (Mty_functor(param1, Some arg1, res1),
      Mty_functor(param2, Some arg2, res2)) ->
       let arg2' = Subst.modtype subst arg2 in
-      let cc_arg = modtypes env (Arg param1::cxt) Subst.identity arg2' arg1 in
+      let cc_arg = modtypes ~loc env (Arg param1::cxt) Subst.identity arg2' arg1 in
       let cc_res =
-        modtypes (Env.add_module param1 arg2' env) (Body param1::cxt)
+        modtypes ~loc (Env.add_module param1 arg2' env) (Body param1::cxt)
           (Subst.add_module param2 (Pident param1) subst) res1 res2 in
       begin match (cc_arg, cc_res) with
           (Tcoerce_none, Tcoerce_none) -> Tcoerce_none
@@ -289,7 +291,7 @@ and try_modtypes env cxt subst mty1 mty2 =
   | (_, _) ->
       raise Dont_match
 
-and try_modtypes2 env cxt mty1 mty2 =
+and try_modtypes2 ~loc env cxt mty1 mty2 =
   (* mty2 is an identifier *)
   match (mty1, mty2) with
     (Mty_ident p1, Mty_ident p2)
@@ -297,13 +299,13 @@ and try_modtypes2 env cxt mty1 mty2 =
                    (Env.normalize_path_prefix None env p2) ->
       Tcoerce_none
   | (_, Mty_ident p2) when may_expand_module_path env p2 ->
-      try_modtypes env cxt Subst.identity mty1 (expand_module_path env cxt p2)
+      try_modtypes ~loc env cxt Subst.identity mty1 (expand_module_path env cxt p2)
   | (_, _) ->
       raise Dont_match
 
 (* Inclusion between signatures *)
 
-and signatures env cxt subst sig1 sig2 =
+and signatures ~loc env cxt subst sig1 sig2 =
   (* Environment used to check inclusion of components *)
   let new_env =
     Env.add_signature sig1 (Env.in_signature true env) in
@@ -342,7 +344,8 @@ and signatures env cxt subst sig1 sig2 =
         begin match unpaired with
             [] ->
               let cc =
-                signature_components env new_env cxt subst (List.rev paired)
+                signature_components ~loc env new_env cxt subst
+                  (List.rev paired)
               in
               if len1 = len2 then (* see PR#5098 *)
                 simplify_structure_coercion cc id_pos_list
@@ -355,8 +358,7 @@ and signatures env cxt subst sig1 sig2 =
         let name2, report =
           match item2, name2 with
             Sig_type (_, {type_manifest=None}, _), Field_type s
-            when let l = String.length s in
-            l >= 4 && String.sub s (l-4) 4 = "#row" ->
+            when Btype.is_row_name s ->
               (* Do not report in case of failure,
                  as the main type will generate an error *)
               Field_type (String.sub s 0 (String.length s - 4)), false
@@ -391,47 +393,60 @@ and signatures env cxt subst sig1 sig2 =
 
 (* Inclusion between signature components *)
 
-and signature_components old_env env cxt subst paired =
-  let comps_rec rem = signature_components old_env env cxt subst rem in
+and signature_components ~loc old_env env cxt subst paired =
+  let comps_rec rem = signature_components ~loc old_env env cxt subst rem in
   match paired with
     [] -> []
   | (Sig_value(id1, valdecl1), Sig_value(_id2, valdecl2), pos) :: rem ->
-      let cc = value_descriptions env cxt subst id1 valdecl1 valdecl2 in
+      let cc = value_descriptions ~loc env cxt subst id1 valdecl1 valdecl2 in
       begin match valdecl2.val_kind with
         Val_prim _ -> comps_rec rem
       | _ -> (pos, cc) :: comps_rec rem
       end
   | (Sig_type(id1, tydecl1, _), Sig_type(_id2, tydecl2, _), _pos) :: rem ->
-      type_declarations ~old_env env cxt subst id1 tydecl1 tydecl2;
+      type_declarations ~loc ~old_env env cxt subst id1 tydecl1 tydecl2;
       comps_rec rem
   | (Sig_typext(id1, ext1, _), Sig_typext(_id2, ext2, _), pos)
     :: rem ->
-      extension_constructors env cxt subst id1 ext1 ext2;
+      extension_constructors ~loc env cxt subst id1 ext1 ext2;
       (pos, Tcoerce_none) :: comps_rec rem
   | (Sig_module(id1, mty1, _), Sig_module(_id2, mty2, _), pos) :: rem ->
-      let p1 = Pident id1 in
-      Env.mark_module_used env (Ident.name id1) mty1.md_loc;
-      let cc =
-        modtypes env (Module id1::cxt) subst
-          (Mtype.strengthen ~aliasable:true env mty1.md_type p1) mty2.md_type
-      in
+      let cc = module_declarations ~loc env cxt subst id1 mty1 mty2 in
       (pos, cc) :: comps_rec rem
   | (Sig_modtype(id1, info1), Sig_modtype(_id2, info2), _pos) :: rem ->
-      modtype_infos env cxt subst id1 info1 info2;
+      modtype_infos ~loc env cxt subst id1 info1 info2;
       comps_rec rem
   | (Sig_class(id1, decl1, _), Sig_class(_id2, decl2, _), pos) :: rem ->
       class_declarations ~old_env env cxt subst id1 decl1 decl2;
       (pos, Tcoerce_none) :: comps_rec rem
   | (Sig_class_type(id1, info1, _),
      Sig_class_type(_id2, info2, _), _pos) :: rem ->
-      class_type_declarations ~old_env env cxt subst id1 info1 info2;
+      class_type_declarations ~loc ~old_env env cxt subst id1 info1 info2;
       comps_rec rem
   | _ ->
       assert false
 
+and module_declarations ~loc env cxt subst id1 md1 md2 =
+  Builtin_attributes.check_deprecated_inclusion
+    ~def:md1.md_loc
+    ~use:md2.md_loc
+    loc
+    md1.md_attributes md2.md_attributes
+    (Ident.name id1);
+  let p1 = Pident id1 in
+  Env.mark_module_used env (Ident.name id1) md1.md_loc;
+  modtypes ~loc env (Module id1::cxt) subst
+    (Mtype.strengthen ~aliasable:true env md1.md_type p1) md2.md_type
+
 (* Inclusion between module type specifications *)
 
-and modtype_infos env cxt subst id info1 info2 =
+and modtype_infos ~loc env cxt subst id info1 info2 =
+  Builtin_attributes.check_deprecated_inclusion
+    ~def:info1.mtd_loc
+    ~use:info2.mtd_loc
+    loc
+    info1.mtd_attributes info2.mtd_attributes
+    (Ident.name id);
   let info2 = Subst.modtype_declaration subst info2 in
   let cxt' = Modtype id :: cxt in
   try
@@ -439,16 +454,16 @@ and modtype_infos env cxt subst id info1 info2 =
       (None, None) -> ()
     | (Some _, None) -> ()
     | (Some mty1, Some mty2) ->
-        check_modtype_equiv env cxt' mty1 mty2
+        check_modtype_equiv ~loc env cxt' mty1 mty2
     | (None, Some mty2) ->
-        check_modtype_equiv env cxt' (Mty_ident(Pident id)) mty2
+        check_modtype_equiv ~loc env cxt' (Mty_ident(Pident id)) mty2
   with Error reasons ->
     raise(Error((cxt, env, Modtype_infos(id, info1, info2)) :: reasons))
 
-and check_modtype_equiv env cxt mty1 mty2 =
+and check_modtype_equiv ~loc env cxt mty1 mty2 =
   match
-    (modtypes env cxt Subst.identity mty1 mty2,
-     modtypes env cxt Subst.identity mty2 mty1)
+    (modtypes ~loc env cxt Subst.identity mty1 mty2,
+     modtypes ~loc env cxt Subst.identity mty2 mty1)
   with
     (Tcoerce_none, Tcoerce_none) -> ()
   | (_c1, _c2) ->
@@ -466,10 +481,10 @@ let can_alias env path =
   in
   no_apply path && not (Env.is_functor_arg path env)
 
-let check_modtype_inclusion env mty1 path1 mty2 =
+let check_modtype_inclusion ~loc env mty1 path1 mty2 =
   try
     let aliasable = can_alias env path1 in
-    ignore(modtypes env [] Subst.identity
+    ignore(modtypes ~loc env [] Subst.identity
                     (Mtype.strengthen ~aliasable env mty1 path1) mty2)
   with Error _ ->
     raise Not_found
@@ -481,17 +496,19 @@ let _ = Env.check_modtype_inclusion := check_modtype_inclusion
 
 let compunit env impl_name impl_sig intf_name intf_sig =
   try
-    signatures env [] Subst.identity impl_sig intf_sig
+    signatures ~loc:(Location.in_file impl_name) env [] Subst.identity
+      impl_sig intf_sig
   with Error reasons ->
     raise(Error(([], Env.empty,Interface_mismatch(impl_name, intf_name))
                 :: reasons))
 
 (* Hide the context and substitution parameters to the outside world *)
 
-let modtypes env mty1 mty2 = modtypes env [] Subst.identity mty1 mty2
-let signatures env sig1 sig2 = signatures env [] Subst.identity sig1 sig2
-let type_declarations env id decl1 decl2 =
-  type_declarations env [] Subst.identity id decl1 decl2
+let modtypes ~loc env mty1 mty2 = modtypes ~loc env [] Subst.identity mty1 mty2
+let signatures env sig1 sig2 =
+  signatures ~loc:Location.none env [] Subst.identity sig1 sig2
+let type_declarations ~loc env id decl1 decl2 =
+  type_declarations ~loc env [] Subst.identity id decl1 decl2
 
 (*
 let modtypes env m1 m2 =

diff --git a/typing/includemod.mli b/typing/includemod.mli
index 72afe398e13b29f31a944fe83ee8f0d0250a9186..d5d3cbfc489bd54b5c4488de3b8a89d73096c54a 100644 (file)
--- a/typing/includemod.mli
+++ b/typing/includemod.mli
@@ -19,12 +19,19 @@ open Typedtree
 open Types
 open Format
 
-val modtypes: Env.t -> module_type -> module_type -> module_coercion
+val modtypes:
+  loc:Location.t -> Env.t ->
+  module_type -> module_type -> module_coercion
+
 val signatures: Env.t -> signature -> signature -> module_coercion
+
 val compunit:
       Env.t -> string -> signature -> string -> signature -> module_coercion
+
 val type_declarations:
-      Env.t -> Ident.t -> type_declaration -> type_declaration -> unit
+  loc:Location.t -> Env.t ->
+  Ident.t -> type_declaration -> type_declaration -> unit
+
 val print_coercion: formatter -> module_coercion -> unit
 
 type symptom =

diff --git a/typing/oprint.ml b/typing/oprint.ml
index b0145ec632067ecd6cc1ac36e53f9c416c5e6529..e825513b64920e4b565f2fa97c01ba4fbf01913c 100644 (file)
--- a/typing/oprint.ml
+++ b/typing/oprint.ml
@@ -22,11 +22,15 @@ let cautious f ppf arg =
   try f ppf arg with
     Ellipsis -> fprintf ppf "..."
 
+let print_lident ppf = function
+  | "::" -> pp_print_string ppf "(::)"
+  | s -> pp_print_string ppf s
+
 let rec print_ident ppf =
   function
-    Oide_ident s -> pp_print_string ppf s
+    Oide_ident s -> print_lident ppf s
   | Oide_dot (id, s) ->
-      print_ident ppf id; pp_print_char ppf '.'; pp_print_string ppf s
+      print_ident ppf id; pp_print_char ppf '.'; print_lident ppf s
   | Oide_apply (id1, id2) ->
       fprintf ppf "%a(%a)" print_ident id1 print_ident id2
 
@@ -74,6 +78,63 @@ let parenthesize_if_neg ppf fmt v isneg =
   fprintf ppf fmt v;
   if isneg then pp_print_char ppf ')'
 
+let escape_string s =
+  (* Escape only C0 control characters (bytes <= 0x1F), DEL(0x7F), '\\' and '"' *)
+   let n = ref 0 in
+  for i = 0 to String.length s - 1 do
+    n := !n +
+      (match String.unsafe_get s i with
+       | '\"' | '\\' | '\n' | '\t' | '\r' | '\b' -> 2
+       | '\x00' .. '\x1F'
+       | '\x7F' -> 4
+       | _ -> 1)
+  done;
+  if !n = String.length s then s else begin
+    let s' = Bytes.create !n in
+    n := 0;
+    for i = 0 to String.length s - 1 do
+      begin match String.unsafe_get s i with
+      | ('\"' | '\\') as c ->
+          Bytes.unsafe_set s' !n '\\'; incr n; Bytes.unsafe_set s' !n c
+      | '\n' ->
+          Bytes.unsafe_set s' !n '\\'; incr n; Bytes.unsafe_set s' !n 'n'
+      | '\t' ->
+          Bytes.unsafe_set s' !n '\\'; incr n; Bytes.unsafe_set s' !n 't'
+      | '\r' ->
+          Bytes.unsafe_set s' !n '\\'; incr n; Bytes.unsafe_set s' !n 'r'
+      | '\b' ->
+          Bytes.unsafe_set s' !n '\\'; incr n; Bytes.unsafe_set s' !n 'b'
+      | '\x00' .. '\x1F' | '\x7F' as c ->
+          let a = Char.code c in
+          Bytes.unsafe_set s' !n '\\';
+          incr n;
+          Bytes.unsafe_set s' !n (Char.chr (48 + a / 100));
+          incr n;
+          Bytes.unsafe_set s' !n (Char.chr (48 + (a / 10) mod 10));
+          incr n;
+          Bytes.unsafe_set s' !n (Char.chr (48 + a mod 10));
+      | c -> Bytes.unsafe_set s' !n c
+      end;
+      incr n
+    done;
+    Bytes.to_string s'
+  end
+
+
+let print_out_string ppf s =
+  let not_escaped =
+    (* let the user dynamically choose if strings should be escaped: *)
+    match Sys.getenv_opt "OCAMLTOP_UTF_8" with
+    | None -> true
+    | Some x ->
+        match bool_of_string_opt x with
+        | None -> true
+        | Some f -> f in
+  if not_escaped then
+    fprintf ppf "\"%s\"" (escape_string s)
+  else
+    fprintf ppf "%S" s
+
 let print_out_value ppf tree =
   let rec print_tree_1 ppf =
     function
@@ -91,6 +152,10 @@ let print_out_value ppf tree =
     | Oval_int64 i -> parenthesize_if_neg ppf "%LiL" i (i < 0L)
     | Oval_nativeint i -> parenthesize_if_neg ppf "%nin" i (i < 0n)
     | Oval_float f -> parenthesize_if_neg ppf "%s" (float_repres f) (f < 0.0)
+    | Oval_string (_,_, Ostr_bytes) as tree ->
+      pp_print_char ppf '(';
+      print_simple_tree ppf tree;
+      pp_print_char ppf ')';
     | tree -> print_simple_tree ppf tree
   and print_simple_tree ppf =
     function
@@ -100,8 +165,19 @@ let print_out_value ppf tree =
     | Oval_nativeint i -> fprintf ppf "%nin" i
     | Oval_float f -> pp_print_string ppf (float_repres f)
     | Oval_char c -> fprintf ppf "%C" c
-    | Oval_string s ->
-        begin try fprintf ppf "%S" s with
+    | Oval_string (s, maxlen, kind) ->
+       begin try
+         let len = String.length s in
+         let s = if len > maxlen then String.sub s 0 maxlen else s in
+         begin match kind with
+         | Ostr_bytes -> fprintf ppf "Bytes.of_string %S" s
+         | Ostr_string -> print_out_string ppf s
+         end;
+         (if len > maxlen then
+            fprintf ppf
+              "... (* string length %d; truncated *)" len
+         )
+          with
           Invalid_argument _ (* "String.create" *)-> fprintf ppf "<huge string>"
         end
     | Oval_list tl ->
@@ -520,7 +596,8 @@ and print_out_type_decl kwd ppf td =
         print_private td.otype_private
         (print_list print_out_constr (fun ppf -> fprintf ppf "@ | ")) constrs
   | Otyp_open ->
-      fprintf ppf " = .."
+      fprintf ppf " =%a .."
+        print_private td.otype_private
   | ty ->
       fprintf ppf " =%a@;<1 2>%a"
         print_private td.otype_private

diff --git a/typing/outcometree.mli b/typing/outcometree.mli
index 17c4862d63b6ee917ab5914ff827dfce86d505b5..e4c62c31f9845dca4c142f80fa1b5ee1d6246e74 100644 (file)
--- a/typing/outcometree.mli
+++ b/typing/outcometree.mli
@@ -27,6 +27,10 @@ type out_ident =
   | Oide_dot of out_ident * string
   | Oide_ident of string
 
+type out_string =
+  | Ostr_string
+  | Ostr_bytes
+
 type out_attribute =
   { oattr_name: string }
 
@@ -43,7 +47,7 @@ type out_value =
   | Oval_list of out_value list
   | Oval_printer of (Format.formatter -> unit)
   | Oval_record of (out_ident * out_value) list
-  | Oval_string of string
+  | Oval_string of string * int * out_string (* string, size-to-print, kind *)
   | Oval_stuff of string
   | Oval_tuple of out_value list
   | Oval_variant of string * out_value option

diff --git a/typing/parmatch.ml b/typing/parmatch.ml
index 9e9357304b97784cb6b520c40e8b8299d3725cd6..a2e64f65fdbf409ff0aff33c9114875e0874fae4 100644 (file)
--- a/typing/parmatch.ml
+++ b/typing/parmatch.ml
@@ -92,7 +92,7 @@ let rec compat p q =
   | Tpat_tuple ps, Tpat_tuple qs -> compats ps qs
   | Tpat_lazy p, Tpat_lazy q -> compat p q
   | Tpat_construct (_, c1,ps1), Tpat_construct (_, c2,ps2) ->
-      c1.cstr_tag = c2.cstr_tag && compats ps1 ps2
+      Types.equal_tag c1.cstr_tag c2.cstr_tag && compats ps1 ps2
   | Tpat_variant(l1,Some p1, _r1), Tpat_variant(l2,Some p2,_) ->
       l1=l2 && compat p1 p2
   | Tpat_variant (l1,None, _r1), Tpat_variant(l2,None,_) ->
@@ -284,7 +284,7 @@ let pretty_matrix (pss : matrix) =
 let simple_match p1 p2 =
   match p1.pat_desc, p2.pat_desc with
   | Tpat_construct(_, c1, _), Tpat_construct(_, c2, _) ->
-      c1.cstr_tag = c2.cstr_tag
+      Types.equal_tag c1.cstr_tag c2.cstr_tag
   | Tpat_variant(l1, _, _), Tpat_variant(l2, _, _) ->
       l1 = l2
   | Tpat_constant(c1), Tpat_constant(c2) -> const_compare c1 c2 = 0
@@ -484,7 +484,7 @@ let do_set_args erase_mutable q r = match q with
 let set_args q r = do_set_args false q r
 and set_args_erase_mutable q r = do_set_args true q r
 
-(* filter pss acording to pattern q *)
+(* filter pss according to pattern q *)
 let filter_one q pss =
   let rec filter_rec = function
       ({pat_desc = Tpat_alias(p,_,_)}::ps)::pss ->
@@ -501,7 +501,7 @@ let filter_one q pss =
 (*
   Filter pss in the ``extra case''. This applies :
   - According to an extra constructor (datatype case, non-complete signature).
-  - Acordinng to anything (all-variables case).
+  - According to anything (all-variables case).
 *)
 let filter_extra pss =
   let rec filter_rec = function
@@ -660,7 +660,7 @@ let full_match closing env =  match env with
   ->
     assert false
 
-(* Written as a non-fragile matching, PR7451 originated from a fragile matching below. *)
+(* Written as a non-fragile matching, PR#7451 originated from a fragile matching below. *)
 let should_extend ext env = match ext with
 | None -> false
 | Some ext -> begin match env with
@@ -681,6 +681,14 @@ let should_extend ext env = match ext with
       end
 end
 
+module ConstructorTagHashtbl = Hashtbl.Make(
+  struct
+    type t = Types.constructor_tag
+    let hash = Hashtbl.hash
+    let equal = Types.equal_tag
+  end
+)
+
 (* complement constructor tags *)
 let complete_tags nconsts nconstrs tags =
   let seen_const = Array.make nconsts false
@@ -691,16 +699,16 @@ let complete_tags nconsts nconstrs tags =
       | Cstr_block i -> seen_constr.(i) <- true
       | _  -> assert false)
     tags ;
-  let r = ref [] in
+  let r = ConstructorTagHashtbl.create (nconsts+nconstrs) in
   for i = 0 to nconsts-1 do
     if not seen_const.(i) then
-      r := Cstr_constant i :: !r
+      ConstructorTagHashtbl.add r (Cstr_constant i) ()
   done ;
   for i = 0 to nconstrs-1 do
     if not seen_constr.(i) then
-      r := Cstr_block i :: !r
+      ConstructorTagHashtbl.add r (Cstr_block i) ()
   done ;
-  !r
+  r
 
 (* build a pattern from a constructor list *)
 let pat_of_constr ex_pat cstr =
@@ -765,7 +773,9 @@ let complete_constrs p all_tags =
   let not_tags = complete_tags c.cstr_consts c.cstr_nonconsts all_tags in
   let constrs = get_variant_constructors p.pat_env c.cstr_res in
   let others =
-    List.filter (fun cnstr -> List.mem cnstr.cstr_tag not_tags) constrs in
+    List.filter
+      (fun cnstr -> ConstructorTagHashtbl.mem not_tags cnstr.cstr_tag) 
+      constrs in
   let const, nonconst =
     List.partition (fun cnstr -> cnstr.cstr_arity = 0) others in
   const @ nonconst
@@ -1245,7 +1255,7 @@ let rec pressure_variants tdefs = function
       end
 
 
-(* Yet another satisfiable fonction *)
+(* Yet another satisfiable function *)
 
 (*
    This time every_satisfiable pss qs checks the
@@ -1501,7 +1511,7 @@ let rec le_pat p q =
   | _, Tpat_alias(q,_,_) -> le_pat p q
   | Tpat_constant(c1), Tpat_constant(c2) -> const_compare c1 c2 = 0
   | Tpat_construct(_,c1,ps), Tpat_construct(_,c2,qs) ->
-      c1.cstr_tag = c2.cstr_tag && le_pats ps qs
+      Types.equal_tag c1.cstr_tag c2.cstr_tag && le_pats ps qs
   | Tpat_variant(l1,Some p1,_), Tpat_variant(l2,Some p2,_) ->
       (l1 = l2 && le_pat p1 p2)
   | Tpat_variant(l1,None,_r1), Tpat_variant(l2,None,_) ->
@@ -1551,7 +1561,7 @@ let rec lub p q = match p.pat_desc,q.pat_desc with
     let r = lub p q in
     make_pat (Tpat_lazy r) p.pat_type p.pat_env
 | Tpat_construct (lid, c1,ps1), Tpat_construct (_,c2,ps2)
-      when  c1.cstr_tag = c2.cstr_tag  ->
+      when  Types.equal_tag c1.cstr_tag c2.cstr_tag  ->
         let rs = lubs ps1 ps2 in
         make_pat (Tpat_construct (lid, c1,rs))
           p.pat_type p.pat_env
@@ -1785,7 +1795,9 @@ let do_check_partial ?pred exhaust loc casel pss = match pss with
           *)
     begin match casel with
     | [] -> ()
-    | _  -> Location.prerr_warning loc Warnings.All_clauses_guarded
+    | _  ->
+      if Warnings.is_active Warnings.All_clauses_guarded then
+        Location.prerr_warning loc Warnings.All_clauses_guarded
     end ;
     Partial
 | ps::_  ->
@@ -1808,32 +1820,34 @@ let do_check_partial ?pred exhaust loc casel pss = match pss with
         begin match v with
           None -> Total
         | Some v ->
-            let errmsg =
-              try
-                let buf = Buffer.create 16 in
-                let fmt = formatter_of_buffer buf in
-                top_pretty fmt v;
-                begin match check_partial_all v casel with
-                | None -> ()
-                | Some _ ->
-                    (* This is 'Some loc', where loc is the location of
-                       a possibly matching clause.
-                       Forget about loc, because printing two locations
-                       is a pain in the top-level *)
+            if Warnings.is_active (Warnings.Partial_match "") then begin
+              let errmsg =
+                try
+                  let buf = Buffer.create 16 in
+                  let fmt = formatter_of_buffer buf in
+                  top_pretty fmt v;
+                  begin match check_partial_all v casel with
+                  | None -> ()
+                  | Some _ ->
+                      (* This is 'Some loc', where loc is the location of
+                         a possibly matching clause.
+                         Forget about loc, because printing two locations
+                         is a pain in the top-level *)
+                      Buffer.add_string buf
+                        "\n(However, some guarded clause may match this value.)"
+                  end;
+                  if contains_extension v then
                     Buffer.add_string buf
-                      "\n(However, some guarded clause may match this value.)"
-                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 _ ->
-                ""
-            in
-            Location.prerr_warning loc (Warnings.Partial_match errmsg) ;
+                      "\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 _ ->
+                  ""
+              in
+                Location.prerr_warning loc (Warnings.Partial_match errmsg)
+            end;
             Partial
         end
     | _ ->
@@ -1896,7 +1910,7 @@ let rec collect_paths_from_pat r p = match p.pat_desc with
 (*
   Actual fragile check
    1. Collect data types in the patterns of the match.
-   2. One exhautivity check per datatype, considering that
+   2. One exhaustivity check per datatype, considering that
       the type is extended.
 *)
 
@@ -1990,28 +2004,35 @@ let check_unused pred casel =
 
 let irrefutable pat = le_pat pat omega
 
-(* An inactive pattern is a pattern whose matching needs only
-   trivial computations (tag/equality tests).
-   Patterns containing (lazy _) subpatterns are active. *)
-
-let rec inactive pat = match pat with
-| Tpat_lazy _ ->
-    false
-| Tpat_any | Tpat_var _ | Tpat_constant _ | Tpat_variant (_, None, _) ->
-    true
-| Tpat_tuple ps | Tpat_construct (_, _, ps) | Tpat_array ps ->
-    List.for_all (fun p -> inactive p.pat_desc) ps
-| Tpat_alias (p,_,_) | Tpat_variant (_, Some p, _) ->
-    inactive p.pat_desc
-| Tpat_record (ldps,_) ->
-    List.exists (fun (_, _, p) -> inactive p.pat_desc) ldps
-| Tpat_or (p,q,_) ->
-    inactive p.pat_desc && inactive q.pat_desc
-
-(* A `fluid' pattern is both irrefutable and inactive *)
-
-let fluid pat =  irrefutable pat && inactive pat.pat_desc
-
+let inactive ~partial pat =
+  match partial with
+  | Partial -> false
+  | Total -> begin
+      let rec loop pat =
+        match pat.pat_desc with
+        | Tpat_lazy _ | Tpat_array _ ->
+          false
+        | Tpat_any | Tpat_var _ | Tpat_variant (_, None, _) ->
+            true
+        | Tpat_constant c -> begin
+            match c with
+            | Const_string _ -> Config.safe_string
+            | Const_int _ | Const_char _ | Const_float _
+            | Const_int32 _ | Const_int64 _ | Const_nativeint _ -> true
+          end
+        | Tpat_tuple ps | Tpat_construct (_, _, ps) ->
+            List.for_all (fun p -> loop p) ps
+        | Tpat_alias (p,_,_) | Tpat_variant (_, Some p, _) ->
+            loop p
+        | Tpat_record (ldps,_) ->
+            List.for_all
+              (fun (_, lbl, p) -> lbl.lbl_mut = Immutable && loop p)
+              ldps
+        | Tpat_or (p,q,_) ->
+            loop p && loop q
+      in
+      loop pat
+  end
 
 
 
@@ -2019,9 +2040,9 @@ let fluid pat =  irrefutable pat && inactive pat.pat_desc
 
 
 
-(********************************)
-(* Exported exhustiveness check *)
-(********************************)
+(*********************************)
+(* Exported exhaustiveness check *)
+(*********************************)
 
 (*
    Fragile check is performed when required and
@@ -2029,18 +2050,15 @@ let fluid pat =  irrefutable pat && inactive pat.pat_desc
 *)
 
 let check_partial_param do_check_partial do_check_fragile loc casel =
-    if Warnings.is_active (Warnings.Partial_match "") then begin
-      let pss = initial_matrix casel in
-      let pss = get_mins le_pats pss in
-      let total = do_check_partial loc casel pss in
-      if
-        total = Total && Warnings.is_active (Warnings.Fragile_match "")
-      then begin
-        do_check_fragile loc casel pss
-      end ;
-      total
-    end else
-      Partial
+    let pss = initial_matrix casel in
+    let pss = get_mins le_pats pss in
+    let total = do_check_partial loc casel pss in
+    if
+      total = Total && Warnings.is_active (Warnings.Fragile_match "")
+    then begin
+      do_check_fragile loc casel pss
+    end ;
+    total
 
 (*let check_partial =
     check_partial_param
@@ -2268,7 +2286,7 @@ let all_rhs_idents exp =
       | _ -> ()
 
 (* Very hackish, detect unpack pattern  compilation
-   and perfom "indirect check for them" *)
+   and perform "indirect check for them" *)
     let is_unpack exp =
       List.exists
         (fun (attr, _) -> attr.txt = "#modulepat") exp.exp_attributes

diff --git a/typing/parmatch.mli b/typing/parmatch.mli
index 3dcb6dde159d749703a77d7d9b1a7d85ff8dd4bc..0fb4f7578588dbf6b3f3fc9db6fad5094e51d87c 100644 (file)
--- a/typing/parmatch.mli
+++ b/typing/parmatch.mli
@@ -75,7 +75,11 @@ val check_unused:
 
 (* Irrefutability tests *)
 val irrefutable : pattern -> bool
-val fluid : pattern -> bool
+
+(** An inactive pattern is a pattern, matching against which can be duplicated, erased or
+    delayed without change in observable behavior of the program.  Patterns containing
+    (lazy _) subpatterns or reads of mutable fields are active. *)
+val inactive : partial:partial -> pattern -> bool
 
 (* Ambiguous bindings *)
 val check_ambiguous_bindings : case list -> unit

diff --git a/typing/path.ml b/typing/path.ml
index a1a81015102e363d5877e505022cf80e4596a621..cff31cb81c18aa7fe46b4a222f28d9015a2593c7 100644 (file)
--- a/typing/path.ml
+++ b/typing/path.ml
@@ -63,6 +63,14 @@ let rec head = function
   | Pdot(p, _s, _pos) -> head p
   | Papply _ -> assert false
 
+let flatten =
+  let rec flatten acc = function
+    | Pident id -> `Ok (id, acc)
+    | Pdot (p, s, _) -> flatten (s :: acc) p
+    | Papply _ -> `Contains_apply
+  in
+  fun t -> flatten [] t
+
 let heads p =
   let rec heads p acc = match p with
     | Pident id -> id :: acc

diff --git a/typing/path.mli b/typing/path.mli
index 4853f925c8169cc048a57847729b497f837e17fa..18491462e86411ba63b81b9c438ee5b7a03a7ff9 100644 (file)
--- a/typing/path.mli
+++ b/typing/path.mli
@@ -24,6 +24,7 @@ val same: t -> t -> bool
 val compare: t -> t -> int
 val isfree: Ident.t -> t -> bool
 val binding_time: t -> int
+val flatten : t -> [ `Contains_apply | `Ok of Ident.t * string list ]
 
 val nopos: int
 

diff --git a/typing/predef.ml b/typing/predef.ml
index a16997f96e6b01cb58983ac24a240b125dc2c5a8..e00df7febd6ea5044cd76444efdceebd75b4759b 100644 (file)
--- a/typing/predef.ml
+++ b/typing/predef.ml
@@ -45,6 +45,7 @@ and ident_int64 = ident_create "int64"
 and ident_lazy_t = ident_create "lazy_t"
 and ident_string = ident_create "string"
 and ident_extension_constructor = ident_create "extension_constructor"
+and ident_floatarray = ident_create "floatarray"
 
 let path_int = Pident ident_int
 and path_char = Pident ident_char
@@ -62,6 +63,7 @@ and path_int64 = Pident ident_int64
 and path_lazy_t = Pident ident_lazy_t
 and path_string = Pident ident_string
 and path_extension_constructor = Pident ident_extension_constructor
+and path_floatarray = Pident ident_floatarray
 
 let type_int = newgenty (Tconstr(path_int, [], ref Mnil))
 and type_char = newgenty (Tconstr(path_char, [], ref Mnil))
@@ -80,6 +82,7 @@ and type_lazy_t t = newgenty (Tconstr(path_lazy_t, [t], ref Mnil))
 and type_string = newgenty (Tconstr(path_string, [], ref Mnil))
 and type_extension_constructor =
       newgenty (Tconstr(path_extension_constructor, [], ref Mnil))
+and type_floatarray = newgenty (Tconstr(path_floatarray, [], ref Mnil))
 
 let ident_match_failure = ident_create_predef_exn "Match_failure"
 and ident_out_of_memory = ident_create_predef_exn "Out_of_memory"
@@ -229,7 +232,8 @@ let common_initial_env add_type add_extension empty_env =
   add_type ident_char decl_abstr_imm (
   add_type ident_int decl_abstr_imm (
   add_type ident_extension_constructor decl_abstr (
-    empty_env)))))))))))))))))))))))))))
+  add_type ident_floatarray decl_abstr (
+    empty_env))))))))))))))))))))))))))))
 
 let build_initial_env add_type add_exception empty_env =
   let common = common_initial_env add_type add_exception empty_env in

diff --git a/typing/predef.mli b/typing/predef.mli
index a7bf06342454d7a19c57414cea90390b9854ab3c..878dc6eb9fc8c4187acdfd6e3e1994f4a26713d5 100644 (file)
--- a/typing/predef.mli
+++ b/typing/predef.mli
@@ -33,6 +33,7 @@ val type_int32: type_expr
 val type_int64: type_expr
 val type_lazy_t: type_expr -> type_expr
 val type_extension_constructor:type_expr
+val type_floatarray:type_expr
 
 val path_int: Path.t
 val path_char: Path.t
@@ -50,6 +51,7 @@ val path_int32: Path.t
 val path_int64: Path.t
 val path_lazy_t: Path.t
 val path_extension_constructor: Path.t
+val path_floatarray: Path.t
 
 val path_match_failure: Path.t
 val path_assert_failure : Path.t

diff --git a/typing/primitive.ml b/typing/primitive.ml
index 81a33397a02f16fd7b72817a388bca06d2a00b88..4d0a070d5510b8d1c4524882eabf06d45fab2f6f 100644 (file)
--- a/typing/primitive.ml
+++ b/typing/primitive.ml
@@ -110,13 +110,11 @@ let parse_declaration valdecl ~native_repr_args ~native_repr_res =
      explicit now (GPR#167): *)
   let old_style_noalloc = old_style_noalloc || old_style_float in
   if old_style_float then
-    Location.prerr_warning valdecl.pval_loc
-      (Warnings.Deprecated "[@@unboxed] + [@@noalloc] should be used instead \
-                            of \"float\"")
+    Location.deprecated valdecl.pval_loc
+      "[@@unboxed] + [@@noalloc] should be used instead of \"float\""
   else if old_style_noalloc then
-    Location.prerr_warning valdecl.pval_loc
-      (Warnings.Deprecated "[@@noalloc] should be used instead of \
-                            \"noalloc\"");
+    Location.deprecated valdecl.pval_loc
+      "[@@noalloc] should be used instead of \"noalloc\"";
   if native_name = "" &&
      not (List.for_all is_ocaml_repr native_repr_args &&
           is_ocaml_repr native_repr_res) then

diff --git a/typing/printtyp.ml b/typing/printtyp.ml
index 64f8d0cbc456e7b5a571a4c77574593cf6f63160..cadf6117f795e9bc0ebaf08b123f4a291a1cf310 100644 (file)
--- a/typing/printtyp.ml
+++ b/typing/printtyp.ml
@@ -48,12 +48,19 @@ let ident ppf id = pp_print_string ppf (ident_name id)
 
 (* Print a path *)
 
-let ident_pervasive = Ident.create_persistent "Pervasives"
+let ident_pervasives = Ident.create_persistent "Pervasives"
+let printing_env = ref Env.empty
+let non_shadowed_pervasive = function
+  | Pdot(Pident id, s, _pos) as path ->
+      Ident.same id ident_pervasives &&
+      (try Path.same path (Env.lookup_type (Lident s) !printing_env)
+       with Not_found -> true)
+  | _ -> false
 
 let rec tree_of_path = function
   | Pident id ->
       Oide_ident (ident_name id)
-  | Pdot(Pident id, s, _pos) when Ident.same id ident_pervasive ->
+  | Pdot(_, s, _pos) as path when non_shadowed_pervasive path ->
       Oide_ident s
   | Pdot(p, s, _pos) ->
       Oide_dot (tree_of_path p, s)
@@ -63,7 +70,7 @@ let rec tree_of_path = function
 let rec path ppf = function
   | Pident id ->
       ident ppf id
-  | Pdot(Pident id, s, _pos) when Ident.same id ident_pervasive ->
+  | Pdot(_, s, _pos) as path when non_shadowed_pervasive path ->
       pp_print_string ppf s
   | Pdot(p, s, _pos) ->
       path ppf p;
@@ -182,7 +189,7 @@ and raw_type_desc ppf = function
         raw_type_list tl
   | Tvariant row ->
       fprintf ppf
-        "@[<hov1>{@[%s@,%a;@]@ @[%s@,%a;@]@ %s%b;@ %s%b;@ @[<1>%s%t@]}@]"
+        "@[<hov1>{@[%s@,%a;@]@ @[%s@,%a;@]@ %s%B;@ %s%B;@ @[<1>%s%t@]}@]"
         "row_fields="
         (raw_list (fun ppf (l, f) ->
           fprintf ppf "@[%s,@ %a@]" l raw_field f))
@@ -203,7 +210,7 @@ and raw_field ppf = function
     Rpresent None -> fprintf ppf "Rpresent None"
   | Rpresent (Some t) -> fprintf ppf "@[<1>Rpresent(Some@,%a)@]" raw_type t
   | Reither (c,tl,m,e) ->
-      fprintf ppf "@[<hov1>Reither(%b,@,%a,@,%b,@,@[<1>ref%t@])@]" c
+      fprintf ppf "@[<hov1>Reither(%B,@,%a,@,%B,@,@[<1>ref%t@])@]" c
         raw_type_list tl m
         (fun ppf ->
           match !e with None -> fprintf ppf " None"
@@ -231,14 +238,16 @@ let compose l1 = function
   | Nth n  -> Nth (List.nth l1 n)
 
 let apply_subst s1 tyl =
-  match s1 with
-    Nth n1 -> [List.nth tyl n1]
-  | Map l1 -> List.map (List.nth tyl) l1
-  | Id -> tyl
+  if tyl = [] then []
+  (* cf. PR#7543: Typemod.type_package doesn't respect type constructor arity *)
+  else
+    match s1 with
+      Nth n1 -> [List.nth tyl n1]
+    | Map l1 -> List.map (List.nth tyl) l1
+    | Id -> 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
@@ -305,8 +314,9 @@ let same_printing_env env =
   Env.same_types !printing_old env && Concr.equal !printing_pers used_pers
 
 let set_printing_env env =
-  printing_env := if !Clflags.real_paths then Env.empty else env;
-  if !printing_env == Env.empty || same_printing_env env then () else
+  printing_env := env;
+  if !Clflags.real_paths
+  || !printing_env == Env.empty || same_printing_env env then () else
   begin
     (* printf "Reset printing_map@."; *)
     printing_old := env;
@@ -391,6 +401,10 @@ let names = ref ([] : (type_expr * string) list)
 let name_counter = ref 0
 let named_vars = ref ([] : string list)
 
+let weak_counter = ref 1
+let weak_var_map = ref TypeMap.empty
+let named_weak_vars = ref StringSet.empty
+
 let reset_names () = names := []; name_counter := 0; named_vars := []
 let add_named_var ty =
   match ty.desc with
@@ -399,6 +413,11 @@ let add_named_var ty =
       named_vars := name :: !named_vars
   | _ -> ()
 
+let name_is_already_used name =
+  List.mem name !named_vars
+  || List.exists (fun (_, name') -> name = name') !names
+  || StringSet.mem name !named_weak_vars
+
 let rec new_name () =
   let name =
     if !name_counter < 26
@@ -406,15 +425,23 @@ let rec new_name () =
     else String.make 1 (Char.chr(97 + !name_counter mod 26)) ^
            string_of_int(!name_counter / 26) in
   incr name_counter;
-  if List.mem name !named_vars
-  || List.exists (fun (_, name') -> name = name') !names
-  then new_name ()
-  else name
+  if name_is_already_used name then new_name () else name
+
+let rec new_weak_name ty () =
+  let name = "weak" ^ string_of_int !weak_counter in
+  incr weak_counter;
+  if name_is_already_used name then new_weak_name ty ()
+  else begin
+      named_weak_vars := StringSet.add name !named_weak_vars;
+      weak_var_map := TypeMap.add ty name !weak_var_map;
+      name
+    end
 
-let name_of_type t =
+let name_of_type name_generator t =
   (* We've already been through repr at this stage, so t is our representative
      of the union-find class. *)
   try List.assq t !names with Not_found ->
+    try TypeMap.find t !weak_var_map with Not_found ->
     let name =
       match t.desc with
         Tvar (Some name) | Tunivar (Some name) ->
@@ -430,13 +457,13 @@ let name_of_type t =
           !current_name
       | _ ->
           (* No name available, create a new one *)
-          new_name ()
+          name_generator ()
     in
     (* Exception for type declarations *)
     if name <> "_" then names := (t, name) :: !names;
     name
 
-let check_name_of_type t = ignore(name_of_type t)
+let check_name_of_type t = ignore(name_of_type new_name t)
 
 let remove_names tyl =
   let tyl = List.map repr tyl in
@@ -554,14 +581,17 @@ let rec tree_of_typexp sch ty =
   let px = proxy ty in
   if List.mem_assq px !names && not (List.memq px !delayed) then
    let mark = is_non_gen sch ty in
-   Otyp_var (mark, name_of_type px) else
+   let name = name_of_type (if mark then new_weak_name ty else new_name) px in
+   Otyp_var (mark, name) else
 
   let pr_typ () =
     match ty.desc with
     | Tvar _ ->
         (*let lev =
           if is_non_gen sch ty then "/" ^ string_of_int ty.level else "" in*)
-        Otyp_var (is_non_gen sch ty, name_of_type ty)
+        let non_gen = is_non_gen sch ty in
+        let name_gen = if non_gen then new_weak_name ty else new_name in
+        Otyp_var (non_gen, name_of_type name_gen ty)
     | Tarrow(l, ty1, ty2, _) ->
         let pr_arrow l ty1 ty2 =
           let lab =
@@ -582,7 +612,7 @@ let rec tree_of_typexp sch ty =
     | Tconstr(p, tyl, _abbrev) ->
         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
+        if is_nth s && not (tyl'=[]) 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
@@ -641,14 +671,14 @@ let rec tree_of_typexp sch ty =
           (* Make the names delayed, so that the real type is
              printed once when used as proxy *)
           List.iter add_delayed tyl;
-          let tl = List.map name_of_type tyl in
+          let tl = List.map (name_of_type new_name) tyl in
           let tr = Otyp_poly (tl, tree_of_typexp sch ty) in
           (* Forget names when we leave scope *)
           remove_names tyl;
           delayed := old_delayed; tr
         end
     | Tunivar _ ->
-        Otyp_var (false, name_of_type ty)
+        Otyp_var (false, name_of_type new_name ty)
     | Tpackage (p, n, tyl) ->
         let n =
           List.map (fun li -> String.concat "." (Longident.flatten li)) n in
@@ -657,7 +687,7 @@ let rec tree_of_typexp sch ty =
   if List.memq px !delayed then delayed := List.filter ((!=) px) !delayed;
   if is_aliased px && aliasable ty then begin
     check_name_of_type px;
-    Otyp_alias (pr_typ (), name_of_type px) end
+    Otyp_alias (pr_typ (), name_of_type new_name px) end
   else pr_typ ()
 
 and tree_of_row_field sch (l, f) =
@@ -865,7 +895,7 @@ let rec tree_of_type_decl id decl =
         decl.type_private
     | Type_open ->
         tree_of_manifest Otyp_open,
-        Public
+        decl.type_private
   in
   let immediate =
     Builtin_attributes.immediate decl.type_attributes
@@ -1036,7 +1066,7 @@ let rec tree_of_class_type sch params =
       let sty = repr sign.csig_self in
       let self_ty =
         if is_aliased sty then
-          Some (Otyp_var (false, name_of_type (proxy sty)))
+          Some (Otyp_var (false, name_of_type new_name (proxy sty)))
         else None
       in
       let (fields, _) =
@@ -1263,14 +1293,32 @@ let modtype_declaration id ppf decl =
   !Oprint.out_sig_item ppf (tree_of_modtype_declaration id decl)
 
 (* For the toplevel: merge with tree_of_signature? *)
-let rec print_items showval env = function
+
+(* Refresh weak variable map in the toplevel *)
+let refresh_weak () =
+  let refresh t name (m,s) =
+    if is_non_gen true (repr t) then
+      begin
+        TypeMap.add t name m,
+        StringSet.add name s
+      end
+    else m, s in
+  let m, s =
+    TypeMap.fold refresh !weak_var_map (TypeMap.empty ,StringSet.empty)  in
+  named_weak_vars := s;
+  weak_var_map := m
+
+let print_items showval env x =
+  refresh_weak();
+  let rec print showval env = function
   | [] -> []
   | item :: rem as items ->
       let (_sg, rem) = filter_rem_sig item rem in
       hide_rec_items items;
       let trees = trees_of_sigitem item in
       List.map (fun d -> (d, showval env item)) trees @
-      print_items showval env rem
+      print showval env rem in
+  print showval env x
 
 (* Print a signature body (used by -i when compiling a .ml) *)
 

diff --git a/typing/printtyped.ml b/typing/printtyped.ml
index 78e1b60a5b6ef672c874768cca9ea7bf57b3cb76..1d06ad9b922c2b43d2c53cb63abe7c01d7dd4e5d 100644 (file)
--- a/typing/printtyped.ml
+++ b/typing/printtyped.ml
@@ -147,6 +147,13 @@ let arg_label i ppf = function
   | Labelled s -> line i ppf "Labelled \"%s\"\n" s
 ;;
 
+let record_representation i ppf = let open Types in function
+  | Record_regular -> line i ppf "Record_regular\n"
+  | Record_float -> line i ppf "Record_float\n"
+  | Record_unboxed b -> line i ppf "Record_unboxed %b\n" b
+  | Record_inlined i -> line i ppf "Record_inlined %d\n" i
+  | Record_extension -> line i ppf "Record_extension\n"
+
 let attributes i ppf l =
   let i = i + 1 in
   List.iter
@@ -181,13 +188,15 @@ let rec core_type i ppf x =
   | Ttyp_object (l, c) ->
       line i ppf "Ttyp_object %a\n" fmt_closed_flag c;
       let i = i + 1 in
-      List.iter
-        (fun (s, attrs, t) ->
-          line i ppf "method %s\n" s;
-          attributes i ppf attrs;
-          core_type (i + 1) ppf t
-        )
-        l
+      List.iter (function
+        | OTtag (s, attrs, t) ->
+            line i ppf "method %s\n" s.txt;
+            attributes i ppf attrs;
+            core_type (i + 1) ppf t
+        | OTinherit ct ->
+            line i ppf "OTinherit\n";
+            core_type (i + 1) ppf ct
+        ) l
   | Ttyp_class (li, _, l) ->
       line i ppf "Ttyp_class %a\n" fmt_path li;
       list i core_type ppf l;
@@ -323,10 +332,15 @@ and expression i ppf x =
   | Texp_variant (l, eo) ->
       line i ppf "Texp_variant \"%s\"\n" l;
       option i expression ppf eo;
-  | Texp_record { fields; extended_expression; _ } ->
+  | Texp_record { fields; representation; extended_expression } ->
       line i ppf "Texp_record\n";
-      array i record_field ppf fields;
-      option i expression ppf extended_expression;
+      let i = i+1 in
+      line i ppf "fields =\n";
+      array (i+1) record_field ppf fields;
+      line i ppf "representation =\n";
+      record_representation (i+1) ppf representation;
+      line i ppf "extended_expression =\n";
+      option (i+1) expression ppf extended_expression;
   | Texp_field (e, li, _) ->
       line i ppf "Texp_field\n";
       expression i ppf e;
@@ -377,7 +391,7 @@ and expression i ppf x =
       module_expr i ppf me;
       expression i ppf e;
   | Texp_letexception (cd, e) ->
-      line i ppf "Pexp_letexception\n";
+      line i ppf "Texp_letexception\n";
       extension_constructor i ppf cd;
       expression i ppf e;
   | Texp_assert (e) ->
@@ -479,6 +493,9 @@ and class_type i ppf x =
       arg_label i ppf l;
       core_type i ppf co;
       class_type i ppf cl;
+  | Tcty_open (ovf, m, _, _, e) ->
+      line i ppf "Tcty_open %a \"%a\"\n" fmt_override_flag ovf fmt_path m;
+      class_type i ppf e
 
 and class_signature i ppf { csig_self = ct; csig_fields = l } =
   line i ppf "class_signature\n";
@@ -560,6 +577,9 @@ and class_expr i ppf x =
       class_expr i ppf ce;
       class_type i ppf ct
   | Tcl_constraint (ce, None, _, _, _) -> class_expr i ppf ce
+  | Tcl_open (ovf, m, _, _, e) ->
+      line i ppf "Tcty_open %a \"%a\"\n" fmt_override_flag ovf fmt_path m;
+      class_expr i ppf e
 
 and class_structure i ppf { cstr_self = p; cstr_fields = l } =
   line i ppf "class_structure\n";
@@ -856,11 +876,11 @@ and ident_x_loc_x_expression_def i ppf (l,_, e) =
 and label_x_bool_x_core_type_list i ppf x =
   match x with
     Ttag (l, attrs, b, ctl) ->
-      line i ppf "Rtag \"%s\" %s\n" l (string_of_bool b);
+      line i ppf "Ttag \"%s\" %s\n" l.txt (string_of_bool b);
       attributes (i+1) ppf attrs;
       list (i+1) core_type ppf ctl
   | Tinherit (ct) ->
-      line i ppf "Rinherit\n";
+      line i ppf "Tinherit\n";
       core_type (i+1) ppf ct
 ;;
 

diff --git a/typing/stypes.ml b/typing/stypes.ml
index 140b79e2fef8132750c2c4658fca08725e3469f1..8435669ec64031556ab35fa0f0f6b6c9368e0492 100644 (file)
--- a/typing/stypes.ml
+++ b/typing/stypes.ml
@@ -194,16 +194,14 @@ let get_info () =
 
 let dump filename =
   if !Clflags.annotations then begin
-    let info = get_info () in
-    let pp =
-      match filename with
-          None -> stdout
-        | Some filename -> open_out filename in
-    sort_filter_phrases ();
-    ignore (List.fold_left (print_info pp) Location.none info);
+    let do_dump _temp_filename pp =
+      let info = get_info () in
+      sort_filter_phrases ();
+      ignore (List.fold_left (print_info pp) Location.none info) in
     begin match filename with
-    | None -> ()
-    | Some _ -> close_out pp
+    | None -> do_dump "" stdout
+    | Some filename ->
+        Misc.output_to_file_via_temporary ~mode:[Open_text] filename do_dump
     end;
     phrases := [];
   end else begin

diff --git a/typing/subst.ml b/typing/subst.ml
index e6fc9e3de0d1c92a343bc6db45ddd1e23d05e694..fb5f9019456085f6fd1d8fa41f5664aaa18c39c6 100644 (file)
--- a/typing/subst.ml
+++ b/typing/subst.ml
@@ -20,19 +20,34 @@ open Path
 open Types
 open Btype
 
+type type_replacement =
+  | Path of Path.t
+  | Type_function of { params : type_expr list; body : type_expr }
+
+module PathMap = Map.Make(Path)
+
 type t =
-  { types: (Ident.t, Path.t) Tbl.t;
-    modules: (Ident.t, Path.t) Tbl.t;
+  { types: type_replacement PathMap.t;
+    modules: Path.t PathMap.t;
     modtypes: (Ident.t, module_type) Tbl.t;
-    for_saving: bool }
+    for_saving: bool;
+  }
 
 let identity =
-  { types = Tbl.empty; modules = Tbl.empty; modtypes = Tbl.empty;
-    for_saving = false }
+  { types = PathMap.empty;
+    modules = PathMap.empty;
+    modtypes = Tbl.empty;
+    for_saving = false;
+  }
+
+let add_type_path id p s = { s with types = PathMap.add id (Path p) s.types }
+let add_type id p s = add_type_path (Pident id) p s
 
-let add_type id p s = { s with types = Tbl.add id p s.types }
+let add_type_function id ~params ~body s =
+  { s with types = PathMap.add id (Type_function { params; body }) s.types }
 
-let add_module id p s = { s with modules = Tbl.add id p s.modules }
+let add_module_path id p s = { s with modules = PathMap.add id p s.modules }
+let add_module id p s = add_module_path (Pident id) p s
 
 let add_modtype id ty s = { s with modtypes = Tbl.add id ty s.modtypes }
 
@@ -62,13 +77,15 @@ let attrs s x =
     then remove_loc.Ast_mapper.attributes remove_loc x
     else x
 
-let rec module_path s = function
-    Pident id as p ->
-      begin try Tbl.find id s.modules with Not_found -> p end
-  | Pdot(p, n, pos) ->
-      Pdot(module_path s p, n, pos)
-  | Papply(p1, p2) ->
-      Papply(module_path s p1, module_path s p2)
+let rec module_path s path =
+  try PathMap.find path s.modules
+  with Not_found ->
+    match path with
+    | Pident _ -> path
+    | Pdot(p, n, pos) ->
+       Pdot(module_path s p, n, pos)
+    | Papply(p1, p2) ->
+       Papply(module_path s p1, module_path s p2)
 
 let modtype_path s = function
     Pident id as p ->
@@ -82,13 +99,17 @@ let modtype_path s = function
   | Papply _ ->
       fatal_error "Subst.modtype_path"
 
-let type_path s = function
-    Pident id as p ->
-      begin try Tbl.find id s.types with Not_found -> p end
-  | Pdot(p, n, pos) ->
-      Pdot(module_path s p, n, pos)
-  | Papply _ ->
-      fatal_error "Subst.type_path"
+let type_path s path =
+  match PathMap.find path s.types with
+  | Path p -> p
+  | Type_function _ -> assert false
+  | exception Not_found ->
+     match path with
+     | Pident _ -> path
+     | Pdot(p, n, pos) ->
+        Pdot(module_path s p, n, pos)
+     | Papply _ ->
+        fatal_error "Subst.type_path"
 
 let type_path s p =
   match Path.constructor_typath p with
@@ -97,6 +118,12 @@ let type_path s p =
   | LocalExt _ -> type_path s p
   | Ext (p, cstr) -> Pdot(module_path s p, cstr, nopos)
 
+let to_subst_by_type_function s p =
+  match PathMap.find p s.types with
+  | Path _ -> false
+  | Type_function _ -> true
+  | exception Not_found -> false
+
 (* Special type ids for saved signatures *)
 
 let new_id = ref (-1)
@@ -114,6 +141,8 @@ let norm = function
   | Tunivar None -> tunivar_none
   | d -> d
 
+let ctype_apply_env_empty = ref (fun _ -> assert false)
+
 (* Similar to [Ctype.nondep_type_rec]. *)
 let rec typexp s ty =
   let ty = repr ty in
@@ -132,7 +161,7 @@ let rec typexp s ty =
       && field_kind_repr k <> Fabsent && (repr ty).level < generic_level ->
       (* do not copy the type of self when it is not generalized *)
       ty
-(* cannot do it, since it would omit subsitution
+(* cannot do it, since it would omit substitution
   | Tvariant row when not (static_row row) ->
       ty
 *)
@@ -153,8 +182,14 @@ let rec typexp s ty =
             Tconstr(type_path s (Pdot(m,i',pos)), tl, ref Mnil)
         | _ -> assert false
       else match desc with
-      | Tconstr(p, tl, _abbrev) ->
-          Tconstr(type_path s p, List.map (typexp s) tl, ref Mnil)
+      | Tconstr (p, args, _abbrev) ->
+         let args = List.map (typexp s) args in
+         begin match PathMap.find p s.types with
+         | exception Not_found -> Tconstr(type_path s p, args, ref Mnil)
+         | Path _ -> Tconstr(type_path s p, args, ref Mnil)
+         | Type_function { params; body } ->
+            (!ctype_apply_env_empty params body args).desc
+         end
       | Tpackage(p, n, tl) ->
           Tpackage(modtype_path s p, n, List.map (typexp s) tl)
       | Tobject (t1, name) ->
@@ -162,7 +197,9 @@ let rec typexp s ty =
                  ref (match !name with
                         None -> None
                       | Some (p, tl) ->
-                          Some (type_path s p, List.map (typexp s) tl)))
+                         if to_subst_by_type_function s p
+                         then None
+                         else Some (type_path s p, List.map (typexp s) tl)))
       | Tvariant row ->
           let row = row_repr row in
           let more = repr row.row_more in
@@ -194,8 +231,11 @@ let rec typexp s ty =
               let row =
                 copy_row (typexp s) true row (not dup) more' in
               match row.row_name with
-                Some (p, tl) ->
-                  Tvariant {row with row_name = Some (type_path s p, tl)}
+              | Some (p, tl) ->
+                 Tvariant {row with row_name =
+                                      if to_subst_by_type_function s p
+                                      then None
+                                      else Some (type_path s p, tl)}
               | None ->
                   Tvariant row
           end
@@ -430,11 +470,22 @@ and modtype_declaration s decl  =
 let merge_tbls f m1 m2 =
   Tbl.fold (fun k d accu -> Tbl.add k (f d) accu) m1 m2
 
+let merge_path_maps f m1 m2 =
+  PathMap.fold (fun k d accu -> PathMap.add k (f d) accu) m1 m2
+
+let type_replacement s = function
+  | Path p -> Path (type_path s p)
+  | Type_function { params; body } ->
+     let params = List.map (typexp s) params in
+     let body = typexp s body in
+     Type_function { params; body }
+
 (* Composition of substitutions:
      apply (compose s1 s2) x = apply s2 (apply s1 x) *)
 
 let compose s1 s2 =
-  { types = merge_tbls (type_path s2) s1.types s2.types;
-    modules = merge_tbls (module_path s2) s1.modules s2.modules;
+  { types = merge_path_maps (type_replacement s2) s1.types s2.types;
+    modules = merge_path_maps (module_path s2) s1.modules s2.modules;
     modtypes = merge_tbls (modtype s2) s1.modtypes s2.modtypes;
-    for_saving = s1.for_saving || s2.for_saving }
+    for_saving = s1.for_saving || s2.for_saving;
+  }

diff --git a/typing/subst.mli b/typing/subst.mli
index 55eee757d79b2b9740e6cae52e1e60ff9bb72fa0..f81cb4da5661e02d5ce399e3a2c16fa32bc2c8bb 100644 (file)
--- a/typing/subst.mli
+++ b/typing/subst.mli
@@ -21,9 +21,9 @@ type t
 
 (*
    Substitutions are used to translate a type from one context to
-   another.  This requires substituing paths for identifiers, and
+   another.  This requires substituting paths for identifiers, and
    possibly also lowering the level of non-generic variables so that
-   it be inferior to the maximum level of the new context.
+   they are inferior to the maximum level of the new context.
 
    Substitutions can also be used to create a "clean" copy of a type.
    Indeed, non-variable node of a type are duplicated, with their
@@ -34,7 +34,11 @@ type t
 val identity: t
 
 val add_type: Ident.t -> Path.t -> t -> t
+val add_type_path: Path.t -> Path.t -> t -> t
+val add_type_function:
+  Path.t -> params:type_expr list -> body:type_expr -> t -> t
 val add_module: Ident.t -> Path.t -> t -> t
+val add_module_path: Path.t -> Path.t -> t -> t
 val add_modtype: Ident.t -> module_type -> t -> t
 val for_saving: t -> t
 val reset_for_saving: unit -> unit
@@ -60,3 +64,7 @@ val class_signature: t -> class_signature -> class_signature
 (* Composition of substitutions:
      apply (compose s1 s2) x = apply s2 (apply s1 x) *)
 val compose: t -> t -> t
+
+(* A forward reference to be filled in ctype.ml. *)
+val ctype_apply_env_empty:
+  (type_expr list -> type_expr -> type_expr list -> type_expr) ref

diff --git a/typing/tast_mapper.ml b/typing/tast_mapper.ml
index 0873dd4c9ee4871939fa80f0e50f8ada3717a14d..36e33e3f2fbd7f45cd166bc80feb3e3f41200493 100644 (file)
--- a/typing/tast_mapper.ml
+++ b/typing/tast_mapper.ml
@@ -47,6 +47,7 @@ type mapper =
     package_type: mapper -> package_type -> package_type;
     pat: mapper -> pattern -> pattern;
     row_field: mapper -> row_field -> row_field;
+    object_field: mapper -> object_field -> object_field;
     signature: mapper -> signature -> signature;
     signature_item: mapper -> signature_item -> signature_item;
     structure: mapper -> structure -> structure;
@@ -521,6 +522,8 @@ let class_expr sub x =
         )
     | Tcl_ident (path, lid, tyl) ->
         Tcl_ident (path, lid, List.map (sub.typ sub) tyl)
+    | Tcl_open (ovf, p, lid, env, e) ->
+        Tcl_open (ovf, p, lid, sub.env sub env, sub.class_expr sub e)
   in
   {x with cl_desc; cl_env}
 
@@ -541,6 +544,8 @@ let class_type sub x =
            sub.typ sub ct,
            sub.class_type sub cl
           )
+    | Tcty_open (ovf, p, lid, env, e) ->
+        Tcty_open (ovf, p, lid, sub.env sub env, sub.class_type sub e)
   in
   {x with cltyp_desc; cltyp_env}
 
@@ -576,10 +581,7 @@ let typ sub x =
     | 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_object ((List.map (sub.object_field sub) list), closed)
     | Ttyp_class (path, lid, list) ->
         Ttyp_class
           (path,
@@ -607,6 +609,11 @@ let row_field sub = function
       Ttag (label, attrs, b, List.map (sub.typ sub) list)
   | Tinherit ct -> Tinherit (sub.typ sub ct)
 
+let object_field sub = function
+  | OTtag (label, attrs, ct) ->
+      OTtag (label, attrs, (sub.typ sub ct))
+  | OTinherit ct -> OTinherit (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)
@@ -676,6 +683,7 @@ let default =
     package_type;
     pat;
     row_field;
+    object_field;
     signature;
     signature_item;
     structure;

diff --git a/typing/tast_mapper.mli b/typing/tast_mapper.mli
index ae9dd8ba3e87f0f62ccc37ef6e81a38a32247f04..2251fa570941104a940ee45acd052cfe89dc5e1f 100644 (file)
--- a/typing/tast_mapper.mli
+++ b/typing/tast_mapper.mli
@@ -16,7 +16,7 @@
 open Asttypes
 open Typedtree
 
-(** {2 A generic Typedtree mapper} *)
+(** {1 A generic Typedtree mapper} *)
 
 type mapper =
   {
@@ -46,6 +46,7 @@ type mapper =
     package_type: mapper -> package_type -> package_type;
     pat: mapper -> pattern -> pattern;
     row_field: mapper -> row_field -> row_field;
+    object_field: mapper -> object_field -> object_field;
     signature: mapper -> signature -> signature;
     signature_item: mapper -> signature_item -> signature_item;
     structure: mapper -> structure -> structure;

diff --git a/typing/typeclass.ml b/typing/typeclass.ml
index 51f8a256dc773d7a5586359698edc45153005dde..371d2ad7d20077b8d166b0865f729b12b6824062 100644 (file)
--- a/typing/typeclass.ml
+++ b/typing/typeclass.ml
@@ -356,13 +356,13 @@ let declare_method val_env meths self_type lab priv sty loc =
 so that we can get an immediate value. Is that correct ? Ask Jacques. *)
       let returned_cty = ctyp Ttyp_any (Ctype.newty Tnil) val_env loc in
       delayed_meth_specs :=
-      lazy (
-        let cty = transl_simple_type_univars val_env sty' in
-        let ty = cty.ctyp_type in
-        unif ty;
-        returned_cty.ctyp_desc <- Ttyp_poly ([], cty);
-        returned_cty.ctyp_type <- ty;
-        ) ::
+      Warnings.mk_lazy (fun () ->
+            let cty = transl_simple_type_univars val_env sty' in
+            let ty = cty.ctyp_type in
+            unif ty;
+            returned_cty.ctyp_desc <- Ttyp_poly ([], cty);
+            returned_cty.ctyp_type <- ty;
+          ) ::
       !delayed_meth_specs;
       returned_cty
   | _ ->
@@ -400,8 +400,13 @@ let add_val lab (mut, virt, ty) val_sig =
   in
   Vars.add lab (mut, virt, ty) val_sig
 
-let rec class_type_field env self_type meths
+let rec class_type_field env self_type meths arg ctf =
+  Builtin_attributes.warning_scope ctf.pctf_attributes
+    (fun () -> class_type_field_aux env self_type meths arg ctf)
+
+and class_type_field_aux env self_type meths
     (fields, val_sig, concr_meths, inher) ctf =
+
   let loc = ctf.pctf_loc in
   let mkctf desc =
     { ctf_desc = desc; ctf_loc = loc; ctf_attributes = ctf.pctf_attributes }
@@ -446,7 +451,7 @@ let rec class_type_field env self_type meths
         val_sig, concr_meths, inher)
 
   | Pctf_attribute x ->
-      Builtin_attributes.warning_attribute [x];
+      Builtin_attributes.warning_attribute x;
       (mkctf (Tctf_attribute x) :: fields,
         val_sig, concr_meths, inher)
 
@@ -472,13 +477,14 @@ and class_signature env {pcsig_self=sty; pcsig_fields=sign} =
   end;
 
   (* Class type fields *)
-  Builtin_attributes.warning_enter_scope ();
   let (rev_fields, val_sig, concr_meths, inher) =
-    List.fold_left (class_type_field env self_type meths)
-      ([], Vars.empty, Concr.empty, [])
-      sign
+    Builtin_attributes.warning_scope []
+      (fun () ->
+         List.fold_left (class_type_field env self_type meths)
+           ([], Vars.empty, Concr.empty, [])
+           sign
+      )
   in
-  Builtin_attributes.warning_leave_scope ();
   let cty =   {csig_self = self_type;
    csig_vars = val_sig;
    csig_concr = concr_meths;
@@ -490,6 +496,10 @@ and class_signature env {pcsig_self=sty; pcsig_fields=sign} =
   }
 
 and class_type env scty =
+  Builtin_attributes.warning_scope scty.pcty_attributes
+    (fun () -> class_type_aux env scty)
+
+and class_type_aux env scty =
   let cltyp desc typ =
     {
      cltyp_desc = desc;
@@ -540,6 +550,12 @@ and class_type env scty =
       let clty = class_type env scty in
       let typ = Cty_arrow (l, ty, clty.cltyp_type) in
       cltyp (Tcty_arrow (l, cty, clty)) typ
+
+  | Pcty_open (ovf, lid, e) ->
+      let (path, newenv) = !Typecore.type_open ovf env scty.pcty_loc lid in
+      let clty = class_type newenv e in
+      cltyp (Tcty_open (ovf, path, lid, newenv, clty)) clty.cltyp_type
+
   | Pcty_extension ext ->
       raise (Error_forward (Builtin_attributes.error_of_extension ext))
 
@@ -552,10 +568,13 @@ let class_type env scty =
 
 (*******************************)
 
-let rec class_field self_loc cl_num self_type meths vars
+let rec class_field self_loc cl_num self_type meths vars arg cf =
+  Builtin_attributes.warning_scope cf.pcf_attributes
+    (fun () -> class_field_aux self_loc cl_num self_type meths vars arg cf)
+
+and class_field_aux self_loc cl_num self_type meths vars
     (val_env, met_env, par_env, fields, concr_meths, warn_vals, inher,
-     local_meths, local_vals)
-  cf =
+     local_meths, local_vals) cf =
   let loc = cf.pcf_loc in
   let mkcf desc =
     { cf_desc = desc; cf_loc = loc; cf_attributes = cf.pcf_attributes }
@@ -712,17 +731,19 @@ let rec class_field self_loc cl_num self_type meths vars
       let vars_local = !vars in
 
       let field =
-        lazy begin
-          (* Read the generalized type *)
-          let (_, ty) = Meths.find lab.txt !meths in
-          let meth_type =
-            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
-          Ctype.end_def ();
-          mkcf (Tcf_method (lab, priv, Tcfk_concrete (ovf, texp)))
-        end in
+        Warnings.mk_lazy
+          (fun () ->
+             (* Read the generalized type *)
+             let (_, ty) = Meths.find lab.txt !meths in
+             let meth_type =
+               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
+             Ctype.end_def ();
+             mkcf (Tcf_method (lab, priv, Tcfk_concrete (ovf, texp)))
+          )
+      in
       (val_env, met_env, par_env, field::fields,
        Concr.add lab.txt concr_meths, warn_vals, inher,
        Concr.add lab.txt local_meths, local_vals)
@@ -751,7 +772,7 @@ let rec class_field self_loc cl_num self_type meths vars
       (val_env, met_env, par_env, field::fields, concr_meths, warn_vals,
        inher, local_meths, local_vals)
   | Pcf_attribute x ->
-      Builtin_attributes.warning_attribute [x];
+      Builtin_attributes.warning_attribute x;
       (val_env, met_env, par_env,
         lazy (mkcf (Tcf_attribute x)) :: fields,
         concr_meths, warn_vals, inher, local_meths, local_vals)
@@ -805,14 +826,15 @@ and class_structure cl_num final val_env met_env loc
   end;
 
   (* Typing of class fields *)
-  Builtin_attributes.warning_enter_scope ();
   let (_, _, _, fields, concr_meths, _, inher, _local_meths, _local_vals) =
-    List.fold_left (class_field self_loc cl_num self_type meths vars)
-      (val_env, meth_env, par_env, [], Concr.empty, Concr.empty, [],
-       Concr.empty, Concr.empty)
-      str
+    Builtin_attributes.warning_scope []
+      (fun () ->
+         List.fold_left (class_field self_loc cl_num self_type meths vars)
+           (val_env, meth_env, par_env, [], Concr.empty, Concr.empty, [],
+            Concr.empty, Concr.empty)
+           str
+      )
   in
-  Builtin_attributes.warning_leave_scope ();
   Ctype.unify val_env self_type (Ctype.newvar ());
   let sign =
     {csig_self = public_self;
@@ -884,6 +906,10 @@ and class_structure cl_num final val_env met_env loc
     cstr_meths = meths}, sign (* redondant, since already in cstr_type *)
 
 and class_expr cl_num val_env met_env scl =
+  Builtin_attributes.warning_scope scl.pcl_attributes
+    (fun () -> class_expr_aux cl_num val_env met_env scl)
+
+and class_expr_aux cl_num val_env met_env scl =
   match scl.pcl_desc with
     Pcl_constr (lid, styl) ->
       let (path, decl) = Typetexp.find_class val_env scl.pcl_loc lid.txt in
@@ -1157,6 +1183,9 @@ and class_expr cl_num val_env met_env scl =
           ([], met_env)
       in
       let cl = class_expr cl_num val_env met_env scl' in
+      let () = if rec_flag = Recursive then
+        check_recursive_bindings val_env defs
+      in
       rc {cl_desc = Tcl_let (rec_flag, defs, vals, cl);
           cl_loc = scl.pcl_loc;
           cl_type = cl.cl_type;
@@ -1191,6 +1220,17 @@ and class_expr cl_num val_env met_env scl =
           cl_env = val_env;
           cl_attributes = scl.pcl_attributes;
          }
+  | Pcl_open (ovf, lid, e) ->
+      let used_slot = ref false in
+      let (path, new_val_env) = !Typecore.type_open ~used_slot ovf val_env scl.pcl_loc lid in
+      let (_path, new_met_env) = !Typecore.type_open ~used_slot ovf met_env scl.pcl_loc lid in
+      let cl = class_expr cl_num new_val_env new_met_env e in
+      rc {cl_desc = Tcl_open (ovf, path, lid, new_val_env, cl);
+          cl_loc = scl.pcl_loc;
+          cl_type = cl.cl_type;
+          cl_env = val_env;
+          cl_attributes = scl.pcl_attributes;
+         }
   | Pcl_extension ext ->
       raise (Error_forward (Builtin_attributes.error_of_extension ext))
 
@@ -1569,6 +1609,22 @@ let final_decl env define_class
  })
 (*   (cl.pci_variance, cl.pci_loc)) *)
 
+let class_infos define_class kind
+    (cl, id, ty_id,
+     obj_id, obj_params, obj_ty,
+     cl_id, cl_params, cl_ty,
+     constr_type, dummy_class)
+    (res, env) =
+  Builtin_attributes.warning_scope cl.pci_attributes
+    (fun () ->
+       class_infos define_class kind
+         (cl, id, ty_id,
+          obj_id, obj_params, obj_ty,
+          cl_id, cl_params, cl_ty,
+          constr_type, dummy_class)
+         (res, env)
+    )
+
 let extract_type_decls
     (_id, _id_loc, clty, _ty_id, cltydef, obj_id, obj_abbr, _cl_id, cl_abbr,
      _arity, _pub_meths, _coe, _expr, required) decls =
@@ -1670,7 +1726,17 @@ let class_description env sexpr =
   (expr, expr.cltyp_type)
 
 let class_declarations env cls =
-  type_classes true approx_declaration class_declaration env cls
+  let info, env =
+    type_classes true approx_declaration class_declaration env cls
+  in
+  let ids, exprs =
+    List.split
+      (List.map
+         (fun ci -> ci.cls_id, ci.cls_info.ci_expr)
+         info)
+  in
+  check_recursive_class_bindings env ids exprs;
+  info, env
 
 let class_descriptions env cls =
   type_classes true approx_description class_description env cls
@@ -1704,6 +1770,7 @@ let rec unify_parents env ty cl =
       | _exn -> assert false
       end
   | Tcl_structure st -> unify_parents_struct env ty st
+  | Tcl_open (_, _, _, _, cl)
   | Tcl_fun (_, _, _, cl, _)
   | Tcl_apply (cl, _)
   | Tcl_let (_, _, _, cl)

diff --git a/typing/typecore.ml b/typing/typecore.ml
index f80b81beaac960d204f68ba2f8717101c828091a..b4cfb8b0cd5c9a0d585e672d392c6e3b0b22753a 100644 (file)
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -77,6 +77,9 @@ type error =
   | Not_an_extension_constructor
   | Literal_overflow of string
   | Unknown_literal of string * char
+  | Illegal_letrec_pat
+  | Illegal_letrec_expr
+  | Illegal_class_expr
 
 exception Error of Location.t * Env.t * error
 exception Error_forward of Location.error
@@ -89,8 +92,11 @@ let type_module =
 
 (* Forward declaration, to be filled in by Typemod.type_open *)
 
-let type_open =
-  ref (fun _ -> assert false)
+let type_open :
+  (?used_slot:bool ref -> override_flag -> Env.t -> Location.t ->
+   Longident.t loc -> Path.t * Env.t)
+    ref =
+  ref (fun ?used_slot:_ _ -> assert false)
 
 (* Forward declaration, to be filled in by Typemod.type_package *)
 
@@ -220,6 +226,7 @@ let iter_expression f e =
         class_expr ce; List.iter (fun (_, e) -> expr e) lel
     | Pcl_let (_, pel, ce) ->
         List.iter binding pel; class_expr ce
+    | Pcl_open (_, _, ce)
     | Pcl_constraint (ce, _) -> class_expr ce
     | Pcl_extension _ -> ()
 
@@ -978,6 +985,14 @@ exception Need_backtrack
    explode > 0 => explode Ppat_any for gadts *)
 let rec type_pat ~constrs ~labels ~no_existentials ~mode ~explode ~env
     sp expected_ty k =
+  Builtin_attributes.warning_scope sp.ppat_attributes
+    (fun () ->
+       type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env
+         sp expected_ty k
+    )
+
+and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env
+    sp expected_ty k =
   let mode' = if mode = Splitting_or then Normal else mode in
   let type_pat ?(constrs=constrs) ?(labels=labels) ?(mode=mode')
       ?(explode=explode) ?(env=env) =
@@ -1457,7 +1472,13 @@ let type_pattern ~lev env spat scope expected_ty =
 let type_pattern_list env spatl scope expected_tys allow =
   reset_pattern scope allow;
   let new_env = ref env in
-  let patl = List.map2 (type_pat new_env) spatl expected_tys in
+  let type_pat (attrs, pat) ty =
+    Builtin_attributes.warning_scope ~ppwarning:false attrs
+      (fun () ->
+         type_pat new_env pat ty
+      )
+  in
+  let patl = List.map2 type_pat spatl expected_tys in
   let new_env, unpacks = add_pattern_variables !new_env in
   (patl, new_env, get_ref pattern_force, unpacks)
 
@@ -1616,6 +1637,16 @@ let rec is_nonexpansive exp =
       is_nonexpansive_mod mexp && is_nonexpansive e
   | Texp_pack mexp ->
       is_nonexpansive_mod mexp
+  (* Computations which raise exceptions are nonexpansive, since (raise e) is equivalent
+     to (raise e; diverge), and a nonexpansive "diverge" can be produced using lazy values
+     or the relaxed value restriction. See GPR#1142 *)
+  | Texp_assert exp ->
+      is_nonexpansive exp
+  | Texp_apply (
+      { exp_desc = Texp_ident (_, _, {val_kind =
+             Val_prim {Primitive.prim_name = "%raise"}}) },
+      [Nolabel, Some e]) ->
+     is_nonexpansive e
   | _ -> false
 
 and is_nonexpansive_mod mexp =
@@ -1654,6 +1685,644 @@ and is_nonexpansive_opt = function
     None -> true
   | Some e -> is_nonexpansive e
 
+module Env' = Env
+module Rec_context =
+struct
+  type access =
+      Dereferenced
+    (** [Dereferenced] indicates that the value (not just the address) of a
+        variable is accessed *)
+
+    | Guarded
+    (** [Guarded] indicates that the address of a variable is used in a
+        guarded context, i.e. under a constructor.  A variable that is
+        dereferenced within a function body or lazy context is also considered
+        guarded. *)
+
+    | Unguarded
+    (** [Unguarded] indicates that the address of a variable is used in an
+        unguarded context, i.e. not under a constructor. *)
+
+  (** [guard] represents guarded contexts such as [C -] and [{l = -}] *)
+  let guard : access -> access = function
+    | Dereferenced -> Dereferenced
+    | Guarded -> Guarded
+    | Unguarded -> Guarded
+
+  (** [inspect] represents elimination contexts such as [match - with cases],
+      [e -] and [- e] *)
+  let inspect : access -> access = function
+    | Dereferenced -> Dereferenced
+    | Guarded -> Dereferenced
+    | Unguarded -> Dereferenced
+
+  (** [delay] represents contexts that delay evaluation such as [fun p -> -]
+      or [lazy -] *)
+  let delay : access -> access = function
+    | Dereferenced -> Guarded
+    | Guarded -> Guarded
+    | Unguarded -> Guarded
+
+  module Use :
+  sig
+    type t
+    val guard : t -> t
+    (** An expression appears in a guarded context *)
+
+    val discard : t -> t
+    (** The address of a subexpression is not used, but may be bound *)
+
+    val inspect : t -> t
+    (** The value of a subexpression is inspected with match, application, etc. *)
+
+    val delay : t -> t
+    (** An expression appears under 'fun p ->' or 'lazy' *)
+
+    val join : t -> t -> t
+    (** Combine the access information of two expressions *)
+
+    val single : Ident.t -> access -> t
+    (** Combine the access information of two expressions *)
+
+    val empty : t
+    (** No variables are accessed in an expression; it might be a
+        constant or a global identifier *)
+      
+    val unguarded : t -> Ident.t list
+    (** The list of identifiers that are used in an unguarded context *)
+
+    val dependent : t -> Ident.t list
+    (** The list of all used identifiers *)
+  end =
+  struct
+    module M = Map.Make(Ident)
+
+    (** A "t" maps each rec-bound variable to an access status *)
+    type t = access M.t
+
+    let map f tbl = M.map f tbl
+    let guard t = map guard t
+    let inspect t = map inspect t
+    let delay t = map delay t
+    let discard = guard
+
+    let prec x y =
+      match x, y with
+      | Dereferenced, _
+      | _, Dereferenced -> Dereferenced
+      | Unguarded, _
+      | _, Unguarded -> Unguarded
+      | _ -> Guarded
+
+    let join x y =
+      M.fold
+        (fun id v tbl ->
+           let v' = try M.find id tbl with Not_found -> Guarded in
+           M.add id (prec v v') tbl)
+        x y
+
+    let single id access = M.add id access M.empty
+  
+    let empty = M.empty
+
+    let list_matching p t =
+      let r = ref [] in
+      M.iter (fun id v -> if p v then r := id :: !r) t;
+      !r
+    
+    let unguarded =
+      list_matching (function Unguarded | Dereferenced -> true | _ -> false)
+
+    let dependent =
+      list_matching (function _ -> true)
+  end
+
+  module Env =
+  struct
+    (* A typing environment maps identifiers to types *)
+    type env = Use.t Ident.tbl
+
+    let empty = Ident.empty
+
+    let join x y =
+      let r = 
+      Ident.fold_all
+        (fun id v tbl ->
+           let v' = try Ident.find_same id tbl with Not_found -> Use.empty in
+           Ident.add id (Use.join v v') tbl)
+        x
+        y
+      in
+      r
+  end
+end
+
+let rec pattern_variables : Typedtree.pattern -> Ident.t list =
+  fun pat -> match pat.pat_desc with
+    | Tpat_any -> []
+    | Tpat_var (id, _) -> [id]
+    | Tpat_alias (pat, id, _) -> id :: pattern_variables pat
+    | Tpat_constant _ -> []
+    | Tpat_tuple pats -> List.concat (List.map pattern_variables pats)
+    | Tpat_construct (_, _, pats) ->
+        List.concat (List.map pattern_variables pats)
+    | Tpat_variant (_, Some pat, _) -> pattern_variables pat
+    | Tpat_variant (_, None, _) -> []
+    | Tpat_record (fields, _) ->
+        List.concat (List.map (fun (_,_,p) -> pattern_variables p) fields)
+    | Tpat_array pats ->
+        List.concat (List.map pattern_variables pats)
+    | Tpat_or (l,r,_) ->
+        pattern_variables l @ pattern_variables r
+    | Tpat_lazy p ->
+        pattern_variables p
+
+module Rec_check =
+struct
+  open Rec_context
+
+  let build_unguarded_env : Ident.t list -> Env.env = fun idlist ->
+    List.fold_left
+      (fun env id -> Ident.add id (Use.single id Unguarded) env)
+      Env.empty
+      idlist
+
+  let is_ref : Types.value_description -> bool = function
+    | { Types.val_kind =
+          Types.Val_prim { Primitive.prim_name = "%makemutable";
+                           prim_arity = 1 } } ->
+          true
+    | _ -> false
+
+  let scrape env ty =
+    (Ctype.repr (Ctype.expand_head_opt env (Ctype.correct_levels ty))).desc
+
+  let array_element_kind env ty =
+    match scrape env ty with
+    | Tvar _ | Tunivar _ ->
+        `Pgenarray
+    | Tconstr(p, _, _) ->
+        if Path.same p Predef.path_int || Path.same p Predef.path_char then
+          `Pintarray
+        else if Path.same p Predef.path_float then
+          `Pfloatarray
+        else if Path.same p Predef.path_string
+             || Path.same p Predef.path_array
+             || Path.same p Predef.path_nativeint
+             || Path.same p Predef.path_int32
+             || Path.same p Predef.path_int64 then
+          `Paddrarray
+        else begin
+          try
+            match Env'.find_type p env with
+              {type_kind = Type_abstract} ->
+                `Pgenarray
+            | {type_kind = Type_variant cstrs}
+              when List.for_all (fun c -> c.Types.cd_args = Types.Cstr_tuple [])
+                  cstrs ->
+                `Pintarray
+            | {type_kind = _} ->
+                `Paddrarray
+          with Not_found ->
+            (* This can happen due to e.g. missing -I options,
+               causing some .cmi files to be unavailable.
+               Maybe we should emit a warning. *)
+            `Pgenarray
+        end
+    | _ ->
+        `Paddrarray
+
+  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 ->
+        array_element_kind env elt_ty
+    | _ ->
+        (* This can happen with e.g. Obj.field *)
+        `Pgenarray
+
+  let array_kind exp = array_type_kind exp.exp_env exp.exp_type
+
+  let has_concrete_element_type : Typedtree.expression -> bool =
+    fun e -> array_kind e <> `Pgenarray
+
+  type sd = Static | Dynamic
+
+  let rec classify_expression : Typedtree.expression -> sd =
+    fun exp -> match exp.exp_desc with 
+      | Texp_let (_, _, e)
+      | Texp_letmodule (_, _, _, e)
+      | Texp_sequence (_, e)
+      | Texp_letexception (_, e) -> classify_expression e
+      | Texp_ident _
+      | Texp_for _
+      | Texp_constant _
+      | Texp_new _
+      | Texp_instvar _
+      | Texp_tuple _
+      | Texp_array _
+      | Texp_construct _
+      | Texp_variant _
+      | Texp_record _
+      | Texp_setfield _
+      | Texp_while _
+      | Texp_setinstvar _
+      | Texp_pack _
+      | Texp_object _
+      | Texp_function _
+      | Texp_lazy _
+      | Texp_unreachable
+      | Texp_extension_constructor _ -> Static
+      | Texp_apply ({exp_desc = Texp_ident (_, _, vd)}, _)
+        when is_ref vd -> Static
+      | Texp_apply _
+      | Texp_match _
+      | Texp_ifthenelse _
+      | Texp_send _
+      | Texp_field _
+      | Texp_assert _
+      | Texp_try _
+      | Texp_override _ -> Dynamic
+
+  let rec expression : Env.env -> Typedtree.expression -> Use.t =
+    fun env exp -> match exp.exp_desc with
+      | Texp_ident (pth, _, _) ->
+          (path env pth)
+      | Texp_let (rec_flag, bindings, body) ->
+        let env', ty = value_bindings rec_flag env bindings in
+        (* Here and in other binding constructs 'discard' is used in a
+           similar way to the way it's used in sequence: uses are
+           propagated, but unguarded access are not. *)
+        Use.join (Use.discard ty) (expression (Env.join env env') body)
+      | Texp_letmodule (x, _, m, e) ->
+        let ty = modexp env m in
+        Use.join (Use.discard ty) (expression (Ident.add x ty env) e)
+      | Texp_match (e, val_cases, exn_cases, _) ->
+        let t = expression env e in
+        let exn_case env {Typedtree.c_rhs} = expression env c_rhs in
+        let cs = list (case ~scrutinee:t) env val_cases
+        and es = list exn_case env exn_cases in
+        Use.(join cs es)
+      | Texp_for (_, _, e1, e2, _, e3) ->
+        Use.(join
+                (join
+                   (inspect (expression env e1))
+                   (inspect (expression env e2)))
+                (* The body is evaluated, but not used, and not available 
+                   for inclusion in another value *)
+                (discard (expression env e3)))
+
+      | Texp_constant _ ->
+        Use.empty
+      | Texp_new (pth, _, _) ->
+          Use.inspect (path env pth)
+      | Texp_instvar _ ->
+        Use.empty
+      | Texp_apply ({exp_desc = Texp_ident (_, _, vd)}, [_, Some arg])
+        when is_ref vd ->
+          Use.guard (expression env arg)
+      | Texp_apply (e, args) ->
+        let arg env (_, eo) = option expression env eo in
+        Use.(join
+                (inspect (expression env e))
+                (inspect (list arg env args)))
+      | Texp_tuple exprs ->
+        Use.guard (list expression env exprs)
+      | Texp_array exprs when array_kind exp = `Pfloatarray ->
+        Use.inspect (list expression env exprs)
+      | Texp_array exprs when has_concrete_element_type exp ->
+        Use.guard (list expression env exprs)
+      | Texp_array exprs ->
+        (* This is counted as a use, because constructing a generic array
+           involves inspecting the elements (PR#6939). *)
+        Use.inspect (list expression env exprs)
+      | Texp_construct (_, desc, exprs) ->
+        let access_constructor =
+          match desc.cstr_tag with
+          | Cstr_extension (pth, _) -> Use.inspect (path env pth)
+          | _ -> Use.empty
+        in
+        let use = match desc.cstr_tag with
+          | Cstr_unboxed -> (fun x -> x)
+          | Cstr_constant _ | Cstr_block _ | Cstr_extension _ -> Use.guard
+        in
+        Use.join access_constructor (use (list expression env exprs))
+      | Texp_variant (_, eo) ->
+        Use.guard (option expression env eo)
+      | Texp_record { fields = es; extended_expression = eo;
+                      representation = rep } ->
+          let use = match rep with
+            | Record_float -> Use.inspect
+            | Record_unboxed _ -> (fun x -> x)
+            | Record_regular | Record_inlined _
+            | Record_extension -> Use.guard
+          in
+          let field env = function
+              _, Kept _ -> Use.empty
+            | _, Overridden (_, e) -> expression env e
+          in
+          Use.join
+            (use (array field env es))
+            (option expression env eo)
+      | Texp_ifthenelse (cond, ifso, ifnot) ->
+          Use.(join (inspect (expression env cond))
+                  (join
+                     (expression env ifso)
+                     (option expression env ifnot)))
+      | Texp_setfield (e1, _, _, e2) ->
+          Use.(join (inspect (expression env e1))
+                (inspect (expression env e2)))
+      | Texp_sequence (e1, e2) ->
+        Use.(join (discard (expression env e1))
+                (expression env e2))
+      | Texp_while (e1, e2) ->
+        Use.(join (inspect (expression env e1))
+                (discard (expression env e2)))
+      | Texp_send (e1, _, eo) ->
+        Use.(join (inspect (expression env e1))
+                (inspect (option expression env eo)))
+      | Texp_field (e, _, _) ->
+        Use.(inspect (expression env e))
+      | Texp_setinstvar (_,_,_,e) ->
+          Use.(inspect (expression env e))
+      | Texp_letexception (_, e) ->
+          expression env e
+      | Texp_assert e ->
+          Use.inspect (expression env e)
+      | Texp_pack m ->
+          modexp env m
+      | Texp_object (clsstrct, _) ->
+          class_structure env clsstrct
+      | Texp_try (e, cases) ->
+        (* This is more permissive than the old check. *)
+        let case env {Typedtree.c_rhs} = expression env c_rhs in
+        Use.join (expression env e)
+          (list case env cases)
+      | Texp_override (_, fields) ->
+        let field env (_, _, e) = expression env e in
+        Use.inspect (list field env fields)
+      | Texp_function { cases } ->
+        Use.delay (list (case ~scrutinee:Use.empty) env cases)
+      | Texp_lazy e ->
+         begin match Typeopt.classify_lazy_argument e with
+         | `Constant_or_function
+         | `Identifier _
+         | `Float ->
+            expression env e
+         | `Other ->
+            Use.delay (expression env e)
+         end
+      | Texp_unreachable ->
+        Use.empty
+      | Texp_extension_constructor _ ->
+        Use.empty
+  and option : 'a. (Env.env -> 'a -> Use.t) -> Env.env -> 'a option -> Use.t =
+    fun f env -> Misc.Stdlib.Option.value_default (f env) ~default:Use.empty
+  and list : 'a. (Env.env -> 'a -> Use.t) -> Env.env -> 'a list -> Use.t =
+    fun f env ->
+      List.fold_left (fun typ item -> Use.join (f env item) typ) Use.empty
+  and array : 'a. (Env.env -> 'a -> Use.t) -> Env.env -> 'a array -> Use.t =
+    fun f env ->
+      Array.fold_left (fun typ item -> Use.join (f env item) typ) Use.empty
+  and class_structure : Env.env -> Typedtree.class_structure -> Use.t =
+    fun env cs -> Use.(inspect (list class_field env cs.cstr_fields))
+  and class_field : Env.env -> Typedtree.class_field -> Use.t =
+    fun env cf -> match cf.cf_desc with
+      | Tcf_inherit (_, ce, _super, _inh_vars, _inh_meths) ->
+          Use.inspect (class_expr env ce)
+      | Tcf_val (_lab, _mut, _, cfk, _) ->
+          class_field_kind env cfk
+      | Tcf_method (_, _, cfk) ->
+          class_field_kind env cfk
+      | Tcf_constraint _ ->
+          Use.empty
+      | Tcf_initializer e ->
+          Use.inspect (expression env e)
+      | Tcf_attribute _ ->
+          Use.empty
+  and class_field_kind : Env.env -> Typedtree.class_field_kind -> Use.t =
+    fun env cfk -> match cfk with
+      | Tcfk_virtual _ ->
+          Use.empty
+      | Tcfk_concrete (_, e) ->
+          Use.inspect (expression env e)
+  and modexp : Env.env -> Typedtree.module_expr -> Use.t =
+    fun env m -> match m.mod_desc with
+      | Tmod_ident (pth, _) ->
+          (path env pth)
+      | Tmod_structure s ->
+          structure env s
+      | Tmod_functor (_, _, _, e) ->
+        Use.delay (modexp env e)
+      | Tmod_apply (f, p, _) ->
+        Use.(join
+                (inspect (modexp env f))
+                (inspect (modexp env p)))
+      | Tmod_constraint (m, _, _, Tcoerce_none) ->
+        modexp env m
+      | Tmod_constraint (m, _, _, _) ->
+        Use.inspect (modexp env m)
+      | Tmod_unpack (e, _) ->
+          expression env e
+  and path : Env.env -> Path.t -> Use.t =
+    fun env pth -> match pth with
+      | Path.Pident x ->
+          (try Ident.find_same x env with Not_found -> Use.empty)
+      | Path.Pdot (t, _, _) ->
+          Use.inspect (path env t)
+      | Path.Papply (f, p) ->
+          Use.(inspect (join (path env f) (path env p)))
+  and structure : Env.env -> Typedtree.structure -> Use.t =
+    fun env s ->
+      let _, ty =
+        List.fold_left
+          (fun (env, ty) item ->
+             let env', ty' = structure_item env item in
+             Env.join env env', Use.join ty ty')
+          (env, Use.empty)
+          s.str_items
+      in
+      Use.guard ty
+  and structure_item : Env.env -> Typedtree.structure_item -> Env.env * Use.t =
+    fun env s -> match s.str_desc with
+      | Tstr_eval (e, _) ->
+          Env.empty, expression env e
+      | Tstr_value (rec_flag, valbinds) ->
+          value_bindings rec_flag env valbinds
+      | Tstr_module {mb_id; mb_expr} ->
+          let ty = modexp env mb_expr in
+          Ident.add mb_id ty Env.empty, ty
+      | Tstr_recmodule mbs ->
+          let modbind env {mb_expr} = modexp env mb_expr in
+          (* Over-approximate: treat any access as a use *)
+          Env.empty, Use.inspect (list modbind env mbs)
+      | Tstr_primitive _ ->
+          Env.empty, Use.empty
+      | Tstr_type _ ->
+          Env.empty, Use.empty
+      | Tstr_typext _ ->
+          Env.empty, Use.empty
+      | Tstr_exception _ ->
+          Env.empty, Use.empty
+      | Tstr_modtype _ ->
+          Env.empty, Use.empty
+      | Tstr_open _ ->
+          Env.empty, Use.empty
+      | Tstr_class classes ->
+          (* Any occurrence in a class definition is counted as a use,
+             so there's no need to add anything to the environment. *)
+          let cls env ({ci_expr=ce}, _) = class_expr env ce in
+          Env.empty, Use.inspect (list cls env classes)
+      | Tstr_class_type _ ->
+          Env.empty, Use.empty
+      | Tstr_include inc ->
+          (* This is a kind of projection.  There's no need to add
+             anything to the environment because everything is used in
+             the type component already *)
+          Env.empty, Use.inspect (modexp env inc.incl_mod)
+      | Tstr_attribute _ ->
+          Env.empty, Use.empty
+  and class_expr : Env.env -> Typedtree.class_expr -> Use.t =
+    fun env ce -> match ce.cl_desc with
+      | Tcl_ident (pth, _, _) ->
+          Use.inspect (path env pth)
+      | Tcl_structure cs ->
+          class_structure env cs
+      | Tcl_fun (_, _, args, ce, _) ->
+          let arg env (_, _, e) = expression env e in
+          Use.inspect (Use.join (list arg env args)
+                          (class_expr env ce))
+      | Tcl_apply (ce, args) ->
+          let arg env (_, eo) = option expression env eo in
+          Use.inspect (Use.join (class_expr env ce)
+                          (list arg env args))
+      | Tcl_let (rec_flag, valbinds, _, ce) ->
+          let _, ty = value_bindings rec_flag env valbinds in
+          Use.(inspect (join ty (class_expr env ce)))
+      | Tcl_constraint (ce, _, _, _, _) ->
+          class_expr env ce
+      | Tcl_open (_, _, _, _, ce) ->
+          class_expr env ce
+  and case : Env.env -> Typedtree.case -> scrutinee:Use.t -> Use.t =
+    fun env { Typedtree.c_lhs; c_guard; c_rhs } ~scrutinee:ty ->
+      let ty =
+        if is_destructuring_pattern c_lhs then Use.inspect ty
+        else Use.discard ty (* as in 'let' *)
+      in
+      let vars = pattern_variables c_lhs in
+      let env = 
+        List.fold_left
+          (fun env id -> Ident.add id ty env)
+          env
+          vars
+      in
+      Use.(join ty
+              (join (expression env c_rhs)
+                 (inspect (option expression env c_guard))))
+  and value_bindings : rec_flag -> Env.env -> Typedtree.value_binding list -> Env.env * Use.t =
+    fun rec_flag env bindings ->
+      match rec_flag with
+      | Recursive ->
+          (* Approximation: 
+                let rec y =
+                  let rec x1 = e1
+                      and x2 = e2
+                    in e
+             treated as
+                let rec y =
+                   let rec x = (e1, e2)[x1:=fst x, x2:=snd x] in
+                      e[x1:=fst x, x2:=snd x]
+             Further, use the fact that x1,x2 cannot occur unguarded in e1, e2
+             to avoid recursive trickiness.
+          *)
+          let ids, ty =
+            List.fold_left
+              (fun (pats, tys) {vb_pat=p; vb_expr=e} ->
+                 (pattern_variables p @ pats,
+                  Use.join (expression env e) tys))
+              ([], Use.empty)
+              bindings
+          in
+          (List.fold_left (fun  (env : Env.env) (id : Ident.t) ->
+               Ident.add id ty env) Env.empty ids,
+           ty)
+      | Nonrecursive ->
+          List.fold_left
+            (fun (env2, ty) binding ->
+               let env', ty' = value_binding env binding in
+               (Env.join env2 env', Use.join ty ty'))
+            (Env.empty, Use.empty)
+            bindings
+  and value_binding : Env.env -> Typedtree.value_binding -> Env.env * Use.t =
+    (* NB: returns new environment only *)
+    fun env { vb_pat; vb_expr } ->
+      let vars = pattern_variables vb_pat in
+      let ty = expression env vb_expr in
+      let ty = if is_destructuring_pattern vb_pat then Use.inspect ty else ty in
+      (List.fold_left
+        (fun env id -> Ident.add id ty env)
+        Env.empty
+        vars,
+       ty)
+  and is_destructuring_pattern : Typedtree.pattern -> bool =
+    fun pat -> match pat.pat_desc with
+      | Tpat_any -> false
+      | Tpat_var (_, _) -> false
+      | Tpat_alias (pat, _, _) -> is_destructuring_pattern pat
+      | Tpat_constant _ -> true
+      | Tpat_tuple _ -> true
+      | Tpat_construct (_, _, _) -> true
+      | Tpat_variant _ -> true
+      | Tpat_record (_, _) -> true
+      | Tpat_array _ -> true
+      | Tpat_or (l,r,_) -> is_destructuring_pattern l || is_destructuring_pattern r
+      | Tpat_lazy _ -> true
+
+  let check_recursive_expression env idlist expr =
+    let ty = expression (build_unguarded_env idlist) expr in
+    match Use.unguarded ty, Use.dependent ty, classify_expression expr with
+    | _ :: _, _, _ (* The expression inspects rec-bound variables *)
+    | _, _ :: _, Dynamic -> (* The expression depends on rec-bound variables 
+                               and its size is unknown *)
+        raise(Error(expr.exp_loc, env, Illegal_letrec_expr))
+    | [], _, Static (* The expression has known size *)
+    | [], [], Dynamic -> (* The expression has unknown size,
+                            but does not depend on rec-bound variables *)
+        ()
+  let check_class_expr env idlist ce =
+    let rec class_expr : Env.env -> Typedtree.class_expr -> Use.t =
+      fun env ce -> match ce.cl_desc with
+        | Tcl_ident (_, _, _) -> Use.empty
+        | Tcl_structure _ -> Use.empty
+        | Tcl_fun (_, _, _, _, _) -> Use.empty
+        | Tcl_apply (_, _) -> Use.empty
+        | Tcl_let (rec_flag, valbinds, _, ce) ->
+            let _, ty = value_bindings rec_flag env valbinds in
+            Use.join ty (class_expr env ce)
+        | Tcl_constraint (ce, _, _, _, _) ->
+            class_expr env ce
+        | Tcl_open (_, _, _, _, ce) ->
+            class_expr env ce
+    in
+    match Use.unguarded (class_expr (build_unguarded_env idlist) ce) with
+    | [] -> ()
+    | _ :: _ -> raise(Error(ce.cl_loc, env, Illegal_class_expr))
+end
+
+let check_recursive_bindings env valbinds =
+  let ids = List.concat
+      (List.map (fun b -> pattern_variables b.vb_pat) valbinds) in
+  List.iter
+    (fun {vb_expr} ->
+       Rec_check.check_recursive_expression env ids vb_expr)
+    valbinds
+
+let check_recursive_class_bindings env ids exprs =
+  List.iter
+    (fun expr ->
+       Rec_check.check_class_expr env ids expr)
+    exprs
+
 (* Approximate the type of an expression, for better recursion *)
 
 let rec approx_type env sty =
@@ -1883,12 +2552,7 @@ let check_absent_variant env =
 let duplicate_ident_types caselist env =
   let caselist =
     List.filter (fun {pc_lhs} -> contains_gadt env pc_lhs) caselist in
-  let idents = all_idents_cases caselist in
-  let upd desc = {desc with val_type = correct_levels desc.val_type} in
-  (* Be careful not the mark the original value as being used, and
-     to keep the same internal 'slot' to track unused opens. *)
-  List.fold_left (fun env s -> Env.update_value s upd env) env idents
-
+  Env.copy_types (all_idents_cases caselist) env
 
 (* Getting proper location of already typed expressions.
 
@@ -1939,10 +2603,12 @@ let rec type_exp ?recarg env sexp =
 
 and type_expect ?in_function ?recarg env sexp ty_expected =
   let previous_saved_types = Cmt_format.get_saved_types () in
-  Builtin_attributes.warning_enter_scope ();
-  Builtin_attributes.warning_attribute sexp.pexp_attributes;
-  let exp = type_expect_ ?in_function ?recarg env sexp ty_expected in
-  Builtin_attributes.warning_leave_scope ();
+  let exp =
+    Builtin_attributes.warning_scope sexp.pexp_attributes
+      (fun () ->
+         type_expect_ ?in_function ?recarg env sexp ty_expected
+      )
+  in
   Cmt_format.set_saved_types
     (Cmt_format.Partial_expression exp :: previous_saved_types);
   exp
@@ -2068,6 +2734,10 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected =
         type_let env rec_flag spat_sexp_list scp true in
       let body =
         type_expect new_env (wrap_unpacks sbody unpacks) ty_expected in
+      let () =
+        if rec_flag = Recursive then
+          check_recursive_bindings env pat_exp_list
+      in
       re {
         exp_desc = Texp_let(rec_flag, pat_exp_list, body);
         exp_loc = loc; exp_extra = [];
@@ -2799,6 +3469,9 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected =
          i.e. if generative types rooted at id show up in the
          type body.exp_type.  Thus, this unification enforces the
          scoping condition on "let module". *)
+      (* Note that this code will only be reached if ty_expected
+         is a generic type variable, otherwise the error will occur
+         above in type_expect *)
       begin try
         Ctype.unify_var new_env ty body.exp_type
       with Unify _ ->
@@ -3231,8 +3904,8 @@ and type_format loc str env =
           mk_constr "Ignored_int64" [ mk_iconv iconv; mk_int_opt pad_opt ]
         | Ignored_float (pad_opt, prec_opt) ->
           mk_constr "Ignored_float" [ mk_int_opt pad_opt; mk_int_opt prec_opt ]
-        | Ignored_bool ->
-          mk_constr "Ignored_bool" []
+        | Ignored_bool pad_opt ->
+          mk_constr "Ignored_bool" [ mk_int_opt pad_opt ]
         | Ignored_format_arg (pad_opt, fmtty) ->
           mk_constr "Ignored_format_arg" [ mk_int_opt pad_opt; mk_fmtty fmtty ]
         | Ignored_format_subst (pad_opt, fmtty) ->
@@ -3285,8 +3958,8 @@ and type_format loc str env =
         | Float (fconv, pad, prec, rest) ->
           mk_constr "Float" [
             mk_fconv fconv; mk_padding pad; mk_precision prec; mk_fmt rest ]
-        | Bool rest ->
-          mk_constr "Bool" [ mk_fmt rest ]
+        | Bool (pad, rest) ->
+          mk_constr "Bool" [ mk_padding pad; mk_fmt rest ]
         | Flush rest ->
           mk_constr "Flush" [ mk_fmt rest ]
         | String_literal (s, rest) ->
@@ -3463,7 +4136,6 @@ and type_argument ?recarg env sarg ty_expected' ty_expected =
            (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
       (* let-expand to have side effects *)
       let let_pat, let_var = var_pair "arg" texp.exp_type in
       re { texp with exp_type = ty_fun; exp_desc =
@@ -3828,7 +4500,6 @@ and type_cases ?in_function env ty_arg ty_res partial_flag loc caselist =
       [{pc_lhs}] when is_var pc_lhs -> false
     | _ -> true in
   if propagate then begin_def (); (* propagation of the argument *)
-  let ty_arg' = newvar () in
   let pattern_force = ref [] in
 (*  Format.printf "@[%i %i@ %a@]@." lev (get_current_level())
     Printtyp.raw_type_expr ty_arg; *)
@@ -3855,15 +4526,19 @@ and type_cases ?in_function env ty_arg ty_res partial_flag loc caselist =
           if !Clflags.principal then begin
             end_def ();
             iter_pattern (fun {pat_type=t} -> generalize_structure t) pat;
-            { pat with pat_type = instance env pat.pat_type }
+            { pat with pat_type = instance ext_env pat.pat_type }
           end else pat
         in
         (pat, (ext_env, unpacks)))
       caselist in
-  (* Unify cases (delayed to keep it order-free) *)
-  let patl = List.map fst pat_env_list in
-  List.iter (fun pat -> unify_pat env pat ty_arg') patl;
+  (* Unify all cases (delayed to keep it order-free) *)
+  let ty_arg' = newvar () in
+  let unify_pats ty =
+    List.iter (fun (pat, (ext_env, _)) -> unify_pat ext_env pat ty)
+      pat_env_list in
+  unify_pats ty_arg';
   (* Check for polymorphic variants to close *)
+  let patl = List.map fst pat_env_list in
   if List.exists has_variants patl then begin
     Parmatch.pressure_variants env patl;
     List.iter (iter_pattern finalize_variant) patl
@@ -3871,15 +4546,13 @@ and type_cases ?in_function env ty_arg ty_res partial_flag loc caselist =
   (* `Contaminating' unifications start here *)
   List.iter (fun f -> f()) !pattern_force;
   (* Post-processing and generalization *)
-  let unify_pats ty = List.iter (fun pat -> unify_pat env pat ty) patl in
+  if propagate || erase_either then unify_pats (instance env ty_arg);
   if propagate then begin
     List.iter
       (iter_pattern (fun {pat_type=t} -> unify_var env t (newvar()))) patl;
-    unify_pats (instance env ty_arg);
     end_def ();
     List.iter (iter_pattern (fun {pat_type=t} -> generalize t)) patl;
-  end
-  else if erase_either then unify_pats (instance env ty_arg);
+  end;
   (* type bodies *)
   let in_function = if List.length caselist = 1 then in_function else None in
   let cases =
@@ -3972,7 +4645,8 @@ and type_let ?(check = fun s -> Warnings.Unused_var s)
 
   let spatl =
     List.map
-      (fun {pvb_pat=spat; pvb_expr=sexp; pvb_attributes=_} ->
+      (fun {pvb_pat=spat; pvb_expr=sexp; pvb_attributes=attrs} ->
+        attrs,
         match spat.ppat_desc, sexp.pexp_desc with
           (Ppat_any | Ppat_constraint _), _ -> spat
         | _, Pexp_coerce (_, _, sty)
@@ -3988,6 +4662,7 @@ and type_let ?(check = fun s -> Warnings.Unused_var s)
   let nvs = List.map (fun _ -> newvar ()) spatl in
   let (pat_list, new_env, force, unpacks) =
     type_pattern_list env spatl scope nvs allow in
+  let attrs_list = List.map fst spatl in
   let is_recursive = (rec_flag = Recursive) in
   (* If recursive, first unify with an approximation of the expression *)
   if is_recursive then
@@ -4026,9 +4701,13 @@ and type_let ?(check = fun s -> Warnings.Unused_var s)
 
   let current_slot = ref None in
   let rec_needed = ref false in
-  let warn_unused =
-    Warnings.is_active (check "") || Warnings.is_active (check_strict "") ||
-    (is_recursive && (Warnings.is_active Warnings.Unused_rec_flag))
+  let warn_about_unused_bindings =
+    List.exists
+      (fun attrs ->
+         Builtin_attributes.warning_scope ~ppwarning:false attrs (fun () ->
+           Warnings.is_active (check "") || Warnings.is_active (check_strict "") ||
+           (is_recursive && (Warnings.is_active Warnings.Unused_rec_flag))))
+      attrs_list
   in
   let pat_slot_list =
     (* Algorithm to detect unused declarations in recursive bindings:
@@ -4047,43 +4726,45 @@ and type_let ?(check = fun s -> Warnings.Unused_var s)
        are unused. If this is the case, for local declarations, the issued
        warning is 26, not 27.
      *)
-    List.map
-      (fun pat ->
-        if not warn_unused then pat, None
-        else
-          let some_used = ref false in
-            (* has one of the identifier of this pattern been used? *)
-          let slot = ref [] in
-          List.iter
-            (fun id ->
-              let vd = Env.find_value (Path.Pident id) new_env in
-              (* note: Env.find_value does not trigger the value_used event *)
-              let name = Ident.name id in
-              let used = ref false in
-              if not (name = "" || name.[0] = '_' || name.[0] = '#') then
-                add_delayed_check
-                  (fun () ->
-                    if not !used then
-                      Location.prerr_warning vd.Types.val_loc
-                        ((if !some_used then check_strict else check) name)
-                  );
-              Env.set_value_used_callback
-                name vd
-                (fun () ->
-                  match !current_slot with
-                  | Some slot ->
-                      slot := (name, vd) :: !slot; rec_needed := true
-                  | None ->
-                      List.iter
-                        (fun (name, vd) -> Env.mark_value_used env name vd)
-                        (get_ref slot);
-                      used := true;
-                      some_used := true
-                )
-            )
-            (Typedtree.pat_bound_idents pat);
-          pat, Some slot
-        )
+    List.map2
+      (fun attrs pat ->
+         Builtin_attributes.warning_scope ~ppwarning:false attrs (fun () ->
+           if not warn_about_unused_bindings then pat, None
+           else
+             let some_used = ref false in
+             (* has one of the identifier of this pattern been used? *)
+             let slot = ref [] in
+             List.iter
+               (fun id ->
+                  let vd = Env.find_value (Path.Pident id) new_env in
+                  (* note: Env.find_value does not trigger the value_used event *)
+                  let name = Ident.name id in
+                  let used = ref false in
+                  if not (name = "" || name.[0] = '_' || name.[0] = '#') then
+                    add_delayed_check
+                      (fun () ->
+                         if not !used then
+                           Location.prerr_warning vd.Types.val_loc
+                             ((if !some_used then check_strict else check) name)
+                      );
+                  Env.set_value_used_callback
+                    name vd
+                    (fun () ->
+                       match !current_slot with
+                       | Some slot ->
+                         slot := (name, vd) :: !slot; rec_needed := true
+                       | None ->
+                         List.iter
+                           (fun (name, vd) -> Env.mark_value_used env name vd)
+                           (get_ref slot);
+                         used := true;
+                         some_used := true
+                    )
+               )
+               (Typedtree.pat_bound_idents pat);
+             pat, Some slot
+         ))
+      attrs_list
       pat_list
   in
   let exp_list =
@@ -4102,14 +4783,14 @@ and type_let ?(check = fun s -> Warnings.Unused_var s)
               generalize_structure ty'
             end;
             let exp =
-              Builtin_attributes.with_warning_attribute pvb_attributes
+              Builtin_attributes.warning_scope 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}
         | _ ->
-            Builtin_attributes.with_warning_attribute pvb_attributes (fun () ->
+            Builtin_attributes.warning_scope pvb_attributes (fun () ->
               type_expect exp_env sexp pat.pat_type))
       spat_sexp_list pat_slot_list in
   current_slot := None;
@@ -4117,15 +4798,21 @@ and type_let ?(check = fun s -> Warnings.Unused_var s)
   && Warnings.is_active Warnings.Unused_rec_flag then begin
     let {pvb_pat; pvb_attributes} = List.hd spat_sexp_list in
     (* See PR#6677 *)
-    Builtin_attributes.with_warning_attribute pvb_attributes
+    Builtin_attributes.warning_scope ~ppwarning:false pvb_attributes
       (fun () ->
          Location.prerr_warning pvb_pat.ppat_loc Warnings.Unused_rec_flag
       )
   end;
   List.iter2
-    (fun pat exp ->
-      ignore(check_partial env pat.pat_type pat.pat_loc [case pat exp]))
-    pat_list exp_list;
+    (fun pat (attrs, exp) ->
+       Builtin_attributes.warning_scope ~ppwarning:false attrs
+         (fun () ->
+            ignore(check_partial env pat.pat_type pat.pat_loc
+                     [case pat exp])
+         )
+    )
+    pat_list
+    (List.map2 (fun (attrs, _) e -> attrs, e) spatl exp_list);
   end_def();
   List.iter2
     (fun pat exp ->
@@ -4144,6 +4831,13 @@ and type_let ?(check = fun s -> Warnings.Unused_var s)
         })
       l spat_sexp_list
   in
+  if is_recursive then
+    List.iter 
+      (fun {vb_pat=pat} -> match pat.pat_desc with
+           Tpat_var _ -> ()
+         | Tpat_alias ({pat_desc=Tpat_any}, _, _) -> ()
+         | _ -> raise(Error(pat.pat_loc, env, Illegal_letrec_pat)))
+      l;
   (l, new_env, unpacks)
 
 (* Typing of toplevel bindings *)
@@ -4439,7 +5133,14 @@ let report_error env ppf = function
                    integers of type %s" ty
   | Unknown_literal (n, m) ->
       fprintf ppf "Unknown modifier '%c' for literal %s%c" m n m
-
+  | Illegal_letrec_pat ->
+      fprintf ppf
+        "Only variables are allowed as left-hand side of `let rec'"
+  | Illegal_letrec_expr ->
+      fprintf ppf
+        "This kind of expression is not allowed as right-hand side of `let rec'"
+  | Illegal_class_expr ->
+      fprintf ppf "This kind of recursive class expression is not allowed"
 
 let report_error env ppf err =
   wrap_printing_env env (fun () -> report_error env ppf err)

diff --git a/typing/typecore.mli b/typing/typecore.mli
index 7b64ee343cb5b8e29a1264df8080906599821229..42f125c1766eb67fbb34ca0a14f91376a8cc8ecc 100644 (file)
--- a/typing/typecore.mli
+++ b/typing/typecore.mli
@@ -124,6 +124,9 @@ type error =
   | Not_an_extension_constructor
   | Literal_overflow of string
   | Unknown_literal of string * char
+  | Illegal_letrec_pat
+  | Illegal_letrec_expr
+  | Illegal_class_expr
 
 exception Error of Location.t * Env.t * error
 exception Error_forward of Location.error
@@ -135,7 +138,8 @@ val report_error: Env.t -> formatter -> error -> unit
 val type_module: (Env.t -> Parsetree.module_expr -> Typedtree.module_expr) ref
 (* Forward declaration, to be filled in by Typemod.type_open *)
 val type_open:
-    (override_flag -> Env.t -> Location.t -> Longident.t loc -> Path.t * Env.t)
+  (?used_slot:bool ref -> override_flag -> Env.t -> Location.t ->
+   Longident.t loc -> Path.t * Env.t)
     ref
 (* Forward declaration, to be filled in by Typeclass.class_structure *)
 val type_object:
@@ -150,3 +154,7 @@ val create_package_type : Location.t -> Env.t ->
   Path.t * (Longident.t * Typedtree.core_type) list * Types.type_expr
 
 val constant: Parsetree.constant -> (Asttypes.constant, error) result
+
+val check_recursive_bindings : Env.t -> Typedtree.value_binding list -> unit
+val check_recursive_class_bindings :
+  Env.t -> Ident.t list -> Typedtree.class_expr list -> unit

diff --git a/typing/typedecl.ml b/typing/typedecl.ml
index 4872da67d708b7144acd2905063124d3e8fa7697..2369b84c6887f4fa532b3807c4ba280d7de130df 100644 (file)
--- a/typing/typedecl.ml
+++ b/typing/typedecl.ml
@@ -39,7 +39,7 @@ type error =
   | Null_arity_external
   | Missing_native_external
   | Unbound_type_var of type_expr * type_declaration
-  | Not_open_type of Path.t
+  | Cannot_extend_private_type of Path.t
   | Not_extensible_type of Path.t
   | Extension_mismatch of Path.t * Includecore.type_mismatch list
   | Rebind_wrong_type of Longident.t * Env.t * (type_expr * type_expr) list
@@ -58,6 +58,7 @@ type error =
   | Bad_unboxed_attribute of string
   | Wrong_unboxed_type_float
   | Boxed_and_unboxed
+  | Nonrec_gadt
 
 open Typedtree
 
@@ -81,7 +82,15 @@ let get_unboxed_from_attributes sdecl =
 let enter_type rec_flag env sdecl id =
   let needed =
     match rec_flag with
-    | Asttypes.Nonrecursive -> Btype.is_row_name (Ident.name id)
+    | Asttypes.Nonrecursive ->
+        begin match sdecl.ptype_kind with
+        | Ptype_variant scds ->
+            List.iter (fun cd ->
+              if cd.pcd_res <> None then raise (Error(cd.pcd_loc, Nonrec_gadt)))
+              scds
+        | _ -> ()
+        end;
+        Btype.is_row_name (Ident.name id)
     | Asttypes.Recursive -> true
   in
   if not needed then env else
@@ -218,10 +227,13 @@ let transl_labels env closed lbls =
     lbls;
   let mk {pld_name=name;pld_mutable=mut;pld_type=arg;pld_loc=loc;
           pld_attributes=attrs} =
-    let arg = Ast_helper.Typ.force_poly arg in
-    let cty = transl_simple_type env closed arg in
-    {ld_id = Ident.create name.txt; ld_name = name; ld_mutable = mut;
-     ld_type = cty; ld_loc = loc; ld_attributes = attrs}
+    Builtin_attributes.warning_scope attrs
+      (fun () ->
+         let arg = Ast_helper.Typ.force_poly arg in
+         let cty = transl_simple_type env closed arg in
+         {ld_id = Ident.create name.txt; ld_name = name; ld_mutable = mut;
+          ld_type = cty; ld_loc = loc; ld_attributes = attrs}
+      )
   in
   let lbls = List.map mk lbls in
   let lbls' =
@@ -255,7 +267,7 @@ let make_constructor env type_path type_params sargs sret_type =
       let args, targs =
         transl_constructor_arguments env true sargs
       in
-        targs, None, args, None
+        targs, None, args, None, type_params
   | Some sret_type ->
       (* if it's a generalized constructor we must first narrow and
          then widen so as to not introduce any new constraints *)
@@ -266,15 +278,16 @@ let make_constructor env type_path type_params sargs sret_type =
       in
       let tret_type = transl_simple_type env false sret_type in
       let ret_type = tret_type.ctyp_type in
-      begin
+      let params =
         match (Ctype.repr ret_type).desc with
-          Tconstr (p', _, _) when Path.same type_path p' -> ()
+        | Tconstr (p', params, _) when Path.same type_path p' ->
+            params
         | _ ->
             raise (Error (sret_type.ptyp_loc, Constraint_failed
                             (ret_type, Ctype.newconstr type_path type_params)))
-      end;
+      in
       widen z;
-      targs, Some tret_type, args, Some ret_type
+      targs, Some tret_type, args, Some ret_type, params
 
 (* Check that the variable [id] is present in the [univ] list. *)
 let check_type_var loc univ id =
@@ -413,6 +426,12 @@ let transl_declaration env sdecl id =
       | Ptype_abstract -> Ttype_abstract, Type_abstract
       | Ptype_variant scstrs ->
         assert (scstrs <> []);
+        if List.exists (fun cstr -> cstr.pcd_res <> None) scstrs then begin
+          match cstrs with
+            [] -> ()
+          | (_,_,loc)::_ ->
+              Location.prerr_warning loc Warnings.Constraint_on_gadt
+        end;
         let all_constrs = ref StringSet.empty in
         List.iter
           (fun {pcd_name = {txt = name}} ->
@@ -426,11 +445,11 @@ let transl_declaration env sdecl id =
           raise(Error(sdecl.ptype_loc, Too_many_constructors));
         let make_cstr scstr =
           let name = Ident.create scstr.pcd_name.txt in
-          let targs, tret_type, args, ret_type =
+          let targs, tret_type, args, ret_type, cstr_params =
             make_constructor env (Path.Pident id) params
                              scstr.pcd_args scstr.pcd_res
           in
-          if unbox then begin
+          if Config.flat_float_array && unbox then begin
             (* Cannot unbox a type when the argument can be both float and
                non-float because it interferes with the dynamic float array
                optimization. This can only happen when the type is a GADT
@@ -445,7 +464,7 @@ let transl_declaration env sdecl id =
             match Datarepr.constructor_existentials args ret_type with
             | _, [] -> ()
             | [argty], _ex ->
-                check_unboxed_gadt_arg sdecl.ptype_loc params env argty
+                check_unboxed_gadt_arg sdecl.ptype_loc cstr_params env argty
             | _ -> assert false
           end;
           let tcstr =
@@ -465,6 +484,10 @@ let transl_declaration env sdecl id =
           in
             tcstr, cstr
         in
+        let make_cstr scstr =
+          Builtin_attributes.warning_scope scstr.pcd_attributes
+            (fun () -> make_cstr scstr)
+        in
         let tcstrs, cstrs = List.split (List.map make_cstr scstrs) in
           Ttype_variant tcstrs, Type_variant cstrs
       | Ptype_record lbls ->
@@ -659,7 +682,7 @@ let check_coherence env loc id decl =
               else if not (Ctype.equal env false args decl.type_params)
               then [Includecore.Constraint]
               else
-                Includecore.type_declarations ~equality:true env
+                Includecore.type_declarations ~loc ~equality:true env
                   (Path.last path)
                   decl'
                   id
@@ -918,7 +941,7 @@ let compute_variance_type env check (required, loc) decl tyl =
   (* Prepare *)
   let params = List.map Btype.repr decl.type_params in
   let tvl = ref TypeMap.empty in
-  (* Compute occurences in body *)
+  (* Compute occurrences in the body *)
   let open Variance in
   List.iter
     (fun (cn,ty) ->
@@ -997,7 +1020,7 @@ let compute_variance_type env check (required, loc) decl tyl =
 
 let add_false = List.map (fun ty -> false, ty)
 
-(* A parameter is constrained if either is is instantiated,
+(* A parameter is constrained if it is either instantiated,
    or it is a variable appearing in another parameter *)
 let constrained vars ty =
   match ty.desc with
@@ -1292,7 +1315,11 @@ let transl_type_decl env rec_flag sdecl_list =
         id, None
   in
   let transl_declaration name_sdecl (id, slot) =
-    current_slot := slot; transl_declaration temp_env name_sdecl id in
+    current_slot := slot;
+    Builtin_attributes.warning_scope
+      name_sdecl.ptype_attributes
+      (fun () -> transl_declaration temp_env name_sdecl id)
+  in
   let tdecls =
     List.map2 transl_declaration sdecl_list (List.map id_slots id_list) in
   let decls =
@@ -1333,7 +1360,7 @@ let transl_type_decl env rec_flag sdecl_list =
       decl to_check)
     decls;
   List.iter (check_abbrev_recursion newenv id_loc_list to_check) tdecls;
-  (* Check that all type variable are closed *)
+  (* Check that all type variables are closed *)
   List.iter2
     (fun sdecl tdecl ->
       let decl = tdecl.typ_type in
@@ -1382,7 +1409,7 @@ let transl_extension_constructor env type_path type_params
   let args, ret_type, kind =
     match sext.pext_kind with
       Pext_decl(sargs, sret_type) ->
-        let targs, tret_type, args, ret_type =
+        let targs, tret_type, args, ret_type, _ =
           make_constructor env type_path typext_params
             sargs sret_type
         in
@@ -1492,7 +1519,13 @@ let transl_extension_constructor env type_path type_params
       Typedtree.ext_loc = sext.pext_loc;
       Typedtree.ext_attributes = sext.pext_attributes; }
 
-let transl_type_extension check_open env loc styext =
+let transl_extension_constructor env type_path type_params
+    typext_params priv sext =
+  Builtin_attributes.warning_scope sext.pext_attributes
+    (fun () -> transl_extension_constructor env type_path type_params
+        typext_params priv sext)
+
+let transl_type_extension extend env loc styext =
   reset_type_variables();
   Ctype.begin_def();
   let (type_path, type_decl) =
@@ -1501,19 +1534,23 @@ let transl_type_extension check_open env loc styext =
   in
   begin
     match type_decl.type_kind with
-      Type_open -> ()
-    | Type_abstract ->
-        if check_open then begin
-          try
-            let {pext_loc} =
-              List.find (function {pext_kind = Pext_decl _} -> true
-                                | {pext_kind = Pext_rebind _} -> false)
-                        styext.ptyext_constructors
-            in
-              raise (Error(pext_loc, Not_open_type type_path))
-          with Not_found -> ()
-        end
-    | _ -> raise (Error(loc, Not_extensible_type type_path))
+    | Type_open -> begin
+        match type_decl.type_private with
+        | Private when extend -> begin
+            match
+              List.find
+                (function {pext_kind = Pext_decl _} -> true
+                        | {pext_kind = Pext_rebind _} -> false)
+                styext.ptyext_constructors
+            with
+            | {pext_loc} ->
+                raise (Error(pext_loc, Cannot_extend_private_type type_path))
+            | exception Not_found -> ()
+          end
+        | _ -> ()
+      end
+    | _ ->
+        raise (Error(loc, Not_extensible_type type_path))
   end;
   let type_variance =
     List.map (fun v ->
@@ -1551,7 +1588,7 @@ let transl_type_extension check_open env loc styext =
        Btype.iter_type_expr_cstr_args Ctype.generalize ext.ext_type.ext_args;
        may Ctype.generalize ext.ext_type.ext_ret_type)
     constructors;
-  (* Check that all type variable are closed *)
+  (* Check that all type variables are closed *)
   List.iter
     (fun ext ->
        match Ctype.closed_extension_constructor ext.ext_type with
@@ -1582,6 +1619,10 @@ let transl_type_extension check_open env loc styext =
   in
     (tyext, newenv)
 
+let transl_type_extension extend env loc styext =
+  Builtin_attributes.warning_scope styext.ptyext_attributes
+    (fun () -> transl_type_extension extend env loc styext)
+
 let transl_exception env sext =
   reset_type_variables();
   Ctype.begin_def();
@@ -1593,7 +1634,7 @@ let transl_exception env sext =
   (* Generalize types *)
   Btype.iter_type_expr_cstr_args Ctype.generalize ext.ext_type.ext_args;
   may Ctype.generalize ext.ext_type.ext_ret_type;
-  (* Check that all type variable are closed *)
+  (* Check that all type variables are closed *)
   begin match Ctype.closed_extension_constructor ext.ext_type with
     Some ty ->
       raise (Error(ext.ext_loc, Unbound_type_var_ext(ty, ext.ext_type)))
@@ -1747,6 +1788,10 @@ let transl_value_decl env loc valdecl =
   in
   desc, newenv
 
+let transl_value_decl env loc valdecl =
+  Builtin_attributes.warning_scope valdecl.pval_attributes
+    (fun () -> transl_value_decl env loc valdecl)
+
 (* Translate a "with" constraint -- much simplified version of
     transl_type_decl. *)
 let transl_with_constraint env id row_path orig_decl sdecl =
@@ -1786,8 +1831,7 @@ let transl_with_constraint env id row_path orig_decl sdecl =
   in
   if arity_ok && orig_decl.type_kind <> Type_abstract
   && sdecl.ptype_private = Private then
-    Location.prerr_warning sdecl.ptype_loc
-      (Warnings.Deprecated "spurious use of private");
+    Location.deprecated sdecl.ptype_loc "spurious use of private";
   let type_kind, type_unboxed =
     if arity_ok && man <> None then
       orig_decl.type_kind, orig_decl.type_unboxed
@@ -2000,13 +2044,13 @@ let report_error ppf = function
       fprintf ppf "A type variable is unbound in this extension constructor";
       let args = tys_of_constr_args ext.ext_args in
       explain_unbound ppf ty args (fun c -> c) "type" (fun _ -> "")
-  | Not_open_type path ->
+  | Cannot_extend_private_type path ->
       fprintf ppf "@[%s@ %a@]"
-        "Cannot extend type definition"
+        "Cannot extend private type definition"
         Printtyp.path path
   | Not_extensible_type path ->
       fprintf ppf "@[%s@ %a@ %s@]"
-        "Type"
+        "Type definition"
         Printtyp.path path
         "is not extensible"
   | Extension_mismatch (path, errs) ->
@@ -2107,6 +2151,9 @@ let report_error ppf = function
                    You should annotate it with [%@%@ocaml.boxed].@]"
   | Boxed_and_unboxed ->
       fprintf ppf "@[A type cannot be boxed and unboxed at the same time.@]"
+  | Nonrec_gadt ->
+      fprintf ppf
+        "@[GADT case syntax cannot be used in a 'nonrec' block.@]"
 
 let () =
   Location.register_error_of_exn

diff --git a/typing/typedecl.mli b/typing/typedecl.mli
index db4875f96f26b85ccf6ca8e6b1057b7836ba9987..1c687cd04f06dce426749bb4050cc35f694b375c 100644 (file)
--- a/typing/typedecl.mli
+++ b/typing/typedecl.mli
@@ -80,7 +80,7 @@ type error =
   | Null_arity_external
   | Missing_native_external
   | Unbound_type_var of type_expr * type_declaration
-  | Not_open_type of Path.t
+  | Cannot_extend_private_type of Path.t
   | Not_extensible_type of Path.t
   | Extension_mismatch of Path.t * Includecore.type_mismatch list
   | Rebind_wrong_type of Longident.t * Env.t * (type_expr * type_expr) list
@@ -99,6 +99,7 @@ type error =
   | Bad_unboxed_attribute of string
   | Wrong_unboxed_type_float
   | Boxed_and_unboxed
+  | Nonrec_gadt
 
 exception Error of Location.t * error
 

diff --git a/typing/typedtree.ml b/typing/typedtree.ml
index db4440c18f78b9f49e5d4fedff81cec13a501394..4cc996432413d145c253b6a460e2833cf3f1035a 100644 (file)
--- a/typing/typedtree.ml
+++ b/typing/typedtree.ml
@@ -152,7 +152,8 @@ and class_expr_desc =
                   (Ident.t * string loc * expression) list * class_expr
   | Tcl_constraint of
       class_expr * class_type option * string list * string list * Concr.t
-    (* Visible instance variables, methods and concretes methods *)
+    (* Visible instance variables, methods and concrete methods *)
+  | Tcl_open of override_flag * Path.t * Longident.t loc * Env.t * class_expr
 
 and class_structure =
   {
@@ -370,7 +371,7 @@ and core_type_desc =
   | 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
+  | Ttyp_object of object_field list * closed_flag
   | Ttyp_class of Path.t * Longident.t loc * core_type list
   | Ttyp_alias of core_type * string
   | Ttyp_variant of row_field list * closed_flag * label list option
@@ -385,9 +386,13 @@ and package_type = {
 }
 
 and row_field =
-    Ttag of label * attributes * bool * core_type list
+    Ttag of string loc * attributes * bool * core_type list
   | Tinherit of core_type
 
+and object_field =
+  | OTtag of string loc * attributes * core_type
+  | OTinherit of core_type
+
 and value_description =
   { val_id: Ident.t;
     val_name: string loc;
@@ -478,6 +483,7 @@ and class_type_desc =
     Tcty_constr of Path.t * Longident.t loc * core_type list
   | Tcty_signature of class_signature
   | Tcty_arrow of arg_label * core_type * class_type
+  | Tcty_open of override_flag * Path.t * Longident.t loc * Env.t * class_type
 
 and class_signature = {
     csig_self: core_type;

diff --git a/typing/typedtree.mli b/typing/typedtree.mli
index ee26bca3e17bd95ead9855e0a40dbcf98b0ad038..2e89ed52330fa221e09df0e933e0da65b924e9db 100644 (file)
--- a/typing/typedtree.mli
+++ b/typing/typedtree.mli
@@ -28,12 +28,12 @@ open Types
 
 type partial = Partial | Total
 
-(** {2 Extension points} *)
+(** {1 Extension points} *)
 
 type attribute = Parsetree.attribute
 type attributes = attribute list
 
-(** {2 Core language} *)
+(** {1 Core language} *)
 
 type pattern =
   { pat_desc: pattern_desc;
@@ -267,7 +267,8 @@ and class_expr_desc =
                   (Ident.t * string loc * expression) list * class_expr
   | Tcl_constraint of
       class_expr * class_type option * string list * string list * Concr.t
-    (* Visible instance variables, methods and concretes methods *)
+  (* Visible instance variables, methods and concrete methods *)
+  | Tcl_open of override_flag * Path.t * Longident.t loc * Env.t * class_expr
 
 and class_structure =
   {
@@ -312,7 +313,7 @@ and module_expr =
 (** Annotations for [Tmod_constraint]. *)
 and module_type_constraint =
   | Tmodtype_implicit
-  (** The module type constraint has been synthesized during typecheking. *)
+  (** The module type constraint has been synthesized during typechecking. *)
   | Tmodtype_explicit of module_type
   (** The module type was in the source file. *)
 
@@ -491,7 +492,7 @@ and core_type_desc =
   | 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
+  | Ttyp_object of object_field list * closed_flag
   | Ttyp_class of Path.t * Longident.t loc * core_type list
   | Ttyp_alias of core_type * string
   | Ttyp_variant of row_field list * closed_flag * label list option
@@ -506,9 +507,13 @@ and package_type = {
 }
 
 and row_field =
-    Ttag of label * attributes * bool * core_type list
+    Ttag of string loc * attributes * bool * core_type list
   | Tinherit of core_type
 
+and object_field =
+  | OTtag of string loc * attributes * core_type
+  | OTinherit of core_type
+
 and value_description =
   { val_id: Ident.t;
     val_name: string loc;
@@ -600,6 +605,7 @@ and class_type_desc =
     Tcty_constr of Path.t * Longident.t loc * core_type list
   | Tcty_signature of class_signature
   | Tcty_arrow of arg_label * core_type * class_type
+  | Tcty_open of override_flag * Path.t * Longident.t loc * Env.t * class_type
 
 and class_signature = {
     csig_self : core_type;

diff --git a/typing/typedtreeIter.ml b/typing/typedtreeIter.ml
index fd04e55210aa25d284113b7ad19ab34d81d8ef93..a3be8d3be547c3d430520015c05bab34f8ff684c 100644 (file)
--- a/typing/typedtreeIter.ml
+++ b/typing/typedtreeIter.ml
@@ -511,6 +511,9 @@ module MakeIterator(Iter : IteratorArgument) : sig
 
         | Tcl_ident (_, _, tyl) ->
             List.iter iter_core_type tyl
+
+        | Tcl_open (_, _, _, _, e) ->
+            iter_class_expr e
       end;
       Iter.leave_class_expr cexpr;
 
@@ -524,6 +527,8 @@ module MakeIterator(Iter : IteratorArgument) : sig
         | Tcty_arrow (_label, ct, cl) ->
             iter_core_type ct;
             iter_class_type cl
+        | Tcty_open (_, _, _, _, e) ->
+            iter_class_type e
       end;
       Iter.leave_class_type ct;
 
@@ -563,7 +568,7 @@ module MakeIterator(Iter : IteratorArgument) : sig
         | Ttyp_constr (_path, _, list) ->
             List.iter iter_core_type list
         | Ttyp_object (list, _o) ->
-            List.iter (fun (_, _, t) -> iter_core_type t) list
+            List.iter iter_object_field list
         | Ttyp_class (_path, _, list) ->
             List.iter iter_core_type list
         | Ttyp_alias (ct, _s) ->
@@ -588,6 +593,10 @@ module MakeIterator(Iter : IteratorArgument) : sig
           List.iter iter_core_type list
       | Tinherit ct -> iter_core_type ct
 
+    and iter_object_field ofield =
+      match ofield with
+        OTtag (_, _, ct) | OTinherit ct -> iter_core_type ct
+
     and iter_class_field cf =
       Iter.enter_class_field cf;
       begin

diff --git a/typing/typedtreeMap.ml b/typing/typedtreeMap.ml
index 58249be2a6d29df7459918c5b83e0f554c7aafc9..ccde8c03a4b561a369b65a87c1eff02a43b5a6a9 100644 (file)
--- a/typing/typedtreeMap.ml
+++ b/typing/typedtreeMap.ml
@@ -566,7 +566,9 @@ module MakeMap(Map : MapArgument) = struct
                            Some (map_class_type clty), vals, meths, concrs)
 
         | Tcl_ident (id, name, tyl) ->
-          Tcl_ident (id, name, List.map map_core_type tyl)
+            Tcl_ident (id, name, List.map map_core_type tyl)
+        | Tcl_open (ovf, p, lid, env, e) ->
+            Tcl_open (ovf, p, lid, env, map_class_expr e)
     in
     Map.leave_class_expr { cexpr with cl_desc = cl_desc }
 
@@ -579,6 +581,8 @@ module MakeMap(Map : MapArgument) = struct
           Tcty_constr (path, lid, List.map map_core_type list)
         | Tcty_arrow (label, ct, cl) ->
           Tcty_arrow (label, map_core_type ct, map_class_type cl)
+        | Tcty_open (ovf, p, lid, env, e) ->
+          Tcty_open (ovf, p, lid, env, map_class_type e)
     in
     Map.leave_class_type { ct with cltyp_desc = cltyp_desc }
 
@@ -618,7 +622,7 @@ module MakeMap(Map : MapArgument) = struct
           Ttyp_constr (path, lid, List.map map_core_type list)
         | Ttyp_object (list, o) ->
           Ttyp_object
-            (List.map (fun (s, a, t) -> (s, a, map_core_type t)) list, o)
+            (List.map map_object_field list, o)
         | Ttyp_class (path, lid, list) ->
           Ttyp_class (path, lid, List.map map_core_type list)
         | Ttyp_alias (ct, s) -> Ttyp_alias (map_core_type ct, s)
@@ -641,6 +645,12 @@ module MakeMap(Map : MapArgument) = struct
           Ttag (label, attrs, bool, List.map map_core_type list)
       | Tinherit ct -> Tinherit (map_core_type ct)
 
+  and map_object_field ofield =
+    match ofield with
+        OTtag (label, attrs, ct) ->
+          OTtag (label, attrs, map_core_type ct)
+      | OTinherit ct -> OTinherit (map_core_type ct)
+
   and map_class_field cf =
     let cf = Map.enter_class_field cf in
     let cf_desc =

diff --git a/typing/typemod.ml b/typing/typemod.ml
index cdff23eeadf04815f65caac39b0a2275b84b4a3e..84fc6490173a1751e8f926cca2c3006d1035715c 100644 (file)
--- a/typing/typemod.ml
+++ b/typing/typemod.ml
@@ -29,6 +29,10 @@ type error =
   | Structure_expected of module_type
   | With_no_component of Longident.t
   | With_mismatch of Longident.t * Includemod.error list
+  | With_makes_applicative_functor_ill_typed of
+      Longident.t * Path.t * Includemod.error list
+  | With_changes_module_alias of Longident.t * Ident.t * Path.t
+  | With_cannot_remove_constrained_type
   | Repeated_name of string * string
   | Non_generalizable of type_expr
   | Non_generalizable_class of Ident.t * class_declaration
@@ -36,7 +40,6 @@ type error =
   | Implementation_is_required of string
   | Interface_not_compiled of string
   | Not_allowed_in_functor_body
-  | With_need_typeconstr
   | Not_a_packed_module of type_expr
   | Incomplete_packed_module of type_expr
   | Scoping_pack of Longident.t * type_expr
@@ -82,14 +85,22 @@ let extract_sig_open env loc mty =
 
 (* Compute the environment after opening a module *)
 
-let type_open_ ?toplevel ovf env loc lid =
-  let path, md = Typetexp.find_module env lid.loc lid.txt in
-  let sg = extract_sig_open env lid.loc md.md_type in
-  path, Env.open_signature ~loc ?toplevel ovf path sg env
+let type_open_ ?used_slot ?toplevel ovf env loc lid =
+  let path = Typetexp.lookup_module ~load:true env lid.loc lid.txt in
+  match Env.open_signature ~loc ?used_slot ?toplevel ovf path env with
+  | Some env -> path, env
+  | None ->
+      let md = Env.find_module path env in
+      ignore (extract_sig_open env lid.loc md.md_type);
+      assert false
 
 let type_open ?toplevel env sod =
   let (path, newenv) =
-    type_open_ ?toplevel sod.popen_override env sod.popen_loc sod.popen_lid
+    Builtin_attributes.warning_scope sod.popen_attributes
+      (fun () ->
+         type_open_ ?toplevel sod.popen_override env sod.popen_loc
+           sod.popen_lid
+      )
   in
   let od =
     {
@@ -128,7 +139,7 @@ let check_type_decl env loc id row_id newdecl decl rs rem =
     | Some id -> Env.add_type ~check:false id newdecl env
   in
   let env = if rs = Trec_not then env else add_rec_types env rem in
-  Includemod.type_declarations env id newdecl decl;
+  Includemod.type_declarations ~loc env id newdecl decl;
   Typedecl.check_coherence env loc id newdecl
 
 let update_rec_next rs rem =
@@ -146,14 +157,151 @@ let make p n i =
   let open Variance in
   set May_pos p (set May_neg n (set May_weak n (set Inj i null)))
 
+let rec iter_path_apply p ~f =
+  match p with
+  | Pident _ -> ()
+  | Pdot (p, _, _) -> iter_path_apply p ~f
+  | Papply (p1, p2) ->
+     iter_path_apply p1 ~f;
+     iter_path_apply p2 ~f;
+     f p1 p2 (* after recursing, so we know both paths are well typed *)
+
+let path_is_strict_prefix =
+  let rec list_is_strict_prefix l ~prefix =
+    match l, prefix with
+    | [], [] -> false
+    | _ :: _, [] -> true
+    | [], _ :: _ -> false
+    | s1 :: t1, s2 :: t2 ->
+       String.equal s1 s2 && list_is_strict_prefix t1 ~prefix:t2
+  in
+  fun path ~prefix ->
+    match Path.flatten path, Path.flatten prefix with
+    | `Contains_apply, _ | _, `Contains_apply -> false
+    | `Ok (ident1, l1), `Ok (ident2, l2) ->
+       Ident.same ident1 ident2
+       && list_is_strict_prefix l1 ~prefix:l2
+
+let iterator_with_env env =
+  let env = ref env in
+  let super = Btype.type_iterators in
+  env, { super with
+    Btype.it_signature = (fun self sg ->
+      (* add all items to the env before recursing down, to handle recursive
+         definitions *)
+      let env_before = !env in
+      List.iter (fun i -> env := Env.add_item i !env) sg;
+      super.Btype.it_signature self sg;
+      env := env_before
+    );
+    Btype.it_module_type = (fun self -> function
+    | Mty_functor (param, mty_arg, mty_body) ->
+      may (self.Btype.it_module_type self) mty_arg;
+      let env_before = !env in
+      env := Env.add_module ~arg:true param (Btype.default_mty mty_arg) !env;
+      self.Btype.it_module_type self mty_body;
+      env := env_before;
+    | mty ->
+      super.Btype.it_module_type self mty
+    )
+  }
+
+let retype_applicative_functor_type ~loc env funct arg =
+  let mty_functor = (Env.find_module funct env).md_type in
+  let mty_arg = (Env.find_module arg env).md_type in
+  let mty_param =
+    match Env.scrape_alias env mty_functor with
+    | Mty_functor (_, Some mty_param, _) -> mty_param
+    | _ -> assert false (* could trigger due to MPR#7611 *)
+  in
+  let aliasable = not (Env.is_functor_arg arg env) in
+  ignore(Includemod.modtypes ~loc env
+           (Mtype.strengthen ~aliasable env mty_arg arg) mty_param)
+
+(* When doing a deep destructive substitution with type M.N.t := .., we change M
+   and M.N and so we have to check that uses of the modules other than just
+   extracting components from them still make sense. There are only two such
+   kinds of uses:
+   - applicative functor types: F(M).t might not be well typed anymore
+   - aliases: module A = M still makes sense but it doesn't mean the same thing
+     anymore, so it's forbidden until it's clear what we should do with it.
+   This function would be called with M.N.t and N.t to check for these uses. *)
+let check_usage_of_path_of_substituted_item paths env signature ~loc ~lid =
+  let iterator =
+    let env, super = iterator_with_env env in
+    { super with
+      Btype.it_signature_item = (fun self -> function
+      | Sig_module (id, { md_type = Mty_alias (_, aliased_path); _ }, _)
+        when List.exists
+               (fun path -> path_is_strict_prefix path ~prefix:aliased_path)
+               paths
+        ->
+         let e = With_changes_module_alias (lid.txt, id, aliased_path) in
+         raise(Error(loc, !env, e))
+      | sig_item ->
+         super.Btype.it_signature_item self sig_item
+      );
+      Btype.it_path = (fun referenced_path ->
+        iter_path_apply referenced_path ~f:(fun funct arg ->
+          if List.exists
+               (fun path -> path_is_strict_prefix path ~prefix:arg)
+               paths
+          then
+            let env = !env in
+            try retype_applicative_functor_type ~loc env funct arg
+            with Includemod.Error explanation ->
+              raise(Error(loc, env,
+                          With_makes_applicative_functor_ill_typed
+                            (lid.txt, referenced_path, explanation)))
+        )
+      );
+    }
+  in
+  iterator.Btype.it_signature iterator signature;
+  Btype.unmark_iterators.Btype.it_signature Btype.unmark_iterators signature
+
+let type_decl_is_alias sdecl = (* assuming no explicit constraint *)
+  match sdecl.ptype_manifest with
+  | Some {ptyp_desc = Ptyp_constr (lid, stl)}
+       when List.length stl = List.length sdecl.ptype_params ->
+     begin
+       match
+         List.iter2 (fun x (y, _) ->
+             match x, y with
+               {ptyp_desc=Ptyp_var sx}, {ptyp_desc=Ptyp_var sy}
+                  when sx = sy -> ()
+             | _, _ -> raise Exit)
+           stl sdecl.ptype_params;
+       with
+       | exception Exit -> None
+       | () -> Some lid
+     end
+  | _ -> None
+;;
+
+let params_are_constrained =
+  let rec loop = function
+    | [] -> false
+    | hd :: tl ->
+       match (Btype.repr hd).desc with
+       | Tvar _ -> List.memq hd tl || loop tl
+       | _ -> true
+  in
+  loop
+;;
+
 let merge_constraint initial_env loc sg constr =
   let lid =
     match constr with
-    | Pwith_type (lid, _) | Pwith_module (lid, _) -> lid
-    | Pwith_typesubst {ptype_name=s} | Pwith_modsubst (s, _) ->
-        {loc = s.loc; txt=Lident s.txt}
+    | Pwith_type (lid, _) | Pwith_module (lid, _)
+    | Pwith_typesubst (lid, _) | Pwith_modsubst (lid, _) -> lid
   in
-  let real_id = ref None in
+  let destructive_substitution =
+    match constr with
+    | Pwith_type _ | Pwith_module _ -> false
+    | Pwith_typesubst _ | Pwith_modsubst _ -> true
+  in
+  let real_ids = ref [] in
   let rec merge env sg namelist row_id =
     match (sg, namelist, constr) with
       ([], _, _) ->
@@ -208,14 +356,14 @@ let merge_constraint initial_env loc sg constr =
     | (Sig_type(id, _, _) :: rem, [s], (Pwith_type _ | Pwith_typesubst _))
       when Ident.name id = s ^ "#row" ->
         merge env rem namelist (Some id)
-    | (Sig_type(id, decl, rs) :: rem, [s], Pwith_typesubst sdecl)
+    | (Sig_type(id, decl, rs) :: rem, [s], Pwith_typesubst (_, sdecl))
       when Ident.name id = s ->
         (* Check as for a normal with constraint, but discard definition *)
         let tdecl =
           Typedecl.transl_with_constraint initial_env id None decl sdecl in
         let newdecl = tdecl.typ_type in
         check_type_decl env sdecl.ptype_loc id row_id newdecl decl rs rem;
-        real_id := Some id;
+        real_ids := [Pident id];
         (Pident id, lid, Twith_typesubst tdecl),
         update_rec_next rs rem
     | (Sig_module(id, md, rs) :: rem, [s], Pwith_module (_, lid'))
@@ -223,23 +371,26 @@ let merge_constraint initial_env loc sg constr =
         let path, md' = Typetexp.find_module initial_env loc lid'.txt in
         let md'' = {md' with md_type = Mtype.remove_aliases env md'.md_type} in
         let newmd = Mtype.strengthen_decl ~aliasable:false env md'' path in
-        ignore(Includemod.modtypes env newmd.md_type md.md_type);
+        ignore(Includemod.modtypes ~loc env newmd.md_type md.md_type);
         (Pident id, lid, Twith_module (path, lid')),
         Sig_module(id, newmd, rs) :: rem
     | (Sig_module(id, md, rs) :: rem, [s], Pwith_modsubst (_, lid'))
       when Ident.name id = s ->
         let path, md' = Typetexp.find_module initial_env loc lid'.txt in
         let newmd = Mtype.strengthen_decl ~aliasable:false env md' path in
-        ignore(Includemod.modtypes env newmd.md_type md.md_type);
-        real_id := Some id;
+        ignore(Includemod.modtypes ~loc env newmd.md_type md.md_type);
+        real_ids := [Pident id];
         (Pident id, lid, Twith_modsubst (path, lid')),
         update_rec_next rs rem
     | (Sig_module(id, md, rs) :: rem, s :: namelist, _)
       when Ident.name id = s ->
         let ((path, _path_loc, tcstr), newsg) =
           merge env (extract_sig env loc md.md_type) namelist None in
-        (path_concat id path, lid, tcstr),
-        Sig_module(id, {md with md_type=Mty_signature newsg}, rs) :: rem
+        let path = path_concat id path in
+        real_ids := path :: !real_ids;
+        let item = Sig_module(id, {md with md_type=Mty_signature newsg}, rs) in
+        (path, lid, tcstr),
+        item :: rem
     | (item :: rem, _, _) ->
         let (cstr, items) = merge (Env.add_item item env) rem namelist row_id
         in
@@ -248,39 +399,58 @@ let merge_constraint initial_env loc sg constr =
   try
     let names = Longident.flatten lid.txt in
     let (tcstr, sg) = merge initial_env sg names None in
+    if destructive_substitution then (
+      match List.rev !real_ids with
+      | [] -> assert false
+      | last :: rest ->
+        (* The last item is the one that's removed. We don't need to check how
+           it's used since it's replaced by a more specific type/module. *)
+        assert (match last with Pident _ -> true | _ -> false);
+        match rest with
+        | [] -> ()
+        | _ :: _ ->
+          check_usage_of_path_of_substituted_item
+            rest initial_env sg ~loc ~lid;
+    );
     let sg =
-    match names, constr with
-      [_], Pwith_typesubst sdecl ->
-        let id =
-          match !real_id with None -> assert false | Some id -> id in
-        let lid =
-          try match sdecl.ptype_manifest with
-          | Some {ptyp_desc = Ptyp_constr (lid, stl)}
-            when List.length stl = List.length sdecl.ptype_params ->
-              List.iter2 (fun x (y, _) ->
-                match x, y with
-                  {ptyp_desc=Ptyp_var sx}, {ptyp_desc=Ptyp_var sy}
-                    when sx = sy -> ()
-                | _, _ -> raise Exit)
-                stl sdecl.ptype_params;
-              lid
-          | _ -> raise Exit
-          with Exit ->
-            raise(Error(sdecl.ptype_loc, initial_env, With_need_typeconstr))
-        in
-        let path =
-          try Env.lookup_type lid.txt initial_env with Not_found -> assert false
-        in
-        let sub = Subst.add_type id path Subst.identity in
-        Subst.signature sub sg
-    | [_], Pwith_modsubst (_, lid) ->
-        let id =
-          match !real_id with None -> assert false | Some id -> id in
-        let path = Typetexp.lookup_module initial_env loc lid.txt in
-        let sub = Subst.add_module id path Subst.identity in
-        Subst.signature sub sg
+    match tcstr with
+    | (_, _, Twith_typesubst tdecl) ->
+       let how_to_extend_subst =
+         let sdecl =
+           match constr with
+           | Pwith_typesubst (_, sdecl) -> sdecl
+           | _ -> assert false
+         in
+         match type_decl_is_alias sdecl with
+         | Some lid ->
+            let replacement =
+              try Env.lookup_type lid.txt initial_env
+              with Not_found -> assert false
+            in
+            fun s path -> Subst.add_type_path path replacement s
+         | None ->
+            let body =
+              match tdecl.typ_type.type_manifest with
+              | None -> assert false
+              | Some x -> x
+            in
+            let params = tdecl.typ_type.type_params in
+            if params_are_constrained params
+            then raise(Error(loc, initial_env, With_cannot_remove_constrained_type));
+            fun s path -> Subst.add_type_function path ~params ~body s
+       in
+       let sub = List.fold_left how_to_extend_subst Subst.identity !real_ids in
+       Subst.signature sub sg
+    | (_, _, Twith_modsubst (real_path, _)) ->
+       let sub =
+         List.fold_left
+           (fun s path -> Subst.add_module_path path real_path s)
+           Subst.identity
+           !real_ids
+       in
+       Subst.signature sub sg
     | _ ->
-          sg
+       sg
     in
     (tcstr, sg)
   with Includemod.Error explanation ->
@@ -314,7 +484,7 @@ let rec map_rec_type_with_row_types ~rec_flag fn decls rem =
       else
         map_rec_type ~rec_flag fn decls rem
 
-(* Add type extension flags to extension contructors *)
+(* Add type extension flags to extension constructors *)
 let map_ext fn exts rem =
   match exts with
   | [] -> rem
@@ -399,7 +569,7 @@ and approx_sig env ssg =
           let smty = sincl.pincl_mod in
           let mty = approx_modtype env smty in
           let sg = Subst.signature Subst.identity
-                     (extract_sig env smty.pmty_loc mty) in
+              (extract_sig env smty.pmty_loc mty) in
           let newenv = Env.add_signature sg env in
           sg @ approx_sig newenv srem
       | Psig_class sdecls | Psig_class_type sdecls ->
@@ -423,6 +593,10 @@ and approx_modtype_info env sinfo =
    mtd_loc = sinfo.pmtd_loc;
   }
 
+let approx_modtype env smty =
+  Warnings.without_warnings
+    (fun () -> approx_modtype env smty)
+
 (* Additional validity checks on type definitions arising from
    recursive modules *)
 
@@ -527,6 +701,10 @@ let mksig desc env loc =
 (* let signature sg = List.map (fun item -> item.sig_type) sg *)
 
 let rec transl_modtype env smty =
+  Builtin_attributes.warning_scope smty.pmty_attributes
+    (fun () -> transl_modtype_aux env smty)
+
+and transl_modtype_aux env smty =
   let loc = smty.pmty_loc in
   match smty.pmty_desc with
     Pmty_ident lid ->
@@ -583,8 +761,7 @@ and transl_signature env sg =
         match item.psig_desc with
         | Psig_value sdesc ->
             let (tdesc, newenv) =
-              Builtin_attributes.with_warning_attribute sdesc.pval_attributes
-                (fun () -> Typedecl.transl_value_decl env item.psig_loc sdesc)
+              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,
@@ -626,7 +803,7 @@ and transl_signature env sg =
             check_name check_module names pmd.pmd_name;
             let id = Ident.create pmd.pmd_name.txt in
             let tmty =
-              Builtin_attributes.with_warning_attribute pmd.pmd_attributes
+              Builtin_attributes.warning_scope pmd.pmd_attributes
                 (fun () -> transl_modtype env pmd.pmd_type)
             in
             let md = {
@@ -661,8 +838,7 @@ and transl_signature env sg =
             final_env
         | Psig_modtype pmtd ->
             let newenv, mtd, sg =
-              Builtin_attributes.with_warning_attribute pmtd.pmtd_attributes
-                (fun () -> transl_modtype_decl names env pmtd)
+              transl_modtype_decl names env pmtd
             in
             let (trem, rem, final_env) = transl_sig newenv srem in
             mksig (Tsig_modtype mtd) env loc :: trem,
@@ -676,7 +852,7 @@ and transl_signature env sg =
         | Psig_include sincl ->
             let smty = sincl.pincl_mod in
             let tmty =
-              Builtin_attributes.with_warning_attribute sincl.pincl_attributes
+              Builtin_attributes.warning_scope sincl.pincl_attributes
                 (fun () -> transl_modtype env smty)
             in
             let mty = tmty.mty_type in
@@ -734,23 +910,28 @@ and transl_signature env sg =
                  classes [rem]),
             final_env
         | Psig_attribute x ->
-            Builtin_attributes.warning_attribute [x];
+            Builtin_attributes.warning_attribute x;
             let (trem,rem, final_env) = transl_sig env srem in
             mksig (Tsig_attribute x) env loc :: trem, rem, final_env
         | Psig_extension (ext, _attrs) ->
             raise (Error_forward (Builtin_attributes.error_of_extension ext))
   in
   let previous_saved_types = Cmt_format.get_saved_types () in
-  Builtin_attributes.warning_enter_scope ();
-  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
-  Builtin_attributes.warning_leave_scope ();
-  Cmt_format.set_saved_types
-    ((Cmt_format.Partial_signature sg) :: previous_saved_types);
-  sg
+  Builtin_attributes.warning_scope []
+    (fun () ->
+       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
+       Cmt_format.set_saved_types
+         ((Cmt_format.Partial_signature sg) :: previous_saved_types);
+       sg
+    )
 
-and transl_modtype_decl names env
+and transl_modtype_decl names env pmtd =
+  Builtin_attributes.warning_scope pmtd.pmtd_attributes
+    (fun () -> transl_modtype_decl_aux names env pmtd)
+
+and transl_modtype_decl_aux names env
     {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} =
   check_name check_modtype names pmtd_name;
   let tmty = Misc.may_map (transl_modtype env) pmtd_type in
@@ -786,7 +967,7 @@ and transl_recmodule_modtypes env sdecls =
     List.map2
       (fun pmd (id, id_loc, _mty) ->
         let tmty =
-          Builtin_attributes.with_warning_attribute pmd.pmd_attributes
+          Builtin_attributes.warning_scope pmd.pmd_attributes
             (fun () -> transl_modtype env_c pmd.pmd_type)
         in
         (id, id_loc, tmty))
@@ -814,7 +995,10 @@ and transl_recmodule_modtypes env sdecls =
       ids sdecls
   in
   let env0 = make_env init in
-  let dcl1 = transition env0 init in
+  let dcl1 =
+    Warnings.without_warnings
+      (fun () -> transition env0 init)
+  in
   let env1 = make_env2 dcl1 in
   check_recmod_typedecls env1 sdecls dcl1;
   let dcl2 = transition env1 dcl1 in
@@ -968,7 +1152,7 @@ let check_recmodule_inclusion env bindings =
         and mty_actual' = subst_and_strengthen env s id mty_actual in
         let coercion =
           try
-            Includemod.modtypes env mty_actual' mty_decl'
+            Includemod.modtypes ~loc:modl.mod_loc env mty_actual' mty_decl'
           with Includemod.Error msg ->
             raise(Error(modl.mod_loc, env, Not_included msg)) in
         let modl' =
@@ -1043,7 +1227,7 @@ let package_subtype env p1 nl1 tl1 p2 nl2 tl2 =
     modtype_of_package env Location.none p nl tl
   in
   let mty1 = mkmty p1 nl1 tl1 and mty2 = mkmty p2 nl2 tl2 in
-  try Includemod.modtypes env mty1 mty2 = Tcoerce_none
+  try Includemod.modtypes ~loc:Location.none env mty1 mty2 = Tcoerce_none
   with Includemod.Error _msg -> false
     (* raise(Error(Location.none, env, Not_included msg)) *)
 
@@ -1052,7 +1236,7 @@ let () = Ctype.package_subtype := package_subtype
 let wrap_constraint env arg mty explicit =
   let coercion =
     try
-      Includemod.modtypes env arg.mod_type mty
+      Includemod.modtypes ~loc:arg.mod_loc env arg.mod_type mty
     with Includemod.Error msg ->
       raise(Error(arg.mod_loc, env, Not_included msg)) in
   { mod_desc = Tmod_constraint(arg, mty, explicit, coercion);
@@ -1064,6 +1248,10 @@ let wrap_constraint env arg mty explicit =
 (* Type a module value expression *)
 
 let rec type_module ?(alias=false) sttn funct_body anchor env smod =
+  Builtin_attributes.warning_scope smod.pmod_attributes
+    (fun () -> type_module_aux ~alias sttn funct_body anchor env smod)
+
+and type_module_aux ~alias sttn funct_body anchor env smod =
   match smod.pmod_desc with
     Pmod_ident lid ->
       let path =
@@ -1138,7 +1326,7 @@ let rec type_module ?(alias=false) sttn funct_body anchor env smod =
           end;
           let coercion =
             try
-              Includemod.modtypes env arg.mod_type mty_param
+              Includemod.modtypes ~loc:sarg.pmod_loc env arg.mod_type mty_param
             with Includemod.Error msg ->
               raise(Error(sarg.pmod_loc, env, Not_included msg)) in
           let mty_appl =
@@ -1216,7 +1404,7 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
     match desc with
     | Pstr_eval (sexpr, attrs) ->
         let expr =
-          Builtin_attributes.with_warning_attribute attrs
+          Builtin_attributes.warning_scope attrs
             (fun () -> Typecore.type_expression env sexpr)
         in
         Tstr_eval (expr, attrs), [], env
@@ -1236,6 +1424,9 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
         in
         let (defs, newenv) =
           Typecore.type_binding env rec_flag sdefs scope in
+        let () = if rec_flag = Recursive then
+          Typecore.check_recursive_bindings env defs
+        in
         (* Note: Env.find_value does not trigger the value_used event. Values
            will be marked as being used during the signature inclusion test. *)
         Tstr_value(rec_flag, defs),
@@ -1279,7 +1470,7 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
         check_name check_module names name;
         let id = Ident.create name.txt in (* create early for PR#6752 *)
         let modl =
-          Builtin_attributes.with_warning_attribute attrs
+          Builtin_attributes.warning_scope attrs
             (fun () ->
                type_module ~alias:true true funct_body
                  (anchor_submodule name.txt anchor) env smodl
@@ -1332,7 +1523,7 @@ 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 =
-                 Builtin_attributes.with_warning_attribute attrs
+                 Builtin_attributes.warning_scope attrs
                    (fun () ->
                       type_module true funct_body (anchor_recmodule id)
                         newenv smodl
@@ -1371,8 +1562,7 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
     | Pstr_modtype pmtd ->
         (* check that it is non-abstract *)
         let newenv, mtd, sg =
-          Builtin_attributes.with_warning_attribute pmtd.pmtd_attributes
-            (fun () -> transl_modtype_decl names env pmtd)
+          transl_modtype_decl names env pmtd
         in
         Tstr_modtype mtd, [sg], newenv
     | Pstr_open sod ->
@@ -1432,7 +1622,7 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
     | Pstr_include sincl ->
         let smodl = sincl.pincl_mod in
         let modl =
-          Builtin_attributes.with_warning_attribute sincl.pincl_attributes
+          Builtin_attributes.warning_scope sincl.pincl_attributes
             (fun () -> type_module true funct_body None env smodl)
         in
         (* Rename all identifiers bound by this signature to avoid clashes *)
@@ -1451,7 +1641,7 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
     | Pstr_extension (ext, _attrs) ->
         raise (Error_forward (Builtin_attributes.error_of_extension ext))
     | Pstr_attribute x ->
-        Builtin_attributes.warning_attribute [x];
+        Builtin_attributes.warning_attribute x;
         Tstr_attribute x, [], env
   in
   let rec type_struct env sstr =
@@ -1471,20 +1661,18 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
     (* moved to genannot *)
     List.iter (function {pstr_loc = l} -> Stypes.record_phrase l) sstr;
   let previous_saved_types = Cmt_format.get_saved_types () in
-  if not toplevel then Builtin_attributes.warning_enter_scope ();
-  let (items, sg, final_env) = type_struct env sstr in
-  let str = { str_items = items; str_type = sg; str_final_env = final_env } in
-  if not toplevel then Builtin_attributes.warning_leave_scope ();
-  Cmt_format.set_saved_types
-    (Cmt_format.Partial_structure str :: previous_saved_types);
-  str, sg, final_env
+  let run () =
+    let (items, sg, final_env) = type_struct env sstr in
+    let str = { str_items = items; str_type = sg; str_final_env = final_env } in
+    Cmt_format.set_saved_types
+      (Cmt_format.Partial_structure str :: previous_saved_types);
+    str, sg, final_env
+  in
+  if toplevel then run ()
+  else Builtin_attributes.warning_scope [] run
 
 let type_toplevel_phrase env s =
   Env.reset_required_globals ();
-  begin
-    let iter = Builtin_attributes.emit_external_warnings in
-    iter.Ast_iterator.structure iter s
-  end;
   let (str, sg, env) =
     type_structure ~toplevel:true false None env s Location.none in
   let (str, _coerce) = ImplementationHooks.apply_hooks
@@ -1561,6 +1749,8 @@ let type_package env m p nl =
   let tl' =
     List.map
       (fun name -> Btype.newgenty (Tconstr (mkpath mp name,[],ref Mnil)))
+      (* beware of interactions with Printtyp and short-path:
+         mp.name may have an arity > 0, cf. PR#7534 *)
       nl in
   (* go back to original level *)
   Ctype.end_def ();
@@ -1592,15 +1782,13 @@ let type_implementation sourcefile outputprefix modulename initial_env ast =
   try
   Typecore.reset_delayed_checks ();
   Env.reset_required_globals ();
-  begin
-    let iter = Builtin_attributes.emit_external_warnings in
-    iter.Ast_iterator.structure iter ast
-  end;
-
+  if !Clflags.print_types then (* #7656 *)
+    Warnings.parse_options false "-32-34-37-38-60";
   let (str, sg, finalenv) =
     type_structure initial_env ast (Location.in_file sourcefile) in
   let simple_sg = simplify_signature sg in
   if !Clflags.print_types then begin
+    Typecore.force_delayed_checks ();
     Printtyp.wrap_printing_env initial_env
       (fun () -> fprintf std_formatter "%a@." Printtyp.signature simple_sg);
     (str, Tcoerce_none)   (* result is ignored by Compile.implementation *)
@@ -1625,11 +1813,11 @@ 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 sg;
-      normalize_signature finalenv simple_sg;
       let coercion =
         Includemod.compunit initial_env sourcefile sg
                             "(inferred signature)" simple_sg in
+      check_nongen_schemes finalenv simple_sg;
+      normalize_signature finalenv simple_sg;
       Typecore.force_delayed_checks ();
       (* See comment above. Here the target signature contains all
          the value being exported. We can still capture unused
@@ -1664,10 +1852,6 @@ let save_signature modname tsg outputprefix source_file initial_env cmi =
     (Cmt_format.Interface tsg) (Some source_file) initial_env (Some cmi)
 
 let type_interface sourcefile env ast =
-  begin
-    let iter = Builtin_attributes.emit_external_warnings in
-    iter.Ast_iterator.signature iter ast
-  end;
   InterfaceHooks.apply_hooks { Misc.sourcefile } (transl_signature env ast)
 
 (* "Packaging" of several compilation units into one unit
@@ -1767,6 +1951,24 @@ let report_error ppf = function
              in the constrained signature:@]@ \
            %a@]"
         longident lid Includemod.report_error explanation
+  | With_makes_applicative_functor_ill_typed(lid, path, explanation) ->
+      fprintf ppf
+        "@[<v>\
+           @[This `with' constraint on %a makes the applicative functor @ \
+             type %s ill-typed in the constrained signature:@]@ \
+           %a@]"
+        longident lid (Path.name path) Includemod.report_error explanation
+  | With_changes_module_alias(lid, id, path) ->
+      fprintf ppf
+        "@[<v>\
+           @[This `with' constraint on %a changes %s, which is aliased @ \
+             in the constrained signature (as %s)@].@]"
+        longident lid (Path.name path) (Ident.name id)
+  | With_cannot_remove_constrained_type ->
+      fprintf ppf
+        "@[<v>Destructive substitutions are not supported for constrained @ \
+              types (other than when replacing a type constructor with @ \
+              a type constructor with the same arguments).@]"
   | Repeated_name(kind, name) ->
       fprintf ppf
         "@[Multiple definition of the %s name %s.@ \
@@ -1797,9 +1999,6 @@ let report_error ppf = function
       fprintf ppf
         "@[This expression creates fresh types.@ %s@]"
         "It is not allowed inside applicative functors."
-  | With_need_typeconstr ->
-      fprintf ppf
-        "Only type constructors with identical parameters can be substituted."
   | Not_a_packed_module ty ->
       fprintf ppf
         "This expression is not a packed module. It has type@ %a"

diff --git a/typing/typemod.mli b/typing/typemod.mli
index fab7cdae531741bfe2399bef4de690dbe7d206fc..fb767db2e39d77afd9f4b05c32c9d5f3783ed7df 100644 (file)
--- a/typing/typemod.mli
+++ b/typing/typemod.mli
@@ -13,7 +13,7 @@
 (*                                                                        *)
 (**************************************************************************)
 
-(* Type-checking of the module language *)
+(** Type-checking of the module language and typed ast plugin hooks *)
 
 open Types
 open Format
@@ -36,7 +36,7 @@ val transl_signature:
 val check_nongen_schemes:
         Env.t -> Types.signature -> unit
 val type_open_:
-        ?toplevel:bool -> Asttypes.override_flag ->
+        ?used_slot:bool ref -> ?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 ->
@@ -60,6 +60,10 @@ type error =
   | Structure_expected of module_type
   | With_no_component of Longident.t
   | With_mismatch of Longident.t * Includemod.error list
+  | With_makes_applicative_functor_ill_typed of
+      Longident.t * Path.t * Includemod.error list
+  | With_changes_module_alias of Longident.t * Ident.t * Path.t
+  | With_cannot_remove_constrained_type
   | Repeated_name of string * string
   | Non_generalizable of type_expr
   | Non_generalizable_class of Ident.t * class_declaration
@@ -67,7 +71,6 @@ type error =
   | Implementation_is_required of string
   | Interface_not_compiled of string
   | Not_allowed_in_functor_body
-  | With_need_typeconstr
   | Not_a_packed_module of type_expr
   | Incomplete_packed_module of type_expr
   | Scoping_pack of Longident.t * type_expr

diff --git a/typing/typeopt.ml b/typing/typeopt.ml
new file mode 100644 (file)
index 0000000..1d3101e
--- /dev/null
+++ b/typing/typeopt.ml
@@ -0,0 +1,204 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, 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 GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Auxiliaries for type-based optimizations, e.g. array kinds *)
+
+open Path
+open Types
+open Asttypes
+open Typedtree
+open Lambda
+
+let scrape_ty env ty =
+  let ty = Ctype.expand_head_opt env (Ctype.correct_levels ty) in
+  match ty.desc with
+  | Tconstr (p, _, _) ->
+      begin match Env.find_type p env with
+      | {type_unboxed = {unboxed = true; _}; _} ->
+        begin match Typedecl.get_unboxed_type_representation env ty with
+        | None -> ty
+        | Some ty2 -> ty2
+        end
+      | _ -> ty
+      | exception Not_found -> ty
+      end
+  | _ -> ty
+
+let scrape env ty =
+  (scrape_ty env ty).desc
+
+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_type env ty =
+  if Ctype.maybe_pointer_type env ty then
+    Pointer
+  else
+    Immediate
+
+let maybe_pointer exp = maybe_pointer_type exp.exp_env exp.exp_type
+
+type classification =
+  | Int
+  | Float
+  | Lazy
+  | Addr  (* anything except a float or a lazy *)
+  | Any
+
+let classify env ty =
+  let ty = scrape_ty env ty in
+  if maybe_pointer_type env ty = Immediate then Int
+  else match ty.desc with
+  | Tvar _ | Tunivar _ ->
+      Any
+  | Tconstr (p, _args, _abbrev) ->
+      if Path.same p Predef.path_float then Float
+      else if Path.same p Predef.path_lazy_t then Lazy
+      else if Path.same p Predef.path_string
+           || Path.same p Predef.path_bytes
+           || Path.same p Predef.path_array
+           || Path.same p Predef.path_nativeint
+           || Path.same p Predef.path_int32
+           || Path.same p Predef.path_int64 then Addr
+      else begin
+        try
+          match (Env.find_type p env).type_kind with
+          | Type_abstract ->
+              Any
+          | Type_record _ | Type_variant _ | Type_open ->
+              Addr
+        with Not_found ->
+          (* This can happen due to e.g. missing -I options,
+             causing some .cmi files to be unavailable.
+             Maybe we should emit a warning. *)
+          Any
+      end
+  | Tarrow _ | Ttuple _ | Tpackage _ | Tobject _ | Tnil | Tvariant _ ->
+      Addr
+  | Tlink _ | Tsubst _ | Tpoly _ | Tfield _ ->
+      assert false
+
+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 ->
+      begin match classify env elt_ty with
+      | Any -> if Config.flat_float_array then Pgenarray else Paddrarray
+      | Float -> if Config.flat_float_array then Pfloatarray else Paddrarray
+      | Addr | Lazy -> Paddrarray
+      | Int -> Pintarray
+      end
+  | Tconstr(p, [], _) | Tpoly({desc = Tconstr(p, [], _)}, _)
+    when Path.same p Predef.path_floatarray ->
+      Pfloatarray
+  | _ ->
+      (* This can happen with e.g. Obj.field *)
+      Pgenarray
+
+let array_kind exp = array_type_kind exp.exp_env exp.exp_type
+
+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
+  | Tconstr(Pdot(Pident mod_id, type_name, _), [], _)
+    when Ident.name mod_id = "CamlinternalBigarray" ->
+      begin try List.assoc type_name tbl with Not_found -> dfl end
+  | _ ->
+      dfl
+
+let kind_table =
+  ["float32_elt", Pbigarray_float32;
+   "float64_elt", Pbigarray_float64;
+   "int8_signed_elt", Pbigarray_sint8;
+   "int8_unsigned_elt", Pbigarray_uint8;
+   "int16_signed_elt", Pbigarray_sint16;
+   "int16_unsigned_elt", Pbigarray_uint16;
+   "int32_elt", Pbigarray_int32;
+   "int64_elt", Pbigarray_int64;
+   "int_elt", Pbigarray_caml_int;
+   "nativeint_elt", Pbigarray_native_int;
+   "complex32_elt", Pbigarray_complex32;
+   "complex64_elt", Pbigarray_complex64]
+
+let layout_table =
+  ["c_layout", Pbigarray_c_layout;
+   "fortran_layout", Pbigarray_fortran_layout]
+
+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 env elt_type kind_table Pbigarray_unknown,
+       bigarray_decode_type env layout_type layout_table
+                            Pbigarray_unknown_layout)
+  | _ ->
+      (Pbigarray_unknown, Pbigarray_unknown_layout)
+
+let value_kind env ty =
+  match scrape env ty with
+  | Tconstr(p, _, _) when Path.same p Predef.path_int ->
+      Pintval
+  | Tconstr(p, _, _) when Path.same p Predef.path_char ->
+      Pintval
+  | Tconstr(p, _, _) when Path.same p Predef.path_float ->
+      Pfloatval
+  | Tconstr(p, _, _) when Path.same p Predef.path_int32 ->
+      Pboxedintval Pint32
+  | Tconstr(p, _, _) when Path.same p Predef.path_int64 ->
+      Pboxedintval Pint64
+  | Tconstr(p, _, _) when Path.same p Predef.path_nativeint ->
+      Pboxedintval Pnativeint
+  | _ ->
+      Pgenval
+
+
+(** Whether a forward block is needed for a lazy thunk on a value, i.e.
+    if the value can be represented as a float/forward/lazy *)
+let lazy_val_requires_forward env ty =
+  match classify env ty with
+  | Any | Lazy -> true
+  | Float -> Config.flat_float_array
+  | Addr | Int -> false
+
+(** The compilation of the expression [lazy e] depends on the form of e:
+    constants, floats and identifiers are optimized.  The optimization must be
+    taken into account when determining whether a recursive binding is safe. *)
+let classify_lazy_argument : Typedtree.expression ->
+                             [`Constant_or_function
+                             |`Float
+                             |`Identifier of [`Forward_value|`Other]
+                             |`Other] =
+  fun e -> match e.exp_desc with
+    | Texp_constant
+        ( Const_int _ | Const_char _ | Const_string _
+        | Const_int32 _ | Const_int64 _ | Const_nativeint _ )
+    | Texp_function _
+    | Texp_construct (_, {cstr_arity = 0}, _) ->
+       `Constant_or_function
+    | Texp_constant(Const_float _) ->
+       `Float
+    | Texp_ident _ when lazy_val_requires_forward e.exp_env e.exp_type ->
+       `Identifier `Forward_value
+    | Texp_ident _ ->
+       `Identifier `Other
+    | _ ->
+       `Other

diff --git a/typing/typeopt.mli b/typing/typeopt.mli
new file mode 100644 (file)
index 0000000..299e822
--- /dev/null
+++ b/typing/typeopt.mli
@@ -0,0 +1,37 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, 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 GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* 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 maybe_pointer_type : Env.t -> Types.type_expr
+  -> Lambda.immediate_or_pointer
+val maybe_pointer : Typedtree.expression -> Lambda.immediate_or_pointer
+
+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_type_kind_and_layout :
+      Env.t -> Types.type_expr -> Lambda.bigarray_kind * Lambda.bigarray_layout
+val value_kind : Env.t -> Types.type_expr -> Lambda.value_kind
+
+val classify_lazy_argument : Typedtree.expression ->
+                             [ `Constant_or_function
+                             | `Float
+                             | `Identifier of [`Forward_value | `Other]
+                             | `Other]

diff --git a/typing/types.ml b/typing/types.ml
index 0e85644f0e53214da7f5a46c048c0928f8a936db..51d58a9a8bd2afbce001bea77600aed751545bd5 100644 (file)
--- a/typing/types.ml
+++ b/typing/types.ml
@@ -279,7 +279,7 @@ and module_declaration =
 
 and modtype_declaration =
   {
-    mtd_type: module_type option;  (* Nonte: abstract *)
+    mtd_type: module_type option;  (* Note: abstract *)
     mtd_attributes: Parsetree.attributes;
     mtd_loc: Location.t;
   }
@@ -322,6 +322,15 @@ and constructor_tag =
   | Cstr_extension of Path.t * bool     (* Extension constructor
                                            true if a constant false if a block*)
 
+let equal_tag t1 t2 = 
+  match (t1, t2) with
+  | Cstr_constant i1, Cstr_constant i2 -> i2 = i1
+  | Cstr_block i1, Cstr_block i2 -> i2 = i1
+  | Cstr_unboxed, Cstr_unboxed -> true
+  | Cstr_extension (path1, b1), Cstr_extension (path2, b2) -> 
+      Path.same path1 path2 && b1 = b2
+  | (Cstr_constant _|Cstr_block _|Cstr_unboxed|Cstr_extension _), _ -> false
+
 type label_description =
   { lbl_name: string;                   (* Short name *)
     lbl_res: type_expr;                 (* Type of the result *)

diff --git a/typing/types.mli b/typing/types.mli
index 2dc1481ee02d092f260a1d7061b4f1e141834233..633aa31d1b4c3033224a347c215819c8c346b35c 100644 (file)
--- a/typing/types.mli
+++ b/typing/types.mli
@@ -123,7 +123,7 @@ and type_desc =
   | Tpoly of type_expr * type_expr list
   (** [Tpoly (ty,tyl)] ==> ['a1... 'an. ty],
       where 'a1 ... 'an are names given to types in tyl
-      and occurences of those types in ty. *)
+      and occurrences of those types in ty. *)
 
   | Tpackage of Path.t * Longident.t list * type_expr list
   (** Type of a first-class module (a.k.a package). *)
@@ -186,7 +186,7 @@ and row_field =
     removing abbreviations.
 *)
 and abbrev_memo =
-  | Mnil (** No known abbrevation *)
+  | Mnil (** No known abbreviation *)
 
   | Mcons of private_flag * Path.t * type_expr * type_expr * abbrev_memo
   (** Found one abbreviation.
@@ -266,7 +266,7 @@ and value_kind =
 module Variance : sig
   type t
   type f = May_pos | May_neg | May_weak | Inj | Pos | Neg | Inv
-  val null : t                          (* no occurence *)
+  val null : t                          (* no occurrence *)
   val full : t                          (* strictly invariant *)
   val covariant : t                     (* strictly covariant *)
   val may_inv : t                       (* maybe invariant *)
@@ -473,6 +473,8 @@ and constructor_tag =
   | Cstr_extension of Path.t * bool     (* Extension constructor
                                            true if a constant false if a block*)
 
+val equal_tag :  constructor_tag -> constructor_tag -> bool
+
 type label_description =
   { lbl_name: string;                   (* Short name *)
     lbl_res: type_expr;                 (* Type of the result *)

diff --git a/typing/typetexp.ml b/typing/typetexp.ml
index f37a5c133e54cdef93c21c3df900cd05f74bb9b6..5347c42da223cc2c5db27c3d60f76409450aefbd 100644 (file)
--- a/typing/typetexp.ml
+++ b/typing/typetexp.ml
@@ -44,7 +44,7 @@ type error =
   | Invalid_variable_name of string
   | Cannot_quantify of string * type_expr
   | Multiple_constraints_on_type of Longident.t
-  | Repeated_method_label of string
+  | Method_mismatch of string * type_expr * type_expr
   | Unbound_value of Longident.t
   | Unbound_constructor of Longident.t
   | Unbound_label of Longident.t
@@ -57,6 +57,8 @@ type error =
   | Access_functor_as_structure of Longident.t
   | Apply_structure_as_functor of Longident.t
   | Cannot_scrape_alias of Longident.t * Path.t
+  | Opened_object of Path.t option
+  | Not_an_object of type_expr
 
 exception Error of Location.t * Env.t * error
 exception Error_forward of Location.error
@@ -283,6 +285,13 @@ let transl_type_param env styp =
           ctyp_loc = loc; ctyp_attributes = styp.ptyp_attributes; }
   | _ -> assert false
 
+let transl_type_param env styp =
+  (* Currently useless, since type parameters cannot hold attributes
+     (but this could easily be lifted in the future). *)
+  Builtin_attributes.warning_scope styp.ptyp_attributes
+    (fun () -> transl_type_param env styp)
+
+
 let new_pre_univar ?name () =
   let v = newvar ?name () in pre_univars := v :: !pre_univars; v
 
@@ -293,6 +302,10 @@ let rec swap_list = function
 type policy = Fixed | Extensible | Univars
 
 let rec transl_type env policy styp =
+  Builtin_attributes.warning_scope styp.ptyp_attributes
+    (fun () -> transl_type_aux env policy styp)
+
+and transl_type_aux env policy styp =
   let loc = styp.ptyp_loc in
   let ctyp ctyp_desc ctyp_type =
     { ctyp_desc; ctyp_type; ctyp_env = env;
@@ -373,12 +386,8 @@ let rec transl_type env policy styp =
       end;
       ctyp (Ttyp_constr (path, lid, args)) constr
   | Ptyp_object (fields, o) ->
-      let fields =
-        List.map (fun (s, a, t) -> (s.txt, a, transl_poly_type env policy t))
-          fields
-      in
-      let ty = newobj (transl_fields loc env policy [] o fields) in
-      ctyp (Ttyp_object (fields, o)) ty
+      let ty, fields = transl_fields env policy o fields in
+      ctyp (Ttyp_object (fields, o)) (newobj ty)
   | Ptyp_class(lid, stl) ->
       let (path, decl, _is_variant) =
         try
@@ -394,8 +403,8 @@ let rec transl_type env policy styp =
                     check (Env.find_type path env)
                 | _ -> raise Not_found
           in check decl;
-          Location.prerr_warning styp.ptyp_loc
-            (Warnings.Deprecated "old syntax for polymorphic variant type");
+          Location.deprecated styp.ptyp_loc
+            "old syntax for polymorphic variant type";
           (path, decl,true)
         with Not_found -> try
           let lid2 =
@@ -520,19 +529,23 @@ let rec transl_type env policy styp =
       let add_field = function
           Rtag (l, attrs, c, stl) ->
             name := None;
-            let tl = List.map (transl_type env policy) stl in
+            let tl =
+              Builtin_attributes.warning_scope attrs
+                (fun () -> List.map (transl_type env policy) stl)
+            in
             let f = match present with
-              Some present when not (List.mem l present) ->
+              Some present when not (List.mem l.txt present) ->
                 let ty_tl = List.map (fun cty -> cty.ctyp_type) tl in
                 Reither(c, ty_tl, false, ref None)
             | _ ->
                 if List.length stl > 1 || c && stl <> [] then
-                  raise(Error(styp.ptyp_loc, env, Present_has_conjunction l));
+                  raise(Error(styp.ptyp_loc, env,
+                              Present_has_conjunction l.txt));
                 match tl with [] -> Rpresent None
                 | st :: _ ->
                       Rpresent (Some st.ctyp_type)
             in
-            add_typed_field styp.ptyp_loc l f;
+            add_typed_field styp.ptyp_loc l.txt f;
               Ttag (l,attrs,c,tl)
         | Rinherit sty ->
             let cty = transl_type env policy sty in
@@ -651,18 +664,63 @@ let rec transl_type env policy styp =
 and transl_poly_type env policy t =
   transl_type env policy (Ast_helper.Typ.force_poly t)
 
-and transl_fields loc env policy seen o =
-  function
-    [] ->
-      begin match o, policy with
-      | Closed, _ -> newty Tnil
-      | Open, Univars -> new_pre_univar ()
-      | Open, _ -> newvar ()
+and transl_fields env policy o fields =
+  let hfields = Hashtbl.create 17 in
+  let add_typed_field loc l ty =
+    try
+      let ty' = Hashtbl.find hfields l in
+      if equal env false [ty] [ty'] then () else
+        try unify env ty ty'
+        with Unify _trace ->
+          raise(Error(loc, env, Method_mismatch (l, ty, ty')))
+    with Not_found ->
+      Hashtbl.add hfields l ty in
+  let add_field = function
+    | Otag (s, a, ty1) -> begin
+        let ty1 =
+          Builtin_attributes.warning_scope a
+            (fun () -> transl_poly_type env policy ty1)
+        in
+        let field = OTtag (s, a, ty1) in
+        add_typed_field ty1.ctyp_loc s.txt ty1.ctyp_type;
+        field
       end
-  | (s, _attrs, ty1) :: l ->
-      if List.mem s seen then raise (Error (loc, env, Repeated_method_label s));
-      let ty2 = transl_fields loc env policy (s :: seen) o l in
-      newty (Tfield (s, Fpresent, ty1.ctyp_type, ty2))
+    | Oinherit sty -> begin
+        let cty = transl_type env policy sty in
+        let nm =
+          match repr cty.ctyp_type with
+            {desc=Tconstr(p, _, _)} -> Some p
+          | _                        -> None in
+        let t = expand_head env cty.ctyp_type in
+        match t, nm with
+          {desc=Tobject ({desc=(Tfield _ | Tnil) as tf}, _)}, _ -> begin
+            if opened_object t then
+              raise (Error (sty.ptyp_loc, env, Opened_object nm));
+            let rec iter_add = function
+              | Tfield (s, _k, ty1, ty2) -> begin
+                  add_typed_field sty.ptyp_loc s ty1;
+                  iter_add ty2.desc
+                end
+              | Tnil -> ()
+              | _ -> assert false in
+            iter_add tf;
+            OTinherit cty
+            end
+        | {desc=Tvar _}, Some p ->
+            raise (Error (sty.ptyp_loc, env, Unbound_type_constructor_2 p))
+        | _ -> raise (Error (sty.ptyp_loc, env, Not_an_object t))
+      end in
+  let object_fields = List.map add_field fields in
+  let fields = Hashtbl.fold (fun s ty l -> (s, ty) :: l) hfields [] in
+  let ty_init =
+     match o, policy with
+     | Closed, _ -> newty Tnil
+     | Open, Univars -> new_pre_univar ()
+     | Open, _ -> newvar () in
+  let ty = List.fold_left (fun ty (s, ty') ->
+      newty (Tfield (s, Fpresent, ty', ty))) ty_init fields in
+  ty, object_fields
+
 
 (* Make the rows "fixed" in this type, to make universal check easier *)
 let rec make_fixed_univars ty =
@@ -845,7 +903,8 @@ let report_error env ppf = function
           Printtyp.type_expr ty')
   | Not_a_variant ty ->
       Printtyp.reset_and_mark_loops ty;
-      fprintf ppf "@[The type %a@ is not a polymorphic variant type@]"
+      fprintf ppf
+        "@[The type %a@ does not expand to a polymorphic variant type@]"
         Printtyp.type_expr ty;
       begin match ty.desc with
         | Tvar (Some s) ->
@@ -868,9 +927,11 @@ let report_error env ppf = function
          else "it is not a variable")
   | Multiple_constraints_on_type s ->
       fprintf ppf "Multiple constraints for type %a" longident s
-  | Repeated_method_label s ->
-      fprintf ppf "@[This is the second method `%s' of this object type.@ %s@]"
-        s "Multiple occurrences are not allowed."
+  | Method_mismatch (l, ty, ty') ->
+      wrap_printing_env env (fun ()  ->
+        Printtyp.reset_and_mark_loops_list [ty; ty'];
+        fprintf ppf "@[<hov>Method '%s' has type %a,@ which should be %a@]"
+          l Printtyp.type_expr ty Printtyp.type_expr ty')
   | Unbound_value lid ->
       fprintf ppf "Unbound value %a" longident lid;
       spellcheck ppf fold_values env lid;
@@ -904,6 +965,16 @@ let report_error env ppf = function
       fprintf ppf
         "The module %a is an alias for module %a, which is missing"
         longident lid path p
+  | Opened_object nm ->
+      fprintf ppf
+        "Illegal open object type%a"
+        (fun ppf -> function
+             Some p -> fprintf ppf "@ %a" path p
+           | None -> fprintf ppf "") nm
+  | Not_an_object ty ->
+      Printtyp.reset_and_mark_loops ty;
+      fprintf ppf "@[The type %a@ is not an object type@]"
+        Printtyp.type_expr ty
 
 let () =
   Location.register_error_of_exn

diff --git a/typing/typetexp.mli b/typing/typetexp.mli
index 20ca9cb4e88ae3924f2da7e44dff4fe6e438c76b..c6bc5e43027c34598e37389a27045e9d66f31137 100644 (file)
--- a/typing/typetexp.mli
+++ b/typing/typetexp.mli
@@ -56,7 +56,7 @@ type error =
   | Invalid_variable_name of string
   | Cannot_quantify of string * type_expr
   | Multiple_constraints_on_type of Longident.t
-  | Repeated_method_label of string
+  | Method_mismatch of string * type_expr * type_expr
   | Unbound_value of Longident.t
   | Unbound_constructor of Longident.t
   | Unbound_label of Longident.t
@@ -69,6 +69,8 @@ type error =
   | Access_functor_as_structure of Longident.t
   | Apply_structure_as_functor of Longident.t
   | Cannot_scrape_alias of Longident.t * Path.t
+  | Opened_object of Path.t option
+  | Not_an_object of type_expr
 
 exception Error of Location.t * Env.t * error
 

diff --git a/typing/untypeast.ml b/typing/untypeast.ml
index 0cb58f484a68d6c200d5f29225384567ca38e2e1..e4ec51ce45b88b9a136f56ec8b3cc518991239d6 100644 (file)
--- a/typing/untypeast.ml
+++ b/typing/untypeast.ml
@@ -54,6 +54,7 @@ type mapper = {
   open_description: mapper -> T.open_description -> open_description;
   pat: mapper -> T.pattern -> pattern;
   row_field: mapper -> T.row_field -> row_field;
+  object_field: mapper -> T.object_field -> object_field;
   signature: mapper -> T.signature -> signature;
   signature_item: mapper -> T.signature_item -> signature_item;
   structure: mapper -> T.structure -> structure;
@@ -186,7 +187,7 @@ let value_description sub v =
     (sub.typ sub v.val_desc)
 
 let module_binding sub mb =
-  let loc = sub.location sub mb.mb_loc; in
+  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)
@@ -195,7 +196,7 @@ let module_binding sub mb =
 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 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)
@@ -222,7 +223,7 @@ let constructor_arguments sub = function
    | 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 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)
@@ -230,7 +231,7 @@ let constructor_declaration sub cd =
     (map_loc sub cd.cd_name)
 
 let label_declaration sub ld =
-  let loc = sub.location sub ld.ld_loc; in
+  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
@@ -246,7 +247,7 @@ let type_extension sub tyext =
     (List.map (sub.extension_constructor sub) tyext.tyext_constructors)
 
 let extension_constructor sub ext =
-  let loc = sub.location sub ext.ext_loc; in
+  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)
@@ -258,7 +259,7 @@ let extension_constructor sub ext =
     )
 
 let pattern sub pat =
-  let loc = sub.location sub pat.pat_loc; in
+  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 =
@@ -318,7 +319,7 @@ let pattern sub pat =
   Pat.mk ~loc ~attrs desc
 
 let exp_extra sub (extra, loc, attrs) sexp =
-  let loc = sub.location sub loc; in
+  let loc = sub.location sub loc in
   let attrs = sub.attributes sub attrs in
   let desc =
     match extra with
@@ -345,14 +346,14 @@ let case sub {c_lhs; c_guard; c_rhs} =
   }
 
 let value_binding sub vb =
-  let loc = sub.location sub vb.vb_loc; in
+  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 loc = sub.location sub exp.exp_loc in
   let attrs = sub.attributes sub exp.exp_attributes in
   let desc =
     match exp.exp_desc with
@@ -480,7 +481,7 @@ let package_type sub pack =
         (s, sub.typ sub ct)) pack.pack_fields)
 
 let module_type_declaration sub mtd =
-  let loc = sub.location sub mtd.mtd_loc; in
+  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)
@@ -490,7 +491,7 @@ 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 loc = sub.location sub item.sig_loc in
   let desc =
     match item.sig_desc with
       Tsig_value v ->
@@ -521,14 +522,14 @@ let signature_item sub item =
   Sig.mk ~loc desc
 
 let module_declaration sub md =
-  let loc = sub.location sub md.md_loc; in
+  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 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)
@@ -537,7 +538,7 @@ 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 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
@@ -550,7 +551,7 @@ 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 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)
@@ -573,14 +574,13 @@ let with_constraint sub (_path, lid, cstr) =
       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_typesubst decl ->
+     Pwith_typesubst (map_loc sub lid, 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)
+      Pwith_modsubst (map_loc sub lid, map_loc sub lid2)
 
 let module_expr sub mexpr =
-  let loc = sub.location sub mexpr.mod_loc; in
+  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, _ ) ->
@@ -606,7 +606,7 @@ let module_expr sub mexpr =
         Mod.mk ~loc ~attrs desc
 
 let class_expr sub cexpr =
-  let loc = sub.location sub cexpr.cl_loc; in
+  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); _ },
@@ -634,13 +634,16 @@ let class_expr sub cexpr =
     | Tcl_constraint (cl, Some clty, _vals, _meths, _concrs) ->
         Pcl_constraint (sub.class_expr sub cl,  sub.class_type sub clty)
 
+    | Tcl_open (ovf, _p, lid, _env, e) ->
+        Pcl_open (ovf, lid, sub.class_expr sub e)
+
     | 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 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)
@@ -648,6 +651,8 @@ let class_type sub ct =
         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)
+    | Tcty_open (ovf, _p, lid, _env, e) ->
+        Pcty_open (ovf, lid, sub.class_type sub e)
   in
   Cty.mk ~loc ~attrs desc
 
@@ -658,7 +663,7 @@ let class_signature sub cs =
   }
 
 let class_type_field sub ctf =
-  let loc = sub.location sub ctf.ctf_loc; in
+  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)
@@ -673,7 +678,7 @@ let class_type_field sub ctf =
   Ctf.mk ~loc ~attrs desc
 
 let core_type sub ct =
-  let loc = sub.location sub ct.ctyp_loc; in
+  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
@@ -686,8 +691,7 @@ let core_type sub ct =
           List.map (sub.typ sub) list)
     | Ttyp_object (list, o) ->
         Ptyp_object
-          (List.map (fun (s, a, t) ->
-               (mkloc s loc, a, sub.typ sub t)) list, o)
+          (List.map (sub.object_field sub) list, o)
     | Ttyp_class (_path, lid, list) ->
         Ptyp_class (map_loc sub lid, List.map (sub.typ sub) list)
     | Ttyp_alias (ct, s) ->
@@ -718,13 +722,19 @@ let row_field sub rf =
       Rtag (label, sub.attributes sub attrs, bool, List.map (sub.typ sub) list)
   | Tinherit ct -> Rinherit (sub.typ sub ct)
 
+let object_field sub ofield =
+  match ofield with
+    OTtag (label, attrs, ct) ->
+      Otag (label, sub.attributes sub attrs, sub.typ sub ct)
+  | OTinherit ct -> Oinherit (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 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) ->
@@ -804,6 +814,7 @@ let default_mapper =
     case = case;
     location = location;
     row_field = row_field ;
+    object_field = object_field ;
   }
 
 let untype_structure ?(mapper=default_mapper) structure =

diff --git a/typing/untypeast.mli b/typing/untypeast.mli
index 1b5e84a24155e050c10c5998b7df9edd731183b1..20a6668c926394c46195c8202df97e3839e828a7 100644 (file)
--- a/typing/untypeast.mli
+++ b/typing/untypeast.mli
@@ -55,6 +55,7 @@ type mapper = {
   open_description: mapper -> Typedtree.open_description -> open_description;
   pat: mapper -> Typedtree.pattern -> pattern;
   row_field: mapper -> Typedtree.row_field -> row_field;
+  object_field: mapper -> Typedtree.object_field -> object_field;
   signature: mapper -> Typedtree.signature -> signature;
   signature_item: mapper -> Typedtree.signature_item -> signature_item;
   structure: mapper -> Typedtree.structure -> structure;

diff --git a/utils/ccomp.ml b/utils/ccomp.ml
index 30115b0be1a29f0ab2095216a9ff5b85a9b9a683..3f186b3bb0a6daade0a348796f3b6403e2787b71 100644 (file)
--- a/utils/ccomp.ml
+++ b/utils/ccomp.ml
@@ -64,7 +64,7 @@ let display_msvc_output file name =
     close_in c;
     Sys.remove file
 
-let compile_file name =
+let compile_file ?output ?(opt="") name =
   let (pipe, file) =
     if Config.ccomp_type = "msvc" && not !Clflags.verbose then
       try
@@ -78,13 +78,19 @@ let compile_file name =
   let exit =
     command
       (Printf.sprintf
-         "%s -c %s %s %s %s %s%s"
+         "%s %s %s -c %s %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)
+              let (cflags, cppflags) =
+                  if !Clflags.native_code
+                  then (Config.ocamlopt_cflags, Config.ocamlopt_cppflags)
+                  else (Config.ocamlc_cflags, Config.ocamlc_cppflags) in
+              (String.concat " " [Config.c_compiler; cflags; cppflags]))
+         (match output with
+          | None -> ""
+          | Some o -> Printf.sprintf "%s%s" Config.c_output_obj o)
+         opt
          (if !Clflags.debug && Config.ccomp_type <> "msvc" then "-g" else "")
          (String.concat " " (List.rev !Clflags.all_ccopts))
          (quote_prefixed "-I" (List.rev !Clflags.include_dirs))

diff --git a/utils/ccomp.mli b/utils/ccomp.mli
index b57df6e02e6a9233ad5345a534758e8ffbe42a38..17094ba21351d13c244ebf1983d88571e4dc09ca 100644 (file)
--- a/utils/ccomp.mli
+++ b/utils/ccomp.mli
@@ -17,7 +17,7 @@
 
 val command: string -> int
 val run_command: string -> unit
-val compile_file: string -> int
+val compile_file: ?output:string -> ?opt:string -> 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 04c95847815af27e196a908c070877ee3195c4b8..c502c41cdda8942017b0052a51f6f663fece9f98 100644 (file)
--- a/utils/clflags.ml
+++ b/utils/clflags.ml
@@ -50,6 +50,7 @@ and print_types = ref false             (* -i *)
 and make_archive = ref false            (* -a *)
 and debug = ref false                   (* -g *)
 and fast = ref false                    (* -unsafe *)
+and use_linscan = ref false             (* -linscan *)
 and link_everything = ref false         (* -linkall *)
 and custom_runtime = ref false          (* -custom *)
 and no_check_prims = ref false          (* -no-check-prims *)
@@ -112,6 +113,7 @@ and dump_cmm = ref false                (* -dcmm *)
 let dump_selection = ref false          (* -dsel *)
 let dump_cse = ref false                (* -dcse *)
 let dump_live = ref false               (* -dlive *)
+let dump_avail = ref false              (* -davail *)
 let dump_spill = ref false              (* -dspill *)
 let dump_split = ref false              (* -dsplit *)
 let dump_interf = ref false             (* -dinterf *)
@@ -120,9 +122,12 @@ let dump_regalloc = ref false           (* -dalloc *)
 let dump_reload = ref false             (* -dreload *)
 let dump_scheduling = ref false         (* -dscheduling *)
 let dump_linear = ref false             (* -dlinear *)
+let dump_interval = ref false           (* -dinterval *)
 let keep_startup_file = ref false       (* -dstartup *)
 let dump_combine = ref false            (* -dcombine *)
-let print_timings = ref false           (* -dtimings *)
+let profile_columns : Profile.column list ref = ref [] (* -dprofile/-dtimings *)
+
+let debug_runavail = ref false          (* -drunavail *)
 
 let native_code = ref false             (* set to true under ocamlopt *)
 
@@ -152,8 +157,10 @@ let pic_code = ref (match Config.architecture with (* -fPIC *)
 let runtime_variant = ref "";;      (* -runtime-variant *)
 
 let keep_docs = ref false              (* -keep-docs *)
-let keep_locs = ref false              (* -keep-locs *)
-let unsafe_string = ref (not Config.safe_string)
+let keep_locs = ref true               (* -keep-locs *)
+let unsafe_string =
+  if Config.safe_string then ref false
+  else ref (not Config.default_safe_string)
                                    (* -safe-string / -unsafe-string *)
 
 let classic_inlining = ref false       (* -Oclassic *)
@@ -364,6 +371,11 @@ let unboxed_types = ref false
 
 let arg_spec = ref []
 let arg_names = ref Misc.StringMap.empty
+
+let reset_arguments () =
+  arg_spec := [];
+  arg_names := Misc.StringMap.empty
+
 let add_arguments loc args =
   List.iter (function (arg_name, _, _) as arg ->
     try

diff --git a/utils/clflags.mli b/utils/clflags.mli
index 79e79aad5334878d2e305a140ce80f41841b7239..9a15649fef8ddd0568c966c54d67db2fde263139 100644 (file)
--- a/utils/clflags.mli
+++ b/utils/clflags.mli
@@ -13,6 +13,8 @@
 (*                                                                        *)
 (**************************************************************************)
 
+(** Command line flags *)
+
 (** Optimization parameters represented as ints indexed by round number. *)
 module Int_arg_helper : sig
   type parsed
@@ -75,6 +77,7 @@ val print_types : bool ref
 val make_archive : bool ref
 val debug : bool ref
 val fast : bool ref
+val use_linscan : bool ref
 val link_everything : bool ref
 val custom_runtime : bool ref
 val no_check_prims : bool ref
@@ -133,6 +136,8 @@ val dump_cmm : bool ref
 val dump_selection : bool ref
 val dump_cse : bool ref
 val dump_live : bool ref
+val dump_avail : bool ref
+val debug_runavail : bool ref
 val dump_spill : bool ref
 val dump_split : bool ref
 val dump_interf : bool ref
@@ -141,6 +146,7 @@ val dump_regalloc : bool ref
 val dump_reload : bool ref
 val dump_scheduling : bool ref
 val dump_linear : bool ref
+val dump_interval : bool ref
 val keep_startup_file : bool ref
 val dump_combine : bool ref
 val native_code : bool ref
@@ -180,7 +186,7 @@ val keep_docs : bool ref
 val keep_locs : bool ref
 val unsafe_string : bool ref
 val opaque : bool ref
-val print_timings : bool ref
+val profile_columns : Profile.column list ref
 val flambda_invariant_checks : bool ref
 val unbox_closures : bool ref
 val unbox_closures_factor : int ref
@@ -220,4 +226,8 @@ val add_arguments : string -> (string * Arg.spec * string) list -> unit
 *)
 val parse_arguments : Arg.anon_fun -> string -> unit
 
+(* [print_arguments usage] print the standard usage message *)
 val print_arguments : string -> unit
+
+(* [reset_arguments ()] clear all declared arguments *)
+val reset_arguments : unit -> unit

diff --git a/utils/config.mli b/utils/config.mli
index 07be0f1232c734a9c21910459651fa395fc0b2f7..2e0bd869016e703eb6a9efe0c7bcaff617edd83d 100644 (file)
--- a/utils/config.mli
+++ b/utils/config.mli
@@ -26,14 +26,20 @@ val ccomp_type: string
         (* The "kind" of the C compiler, assembler and linker used: one of
                "cc" (for Unix-style C compilers)
                "msvc" (for Microsoft Visual C++ and MASM) *)
-val bytecomp_c_compiler: string
-        (* The C compiler to use for compiling C files
-           with the bytecode compiler *)
+val c_compiler: string
+        (* The compiler to use for compiling C files *)
+val c_output_obj: string
+        (* Name of the option of the C compiler for specifying the output file *)
+val ocamlc_cflags : string
+        (* The flags ocamlc should pass to the C compiler *)
+val ocamlc_cppflags : string
+        (* The flags ocamlc should pass to the C preprocessor *)
+val ocamlopt_cflags : string
+        (* The flags ocamlopt should pass to the C compiler *)
+val ocamlopt_cppflags : string
+        (* The flags ocamlopt should pass to the C preprocessor *)
 val bytecomp_c_libraries: string
         (* The C libraries to link with custom runtimes *)
-val native_c_compiler: string
-        (* The C compiler to use for compiling C files
-           with the native-code compiler *)
 val native_c_libraries: string
         (* The C libraries to link with native-code programs *)
 val native_pack_linker: string
@@ -147,6 +153,8 @@ val flambda : bool
 
 val spacetime : bool
         (* Whether the compiler was configured for Spacetime profiling *)
+val enable_call_counts : bool
+        (* Whether call counts are to be available when Spacetime profiling *)
 val profinfo : bool
         (* Whether the compiler was configured for profiling *)
 val profinfo_width : int
@@ -158,6 +166,19 @@ val libunwind_link_flags : string
         (* Linker flags to use libunwind *)
 
 val safe_string: bool
-        (* Whether the compiler was configured with -safe-string *)
+        (* Whether the compiler was configured with -force-safe-string;
+           in that case, the -unsafe-string compile-time option is unavailable
+
+           @since 4.05.0 *)
+val default_safe_string: bool
+        (* Whether the compiler was configured to use the -safe-string
+           or -unsafe-string compile-time option by default.
+
+           @since 4.06.0 *)
+val flat_float_array : bool
+        (* Whether the compiler and runtime automagically flatten float
+           arrays *)
+val windows_unicode: bool
+        (* Whether Windows Unicode runtime is enabled *)
 val afl_instrument : bool
         (* Whether afl-fuzz instrumentation is generated by default *)

diff --git a/utils/config.mlp b/utils/config.mlp
index 28bff73a80f20a51d7eb1181aa5cf7623616eb18..434283b5843c38b2814d9a93cf1eea283cde65f9 100644 (file)
--- a/utils/config.mlp
+++ b/utils/config.mlp
@@ -30,9 +30,23 @@ let standard_library =
 
 let standard_runtime = "%%BYTERUN%%"
 let ccomp_type = "%%CCOMPTYPE%%"
-let bytecomp_c_compiler = "%%BYTECODE_C_COMPILER%%"
+let c_compiler = "%%CC%%"
+let c_output_obj = "%%OUTPUTOBJ%%"
+let ocamlc_cflags = "%%OCAMLC_CFLAGS%%"
+let ocamlc_cppflags = "%%OCAMLC_CPPFLAGS%%"
+let ocamlopt_cflags = "%%OCAMLOPT_CFLAGS%%"
+let ocamlopt_cppflags = "%%OCAMLOPT_CPPFLAGS%%"
 let bytecomp_c_libraries = "%%BYTECCLIBS%%"
-let native_c_compiler = "%%NATIVE_C_COMPILER%%"
+(* bytecomp_c_compiler and native_c_compiler have been supported for a
+   long time and are retained for backwards compatibility.
+   For programs that don't need compatibility with older OCaml releases
+   the recommended approach is to use the constituent variables
+   c_compiler, ocamlc_cflags, ocamlc_cppflags etc., directly.
+*)
+let bytecomp_c_compiler =
+  c_compiler ^ " " ^ ocamlc_cflags ^ " " ^ ocamlc_cppflags
+let native_c_compiler =
+  c_compiler ^ " " ^ ocamlopt_cflags ^ " " ^ ocamlopt_cppflags
 let native_c_libraries = "%%NATIVECCLIBS%%"
 let native_pack_linker = "%%PACKLD%%"
 let ranlib = "%%RANLIBCMD%%"
@@ -50,7 +64,7 @@ let mkdll, mkexe, mkmaindll =
           if c = '/' then '\\' else c in
         (String.init (String.length flexlink) f) ^ " %%FLEXLINK_FLAGS%%" in
       flexlink,
-      flexlink ^ " -exe",
+      flexlink ^ " -exe%%FLEXLINK_LDFLAGS%%",
       flexlink ^ " -maindll"
     with Not_found ->
       "%%MKDLL%%", "%%MKEXE%%", "%%MKMAINDLL%%"
@@ -59,28 +73,33 @@ let mkdll, mkexe, mkmaindll =
 
 let profiling = %%PROFILING%%
 let flambda = %%FLAMBDA%%
-let safe_string = %%SAFE_STRING%%
+let safe_string = %%FORCE_SAFE_STRING%%
+let default_safe_string = %%DEFAULT_SAFE_STRING%%
+let windows_unicode = %%WINDOWS_UNICODE%% != 0
+
+let flat_float_array = %%FLAT_FLOAT_ARRAY%%
 
 let afl_instrument = %%AFL_INSTRUMENT%%
 
 let exec_magic_number = "Caml1999X011"
-and cmi_magic_number = "Caml1999I021"
-and cmo_magic_number = "Caml1999O011"
-and cma_magic_number = "Caml1999A012"
+and cmi_magic_number = "Caml1999I022"
+and cmo_magic_number = "Caml1999O022"
+and cma_magic_number = "Caml1999A022"
 and cmx_magic_number =
   if flambda then
-    "Caml1999Y016"
+    "Caml1999y022"
   else
-    "Caml1999Y015"
+    "Caml1999Y022"
 and cmxa_magic_number =
   if flambda then
-    "Caml1999Z015"
+    "Caml1999z022"
   else
-    "Caml1999Z014"
-and ast_impl_magic_number = "Caml1999M020"
-and ast_intf_magic_number = "Caml1999N018"
-and cmxs_magic_number = "Caml2007D002"
-and cmt_magic_number = "Caml2012T009"
+    "Caml1999Z022"
+and ast_impl_magic_number = "Caml1999M022"
+and ast_intf_magic_number = "Caml1999N022"
+and cmxs_magic_number = "Caml1999D022"
+    (* cmxs_magic_number is duplicated in otherlibs/dynlink/natdynlink.ml *)
+and cmt_magic_number = "Caml1999T022"
 
 let load_path = ref ([] : string list)
 
@@ -104,12 +123,13 @@ let asm = "%%ASM%%"
 let asm_cfi_supported = %%ASM_CFI_SUPPORTED%%
 let with_frame_pointers = %%WITH_FRAME_POINTERS%%
 let spacetime = %%WITH_SPACETIME%%
+let enable_call_counts = %%ENABLE_CALL_COUNTS%%
 let libunwind_available = %%LIBUNWIND_AVAILABLE%%
 let libunwind_link_flags = "%%LIBUNWIND_LINK_FLAGS%%"
 let profinfo = %%WITH_PROFINFO%%
 let profinfo_width = %%PROFINFO_WIDTH%%
 
-let ext_exe = "%%EXT_EXE%%"
+let ext_exe = "%%EXE%%"
 let ext_obj = "%%EXT_OBJ%%"
 let ext_asm = "%%EXT_ASM%%"
 let ext_lib = "%%EXT_LIB%%"
@@ -137,9 +157,14 @@ let print_config oc =
   p "standard_library" standard_library;
   p "standard_runtime" standard_runtime;
   p "ccomp_type" ccomp_type;
+  p "c_compiler" c_compiler;
+  p "ocamlc_cflags" ocamlc_cflags;
+  p "ocamlc_cppflags" ocamlc_cppflags;
+  p "ocamlopt_cflags" ocamlopt_cflags;
+  p "ocamlopt_cppflags" ocamlopt_cppflags;
   p "bytecomp_c_compiler" bytecomp_c_compiler;
-  p "bytecomp_c_libraries" bytecomp_c_libraries;
   p "native_c_compiler" native_c_compiler;
+  p "bytecomp_c_libraries" bytecomp_c_libraries;
   p "native_c_libraries" native_c_libraries;
   p "native_pack_linker" native_pack_linker;
   p "ranlib" ranlib;
@@ -166,6 +191,10 @@ let print_config oc =
   p_bool "flambda" flambda;
   p_bool "spacetime" spacetime;
   p_bool "safe_string" safe_string;
+  p_bool "default_safe_string" default_safe_string;
+  p_bool "flat_float_array" flat_float_array;
+  p_bool "afl_instrument" afl_instrument;
+  p_bool "windows_unicode" windows_unicode;
 
   (* print the magic number *)
   p "exec_magic_number" exec_magic_number;

diff --git a/utils/identifiable.ml b/utils/identifiable.ml
index 8bbafcd3fa135f6cb1f5e9c66503885260239ef8..b0b706f833d28bdb084c07846f071d3795ef80df 100644 (file)
--- a/utils/identifiable.ml
+++ b/utils/identifiable.ml
@@ -14,9 +14,6 @@
 (*                                                                        *)
 (**************************************************************************)
 
-module Stdlib_map = Map
-module Stdlib_set = Set
-
 module type Thing = sig
   type t
 
@@ -27,6 +24,65 @@ module type Thing = sig
   val print : Format.formatter -> t -> unit
 end
 
+module type Set = sig
+  module T : Set.OrderedType
+  include Set.S
+    with type elt = T.t
+     and type t = Set.Make (T).t
+
+  val output : out_channel -> t -> unit
+  val print : Format.formatter -> t -> unit
+  val to_string : t -> string
+  val of_list : elt list -> t
+  val map : (elt -> elt) -> t -> t
+end
+
+module type Map = sig
+  module T : Map.OrderedType
+  include Map.S
+    with type key = T.t
+     and type 'a t = 'a Map.Make (T).t
+
+  val filter_map : 'a t -> f:(key -> 'a -> 'b option) -> 'b t
+  val of_list : (key * 'a) list -> 'a t
+
+  val disjoint_union : ?eq:('a -> 'a -> bool) -> ?print:(Format.formatter -> 'a -> unit) -> 'a t -> 'a t -> 'a t
+
+  val union_right : 'a t -> 'a t -> 'a t
+
+  val union_left : 'a t -> 'a t -> 'a t
+
+  val union_merge : ('a -> 'a -> 'a) -> 'a t -> 'a t -> 'a t
+  val rename : key t -> key -> key
+  val map_keys : (key -> key) -> 'a t -> 'a t
+  val keys : 'a t -> Set.Make(T).t
+  val data : 'a t -> 'a list
+  val of_set : (key -> 'a) -> Set.Make(T).t -> 'a t
+  val transpose_keys_and_data : key t -> key t
+  val transpose_keys_and_data_set : key t -> Set.Make(T).t t
+  val print :
+    (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit
+end
+
+module type Tbl = sig
+  module T : sig
+    type t
+    include Map.OrderedType with type t := t
+    include Hashtbl.HashedType with type t := t
+  end
+  include Hashtbl.S
+    with type key = T.t
+     and type 'a t = 'a Hashtbl.Make (T).t
+
+  val to_list : 'a t -> (T.t * 'a) list
+  val of_list : (T.t * 'a) list -> 'a t
+
+  val to_map : 'a t -> 'a Map.Make(T).t
+  val of_map : 'a Map.Make(T).t -> 'a t
+  val memoize : 'a t -> (key -> 'a) -> key -> 'a
+  val map : 'a t -> ('a -> 'b) -> 'b t
+end
+
 module Pair (A : Thing) (B : Thing) : Thing with type t = A.t * B.t = struct
   type t = A.t * B.t
 
@@ -183,53 +239,9 @@ module type S = sig
   module T : Thing with type t = t
   include Thing with type t := T.t
 
-  module Set : sig
-    include Stdlib_set.S
-      with type elt = T.t
-      and type t = Make_set (T).t
-
-    val output : out_channel -> t -> unit
-    val print : Format.formatter -> t -> unit
-    val to_string : t -> string
-    val of_list : elt list -> t
-    val map : (elt -> elt) -> t -> t
-  end
-
-  module Map : sig
-    include Stdlib_map.S
-      with type key = T.t
-      and type 'a t = 'a Make_map (T).t
-
-    val filter_map : 'a t -> f:(key -> 'a -> 'b option) -> 'b t
-    val of_list : (key * 'a) list -> 'a t
-    val disjoint_union : ?eq:('a -> 'a -> bool) -> ?print:(Format.formatter -> 'a -> unit) -> 'a t -> 'a t -> 'a t
-    val union_right : 'a t -> 'a t -> 'a t
-    val union_left : 'a t -> 'a t -> 'a t
-    val union_merge : ('a -> 'a -> 'a) -> 'a t -> 'a t -> 'a t
-    val rename : key t -> key -> key
-    val map_keys : (key -> key) -> 'a t -> 'a t
-    val keys : 'a t -> Make_set (T).t
-    val data : 'a t -> 'a list
-    val of_set : (key -> 'a) -> Make_set (T).t -> 'a t
-    val transpose_keys_and_data : key t -> key t
-    val transpose_keys_and_data_set : key t -> Set.t t
-    val print :
-      (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit
-  end
-
-  module Tbl : sig
-    include Hashtbl.S
-      with type key = T.t
-      and type 'a t = 'a Hashtbl.Make (T).t
-
-    val to_list : 'a t -> (T.t * 'a) list
-    val of_list : (T.t * 'a) list -> 'a t
-
-    val to_map : 'a t -> 'a Make_map (T).t
-    val of_map : 'a Make_map (T).t -> 'a t
-    val memoize : 'a t -> (key -> 'a) -> key -> 'a
-    val map : 'a t -> ('a -> 'b) -> 'b t
-  end
+  module Set : Set with module T := T
+  module Map : Map with module T := T
+  module Tbl : Tbl with module T := T
 end
 
 module Make (T : Thing) = struct

diff --git a/utils/identifiable.mli b/utils/identifiable.mli
index 55ed444641bc2d3e827fb1fb2d4477a9eb2310ac..50e3ac577a5d1e5c289b9b7a05dedd56e93b08a0 100644 (file)
--- a/utils/identifiable.mli
+++ b/utils/identifiable.mli
@@ -28,69 +28,80 @@ end
 
 module Pair : functor (A : Thing) (B : Thing) -> Thing with type t = A.t * B.t
 
-module type S = sig
-  type t
+module type Set = sig
+  module T : Set.OrderedType
+  include Set.S
+    with type elt = T.t
+     and type t = Set.Make (T).t
 
-  module T : Thing with type t = t
-  include Thing with type t := T.t
+  val output : out_channel -> t -> unit
+  val print : Format.formatter -> t -> unit
+  val to_string : t -> string
+  val of_list : elt list -> t
+  val map : (elt -> elt) -> t -> t
+end
 
-  module Set : sig
-    include Set.S
-      with type elt = T.t
-      and type t = Set.Make (T).t
+module type Map = sig
+  module T : Map.OrderedType
+  include Map.S
+    with type key = T.t
+     and type 'a t = 'a Map.Make (T).t
+
+  val filter_map : 'a t -> f:(key -> 'a -> 'b option) -> 'b t
+  val of_list : (key * 'a) list -> 'a t
+
+  (** [disjoint_union m1 m2] contains all bindings from [m1] and
+      [m2]. If some binding is present in both and the associated
+      value is not equal, a Fatal_error is raised *)
+  val disjoint_union : ?eq:('a -> 'a -> bool) -> ?print:(Format.formatter -> 'a -> unit) -> 'a t -> 'a t -> 'a t
+
+  (** [union_right m1 m2] contains all bindings from [m1] and [m2]. If
+      some binding is present in both, the one from [m2] is taken *)
+  val union_right : 'a t -> 'a t -> 'a t
+
+  (** [union_left m1 m2 = union_right m2 m1] *)
+  val union_left : 'a t -> 'a t -> 'a t
+
+  val union_merge : ('a -> 'a -> 'a) -> 'a t -> 'a t -> 'a t
+  val rename : key t -> key -> key
+  val map_keys : (key -> key) -> 'a t -> 'a t
+  val keys : 'a t -> Set.Make(T).t
+  val data : 'a t -> 'a list
+  val of_set : (key -> 'a) -> Set.Make(T).t -> 'a t
+  val transpose_keys_and_data : key t -> key t
+  val transpose_keys_and_data_set : key t -> Set.Make(T).t t
+  val print :
+    (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit
+end
 
-    val output : out_channel -> t -> unit
-    val print : Format.formatter -> t -> unit
-    val to_string : t -> string
-    val of_list : elt list -> t
-    val map : (elt -> elt) -> t -> t
+module type Tbl = sig
+  module T : sig
+    type t
+    include Map.OrderedType with type t := t
+    include Hashtbl.HashedType with type t := t
   end
+  include Hashtbl.S
+    with type key = T.t
+     and type 'a t = 'a Hashtbl.Make (T).t
 
-  module Map : sig
-    include Map.S
-      with type key = T.t
-      and type 'a t = 'a Map.Make (T).t
-
-    val filter_map : 'a t -> f:(key -> 'a -> 'b option) -> 'b t
-    val of_list : (key * 'a) list -> 'a t
-
-    (** [disjoint_union m1 m2] contains all bindings from [m1] and
-        [m2]. If some binding is present in both and the associated
-        value is not equal, a Fatal_error is raised *)
-    val disjoint_union : ?eq:('a -> 'a -> bool) -> ?print:(Format.formatter -> 'a -> unit) -> 'a t -> 'a t -> 'a t
-
-    (** [union_right m1 m2] contains all bindings from [m1] and [m2]. If
-        some binding is present in both, the one from [m2] is taken *)
-    val union_right : 'a t -> 'a t -> 'a t
-
-    (** [union_left m1 m2 = union_right m2 m1] *)
-    val union_left : 'a t -> 'a t -> 'a t
-
-    val union_merge : ('a -> 'a -> 'a) -> 'a t -> 'a t -> 'a t
-    val rename : key t -> key -> key
-    val map_keys : (key -> key) -> 'a t -> 'a t
-    val keys : 'a t -> Set.t
-    val data : 'a t -> 'a list
-    val of_set : (key -> 'a) -> Set.t -> 'a t
-    val transpose_keys_and_data : key t -> key t
-    val transpose_keys_and_data_set : key t -> Set.t t
-    val print :
-      (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit
-  end
+  val to_list : 'a t -> (T.t * 'a) list
+  val of_list : (T.t * 'a) list -> 'a t
+
+  val to_map : 'a t -> 'a Map.Make(T).t
+  val of_map : 'a Map.Make(T).t -> 'a t
+  val memoize : 'a t -> (key -> 'a) -> key -> 'a
+  val map : 'a t -> ('a -> 'b) -> 'b t
+end
 
-  module Tbl : sig
-    include Hashtbl.S
-      with type key = T.t
-      and type 'a t = 'a Hashtbl.Make (T).t
+module type S = sig
+  type t
 
-    val to_list : 'a t -> (T.t * 'a) list
-    val of_list : (T.t * 'a) list -> 'a t
+  module T : Thing with type t = t
+  include Thing with type t := T.t
 
-    val to_map : 'a t -> 'a Map.t
-    val of_map : 'a Map.t -> 'a t
-    val memoize : 'a t -> (key -> 'a) -> key -> 'a
-    val map : 'a t -> ('a -> 'b) -> 'b t
-  end
+  module Set : Set with module T := T
+  module Map : Map with module T := T
+  module Tbl : Tbl with module T := T
 end
 
 module Make (T : Thing) : S with type t := T.t

diff --git a/utils/misc.ml b/utils/misc.ml
index fa084bf1d6f819a9d8a8e7d62a689e9e05f9374c..052eea2a4904f3fa32c9b04f9f5ba6ff6d3bd8ef 100644 (file)
--- a/utils/misc.ml
+++ b/utils/misc.ml
@@ -163,6 +163,17 @@ module Stdlib = struct
       | None -> default
       | Some a -> f a
   end
+
+  module Array = struct
+    let exists2 p a1 a2 =
+      let n = Array.length a1 in
+      if Array.length a2 <> n then invalid_arg "Misc.Stdlib.Array.exists2";
+      let rec loop i =
+        if i = n then false
+        else if p (Array.unsafe_get a1 i) (Array.unsafe_get a2 i) then true
+        else loop (succ i) in
+      loop 0
+  end
 end
 
 let may = Stdlib.Option.iter
@@ -260,6 +271,31 @@ let string_of_file ic =
       (Buffer.add_subbytes b buff 0 n; copy())
   in copy()
 
+let output_to_file_via_temporary ?(mode = [Open_text]) filename fn =
+  let (temp_filename, oc) =
+    Filename.open_temp_file
+       ~mode ~perms:0o666 ~temp_dir:(Filename.dirname filename)
+       (Filename.basename filename) ".tmp" in
+    (* The 0o666 permissions will be modified by the umask.  It's just
+       like what [open_out] and [open_out_bin] do.
+       With temp_dir = dirname filename, we ensure that the returned
+       temp file is in the same directory as filename itself, making
+       it safe to rename temp_filename to filename later.
+       With prefix = basename filename, we are almost certain that
+       the first generated name will be unique.  A fixed prefix
+       would work too but might generate more collisions if many
+       files are being produced simultaneously in the same directory. *)
+  match fn temp_filename oc with
+  | res ->
+      close_out oc;
+      begin try
+        Sys.rename temp_filename filename; res
+      with exn ->
+        remove_file temp_filename; raise exn
+      end
+  | exception exn ->
+      close_out oc; remove_file temp_filename; raise exn
+
 (* Integer operations *)
 
 let rec log2 n =
@@ -552,7 +588,7 @@ module Color = struct
 
   let color_enabled = ref true
 
-  (* either prints the tag of [s] or delegate to [or_else] *)
+  (* either prints the tag of [s] or delegates to [or_else] *)
   let mark_open_tag ~or_else s =
     try
       let style = style_of_tag s in

diff --git a/utils/misc.mli b/utils/misc.mli
index 0cd23baabcee8dd521d4d43c3371e6df1186d7bb..7b91844081a157743f2e45a80cf6b07a860877e7 100644 (file)
--- a/utils/misc.mli
+++ b/utils/misc.mli
@@ -90,6 +90,13 @@ module Stdlib : sig
     val fold : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b
     val value_default : ('a -> 'b) -> default:'b -> 'a t -> 'b
   end
+
+  module Array : sig
+    val exists2 : ('a -> 'b -> bool) -> 'a array -> 'b array -> bool
+    (* Same as [Array.exists], but for a two-argument predicate. Raise
+       Invalid_argument if the two arrays are determined to have
+       different lengths. *)
+  end
 end
 
 val find_in_path: string list -> string -> string
@@ -120,6 +127,15 @@ val copy_file_chunk: in_channel -> out_channel -> int -> unit
 val string_of_file: in_channel -> string
         (* [string_of_file ic] reads the contents of file [ic] and copies
            them to a string. It stops when encountering EOF on [ic]. *)
+val output_to_file_via_temporary:
+      ?mode:open_flag list -> string -> (string -> out_channel -> 'a) -> 'a
+        (* Produce output in temporary file, then rename it
+           (as atomically as possible) to the desired output file name.
+           [output_to_file_via_temporary filename fn] opens a temporary file
+           which is passed to [fn] (name + output channel).  When [fn] returns,
+           the channel is closed and the temporary file is renamed to
+           [filename]. *)
+
 val log2: int -> int
         (* [log2 n] returns [s] such that [n = 1 lsl s]
            if [n] is a power of 2*)
@@ -298,9 +314,9 @@ val delete_eol_spaces : string -> string
 
 
 
-(** {2 Hook machinery} *)
+(** {1 Hook machinery}
 
-(* Hooks machinery:
+    Hooks machinery:
    [add_hook name f] will register a function that will be called on the
     argument of a later call to [apply_hooks]. Hooks are applied in the
     lexicographical order of their names.

diff --git a/utils/numbers.ml b/utils/numbers.ml
index 070f583875fd13e0cb8d0176a209966aed26563e..3e361e6619a2e93d33e93dfec5b26153db8ff266 100644 (file)
--- a/utils/numbers.ml
+++ b/utils/numbers.ml
@@ -33,6 +33,44 @@ module Int = struct
     if n < 0 then Set.empty else Set.add n (zero_to_n (n-1))
 end
 
+module Int8 = struct
+  type t = int
+
+  let zero = 0
+  let one = 1
+
+  let of_int_exn i =
+    if i < -(1 lsl 7) || i > ((1 lsl 7) - 1) then
+      Misc.fatal_errorf "Int8.of_int_exn: %d is out of range" i
+    else
+      i
+
+  let to_int i = i
+end
+
+module Int16 = struct
+  type t = int
+
+  let of_int_exn i =
+    if i < -(1 lsl 15) || i > ((1 lsl 15) - 1) then
+      Misc.fatal_errorf "Int16.of_int_exn: %d is out of range" i
+    else
+      i
+
+  let lower_int64 = Int64.neg (Int64.shift_left Int64.one 15)
+  let upper_int64 = Int64.sub (Int64.shift_left Int64.one 15) Int64.one
+
+  let of_int64_exn i =
+    if Int64.compare i lower_int64 < 0
+        || Int64.compare i upper_int64 > 0
+    then
+      Misc.fatal_errorf "Int16.of_int64_exn: %Ld is out of range" i
+    else
+      Int64.to_int i
+
+  let to_int t = t
+end
+
 module Float = struct
   type t = float
 

diff --git a/utils/numbers.mli b/utils/numbers.mli
index 873f409f8d3747da6bdf153ac744bb046859542a..4d5e285fa635bd4cba80615dae25768e41653378 100644 (file)
--- a/utils/numbers.mli
+++ b/utils/numbers.mli
@@ -14,7 +14,7 @@
 (*                                                                        *)
 (**************************************************************************)
 
-(** Modules about numbers that satisfy {!Identifiable.S}. *)
+(** Modules about numbers, some of which satisfy {!Identifiable.S}. *)
 
 module Int : sig
   include Identifiable.S with type t = int
@@ -23,4 +23,23 @@ module Int : sig
   val zero_to_n : int -> Set.t
 end
 
+module Int8 : sig
+  type t
+
+  val zero : t
+  val one : t
+
+  val of_int_exn : int -> t
+  val to_int : t -> int
+end
+
+module Int16 : sig
+  type t
+
+  val of_int_exn : int -> t
+  val of_int64_exn : Int64.t -> t
+
+  val to_int : t -> int
+end
+
 module Float : Identifiable.S with type t = float

diff --git a/utils/profile.ml b/utils/profile.ml
new file mode 100644 (file)
index 0000000..59d67a1
--- /dev/null
+++ b/utils/profile.ml
@@ -0,0 +1,334 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                      Pierre Chambart, OCamlPro                         *)
+(*                                                                        *)
+(*   Copyright 2015 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+[@@@ocaml.warning "+a-18-40-42-48"]
+
+type file = string
+
+external time_include_children: bool -> float = "caml_sys_time_include_children"
+let cpu_time () = time_include_children true
+
+module Measure = struct
+  type t = {
+    time : float;
+    allocated_words : float;
+    top_heap_words : int;
+  }
+  let create () =
+    let stat = Gc.quick_stat () in
+    {
+      time = cpu_time ();
+      allocated_words = stat.minor_words +. stat.major_words;
+      top_heap_words = stat.top_heap_words;
+    }
+  let zero = { time = 0.; allocated_words = 0.; top_heap_words = 0 }
+end
+
+module Measure_diff = struct
+  let timestamp = let r = ref (-1) in fun () -> incr r; !r
+  type t = {
+    timestamp : int;
+    duration : float;
+    allocated_words : float;
+    top_heap_words_increase : int;
+  }
+  let zero () = {
+    timestamp = timestamp ();
+    duration = 0.;
+    allocated_words = 0.;
+    top_heap_words_increase = 0;
+  }
+  let accumulate t (m1 : Measure.t) (m2 : Measure.t) = {
+    timestamp = t.timestamp;
+    duration = t.duration +. (m2.time -. m1.time);
+    allocated_words =
+      t.allocated_words +. (m2.allocated_words -. m1.allocated_words);
+    top_heap_words_increase =
+      t.top_heap_words_increase + (m2.top_heap_words - m1.top_heap_words);
+  }
+  let of_diff m1 m2 =
+    accumulate (zero ()) m1 m2
+end
+
+type hierarchy =
+  | E of (string, Measure_diff.t * hierarchy) Hashtbl.t
+[@@unboxed]
+
+let create () = E (Hashtbl.create 2)
+let hierarchy = ref (create ())
+let initial_measure = ref None
+let reset () = hierarchy := create (); initial_measure := None
+
+let record_call ?(accumulate = false) name f =
+  let E prev_hierarchy = !hierarchy in
+  let start_measure = Measure.create () in
+  if !initial_measure = None then initial_measure := Some start_measure;
+  let this_measure_diff, this_table =
+    (* We allow the recording of multiple categories by the same name, for tools
+       like ocamldoc that use the compiler libs but don't care about profile
+       information, and so may record, say, "parsing" multiple times. *)
+    if accumulate
+    then
+      match Hashtbl.find prev_hierarchy name with
+      | exception Not_found -> Measure_diff.zero (), Hashtbl.create 2
+      | measure_diff, E table ->
+        Hashtbl.remove prev_hierarchy name;
+        measure_diff, table
+    else Measure_diff.zero (), Hashtbl.create 2
+  in
+  hierarchy := E this_table;
+  Misc.try_finally f
+    (fun () ->
+       hierarchy := E prev_hierarchy;
+       let end_measure = Measure.create () in
+       let measure_diff =
+         Measure_diff.accumulate this_measure_diff start_measure end_measure in
+       Hashtbl.add prev_hierarchy name (measure_diff, E this_table))
+
+let record ?accumulate pass f x = record_call ?accumulate pass (fun () -> f x)
+
+type display = {
+  to_string : max:float -> width:int -> string;
+  worth_displaying : max:float -> bool;
+}
+
+let time_display v : display =
+  (* Because indentation is meaningful, and because the durations are
+     the first element of each row, we can't pad them with spaces. *)
+  let to_string_without_unit v ~width = Printf.sprintf "%0*.03f" width v in
+  let to_string ~max:_ ~width =
+    to_string_without_unit v ~width:(width - 1) ^ "s" in
+  let worth_displaying ~max:_ =
+    float_of_string (to_string_without_unit v ~width:0) <> 0. in
+  { to_string; worth_displaying }
+
+let memory_word_display =
+  (* To make memory numbers easily comparable across rows, we choose a single
+     scale for an entire column. To keep the display compact and not overly
+     precise (no one cares about the exact number of bytes), we pick the largest
+     scale we can and we only show 3 digits. Avoiding showing tiny numbers also
+     allows us to avoid displaying passes that barely allocate compared to the
+     rest of the compiler.  *)
+  let bytes_of_words words = words *. float_of_int (Sys.word_size / 8) in
+  let to_string_without_unit v ~width scale =
+    let precision = 3 and precision_power = 1e3 in
+    let v_rescaled = bytes_of_words v /. scale in
+    let v_rounded =
+      floor (v_rescaled *. precision_power +. 0.5) /. precision_power in
+    let v_str = Printf.sprintf "%.*f" precision v_rounded in
+    let index_of_dot = String.index v_str '.' in
+    let v_str_truncated =
+      String.sub v_str 0
+        (if index_of_dot >= precision
+         then index_of_dot
+         else precision + 1)
+    in
+    Printf.sprintf "%*s" width v_str_truncated
+  in
+  let choose_memory_scale =
+    let units = [|"B"; "kB"; "MB"; "GB"|] in
+    fun words ->
+      let bytes = bytes_of_words words in
+      let scale = ref (Array.length units - 1) in
+      while !scale > 0 && bytes < 1024. ** float_of_int !scale do
+        decr scale
+      done;
+      1024. ** float_of_int !scale, units.(!scale)
+  in
+  fun ?previous v : display ->
+    let to_string ~max ~width =
+      let scale, scale_str = choose_memory_scale max in
+      let width = width - String.length scale_str in
+      to_string_without_unit v ~width scale ^ scale_str
+    in
+    let worth_displaying ~max =
+      let scale, _ = choose_memory_scale max in
+      float_of_string (to_string_without_unit v ~width:0 scale) <> 0.
+      && match previous with
+      | None -> true
+      | Some p ->
+         (* This branch is for numbers that represent absolute quantity, rather
+            than differences. It allows us to skip displaying the same absolute
+            quantity many times in a row. *)
+         to_string_without_unit p ~width:0 scale
+         <> to_string_without_unit v ~width:0 scale
+    in
+    { to_string; worth_displaying }
+
+let profile_list (E table) =
+  let l = Hashtbl.fold (fun k d l -> (k, d) :: l) table [] in
+  List.sort (fun (_, (p1, _)) (_, (p2, _)) ->
+    compare p1.Measure_diff.timestamp p2.Measure_diff.timestamp) l
+
+let compute_other_category (E table : hierarchy) (total : Measure_diff.t) =
+  let r = ref total in
+  Hashtbl.iter (fun _pass ((p2 : Measure_diff.t), _) ->
+    let p1 = !r in
+    r := {
+      timestamp = p1.timestamp;
+      duration = p1.duration -. p2.duration;
+      allocated_words = p1.allocated_words -. p2.allocated_words;
+      top_heap_words_increase =
+        p1.top_heap_words_increase - p2.top_heap_words_increase;
+    }
+  ) table;
+  !r
+
+type row = R of string * (float * display) list * row list
+type column = [ `Time | `Alloc | `Top_heap | `Abs_top_heap ]
+
+let rec rows_of_hierarchy ~nesting make_row name measure_diff hierarchy env =
+  let rows =
+    rows_of_hierarchy_list
+      ~nesting:(nesting + 1) make_row hierarchy measure_diff env in
+  let values, env =
+    make_row env measure_diff ~toplevel_other:(nesting = 0 && name = "other") in
+  R (name, values, rows), env
+
+and rows_of_hierarchy_list ~nesting make_row hierarchy total env =
+  let list = profile_list hierarchy in
+  let list =
+    if list <> [] || nesting = 0
+    then list @ [ "other", (compute_other_category hierarchy total, create ()) ]
+    else []
+  in
+  let env = ref env in
+  List.map (fun (name, (measure_diff, hierarchy)) ->
+    let a, env' =
+      rows_of_hierarchy ~nesting make_row name measure_diff hierarchy !env in
+    env := env';
+    a
+  ) list
+
+let rows_of_hierarchy hierarchy measure_diff initial_measure columns =
+  (* Computing top heap size is a bit complicated: if the compiler applies a
+     list of passes n times (rather than applying pass1 n times, then pass2 n
+     times etc), we only show one row for that pass but what does "top heap
+     size at the end of that pass" even mean?
+     It seems the only sensible answer is to pretend the compiler applied pass1
+     n times, pass2 n times by accumulating all the heap size increases that
+     happened during each pass, and then compute what the heap size would have
+     been. So that's what we do.
+     There's a bit of extra complication, which is that the heap can increase in
+     between measurements. So the heap sizes can be a bit off until the "other"
+     rows account for what's missing. We special case the toplevel "other" row
+     so that any increases that happened before the start of the compilation is
+     correctly reported, as a lot of code may run before the start of the
+     compilation (eg functor applications). *)
+    let make_row prev_top_heap_words (p : Measure_diff.t) ~toplevel_other =
+      let top_heap_words =
+        prev_top_heap_words
+        + p.top_heap_words_increase
+        - if toplevel_other
+          then initial_measure.Measure.top_heap_words
+          else 0
+      in
+      let make value ~f = value, f value in
+      List.map (function
+        | `Time ->
+          make p.duration ~f:time_display
+        | `Alloc ->
+          make p.allocated_words ~f:memory_word_display
+        | `Top_heap ->
+          make (float_of_int p.top_heap_words_increase) ~f:memory_word_display
+        | `Abs_top_heap ->
+          make (float_of_int top_heap_words)
+           ~f:(memory_word_display ~previous:(float_of_int prev_top_heap_words))
+      ) columns,
+      top_heap_words
+  in
+  rows_of_hierarchy_list ~nesting:0 make_row hierarchy measure_diff
+    initial_measure.top_heap_words
+
+let max_by_column ~n_columns rows =
+  let a = Array.make n_columns 0. in
+  let rec loop (R (_, values, rows)) =
+    List.iteri (fun i (v, _) -> a.(i) <- max a.(i) v) values;
+    List.iter loop rows
+  in
+  List.iter loop rows;
+  a
+
+let width_by_column ~n_columns ~display_cell rows =
+  let a = Array.make n_columns 1 in
+  let rec loop (R (_, values, rows)) =
+    List.iteri (fun i cell ->
+      let _, str = display_cell i cell ~width:0 in
+      a.(i) <- max a.(i) (String.length str)
+    ) values;
+    List.iter loop rows;
+  in
+  List.iter loop rows;
+  a
+
+let display_rows ppf rows =
+  let n_columns =
+    match rows with
+    | [] -> 0
+    | R (_, values, _) :: _ -> List.length values
+  in
+  let maxs = max_by_column ~n_columns rows in
+  let display_cell i (_, c) ~width =
+    let display_cell = c.worth_displaying ~max:maxs.(i) in
+    display_cell, if display_cell
+                  then c.to_string ~max:maxs.(i) ~width
+                  else String.make width '-'
+  in
+  let widths = width_by_column ~n_columns ~display_cell rows in
+  let rec loop (R (name, values, rows)) ~indentation =
+    let worth_displaying, cell_strings =
+      values
+      |> List.mapi (fun i cell -> display_cell i cell ~width:widths.(i))
+      |> List.split
+    in
+    if List.exists (fun b -> b) worth_displaying then
+      Format.fprintf ppf "%s%s %s@\n"
+        indentation (String.concat " " cell_strings) name;
+    List.iter (loop ~indentation:("  " ^ indentation)) rows;
+  in
+  List.iter (loop ~indentation:"") rows
+
+let print ppf columns =
+  match columns with
+  | [] -> ()
+  | _ :: _ ->
+     let initial_measure =
+       match !initial_measure with
+       | Some v -> v
+       | None -> Measure.zero
+     in
+     let total = Measure_diff.of_diff Measure.zero (Measure.create ()) in
+     display_rows ppf (rows_of_hierarchy !hierarchy total initial_measure columns)
+
+let column_mapping = [
+  "time", `Time;
+  "alloc", `Alloc;
+  "top-heap", `Top_heap;
+  "absolute-top-heap", `Abs_top_heap;
+]
+
+let column_names = List.map fst column_mapping
+
+let options_doc =
+  Printf.sprintf
+    " Print performance information for each pass\
+   \n    The columns are: %s."
+    (String.concat " " column_names)
+
+let all_columns = List.map snd column_mapping
+
+let generate = "generate"
+let transl = "transl"
+let typing = "typing"

diff --git a/utils/profile.mli b/utils/profile.mli
new file mode 100644 (file)
index 0000000..83a8252
--- /dev/null
+++ b/utils/profile.mli
@@ -0,0 +1,44 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                      Pierre Chambart, OCamlPro                         *)
+(*                                                                        *)
+(*   Copyright 2015 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Compiler performance recording *)
+
+type file = string
+
+val reset : unit -> unit
+(** erase all recorded profile information *)
+
+val record_call : ?accumulate:bool -> string -> (unit -> 'a) -> 'a
+(** [record_call pass f] calls [f] and records its profile information. *)
+
+val record : ?accumulate:bool -> string -> ('a -> 'b) -> 'a -> 'b
+(** [record pass f arg] records the profile information of [f arg] *)
+
+type column = [ `Time | `Alloc | `Top_heap | `Abs_top_heap ]
+
+val print : Format.formatter -> column list -> unit
+(** Prints the selected recorded profiling information to the formatter. *)
+
+(** Command line flags *)
+
+val options_doc : string
+val all_columns : column list
+
+(** A few pass names that are needed in several places, and shared to
+    avoid typos. *)
+
+val generate : string
+val transl : string
+val typing : string

diff --git a/utils/targetint.mli b/utils/targetint.mli
index 005e2501e261c330d173b5abf2f4b13ac135d688..788d690f6b0ad9751597d9d099155958a9ee43ae 100644 (file)
--- a/utils/targetint.mli
+++ b/utils/targetint.mli
@@ -96,7 +96,7 @@ val logxor : t -> t -> t
 (** Bitwise logical exclusive or. *)
 
 val lognot : t -> t
-(** Bitwise logical negation *)
+(** Bitwise logical negation. *)
 
 val shift_left : t -> int -> t
 (** [Targetint.shift_left x y] shifts [x] to the left by [y] bits.

diff --git a/utils/tbl.ml b/utils/tbl.ml
index abb7309b948fdf61c8d1415275f3674d9bc4eed2..fa278b43bb00d95190f00ffb4abe828d58bbf865 100644 (file)
--- a/utils/tbl.ml
+++ b/utils/tbl.ml
@@ -13,9 +13,9 @@
 (*                                                                        *)
 (**************************************************************************)
 
-type ('a, 'b) t =
+type ('k, 'v) t =
     Empty
-  | Node of ('a, 'b) t * 'a * 'b * ('a, 'b) t * int
+  | Node of ('k, 'v) t * 'k * 'v * ('k, 'v) t * int
 
 let empty = Empty
 
@@ -66,6 +66,14 @@ let rec find x = function
       if c = 0 then d
       else find x (if c < 0 then l else r)
 
+let rec find_str (x : string) = function
+    Empty ->
+      raise Not_found
+  | Node(l, v, d, r, _) ->
+      let c = compare x v in
+      if c = 0 then d
+      else find_str x (if c < 0 then l else r)
+
 let rec mem x = function
     Empty -> false
   | Node(l, v, _d, r, _) ->

diff --git a/utils/tbl.mli b/utils/tbl.mli
index dd545b6d9670031cd57bb4ff8e1a0bc819a6a62d..d23b959c721c509ab97a71fa02d0964f3b79581b 100644 (file)
--- a/utils/tbl.mli
+++ b/utils/tbl.mli
@@ -16,18 +16,19 @@
 (* Association tables from any ordered type to any type.
    We use the generic ordering to compare keys. *)
 
-type ('a, 'b) t
+type ('k, 'v) t
 
-val empty: ('a, 'b) t
-val add: 'a -> 'b -> ('a, 'b) t -> ('a, 'b) t
-val find: 'a -> ('a, 'b) t -> 'b
-val mem: 'a -> ('a, 'b) t -> bool
-val remove: 'a -> ('a,  'b) t -> ('a, 'b) t
-val iter: ('a -> 'b -> unit) -> ('a, 'b) t -> unit
-val map: ('a -> 'b -> 'c) -> ('a, 'b) t -> ('a, 'c) t
-val fold: ('a -> 'b -> 'c -> 'c) -> ('a, 'b) t -> 'c -> 'c
+val empty: ('k, 'v) t
+val add: 'k -> 'v -> ('k, 'v) t -> ('k, 'v) t
+val find: 'k -> ('k, 'v) t -> 'v
+val find_str: string -> (string, 'v) t -> 'v
+val mem: 'k -> ('k, 'v) t -> bool
+val remove: 'k -> ('k,  'v) t -> ('k, 'v) t
+val iter: ('k -> 'v -> unit) -> ('k, 'v) t -> unit
+val map: ('k -> 'v1 -> 'v2) -> ('k, 'v1) t -> ('k, 'v2) t
+val fold: ('k -> 'v -> 'acc -> 'acc) -> ('k, 'v) t -> 'acc -> 'acc
 
 open Format
 
-val print: (formatter -> 'a -> unit) -> (formatter -> 'b -> unit) ->
-           formatter -> ('a, 'b) t -> unit
+val print: (formatter -> 'k -> unit) -> (formatter -> 'v -> unit) ->
+           formatter -> ('k, 'v) t -> unit

diff --git a/utils/timings.ml b/utils/timings.ml
deleted file mode 100644 (file)
index 4fe6ec3..0000000
--- a/utils/timings.ml
+++ /dev/null
@@ -1,158 +0,0 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                 OCaml                                  *)
-(*                                                                        *)
-(*                      Pierre Chambart, OCamlPro                         *)
-(*                                                                        *)
-(*   Copyright 2015 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
-type file = string
-
-type source_provenance =
-  | File of file
-  | Pack of string
-  | Startup
-  | Toplevel
-
-type compiler_pass =
-  | All
-  | Parsing of file
-  | Parser of file
-  | Dash_pp of file
-  | Dash_ppx of file
-  | Typing of file
-  | Transl of file
-  | Generate of file
-  | Assemble of source_provenance
-  | Clambda of source_provenance
-  | Cmm of source_provenance
-  | Compile_phrases of source_provenance
-  | Selection of source_provenance
-  | Comballoc of source_provenance
-  | CSE of source_provenance
-  | Liveness of source_provenance
-  | Deadcode of source_provenance
-  | Spill of source_provenance
-  | Split of source_provenance
-  | Regalloc of source_provenance
-  | Linearize of source_provenance
-  | Scheduling of source_provenance
-  | Emit of source_provenance
-  | Flambda_pass of string * source_provenance
-
-let timings : (compiler_pass, float * float option) Hashtbl.t =
-  Hashtbl.create 20
-
-external time_include_children: bool -> float = "caml_sys_time_include_children"
-let cpu_time () = time_include_children true
-
-let reset () = Hashtbl.clear timings
-
-let start pass =
-  (* Cannot assert it is not here: a source file can be compiled
-     multiple times on the same command line *)
-  (* assert(not (Hashtbl.mem timings pass)); *)
-  let time = cpu_time () in
-  Hashtbl.add timings pass (time, None)
-
-let stop pass =
-  assert(Hashtbl.mem timings pass);
-  let time = cpu_time () in
-  let (start, stop) = Hashtbl.find timings pass in
-  assert(stop = None);
-  Hashtbl.replace timings pass (start, Some (time -. start))
-
-let time_call pass f =
-  start pass;
-  let r = f () in
-  stop pass;
-  r
-
-let time pass f x = time_call pass (fun () -> f x)
-
-let restart pass =
-  let previous_duration =
-    match Hashtbl.find timings pass with
-    | exception Not_found -> 0.
-    | (_, Some duration) -> duration
-    | _, None -> assert false
-  in
-  let time = cpu_time () in
-  Hashtbl.replace timings pass (time, Some previous_duration)
-
-let accumulate pass =
-  let time = cpu_time () in
-  match Hashtbl.find timings pass with
-  | exception Not_found -> assert false
-  | _, None -> assert false
-  | (start, Some duration) ->
-    let duration = duration +. (time -. start) in
-    Hashtbl.replace timings pass (start, Some duration)
-
-let accumulate_time pass f x =
-  restart pass;
-  let r = f x in
-  accumulate pass;
-  r
-
-let get pass =
-  match Hashtbl.find timings pass with
-  | _start, Some duration -> Some duration
-  | _, None -> None
-  | exception Not_found -> None
-
-let kind_name = function
-  | File f -> Printf.sprintf "sourcefile(%s)" f
-  | Pack p -> Printf.sprintf "pack(%s)" p
-  | Startup -> "startup"
-  | Toplevel  -> "toplevel"
-
-let pass_name = function
-  | All -> "all"
-  | Parsing file -> Printf.sprintf "parsing(%s)" file
-  | Parser file -> Printf.sprintf "parser(%s)" file
-  | Dash_pp file -> Printf.sprintf "-pp(%s)" file
-  | Dash_ppx file -> Printf.sprintf "-ppx(%s)" file
-  | Typing file -> Printf.sprintf "typing(%s)" file
-  | Transl file -> Printf.sprintf "transl(%s)" file
-  | Generate file -> Printf.sprintf "generate(%s)" file
-  | Assemble k -> Printf.sprintf "assemble(%s)" (kind_name k)
-  | Clambda k -> Printf.sprintf "clambda(%s)" (kind_name k)
-  | Cmm k -> Printf.sprintf "cmm(%s)" (kind_name k)
-  | Compile_phrases k -> Printf.sprintf "compile_phrases(%s)" (kind_name k)
-  | Selection k -> Printf.sprintf "selection(%s)" (kind_name k)
-  | Comballoc k -> Printf.sprintf "comballoc(%s)" (kind_name k)
-  | CSE k -> Printf.sprintf "cse(%s)" (kind_name k)
-  | Liveness k -> Printf.sprintf "liveness(%s)" (kind_name k)
-  | Deadcode k -> Printf.sprintf "deadcode(%s)" (kind_name k)
-  | Spill k -> Printf.sprintf "spill(%s)" (kind_name k)
-  | Split k -> Printf.sprintf "split(%s)" (kind_name k)
-  | Regalloc k -> Printf.sprintf "regalloc(%s)" (kind_name k)
-  | Linearize k -> Printf.sprintf "linearize(%s)" (kind_name k)
-  | Scheduling k -> Printf.sprintf "scheduling(%s)" (kind_name k)
-  | Emit k -> Printf.sprintf "emit(%s)" (kind_name k)
-  | Flambda_pass (pass, file) ->
-    Printf.sprintf "flambda(%s)(%s)" pass (kind_name file)
-
-let timings_list () =
-  let l = Hashtbl.fold (fun pass times l -> (pass, times) :: l) timings [] in
-  List.sort (fun (pass1, (start1, _)) (pass2, (start2, _)) ->
-    compare (start1, pass1) (start2, pass2)) l
-
-let print ppf =
-  let current_time = cpu_time () in
-  List.iter (fun (pass, (start, stop)) ->
-      match stop with
-      | Some duration ->
-        Format.fprintf ppf "%s: %.03fs@." (pass_name pass) duration
-      | None ->
-        Format.fprintf ppf "%s: running for %.03fs@." (pass_name pass)
-          (current_time -. start))
-    (timings_list ())

diff --git a/utils/timings.mli b/utils/timings.mli
deleted file mode 100644 (file)
index 1983a9c..0000000
--- a/utils/timings.mli
+++ /dev/null
@@ -1,68 +0,0 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                 OCaml                                  *)
-(*                                                                        *)
-(*                      Pierre Chambart, OCamlPro                         *)
-(*                                                                        *)
-(*   Copyright 2015 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
-(** Compiler performance recording *)
-
-type file = string
-
-type source_provenance =
-  | File of file
-  | Pack of string
-  | Startup
-  | Toplevel
-
-type compiler_pass =
-  | All
-  | Parsing of file
-  | Parser of file
-  | Dash_pp of file
-  | Dash_ppx of file
-  | Typing of file
-  | Transl of file
-  | Generate of file
-  | Assemble of source_provenance
-  | Clambda of source_provenance
-  | Cmm of source_provenance
-  | Compile_phrases of source_provenance
-  | Selection of source_provenance
-  | Comballoc of source_provenance
-  | CSE of source_provenance
-  | Liveness of source_provenance
-  | Deadcode of source_provenance
-  | Spill of source_provenance
-  | Split of source_provenance
-  | Regalloc of source_provenance
-  | Linearize of source_provenance
-  | Scheduling of source_provenance
-  | Emit of source_provenance
-  | Flambda_pass of string * source_provenance
-
-val reset : unit -> unit
-(** erase all recorded times *)
-
-val get : compiler_pass -> float option
-(** returns the runtime in seconds of a completed pass *)
-
-val time_call : compiler_pass -> (unit -> 'a) -> 'a
-(** [time_call pass f] calls [f] and records its runtime. *)
-
-val time : compiler_pass -> ('a -> 'b) -> 'a -> 'b
-(** [time pass f arg] records the runtime of [f arg] *)
-
-val accumulate_time : compiler_pass -> ('a -> 'b) -> 'a -> 'b
-(** Like time for passes that can run multiple times *)
-
-val print : Format.formatter -> unit
-(** Prints all recorded timings to the formatter. *)

diff --git a/utils/warnings.ml b/utils/warnings.ml
index f2e08580f22a14dcc82269ddeece351cf3dba3a1..23f3f1d5a6e41e870db20ac1ff70153df736106a 100644 (file)
--- a/utils/warnings.ml
+++ b/utils/warnings.ml
@@ -20,10 +20,16 @@
    - manual/manual/cmds/native.etex
 *)
 
+type loc = {
+  loc_start: Lexing.position;
+  loc_end: Lexing.position;
+  loc_ghost: bool;
+}
+
 type t =
   | Comment_start                           (*  1 *)
   | Comment_not_end                         (*  2 *)
-  | Deprecated of string                    (*  3 *)
+  | Deprecated of string * loc * loc        (*  3 *)
   | Fragile_match of string                 (*  4 *)
   | Partial_application                     (*  5 *)
   | Labels_omitted of string list           (*  6 *)
@@ -82,6 +88,7 @@ type t =
   | Assignment_to_non_mutable_value         (* 59 *)
   | Unused_module of string                 (* 60 *)
   | Unboxable_type_in_prim_decl of string   (* 61 *)
+  | Constraint_on_gadt                      (* 62 *)
 ;;
 
 (* If you remove a warning, leave a hole in the numbering.  NEVER change
@@ -152,9 +159,10 @@ let number = function
   | Assignment_to_non_mutable_value -> 59
   | Unused_module _ -> 60
   | Unboxable_type_in_prim_decl _ -> 61
+  | Constraint_on_gadt -> 62
 ;;
 
-let last_warning_number = 61
+let last_warning_number = 62
 ;;
 
 (* Must be the max number returned by the [number] function. *)
@@ -204,12 +212,32 @@ let current =
       error = Array.make (last_warning_number + 1) false;
     }
 
+let disabled = ref false
+
+let without_warnings f =
+  Misc.protect_refs [Misc.R(disabled, true)] f
+
 let backup () = !current
 
 let restore x = current := x
 
-let is_active x = (!current).active.(number x);;
-let is_error x = (!current).error.(number x);;
+let is_active x = not !disabled && (!current).active.(number x);;
+let is_error x = not !disabled && (!current).error.(number x);;
+
+let mk_lazy f =
+  let state = backup () in
+  lazy
+    (
+      let prev = backup () in
+      restore state;
+      try
+        let r = f () in
+        restore prev;
+        r
+      with exn ->
+        restore prev;
+        raise exn
+    )
 
 let parse_opt error active flags s =
   let set i = flags.(i) <- true in
@@ -269,7 +297,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-50-60";;
+let defaults_w = "+a-4-6-7-9-27-29-32..42-44-45-48-50-60";;
 let defaults_warn_error = "-a+31";;
 
 let () = parse_options false defaults_w;;
@@ -278,7 +306,7 @@ let () = parse_options true defaults_warn_error;;
 let message = function
   | Comment_start -> "this is the start of a comment."
   | Comment_not_end -> "this is not the end of a comment."
-  | Deprecated s ->
+  | Deprecated (s, _, _) ->
       (* Reduce \r\n to \n:
            - Prevents any \r characters being printed on Unix when processing
              Windows sources
@@ -483,28 +511,46 @@ let message = function
          unboxable. The representation of such types may change in future\n\
          versions. You should annotate the declaration of %s with [@@boxed]\n\
          or [@@unboxed]." t t
+  | Constraint_on_gadt ->
+      "Type constraints do not apply to GADT cases of variant types."
 ;;
 
+let sub_locs = function
+  | Deprecated (_, def, use) ->
+      [
+        def, "Definition";
+        use, "Expected signature";
+      ]
+  | _ -> []
+
 let nerrors = ref 0;;
 
-let print ppf w =
-  let msg = message w in
-  let num = number w in
-  Format.fprintf ppf "%d: %s" num msg;
-  Format.pp_print_flush ppf ();
-  if (!current).error.(num) then incr nerrors
+type reporting_information =
+  { number : int
+  ; message : string
+  ; is_error : bool
+  ; sub_locs : (loc * string) list;
+  }
+
+let report w =
+  match is_active w with
+  | false -> `Inactive
+  | true ->
+     if is_error w then incr nerrors;
+     `Active { number = number w; message = message w; is_error = is_error w;
+               sub_locs = sub_locs w;
+             }
 ;;
 
-exception Errors of int;;
+exception Errors;;
 
 let reset_fatal () =
   nerrors := 0
 
 let check_fatal () =
   if !nerrors > 0 then begin
-    let e = Errors !nerrors in
     nerrors := 0;
-    raise e;
+    raise Errors;
   end;
 ;;
 
@@ -540,9 +586,7 @@ let descriptions =
    23, "Useless record \"with\" clause.";
    24, "Bad module name: the source file name is not a valid OCaml module \
         name.";
-   (* 25, "Pattern-matching with all clauses guarded.  Exhaustiveness cannot \
-      be\n\
-   \    checked.";  (* Now part of warning 8 *) *)
+   25, "Deprecated: now part of warning 8.";
    26, "Suspicious unused variable: unused variable that is bound\n\
    \    with \"let\" or \"as\", and doesn't start with an underscore (\"_\")\n\
    \    character.";
@@ -583,6 +627,8 @@ let descriptions =
    58, "Missing cmx file";
    59, "Assignment to non-mutable value";
    60, "Unused module declaration";
+   61, "Unboxable type in primitive declaration";
+   62, "Type constraint on GADT type declaration"
   ]
 ;;
 

diff --git a/utils/warnings.mli b/utils/warnings.mli
index fb03935b8f03d028dcccaa71f372d4da06b672cc..1171f8b3f312f7a2b092cf7752d2ea2dc23179f0 100644 (file)
--- a/utils/warnings.mli
+++ b/utils/warnings.mli
@@ -13,12 +13,16 @@
 (*                                                                        *)
 (**************************************************************************)
 
-open Format
+type loc = {
+  loc_start: Lexing.position;
+  loc_end: Lexing.position;
+  loc_ghost: bool;
+}
 
 type t =
   | Comment_start                           (*  1 *)
   | Comment_not_end                         (*  2 *)
-  | Deprecated of string                    (*  3 *)
+  | Deprecated of string * loc * loc        (*  3 *)
   | Fragile_match of string                 (*  4 *)
   | Partial_application                     (*  5 *)
   | Labels_omitted of string list           (*  6 *)
@@ -40,7 +44,7 @@ type t =
   | Preprocessor of string                  (* 22 *)
   | Useless_record_with                     (* 23 *)
   | Bad_module_name of string               (* 24 *)
-  | All_clauses_guarded                     (* 25 *)
+  | All_clauses_guarded                     (* 8, used to be 25 *)
   | Unused_var of string                    (* 26 *)
   | Unused_var_strict of string             (* 27 *)
   | Wildcard_arg_to_constant_constr         (* 28 *)
@@ -77,19 +81,29 @@ type t =
   | Assignment_to_non_mutable_value         (* 59 *)
   | Unused_module of string                 (* 60 *)
   | Unboxable_type_in_prim_decl of string   (* 61 *)
+  | Constraint_on_gadt                      (* 62 *)
 ;;
 
 val parse_options : bool -> string -> unit;;
 
+val without_warnings : (unit -> 'a) -> 'a
+
 val is_active : t -> bool;;
 val is_error : t -> bool;;
 
 val defaults_w : string;;
 val defaults_warn_error : string;;
 
-val print : formatter -> t -> unit;;
+type reporting_information =
+  { number : int
+  ; message : string
+  ; is_error : bool
+  ; sub_locs : (loc * string) list;
+  }
+
+val report : t -> [ `Active of reporting_information | `Inactive ]
 
-exception Errors of int;;
+exception Errors;;
 
 val check_fatal : unit -> unit;;
 val reset_fatal: unit -> unit
@@ -99,3 +113,6 @@ val help_warnings: unit -> unit
 type state
 val backup: unit -> state
 val restore: state -> unit
+val mk_lazy: (unit -> 'a) -> 'a Lazy.t
+    (** Like [Lazy.of_fun], but the function is applied with
+        the warning settings at the time [mk_lazy] is called. *)

diff --git a/yacc/Makefile b/yacc/Makefile
index d5be9f96117ea17b6e3ce93ef6d058f808fe7e3a..8d3b0870c937716f3ad526bbb17f4d29965f412a 100644 (file)
--- a/yacc/Makefile
+++ b/yacc/Makefile
@@ -17,23 +17,18 @@
 
 include ../config/Makefile
 
-CC=$(BYTECC)
-CFLAGS=-DNDEBUG $(BYTECCCOMPOPTS)
-
-ifeq "$(TOOLCHAIN)" "mingw"
-  CFLAGS += -DNO_UNIX
-else ifeq "$(TOOLCHAIN)" "msvc"
-  CFLAGS += -DNO_UNIX
-endif
-
 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)
 
 all: ocamlyacc$(EXE)
 
+ifeq ($(TOOLCHAIN),cc)
+MKEXE_ANSI=$(MKEXE)
+endif
+
 ocamlyacc$(EXE): $(OBJS)
-       $(MKEXE) -o ocamlyacc$(EXE) $(OBJS) $(EXTRALIBS)
+       $(MKEXE_ANSI) -o ocamlyacc$(EXE) $(OBJS) $(EXTRALIBS)
 
 version.h : ../VERSION
        echo "#define OCAML_VERSION \"`sed -e 1q $^ | tr -d '\r'`\"" > $@
@@ -60,4 +55,4 @@ warshall.$(O): defs.h
 # also works for .obj files.
 
 %.$(O): %.c
-       $(CC) $(CFLAGS) -c $<
+       $(CC) -c $(CFLAGS) $(CPPFLAGS) -I../byterun $(OUTPUTOBJ)$@ $<

diff --git a/yacc/defs.h b/yacc/defs.h
index 8377d05de5010bfb8d9aaa594b8abf8dfbc80425..bb7305a220504ca7587b4ba77f88bb4a0a545d32 100644 (file)
--- a/yacc/defs.h
+++ b/yacc/defs.h
@@ -15,13 +15,17 @@
 
 /* Based on public-domain code from Berkeley Yacc */
 
+#ifndef DEBUG
+#define NDEBUG
+#endif
+
 #include <assert.h>
 #include <ctype.h>
 #include <errno.h>
 #include <limits.h>
 #include <stdio.h>
 #include <stdlib.h>
-#include "../config/s.h"
+#include "caml/s.h"
 
 /*  machine-dependent definitions                              */
 /*  the following definitions are for the Tahoe                */
@@ -81,8 +85,6 @@
 #define TEXT 5
 #define TYPE 6
 #define START 7
-#define UNION 8
-#define IDENT 9
 
 /*  symbol classes  */
 
@@ -227,7 +229,6 @@ extern char *defines_file_name;
 extern char *input_file_name;
 extern char *output_file_name;
 extern char *text_file_name;
-extern char *union_file_name;
 extern char *verbose_file_name;
 extern char *interface_file_name;
 
@@ -238,7 +239,6 @@ extern FILE *defines_file;
 extern FILE *input_file;
 extern FILE *output_file;
 extern FILE *text_file;
-extern FILE *union_file;
 extern FILE *verbose_file;
 extern FILE *interface_file;
 
@@ -250,7 +250,6 @@ extern int ntokens;
 extern int nvars;
 extern int ntags;
 
-extern char unionized;
 extern char line_format[];
 
 extern int   start_symbol;
@@ -333,7 +332,6 @@ extern void no_grammar (void) Noreturn;
 extern void no_space (void) Noreturn;
 extern void open_error (char *filename) Noreturn;
 extern void output (void);
-extern void over_unionized (char *u_cptr) Noreturn;
 extern void prec_redeclared (void);
 extern void polymorphic_entry_point(char *s) Noreturn;
 extern void forbidden_conflicts (void);
@@ -355,7 +353,6 @@ extern void unterminated_action (int a_lineno, char *a_line, char *a_cptr) Noret
 extern void unterminated_comment (int c_lineno, char *c_line, char *c_cptr) Noreturn;
 extern void unterminated_string (int s_lineno, char *s_line, char *s_cptr) Noreturn;
 extern void unterminated_text (int t_lineno, char *t_line, char *t_cptr) Noreturn;
-extern void unterminated_union (int u_lineno, char *u_line, char *u_cptr) Noreturn;
 extern void used_reserved (char *s) Noreturn;
 extern void verbose (void);
 extern void write_section (char **section);

diff --git a/yacc/error.c b/yacc/error.c
index 236908c08ed7d87ed42112fb982f17ae136f09cc..f116f2c8741b3edcdc0414b9fd32d5e41a59f551 100644 (file)
--- a/yacc/error.c
+++ b/yacc/error.c
@@ -109,24 +109,6 @@ void unterminated_text(int t_lineno, char *t_line, char *t_cptr)
 }
 
 
-void unterminated_union(int u_lineno, char *u_line, char *u_cptr)
-{
-    fprintf(stderr, "File \"%s\", line %d: unterminated %%union declaration\n",
-            virtual_input_file_name, u_lineno);
-    print_pos(u_line, u_cptr);
-    done(1);
-}
-
-
-void over_unionized(char *u_cptr)
-{
-    fprintf(stderr, "File \"%s\", line %d: too many %%union declarations\n",
-            virtual_input_file_name, lineno);
-    print_pos(line, u_cptr);
-    done(1);
-}
-
-
 void illegal_tag(int t_lineno, char *t_line, char *t_cptr)
 {
     fprintf(stderr, "File \"%s\", line %d: illegal tag\n",

diff --git a/yacc/main.c b/yacc/main.c
index e7606dae447448db029daee920d4147f23e659b6..9bb3786184fcf2f202516a07d1882da963b5b048 100644 (file)
--- a/yacc/main.c
+++ b/yacc/main.c
@@ -38,7 +38,7 @@ char *file_prefix = 0;
 char *myname = "yacc";
 char temp_form[] = "yacc.XXXXXXX";
 
-#ifdef NO_UNIX
+#ifdef _WIN32
 char dirsep = '\\';
 #else
 char dirsep = '/';
@@ -56,11 +56,10 @@ char *defines_file_name;
 char *input_file_name = "";
 char *output_file_name;
 char *text_file_name;
-char *union_file_name;
 char *verbose_file_name;
 
 #ifdef HAS_MKSTEMP
-int action_fd = -1, entry_fd = -1, text_fd = -1, union_fd = -1;
+int action_fd = -1, entry_fd = -1, text_fd = -1;
 #endif
 
 FILE *action_file;      /*  a temp file, used to save actions associated    */
@@ -72,9 +71,6 @@ FILE *input_file;       /*  the input file                                  */
 FILE *output_file;      /*  y.tab.c                                         */
 FILE *text_file;        /*  a temp file, used to save text until all        */
                         /*  symbols have been defined                       */
-FILE *union_file;       /*  a temp file, used to save the union             */
-                        /*  definition until all symbol have been           */
-                        /*  defined                                         */
 FILE *verbose_file;     /*  y.output                                        */
 FILE *interface_file;
 
@@ -104,9 +100,6 @@ char *nullable;
 #if !defined(HAS_MKSTEMP)
 extern char *mktemp(char *);
 #endif
-#ifndef NO_UNIX
-extern char *getenv(const char *);
-#endif
 
 
 void done(int k)
@@ -118,13 +111,10 @@ void done(int k)
        unlink(entry_file_name);
     if (text_fd != -1)
        unlink(text_file_name);
-    if (union_fd != -1)
-       unlink(union_file_name);
 #else
     if (action_file) { fclose(action_file); unlink(action_file_name); }
     if (entry_file) { fclose(entry_file); unlink(entry_file_name); }
     if (text_file) { fclose(text_file); unlink(text_file_name); }
-    if (union_file) { fclose(union_file); unlink(union_file_name); }
 #endif
     if (output_file && k > 0) {
       fclose(output_file); unlink(output_file_name);
@@ -284,7 +274,7 @@ void create_file_names(void)
     int i, len;
     char *tmpdir;
 
-#ifdef NO_UNIX
+#ifdef _WIN32
     tmpdir = getenv("TEMP");
     if (tmpdir == 0) tmpdir = ".";
 #else
@@ -302,32 +292,26 @@ void create_file_names(void)
     if (entry_file_name == 0) no_space();
     text_file_name = MALLOC(i);
     if (text_file_name == 0) no_space();
-    union_file_name = MALLOC(i);
-    if (union_file_name == 0) no_space();
 
     strcpy(action_file_name, tmpdir);
     strcpy(entry_file_name, tmpdir);
     strcpy(text_file_name, tmpdir);
-    strcpy(union_file_name, tmpdir);
 
     if (len && tmpdir[len - 1] != dirsep)
     {
         action_file_name[len] = dirsep;
         entry_file_name[len] = dirsep;
         text_file_name[len] = dirsep;
-        union_file_name[len] = dirsep;
         ++len;
     }
 
     strcpy(action_file_name + len, temp_form);
     strcpy(entry_file_name + len, temp_form);
     strcpy(text_file_name + len, temp_form);
-    strcpy(union_file_name + len, temp_form);
 
     action_file_name[len + 5] = 'a';
     entry_file_name[len + 5] = 'e';
     text_file_name[len + 5] = 't';
-    union_file_name[len + 5] = 'u';
 
 #ifdef HAS_MKSTEMP
     action_fd = mkstemp(action_file_name);
@@ -339,14 +323,10 @@ void create_file_names(void)
     text_fd = mkstemp(text_file_name);
     if (text_fd == -1)
         open_error(text_file_name);
-    union_fd = mkstemp(union_file_name);
-    if (union_fd == -1)
-        open_error(union_file_name);
 #else
     mktemp(action_file_name);
     mktemp(entry_file_name);
     mktemp(text_file_name);
-    mktemp(union_file_name);
 #endif
 
     len = strlen(file_prefix);
@@ -424,13 +404,6 @@ void open_files(void)
         defines_file = fopen(defines_file_name, "w");
         if (defines_file == 0)
             open_error(defines_file_name);
-#ifdef HAS_MKSTEMP
-        union_file = fdopen(union_fd, "w");
-#else
-        union_file = fopen(union_file_name, "w");
-#endif
-        if (union_file ==  0)
-            open_error(union_file_name);
     }
 
     output_file = fopen(output_file_name, "w");

diff --git a/yacc/reader.c b/yacc/reader.c
index 3e99e8c8ebec6e86cde1571f87ad6c32996731b4..0fb3a9cd46bd8e8a6e986d0c96ed7023d2033229 100644 (file)
--- a/yacc/reader.c
+++ b/yacc/reader.c
@@ -31,7 +31,7 @@ int cinc, cache_size;
 int ntags, tagmax;
 char **tag_table;
 
-char saw_eof, unionized;
+char saw_eof;
 char *cptr, *line;
 int linesize;
 
@@ -51,10 +51,39 @@ char *name_pool;
 
 char line_format[] = "# %d \"%s\"\n";
 
+static unsigned char caml_ident_start[32] =
+"\000\000\000\000\000\000\000\000\376\377\377\207\376\377\377\007\000\000\000\000\000\000\000\000\377\377\177\377\377\377\177\377";
+static unsigned char caml_ident_body[32] =
+"\000\000\000\000\200\000\377\003\376\377\377\207\376\377\377\007\000\000\000\000\000\000\000\000\377\377\177\377\377\377\177\377";
 
+#define In_bitmap(bm,c) (bm[(unsigned char)(c) >> 3] & (1 << ((c) & 7)))
 
 void start_rule (register bucket *bp, int s_lineno);
 
+static char *buffer;
+static size_t length;
+static size_t capacity;
+static void push_stack(char x) {
+    if (length - 1 >= capacity) {
+        buffer = realloc(buffer, capacity = 3*length/2 + 100);
+        if (!buffer) no_space();
+    }
+    buffer[++length] = x;
+    buffer[0] = '\1';
+}
+
+static void pop_stack(char x) {
+    if (!buffer || buffer[length--] != x) {
+        switch (x) {
+            case '{': x = '}'; break;
+            case '(': x = ')'; break;
+            default: break;
+        }
+        fprintf(stderr, "Mismatched parentheses or braces: '%c'\n", x);
+                syntax_error(lineno, line, cptr - 1);
+   }
+}
+
 void cachec(int c)
 {
     assert(cinc >= 0);
@@ -161,6 +190,184 @@ void skip_comment(void)
     }
 }
 
+static void process_quoted_string(char c, FILE *const f)
+{
+    int s_lineno = lineno;
+    char *s_line = dup_line();
+    char *s_cptr = s_line + (cptr - line - 1);
+
+    char quote = c;
+    for (;;)
+    {
+        c = *cptr++;
+        putc(c, f);
+        if (c == quote)
+        {
+            FREE(s_line);
+            return;
+        }
+        if (c == '\n')
+            unterminated_string(s_lineno, s_line, s_cptr);
+        if (c == '\\')
+        {
+            c = *cptr++;
+            putc(c, f);
+            if (c == '\n')
+            {
+                get_line();
+                if (line == 0)
+                    unterminated_string(s_lineno, s_line, s_cptr);
+            }
+        }
+    }
+}
+
+int process_apostrophe(FILE *const f)
+{
+    if (cptr[0] != 0 && cptr[0] != '\\' && cptr[1] == '\'') {
+        fwrite(cptr, 1, 2, f);
+        cptr += 2;
+    } else if (cptr[0] == '\\'
+            && (isdigit((unsigned char) cptr[1]) || cptr[1] == 'x')
+            && isdigit((unsigned char) cptr[2])
+            && isdigit((unsigned char) cptr[3])
+            && cptr[4] == '\'') {
+        fwrite(cptr, 1, 5, f);
+        cptr += 5;
+    } else if (cptr[0] == '\\' && cptr[2] == '\'') {
+        fwrite(cptr, 1, 3, f);
+        cptr += 3;
+    } else {
+        return 0;
+    }
+    return 1;
+}
+
+void process_apostrophe_body(FILE *f)
+{
+    if (!process_apostrophe(f)) {
+        while (In_bitmap(caml_ident_body, *cptr)) {
+           putc(*cptr, f);
+           cptr++;
+        }
+    }
+}
+
+
+static void process_open_curly_bracket(FILE *f) {
+    if (In_bitmap(caml_ident_start, *cptr) || *cptr == '|')
+    {
+        char *newcptr = cptr;
+        size_t size = 0;
+        char *buf;
+        while(In_bitmap(caml_ident_body, *newcptr)) { newcptr++; }
+        if (*newcptr == '|')
+        { /* Raw string */
+            int s_lineno;
+            char *s_line;
+            char *s_cptr;
+
+            size = newcptr - cptr;
+            buf = MALLOC(size + 2);
+            if (!buf) no_space();
+            memcpy(buf, cptr, size);
+            buf[size] = '}';
+            buf[size + 1] = '\0';
+            fwrite(cptr, 1, size + 1, f);
+            cptr = newcptr + 1;
+            s_lineno = lineno;
+            s_line = dup_line();
+            s_cptr = s_line + (cptr - line - 1);
+
+            for (;;)
+            {
+                char c = *cptr++;
+                putc(c, f);
+                if (c == '|')
+                {
+                    int match = 1;
+                    size_t i;
+                    for (i = 0; i <= size; ++i) {
+                        if (cptr[i] != buf[i]) {
+                            newcptr--;
+                            match = 0;
+                            break;
+                        }
+                    }
+                    if (match) {
+                        FREE(s_line);
+                        FREE(buf);
+                        fwrite(cptr, 1, size, f);
+                        cptr += size;
+                        return;
+                    }
+                }
+                if (c == '\n')
+                {
+                    get_line();
+                    if (line == 0)
+                        unterminated_string(s_lineno, s_line, s_cptr);
+                }
+            }
+            FREE(buf);
+            return;
+        }
+    }
+    return;
+}
+
+static void process_comment(FILE *const f) {
+    char c = *cptr;
+    unsigned depth = 1;
+    if (c == '*')
+    {
+        int c_lineno = lineno;
+        char *c_line = dup_line();
+        char *c_cptr = c_line + (cptr - line - 1);
+
+        putc('*', f);
+        ++cptr;
+        for (;;)
+        {
+            c = *cptr++;
+            putc(c, f);
+
+            switch (c)
+            {
+            case '*':
+                if (*cptr == ')')
+                {
+                    depth--;
+                    if (depth == 0) {
+                        FREE(c_line);
+                        return;
+                    }
+                }
+                continue;
+            case '\n':
+                get_line();
+                if (line == 0)
+                    unterminated_comment(c_lineno, c_line, c_cptr);
+                continue;
+            case '(':
+                if (*cptr == '*') ++depth;
+                continue;
+            case '\'':
+                process_apostrophe(f);
+                continue;
+            case '"':
+                process_quoted_string(c, f);
+                continue;
+            case '{':
+                process_open_curly_bracket(f);
+                continue;
+            default:
+                continue;
+            }
+        }
+    }
+}
+
 char *substring (char *str, int start, int len)
 {
   int i;
@@ -310,10 +517,6 @@ keyword(void)
             return (NONASSOC);
         if (strcmp(cache, "start") == 0)
             return (START);
-        if (strcmp(cache, "union") == 0)
-            return (UNION);
-        if (strcmp(cache, "ident") == 0)
-            return (IDENT);
     }
     else
     {
@@ -336,40 +539,9 @@ keyword(void)
     return 0;
 }
 
-
-void copy_ident(void)
-{
-    register int c;
-    register FILE *f = output_file;
-
-    c = nextc();
-    if (c == EOF) unexpected_EOF();
-    if (c != '"') syntax_error(lineno, line, cptr);
-    ++outline;
-    fprintf(f, "#ident \"");
-    for (;;)
-    {
-        c = *++cptr;
-        if (c == '\n')
-        {
-            fprintf(f, "\"\n");
-            return;
-        }
-        putc(c, f);
-        if (c == '"')
-        {
-            putc('\n', f);
-            ++cptr;
-            return;
-        }
-    }
-}
-
-
 void copy_text(void)
 {
     register int c;
-    int quote;
     register FILE *f = text_file;
     int need_newline = 0;
     int t_lineno = lineno;
@@ -396,91 +568,19 @@ loop:
         unterminated_text(t_lineno, t_line, t_cptr);
 
     case '"':
-        {
-            int s_lineno = lineno;
-            char *s_line = dup_line();
-            char *s_cptr = s_line + (cptr - line - 1);
-
-            quote = c;
-            putc(c, f);
-            for (;;)
-            {
-                c = *cptr++;
-                putc(c, f);
-                if (c == quote)
-                {
-                    need_newline = 1;
-                    FREE(s_line);
-                    goto loop;
-                }
-                if (c == '\n')
-                    unterminated_string(s_lineno, s_line, s_cptr);
-                if (c == '\\')
-                {
-                    c = *cptr++;
-                    putc(c, f);
-                    if (c == '\n')
-                    {
-                        get_line();
-                        if (line == 0)
-                            unterminated_string(s_lineno, s_line, s_cptr);
-                    }
-                }
-            }
-        }
+        putc(c, f);
+        process_quoted_string(c, f);
+        goto loop;
 
     case '\'':
         putc(c, f);
-        if (cptr[0] != 0 && cptr[0] != '\\' && cptr[1] == '\'') {
-          fwrite(cptr, 1, 2, f);
-          cptr += 2;
-        } else
-        if (cptr[0] == '\\'
-            && isdigit((unsigned char) cptr[1])
-            && isdigit((unsigned char) cptr[2])
-            && isdigit((unsigned char) cptr[3])
-            && cptr[4] == '\'') {
-          fwrite(cptr, 1, 5, f);
-          cptr += 5;
-        } else
-        if (cptr[0] == '\\' && cptr[2] == '\'') {
-          fwrite(cptr, 1, 3, f);
-          cptr += 3;
-        }
+        process_apostrophe_body(f);
         goto loop;
 
     case '(':
         putc(c, f);
         need_newline = 1;
-        c = *cptr;
-        if (c == '*')
-        {
-            int c_lineno = lineno;
-            char *c_line = dup_line();
-            char *c_cptr = c_line + (cptr - line - 1);
-
-            putc('*', f);
-            ++cptr;
-            for (;;)
-            {
-                c = *cptr++;
-                putc(c, f);
-                if (c == '*' && *cptr == ')')
-                {
-                    putc(')', f);
-                    ++cptr;
-                    FREE(c_line);
-                    goto loop;
-                }
-                if (c == '\n')
-                {
-                    get_line();
-                    if (line == 0)
-                        unterminated_comment(c_lineno, c_line, c_cptr);
-                }
-            }
-        }
-        need_newline = 1;
+        process_comment(f);
         goto loop;
 
     case '%':
@@ -494,134 +594,17 @@ loop:
         }
         /* fall through */
 
-    default:
-        putc(c, f);
-        need_newline = 1;
-        goto loop;
-    }
-}
-
-
-void copy_union(void)
-{
-    register int c;
-    int quote;
-    int depth;
-    int u_lineno = lineno;
-    char *u_line = dup_line();
-    char *u_cptr = u_line + (cptr - line - 6);
-
-    if (unionized) over_unionized(cptr - 6);
-    unionized = 1;
-
-    if (!lflag)
-        fprintf(text_file, line_format, lineno, input_file_name);
-
-    fprintf(text_file, "typedef union");
-    if (dflag) fprintf(union_file, "typedef union");
-
-    depth = 1;
-    cptr++;
-
-loop:
-    c = *cptr++;
-    putc(c, text_file);
-    if (dflag) putc(c, union_file);
-    switch (c)
-    {
-    case '\n':
-        get_line();
-        if (line == 0) unterminated_union(u_lineno, u_line, u_cptr);
-        goto loop;
-
     case '{':
-        ++depth;
-        goto loop;
-
-    case '}':
-        --depth;
-        if (c == '}' && depth == 0) {
-          fprintf(text_file, " YYSTYPE;\n");
-          FREE(u_line);
-          return;
-        }
-        goto loop;
-
-    case '\'':
-    case '"':
-        {
-            int s_lineno = lineno;
-            char *s_line = dup_line();
-            char *s_cptr = s_line + (cptr - line - 1);
-
-            quote = c;
-            for (;;)
-            {
-                c = *cptr++;
-                putc(c, text_file);
-                if (dflag) putc(c, union_file);
-                if (c == quote)
-                {
-                    FREE(s_line);
-                    goto loop;
-                }
-                if (c == '\n')
-                    unterminated_string(s_lineno, s_line, s_cptr);
-                if (c == '\\')
-                {
-                    c = *cptr++;
-                    putc(c, text_file);
-                    if (dflag) putc(c, union_file);
-                    if (c == '\n')
-                    {
-                        get_line();
-                        if (line == 0)
-                            unterminated_string(s_lineno, s_line, s_cptr);
-                    }
-                }
-            }
-        }
-
-    case '(':
-        c = *cptr;
-        if (c == '*')
-        {
-            int c_lineno = lineno;
-            char *c_line = dup_line();
-            char *c_cptr = c_line + (cptr - line - 1);
-
-            putc('*', text_file);
-            if (dflag) putc('*', union_file);
-            ++cptr;
-            for (;;)
-            {
-                c = *cptr++;
-                putc(c, text_file);
-                if (dflag) putc(c, union_file);
-                if (c == '*' && *cptr == ')')
-                {
-                    putc(')', text_file);
-                    if (dflag) putc(')', union_file);
-                    ++cptr;
-                    FREE(c_line);
-                    goto loop;
-                }
-                if (c == '\n')
-                {
-                    get_line();
-                    if (line == 0)
-                        unterminated_comment(c_lineno, c_line, c_cptr);
-                }
-            }
-        }
+        putc(c, f);
+        process_open_curly_bracket(f);
         goto loop;
-
     default:
+        putc(c, f);
+        need_newline = 1;
         goto loop;
     }
 }
 
-
 int
 hexval(int c)
 {
@@ -1005,18 +988,10 @@ void read_declarations(void)
         case MARK:
             return;
 
-        case IDENT:
-            copy_ident();
-            break;
-
         case TEXT:
             copy_text();
             break;
 
-        case UNION:
-            copy_union();
-            break;
-
         case TOKEN:
         case LEFT:
         case RIGHT:
@@ -1259,7 +1234,6 @@ void copy_action(void)
     register int c;
     register int i, n;
     int depth;
-    int quote;
     bucket *item;
     char *tagres;
     register FILE *f = action_file;
@@ -1267,6 +1241,7 @@ void copy_action(void)
     char *a_line = dup_line();
     char *a_cptr = a_line + (cptr - line);
 
+    push_stack('{');
     if (last_was_action) syntax_error (lineno, line, cptr);
     last_was_action = 1;
 
@@ -1321,18 +1296,19 @@ loop:
             goto loop;
         }
     }
-    if (isalpha(c) || c == '_' || c == '$')
+    if (c == '_' || c == '$' || In_bitmap(caml_ident_start, c))
     {
         do
         {
             putc(c, f);
             c = *++cptr;
-        } while (isalnum(c) || c == '_' || c == '$');
+        } while (c == '_' || c == '$' || In_bitmap(caml_ident_body, c));
         goto loop;
     }
     if (c == '}' && depth == 1) {
       fprintf(f, ")\n# 0\n              ");
       cptr++;
+      pop_stack('{');
       tagres = plhs[nrules]->tag;
       if (tagres)
         fprintf(f, " : %s))\n", tagres);
@@ -1355,93 +1331,33 @@ loop:
         unterminated_action(a_lineno, a_line, a_cptr);
 
     case '{':
+        process_open_curly_bracket(f);
+        /* Even if there is a raw string, we deliberately keep the
+         * closing '}' in the buffer */
+        push_stack('{');
         ++depth;
         goto loop;
 
     case '}':
         --depth;
+        pop_stack('{');
         goto loop;
 
     case '"':
-        {
-            int s_lineno = lineno;
-            char *s_line = dup_line();
-            char *s_cptr = s_line + (cptr - line - 1);
-
-            quote = c;
-            for (;;)
-            {
-                c = *cptr++;
-                putc(c, f);
-                if (c == quote)
-                {
-                    FREE(s_line);
-                    goto loop;
-                }
-                if (c == '\n')
-                    unterminated_string(s_lineno, s_line, s_cptr);
-                if (c == '\\')
-                {
-                    c = *cptr++;
-                    putc(c, f);
-                    if (c == '\n')
-                    {
-                        get_line();
-                        if (line == 0)
-                            unterminated_string(s_lineno, s_line, s_cptr);
-                    }
-                }
-            }
-        }
+        process_quoted_string('"', f);
+        goto loop;
 
     case '\'':
-        if (cptr[0] != 0 && cptr[0] != '\\' && cptr[1] == '\'') {
-          fwrite(cptr, 1, 2, f);
-          cptr += 2;
-        } else
-        if (cptr[0] == '\\'
-            && isdigit((unsigned char) cptr[1])
-            && isdigit((unsigned char) cptr[2])
-            && isdigit((unsigned char) cptr[3])
-            && cptr[4] == '\'') {
-          fwrite(cptr, 1, 5, f);
-          cptr += 5;
-        } else
-        if (cptr[0] == '\\' && cptr[2] == '\'') {
-          fwrite(cptr, 1, 3, f);
-          cptr += 3;
-        }
+        process_apostrophe_body(f);
         goto loop;
 
     case '(':
-        c = *cptr;
-        if (c == '*')
-        {
-            int c_lineno = lineno;
-            char *c_line = dup_line();
-            char *c_cptr = c_line + (cptr - line - 1);
+        push_stack('(');
+        process_comment(f);
+        goto loop;
 
-            putc('*', f);
-            ++cptr;
-            for (;;)
-            {
-                c = *cptr++;
-                putc(c, f);
-                if (c == '*' && *cptr == ')')
-                {
-                    putc(')', f);
-                    ++cptr;
-                    FREE(c_line);
-                    goto loop;
-                }
-                if (c == '\n')
-                {
-                    get_line();
-                    if (line == 0)
-                        unterminated_comment(c_lineno, c_line, c_cptr);
-                }
-            }
-        }
+    case ')':
+        pop_stack('(');
         goto loop;
 
     default:
@@ -1725,13 +1641,6 @@ void pack_symbols(void)
     FREE(v);
 }
 
-static unsigned char caml_ident_start[32] =
-"\000\000\000\000\000\000\000\000\376\377\377\207\376\377\377\007\000\000\000\000\000\000\000\000\377\377\177\377\377\377\177\377";
-static unsigned char caml_ident_body[32] =
-"\000\000\000\000\200\000\377\003\376\377\377\207\376\377\377\007\000\000\000\000\000\000\000\000\377\377\177\377\377\377\177\377";
-
-#define In_bitmap(bm,c) (bm[(unsigned char)(c) >> 3] & (1 << ((c) & 7)))
-
 static int is_polymorphic(char * s)
 {
   while (*s != 0) {